diff --git a/Agda.cabal b/Agda.cabal --- a/Agda.cabal +++ b/Agda.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Agda -version: 2.6.4.3 +version: 2.7.0 build-type: Custom license: MIT license-file: LICENSE @@ -35,8 +35,9 @@ packages. tested-with: - GHC == 9.8.1 - GHC == 9.6.4 + GHC == 9.10.1 + GHC == 9.8.2 + GHC == 9.6.6 GHC == 9.4.8 GHC == 9.2.8 GHC == 9.0.2 @@ -48,6 +49,7 @@ CHANGELOG.md README.md doc/user-manual/agda.svg + 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 @@ -90,14 +92,14 @@ doc/release-notes/2.2.0.md extra-source-files: - stack-9.8.1.yaml - stack-9.6.4.yaml + stack-9.10.1.yaml + stack-9.8.2.yaml + stack-9.6.6.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 - stack-8.6.5.yaml data-dir: src/data @@ -158,7 +160,7 @@ source-repository this type: git location: https://github.com/agda/agda.git - tag: v2.6.4.3 + tag: v2.7.0 -- Build flags --------------------------------------------------------------------------- @@ -201,10 +203,10 @@ custom-setup setup-depends: - , base >= 4.12.0.0 && < 4.20 - , Cabal >= 2.4.0.1 && < 3.11 + , base >= 4.12.0.0 && < 4.21 + , Cabal >= 2.4.0.1 && < 3.13 , directory >= 1.3.3.0 && < 1.4 - , filepath >= 1.4.2.1 && < 1.5 + , filepath >= 1.4.2.1 && < 1.6 , process >= 1.6.3.0 && < 1.7 -- Common stanzas @@ -243,7 +245,6 @@ -Wwarn=overflowed-literals -Wwarn=overlapping-patterns -- -Wwarn=redundant-constraints - -Wwarn=semigroup -Wwarn=simplifiable-class-constraints -Wwarn=star-binder -Wwarn=star-is-type @@ -268,6 +269,11 @@ -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.8) ghc-options: -Wwarn=missed-extra-shared-lib @@ -301,9 +307,13 @@ if impl(ghc >= 9.4) ghc-options: - -Wwarn=forall-identifier -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: @@ -326,6 +336,7 @@ FlexibleContexts FlexibleInstances FunctionalDependencies + GADTs GeneralizedNewtypeDeriving InstanceSigs LambdaCase @@ -342,6 +353,7 @@ TypeFamilies TypeOperators TypeSynonymInstances + ViewPatterns other-extensions: CPP @@ -402,7 +414,7 @@ , ansi-terminal >= 0.9 && < 1.2 , array >= 0.5.2.0 && < 0.6 , async >= 2.2 && < 2.3 - , base >= 4.12.0.0 && < 4.20 + , base >= 4.12.0.0 && < 4.21 , binary >= 0.8.6.0 && < 0.9 , blaze-html >= 0.8 && < 0.10 , boxes >= 0.1.3 && < 0.2 @@ -417,13 +429,13 @@ , equivalence >= 0.3.2 && < 0.5 -- exceptions-0.8 instead of 0.10 because of stack , exceptions >= 0.8 && < 0.11 - , filepath >= 1.4.2.1 && < 1.5 + , filepath >= 1.4.2.1 && < 1.6 , ghc-compact == 0.1.* , gitrev >= 1.3.1 && < 2 -- hashable 1.2.0.10 makes library-test 10x -- slower. The issue was fixed in hashable 1.2.1.0. -- https://github.com/tibbe/hashable/issues/57. - , hashable >= 1.2.1.0 && < 1.5 + , hashable >= 1.2.1.0 && < 1.6 , haskeline >= 0.7.4.3 && < 0.9 -- monad-control-1.0.1.0 is the first to contain liftThrough , monad-control >= 1.0.1.0 && < 1.1 @@ -431,6 +443,7 @@ , murmur-hash >= 0.1 && < 0.2 , parallel >= 3.2.2.0 && < 3.3 , peano >= 0.1.0.1 && < 0.2 + , pqueue >= 1.4.1.2 && < 1.6 , pretty >= 1.1.3.3 && < 1.2 , process >= 1.6.3.0 && < 1.7 , regex-tdfa >= 1.3.1.0 && < 1.4 @@ -439,9 +452,7 @@ , STMonadTrans >= 0.4.3 && < 0.5 , strict >= 0.4.0.1 && < 0.6 , text >= 1.2.3.1 && < 2.2 - , time >= 1.8.0.2 && < 1.13 - , time-compat >= 1.9.2 && < 1.10 - -- time-compat adds needed functionality missing in time < 1.9 + , time >= 1.9.2 && < 1.15 , transformers >= 0.5.5.0 && < 0.7 , unordered-containers >= 0.2.9.0 && < 0.3 -- unordered-containers < 0.2.9 need base < 4.11 @@ -459,16 +470,9 @@ -- happy-1.19.8 is packaged with Ubuntu 18.04 exposed-modules: - Agda.Auto.Auto - Agda.Auto.Options - Agda.Auto.CaseSplit - Agda.Auto.Convert - Agda.Auto.NarrowingSearch - Agda.Auto.SearchControl - Agda.Auto.Syntax - Agda.Auto.Typecheck Agda.Benchmarking Agda.Compiler.Backend + Agda.Compiler.Backend.Base Agda.Compiler.Builtin Agda.Compiler.CallCompiler Agda.Compiler.Common @@ -525,7 +529,9 @@ Agda.Interaction.Highlighting.LaTeX 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 @@ -536,6 +542,8 @@ Agda.Interaction.Options.Lenses Agda.Interaction.Options.Warnings Agda.Main + Agda.Mimer.Mimer + Agda.Mimer.Options Agda.Syntax.Abstract.Name Agda.Syntax.Abstract.Pattern Agda.Syntax.Abstract.PatternSynonyms @@ -545,8 +553,9 @@ Agda.Syntax.Abstract Agda.Syntax.Builtin Agda.Syntax.Common - Agda.Syntax.Common.Pretty 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 @@ -581,6 +590,7 @@ 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 @@ -631,6 +641,8 @@ 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 @@ -656,6 +668,7 @@ 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 @@ -736,6 +749,7 @@ 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 @@ -775,6 +789,7 @@ Agda.Utils.Hash Agda.Utils.HashTable Agda.Utils.Haskell.Syntax + Agda.Utils.IArray Agda.Utils.Impossible Agda.Utils.IndexedList Agda.Utils.IntSet.Infinite @@ -817,6 +832,7 @@ Agda.Utils.Tuple Agda.Utils.TypeLevel Agda.Utils.TypeLits + Agda.Utils.Unsafe Agda.Utils.Update Agda.Utils.VarSet Agda.Utils.Warshall @@ -830,6 +846,7 @@ other-modules: Paths_Agda + -- Need not export submodules if parent module reexports them. Agda.Interaction.Highlighting.Dot.Backend Agda.Interaction.Highlighting.Dot.Base Agda.Interaction.Highlighting.HTML.Backend @@ -840,7 +857,6 @@ Agda.Interaction.Options.HasOptions Agda.Utils.CallStack.Base Agda.Utils.CallStack.Pretty - Agda.Utils.Unsafe -- Agda binary --------------------------------------------------------------------------- @@ -877,8 +893,8 @@ autogen-modules: Paths_Agda other-modules: Paths_Agda build-depends: - , base >= 4.12.0.0 && < 4.20 + , base >= 4.12.0.0 && < 4.21 , directory >= 1.3.3.0 && < 1.4 - , filepath >= 1.4.2.1 && < 1.5 + , filepath >= 1.4.2.1 && < 1.6 , process >= 1.6.3.0 && < 1.7 default-language: Haskell2010 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,17 +1,442 @@ -Release notes for Agda version 2.6.4.3 -====================================== +Release notes for Agda version 2.7.0 +==================================== -This release fixes a regression in 2.6.4.3 and one in 2.6.4. -It aims to be API-compatible with 2.6.4.1 and 2.6.4.2. +Highlights +---------- -Agda 2.6.4.3 supports GHC versions 8.6.5 to 9.8.1. +* Mimer, a re-implementation of the "auto" term synthesizer, replaces Agsy. -Closed issues -------------- +* New syntax `using x ← e` to bind values on the left-hand-side of a function clause. -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) +* 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 #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 +- [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 #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 +- [Issue #7380](https://github.com/agda/agda/issues/7380): MAlonzo bug: `unreachable code reached` +- [Issue #7382](https://github.com/agda/agda/issues/7382): Agda 2.7.0-rc1 crashes when run twice, probably serialization issue +- [Issue #7401](https://github.com/agda/agda/issues/7401): Cabal 3.12.1.0 install failure for lib:Agda - dist/build/agda/agda does not exist + +These (relevant) pull requests were merged for 2.7.0: + +- [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 #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 +- [PR #7383](https://github.com/agda/agda/issues/7383): Fix #7382: make all module param sections live in DeadCode +- [PR #7386](https://github.com/agda/agda/issues/7386): Testcase for #7382 (completes PR #7383) +- [PR #7404](https://github.com/agda/agda/issues/7404): Fix #7401: do not fail hard in Setup.hs if library interface files cannot be built +- [PR #7410](https://github.com/agda/agda/issues/7410): Fixup #7404 and test agdai-generation in cabal-install workflow +- [PR #7419](https://github.com/agda/agda/issues/7419): #7380: add clauses to generalizedTel projections +- [PR #7423](https://github.com/agda/agda/issues/7423): Fixup #7265: restore passing arguments from goal to Mimer diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -6,21 +6,24 @@ Agda 2 is currently actively developed mainly by Andreas Abel, Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt, -Nils Anders Danielsson, Amélia Liao, Ulf Norell, and -Andrés Sicard-Ramírez. +Nils Anders Danielsson, Amélia Liao, and Ulf Norell. Further, Agda 2 has received contributions by, amongst others, Arthur Adjedj, Stevan Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, Guillaume Brunerie, -James Chapman, Jonathan Coates, +James Chapman, Lawrence Chonavel, Jonathan Coates, Dominique Devriese, Péter Diviánszky, Robert Estelle, -Olle Fredriksson, Adam Gundry, Daniel Gustafsson, Philipp Hausmann, +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, Wen Kokke, John Leo, Fredrik Lindblad, -Víctor López Juan, Ting-Gan Lua, Francesco Mazzoli, Stefan Monnier, -Guilhem Moulin, Konstantin Nisht, Fredrik Nordvall Forsberg, -Josselin Poiret, Nicolas Pouillard, Jonathan Prieto, Christian Sattler, -Makoto Takeyama, Andrea Vezzosi, Noam Zeilberger, and Tesla Ice Zhang. +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, Szumi Xie, 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``. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ [![Documentation Status](https://readthedocs.org/projects/agda/badge/?version=latest)](http://agda.readthedocs.io/en/latest/?badge=latest) [![Agda Zulip](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://agda.zulipchat.com) -![The official Agda logo](doc/user-manual/agda.svg) +![The official Agda logo](https://raw.githubusercontent.com/agda/agda/master/doc/user-manual/agda.svg) Note that this README is only about Agda, not its standard library. See the [Agda Wiki][agdawiki] for information about the diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE ScopedTypeVariables #-} import Data.List import Data.Maybe @@ -18,8 +18,8 @@ import System.IO import System.IO.Error (isDoesNotExistError) -import Control.Monad (forM_, unless) -import Control.Exception (bracket, catch, throwIO) +import Control.Monad +import Control.Exception main :: IO () main = defaultMainWithHooks userhooks @@ -44,9 +44,9 @@ copyHook simpleUserHooks pd lbi hooks flags unless (skipInterfaces lbi) $ do -- Generate .agdai files. - generateInterfaces pd lbi + success <- generateInterfaces pd lbi -- Copy again, now including the .agdai files. - copyHook simpleUserHooks pd' lbi hooks flags + when success $ copyHook simpleUserHooks pd' lbi hooks flags where pd' = pd { dataFiles = concatMap (expandAgdaExt pd) $ dataFiles pd @@ -89,7 +89,9 @@ skipInterfaces :: LocalBuildInfo -> Bool skipInterfaces lbi = fromPathTemplate (progSuffix lbi) == "-quicker" -generateInterfaces :: PackageDescription -> LocalBuildInfo -> IO () +-- | Returns 'True' if call to Agda executes without error. +-- +generateInterfaces :: PackageDescription -> LocalBuildInfo -> IO Bool generateInterfaces pd lbi = do -- for debugging, these are examples how you can inspect the flags... @@ -121,6 +123,13 @@ -- Type-check all builtin modules (in a single Agda session to take -- advantage of caching). + let agdaDirEnvVar = "Agda_datadir" + let agdaArgs = + [ "--interaction" + , "--interaction-exit-on-error" + , "-Werror" + , "-v0" + ] let loadBuiltinCmds = concat [ [ cmd ("Cmd_load " ++ f ++ " []") , cmd "Cmd_no_metas" @@ -130,21 +139,39 @@ , let f = show (ddir b) cmd c = "IOTCM " ++ f ++ " None Indirect (" ++ c ++ ")" ] + let callLines = concat + [ [ unwords $ concat + [ [ concat [ agdaDirEnvVar, "=", ddir ] ] + , [ agda ] + , agdaArgs + , [ "< "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 + (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" $ @@ -286,3 +293,11 @@ -- 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 ([], [])) diff --git a/src/data/emacs-mode/agda-input.el b/src/data/emacs-mode/agda-input.el --- a/src/data/emacs-mode/agda-input.el +++ b/src/data/emacs-mode/agda-input.el @@ -277,6 +277,8 @@ ("exn" . ("∄")) ("0" . ("∅")) ("C" . ("∁")) + ("uin" . ("⟒")) + ("din" . ("⫙")) ;; Corners, ceilings and floors. @@ -308,13 +310,15 @@ ("+ " . ("⊹")) ("+" . ("＋")) ("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. @@ -335,13 +339,19 @@ ;; Boxed operators. - ("b+" . ("⊞")) - ("b-" . ("⊟")) - ("bx" . ("⊠")) - ("b." . ("⊡")) + ("b+" . ("⊞")) + ("b-" . ("⊟")) + ("bx" . ("⊠")) + ("b." . ("⊡")) - ;; APL boxed operators + ("b/" . ("⧄")) + ("b\\" . ("⧅")) + ("b*" . ("⧆")) + ("bo" . ("⧇")) + ("bsq" . ("⧈")) + ;; APL boxed operators. + ("box=" . ("⌸")) ("box?" . ("⍰")) ("box'" . ("⍞")) @@ -376,6 +386,7 @@ ("integral" . ,(agda-input-to-string-list "∫∬∭∮∯∰∱∲∳")) ("angle" . ,(agda-input-to-string-list "∟∡∢⊾⊿")) ("join" . ,(agda-input-to-string-list "⋈⋉⋊⋋⋌⨝⟕⟖⟗")) + ("esh" . ("ʃ")) ;; Arrows. @@ -690,7 +701,7 @@ ("B8" . ("𝟖")) ("B9" . ("𝟗")) - ;; Fullwidth letters + ;; Fullwidth letters. ("FA" . ("Ａ")) ("FB" . ("Ｂ")) @@ -745,7 +756,7 @@ ("Fy" . ("ｙ")) ("Fz" . ("ｚ")) - ;; Fullwidth digits + ;; Fullwidth digits. ("F0" . ("０")) ("F1" . ("１")) @@ -758,6 +769,42 @@ ("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 "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢❪❬❰❲❴⟮⦅⦗⧼⸨❮⦇⦉")) @@ -805,9 +852,11 @@ ;; Musical symbols. - ("note" . ,(agda-input-to-string-list "♩♪♫♬")) - ("b" . ("♭")) - ("#" . ("♯")) + ("note" . ,(agda-input-to-string-list "♩♪♫♬")) + ("b" . ("♭")) + ("#" . ("♯")) + ("bb" . ("𝄫")) + ("##" . ("𝄪")) ;; Other punctuation and symbols. @@ -837,12 +886,13 @@ ("@" . ("＠")) ("__" . ("＿")) ("\"" . ("＂")) + ("crossmark" . ("✗")) ;; Some combining characters. ;; ;; The following combining characters also have (other) ;; translations: - ;; ̀ ́ ̂ ̃ ̄ ̆ ̇ ̈ ̋ ̌ ̣ ̧ ̱ + ;; ("^--" . ,(agda-input-to-string-list"̅̿")) ("_--" . ,(agda-input-to-string-list"̲̳")) @@ -888,7 +938,7 @@ ("Gp" . ("ψ")) ("GP" . ("Ψ")) ("Go" . ("ω")) ("GO" . ("Ω")) - ;; Mathematical characters + ;; Mathematical characters. ("MiA" . ("𝐴")) ("MiB" . ("𝐵")) @@ -942,6 +992,7 @@ ("Mix" . ("𝑥")) ("Miy" . ("𝑦")) ("Miz" . ("𝑧")) + ("MIA" . ("𝑨")) ("MIB" . ("𝑩")) ("MIC" . ("𝑪")) @@ -968,6 +1019,7 @@ ("MIX" . ("𝑿")) ("MIY" . ("𝒀")) ("MIZ" . ("𝒁")) + ("MIa" . ("𝒂")) ("MIb" . ("𝒃")) ("MIc" . ("𝒄")) @@ -994,6 +1046,7 @@ ("MIx" . ("𝒙")) ("MIy" . ("𝒚")) ("MIz" . ("𝒛")) + ("McA" . ("𝒜")) ("McB" . ("ℬ")) ("McC" . ("𝒞")) @@ -1046,6 +1099,7 @@ ("Mcx" . ("𝓍")) ("Mcy" . ("𝓎")) ("Mcz" . ("𝓏")) + ("MCA" . ("𝓐")) ("MCB" . ("𝓑")) ("MCC" . ("𝓒")) @@ -1098,6 +1152,7 @@ ("MCx" . ("𝔁")) ("MCy" . ("𝔂")) ("MCz" . ("𝔃")) + ("MfA" . ("𝔄")) ("MfB" . ("𝔅")) ("MfC" . ("ℭ")) @@ -1151,7 +1206,7 @@ ("Mfy" . ("𝔶")) ("Mfz" . ("𝔷")) - ;; (Sub / Super) scripts + ;; (Sub / Super) scripts. ;; ;; Unicode 12.1 omits several latin characters from sub/superscript. ;; https://www.quora.com/Why-is-there-no-character-for-superscript-q-in-Unicode @@ -1247,13 +1302,17 @@ ;; ("^Y" . ("Y")) ;; ("^Z" . ("Z")) + ("^Ga" . ("ᵅ")) ("^Gb" . ("ᵝ")) ("^Gg" . ("ᵞ")) ("^Gd" . ("ᵟ")) ("^Ge" . ("ᵋ")) ("^Gth" . ("ᶿ")) + ("^Gi" . ("ᶥ")) ("^Gf" . ("ᵠ")) ("^Gc" . ("ᵡ")) + + ("^GF" . ("ᶲ")) ;; Some ISO8859-1 characters. diff --git a/src/data/emacs-mode/agda2-mode-pkg.el b/src/data/emacs-mode/agda2-mode-pkg.el --- a/src/data/emacs-mode/agda2-mode-pkg.el +++ b/src/data/emacs-mode/agda2-mode-pkg.el @@ -1,3 +1,3 @@ -(define-package "agda2-mode" "2.6.4.3" +(define-package "agda2-mode" "2.7.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 diff --git a/src/data/emacs-mode/agda2-mode.el b/src/data/emacs-mode/agda2-mode.el --- a/src/data/emacs-mode/agda2-mode.el +++ b/src/data/emacs-mode/agda2-mode.el @@ -28,7 +28,7 @@ ;;; Code: -(defvar agda2-version "2.6.4.3" +(defvar agda2-version "2.7.0" "The version of the Agda mode. Note that the same version of the Agda executable must be used.") @@ -232,7 +232,7 @@ (agda2-give ,(kbd "C-c C-SPC") (local) "Give") (agda2-elaborate-give ,(kbd "C-c C-m") (local) "Elaborate and Give") (agda2-refine "\C-c\C-r" (local) "Refine") - (agda2-auto-maybe-all "\C-c\C-a" (local global) "Auto") + (agda2-mimer-maybe-all "\C-c\C-a" (local global) "Auto") (agda2-make-case "\C-c\C-c" (local) "Case") (agda2-goal-type "\C-c\C-t" (local) "Goal type") (agda2-show-context "\C-c\C-e" (local) "Context (environment)") @@ -886,16 +886,6 @@ (agda2-goal-cmd "Cmd_refine_or_intro True" 'save 'goal) (agda2-goal-cmd "Cmd_refine_or_intro False" 'save 'goal))) -(defun agda2-autoOne () - "Simple proof search" (interactive) - (agda2-goal-cmd "Cmd_autoOne" 'save 'goal)) - -(defun agda2-autoAll () - "Solves all goals by simple proof search." - (interactive) - (agda2-go nil nil 'busy t "Cmd_autoAll") -) - (defun agda2-make-case () "Refine the pattern variables given in the goal. Assumes that = {!!} is on one line." @@ -1379,13 +1369,26 @@ 'agda2-solveAll)) ) -(defun agda2-auto-maybe-all () - "Run auto. +(defun agda2-mimer-maybe-all () + "Run proof search. Either only one if point is a goal, or all of them." (interactive) (call-interactively (if (agda2-goal-at (point)) - 'agda2-autoOne - 'agda2-autoAll)) + 'agda2-mimer + 'agda2-mimerAll)) +) + +(agda2-maybe-normalised-asis + agda2-mimer + "Run proof search on a goal." + "Cmd_autoOne" + 'goal +) + +(agda2-maybe-normalised-toplevel-asis-noprompt + agda2-mimerAll + "Solves all goals by simple proof search." + "Cmd_autoAll" ) (agda2-maybe-normalised-toplevel-asis-noprompt diff --git a/src/data/html/Agda.css b/src/data/html/Agda.css --- a/src/data/html/Agda.css +++ b/src/data/html/Agda.css @@ -19,6 +19,7 @@ .Agda .Datatype { color: #0000CD } .Agda .Field { color: #EE1289 } .Agda .Function { color: #0000CD } +.Agda .Macro { color: #0000CD } .Agda .Module { color: #A020F0 } .Agda .Postulate { color: #0000CD } .Agda .Primitive { color: #0000CD } diff --git a/src/data/latex/agda.sty b/src/data/latex/agda.sty --- a/src/data/latex/agda.sty +++ b/src/data/latex/agda.sty @@ -6,7 +6,7 @@ % !!! NOTE: when you make changes to this file, bump the date. !!! % !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! \ProvidesPackage{agda} - [2021/07/14 version 2.6.4.3 Formatting LaTeX generated by Agda] + [2021/07/14 version 2.7.0 Formatting LaTeX generated by Agda] \RequirePackage{ifxetex, ifluatex, xifthen, xcolor, polytable, etoolbox, calc, environ, xparse, xkeyval} diff --git a/src/data/lib/prim/Agda/Builtin/Reflection.agda b/src/data/lib/prim/Agda/Builtin/Reflection.agda --- a/src/data/lib/prim/Agda/Builtin/Reflection.agda +++ b/src/data/lib/prim/Agda/Builtin/Reflection.agda @@ -247,7 +247,7 @@ function : (cs : List Clause) → Definition data-type : (pars : Nat) (cs : List Name) → Definition record-type : (c : Name) (fs : List (Arg Name)) → Definition - data-cons : (d : Name) → Definition + data-cons : (d : Name) (q : Quantity) → Definition axiom : Definition prim-fun : Definition @@ -296,7 +296,7 @@ declareDef : Arg Name → Type → TC ⊤ declarePostulate : Arg Name → Type → TC ⊤ declareData : Name → Nat → Type → TC ⊤ - defineData : Name → List (Σ Name (λ _ → Type)) → TC ⊤ + defineData : Name → List (Σ Name (λ _ → Σ Quantity (λ _ → Type))) → TC ⊤ defineFun : Name → List Clause → TC ⊤ getType : Name → TC Type getDefinition : Name → TC Definition @@ -334,6 +334,9 @@ -- "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'. @@ -343,6 +346,12 @@ -- 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 ⊤ + {-# BUILTIN AGDATCM TC #-} {-# BUILTIN AGDATCMRETURN returnTC #-} {-# BUILTIN AGDATCMBIND bindTC #-} @@ -383,8 +392,10 @@ {-# BUILTIN AGDATCMFORMATERRORPARTS formatErrorParts #-} {-# BUILTIN AGDATCMDEBUGPRINT debugPrint #-} {-# BUILTIN AGDATCMNOCONSTRAINTS noConstraints #-} +{-# BUILTIN AGDATCMWORKONTYPES workOnTypes #-} {-# BUILTIN AGDATCMRUNSPECULATIVE runSpeculative #-} {-# BUILTIN AGDATCMGETINSTANCES getInstances #-} +{-# BUILTIN AGDATCMSOLVEINSTANCES solveInstanceConstraints #-} -- All the TC primitives are compiled to functions that return -- undefined, rather than just undefined, in an attempt to make sure diff --git a/src/full/Agda/Auto/Auto.hs b/src/full/Agda/Auto/Auto.hs deleted file mode 100644 --- a/src/full/Agda/Auto/Auto.hs +++ /dev/null @@ -1,512 +0,0 @@ - -module Agda.Auto.Auto - (auto - , AutoResult(..) - , AutoProgress(..) - ) where - -import Prelude hiding ((!!), null) - -import Control.Monad ( filterM, forM, guard, join, when ) -import Control.Monad.Except -import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.State - -import qualified Data.List as List -import qualified Data.Map as Map -import Data.IORef -import qualified System.Timeout -import Data.Maybe -import qualified Data.Traversable as Trav -import qualified Data.HashMap.Strict as HMap - -import Agda.Utils.Permutation (permute, takeP) -import Agda.TypeChecking.Monad hiding (withCurrentModule) -import Agda.TypeChecking.Telescope -import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Abstract.Pretty (prettyA) -import qualified Agda.Syntax.Concrete.Name as C -import qualified Text.PrettyPrint.Annotated as PP -import qualified Agda.TypeChecking.Pretty as TCM -import Agda.Syntax.Position -import qualified Agda.Syntax.Internal as I -import Agda.Syntax.Translation.InternalToAbstract -import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcreteScope, abstractToConcrete_, runAbsToCon, toConcrete) -import Agda.Interaction.Base -import Agda.Interaction.BasicOps hiding (refine) -import Agda.TypeChecking.Reduce (normalise) -import Agda.Syntax.Common -import qualified Agda.Syntax.Scope.Base as Scope -import Agda.Syntax.Scope.Monad (withCurrentModule) -import qualified Agda.Syntax.Abstract.Name as AN -import qualified Agda.TypeChecking.Monad.Base as TCM -import Agda.TypeChecking.EtaContract (etaContract) - -import Agda.Auto.Options -import Agda.Auto.Convert -import Agda.Auto.NarrowingSearch -import Agda.Auto.Syntax -import Agda.Auto.SearchControl -import Agda.Auto.Typecheck - -import Agda.Auto.CaseSplit - -import Agda.Utils.Functor -import Agda.Utils.Impossible -import Agda.Utils.Lens -import Agda.Utils.List -import qualified Agda.Utils.List1 as List1 -import Agda.Utils.Maybe -import Agda.Utils.Null -import Agda.Syntax.Common.Pretty ( prettyShow ) -import Agda.Utils.Size -import Agda.Utils.Tuple - - -insertAbsurdPattern :: String -> String -insertAbsurdPattern [] = [] -insertAbsurdPattern s@(_:_) | take (length abspatvarname) s == abspatvarname = "()" ++ drop (length abspatvarname) s -insertAbsurdPattern (c:s) = c : insertAbsurdPattern s - -getHeadAsHint :: A.Expr -> Maybe Hint -getHeadAsHint (A.ScopedExpr _ e) = getHeadAsHint e -getHeadAsHint (A.Def qname) = Just $ Hint False qname -getHeadAsHint (A.Proj _ qname) = Just $ Hint False $ AN.headAmbQ qname -getHeadAsHint (A.Con qname) = Just $ Hint True $ AN.headAmbQ qname -getHeadAsHint _ = Nothing - --- | Result type: Progress & potential Message for the user --- --- The of the Auto tactic can be one of the following three: --- --- 1. @Solutions [(ii,s)]@ --- A list of solutions @s@ for interaction ids @ii@. --- In particular, @Solutions []@ means Agsy found no solution. --- --- 2. @FunClauses cs@ --- A list of clauses for the interaction id @ii@ in which Auto --- was invoked with case-splitting turned on. --- --- 3. @Refinement s@ --- A refinement for the interaction id @ii@ in which Auto was invoked. - -data AutoProgress = - Solutions [(InteractionId, String)] - | FunClauses [String] - | Refinement String - -data AutoResult = AutoResult - { autoProgress :: AutoProgress - , autoMessage :: Maybe String - } - -stopWithMsg :: String -> TCM AutoResult -stopWithMsg msg = return $ AutoResult (Solutions []) (Just msg) - --- | Entry point for Auto tactic (Agsy). --- --- If the @autoMessage@ part of the result is set to @Just msg@, the --- message @msg@ produced by Agsy should be displayed to the user. - -{-# SPECIALIZE auto :: InteractionId -> Range -> String -> TCM AutoResult #-} -auto - :: MonadTCM tcm - => InteractionId - -> Range - -> String - -> tcm AutoResult -auto ii rng argstr = liftTCM $ locallyTC eMakeCase (const True) $ do - - -- Parse hints and other configuration. - let autoOptions = parseArgs argstr - let hints = autoOptions ^. aoHints - let timeout = autoOptions ^. aoTimeOut - let pick = autoOptions ^. aoPick - let mode = autoOptions ^. aoMode - let hintmode = autoOptions ^. aoHintMode - ahints <- case mode of - MRefine{} -> return [] - _ -> mapM (parseExprIn ii rng) hints - let failHints = stopWithMsg "Hints must be a list of constant names" - - eqstuff <- getEqCombinators ii rng - - caseMaybe (mapM getHeadAsHint ahints) failHints $ \ ehints -> do - - -- Get the meta variable for the interaction point we are trying to fill. - -- Add the @autohints@ for that meta to the hints collection. - mi <- lookupInteractionId ii - thisdefinfo <- findClauseDeep ii - ehints <- (ehints ++) <$> do autohints hintmode mi $ fmap fst3 thisdefinfo - - -- If @thisdefinfo /= Nothing@ get the its type (normalized). - mrectyp <- maybeToList <$> do - Trav.forM thisdefinfo $ \ (def, _, _) -> do - normalise =<< do TCM.defType <$> getConstInfo def - - (myhints', mymrectyp, tccons, eqcons, cmap) <- tomy mi (ehints ++ eqstuff) mrectyp - - let (myhints, c1to6) = splitAt (length myhints' - length eqstuff) myhints' - meqr = ifNull eqstuff Nothing $ \ _ -> {- else -} - let [c1, c2, c3, c4, c5, c6] = c1to6 - in Just $ EqReasoningConsts c1 c2 c3 c4 c5 c6 - - - let tcSearchSC isdep ctx typ trm = caseMaybe meqr a $ \ eqr -> - mpret $ Sidecondition (calcEqRState eqr trm) a - where a = tcSearch isdep ctx typ trm - - let (mainm, _, _, _) = tccons Map.! mi - case mode of - MNormal listmode disprove -> do - let numsols = if listmode then 10 else 1 - -- Andreas, 2015-05-17 Issue 1504: - -- wish to produce several solutions, as - -- the first one might be ill-typed. - -- However, currently changing the 1 to something higher makes Agsy loop. - sols <- liftIO $ newIORef ([] :: [[I.Term]]) - nsol <- liftIO $ newIORef $ pick + numsols - let hsol = do - nsol' <- readIORef nsol - let cond = nsol' <= numsols - when cond $ do - trms <- runExceptT - $ mapM (\ (m , _, _, _) -> convert (Meta m) :: MOT I.Term) - $ Map.elems tccons - case trms of - Left{} -> writeIORef nsol $! nsol' + 1 - Right trms -> modifyIORef sols (trms :) - -- Right trms -> if listmode then modifyIORef sols (trms :) - -- else writeIORef sols [trms] - ticks <- liftIO $ newIORef 0 - - let exsearch initprop recinfo defdfv = - liftIO $ System.Timeout.timeout (getTimeOut timeout * 1000) - $ loop 0 - where - loop d = do - let rechint x = case recinfo of - Nothing -> x - Just (_, recdef) -> (recdef, HMRecCall) : x - env = RIEnv { rieHints = rechint $ map (,HMNormal) myhints - , rieDefFreeVars = defdfv - , rieEqReasoningConsts = meqr - } - depreached <- topSearch ticks nsol hsol env (initprop) d costIncrease - nsol' <- readIORef nsol - if nsol' /= 0 && depreached then loop (d + costIncrease) else return depreached - - let getsols :: [I.Term] -> TCM [(MetaId, A.Expr)] - getsols sol = do - exprs <- forM (zip (Map.keys tccons) sol) $ \ (mi, e) -> do - mv <- lookupLocalMetaAuto mi - e <- etaContract e - expr <- modifyAbstractExpr <$> do withMetaInfo (getMetaInfo mv) $ reify e - return (mi, expr) - - let loop :: I.MetaId -> StateT [I.MetaId] TCM [(I.MetaId, A.Expr)] - loop midx = do - let (m, _, _, deps) = tccons Map.! midx - asolss <- mapM loop deps - dones <- get - asols <- if midx `elem` dones then return [] else do - put (midx : dones) - return [(midx, fromMaybe __IMPOSSIBLE__ $ lookup midx exprs)] - return $ concat asolss ++ asols - (asols, _) <- runStateT (loop mi) [] - return asols - - if disprove then - case eqcons of - [] -> case Map.elems tccons of - (m, mytype, mylocalVars, _) : [] -> do - defdfv <- case thisdefinfo of - Just (def, _, _) -> getdfv mi def - Nothing -> return 0 - ee <- liftIO $ newIORef $ ConstDef {cdname = "T", cdorigin = __IMPOSSIBLE__, cdtype = NotM $ Sort (Set 0), cdcont = Postulate, cddeffreevars = 0} - let (restargs, modargs) = splitAt (length mylocalVars - defdfv) mylocalVars - mytype' = foldl (\x y -> NotM $ Pi Nothing NotHidden (freeIn 0 y) y (Abs NoId x)) mytype restargs - htyp = negtype ee mytype' - sctx = (Id "h", closify htyp) : map (\x -> (NoId, closify x)) modargs - ntt = closify (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil)) - res <- exsearch (tcSearchSC False sctx ntt (Meta m)) Nothing defdfv - rsols <- fmap reverse $ liftIO $ readIORef sols - if null rsols then do - nsol' <- liftIO $ readIORef nsol - stopWithMsg $ insuffsols (pick + numsols - nsol') - else do - aexprss <- mapM getsols rsols - cexprss <- forM aexprss $ mapM $ \(mi, e) -> do - mv <- lookupLocalMetaAuto mi - withMetaInfo (getMetaInfo mv) $ do - (mi,) <$> abstractToConcrete_ e - let ss = dropWhile (== ' ') . dropWhile (/= ' ') . prettyShow - disp [(_, cexpr)] = ss cexpr - disp cexprs = concatMap (\ (mi, cexpr) -> ss cexpr ++ " ") cexprs - ticks <- liftIO $ readIORef ticks - stopWithMsg $ unlines $ - ("Listing disproof(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1)) : - for (zip cexprss [pick..]) (\ (x, y) -> show y ++ " " ++ disp x) - _ -> stopWithMsg "Metavariable dependencies not allowed in disprove mode" - _ -> stopWithMsg "Metavariable dependencies not allowed in disprove mode" - else do - (recinfo, defdfv) <- - case thisdefinfo of - Just (def, clause, _) -> do - let [rectyp'] = mymrectyp - defdfv <- getdfv mi def - myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv} - (_, pats) <- constructPats cmap mi clause - defdfv <- getdfv mi def - return $ if contains_constructor pats then - (Just (pats, myrecdef), defdfv) - else - (Nothing, defdfv) - Nothing -> return (Nothing, 0) - let tc (m, mytype, mylocalVars) isdep = tcSearchSC isdep (map (\x -> (NoId, closify x)) mylocalVars) (closify mytype) (Meta m) - initprop = - foldl (\x (ineq, e, i) -> mpret $ And Nothing x (comp' ineq (closify e) (closify i))) - (foldl (\x (m, mt, mlv, _) -> - if hequalMetavar m mainm then - case recinfo of - Just (recpats, recdef) -> - mpret $ Sidecondition (localTerminationSidecond (localTerminationEnv recpats) recdef (Meta m)) - (tc (m, mt, mlv) False) - Nothing -> mpret $ And Nothing x (tc (m, mt, mlv) False) - else - mpret $ And Nothing x (tc (m, mt, mlv) True) - ) - (mpret OK) - (Map.elems tccons) - ) eqcons - res <- exsearch initprop recinfo defdfv - riis <- map swap <$> getInteractionIdsAndMetas - let timeoutString | isNothing res = " after timeout (" ++ show timeout ++ "ms)" - | otherwise = "" - if listmode then do - rsols <- fmap reverse $ liftIO $ readIORef sols - if null rsols then do - nsol' <- liftIO $ readIORef nsol - stopWithMsg $ insuffsols (pick + numsols - nsol') ++ timeoutString - else do - aexprss <- mapM getsols rsols - -- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss - cexprss <- forM aexprss $ do - mapM $ \ (mi, e) -> do - mv <- lookupLocalMetaAuto mi - withMetaInfo (getMetaInfo mv) $ do - e' <- abstractToConcrete_ e - return (mi, e') - let disp [(_, cexpr)] = prettyShow cexpr - disp cexprs = concat $ for cexprs $ \ (mi, cexpr) -> - maybe (show mi) show (lookup mi riis) - ++ " := " ++ prettyShow cexpr ++ " " - ticks <- liftIO $ readIORef ticks - stopWithMsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++ - "\n" ++ unlines (zipWith (\x y -> show y ++ " " ++ disp x) cexprss [pick..]) - else {- not listmode -} - case res of - Nothing -> do - nsol' <- liftIO $ readIORef nsol - stopWithMsg $ insuffsols (pick + numsols - nsol') ++ timeoutString - Just depthreached -> do - ticks <- liftIO $ readIORef ticks - rsols <- liftIO $ readIORef sols - case rsols of - [] -> do - nsol' <- liftIO $ readIORef nsol - stopWithMsg $ insuffsols (pick + numsols - nsol') - terms -> loop terms where - -- Andreas, 2015-05-17 Issue 1504 - -- If giving a solution failed (e.g. ill-typed) - -- we could try the next one. - -- However, currently @terms@ is always a singleton list. - -- Thus, the following @loop@ is not doing something very - -- meaningful. - loop :: [[I.Term]] -> TCM AutoResult - loop [] = return $ AutoResult (Solutions []) (Just "") - loop (term : terms') = do - -- On exception, try next solution - flip catchError (\ e -> do reportSDoc "auto" 40 $ "Solution failed:" TCM. TCM.prettyTCM e - loop terms') $ do - exprs <- getsols term - reportSDoc "auto" 20 $ "Trying solution " TCM.<+> TCM.prettyTCM exprs - giveress <- forM exprs $ \ (mi, expr0) -> do - let expr = killRange expr0 - case lookup mi riis of - Nothing -> - -- catchError - (giveExpr WithoutForce Nothing mi expr >> return (Nothing, Nothing)) - -- (const retry) - -- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi))) - Just ii' -> do ae <- give WithoutForce ii' Nothing expr - mv <- lookupLocalMetaAuto mi - let scope = getMetaScope mv - ce <- abstractToConcreteScope scope ae - let cmnt = if ii' == ii then agsyinfo ticks else "" - return (Just (ii', prettyShow ce ++ cmnt), Nothing) - -- Andreas, 2015-05-17, Issue 1504 - -- When Agsy produces an ill-typed solution, return nothing. - -- TODO: try other solution. - -- `catchError` const retry -- (return (Nothing, Nothing)) - let msg = if natSize exprs == 1 then - Nothing - else - Just $ "Also gave solution(s) for hole(s)" ++ - concatMap (\(mi', _) -> - if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii}) - ) exprs - let msgs = catMaybes $ msg : map snd giveress - msg' = unlines msgs <$ guard (not $ null msgs) - return $ AutoResult (Solutions $ mapMaybe fst giveress) msg' - - MCaseSplit -> do - case thisdefinfo of - Just (def, clause, True) -> - case Map.elems tccons of - [(m, mytype, mylocalVars, _)] | null eqcons -> do - (ids, pats) <- constructPats cmap mi clause - let ctx = zipWith (\(hid, id) t -> HI hid (id, t)) ids mylocalVars - ticks <- liftIO $ newIORef 0 - let [rectyp'] = mymrectyp - defdfv <- getdfv mi def - myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv} - sols <- liftIO $ System.Timeout.timeout (getTimeOut timeout * 1000) ( - let r d = do - sols <- liftIO $ caseSplitSearch ticks __IMPOSSIBLE__ myhints meqr __IMPOSSIBLE__ d myrecdef ctx mytype pats - case sols of - [] -> r (d + costIncrease) - (_:_) -> return sols - in r 0) - case sols of - Just (cls : _) -> withInteractionId ii $ do - cls' <- liftIO $ runExceptT (mapM frommyClause cls) - case cls' of - Left{} -> stopWithMsg "No solution found" - Right cls' -> do - cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall exact recursive reachable ell wm) -> do - withCurrentModule (AN.qnameModule def) $ do - -- Normalise the dot patterns - ps <- addContext tel $ normalise ps - body <- etaContract body - fmap modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange noRange tel ps body t catchall exact recursive reachable ell wm - moduleTel <- lookupSection (AN.qnameModule def) - pcs <- withInteractionId ii $ inTopContext $ addContext moduleTel $ mapM prettyA cls'' - ticks <- liftIO $ readIORef ticks - - - return $ AutoResult (FunClauses $ map (insertAbsurdPattern . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode })) pcs) Nothing - - Just [] -> stopWithMsg "No solution found" -- case not possible at the moment because case split doesnt care about search exhaustiveness - Nothing -> stopWithMsg $ "No solution found at time out (" ++ show timeout ++ "s)" - _ -> stopWithMsg "Metavariable dependencies not allowed in case split mode" - _ -> stopWithMsg "Metavariable is not at top level of clause RHS" - - MRefine listmode -> do - mv <- lookupLocalMetaAuto mi - let tt = jMetaType $ mvJudgement mv - minfo = getMetaInfo mv - targettyp <- withMetaInfo minfo $ do - vs <- getContextArgs - targettype <- tt `piApplyM` permute (takeP (length vs) $ mvPermutation mv) vs - normalise targettype - let tctx = length $ envContext $ clEnv minfo - - hits <- if "-a" `elem` hints then do - st <- liftTCM $ join $ pureTCM $ \st _ -> return st - let defs = st ^. stSignature . sigDefinitions - idefs = st ^. stImports . sigDefinitions - alldefs = HMap.keys defs ++ HMap.keys idefs - catMaybes <$> mapM (\n -> - case thisdefinfo of - Just (def, _, _) | def == n -> return Nothing - _ -> do - cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n - if C.isInScope cn == C.NotInScope then - return Nothing - else getConstInfo' n >>= \case - Left{} -> return Nothing - Right c -> do - ctyp <- normalise $ defType c - cdfv <- withMetaInfo minfo $ getDefFreeVars n - return $ case matchType cdfv tctx ctyp targettyp of - Nothing -> Nothing - Just score -> Just (prettyShow cn, score) - ) alldefs - else do - let scopeinfo = clScope (getMetaInfo mv) - namespace = Scope.everythingInScope scopeinfo - names = Scope.nsNames namespace - qnames = map (\(x, y) -> (x, Scope.anameName $ List1.head y)) $ Map.toList names - modnames = case thisdefinfo of - Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames - Nothing -> qnames - catMaybes <$> mapM (\(cn, n) -> getConstInfo' n >>= \case - Left{} -> return Nothing - Right c -> do - ctyp <- normalise $ defType c - cdfv <- withMetaInfo minfo $ getDefFreeVars n - return $ case matchType cdfv tctx ctyp targettyp of - Nothing -> Nothing - Just score -> Just (prettyShow cn, score) - ) modnames - - let sorthits = List.sortBy (\(_, (pa1, pb1)) (_, (pa2, pb2)) -> case compare pa2 pa1 of {EQ -> compare pb1 pb2; o -> o}) hits - if listmode || pick == (-1) then - let pick' = max 0 pick - in if pick' >= length sorthits then - stopWithMsg $ insuffcands $ length sorthits - else - let showhits = take 10 $ drop pick' sorthits - in stopWithMsg $ "Listing candidate(s) " ++ show pick' ++ "-" ++ show (pick' + length showhits - 1) ++ " (found " ++ show (length sorthits) ++ " in total)\n" ++ - unlines (zipWith (\i (cn, _) -> show i ++ " " ++ cn) [pick'..pick' + length showhits - 1] showhits) - else - if pick >= length sorthits then - stopWithMsg $ insuffcands $ length sorthits - else - return $ AutoResult (Refinement $ fst $ sorthits !! pick) Nothing - where - agsyinfo ticks = "" - --- Get the functions and axioms defined in the same module as @def@. -autohints :: AutoHintMode -> I.MetaId -> Maybe AN.QName -> TCM [Hint] -autohints AHMModule mi (Just def) = do - scope <- clScope . getMetaInfo <$> lookupLocalMetaAuto mi - let names = Scope.nsNames $ Scope.everythingInScope scope - qnames = map (Scope.anameName . List1.head) $ Map.elems names - modnames = filter (\n -> AN.qnameModule n == AN.qnameModule def && n /= def) qnames - map (Hint False) <$> do - (`filterM` modnames) $ \ n -> getConstInfo' n >>= \case - Left{} -> return False - Right c -> case theDef c of - Axiom{} -> return True - AbstractDefn{} -> return True - Function{} -> return True - _ -> return False - -autohints _ _ _ = return [] - - - --- | Names for the equality reasoning combinators --- Empty if any of these names is not defined. - -getEqCombinators :: InteractionId -> Range -> TCM [Hint] -getEqCombinators ii rng = do - let eqCombinators = ["_≡_", "begin_", "_≡⟨_⟩_", "_∎", "sym", "cong"] - raw <- mapM (parseExprIn ii rng) eqCombinators `catchError` const (pure []) - return $ fromMaybe [] $ mapM getHeadAsHint raw - --- | Templates for error messages - -genericNotEnough :: String -> Int -> String -genericNotEnough str n = unwords $ case n of - 0 -> ["No", str, "found"] - 1 -> ["Only 1", str, "found"] - _ -> ["Only", show n, str ++ "s", "found"] - -insuffsols :: Int -> String -insuffsols = genericNotEnough "solution" - -insuffcands :: Int -> String -insuffcands = genericNotEnough "candidate" diff --git a/src/full/Agda/Auto/CaseSplit.hs b/src/full/Agda/Auto/CaseSplit.hs deleted file mode 100644 --- a/src/full/Agda/Auto/CaseSplit.hs +++ /dev/null @@ -1,668 +0,0 @@ - -module Agda.Auto.CaseSplit where - -import Prelude hiding ((!!)) - -import Control.Monad.State as St hiding (lift) -import Control.Monad.Reader as Rd hiding (lift) -import qualified Control.Monad.State as St -import Control.Monad.IO.Class ( MonadIO(..) ) - -import Data.Function (on) -import Data.IORef -import Data.Tuple (swap) -import Data.List (elemIndex) --- Import of <> needed for 8.2.2, but redundant in 8.8.3 -import Data.Monoid ((<>), Sum(..)) -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap - -import Agda.Syntax.Common (Hiding(..)) -import Agda.Auto.NarrowingSearch -import Agda.Auto.Syntax - -import Agda.Auto.SearchControl -import Agda.Auto.Typecheck - -import Agda.Utils.Impossible -import Agda.Utils.Monad (or2M) -import Agda.Utils.List ((!!), last1) - -abspatvarname :: String -abspatvarname = "\0absurdPattern" - -costCaseSplitVeryHigh, costCaseSplitHigh, costCaseSplitLow, costAddVarDepth - :: Cost -costCaseSplitVeryHigh = 10000 -costCaseSplitHigh = 5000 -costCaseSplitLow = 2000 -costAddVarDepth = 1000 - -data HI a = HI Hiding a - -drophid :: [HI a] -> [a] -drophid = map (\(HI _ x) -> x) - -type CSPat o = HI (CSPatI o) -type CSCtx o = [HI (MId, MExp o)] - -data CSPatI o = CSPatConApp (ConstRef o) [CSPat o] - | CSPatProj (ConstRef o) - | CSPatVar Nat - | CSPatExp (MExp o) - | CSWith (MExp o) -- always an App - | CSAbsurd - - | CSOmittedArg -type Sol o = [(CSCtx o, [CSPat o], Maybe (MExp o))] - -caseSplitSearch :: - forall o . IORef Int -> Int -> [ConstRef o] -> - Maybe (EqReasoningConsts o) -> Int -> Cost -> ConstRef o -> - CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o] -caseSplitSearch ticks nsolwanted chints meqr depthinterval depth recdef ctx tt pats = do - let branchsearch :: Cost -> CSCtx o -> MExp o -> - ([Nat], Nat, [Nat]) -> IO (Maybe (MExp o)) - branchsearch depth ctx tt termcheckenv = do - - nsol <- newIORef 1 - m <- initMeta - sol <- newIORef Nothing - let trm = Meta m - hsol = do trm' <- expandMetas trm - writeIORef sol (Just trm') - initcon = mpret - $ Sidecondition - (localTerminationSidecond termcheckenv recdef trm) - $ (case meqr of - Nothing -> id - Just eqr -> mpret . Sidecondition (calcEqRState eqr trm) - ) $ tcSearch False (map (fmap closify) (drophid ctx)) - (closify tt) trm - recdefd <- readIORef recdef - let env = RIEnv { rieHints = (recdef, HMRecCall) : map (, HMNormal) chints - , rieDefFreeVars = cddeffreevars recdefd - , rieEqReasoningConsts = meqr - } - depreached <- topSearch ticks nsol hsol env initcon depth (depth + 1) - readIORef sol - ctx' = ff 1 ctx - ff _ [] = [] - ff n (HI hid (id, t) : ctx) = HI hid (id, lift n t) : ff (n + 1) ctx - caseSplitSearch' branchsearch depthinterval depth recdef ctx' tt pats - -caseSplitSearch' :: forall o . - (Cost -> CSCtx o -> MExp o -> ([Nat], Nat, [Nat]) -> IO (Maybe (MExp o))) -> - Int -> Cost -> ConstRef o -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o] -caseSplitSearch' branchsearch depthinterval depth recdef ctx tt pats = do - recdefd <- readIORef recdef - rc depth (cddeffreevars recdefd) ctx tt pats - where - rc :: Cost -> Int -> CSCtx o -> MExp o -> [CSPat o] -> IO [Sol o] - rc depth _ _ _ _ | depth < 0 = return [] - rc depth nscrutavoid ctx tt pats = do - - mblkvar <- getblks tt - fork - mblkvar - where - fork :: [Nat] -> IO [Sol o] - fork mblkvar = do - sols1 <- dobody - case sols1 of - (_:_) -> return sols1 - [] -> do - let r :: [Nat] -> IO [Sol o] - r [] = return [] - r (v:vs) = do - sols2 <- splitvar mblkvar v - case sols2 of - (_:_) -> return sols2 - [] -> r vs - r [nv - x | x <- [0..nv]] -- [0..length ctx - 1 - nscrutavoid] - where nv = length ctx - 1 - dobody :: IO [Sol o] - dobody = do - case findperm (map snd (drophid ctx)) of - Just perm -> do - let (ctx', tt', pats') = applyperm perm ctx tt pats - res <- branchsearch depth ctx' tt' (localTerminationEnv pats') - return $ case res of - Just trm -> [[(ctx', pats', Just trm)]] - Nothing -> [] - Nothing -> __IMPOSSIBLE__ -- no permutation found - splitvar :: [Nat] -> Nat -> IO [Sol o] - splitvar mblkvar scrut = do - let scruttype = infertypevar ctx scrut - case rm __IMPOSSIBLE__ scruttype of - App _ _ (Const c) _ -> do - cd <- readIORef c - case cdcont cd of - Datatype cons _ -> do - sols <- dobranches cons - return $ map (\sol -> case sol of - [] -> - case findperm (map snd (drophid ctx)) of - Just perm -> - let HI scrhid(_, scrt) = ctx !! scrut - ctx1 = take scrut ctx ++ (HI scrhid (Id abspatvarname, scrt)) : drop (scrut + 1) ctx - (ctx', _, pats') = applyperm perm ctx1 tt ({-map (replacep scrut 1 CSAbsurd __IMPOSSIBLE__) -}pats) - in [(ctx', pats', Nothing)] - Nothing -> __IMPOSSIBLE__ -- no permutation found - _ -> sol - ) sols - where - dobranches :: [ConstRef o] -> IO [Sol o] - dobranches [] = return [[]] - dobranches (con : cons) = do - cond <- readIORef con - let ff t = case rm __IMPOSSIBLE__ t of - Pi _ h _ it (Abs id ot) -> - let (xs, inft) = ff ot - in (((h, scrut + length xs), id, lift (scrut + length xs + 1) it) : xs, inft) - _ -> ([], lift scrut t) - (newvars, inftype) = ff (cdtype cond) - constrapp = NotM $ App Nothing (NotM OKVal) (Const con) (foldl (\xs ((h, v), _, _) -> NotM $ ALCons h (NotM $ App Nothing (NotM OKVal) (Var v) (NotM ALNil)) xs) (NotM ALNil) (reverse newvars)) - pconstrapp = CSPatConApp con (map (\((hid, v), _, _) -> HI hid (CSPatVar v)) newvars) - thesub = replace scrut (length newvars) constrapp - Id newvarprefix = fst $ (drophid ctx) !! scrut - ctx1 = map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (take scrut ctx) ++ - reverse (zipWith (\((hid, _), id, t) i -> - HI hid (Id (case id of {NoId -> newvarprefix{- ++ show i-}; Id id -> id}), t) - ) newvars [0..]) ++ - map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (drop (scrut + 1) ctx) - tt' = thesub tt - pats' = map (replacep scrut (length newvars) pconstrapp constrapp) pats - scruttype' = thesub scruttype -- scruttype shouldn't really refer to scrutvar so lift is enough, but what if circular ref has been created and this is not detected until case split is done - case unifyexp inftype scruttype' of - Nothing -> do - res <- notequal scrut (length newvars) scruttype' inftype - if res then -- branch absurd - dobranches cons - else -- branch dont know - return [] - Just unif -> - do - let (ctx2, tt2, pats2) = removevar ctx1 tt' pats' unif - --cost = if elem scrut mblkvar then costCaseSplit - (costCaseSplit - costCaseSplitFollow) `div` (length mblkvar) else costCaseSplit - cost - | null mblkvar && scrut < length ctx - nscrutavoid && nothid - = costCaseSplitLow + - costAddVarDepth * - Cost (depthofvar scrut pats) - | null mblkvar = costCaseSplitVeryHigh - | scrut `elem` mblkvar = costCaseSplitLow - | scrut < length ctx - nscrutavoid && nothid = costCaseSplitHigh - | otherwise = costCaseSplitVeryHigh - - nothid = let HI hid _ = ctx !! scrut - in hid == NotHidden - - - sols <- rc (depth - cost) (length ctx - 1 - scrut) ctx2 tt2 pats2 - case sols of - [] -> return [] - _ -> do - sols2 <- dobranches cons - return $ concatMap (\sol -> map (\sol2 -> sol ++ sol2) sols2) sols - _ -> return [] -- split failed "scrut type is not datatype" - _ -> return [] -- split failed "scrut type is not datatype" - -infertypevar :: CSCtx o -> Nat -> MExp o -infertypevar ctx v = snd $ (drophid ctx) !! v - -class Replace t u where - type ReplaceWith t u - replace' :: Nat -> MExp (ReplaceWith t u) -> t -> Reader (Nat, Nat) u - -replace :: Replace t u => Nat -> Nat -> MExp (ReplaceWith t u) -> t -> u -replace sv nnew e t = replace' 0 e t `runReader` (sv, nnew) - -instance Replace t u => Replace (Abs t) (Abs u) where - type ReplaceWith (Abs t) (Abs u) = ReplaceWith t u - replace' n re (Abs mid b) = Abs mid <$> replace' (n + 1) re b - -instance Replace (Exp o) (MExp o) where - type ReplaceWith (Exp o) (MExp o) = o - replace' n re = \case - App uid ok elr@(Var v) args -> do - ih <- NotM <$> replace' n re args - (sv, nnew) <- ask - return $ - if v >= n - then if v - n == sv - then betareduce (lift n re) ih - else if v - n > sv - then NotM $ App uid ok (Var (v + nnew - 1)) ih - else NotM $ App uid ok elr ih - else NotM $ App uid ok elr ih - App uid ok elr@Const{} args -> - NotM . App uid ok elr . NotM <$> replace' n re args - Lam hid b -> NotM . Lam hid <$> replace' (n + 1) re b - Pi uid hid possdep it b -> - fmap NotM $ Pi uid hid possdep <$> replace' n re it <*> replace' n re b - e@Sort{} -> return $ NotM e - e@AbsurdLambda{} -> return $ NotM e - -instance Replace t u => Replace (MM t (RefInfo o)) u where - type ReplaceWith (MM t (RefInfo o)) u = ReplaceWith t u - replace' n re = replace' n re . rm __IMPOSSIBLE__ - -instance Replace (ArgList o) (ArgList o) where - type ReplaceWith (ArgList o) (ArgList o) = o - replace' n re args = case args of - ALNil -> return ALNil - ALCons hid a as -> - ALCons hid <$> replace' n re a <*> (NotM <$> replace' n re as) - ALProj{} -> __IMPOSSIBLE__ - ALConPar as -> ALConPar . NotM <$> replace' n re as - - -betareduce :: MExp o -> MArgList o -> MExp o -betareduce e args = case rm __IMPOSSIBLE__ args of - ALNil -> e - ALCons _ a rargs -> case rm __IMPOSSIBLE__ e of - App uid ok elr eargs -> NotM $ App uid ok elr (concatargs eargs args) - Lam _ (Abs _ b) -> betareduce (replace 0 0 a b) rargs - _ -> __IMPOSSIBLE__ -- not type correct if this happens - ALProj{} -> __IMPOSSIBLE__ - ALConPar as -> __IMPOSSIBLE__ - -concatargs :: MArgList o -> MArgList o -> MArgList o -concatargs xs ys = case rm __IMPOSSIBLE__ xs of - ALNil -> ys - - ALCons hid x xs -> NotM $ ALCons hid x (concatargs xs ys) - - ALProj{} -> __IMPOSSIBLE__ - - ALConPar as -> NotM $ ALConPar (concatargs xs ys) - -replacep :: forall o. Nat -> Nat -> CSPatI o -> MExp o -> CSPat o -> CSPat o -replacep sv nnew rp re = r - where - r :: CSPat o -> CSPat o - r (HI hid (CSPatConApp c ps)) = HI hid (CSPatConApp c (map r ps)) - r (HI hid (CSPatVar v)) | v == sv = HI hid rp - | v > sv = HI hid (CSPatVar (v + nnew - 1)) - | otherwise = HI hid (CSPatVar v) - r (HI hid (CSPatExp e)) = HI hid (CSPatExp $ replace sv nnew re e) - - r p@(HI _ CSOmittedArg) = p - - r _ = __IMPOSSIBLE__ -- other constructors dont appear in indata Pats - - - --- Unification takes two values of the same type and generates a list --- of assignments making the two terms equal. - -type Assignments o = [(Nat, Exp o)] - -class Unify t where - type UnifiesTo t - unify' :: t -> t -> StateT (Assignments (UnifiesTo t)) Maybe () - notequal' :: t -> t -> ReaderT (Nat, Nat) (StateT (Assignments (UnifiesTo t)) IO) Bool - -unify :: Unify t => t -> t -> Maybe (Assignments (UnifiesTo t)) -unify t u = unify' t u `execStateT` [] - -notequal :: Unify t => Nat -> Nat -> t -> t -> IO Bool -notequal fstnew nbnew t1 t2 = notequal' t1 t2 `runReaderT` (fstnew, nbnew) - `evalStateT` [] - -instance (Unify t, o ~ UnifiesTo t) => Unify (MM t (RefInfo o)) where - type UnifiesTo (MM t (RefInfo o)) = o - - unify' = unify' `on` rm __IMPOSSIBLE__ - - notequal' = notequal' `on` rm __IMPOSSIBLE__ - -unifyVar :: Nat -> Exp o -> StateT (Assignments o) Maybe () -unifyVar v e = do - unif <- get - case lookup v unif of - Nothing -> modify ((v, e) :) - Just e' -> unify' e e' - -instance Unify t => Unify (Abs t) where - type UnifiesTo (Abs t) = UnifiesTo t - unify' (Abs _ b1) (Abs _ b2) = unify' b1 b2 - - notequal' (Abs _ b1) (Abs _ b2) = notequal' b1 b2 - -instance Unify (Exp o) where - type UnifiesTo (Exp o) = o - - unify' e1 e2 = case (e1, e2) of - (App _ _ elr1 args1, App _ _ elr2 args2) | elr1 == elr2 -> unify' args1 args2 - (Lam hid1 b1, Lam hid2 b2) | hid1 == hid2 -> unify' b1 b2 - (Pi _ hid1 _ a1 b1, Pi _ hid2 _ a2 b2) | hid1 == hid2 -> unify' a1 a2 - >> unify' b1 b2 - (Sort _, Sort _) -> return () -- a bit sloppy - (App _ _ (Var v) (NotM ALNil), _) - | v `Set.member` (freeVars e2) -> St.lift Nothing -- Occurs check - (_, App _ _ (Var v) (NotM ALNil)) - | v `Set.member` (freeVars e1) -> St.lift Nothing -- Occurs check - (App _ _ (Var v) (NotM ALNil), _) -> unifyVar v e2 - (_, App _ _ (Var v) (NotM ALNil)) -> unifyVar v e1 - _ -> St.lift Nothing - - notequal' e1 e2 = do - (fstnew, nbnew) <- ask - unifier <- get - case (e1, e2) of - (App _ _ elr1 es1, App _ _ elr2 es2) | elr1 == elr2 -> notequal' es1 es2 - (_, App _ _ (Var v2) (NotM ALNil)) -- why is this not symmetric?! - | fstnew <= v2 && v2 < fstnew + nbnew -> - case lookup v2 unifier of - Nothing -> modify ((v2, e1):) >> return False - Just e2' -> notequal' e1 e2' -{- - GA: Skipped these: Not sure why we'd claim they're impossible - (_, App _ _ (Var v2) (NotM ALProj{})) -> __IMPOSSIBLE__ - (_, App _ _ (Var v2) (NotM ALConPar{})) -> __IMPOSSIBLE__ --} - (App _ _ (Const c1) es1, App _ _ (Const c2) es2) -> do - cd1 <- liftIO $ readIORef c1 - cd2 <- liftIO $ readIORef c2 - case (cdcont cd1, cdcont cd2) of - (Constructor{}, Constructor{}) -> if c1 == c2 then notequal' es1 es2 - else return True - _ -> return False -{- GA: Why don't we have a case for distinct heads after all these - unification cases for vars with no spines & metas that can - be looked up? - (App _ _ elr1 _, App _ _ elr2 _) | elr1 <> elr2 -> return True --} - _ -> return False - -instance Unify (ArgList o) where - type UnifiesTo (ArgList o) = o - - unify' args1 args2 = case (args1, args2) of - (ALNil, ALNil) -> pure () - (ALCons hid1 a1 as1, ALCons hid2 a2 as2) | hid1 == hid2 -> unify' a1 a2 - >> unify' as1 as2 - (ALConPar as1, ALCons _ _ as2) -> unify' as1 as2 - (ALCons _ _ as1, ALConPar as2) -> unify' as1 as2 - (ALConPar as1, ALConPar as2) -> unify' as1 as2 - _ -> St.lift Nothing - - notequal' args1 args2 = case (args1, args2) of - (ALCons _ e es, ALCons _ f fs) -> notequal' e f `or2M` notequal' es fs - (ALConPar es1, ALConPar es2) -> notequal' es1 es2 - _ -> return False - --- This definition is only here to respect the previous interface. -unifyexp :: MExp o -> MExp o -> Maybe ([(Nat, MExp o)]) -unifyexp e1 e2 = fmap (NotM <$>) <$> unify e1 e2 - -class Lift t where - lift' :: Nat -> Nat -> t -> t - -lift :: Lift t => Nat -> t -> t -lift 0 = id -lift n = lift' n 0 - -instance Lift t => Lift (Abs t) where - lift' n j (Abs mid b) = Abs mid (lift' n (j + 1) b) - -instance Lift t => Lift (MM t r) where - lift' n j = NotM . lift' n j . rm __IMPOSSIBLE__ - -instance Lift (Exp o) where - lift' n j = \case - App uid ok elr args -> case elr of - Var v | v >= j -> App uid ok (Var (v + n)) (lift' n j args) - _ -> App uid ok elr (lift' n j args) - Lam hid b -> Lam hid (lift' n j b) - Pi uid hid possdep it b -> Pi uid hid possdep (lift' n j it) (lift' n j b) - e@Sort{} -> e - e@AbsurdLambda{} -> e - -instance Lift (ArgList o) where - lift' n j args = case args of - ALNil -> ALNil - ALCons hid a as -> ALCons hid (lift' n j a) (lift' n j as) - ALProj{} -> __IMPOSSIBLE__ - ALConPar as -> ALConPar (lift' n j as) - - -removevar :: CSCtx o -> MExp o -> [CSPat o] -> [(Nat, MExp o)] -> (CSCtx o, MExp o, [CSPat o]) -removevar ctx tt pats [] = (ctx, tt, pats) -removevar ctx tt pats ((v, e) : unif) = - let - e2 = replace v 0 __IMPOSSIBLE__ {- occurs check failed -} e - thesub = replace v 0 e2 - ctx1 = map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (take v ctx) ++ - map (\(HI hid (id, t)) -> HI hid (id, thesub t)) (drop (v + 1) ctx) - tt' = thesub tt - pats' = map (replacep v 0 (CSPatExp e2) e2) pats - unif' = map (\(uv, ue) -> (if uv > v then uv - 1 else uv, thesub ue)) unif - in - removevar ctx1 tt' pats' unif' - -findperm :: [MExp o] -> Maybe [Nat] -findperm ts = - let - frees = map freevars ts - m = IntMap.fromList $ - map (\i -> (i, length (filter (elem i) frees))) - [0..length ts - 1] - r _ perm 0 = Just $ reverse perm - r m perm n = - case lookup 0 (map swap (IntMap.toList m)) of - Nothing -> Nothing - Just i -> r (foldl (flip $ IntMap.adjust (subtract 1)) - (IntMap.insert i (-1) m) - (frees !! i)) - (i : perm) (n - 1) - in r m [] (length ts) - - -freevars :: FreeVars t => t -> [Nat] -freevars = Set.toList . freeVars - -applyperm :: [Nat] -> CSCtx o -> MExp o -> [CSPat o] -> - (CSCtx o, MExp o, [CSPat o]) -applyperm perm ctx tt pats = - let ctx1 = map (\(HI hid (id, t)) -> HI hid (id, rename (ren perm) t)) ctx - ctx2 = map (\i -> ctx1 !! i) perm - ctx3 = seqctx ctx2 - tt' = rename (ren perm) tt - pats' = map (rename (ren perm)) pats - in (ctx3, tt', pats') - -ren :: [Nat] -> Nat -> Int -ren n i = let Just j = elemIndex i n in j - -instance Renaming t => Renaming (HI t) where - renameOffset j ren (HI hid t) = HI hid $ renameOffset j ren t - -instance Renaming (CSPatI o) where - renameOffset j ren = \case - CSPatConApp c pats -> CSPatConApp c $ map (renameOffset j ren) pats - CSPatVar i -> CSPatVar $ j + ren i - CSPatExp e -> CSPatExp $ renameOffset j ren e - e@CSOmittedArg -> e - _ -> __IMPOSSIBLE__ - -seqctx :: CSCtx o -> CSCtx o -seqctx = r (-1) - where - r _ [] = [] - r n (HI hid (id, t) : ctx) = HI hid (id, lift n t) : r (n - 1) ctx --- -------------------- - -depthofvar :: Nat -> [CSPat o] -> Nat -depthofvar v pats = - let [depth] = concatMap (f 0) (drophid pats) - f d (CSPatConApp _ pats) = concatMap (f (d + 1)) (drophid pats) - f d (CSPatVar v') = [d | v == v'] - f _ _ = [] - in depth - --- -------------------- --- | Speculation: Type class computing the size (?) of a pattern --- and collecting the vars it introduces -class LocalTerminationEnv a where - sizeAndBoundVars :: a -> (Sum Nat, [Nat]) - -instance LocalTerminationEnv a => LocalTerminationEnv (HI a) where - sizeAndBoundVars (HI _ p) = sizeAndBoundVars p - -instance LocalTerminationEnv (CSPatI o) where - sizeAndBoundVars = \case - CSPatConApp _ ps -> (1, []) <> sizeAndBoundVars ps - CSPatVar n -> (0, [n]) - CSPatExp e -> sizeAndBoundVars e - _ -> (0, []) - -instance LocalTerminationEnv a => LocalTerminationEnv [a] where - sizeAndBoundVars = foldMap sizeAndBoundVars - -instance LocalTerminationEnv (MExp o) where --- sizeAndBoundVars e = case rm __IMPOSSIBLE__ e of --- GA: 2017 06 27: Not actually impossible! (cf. #2620) - sizeAndBoundVars Meta{} = (0, []) --- Does this default behaviour even make sense? The catchall in the --- following match seems to suggest it does - sizeAndBoundVars (NotM e) = case e of - App _ _ (Var v) _ -> (0, [v]) - App _ _ (Const _) args -> (1, []) <> sizeAndBoundVars args - _ -> (0, []) - -instance (LocalTerminationEnv a, LocalTerminationEnv b) => LocalTerminationEnv (a, b) where - sizeAndBoundVars (a, b) = sizeAndBoundVars a <> sizeAndBoundVars b - -instance LocalTerminationEnv (MArgList o) where - sizeAndBoundVars as = case rm __IMPOSSIBLE__ as of - ALNil -> (0, []) - ALCons _ a as -> sizeAndBoundVars (a, as) - ALProj{} -> __IMPOSSIBLE__ - ALConPar as -> sizeAndBoundVars as - - --- | Take a list of patterns and returns (is, size, vars) where (speculation): ---- * the is are the pattern indices the vars are contained in --- * size is total number of constructors removed (?) to access vars -localTerminationEnv :: [CSPat o] -> ([Nat], Nat, [Nat]) -localTerminationEnv pats = (is, getSum s, vs) where - - (is , s , vs) = g 0 pats - - g :: Nat -> [CSPat o] -> ([Nat], Sum Nat, [Nat]) - g _ [] = ([], 0, []) - g i (hp@(HI _ p) : ps) = case p of - CSPatConApp{} -> let (size, vars) = sizeAndBoundVars hp - in ([i], size, vars) <> g (i + 1) ps - _ -> g (i + 1) ps - -localTerminationSidecond :: ([Nat], Nat, [Nat]) -> ConstRef o -> MExp o -> EE (MyPB o) -localTerminationSidecond (is, size, vars) reccallc b = - ok b - where - ok e = mmpcase (False, prioNo, Nothing) e $ \e -> case e of - App _ _ elr args -> mpret $ Sidecondition - (oks args) - (case elr of - Const c | c == reccallc -> if size == 0 then mpret (Error "localTerminationSidecond: no size to decrement") else okcall 0 size vars args - _ -> mpret OK - ) - Lam _ (Abs _ e) -> ok e - Pi _ _ _ it (Abs _ ot) -> mpret $ Sidecondition - (ok it) - (ok ot) - Sort{} -> mpret OK - - AbsurdLambda{} -> mpret OK - - - oks as = mmpcase (False, prioNo, Nothing) as $ \as -> case as of - ALNil -> mpret OK - ALCons _ a as -> mpret $ Sidecondition - (ok a) - (oks as) - - ALProj eas _ _ as -> mpret $ Sidecondition (oks eas) (oks as) - - - ALConPar as -> oks as - - okcall i size vars as = mmpcase (False, prioNo, Nothing) as $ \as -> case as of - ALNil -> mpret OK - ALCons _ a as | i `elem` is -> - mbpcase prioNo Nothing (he size vars a) $ \x -> case x of - Nothing -> mpret $ Error "localTerminationSidecond: reccall not ok" - Just (size', vars') -> okcall (i + 1) size' vars' as - ALCons _ a as -> okcall (i + 1) size vars as - - ALProj{} -> mpret OK - - - ALConPar as -> __IMPOSSIBLE__ - - he size vars e = mmcase e $ \e -> case e of - App _ _ (Var v) _ -> - case remove v vars of - Nothing -> mbret Nothing - Just vars' -> mbret $ Just (size, vars') - App _ _ (Const c) args -> do - cd <- readIORef c - case cdcont cd of - Constructor{} -> - if size == 1 then - mbret Nothing - else - hes (size - 1) vars args - _ -> mbret Nothing - _ -> mbret Nothing - hes size vars as = mmcase as $ \as -> case as of - ALNil -> mbret $ Just (size, vars) - ALCons _ a as -> - mbcase (he size vars a) $ \x -> case x of - Nothing -> mbret Nothing - Just (size', vars') -> hes size' vars' as - - ALProj{} -> __IMPOSSIBLE__ - - - ALConPar as -> __IMPOSSIBLE__ - - remove _ [] = Nothing - remove x (y : ys) | x == y = Just ys - remove x (y : ys) = case remove x ys of {Nothing -> Nothing; Just ys' -> Just (y : ys')} - --- --------------------------- - - -getblks :: MExp o -> IO [Nat] -getblks tt = do - NotB (hntt, blks) <- hnn_blks (Clos [] tt) - case f blks of - Just v -> return [v] - Nothing -> case rawValue hntt of - HNApp (Const c) args -> do - cd <- readIORef c - case cdcont cd of - Datatype{} -> g [] args - _ -> return [] - _ -> return [] - where - f blks = case blks of - (b : bs) -> case rawValue (last1 b bs) of - HNApp (Var v) _ -> Just v - _ -> Nothing - _ -> Nothing - g vs args = do - NotB hnargs <- hnarglist args - case hnargs of - HNALCons _ a as -> do - NotB (_, blks) <- hnn_blks a - let vs' = case f blks of - Just v | v `notElem` vs -> v : vs - _ -> vs - g vs' as - _ -> return vs --- --------------------------- diff --git a/src/full/Agda/Auto/Convert.hs b/src/full/Agda/Auto/Convert.hs deleted file mode 100644 --- a/src/full/Agda/Auto/Convert.hs +++ /dev/null @@ -1,788 +0,0 @@ - -module Agda.Auto.Convert where - -import Prelude hiding ((!!)) - -import Control.Monad ( when ) -import Control.Monad.Except -import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.State - -import Data.Bifunctor (first) -import Data.IORef -import Data.Maybe (catMaybes) -import Data.Map (Map) -import qualified Data.Map as Map - -import Agda.Syntax.Common (Hiding(..), getHiding, Arg) -import Agda.Syntax.Concrete (exprFieldA) -import qualified Agda.Syntax.Internal as I -import Agda.Syntax.Internal (Dom'(..),domInfo,unDom) -import qualified Agda.Syntax.Internal.Pattern as IP -import qualified Agda.Syntax.Common as Cm -import qualified Agda.Syntax.Abstract.Name as AN -import qualified Agda.Syntax.Abstract as A -import qualified Agda.Syntax.Position as SP - -import qualified Agda.TypeChecking.Monad.Base as MB - -import Agda.TypeChecking.Monad.Signature (getConstInfo, getDefFreeVars, ignoreAbstractMode) -import Agda.TypeChecking.Level (reallyUnLevelView) -import Agda.TypeChecking.Monad.Base (mvJudgement, mvPermutation, getMetaInfo, envContext, clEnv) -import Agda.TypeChecking.Monad.MetaVars - (lookupMeta, withMetaInfo, lookupInteractionPoint) -import Agda.TypeChecking.Monad.Context (getContextArgs) -import Agda.TypeChecking.Monad.Constraints (getAllConstraints) -import Agda.TypeChecking.Substitute (applySubst, renamingR) -import Agda.TypeChecking.Telescope (piApplyM) -import qualified Agda.TypeChecking.Substitute as I (absBody) -import Agda.TypeChecking.Reduce (normalise, instantiate) -import Agda.TypeChecking.EtaContract (etaContract) -import Agda.TypeChecking.Monad.Builtin (constructorForm) -import Agda.TypeChecking.Free as Free (freeIn) - -import Agda.Interaction.MakeCase (getClauseZipperForIP) - -import Agda.Auto.NarrowingSearch -import Agda.Auto.Syntax hiding (getConst) - -import Agda.Auto.CaseSplit hiding (lift) - -import Agda.Utils.Either -import Agda.Utils.Lens -import Agda.Utils.List -import Agda.Utils.Monad ( forMaybeMM ) -import Agda.Utils.Permutation ( Permutation(Perm), permute, takeP, compactP ) -import Agda.Syntax.Common.Pretty ( prettyShow ) - -import Agda.Utils.Impossible - - -data Hint = Hint - { hintIsConstructor :: Bool - , hintQName :: I.QName - } - -type O = (Maybe (Int, [Arg AN.QName]),AN.QName) - -- Nothing - Def - -- Just npar - Con with npar parameters which don't appear in Agda - -data TMode = TMAll -- can be extended to distinguish between different modes (all, only def) - deriving Eq - -type MapS a b = (Map a b, [a]) - -initMapS :: MapS a b -initMapS = (Map.empty, []) - -popMapS :: (S -> (a, [b])) -> ((a, [b]) -> S -> S) -> TOM (Maybe b) -popMapS r w = do (m, xs) <- gets r - case xs of - [] -> return Nothing - (x:xs) -> do - modify (w (m, xs)) - return $ Just x - -data S = S {sConsts :: MapS AN.QName (TMode, ConstRef O), - sMetas :: MapS I.MetaId (Metavar (Exp O) (RefInfo O), Maybe (MExp O, [MExp O]), [I.MetaId]), - sEqs :: MapS Int (Maybe (Bool, MExp O, MExp O)), - sCurMeta :: Maybe I.MetaId, - sMainMeta :: I.MetaId - } - -type TOM = StateT S MB.TCM -type MOT = ExceptT String IO - -tomy :: I.MetaId -> [Hint] -> [I.Type] -> - MB.TCM ([ConstRef O] - , [MExp O] - , Map I.MetaId (Metavar (Exp O) (RefInfo O), MExp O, [MExp O], [I.MetaId]) - , [(Bool, MExp O, MExp O)] - , Map AN.QName (TMode, ConstRef O)) -tomy imi icns typs = do - eqs <- getEqs - let - r :: [AN.QName] -> TOM [AN.QName] - r projfcns = do - nxt <- popMapS sConsts (\x y -> y {sConsts = x}) - case nxt of - Just cn -> do - cmap <- gets (fst . sConsts) - let (mode, c) = cmap Map.! cn - def <- lift $ getConstInfo cn - let typ = MB.defType def - defn = MB.theDef def - typ <- lift $ normalise typ - typ' <- convert typ - let clausesToDef clauses = do - clauses' <- convert clauses - let narg = case clauses of - [] -> 0 - I.Clause {I.namedClausePats = xs} : _ -> length xs - return (Def narg clauses' Nothing Nothing, []) - (cont, projfcns2) <- case defn of - MB.Axiom {} -> return (Postulate, []) - MB.DataOrRecSig{} -> return (Postulate, []) - MB.GeneralizableVar{} -> __IMPOSSIBLE__ - MB.AbstractDefn{} -> return (Postulate, []) - MB.Function {MB.funClauses = clauses} -> clausesToDef clauses - -- MB.Primitive {MB.primClauses = []} -> throwError $ strMsg "Auto: Primitive functions are not supported" -- Andreas, 2013-06-17 breaks interaction/AutoMisc - MB.Primitive {MB.primClauses = clauses} -> clausesToDef clauses - MB.PrimitiveSort{} -> __IMPOSSIBLE__ - MB.Datatype {MB.dataCons = cons} -> do - cons2 <- mapM (\con -> getConst True con TMAll) cons - return (Datatype cons2 [], []) - MB.Record {MB.recFields = fields, MB.recTel = tel} -> do -- the value of recPars seems unreliable or don't know what it signifies - let pars n (I.El _ (I.Pi it typ)) = Cm.Arg (I.domInfo it) (I.var n) : - pars (n - 1) (I.unAbs typ) - pars _ (I.El _ _) = [] - contyp npar I.EmptyTel = I.El (I.mkType 0 {- arbitrary -}) $ - I.Def cn $ map I.Apply $ pars (npar - 1) typ - contyp npar (I.ExtendTel it (I.Abs v tel)) = I.El (I.mkType 0 {- arbitrary -}) (I.Pi it (I.Abs v (contyp (npar + 1) tel))) - contyp npar (I.ExtendTel it I.NoAbs{}) = __IMPOSSIBLE__ - contyp' <- convert $ contyp 0 tel - cc <- lift $ liftIO $ readIORef c - let Datatype [con] [] = cdcont cc - lift $ liftIO $ modifyIORef con (\cdef -> cdef {cdtype = contyp'}) - - projfcns <- mapM (\ dom -> getConst False (I.unDom dom) TMAll) fields - -- Equivalently projfcns <- mapM (($ TMAll) . getConst False . I.unDom) fields - - return (Datatype [con] projfcns, []{-map snd fields-}) - MB.Constructor {MB.conData = dt} -> do - _ <- getConst False dt TMAll -- make sure that datatype is included - cc <- lift $ liftIO $ readIORef c - let (Just (nomi,_), _) = cdorigin cc - return (Constructor (nomi - cddeffreevars cc), []) - lift $ liftIO $ modifyIORef c (\cdef -> cdef {cdtype = typ', cdcont = cont}) - r $ projfcns2 ++ projfcns - Nothing -> do - nxt <- popMapS sMetas (\x y -> y {sMetas = x}) - case nxt of - Just mi -> do - mapM_ (\((_, e, i), eqi) -> do - when (fmExp mi e || fmExp mi i) $ do - (eqsm, eqsl) <- gets sEqs - when (Map.notMember eqi eqsm) $ do - modify $ \s -> s {sEqs = (Map.insert eqi Nothing eqsm, eqi : eqsl)} - ) (zip eqs [0..]) - mv <- lift $ lookupLocalMetaAuto mi - msol <- case MB.mvInstantiation mv of - MB.InstV{} -> - lift $ withMetaInfo (getMetaInfo mv) $ do - args <- getContextArgs - --sol <- norm (I.MetaV mi args) - sol <- instantiate $ I.MetaV mi $ map I.Apply $ permute (takeP (length args) $ mvPermutation mv) args - return $ Just sol - _ -> return Nothing - case msol of - Nothing -> return () - Just sol -> do - m <- getMeta mi - sol' <- convert sol - modify $ \s -> s {sEqs = first (Map.insert (Map.size (fst $ sEqs s)) (Just (False, Meta m, sol'))) (sEqs s)} - let tt = MB.jMetaType $ mvJudgement mv - minfo = getMetaInfo mv - localVars = map (snd . I.unDom) . envContext . clEnv $ minfo - (targettype, localVars) <- lift $ withMetaInfo minfo $ do - vs <- getContextArgs - targettype <- tt `piApplyM` permute (takeP (length vs) $ mvPermutation mv) vs - targettype <- normalise targettype - localVars <- mapM normalise localVars - return (targettype, localVars) - modify (\s -> s {sCurMeta = Just mi}) - typ' <- convert targettype - ctx' <- mapM convert localVars - modify (\s -> s {sCurMeta = Nothing}) - modify (\s -> s {sMetas = first (Map.adjust (\(m, _, deps) -> (m, Just (typ', ctx'), deps)) mi) (sMetas s)}) - r projfcns - Nothing -> do - nxt <- popMapS sEqs (\x y -> y {sEqs = x}) - case nxt of - Just eqi -> do - let (ineq, e, i) = eqs !! eqi - e' <- convert e - i' <- convert i - modify (\s -> s {sEqs = first (Map.adjust (\_ -> Just (ineq, e', i')) eqi) (sEqs s)}) - r projfcns - Nothing -> - return projfcns - ((icns', typs'), s) <- runStateT - (do _ <- getMeta imi - icns' <- mapM (\ (Hint iscon name) -> getConst iscon name TMAll) icns - typs' <- mapM convert typs - projfcns <- r [] - projfcns' <- mapM (\name -> getConst False name TMAll) projfcns - [] <- r [] - return (projfcns' ++ icns', typs') - ) (S {sConsts = initMapS, sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = imi}) - lift $ liftIO $ mapM_ categorizedecl icns' - return (icns', typs', Map.map flatten (fst (sMetas s)), map fromJust $ Map.elems (fst (sEqs s)), fst (sConsts s)) - where - flatten (x, Just (y, z), w) = (x, y, z, w) - flatten (x, Nothing, w) = __IMPOSSIBLE__ - - fromJust (Just x) = x - fromJust Nothing = __IMPOSSIBLE__ - -getConst :: Bool -> AN.QName -> TMode -> TOM (ConstRef O) -getConst iscon name mode = do - def <- lift $ getConstInfo name - case MB.theDef def of - MB.Record {MB.recConHead = con} -> do - let conname = I.conName con - conflds = I.conFields con - cmap <- gets (fst . sConsts) - case Map.lookup name cmap of - Just (mode', c) -> - if iscon then do - cd <- lift $ liftIO $ readIORef c - let Datatype [con] _ = cdcont cd - return con - else - return c - Nothing -> do - mainm <- gets sMainMeta - dfv <- lift $ getdfv mainm name - let nomi = I.arity (MB.defType def) - ccon <- lift $ liftIO $ newIORef (ConstDef {cdname = prettyShow name ++ ".CONS", cdorigin = (Just (nomi,conflds), conname), cdtype = __IMPOSSIBLE__, cdcont = Constructor (nomi - dfv), cddeffreevars = dfv}) -- ?? correct value of deffreevars for records? - c <- lift $ liftIO $ newIORef (ConstDef {cdname = prettyShow name, cdorigin = (Nothing, name), cdtype = __IMPOSSIBLE__, cdcont = Datatype [ccon] [], cddeffreevars = dfv}) -- ?? correct value of deffreevars for records? - modify (\s -> s {sConsts = (Map.insert name (mode, c) cmap, name : snd (sConsts s))}) - return $ if iscon then ccon else c - _ -> do - cmap <- gets (fst . sConsts) - case Map.lookup name cmap of - Just (mode', c) -> - return c - Nothing -> do - (miscon, sname) <- if iscon then do - let MB.Constructor {MB.conPars = npar, MB.conData = dname, MB.conSrcCon = ch} = MB.theDef def - return (Just (npar,I.conFields ch), prettyShow dname ++ "." ++ prettyShow (I.qnameName name)) - else - return (Nothing, prettyShow name) - mainm <- gets sMainMeta - dfv <- lift $ getdfv mainm name - c <- lift $ liftIO $ newIORef (ConstDef {cdname = sname, cdorigin = (miscon, name), cdtype = __IMPOSSIBLE__, cdcont = __IMPOSSIBLE__, cddeffreevars = dfv}) - modify (\s -> s {sConsts = (Map.insert name (mode, c) cmap, name : snd (sConsts s))}) - return c - -getdfv :: I.MetaId -> A.QName -> MB.TCM Cm.Nat -getdfv mainm name = do - mv <- lookupLocalMetaAuto mainm - withMetaInfo (getMetaInfo mv) $ getDefFreeVars name - --- | A variant of 'lookupLocalMeta' that, if applied to a remote --- meta-variable, raises a special error message noting that remote --- meta-variables are not handled by the auto command. - -lookupLocalMetaAuto :: I.MetaId -> MB.TCM MB.MetaVariable -lookupLocalMetaAuto m = do - mv <- lookupMeta m - case mv of - Just (Right mv) -> return mv - Nothing -> __IMPOSSIBLE__ - Just Left{} -> MB.typeError $ MB.GenericError $ - "The auto command does not support remote meta-variables," ++ - "consider using --no-save-metas" - -getMeta :: I.MetaId -> TOM (Metavar (Exp O) (RefInfo O)) -getMeta name = do - mmap <- gets (fst . sMetas) - case Map.lookup name mmap of - Just (m, _, _) -> - return m - Nothing -> do - m <- lift $ liftIO initMeta - modify $ \ s -> s { sMetas = (Map.insert name (m, Nothing, []) mmap, name : snd (sMetas s)) } - return m - -getEqs :: MB.TCM [(Bool, I.Term, I.Term)] -getEqs = forMaybeMM getAllConstraints $ \ eqc -> do - neqc <- normalise eqc - case MB.clValue $ MB.theConstraint neqc of - MB.ValueCmp ineq _ i e -> do - ei <- etaContract i - ee <- etaContract e - return $ Just (tomyIneq ineq, ee, ei) - _ -> return Nothing - -literalsNotImplemented :: MB.TCM a -literalsNotImplemented = MB.typeError $ MB.NotImplemented $ - "The Agda synthesizer (Agsy) does not support literals yet" - -hitsNotImplemented :: MB.TCM a -hitsNotImplemented = MB.typeError $ MB.NotImplemented $ - "The Agda synthesizer (Agsy) does not support HITs yet" - -class Conversion m a b where - convert :: a -> m b - -instance Conversion TOM [I.Clause] [([Pat O], MExp O)] where - convert = fmap catMaybes . mapM convert - -instance Conversion TOM I.Clause (Maybe ([Pat O], MExp O)) where - convert cl = do - let -- Jesper, 2016-07-28: - -- I can't figure out if this should be the old or new - -- clause body (i.e. relative to the positions of pattern variables or - -- relative to the clauseTel). Both options pass the test suite, so I - -- have the impression it doesn't actually matter. - -- ALTERNATIVE CODE: - -- perm = fromMaybe __IMPOSSIBLE__ $ IP.clausePerm cl - -- body = applySubst (renamingR perm) $ I.clauseBody cl - body = I.clauseBody cl - pats = I.clausePats cl - pats' <- mapM convert (IP.unnumberPatVars pats :: [Cm.Arg I.Pattern]) - body' <- traverse convert =<< lift (normalise body) - return $ (pats',) <$> body' - -instance Conversion TOM (Cm.Arg I.Pattern) (Pat O) where - convert p = case Cm.unArg p of - I.IApplyP _ _ _ n -> return $ PatVar (prettyShow n) - I.VarP _ n -> return $ PatVar (prettyShow n) - I.DotP _ _ -> return $ PatVar "_" - -- because Agda includes these when referring to variables in the body - I.ConP con _ pats -> do - let n = I.conName con - c <- getConst True n TMAll - pats' <- mapM (convert . fmap Cm.namedThing) pats - def <- lift $ getConstInfo n - cc <- lift $ liftIO $ readIORef c - let Just (npar,_) = fst $ cdorigin cc - return $ PatConApp c (replicate npar PatExp ++ pats') - I.ProjP _ q -> PatProj <$> getConst True q TMAll - - -- UNSUPPORTED CASES - I.LitP{} -> lift literalsNotImplemented - I.DefP{} -> lift hitsNotImplemented - -instance Conversion TOM I.Type (MExp O) where - convert (I.El _ t) = convert t -- sort info is thrown away - -instance Conversion TOM I.Term (MExp O) where - convert v0 = - case I.unSpine v0 of - I.Var v es -> do - let Just as = I.allApplyElims es - as' <- convert as - return $ NotM $ App Nothing (NotM OKVal) (Var v) as' - I.Lam info b -> do - b' <- convert (I.absBody b) - return $ NotM $ Lam (getHiding info) (Abs (Id $ I.absName b) b') - t@I.Lit{} -> do - t <- lift $ constructorForm t - case t of - I.Lit{} -> lift literalsNotImplemented - _ -> convert t - I.Level l -> convert =<< lift (reallyUnLevelView l) - I.Def name es -> do - let Just as = I.allApplyElims es - c <- getConst False name TMAll - as' <- convert as - return $ NotM $ App Nothing (NotM OKVal) (Const c) as' - I.Con con ci es -> do - let Just as = I.allApplyElims es - let name = I.conName con - c <- getConst True name TMAll - as' <- convert as - def <- lift $ getConstInfo name - cc <- lift $ liftIO $ readIORef c - let Just (npar,_) = fst $ cdorigin cc - return $ NotM $ App Nothing (NotM OKVal) (Const c) (foldl (\x _ -> NotM $ ALConPar x) as' [1..npar]) - I.Pi (I.Dom{domInfo = info, unDom = x}) b -> do - let y = I.absBody b - name = I.absName b - x' <- convert x - y' <- convert y - return $ NotM $ Pi Nothing (getHiding info) (Free.freeIn 0 y) x' (Abs (Id name) y') - I.Sort (I.Type (I.ClosedLevel l)) -> return $ NotM $ Sort $ Set $ fromIntegral l - I.Sort _ -> return $ NotM $ Sort UnknownSort - I.Dummy{}-> return $ NotM $ Sort UnknownSort - t@I.MetaV{} -> do - t <- lift $ instantiate t - case t of - I.MetaV mid _ -> do - mcurmeta <- gets sCurMeta - case mcurmeta of - Nothing -> return () - Just curmeta -> - modify $ \ s -> s { sMetas = first (Map.adjust (\(m, x, deps) -> (m, x, mid : deps)) curmeta) (sMetas s) } - m <- getMeta mid - return $ Meta m - _ -> convert t - I.DontCare _ -> return $ NotM dontCare - -instance Conversion TOM a b => Conversion TOM (Cm.Arg a) (Hiding, b) where - convert (Cm.Arg info a) = (getHiding info,) <$> convert a - -instance Conversion TOM I.Args (MM (ArgList O) (RefInfo O)) where - convert as = NotM . foldr (\ (hid,t) -> ALCons hid t . NotM) ALNil - <$> mapM convert as - -tomyIneq :: MB.Comparison -> Bool -tomyIneq MB.CmpEq = False -tomyIneq MB.CmpLeq = True - --- --------------------------------------------- - -fmType :: I.MetaId -> I.Type -> Bool -fmType m (I.El _ t) = fmExp m t - -fmExp :: I.MetaId -> I.Term -> Bool -fmExp m (I.Var _ as) = fmExps m $ I.argsFromElims as -fmExp m (I.Lam _ b) = fmExp m (I.unAbs b) -fmExp m (I.Lit _) = False -fmExp m (I.Level (I.Max _ as)) = any (fmLevel m) as -fmExp m (I.Def _ as) = fmExps m $ I.argsFromElims as -fmExp m (I.Con _ ci as) = fmExps m $ I.argsFromElims as -fmExp m (I.Pi x y) = fmType m (I.unDom x) || fmType m (I.unAbs y) -fmExp m (I.Sort _) = False -fmExp m (I.MetaV mid _) = mid == m -fmExp m (I.DontCare _) = False -fmExp _ I.Dummy{} = False - -fmExps :: I.MetaId -> I.Args -> Bool -fmExps m as = any (fmExp m . Cm.unArg) as - -fmLevel :: I.MetaId -> I.PlusLevel -> Bool -fmLevel m (I.Plus _ l) = fmExp m l - --- --------------------------------------------- - -icnvh :: Hiding -> Cm.ArgInfo -icnvh h = Cm.setHiding h $ - Cm.setOrigin o $ - Cm.defaultArgInfo - where - -- Andreas, 2017-01-18, issue #819. - -- Visible arguments are made UserWritten, - -- otherwise they might not be printed in patterns. - o = case h of - NotHidden -> Cm.UserWritten - Instance{} -> Cm.Inserted - Hidden -> Cm.Inserted - --- --------------------------------------------- - -instance Conversion MOT a b => Conversion MOT (MM a (RefInfo O)) b where - convert meta = case meta of - NotM a -> convert a - Meta m -> do - ma <- lift $ readIORef $ mbind m - case ma of - Nothing -> throwError "meta not bound" - Just a -> convert a - -instance Conversion MOT a b => Conversion MOT (Abs a) (I.Abs b) where - convert (Abs mid t) = I.Abs id <$> convert t where - id = case mid of - NoId -> "x" - Id id -> id - -instance Conversion MOT (Exp O) I.Type where - convert e = I.El (I.mkType 0) <$> convert e - -- 0 is arbitrary, sort not read by Agda when reifying - -instance Conversion MOT (Exp O) I.Term where - convert = \case - App _ _ (Var v) as -> frommyExps 0 as (I.Var v []) - App _ _ (Const c) as -> do - cdef <- lift $ readIORef c - let (iscon, name) = cdorigin cdef -{- - case iscon of - Just n -> do - v <- getConTerm name -- We are not in TCM - frommyExps n as v --} - (ndrop, h) = case iscon of - Just (n,fs) -> (n, \ q -> I.Con (I.ConHead q I.IsData Cm.Inductive fs) Cm.ConOSystem) - Nothing -> (0, \ f vs -> I.Def f vs) - frommyExps ndrop as (h name []) - Lam hid t -> I.Lam (icnvh hid) <$> convert t - Pi _ hid _ x y -> do - x' <- convert x - let dom = (I.defaultDom x') {domInfo = icnvh hid} - I.Pi dom <$> convert y - -- maybe have case for Pi where possdep is False which produces Fun (and has to unweaken y), return $ I.Fun (Cm.Arg (icnvh hid) x') y' - Sort (Set l) -> return $ I.Sort (I.mkType (fromIntegral l)) - Sort Type -> __IMPOSSIBLE__ - Sort UnknownSort -> return $ I.Sort (I.mkType 0) -- hoping it's thrown away - - AbsurdLambda hid -> return $ I.Lam (icnvh hid) - $ I.Abs abslamvarname (I.Var 0 []) - -frommyExps :: Nat -> MArgList O -> I.Term -> ExceptT String IO I.Term -frommyExps ndrop (Meta m) trm = do - bind <- lift $ readIORef $ mbind m - case bind of - Nothing -> throwError "meta not bound" - Just e -> frommyExps ndrop (NotM e) trm -frommyExps ndrop (NotM as) trm = - case as of - ALNil -> return trm - ALCons _ _ xs | ndrop > 0 -> frommyExps (ndrop - 1) xs trm - ALCons hid x xs -> do - x' <- convert x - frommyExps ndrop xs (addend (Cm.Arg (icnvh hid) x') trm) - - -- Andreas, 2013-10-19 TODO: restore postfix projections - ALProj eas idx hid xs -> do - idx <- lift $ expandbind idx - c <- case idx of - NotM c -> return c - Meta{} -> throwError "meta not bound" - cdef <- lift $ readIORef c - let name = snd $ cdorigin cdef - trm2 <- frommyExps 0 eas (I.Def name []) - frommyExps 0 xs (addend (Cm.Arg (icnvh hid) trm) trm2) - - ALConPar xs | ndrop > 0 -> frommyExps (ndrop - 1) xs trm - ALConPar _ -> __IMPOSSIBLE__ - where - addend x (I.Var h xs) = I.Var h (xs ++ [I.Apply x]) - addend x (I.Con h ci xs) = I.Con h ci (xs ++ [I.Apply x]) - addend x (I.Def h xs) = I.Def h (xs ++ [I.Apply x]) - addend _ _ = __IMPOSSIBLE__ - --- -------------------------------- - -abslamvarname :: String -abslamvarname = "\0absurdlambda" - -modifyAbstractExpr :: A.Expr -> A.Expr -modifyAbstractExpr = f - where - f (A.App i e1 (Cm.Arg info (Cm.Named n e2))) = - A.App i (f e1) (Cm.Arg info (Cm.Named n (f e2))) - f (A.Lam i (A.DomainFree _ x) _) - | A.Binder _ (A.BindName{unBind = n}) <- Cm.namedArg x - , prettyShow (A.nameConcrete n) == abslamvarname = - A.AbsurdLam i $ Cm.getHiding x - f (A.Lam i b e) = A.Lam i b (f e) - f (A.Rec i xs) = A.Rec i (map (mapLeft (over exprFieldA f)) xs) - f (A.RecUpdate i e xs) = A.RecUpdate i (f e) (map (over exprFieldA f) xs) - f (A.ScopedExpr i e) = A.ScopedExpr i (f e) - f e = e - -modifyAbstractClause :: A.Clause -> A.Clause -modifyAbstractClause (A.Clause lhs spats (A.RHS e mc) decls catchall) = - A.Clause lhs spats (A.RHS (modifyAbstractExpr e) mc) decls catchall -modifyAbstractClause cl = cl - --- --------------------------------- - - -constructPats :: Map AN.QName (TMode, ConstRef O) -> I.MetaId -> I.Clause -> MB.TCM ([(Hiding, MId)], [CSPat O]) -constructPats cmap mainm clause = do - let cnvps ns [] = return (ns, []) - cnvps ns (p : ps) = do - (ns', ps') <- cnvps ns ps - (ns'', p') <- cnvp ns' p - return (ns'', p' : ps') - cnvp ns p = - let hid = getHiding $ Cm.argInfo p - in case Cm.namedArg p of - I.VarP _ n -> return ((hid, Id n) : ns, HI hid (CSPatVar $ length ns)) - I.IApplyP _ _ _ n -> return ((hid, Id n) : ns, HI hid (CSPatVar $ length ns)) - I.ConP con _ ps -> do - let c = I.conName con - (c2, _) <- runStateT (getConst True c TMAll) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm}) - (ns', ps') <- cnvps ns ps - cc <- liftIO $ readIORef c2 - let Just (npar,_) = fst $ cdorigin cc - return (ns', HI hid (CSPatConApp c2 (replicate npar (HI Hidden CSOmittedArg) ++ ps'))) - I.DotP _ t -> do - (t2, _) <- runStateT (convert t) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm}) - return (ns, HI hid (CSPatExp t2)) - I.ProjP po c -> do - (c2, _) <- runStateT (getConst True c TMAll) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm}) - cc <- liftIO $ readIORef c2 - return (ns, HI hid (CSPatProj c2)) - I.LitP{} -> literalsNotImplemented - I.DefP{} -> hitsNotImplemented - - (names, pats) <- cnvps [] (IP.unnumberPatVars $ I.namedClausePats clause) - return (reverse names, pats) - - -frommyClause :: (CSCtx O, [CSPat O], Maybe (MExp O)) -> ExceptT String IO I.Clause -frommyClause (ids, pats, mrhs) = do - let ctel [] = return I.EmptyTel - ctel (HI hid (mid, t) : ctx) = do - let Id id = mid - tel <- ctel ctx - t' <- convert t - let dom = (I.defaultDom t') {domInfo = icnvh hid} - return $ I.ExtendTel dom (I.Abs id tel) - tel <- ctel $ reverse ids - let getperms 0 [] perm nv = return (perm, nv) - getperms n [] _ _ = __IMPOSSIBLE__ - getperms 0 (p : ps) perm nv = do - (perm, nv) <- getperm p perm nv - getperms 0 ps perm nv - getperms n (HI _ CSPatExp{} : ps) perm nv = getperms (n - 1) ps perm nv - getperms n (HI _ CSOmittedArg{} : ps) perm nv = getperms (n - 1) ps perm nv - getperms n (_ : _) _ _ = __IMPOSSIBLE__ - getperm (HI _ p) perm nv = - case p of - --CSPatVar v -> return (length ids + nv - 1 - v : perm, nv) - CSPatVar v -> return ((length ids - 1 - v, nv) : perm, nv + 1) - CSPatConApp c ps -> do - cdef <- lift $ readIORef c - let (Just (ndrop,_), _) = cdorigin cdef - getperms ndrop ps perm nv - CSPatExp e -> return (perm, nv + 1) - _ -> __IMPOSSIBLE__ - (rperm, nv) <- getperms 0 pats [] 0 - let --perm = reverse rperm - perm = map (\i -> let Just x = lookup i rperm in x) [0..length ids - 1] - --renperm = map (\i -> length ids + nv - 1 - i) rperm - --renm = rename (\i -> renperm !! i) - cnvps 0 [] = return [] - cnvps n [] = __IMPOSSIBLE__ - cnvps 0 (p : ps) = do - p' <- cnvp p - ps' <- cnvps 0 ps - return (p' : ps') - cnvps n (HI _ CSPatExp{} : ps) = cnvps (n - 1) ps - cnvps n (HI _ CSOmittedArg{} : ps) = cnvps (n - 1) ps - cnvps n (_ : _) = __IMPOSSIBLE__ - cnvp (HI hid p) = do - p' <- case p of - CSPatVar v -> return (I.varP $ let HI _ (Id n, _) = ids !! v in n) - CSPatConApp c ps -> do - cdef <- lift $ readIORef c - let (Just (ndrop,_), name) = cdorigin cdef - ps' <- cnvps ndrop ps - let con = I.ConHead name I.IsData Cm.Inductive [] -- TODO: restore DataOrRecord and record fields! - return (I.ConP con I.noConPatternInfo ps') - CSPatExp e -> do - e' <- convert e {- renm e -} -- renaming before adding to clause below - return (I.dotP e') - CSAbsurd -> __IMPOSSIBLE__ -- CSAbsurd not used - _ -> __IMPOSSIBLE__ - return $ Cm.Arg (icnvh hid) $ Cm.unnamed p' -- TODO: recover names - ps <- cnvps 0 pats - body <- case mrhs of - Nothing -> return $ Nothing - Just e -> Just <$> convert e - let cperm = Perm nv perm - return I.Clause - { I.clauseLHSRange = SP.noRange - , I.clauseFullRange = SP.noRange - , I.clauseTel = tel - , I.namedClausePats = IP.numberPatVars __IMPOSSIBLE__ cperm $ applySubst (renamingR $ compactP cperm) ps - , I.clauseBody = body - , I.clauseType = Nothing -- TODO: compute clause type - , I.clauseCatchall = False - , I.clauseExact = Nothing -- TODO - , I.clauseRecursive = Nothing -- TODO: Don't know here whether recursive or not !? - , I.clauseUnreachable = Nothing -- TODO: Don't know here whether reachable or not !? - , I.clauseEllipsis = Cm.NoEllipsis - , I.clauseWhereModule = Nothing - } - -contains_constructor :: [CSPat O] -> Bool -contains_constructor = any f - where - f (HI _ p) = case p of - CSPatConApp{} -> True - _ -> False - --- --------------------------------- - -freeIn :: Nat -> MExp o -> Bool -freeIn = f - where - mr x = let NotM x' = x in x' - f v e = case mr e of - App _ _ elr args -> case elr of - Var v' | v' == v -> False - _ -> fs v args - Lam _ (Abs _ b) -> f (v + 1) b - Pi _ _ _ it (Abs _ ot) -> f v it && f (v + 1) ot - Sort{} -> True - - AbsurdLambda{} -> True - - - fs v es = case mr es of - ALNil -> True - ALCons _ a as -> f v a && fs v as - - ALProj{} -> __IMPOSSIBLE__ - - - ALConPar as -> fs v as - - -negtype :: ConstRef o -> MExp o -> MExp o -negtype ee = f (0 :: Int) - where - mr x = let NotM x' = x in x' - f n e = case mr e of - Pi uid hid possdep it (Abs id ot) -> NotM $ Pi uid hid possdep it (Abs id (f (n + 1) ot)) - _ -> NotM $ Pi Nothing NotHidden False (NotM $ Pi Nothing NotHidden False e (Abs NoId (NotM $ Pi Nothing NotHidden True (NotM $ Sort (Set 0)) (Abs NoId (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)))))) (Abs NoId (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil))) - --- --------------------------------------- - -findClauseDeep :: Cm.InteractionId -> MB.TCM (Maybe (AN.QName, I.Clause, Bool)) -findClauseDeep ii = ignoreAbstractMode $ do -- Andreas, 2016-09-04, issue #2162 - MB.InteractionPoint { MB.ipClause = ipCl} <- lookupInteractionPoint ii - case ipCl of - MB.IPNoClause -> return Nothing - MB.IPClause f clauseNo _ _ _ _ -> do - (_, (_, c, _)) <- getClauseZipperForIP f clauseNo - return $ Just (f, c, maybe __IMPOSSIBLE__ toplevel $ I.clauseBody c) - where - toplevel e = - case e of - I.MetaV{} -> True - _ -> False - --- --------------------------------------- - -matchType :: Int -> Int -> I.Type -> I.Type -> Maybe (Nat, Nat) -- Nat is deffreevars of const, Nat is ctx length of target type, left arg is const type, right is target type -matchType cdfv tctx ctyp ttyp = trmodps cdfv ctyp - where - trmodps 0 ctyp = tr 0 0 ctyp - trmodps n ctyp = case I.unEl ctyp of - I.Pi _ ot -> trmodps (n - 1) (I.absBody ot) - _ -> __IMPOSSIBLE__ - tr narg na ctyp = - case ft 0 0 Just ctyp ttyp of - Just n -> Just (n, narg) - Nothing -> case I.unEl ctyp of - I.Pi _ (I.Abs _ ot) -> tr (narg + 1) (na + 1) ot - I.Pi _ (I.NoAbs _ ot) -> tr (narg + 1) na ot - _ -> Nothing - where - ft nl n c (I.El _ e1) (I.El _ e2) = f nl n c e1 e2 - f nl n c e1 e2 = case e1 of - I.Var v1 as1 | v1 < nl -> case e2 of - I.Var v2 as2 | v1 == v2 -> fes nl (n + 1) c as1 as2 - _ -> Nothing - I.Var v1 _ | v1 < nl + na -> c n -- unify vars with no args? - I.Var v1 as1 -> case e2 of - I.Var v2 as2 | cdfv + na + nl - v1 == tctx + nl - v2 -> fes nl (n + 1) c as1 as2 - _ -> Nothing - _ -> case (e1, e2) of - (I.MetaV{}, _) -> c n - (_, I.MetaV{}) -> c n - (I.Lam hid1 b1, I.Lam hid2 b2) | hid1 == hid2 -> f (nl + 1) n c (I.absBody b1) (I.absBody b2) - (I.Lit lit1, I.Lit lit2) | lit1 == lit2 -> c (n + 1) - (I.Def n1 as1, I.Def n2 as2) | n1 == n2 -> fes nl (n + 1) c as1 as2 - (I.Con n1 _ as1, I.Con n2 _ as2) | n1 == n2 -> fs nl (n + 1) c as1 as2 - (I.Pi (I.Dom{domInfo = info1, unDom = it1}) ot1, I.Pi (I.Dom{domInfo = info2, unDom = it2}) ot2) | Cm.argInfoHiding info1 == Cm.argInfoHiding info2 -> ft nl n (\n -> ft (nl + 1) n c (I.absBody ot1) (I.absBody ot2)) it1 it2 - (I.Sort{}, I.Sort{}) -> c n -- sloppy - _ -> Nothing - fs nl n c es1 es2 = case (es1, es2) of - ([], []) -> c n - (I.Apply (Cm.Arg info1 e1) : es1, I.Apply (Cm.Arg info2 e2) : es2) | Cm.argInfoHiding info1 == Cm.argInfoHiding info2 -> f nl n (\n -> fs nl n c es1 es2) e1 e2 - _ -> Nothing - fes nl n c es1 es2 = case (es1, es2) of - ([], []) -> c n - (I.Proj _ f : es1, I.Proj _ f' : es2) | f == f' -> fes nl n c es1 es2 - (I.Apply (Cm.Arg info1 e1) : es1, I.Apply (Cm.Arg info2 e2) : es2) | Cm.argInfoHiding info1 == Cm.argInfoHiding info2 -> f nl n (\n -> fes nl n c es1 es2) e1 e2 - _ -> Nothing diff --git a/src/full/Agda/Auto/NarrowingSearch.hs b/src/full/Agda/Auto/NarrowingSearch.hs deleted file mode 100644 --- a/src/full/Agda/Auto/NarrowingSearch.hs +++ /dev/null @@ -1,670 +0,0 @@ -{-# OPTIONS_GHC -Wunused-imports #-} - -module Agda.Auto.NarrowingSearch where - -import Control.Monad ( foldM, when ) -import Control.Monad.State ( MonadState(..), modify, StateT, evalStateT, runStateT ) -import Control.Monad.Trans ( lift ) - -import Data.IORef hiding (writeIORef, modifyIORef) -import qualified Data.IORef as NoUndo (writeIORef, modifyIORef) - -import Agda.Utils.Impossible -import Agda.Utils.Empty - -newtype Prio = Prio { getPrio :: Int } - deriving (Eq, Ord, Num) - -class Trav a where - type Block a - trav :: Monad m => (forall b. TravWith b (Block a) => MM b (Block b) -> m ()) -> a -> m () - --- | Trav instance 'a' with block type 'blk' -type TravWith a blk = (Trav a, Block a ~ blk) - -instance TravWith a blk => Trav (MM a blk) where - type Block (MM a blk) = blk - trav f me = f me - -data Term blk = forall a. TravWith a blk => Term a - --- | Result of type-checking. -data Prop blk - = OK - -- ^ Success. - | Error String - -- ^ Definite failure. - | forall a . AddExtraRef String (Metavar a blk) (Move' blk a) - -- ^ Experimental. - | And (Maybe [Term blk]) (MetaEnv (PB blk)) (MetaEnv (PB blk)) - -- ^ Parallel conjunction of constraints. - | Sidecondition (MetaEnv (PB blk)) (MetaEnv (PB blk)) - -- ^ Experimental, related to 'mcompoint'. - -- First arg is sidecondition. - | Or Prio (MetaEnv (PB blk)) (MetaEnv (PB blk)) - -- ^ Forking proof on something that is not part of the term language. - -- E.g. whether a term will reduce or not. - | ConnectHandle (OKHandle blk) (MetaEnv (PB blk)) - -- ^ Obsolete. - -data OKVal = OKVal -type OKHandle blk = MM OKVal blk -type OKMeta blk = Metavar OKVal blk - --- | Agsy's meta variables. --- --- @a@ the type of the metavariable (what it can be instantiated with). --- @blk@ the search control information (e.g. the scope of the meta). - -data Metavar a blk = Metavar - { mbind :: IORef (Maybe a) - -- ^ Maybe an instantiation (refinement). It is usually shallow, - -- i.e., just one construct(or) with arguments again being metas. - , mprincipalpresent :: IORef Bool - -- ^ Does this meta block a principal constraint - -- (i.e., a type-checking constraint). - , mobs :: IORef [(QPB a blk, Maybe (CTree blk))] - -- ^ List of observers, i.e., constraints blocked by this meta. - , mcompoint :: IORef [SubConstraints blk] - -- ^ Used for experiments with independence of subproofs. - , mextrarefs :: IORef [Move' blk a] - -- ^ Experimental. - } - -hequalMetavar :: Metavar a1 blk1 -> Metavar a2 bkl2 -> Bool -hequalMetavar m1 m2 = mprincipalpresent m1 == mprincipalpresent m2 - -instance Eq (Metavar a blk) where - x == y = hequalMetavar x y - -newMeta :: IORef [SubConstraints blk] -> IO (Metavar a blk) -newMeta mcompoint = do - bind <- newIORef Nothing - pp <- newIORef False - obs <- newIORef [] - erefs <- newIORef [] - return $ Metavar bind pp obs mcompoint erefs - -initMeta :: IO (Metavar a blk) -initMeta = do - cp <- newIORef [] - newMeta cp - -data CTree blk = CTree - {ctpriometa :: IORef (PrioMeta blk), - ctsub :: IORef (Maybe (SubConstraints blk)), - ctparent :: IORef (Maybe (CTree blk)), -- Nothing - root - cthandles :: IORef [OKMeta blk] - } - -data SubConstraints blk = SubConstraints - {scflip :: IORef Bool, - sccomcount :: IORef Int, - scsub1 :: CTree blk, - scsub2 :: CTree blk - } - - -newCTree :: Maybe (CTree blk) -> IO (CTree blk) -newCTree parent = do - priometa <- newIORef (NoPrio False) - sub <- newIORef Nothing - rparent <- newIORef parent - handles <- newIORef [] - return $ CTree priometa sub rparent handles - -newSubConstraints :: CTree blk -> IO (SubConstraints blk) -newSubConstraints node = do - flip <- newIORef True -- False -- initially (and always) True, trying out prefer rightmost subterm when none have priority - comcount <- newIORef 0 - sub1 <- newCTree $ Just node - sub2 <- newCTree $ Just node - return $ SubConstraints flip comcount sub1 sub2 - - -data PrioMeta blk = forall a . Refinable a blk => PrioMeta Prio (Metavar a blk) - | NoPrio Bool -- True if subconstraint is done (all OK) - -instance Eq (PrioMeta blk) where - NoPrio d1 == NoPrio d2 = d1 == d2 - PrioMeta p1 m1 == PrioMeta p2 m2 = p1 == p2 && hequalMetavar m1 m2 - _ == _ = False - --- ----------------------- - -data Restore = forall a . Restore (IORef a) a - -type Undo = StateT [Restore] IO - -ureadIORef :: IORef a -> Undo a -ureadIORef ptr = lift $ readIORef ptr - -uwriteIORef :: IORef a -> a -> Undo () -uwriteIORef ptr newval = do - oldval <- ureadIORef ptr - modify (Restore ptr oldval :) - lift $ NoUndo.writeIORef ptr newval - -umodifyIORef :: IORef a -> (a -> a) -> Undo () -umodifyIORef ptr f = do - oldval <- ureadIORef ptr - modify (Restore ptr oldval :) - lift $ NoUndo.writeIORef ptr (f oldval) - -ureadmodifyIORef :: IORef a -> (a -> a) -> Undo a -ureadmodifyIORef ptr f = do - oldval <- ureadIORef ptr - modify (Restore ptr oldval :) - lift $ NoUndo.writeIORef ptr (f oldval) - return oldval - -runUndo :: Undo a -> IO a -runUndo x = do - (res, restores) <- runStateT x [] - mapM_ (\(Restore ptr oldval) -> NoUndo.writeIORef ptr oldval) restores - return res - --- ----------------------- - -newtype RefCreateEnv blk a = RefCreateEnv - { runRefCreateEnv :: StateT ((IORef [SubConstraints blk]), Int) IO a } - -instance Functor (RefCreateEnv blk) where - fmap f = RefCreateEnv . fmap f . runRefCreateEnv - -instance Applicative (RefCreateEnv blk) where - pure = RefCreateEnv . pure - f <*> t = RefCreateEnv $ runRefCreateEnv f <*> runRefCreateEnv t - -instance Monad (RefCreateEnv blk) where - return = pure - t >>= f = RefCreateEnv $ runRefCreateEnv t >>= runRefCreateEnv . f - - -newtype Cost = Cost { getCost :: Int } - deriving (Num, Eq, Ord) - -data Move' blk a = Move - { moveCost :: Cost - , moveNext :: RefCreateEnv blk a - } - -class Refinable a blk where - refinements :: blk -> [blk] -> Metavar a blk -> IO [Move' blk a] - - -newPlaceholder :: RefCreateEnv blk (MM a blk) -newPlaceholder = RefCreateEnv $ do - (mcompoint, c) <- get - m <- lift $ newMeta mcompoint - put (mcompoint, (c + 1)) - return $ Meta m - -newOKHandle :: RefCreateEnv blk (OKHandle blk) -newOKHandle = RefCreateEnv $ do - (e, c) <- get - cp <- lift $ newIORef [] - m <- lift $ newMeta cp - put (e, (c + 1)) - return $ Meta m - -dryInstantiate :: RefCreateEnv blk a -> IO a -dryInstantiate bind = evalStateT (runRefCreateEnv bind) (__IMPOSSIBLE__, 0) - -type BlkInfo blk = (Bool, Prio, Maybe blk) -- Bool - is principal - -data MM a blk = NotM a - | Meta (Metavar a blk) - -rm :: Empty -> MM a b -> a -rm _ (NotM x) = x -rm e Meta{} = absurd e - -type MetaEnv = IO - - -data MB a blk = NotB a - | forall b . Refinable b blk => Blocked (Metavar b blk) (MetaEnv (MB a blk)) - | Failed String - -data PB blk = NotPB (Prop blk) - | forall b . Refinable b blk => PBlocked (Metavar b blk) (BlkInfo blk) (MetaEnv (PB blk)) - | forall b1 b2 . (Refinable b1 blk, Refinable b2 blk) => PDoubleBlocked (Metavar b1 blk) (Metavar b2 blk) (MetaEnv (PB blk)) - -data QPB b blk = QPBlocked (BlkInfo blk) (MetaEnv (PB blk)) - | QPDoubleBlocked (IORef Bool) (MetaEnv (PB blk)) -- flag set True by first observer that continues - -mmcase :: Refinable a blk => MM a blk -> (a -> MetaEnv (MB b blk)) -> MetaEnv (MB b blk) -mmcase x f = case x of - NotM x -> f x - x@(Meta m) -> do - bind <- readIORef $ mbind m - case bind of - Just x -> f x - Nothing -> return $ Blocked m (mmcase x f) - -mmmcase :: MM a blk -> MetaEnv (MB b blk) -> (a -> MetaEnv (MB b blk)) -> MetaEnv (MB b blk) -mmmcase x fm f = case x of - NotM x -> f x - Meta m -> do - bind <- readIORef $ mbind m - maybe fm f bind - -mmpcase :: Refinable a blk => BlkInfo blk -> MM a blk -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk) -mmpcase blkinfo x f = case x of - NotM x -> f x - x@(Meta m) -> do - bind <- readIORef $ mbind m - case bind of - Just x -> f x - Nothing -> return $ PBlocked m blkinfo (mmpcase __IMPOSSIBLE__ x f) -- blkinfo not needed because will be notb next time - -doubleblock :: (Refinable a blk, Refinable b blk) => MM a blk -> MM b blk -> MetaEnv (PB blk) -> MetaEnv (PB blk) -doubleblock (Meta m1) (Meta m2) cont = return $ PDoubleBlocked m1 m2 cont -doubleblock _ _ _ = __IMPOSSIBLE__ - -mbcase :: MetaEnv (MB a blk) -> (a -> MetaEnv (MB b blk)) -> MetaEnv (MB b blk) -mbcase x f = do - x' <- x - case x' of - NotB x -> f x - Blocked m x -> return $ Blocked m (mbcase x f) - Failed msg -> return $ Failed msg - -mbpcase :: Prio -> Maybe blk -> MetaEnv (MB a blk) -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk) -mbpcase prio bi x f = do - x' <- x - case x' of - NotB x -> f x - Blocked m x -> return $ PBlocked m (False, prio, bi) (mbpcase prio bi x f) - Failed msg -> return $ NotPB $ Error msg - -mmbpcase :: MetaEnv (MB a blk) -> (forall b . Refinable b blk => MM b blk -> MetaEnv (PB blk)) -> (a -> MetaEnv (PB blk)) -> MetaEnv (PB blk) -mmbpcase x fm f = do - x' <- x - case x' of - NotB x -> f x - Blocked m _ -> fm (Meta m) - Failed msg -> return $ NotPB $ Error msg - -waitok :: OKHandle blk -> MetaEnv (MB b blk) -> MetaEnv (MB b blk) -waitok okh f = - mmcase okh $ \ OKVal -> f -- principle constraint is never present for okhandle so it will not be refined - -mbret :: a -> MetaEnv (MB a blk) -mbret x = return $ NotB x - -mbfailed :: String -> MetaEnv (MB a blk) -mbfailed msg = return $ Failed msg - -mpret :: Prop blk -> MetaEnv (PB blk) -mpret p = return $ NotPB p - -expandbind :: MM a blk -> MetaEnv (MM a blk) -expandbind x = case x of - NotM{} -> return x - Meta m -> do - bind <- readIORef $ mbind m - case bind of - Just x -> return $ NotM x - Nothing -> return x - - --- ----------------------- - -type HandleSol = IO () - - -type SRes = Either Bool Int - -topSearch :: forall blk . IORef Int -> IORef Int -> HandleSol -> blk -> MetaEnv (PB blk) -> Cost -> Cost -> IO Bool -topSearch ticks nsol hsol envinfo p searchdepth depthinterval = do - depthreached <- newIORef False - - - mainroot <- newCTree Nothing - - let - searchSubProb :: [(CTree blk, Maybe (IORef Bool))] -> Cost -> IO SRes - searchSubProb [] depth = do - when (depth < depthinterval) $ do - - - hsol - n <- readIORef nsol - NoUndo.writeIORef nsol $! n - 1 - - - return $ Left True - searchSubProb ((root, firstdone) : restprobs) depth = - let - search :: Cost -> IO SRes - search depth = do - pm <- readIORef $ ctpriometa root - case pm of - NoPrio False -> return $ Left False -- nothing to refine but not done, this can happen when eq constraints are passed along with main constraint in agdaplugin - NoPrio True -> - searchSubProb restprobs depth -- ?? what should depth be - PrioMeta _ m -> do - let carryon = fork m depth - sub <- readIORef $ ctsub root - case sub of - Nothing -> carryon - Just sc -> do - let sub1 = scsub1 sc - sub2 = scsub2 sc - pm1 <- readIORef $ ctpriometa sub1 - pm2 <- readIORef $ ctpriometa sub2 - let split = carryon -- split disabled - case pm1 of - NoPrio True -> split - _ -> - case pm2 of - NoPrio True -> split - _ -> do - comc <- readIORef $ sccomcount sc - case comc of - 0 -> split - _ -> carryon - - fork :: forall a. Refinable a blk => Metavar a blk -> Cost -> IO SRes - fork m depth = do - blkinfos <- extractblkinfos m - refs <- refinements envinfo blkinfos m - f refs - where - f :: [Move' blk a] -> IO SRes - f [] = do - erefs <- readIORef $ mextrarefs m - case erefs of - [] -> return (Left False) - _ -> do - NoUndo.writeIORef (mextrarefs m) [] - f erefs - f (Move cost bind : binds) = hsres (refine m bind (depth - cost)) (f binds) - hsres :: IO SRes -> IO SRes -> IO SRes - hsres x1 x2 = do - res <- x1 - case res of - Right _ -> return res - Left found -> do - n <- readIORef nsol - if n == 0 then - return res - else do - res2 <- x2 - case res2 of - Right _ -> if found then __IMPOSSIBLE__ else return res2 - Left found2 -> return $ Left (found || found2) - - refine :: Metavar a blk -> RefCreateEnv blk a -> Cost -> IO SRes - - refine _ _ depthleft | depthleft < 0 = do - NoUndo.writeIORef depthreached True - return $ Left False - - - refine m bind depthleft = runUndo $ - do t <- ureadIORef ticks - lift $ NoUndo.writeIORef ticks $! t + 1 - - - (bind, (_, nnewmeta)) <- lift $ runStateT (runRefCreateEnv bind) (mcompoint m, 0) - uwriteIORef (mbind m) (Just bind) - mcomptr <- ureadIORef $ mcompoint m - mapM_ (\comptr -> - umodifyIORef (sccomcount comptr) (+ (nnewmeta - 1)) - -- umodifyIORef (scflip comptr) not -- don't flip now since trying prefer rightmost subterm if non have prio - ) mcomptr - obs <- ureadIORef (mobs m) - res <- recalcs obs - if res - then - return $ Left False -- failed - else - lift $ search depthleft -- succeeded - - doit = do - res <- search depth - return $ case res of - Right n -> - case firstdone of - Nothing -> - if n == 0 then - Left False - else - Right (n - 1) - Just _ -> - Right (n + 1) - res@(Left True) -> res - res@(Left False) -> - case firstdone of - Nothing -> res - Just _ -> Right 0 - in - case firstdone of - Nothing -> doit - Just rdone -> do - done <- readIORef rdone - if done then - searchSubProb restprobs depth - else do - NoUndo.writeIORef rdone True - doit - - runUndo $ do - res <- reccalc p (Just mainroot) - if res -- failed immediately - then - return False - else - do - Left _solFound <- lift $ searchSubProb [(mainroot, Nothing)] searchdepth - lift $ readIORef depthreached - - -extractblkinfos :: Metavar a blk -> IO [blk] -extractblkinfos m = do - obs <- readIORef $ mobs m - return $ f obs - where - f [] = [] - f ((QPBlocked (_,_,mblkinfo) _, _) : cs) = - case mblkinfo of - Nothing -> f cs - Just blkinfo -> blkinfo : f cs - f ((QPDoubleBlocked{}, _) : cs) = f cs - -recalcs :: [(QPB a blk, Maybe (CTree blk))] -> Undo Bool -recalcs cs = foldr (seqc . recalc) (return False) cs - -seqc :: Undo Bool -> Undo Bool -> Undo Bool -seqc x y = do - res1 <- x - case res1 of - res1@True -> return res1 - False -> y - -recalc :: (QPB a blk, Maybe (CTree blk)) -> Undo Bool -recalc (con, node) = case con of - QPBlocked _ cont -> reccalc cont node - QPDoubleBlocked flag cont -> do - fl <- ureadIORef flag - if fl - then return False - else do - uwriteIORef flag True - reccalc cont node - -reccalc :: MetaEnv (PB blk) -> Maybe (CTree blk) -> Undo Bool -reccalc cont node = do - res <- calc cont node - case res of - Nothing -> return True - Just pendhandles -> - foldM - ( \res1 h -> - if res1 - then return res1 - else do - uwriteIORef (mbind h) $ Just OKVal - obs <- ureadIORef (mobs h) - recalcs obs - ) - False - pendhandles - -calc :: forall blk . MetaEnv (PB blk) -> Maybe (CTree blk) -> Undo (Maybe [OKMeta blk]) -calc cont node = do - res <- donewp node cont - case res of - Just (_, pendhandles) -> do - pendhandles2 <- case node of - Just node -> propagatePrio node - Nothing -> return [] - return $ Just (pendhandles ++ pendhandles2) - Nothing -> return Nothing - where - storeprio (Just node) pm pendhandles = do - pendhandles' <- case pm of - NoPrio True -> do - handles <- ureadIORef (cthandles node) - return $ handles ++ pendhandles - _ -> return pendhandles - uwriteIORef (ctpriometa node) pm - return $ Just (pm, pendhandles') - storeprio Nothing _ _ = - return $ Just (NoPrio False, []) - donewp node p = do - bp <- lift p - case bp of - NotPB p -> - doprop node p - PBlocked m blkinfo cont -> do - oldobs <- ureadmodifyIORef (mobs m) ((QPBlocked blkinfo cont, node) :) - let (princ, prio, _) = blkinfo - pp <- ureadIORef (mprincipalpresent m) - when (princ && not pp) $ do - uwriteIORef (mprincipalpresent m) True - mapM_ (\(qpb, node) -> case node of - Just node -> - case qpb of - QPBlocked (_, prio, _) _ -> do - - - uwriteIORef (ctpriometa node) (PrioMeta prio m) - propagatePrio node - QPDoubleBlocked _flag _ -> - return [] - Nothing -> return [] - ) oldobs - if pp || princ then - storeprio node (PrioMeta prio m) [] - else - storeprio node (NoPrio False) [] - PDoubleBlocked m1 m2 cont -> do - flag <- lift $ newIORef False - - let newobs :: forall b. [(QPB b blk, Maybe (CTree blk))] - -> [(QPB b blk, Maybe (CTree blk))] - newobs = ((QPDoubleBlocked flag cont, node) :) - umodifyIORef (mobs m1) newobs - umodifyIORef (mobs m2) newobs - storeprio node (NoPrio False) [] - doprop node p = - case p of - OK -> storeprio node (NoPrio True) [] - Error _ -> return Nothing - - - AddExtraRef _ m eref -> do - lift $ NoUndo.modifyIORef (mextrarefs m) (eref :) - return Nothing - And coms p1 p2 -> do - let Just jnode = node - sc <- lift $ newSubConstraints jnode - - - uwriteIORef (ctsub jnode) $ Just sc - ndep <- case coms of - Nothing -> return 1 -- no metas pointing to it so will never decrement to 0 - Just _coms -> return 1 -- dito - lift $ NoUndo.writeIORef (sccomcount sc) ndep -- OK since sc was just created - resp1 <- donewp (Just $ scsub1 sc) p1 - case resp1 of - Just (pm1, phs1) -> do - resp2 <- donewp (Just $ scsub2 sc) p2 - case resp2 of - Just (pm2, phs2) -> - storeprio node (choosePrioMeta False pm1 pm2) (phs1 ++ phs2) - resp2@Nothing -> return resp2 - resp1@Nothing -> return resp1 - Sidecondition sidep mainp -> do - resp1 <- donewp Nothing sidep - case resp1 of - Just{} -> do - resp2 <- donewp node mainp - case resp2 of - Just (pm2, phs2) -> - storeprio node pm2 phs2 - resp2@Nothing -> return resp2 - resp1@Nothing -> return resp1 - Or prio p1 p2 -> do - cm <- lift $ initMeta - donewp node (choose (Meta cm) prio p1 p2) - ConnectHandle (Meta handle) p' -> do - let Just jnode = node - umodifyIORef (cthandles jnode) (handle :) - donewp node p' - ConnectHandle (NotM _) _ -> __IMPOSSIBLE__ - -choosePrioMeta :: Bool -> PrioMeta blk -> PrioMeta blk -> PrioMeta blk -choosePrioMeta flip pm1@(PrioMeta p1 _) pm2@(PrioMeta p2 _) - | p1 > p2 = pm1 - | p2 > p1 = pm2 - | flip = pm2 - | otherwise = pm1 -choosePrioMeta _ pm@(PrioMeta _ _) (NoPrio _) = pm -choosePrioMeta _ (NoPrio _) pm@(PrioMeta _ _) = pm -choosePrioMeta _ (NoPrio d1) (NoPrio d2) = NoPrio (d1 && d2) - -propagatePrio :: CTree blk -> Undo [OKMeta blk] -propagatePrio node = do - parent <- lift $ readIORef $ ctparent node - case parent of - Nothing -> return [] - Just parent -> do - Just sc <- ureadIORef (ctsub parent) - pm1 <- ureadIORef $ ctpriometa $ scsub1 sc - pm2 <- ureadIORef $ ctpriometa $ scsub2 sc - flip <- ureadIORef $ scflip sc - let pm = choosePrioMeta flip pm1 pm2 - opm <- ureadIORef (ctpriometa parent) - if (pm /= opm) - then do - uwriteIORef (ctpriometa parent) pm - phs <- case pm of - NoPrio True -> ureadIORef (cthandles parent) - _ -> return [] - phs2 <- propagatePrio parent - return $ phs ++ phs2 - else - return [] - -data Choice = LeftDisjunct | RightDisjunct - -choose :: MM Choice blk -> Prio -> MetaEnv (PB blk) -> MetaEnv (PB blk) -> MetaEnv (PB blk) -choose c prio p1 p2 = - mmpcase (True, prio, Nothing) c $ \c -> case c of - LeftDisjunct -> p1 - RightDisjunct -> p2 - -instance Refinable Choice blk where - refinements _ _ _ = return $ Move 0 . return <$> [LeftDisjunct, RightDisjunct] - - -instance Refinable OKVal blk where - refinements _ _ _ = __IMPOSSIBLE__ -- OKVal should never be refined - - --- ------------------------------------ diff --git a/src/full/Agda/Auto/Options.hs b/src/full/Agda/Auto/Options.hs deleted file mode 100644 --- a/src/full/Agda/Auto/Options.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# OPTIONS_GHC -Wunused-imports #-} - -module Agda.Auto.Options where - -import Data.Char -import Control.Monad.State -import Agda.Utils.Lens - -data Mode = MNormal Bool Bool -- true if list mode, true if disprove - - | MCaseSplit - - | MRefine Bool -- true if list mode - - -data AutoHintMode = AHMNone - | AHMModule - -type Hints = [String] - -newtype TimeOut = TimeOut { getTimeOut :: Int } -- in ms - -instance Show TimeOut where - show = show . getTimeOut - --- | Options for Auto, default value and lenses - -data AutoOptions = AutoOptions - { autoHints :: Hints - , autoTimeOut :: TimeOut - , autoPick :: Int - , autoMode :: Mode - , autoHintMode :: AutoHintMode - } - -initAutoOptions :: AutoOptions -initAutoOptions = AutoOptions - { autoHints = [] - , autoTimeOut = TimeOut 1000 - , autoPick = 0 - , autoMode = MNormal False False - , autoHintMode = AHMNone - } - -aoHints :: Lens' AutoOptions Hints -aoHints f s = - f (autoHints s) <&> - \x -> s {autoHints = x} - -aoTimeOut :: Lens' AutoOptions TimeOut -aoTimeOut f s = - f (autoTimeOut s) <&> - \x -> s {autoTimeOut = x} - -aoPick :: Lens' AutoOptions Int -aoPick f s = - f (autoPick s) <&> - \x -> s {autoPick = x} - -aoMode :: Lens' AutoOptions Mode -aoMode f s = - f (autoMode s) <&> - \x -> s {autoMode = x} - -aoHintMode :: Lens' AutoOptions AutoHintMode -aoHintMode f s = - f (autoHintMode s) <&> - \x -> s {autoHintMode = x} - --- | Tokenising the input (makes `parseArgs` cleaner) - -data AutoToken = - M | C | R | D | L - | T String | S Int | H String - -autoTokens :: [String] -> [AutoToken] -autoTokens [] = [] -autoTokens ("-t" : t : ws) = T t : autoTokens ws -autoTokens ("-s" : s : ws) = S (read s) : autoTokens ws -autoTokens ("-l" : ws) = L : autoTokens ws -autoTokens ("-d" : ws) = D : autoTokens ws -autoTokens ("-m" : ws) = M : autoTokens ws -autoTokens ("-c" : ws) = C : autoTokens ws -autoTokens ("-r" : ws) = R : autoTokens ws -autoTokens (h : ws) = H h : autoTokens ws - -parseTime :: String -> Int -parseTime [] = 0 -parseTime xs = read ds * modifier + parseTime r where - (ds , modr) = span isDigit xs - (mod , r) = break isDigit modr - - modifier = case mod of - "ms" -> 1 - "cs" -> 10 - "ds" -> 100 - "s" -> 1000 - _ -> 1000 - -parseArgs :: String -> AutoOptions -parseArgs s = mapM_ step (autoTokens $ words s) - `execState` initAutoOptions where - - step :: AutoToken -> State AutoOptions () - step M = aoHintMode .= AHMModule - step C = aoMode .= MCaseSplit - step R = aoPick .= (-1) - >> aoMode .= MRefine False - step (T t) = aoTimeOut .= TimeOut (parseTime t) - step (S p) = aoPick .= p - step (H h) = aoHints %= (h :) - step D = do - mode <- use aoMode - case mode of - MNormal lm _ -> aoMode .= MNormal lm True - _ -> return () - step L = do - mode <- use aoMode - case mode of - MNormal _ dp -> aoMode .= MNormal True dp - MRefine _ -> aoMode .= MRefine True - _ -> return () diff --git a/src/full/Agda/Auto/SearchControl.hs b/src/full/Agda/Auto/SearchControl.hs deleted file mode 100644 --- a/src/full/Agda/Auto/SearchControl.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -Wunused-imports #-} -{-# OPTIONS_GHC -Wno-orphans #-} -#if __GLASGOW_HASKELL__ > 907 -{-# OPTIONS_GHC -Wno-x-partial #-} -#endif - - - -module Agda.Auto.SearchControl where - -import Control.Monad -import Data.IORef -import Control.Monad.State -import Data.Maybe (mapMaybe, fromMaybe) - -import Agda.Syntax.Common (Hiding(..)) -import Agda.Auto.NarrowingSearch -import Agda.Auto.Syntax - -import Agda.Utils.Impossible - -instance Refinable (ArgList o) (RefInfo o) where - refinements _ infos _ = return $ fmap (Move 0) $ - [ return ALNil, cons NotHidden, cons Hidden ] - ++ if getIsDep infos then [] - else [ proj NotHidden, proj Hidden ] - - where - - getIsDep :: [RefInfo o] -> Bool - getIsDep (x : xs) = case x of - RICheckElim isDep -> isDep - _ -> getIsDep xs - getIsDep _ = __IMPOSSIBLE__ - - proj :: Hiding -> RefCreateEnv (RefInfo o) (ArgList o) - proj hid = ALProj <$> newPlaceholder <*> newPlaceholder - <*> return hid <*> newPlaceholder - - cons :: Hiding -> RefCreateEnv (RefInfo o) (ArgList o) - cons hid = ALCons hid <$> newPlaceholder <*> newPlaceholder - - -data ExpRefInfo o = ExpRefInfo - { eriMain :: Maybe (RefInfo o) - , eriUnifs :: [RefInfo o] - , eriInfTypeUnknown :: Bool - , eriIsEliminand :: Bool - , eriUsedVars :: Maybe ([UId o], [Elr o]) - , eriIotaStep :: Maybe Bool - , eriPickSubsVar :: Bool - , eriEqRState :: Maybe EqReasoningState - } - -initExpRefInfo :: ExpRefInfo o -initExpRefInfo = ExpRefInfo - { eriMain = Nothing - , eriUnifs = [] - , eriInfTypeUnknown = False - , eriIsEliminand = False - , eriUsedVars = Nothing - , eriIotaStep = Nothing - , eriPickSubsVar = False - , eriEqRState = Nothing - } - -getinfo :: [RefInfo o] -> ExpRefInfo o -getinfo = foldl step initExpRefInfo where - - step :: ExpRefInfo o -> RefInfo o -> ExpRefInfo o - step eri x@RIMainInfo{} = eri { eriMain = Just x } - step eri x@RIUnifInfo{} = eri { eriUnifs = x : eriUnifs eri } - step eri RIInferredTypeUnknown = eri { eriInfTypeUnknown = True } - step eri RINotConstructor = eri { eriIsEliminand = True } - step eri (RIUsedVars nuids nused) = eri { eriUsedVars = Just (nuids, nused) } - step eri (RIIotaStep semif) = eri { eriIotaStep = Just iota' } where - iota' = semif || (Just True ==) (eriIotaStep eri) - step eri RIPickSubsvar = eri { eriPickSubsVar = True } - step eri (RIEqRState s) = eri { eriEqRState = Just s } - step eri _ = __IMPOSSIBLE__ - - --- | @univar sub v@ figures out what the name of @v@ "outside" of --- the substitution @sub@ ought to be, if anything. - -univar :: [CAction o] -> Nat -> Maybe Nat -univar cl v = getOutsideName cl v 0 where - - getOutsideName :: [CAction o] -> Nat -> Nat -> Maybe Nat - -- @v@ is offset by @v'@ binders - getOutsideName [] v v' = Just (v' + v) - -- @v@ was introduced by the weakening: disappears - getOutsideName (Weak n : _) v v' | v < n = Nothing - -- @v@ was introduced before the weakening: strengthened - getOutsideName (Weak n : xs) v v' = getOutsideName xs (v - n) v' - -- Name of @v@ before the substitution was pushed in - -- had to be offset by 1 - getOutsideName (Sub _ : xs) v v' = getOutsideName xs v (v' + 1) - -- If this is the place where @v@ was bound, it used to - -- be called 0 + offset of all the vars substituted for - getOutsideName (Skip : _) 0 v' = Just v' - -- Going over a binder: de Bruijn name of @v@ decreased - -- but offset increased - getOutsideName (Skip : xs) v v' = getOutsideName xs (v - 1) (v' + 1) - --- | List of the variables instantiated by the substitution -subsvars :: [CAction o] -> [Nat] -subsvars = f 0 where - - f :: Nat -> [CAction o] -> [Nat] - f n [] = [] - f n (Weak _ : xs) = f n xs -- why? - f n (Sub _ : xs) = n : f (n + 1) xs - f n (Skip : xs) = f (n + 1) xs - --- | Moves --- A move is composed of a @Cost@ together with an action --- computing the refined problem. - -type Move o = Move' (RefInfo o) (Exp o) - --- | New constructors --- Taking a step towards a solution consists in picking a --- constructor and filling in the missing parts with --- placeholders to be discharged later on. - -newAbs :: MId -> RefCreateEnv blk (Abs (MM a blk)) -newAbs mid = Abs mid <$> newPlaceholder - -newLam :: Hiding -> MId -> RefCreateEnv (RefInfo o) (Exp o) -newLam hid mid = Lam hid <$> newAbs mid - -newPi :: UId o -> Bool -> Hiding -> RefCreateEnv (RefInfo o) (Exp o) -newPi uid dep hid = Pi (Just uid) hid dep <$> newPlaceholder <*> newAbs NoId - -foldArgs :: [(Hiding, MExp o)] -> MArgList o -foldArgs = foldr (\ (h, a) sp -> NotM $ ALCons h a sp) (NotM ALNil) - --- | New spine of arguments potentially using placeholders - -newArgs' :: [Hiding] -> [MExp o] -> RefCreateEnv (RefInfo o) (MArgList o) -newArgs' h tms = foldArgs . zip h . (++ tms) <$> replicateM size newPlaceholder - where size = length h - length tms - -newArgs :: [Hiding] -> RefCreateEnv (RefInfo o) (MArgList o) -newArgs h = newArgs' h [] - --- | New @App@lication node using a new spine of arguments --- respecting the @Hiding@ annotation - -newApp' :: UId o -> ConstRef o -> [Hiding] -> [MExp o] -> - RefCreateEnv (RefInfo o) (Exp o) -newApp' meta cst hds tms = - App (Just meta) <$> newOKHandle <*> return (Const cst) <*> newArgs' hds tms - -newApp :: UId o -> ConstRef o -> [Hiding] -> RefCreateEnv (RefInfo o) (Exp o) -newApp meta cst hds = newApp' meta cst hds [] - --- | Equality reasoning steps --- The begin token is accompanied by two steps because --- it does not make sense to have a derivation any shorter --- than that. - -eqStep :: UId o -> EqReasoningConsts o -> Move o -eqStep meta eqrc = Move costEqStep $ newApp meta (eqrcStep eqrc) - [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden] - -eqEnd :: UId o -> EqReasoningConsts o -> Move o -eqEnd meta eqrc = Move costEqEnd $ newApp meta (eqrcEnd eqrc) - [Hidden, Hidden, NotHidden] - -eqCong :: UId o -> EqReasoningConsts o -> Move o -eqCong meta eqrc = Move costEqCong $ newApp meta (eqrcCong eqrc) - [Hidden, Hidden, Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden] - -eqSym :: UId o -> EqReasoningConsts o -> Move o -eqSym meta eqrc = Move costEqSym $ newApp meta (eqrcSym eqrc) - [Hidden, Hidden, Hidden, Hidden, NotHidden] - -eqBeginStep2 :: UId o -> EqReasoningConsts o -> Move o -eqBeginStep2 meta eqrc = Move costEqStep $ do - e1 <- newApp meta (eqrcStep eqrc) - [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden] - e2 <- newApp' meta (eqrcStep eqrc) - [Hidden, Hidden, NotHidden, Hidden, Hidden, NotHidden, NotHidden] - [NotM e1] - newApp' meta (eqrcBegin eqrc) [Hidden, Hidden, Hidden, Hidden, NotHidden] - [NotM e2] - - --- | Pick the first unused UId amongst the ones you have seen (GA: ??) --- Defaults to the head of the seen ones. - -pickUid :: forall o. [UId o] -> [Maybe (UId o)] -> (Maybe (UId o), Bool) -pickUid used seen = maybe (head seen, False) (, True) $ firstUnused seen where - {- ?? which uid to pick -} - - firstUnused :: [Maybe (UId o)] -> Maybe (Maybe (UId o)) - firstUnused [] = Nothing - firstUnused (Nothing : _) = Just Nothing - firstUnused (mu@(Just u) : us) = - if u `elem` used then firstUnused us else Just mu - -instance Refinable (Exp o) (RefInfo o) where - refinements envinfo infos meta = - let - hints = rieHints envinfo - deffreevars = rieDefFreeVars envinfo - - meqr = rieEqReasoningConsts envinfo - - ExpRefInfo { eriMain = Just (RIMainInfo n tt iotastepdone) - , eriUnifs = unis - , eriInfTypeUnknown = inftypeunknown - , eriIsEliminand = iseliminand -- TODO:: Defined but not used - , eriUsedVars = Just (uids, usedvars) - , eriIotaStep = iotastep - , eriPickSubsVar = picksubsvar -- TODO:: Defined but not used - , eriEqRState = meqrstate - } = getinfo infos - - eqrstate = fromMaybe EqRSNone meqrstate - - set l = return $ Sort (Set l) - in case unis of - [] -> - let - - eqr = fromMaybe __IMPOSSIBLE__ meqr - eq_end = eqEnd meta eqr - eq_step = eqStep meta eqr - eq_cong = eqCong meta eqr - eq_sym = eqSym meta eqr - eq_begin_step2 = eqBeginStep2 meta eqr - - adjustCost i = if inftypeunknown then costInferredTypeUnkown else i - varcost v | v < n - deffreevars = adjustCost $ - if v `elem` (mapMaybe getVar usedvars) - then costAppVarUsed else costAppVar - varcost v | otherwise = adjustCost costAppHint - varapps = map (\ v -> Move (varcost v) $ app n meta Nothing (Var v)) [0..n - 1] - hintapps = map (\(c, hm) -> Move (cost c hm) (app n meta Nothing (Const c))) hints - where - cost :: ConstRef o -> HintMode -> Cost - cost c hm = adjustCost $ case (iotastep , hm) of - (Just _ , _ ) -> costIotaStep - (Nothing , HMNormal) -> - if c `elem` (mapMaybe getConst usedvars) - then costAppHintUsed else costAppHint - (Nothing , HMRecCall) -> - if c `elem` (mapMaybe getConst usedvars) - then costAppRecCallUsed else costAppRecCall - generics = varapps ++ hintapps - in case rawValue tt of - - _ | eqrstate == EqRSChain -> - return [eq_end, eq_step] - - HNPi hid _ _ (Abs id _) -> return $ - Move (adjustCost (if iotastepdone then costLamUnfold else costLam)) (newLam hid id) - : Move costAbsurdLam (return $ AbsurdLambda hid) - : generics - - HNSort (Set l) -> return $ - map (Move (adjustCost costSort) . set) [0..l - 1] - ++ map (Move (adjustCost costPi) . newPi meta True) [NotHidden, Hidden] - ++ generics - - - HNApp (Const c) _ -> do - cd <- readIORef c - return $ case cdcont cd of - - Datatype cons _ | eqrstate == EqRSNone -> - map (\c -> Move (adjustCost $ case iotastep of - Just True -> costUnification - _ -> if length cons <= 1 - then costAppConstructorSingle - else costAppConstructor) - $ app n meta Nothing (Const c)) cons - ++ generics - ++ (guard (maybe False ((c ==) . eqrcId) meqr) - *> [eq_sym, eq_cong, eq_begin_step2]) - - _ | eqrstate == EqRSPrf1 -> generics ++ [eq_sym, eq_cong] - _ | eqrstate == EqRSPrf2 -> generics ++ [eq_cong] - - _ -> generics - _ -> return generics - (RIUnifInfo cl hne : _) -> - let - subsvarapps = map (Move costUnification . app n meta Nothing . Var) (subsvars cl) - mlam = case rawValue tt of - HNPi hid _ _ (Abs id _) -> [Move costUnification (newLam hid id)] - _ -> [] - generics = mlam ++ subsvarapps - - in - return $ case rawValue hne of - HNApp (Var v) _ -> - let (uid, isunique) = pickUid uids $ seenUIds hne - uni = case univar cl v of - Just v | v < n -> [Move (costUnificationIf isunique) $ app n meta uid (Var v)] - _ -> [] - in uni ++ generics - HNApp (Const c) _ -> - let (uid, isunique) = pickUid uids $ seenUIds hne - in Move (costUnificationIf isunique) (app n meta uid (Const c)) : generics - HNLam{} -> generics - HNPi hid possdep _ _ -> - let (uid, isunique) = pickUid uids $ seenUIds hne - in Move (costUnificationIf isunique) (newPi (fromMaybe meta uid) possdep hid) : generics - HNSort (Set l) -> map (Move costUnification . set) [0..l] ++ generics - HNSort _ -> generics - _ -> __IMPOSSIBLE__ - - where - - app :: Nat -> UId o -> Maybe (UId o) -> Elr o -> - RefCreateEnv (RefInfo o) (Exp o) - app n meta muid elr = do - p <- newPlaceholder - p <- case elr of - Var{} -> return p - Const c -> do - cd <- RefCreateEnv $ lift $ readIORef c - let dfvapp 0 _ = p - dfvapp i n = NotM $ ALCons NotHidden - (NotM $ App Nothing (NotM $ OKVal) (Var n) (NotM ALNil)) - (dfvapp (i - 1) (n - 1)) - -- NotHidden is ok because agda reification throws these arguments - -- away and agsy skips typechecking them - return $ dfvapp (cddeffreevars cd) (n - 1) - okh <- newOKHandle - return $ App (Just $ fromMaybe meta muid) okh elr p - - -extraref :: UId o -> [Maybe (UId o)] -> ConstRef o -> Move o -extraref meta seenuids c = Move costAppExtraRef $ app (head seenuids) (Const c) - where - app muid elr = App (Just $ fromMaybe meta muid) - <$> newOKHandle <*> return elr <*> newPlaceholder - -instance Refinable (ICExp o) (RefInfo o) where - refinements _ infos _ = - let (RICopyInfo e : _) = infos - in return [Move 0 (return e)] - - -instance Refinable (ConstRef o) (RefInfo o) where - refinements _ [RICheckProjIndex projs] _ = return $ map (Move 0 . return) projs - refinements _ _ _ = __IMPOSSIBLE__ - - --- --------------------------------- - -costIncrease, costUnificationOccurs, costUnification, costAppVar, - costAppVarUsed, costAppHint, costAppHintUsed, costAppRecCall, - costAppRecCallUsed, costAppConstructor, costAppConstructorSingle, - costAppExtraRef, costLam, costLamUnfold, costPi, costSort, costIotaStep, - costInferredTypeUnkown, costAbsurdLam - :: Cost - -costUnificationIf :: Bool -> Cost -costUnificationIf b = if b then costUnification else costUnificationOccurs - -costIncrease = 1000 -costUnificationOccurs = 100 -- 1000001 -- 1 -- 100 -costUnification = 0000 -costAppVar = 0000 -- 0, 1 -costAppVarUsed = 1000 -- 5 -costAppHint = 3000 -- 2, 5 -costAppHintUsed = 5000 -costAppRecCall = 0 -- 1000? -costAppRecCallUsed = 10000 -- 1000? -costAppConstructor = 1000 -costAppConstructorSingle = 0000 -costAppExtraRef = 1000 -costLam = 0000 -- 1, 0 -costLamUnfold = 1000 -- 1, 0 -costPi = 1000003 -- 100 -- 5 -costSort = 1000004 -- 0 -costIotaStep = 3000 -- 1000005 -- 2 -- 100 -costInferredTypeUnkown = 1000006 -- 100 -costAbsurdLam = 0 - -costEqStep, costEqEnd, costEqSym, costEqCong :: Cost -costEqStep = 2000 -costEqEnd = 0 -costEqSym = 0 -costEqCong = 500 - -prioNo, prioTypeUnknown, prioTypecheckArgList, prioInferredTypeUnknown, - prioCompBeta, prioCompBetaStructured, prioCompareArgList, prioCompIota, - prioCompChoice, prioCompUnif, prioCompCopy, prioNoIota, prioAbsurdLambda, - prioProjIndex - :: Prio -prioNo = (-1) -prioTypeUnknown = 0 -prioTypecheckArgList = 3000 -prioInferredTypeUnknown = 4000 -prioCompBeta = 4000 -prioCompBetaStructured = 4000 -prioCompIota = 4000 -prioCompChoice = 5000 -- 700 -- 5000 -prioCompUnif = 6000 -- 2 -prioCompCopy = 8000 -prioCompareArgList = 7000 -- 5 -- 2 -prioNoIota = 500 -- 500 -prioAbsurdLambda = 1000 - -prioProjIndex = 3000 - -prioTypecheck :: Bool -> Prio -prioTypecheck False = 1000 -prioTypecheck True = 0 - --- --------------------------------- - -instance Trav a => Trav [a] where - type Block [a] = Block a - trav _ [] = return () - trav f (x:xs) = trav f x >> trav f xs - -instance Trav (MId, CExp o) where - type Block (MId, CExp o) = RefInfo o - trav f (_, ce) = trav f ce - -instance Trav (TrBr a o) where - type Block (TrBr a o) = RefInfo o - trav f (TrBr es _) = trav f es - -instance Trav (Exp o) where - type Block (Exp o) = RefInfo o - trav f = \case - App _ _ _ args -> trav f args - Lam _ (Abs _ b) -> trav f b - Pi _ _ _ it (Abs _ ot) -> trav f it >> trav f ot - Sort _ -> return () - AbsurdLambda{} -> return () - -instance Trav (ArgList o) where - type Block (ArgList o) = RefInfo o - trav _ ALNil = return () - trav f (ALCons _ arg args) = trav f arg >> trav f args - trav f (ALProj eas _ _ as) = trav f eas >> trav f as - trav f (ALConPar args) = trav f args - --- --------------------------------- diff --git a/src/full/Agda/Auto/Syntax.hs b/src/full/Agda/Auto/Syntax.hs deleted file mode 100644 --- a/src/full/Agda/Auto/Syntax.hs +++ /dev/null @@ -1,463 +0,0 @@ -{-# OPTIONS_GHC -Wunused-imports #-} - -module Agda.Auto.Syntax where - -import Data.IORef -import qualified Data.Set as Set - -import Agda.Syntax.Common (Hiding) -import Agda.Auto.NarrowingSearch - -import Agda.Utils.Impossible - --- | Unique identifiers for variable occurrences in unification. -type UId o = Metavar (Exp o) (RefInfo o) - -data HintMode = HMNormal - | HMRecCall - -data EqReasoningConsts o = EqReasoningConsts - { eqrcId -- "_≡_" - , eqrcBegin -- "begin_" - , eqrcStep -- "_≡⟨_⟩_" - , eqrcEnd -- "_∎" - , eqrcSym -- "sym" - , eqrcCong -- "cong" - :: ConstRef o - } - -data EqReasoningState = EqRSNone | EqRSChain | EqRSPrf1 | EqRSPrf2 | EqRSPrf3 - deriving (Eq, Show) - --- | The concrete instance of the 'blk' parameter in 'Metavar'. --- I.e., the information passed to the search control. - -data RefInfo o - = RIEnv - { rieHints :: [(ConstRef o, HintMode)] - , rieDefFreeVars :: Nat - -- ^ Nat - deffreevars - -- (to make cost of using module parameters correspond to that of hints). - , rieEqReasoningConsts :: Maybe (EqReasoningConsts o) - } - | RIMainInfo - { riMainCxtLength :: Nat - -- ^ Size of typing context in which meta was created. - , riMainType :: HNExp o - -- ^ Head normal form of type of meta. - , riMainIota :: Bool - -- ^ True if iota steps performed when normalising target type - -- (used to put cost when traversing a definition - -- by construction instantiation). - } - | RIUnifInfo [CAction o] (HNExp o) - -- meta environment, opp hne - | RICopyInfo (ICExp o) - | RIIotaStep Bool -- True - semiflex - | RIInferredTypeUnknown - | RINotConstructor - | RIUsedVars [UId o] [Elr o] - | RIPickSubsvar - - | RIEqRState EqReasoningState - - - | RICheckElim Bool -- isdep - | RICheckProjIndex [ConstRef o] -- noof proj functions - - -type MyPB o = PB (RefInfo o) -type MyMB a o = MB a (RefInfo o) - -type Nat = Int - -data MId = Id String - | NoId - --- | Abstraction with maybe a name. --- --- Different from Agda, where there is also info --- whether function is constant. -data Abs a = Abs MId a - --- | Constant signatures. - -data ConstDef o = ConstDef - { cdname :: String - -- ^ For debug printing. - , cdorigin :: o - -- ^ Reference to the Agda constant. - , cdtype :: MExp o - -- ^ Type of constant. - , cdcont :: DeclCont o - -- ^ Constant definition. - , cddeffreevars :: Nat - -- ^ Free vars of the module where the constant is defined.. - } -- contains no metas - --- | Constant definitions. - -data DeclCont o - = Def Nat [Clause o] (Maybe Nat) -- maybe an index to elimand argument - (Maybe Nat) -- maybe index to elim arg if semiflex - | Datatype [ConstRef o] -- constructors - [ConstRef o] -- projection functions (in case it is a record) - - | Constructor Nat -- number of omitted args - | Postulate - -type Clause o = ([Pat o], MExp o) - -data Pat o - = PatConApp (ConstRef o) [Pat o] - | PatVar String - | PatExp - -- ^ Dot pattern. - | PatProj (ConstRef o) - -- ^ Projection pattern. - -type ConstRef o = IORef (ConstDef o) - --- | Head of application (elimination). -data Elr o - = Var Nat - | Const (ConstRef o) - deriving (Eq) - -getVar :: Elr o -> Maybe Nat -getVar (Var n) = Just n -getVar Const{} = Nothing - -getConst :: Elr o -> Maybe (ConstRef o) -getConst (Const c) = Just c -getConst Var{} = Nothing - -data Sort - = Set Nat - | UnknownSort - | Type - --- | Agsy's internal syntax. -data Exp o - = App - { appUId :: Maybe (UId o) - -- ^ Unique identifier of the head. - , appOK :: OKHandle (RefInfo o) - -- ^ This application has been type-checked. - , appHead :: Elr o - -- ^ Head. - , appElims :: MArgList o - -- ^ Arguments. - } - | Lam Hiding (Abs (MExp o)) - -- ^ Lambda with hiding information. - | Pi (Maybe (UId o)) Hiding Bool (MExp o) (Abs (MExp o)) - -- ^ @True@ if possibly dependent (var not known to not occur). - -- @False@ if non-dependent. - | Sort Sort - | AbsurdLambda Hiding - -- ^ Absurd lambda with hiding information. - -dontCare :: Exp o -dontCare = Sort UnknownSort - --- | "Maybe expression": Expression or reference to meta variable. -type MExp o = MM (Exp o) (RefInfo o) - -data ArgList o - = ALNil - -- ^ No more eliminations. - | ALCons Hiding (MExp o) (MArgList o) - -- ^ Application and tail. - - | ALProj (MArgList o) (MM (ConstRef o) (RefInfo o)) Hiding (MArgList o) - -- ^ proj pre args, projfcn idx, tail - - | ALConPar (MArgList o) - -- ^ Constructor parameter (missing in Agda). - -- Agsy has monomorphic constructors. - -- Inserted to cover glitch of polymorphic constructor - -- applications coming from Agda - -type MArgList o = MM (ArgList o) (RefInfo o) - -data WithSeenUIds a o = WithSeenUIds - { seenUIds :: [Maybe (UId o)] - , rawValue :: a - } - -type HNExp o = WithSeenUIds (HNExp' o) o - -data HNExp' o = - HNApp (Elr o) (ICArgList o) - | HNLam Hiding (Abs (ICExp o)) - | HNPi Hiding Bool (ICExp o) (Abs (ICExp o)) - | HNSort Sort - --- | Head-normal form of 'ICArgList'. First entry is exposed. --- --- Q: Why are there no projection eliminations? -data HNArgList o = HNALNil - | HNALCons Hiding (ICExp o) (ICArgList o) - | HNALConPar (ICArgList o) - --- | Lazy concatenation of argument lists under explicit substitutions. -data ICArgList o = CALNil - | CALConcat (Clos (MArgList o) o) (ICArgList o) - --- | An expression @a@ in an explicit substitution @[CAction a]@. -type ICExp o = Clos (MExp o) o -data Clos a o = Clos [CAction o] a - -type CExp o = TrBr (ICExp o) o -data TrBr a o = TrBr [MExp o] a - --- | Entry of an explicit substitution. --- --- An explicit substitution is a list of @CAction@s. --- This is isomorphic to the usual presentation where --- @Skip@ and @Weak@ would be constructors of exp. substs. - -data CAction o - = Sub (ICExp o) - -- ^ Instantation of variable. - | Skip - -- ^ For going under a binder, often called "Lift". - | Weak Nat - -- ^ Shifting substitution (going to a larger context). - -type Ctx o = [(MId, CExp o)] - -type EE = IO - --- ------------------------------------------- - -detecteliminand :: [Clause o] -> Maybe Nat -detecteliminand cls = - case map cleli cls of - [] -> Nothing - (i:is) -> if all (i ==) is then i else Nothing - where - cleli (pats, _) = pateli 0 pats - pateli i (PatConApp _ args : pats) = if all notcon (args ++ pats) then Just i else Nothing - pateli i (_ : pats) = pateli (i + 1) pats - pateli i [] = Nothing - notcon PatConApp{} = False - notcon _ = True - -detectsemiflex :: ConstRef o -> [Clause o] -> IO Bool -detectsemiflex _ _ = return False -- disabled - -categorizedecl :: ConstRef o -> IO () -categorizedecl c = do - cd <- readIORef c - case cdcont cd of - Def narg cls _ _ -> do - semif <- detectsemiflex c cls - let elim = detecteliminand cls - semifb = case (semif, elim) of - (True, Just i) -> Just i -- just copying val of elim arg. this should be changed - (_, _) -> Nothing - writeIORef c (cd {cdcont = Def narg cls elim semifb}) - _ -> return () - --- ------------------------------------------- - -class MetaliseOKH t where - metaliseOKH :: t -> IO t - -instance MetaliseOKH t => MetaliseOKH (MM t a) where - metaliseOKH = \case - Meta m -> return $ Meta m - NotM e -> NotM <$> metaliseOKH e - -instance MetaliseOKH t => MetaliseOKH (Abs t) where - metaliseOKH (Abs id b) = Abs id <$> metaliseOKH b - -instance MetaliseOKH (Exp o) where - metaliseOKH = \case - App uid okh elr args -> - (\ m -> App uid m elr) <$> (Meta <$> initMeta) <*> metaliseOKH args - Lam hid b -> Lam hid <$> metaliseOKH b - Pi uid hid dep it ot -> - Pi uid hid dep <$> metaliseOKH it <*> metaliseOKH ot - e@Sort{} -> return e - e@AbsurdLambda{} -> return e - -instance MetaliseOKH (ArgList o) where - metaliseOKH = \case - ALNil -> return ALNil - ALCons hid a as -> ALCons hid <$> metaliseOKH a <*> metaliseOKH as - ALProj eas idx hid as -> - (\ eas -> ALProj eas idx hid) <$> metaliseOKH eas <*> metaliseOKH as - ALConPar as -> ALConPar <$> metaliseOKH as - -metaliseokh :: MExp o -> IO (MExp o) -metaliseokh = metaliseOKH - --- ------------------------------------------- - -class ExpandMetas t where - expandMetas :: t -> IO t - -instance ExpandMetas t => ExpandMetas (MM t a) where - expandMetas = \case - NotM e -> NotM <$> expandMetas e - Meta m -> do - mb <- readIORef (mbind m) - case mb of - Nothing -> return $ Meta m - Just e -> NotM <$> expandMetas e - -instance ExpandMetas t => ExpandMetas (Abs t) where - expandMetas (Abs id b) = Abs id <$> expandMetas b - -instance ExpandMetas (Exp o) where - expandMetas = \case - App uid okh elr args -> App uid okh elr <$> expandMetas args - Lam hid b -> Lam hid <$> expandMetas b - Pi uid hid dep it ot -> - Pi uid hid dep <$> expandMetas it <*> expandMetas ot - t@Sort{} -> return t - t@AbsurdLambda{} -> return t - -instance ExpandMetas (ArgList o) where - expandMetas = \case - ALNil -> return ALNil - ALCons hid a as -> ALCons hid <$> expandMetas a <*> expandMetas as - ALProj eas idx hid as -> - (\ a b -> ALProj a b hid) <$> expandMetas eas - <*> expandbind idx <*> expandMetas as - ALConPar as -> ALConPar <$> expandMetas as - --- --------------------------------- - -addtrailingargs :: Clos (MArgList o) o -> ICArgList o -> ICArgList o -addtrailingargs newargs CALNil = CALConcat newargs CALNil -addtrailingargs newargs (CALConcat x xs) = CALConcat x (addtrailingargs newargs xs) - --- --------------------------------- - -closify :: MExp o -> CExp o -closify e = TrBr [e] (Clos [] e) - -sub :: MExp o -> CExp o -> CExp o --- sub e (Clos [] x) = Clos [Sub e] x -sub e (TrBr trs (Clos (Skip : as) x)) = TrBr (e : trs) (Clos (Sub (Clos [] e) : as) x) -{-sub e (Clos (Weak n : as) x) = if n == 1 then - Clos as x - else - Clos (Weak (n - 1) : as) x-} -sub _ _ = __IMPOSSIBLE__ - -subi :: MExp o -> ICExp o -> ICExp o -subi e (Clos (Skip : as) x) = Clos (Sub (Clos [] e) : as) x -subi _ _ = __IMPOSSIBLE__ - -weak :: Weakening t => Nat -> t -> t -weak 0 = id -weak n = weak' n - -class Weakening t where - weak' :: Nat -> t -> t - -instance Weakening a => Weakening (TrBr a o) where - weak' n (TrBr trs e) = TrBr trs (weak' n e) - -instance Weakening (Clos a o) where - weak' n (Clos as x) = Clos (Weak n : as) x - -instance Weakening (ICArgList o) where - weak' n = \case - CALNil -> CALNil - CALConcat a as -> CALConcat (weak' n a) (weak' n as) - -instance Weakening (Elr o) where - weak' n = rename (n +) - --- | Substituting for a variable. -doclos :: [CAction o] -> Nat -> Either Nat (ICExp o) -doclos = f 0 - where - -- ns is the number of weakenings - f ns [] i = Left (ns + i) - f ns (Weak n : xs) i = f (ns + n) xs i - f ns (Sub s : _ ) 0 = Right (weak ns s) - f ns (Skip : _ ) 0 = Left ns - f ns (Skip : xs) i = f (ns + 1) xs (i - 1) - f ns (Sub _ : xs) i = f ns xs (i - 1) - - --- | FreeVars class and instances - -freeVars :: FreeVars t => t -> Set.Set Nat -freeVars = freeVarsOffset 0 - -class FreeVars t where - freeVarsOffset :: Nat -> t -> Set.Set Nat - -instance (FreeVars a, FreeVars b) => FreeVars (a, b) where - freeVarsOffset n (a, b) = Set.union (freeVarsOffset n a) (freeVarsOffset n b) - -instance FreeVars t => FreeVars (MM t a) where - freeVarsOffset n e = freeVarsOffset n (rm __IMPOSSIBLE__ e) - -instance FreeVars t => FreeVars (Abs t) where - freeVarsOffset n (Abs id e) = freeVarsOffset (n + 1) e - -instance FreeVars (Elr o) where - freeVarsOffset n = \case - Var v -> Set.singleton (v - n) - Const{} -> Set.empty - -instance FreeVars (Exp o) where - freeVarsOffset n = \case - App _ _ elr args -> freeVarsOffset n (elr, args) - Lam _ b -> freeVarsOffset n b - Pi _ _ _ it ot -> freeVarsOffset n (it, ot) - Sort{} -> Set.empty - AbsurdLambda{} -> Set.empty - -instance FreeVars (ArgList o) where - freeVarsOffset n es = case es of - ALNil -> Set.empty - ALCons _ e es -> freeVarsOffset n (e, es) - ALConPar es -> freeVarsOffset n es - ALProj{} -> __IMPOSSIBLE__ - - --- | Renaming Typeclass and instances -rename :: Renaming t => (Nat -> Nat) -> t -> t -rename = renameOffset 0 - -class Renaming t where - renameOffset :: Nat -> (Nat -> Nat) -> t -> t - -instance (Renaming a, Renaming b) => Renaming (a, b) where - renameOffset j ren (a, b) = (renameOffset j ren a, renameOffset j ren b) - -instance Renaming t => Renaming (MM t a) where - renameOffset j ren e = NotM $ renameOffset j ren (rm __IMPOSSIBLE__ e) - -instance Renaming t => Renaming (Abs t) where - renameOffset j ren (Abs id e) = Abs id $ renameOffset (j + 1) ren e - -instance Renaming (Elr o) where - renameOffset j ren = \case - Var v | v >= j -> Var (ren (v - j) + j) - e -> e - -instance Renaming (Exp o) where - renameOffset j ren = \case - App uid ok elr args -> uncurry (App uid ok) $ renameOffset j ren (elr, args) - Lam hid e -> Lam hid (renameOffset j ren e) - Pi a b c it ot -> uncurry (Pi a b c) $ renameOffset j ren (it, ot) - e@Sort{} -> e - e@AbsurdLambda{} -> e - -instance Renaming (ArgList o) where - renameOffset j ren = \case - ALNil -> ALNil - ALCons hid a as -> uncurry (ALCons hid) $ renameOffset j ren (a, as) - ALConPar as -> ALConPar (renameOffset j ren as) - ALProj{} -> __IMPOSSIBLE__ diff --git a/src/full/Agda/Auto/Typecheck.hs b/src/full/Agda/Auto/Typecheck.hs deleted file mode 100644 --- a/src/full/Agda/Auto/Typecheck.hs +++ /dev/null @@ -1,846 +0,0 @@ -{-# OPTIONS_GHC -Wunused-imports #-} - -{-# LANGUAGE NondecreasingIndentation #-} - -module Agda.Auto.Typecheck where - -import Prelude hiding ((!!)) - -import Data.IORef - -import Agda.Syntax.Common (Hiding (..)) -import Agda.Auto.NarrowingSearch -import Agda.Auto.Syntax -import Agda.Auto.SearchControl - -import Agda.Utils.Impossible -import Agda.Utils.List -import Agda.Utils.Maybe - --- --------------------------------- - --- | 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 $ \case - App _ okh elr args -> case rawValue hntyp of - HNPi{} | isdep -> mpret $ Error "tcExp, dep terms should be eta-long" - _ -> do - res <- case elr of - Var v -> - case ctx !!! v of - Nothing -> return Nothing - Just (_, a) -> return $ Just (weak (v + 1) a, id) - Const c -> do - cdef <- readIORef c - return $ Just (closify (cdtype cdef), mpret . And (Just [Term args]) (noiotastep_term c args)) - caseMaybe res (mpret $ Error "tcExp, variable not in scope") $ \ (ityp, sc) -> do - - ndfv <- case elr of - Var{} -> return 0 - Const c -> cddeffreevars <$> readIORef c - - - isconstructor <- case elr of - Var{} -> return False - Const c -> do - cdef <- readIORef c - return $ case cdcont cdef of {Constructor{} -> True; _ -> False} - - sc $ tcargs ndfv isdep ctx ityp args (NotM $ App Nothing (NotM OKVal) elr (NotM ALNil)) isconstructor $ \ityp _ -> mpret $ ConnectHandle okh (comp' True typ ityp) - Lam hid (Abs id1 b) -> case rawValue hntyp of - HNPi hid2 _ it (Abs id2 ot) | hid == hid2 -> - tcExp isdep ((pickid id1 id2, t it) : ctx) (t ot) b - _ -> mpret $ Error "tcExp, type of lam should be fun or pi (and same hid)" - Pi _ _ _ it (Abs id ot) -> case rawValue hntyp of - HNSort s -> - mpret $ And (Just [Term ctx, Term it]) - (tcExp True ctx (closify (NotM $ Sort s)) it) - (tcExp isdep ((id, closify it) : ctx) (closify (NotM $ Sort s)) ot) - _ -> mpret $ Error "tcExp, type of pi should be set" - Sort (Set i) -> case rawValue hntyp of - HNSort s2 -> case s2 of - Set j -> mpret $ if i < j then OK else Error "tcExp, type of set should be larger set" - - UnknownSort -> mpret OK -- mpret $ Error "tcExp, type of set i unknown sort" -- OK instead? (prev __IMPOSSIBLE__) - - Type -> mpret OK - _ -> mpret $ Error "tcExp, type of set should be set" - - Sort UnknownSort -> __IMPOSSIBLE__ - - Sort Type -> __IMPOSSIBLE__ - - AbsurdLambda hid -> case rawValue hntyp of - HNPi hid2 _ it _ | hid == hid2 -> - mbpcase prioAbsurdLambda Nothing (getDatatype it) $ \res -> case res of - Just (indeces, cons) -> - foldl (\p con -> mpret $ And Nothing p ( - constructorImpossible indeces con - )) (mpret OK) cons - Nothing -> mpret $ Error "tcExp, absurd lambda, datatype needed" - _ -> mpret $ Error "tcExp, type of absurd lam should be fun or pi (and same hid)" - - - where - t = TrBr typtrs - - -getDatatype :: ICExp o -> EE (MyMB (Maybe (ICArgList o, [ConstRef o])) o) -getDatatype t = - mbcase (hnn t) $ \hnt -> case rawValue hnt of - HNApp (Const c) args -> do - cd <- readIORef c - case cdcont cd of - Datatype cons _ -> mbret $ Just (args, cons) -- ?? check that lenth args corresponds to type of datatype - _ -> mbret Nothing - _ -> mbret Nothing - -constructorImpossible :: ICArgList o -> ConstRef o -> EE (MyPB o) -constructorImpossible args c = do - cd <- readIORef c - mbpcase prioAbsurdLambda Nothing (traversePi (-1) (Clos [] $ cdtype cd)) $ \hnot -> - case rawValue hnot of - HNApp _ args2 -> unequals args args2 (\_ -> mpret $ Error "not unequal") [] - _ -> mpret $ Error "constructorImpossible 1" - -unequals :: ICArgList o -> ICArgList o -> ([(Nat, HNExp o)] -> EE (MyPB o)) -> [(Nat, HNExp o)] -> EE (MyPB o) -unequals es1 es2 cont unifier2 = - mbpcase prioAbsurdLambda Nothing (hnarglist es1) $ \hnes1 -> - mbpcase prioAbsurdLambda Nothing (hnarglist es2) $ \hnes2 -> - case (hnes1, hnes2) of - (HNALCons _ e1 es1, HNALCons _ e2 es2) -> unequal e1 e2 (unequals es1 es2 cont) unifier2 - - (HNALConPar es1, HNALConPar es2) -> unequals es1 es2 cont unifier2 - - _ -> cont unifier2 - -unequal :: ICExp o -> ICExp o -> ([(Nat, HNExp o)] -> EE (MyPB o)) -> [(Nat, HNExp o)] -> EE (MyPB o) -unequal e1 e2 cont unifier2 = - mbpcase prioAbsurdLambda Nothing (hnn e1) $ \hne1 -> - mbpcase prioAbsurdLambda Nothing (hnn e2) $ \hne2 -> - case rawValue hne2 of - HNApp (Var v2) es2 | v2 < 0 -> - mbpcase prioAbsurdLambda Nothing (hnarglist es2) $ \hnes2 -> case hnes2 of - HNALNil -> - case lookup v2 unifier2 of - Nothing -> cont ((v2, hne1) : unifier2) - Just hne2' -> cc hne1 hne2' - HNALCons{} -> cont unifier2 - - HNALConPar{} -> __IMPOSSIBLE__ - - _ -> cc hne1 hne2 - where - cc hne1 hne2 = case (rawValue hne1, rawValue hne2) of - (HNApp (Const c1) es1, HNApp (Const c2) es2) -> do - cd1 <- readIORef c1 - cd2 <- readIORef c2 - case (cdcont cd1, cdcont cd2) of - (Constructor{}, Constructor{}) -> - if c1 == c2 then - unequals es1 es2 cont unifier2 - else - mpret OK - _ -> cont unifier2 - _ -> cont unifier2 - -traversePi :: Int -> ICExp o -> EE (MyMB (HNExp o) o) -traversePi v t = - mbcase (hnn t) $ \hnt -> - case rawValue hnt of - HNPi _ _ _ (Abs _ ot) -> traversePi (v - 1) $ subi (NotM $ App Nothing (NotM OKVal) (Var v) (NotM ALNil)) ot - _ -> mbret hnt - -tcargs :: Nat -> Bool -> Ctx o -> CExp o -> MArgList o -> MExp o -> Bool -> - (CExp o -> MExp o -> EE (MyPB o)) -> EE (MyPB o) -tcargs ndfv isdep ctx ityp@(TrBr ityptrs iityp) args elimtrm isconstructor cont = mmpcase (True, prioTypecheckArgList, (Just $ RICheckElim $ isdep || isconstructor)) args $ \args' -> case args' of - ALNil -> cont ityp elimtrm - ALCons hid a as -> - mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp) $ \hnityp -> case rawValue hnityp of - HNPi hid2 possdep it (Abs _ ot) - | ndfv > 0 || copyarg a || hid == hid2 -> mpret $ - And (Just ([Term a | possdep] ++ [Term ctx, Term ityptrs])) - (if ndfv > 0 then mpret OK else tcExp (isdep || possdep) ctx (t it) a) - (tcargs (ndfv - 1) isdep ctx (sub a (t ot)) as (addend hid a elimtrm) isconstructor cont) - _ -> mpret $ Error "tcargs, inf type should be fun or pi (and same hid)" - - - ALProj{} | ndfv > 0 -> __IMPOSSIBLE__ - - ALProj preas projidx hid as -> - mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp) $ \hnityp -> case rawValue hnityp of - HNApp (Const dd) _ -> do - dddef <- readIORef dd - case cdcont dddef of - Datatype _ projs -> - mmpcase (True, prioProjIndex, Just (RICheckProjIndex projs)) projidx $ - \projidx -> do - projd <- readIORef projidx - tcargs (cddeffreevars projd) isdep ctx (closify $ cdtype projd) preas (NotM $ App Nothing (NotM OKVal) (Const projidx) (NotM ALNil)) True $ - \ityp2@(TrBr ityp2trs iityp2) elimtrm2 -> - case iityp2 of - Clos _ (NotM (Pi _ _ _ (NotM (App _ _ (Const dd2) _)) _)) | dd2 == dd -> - mbpcase prioInferredTypeUnknown (Just RIInferredTypeUnknown) (hnn iityp2) $ \hnityp2 -> case rawValue hnityp2 of - HNPi hid2 possdep it (Abs _ ot) | hid == hid2 -> mpret $ - And Nothing - (comp' True (TrBr ityp2trs it) ityp) - (tcargs 0 isdep ctx (sub elimtrm (t ot)) as (addend hid elimtrm elimtrm2) isconstructor cont) - _ -> mpret $ Error "proj function type is not a Pi" - _ -> mpret $ Error "proj function type is not correct" - _ -> mpret $ Error "proj, not a datatype" - _ -> mpret $ Error "proj, not a const app" - - - ALConPar _ -> __IMPOSSIBLE__ - - where - t = TrBr ityptrs - -addend :: Hiding -> MExp o -> MM (Exp o) blk -> MM (Exp o) blk -addend hid a (NotM (App uid okh elr as)) = NotM $ App uid okh elr (f as) - where - f (NotM ALNil) = NotM $ ALCons hid a (NotM $ ALNil) - f (NotM (ALCons hid a as)) = NotM $ ALCons hid a (f as) - f _ = __IMPOSSIBLE__ -addend _ _ _ = __IMPOSSIBLE__ - -copyarg :: MExp o -> Bool -copyarg _ = False - --- --------------------------------- - -type HNNBlks o = [HNExp o] - -noblks :: HNNBlks o -noblks = [] - -addblk :: HNExp o -> HNNBlks o -> HNNBlks o -addblk = (:) - -hnn :: ICExp o -> EE (MyMB (HNExp o) o) -hnn e = mbcase (hnn_blks e) $ \(hne, _) -> mbret hne - -hnn_blks :: ICExp o -> EE (MyMB (HNExp o, HNNBlks o) o) -hnn_blks e = hnn' e CALNil - -hnn_checkstep :: ICExp o -> EE (MyMB (HNExp o, Bool) o) -hnn_checkstep e = - mbcase (hnb e CALNil) $ \hne -> - mbcase (iotastep True hne) $ \res -> case res of - Right _ -> mbret (hne, False) - Left (e, as) -> - mbcase (hnn' e as) $ \(hne, _) -> mbret (hne, True) - - -hnn' :: ICExp o -> ICArgList o -> EE (MyMB (HNExp o, HNNBlks o) o) -hnn' e as = - mbcase (hnb e as) $ \hne -> - mbcase (iotastep True hne) $ \res -> case res of - Right blks -> mbret (hne, blks) - Left (e, as) -> hnn' e as - -hnb :: ICExp o -> ICArgList o -> EE (MyMB (HNExp o) o) -hnb e as = mbcase (hnc False e as []) $ \res -> case res of - HNDone _ hne -> mbret hne - HNMeta{} -> __IMPOSSIBLE__ - -data HNRes o = HNDone (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o) - | HNMeta (ICExp o) (ICArgList o) [Maybe (UId o)] - -hnc :: Bool -> ICExp o -> ICArgList o -> [Maybe (UId o)] -> EE (MyMB (HNRes o) o) -hnc haltmeta = loop - where - loop ce@(Clos cl e) cargs seenuids = - (if haltmeta then mmmcase e (mbret $ HNMeta ce cargs seenuids) else mmcase e) $ - \ee -> case ee of - App uid okh elr args -> - let ncargs = CALConcat (Clos cl args) cargs - in case elr of - Var v -> case doclos cl v of - Left v' -> mbret $ HNDone expmeta - $ WithSeenUIds (uid : seenuids) - $ HNApp (Var v') ncargs - Right f -> loop f ncargs (uid : seenuids) - Const _ -> mbret $ HNDone expmeta - $ WithSeenUIds (uid : seenuids) - $ HNApp elr ncargs - Lam hid (Abs id b) -> - mbcase (hnarglist cargs) $ \hncargs -> case hncargs of - HNALNil -> mbret $ HNDone expmeta - $ WithSeenUIds seenuids - $ HNLam hid (Abs id (Clos (Skip : cl) b)) - HNALCons _ arg cargs' -> loop (Clos (Sub arg : cl) b) cargs' seenuids - - HNALConPar{} -> __IMPOSSIBLE__ - - Pi uid hid possdep it (Abs id ot) -> - checkNoArgs cargs $ mbret $ HNDone expmeta - $ WithSeenUIds (uid : seenuids) - $ HNPi hid possdep (Clos cl it) (Abs id (Clos (Skip : cl) ot)) - Sort s -> checkNoArgs cargs $ mbret - $ HNDone expmeta $ WithSeenUIds [] $ HNSort s - - AbsurdLambda{} -> mbfailed "hnc: encountered absurdlambda" - - - where expmeta = case e of {Meta m -> Just m; NotM _ -> Nothing} - checkNoArgs cargs c = - mbcase (hnarglist cargs) $ \hncargs -> case hncargs of - HNALNil -> c - HNALCons{} -> mbfailed "hnc: there should be no args" - - HNALConPar{} -> __IMPOSSIBLE__ - - -hnarglist :: ICArgList o -> EE (MyMB (HNArgList o) o) -hnarglist args = - case args of - CALNil -> mbret HNALNil - CALConcat (Clos cl args) args2 -> - mmcase args $ \args -> case args of - ALNil -> hnarglist args2 - ALCons hid arg argsb -> mbret $ HNALCons hid (Clos cl arg) (CALConcat (Clos cl argsb) args2) - - ALProj{} -> mbret HNALNil -- dirty hack to make check of no-iota in term work - - - ALConPar args -> mbret $ HNALConPar (CALConcat (Clos cl args) args2) --- ----------------------------- - -getNArgs :: Nat -> ICArgList o -> EE (MyMB (Maybe ([ICExp o], ICArgList o)) o) -getNArgs 0 args = mbret $ Just ([], args) -getNArgs narg args = - mbcase (hnarglist args) $ \hnargs -> case hnargs of - HNALNil -> mbret Nothing - HNALCons _ arg args' -> - mbcase (getNArgs (narg - 1) args') $ \res -> case res of - Nothing -> mbret Nothing - Just (pargs, rargs) -> mbret $ Just (arg : pargs, rargs) - - HNALConPar{} -> __IMPOSSIBLE__ - - -getAllArgs :: ICArgList o -> EE (MyMB [ICExp o] o) -getAllArgs args = - mbcase (hnarglist args) $ \hnargs -> case hnargs of - HNALNil -> mbret [] - HNALCons _ arg args' -> - mbcase (getAllArgs args') $ \args'' -> - mbret (arg : args'') - - HNALConPar args2 -> - mbcase (getAllArgs args2) $ \args3 -> mbret (__IMPOSSIBLE__ : args3) - - -data PEval o = PENo (ICExp o) - | PEConApp (ICExp o) (ConstRef o) [PEval o] - -iotastep :: Bool -> HNExp o -> EE (MyMB (Either (ICExp o, ICArgList o) (HNNBlks o)) o) -iotastep smartcheck e = case rawValue e of - HNApp (Const c) args -> do - cd <- readIORef c - case cdcont cd of - Def narg cls _ _ -> - mbcase (getNArgs narg args) $ \res -> case res of - Nothing -> mbret (Right noblks) - Just (pargs, rargs) -> - mbcase (dorules cls (map PENo pargs)) $ \res -> case res of - Right blks -> mbret (Right blks) - Left rhs -> mbret $ Left (rhs, rargs) - _ -> mbret $ Right noblks - _ -> mbret $ Right noblks - where - dorules :: [Clause o] -> [PEval o] -> EE (MyMB (Either (ICExp o) (HNNBlks o)) o) - dorules [] _ = mbret $ Right noblks - dorules (rule:rules') as = - mbcase (dorule rule as) $ \x -> case x of - Left (Left as') -> dorules rules' as' - Left (Right blks) -> mbret (Right blks) - Right rhs -> mbret $ Left rhs - - dorule :: Clause o -> [PEval o] -> EE (MyMB (Either (Either [PEval o] (HNNBlks o)) (ICExp o)) o) - dorule (pats, rhs) as = - mbcase (dopats pats as) $ \x -> case x of - Right (_, ss) -> mbret $ Right (Clos (map Sub ss) rhs) - Left hnas -> mbret $ Left hnas - - dopats :: [Pat o] -> [PEval o] -> EE (MyMB (Either (Either [PEval o] (HNNBlks o)) ([PEval o], [ICExp o])) o) - dopats [] [] = mbret $ Right ([], []) - dopats (p:ps') (a:as') = - mbcase (dopat p a) $ \x -> case x of - Right (hna, ss) -> - mbcase (dopats ps' as') $ \x -> case x of - Right (hnas, ss2) -> mbret $ Right (hna : hnas, ss2 ++ ss) - Left (Right blks) -> mbret $ Left (Right blks) - Left (Left hnas) -> mbret $ Left $ Left (hna : hnas) - Left (Right blks) -> mbret $ Left (Right blks) - Left (Left hna) -> mbret $ Left $ Left (hna : as') - dopats _ _ = mbfailed "bad patterns" - - dopat :: Pat o -> PEval o -> EE (MyMB (Either (Either (PEval o) (HNNBlks o)) (PEval o, [ICExp o])) o) - dopat (PatConApp c pas) a = - case a of - PENo a -> - if smartcheck then - mbcase (meta_not_constructor a) $ \notcon -> if notcon then mbret $ Left $ Right noblks else qq -- to know more often if iota step is possible - else - qq - where - qq = - mbcase (hnn_blks a) $ \(hna, blks) -> case rawValue hna of - HNApp (Const c') as -> - if c == c' then - mbcase (getAllArgs as) $ \as' -> - if length as' == length pas then - mbcase (dopats pas (map PENo as')) $ \x -> case x of - Right (hnas, ss) -> mbret $ Right (PEConApp a c' hnas, ss) - Left (Right blks) -> mbret $ Left (Right blks) - Left (Left hnas) -> mbret $ Left $ Left (PEConApp a c' hnas) - else - mbfailed "dopat: wrong amount of args" - else do - cd <- readIORef c' - case cdcont cd of - Constructor{} -> mbcase (getAllArgs as) $ \as' -> - mbret $ Left (Left (PEConApp a c' (map PENo as'))) - _ -> mbret $ Left (Right (addblk hna blks)) - _ -> mbret $ Left (Right (addblk hna blks)) - aa@(PEConApp a c' as) -> - if c == c' then - if length as == length pas then - mbcase (dopats pas as) $ \x -> case x of - Right (hnas, ss) -> mbret $ Right (PEConApp a c' hnas, ss) - Left (Right blks) -> mbret $ Left (Right blks) - Left (Left hnas) -> mbret $ Left $ Left (PEConApp a c' hnas) - else - mbfailed "dopat: wrong amount of args" - else - mbret $ Left (Left aa) - dopat (PatProj cs) a = - case a of - PENo a -> - if smartcheck then - mbcase (meta_not_constructor a) $ \notcon -> if notcon then mbret $ Left $ Right noblks else qq -- to know more often if iota step is possible - else - qq - where - qq = - mbcase (hnn_blks a) $ \(hna, blks) -> case rawValue hna of - HNApp (Const c') as -> - 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) -> mbret $ Left (Left aa) - dopat PatVar{} a@(PENo a') = mbret $ Right (a, [a']) - dopat PatVar{} a@(PEConApp a' _ _) = mbret $ Right (a, [a']) - dopat PatExp a = mbret $ Right (a, []) - --- ----------------------------- - -noiotastep :: HNExp o -> EE (MyPB o) -noiotastep hne = - mbpcase prioNoIota Nothing (iotastep False hne) $ \res -> case res of - Left _ -> mpret $ Error "iota step possible contrary to assumed" - Right _ -> mpret OK - -noiotastep_term :: ConstRef o -> MArgList o -> EE (MyPB o) -noiotastep_term c args = do - cd <- readIORef c - case cdcont cd of - Def _ [(pats, _)] _ _ -> mpret OK - -- all (\pat -> case pat of {PatConApp{} -> False; _ -> True}) pats - _ -> noiotastep $ WithSeenUIds [] - $ HNApp (Const c) $ CALConcat (Clos [] args) CALNil - -data CMode o = CMRigid (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o) - | forall b . Refinable b (RefInfo o) => CMFlex (MM b (RefInfo o)) (CMFlex o) -data CMFlex o = CMFFlex (ICExp o) (ICArgList o) [Maybe (UId o)] - | CMFSemi (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o) - | CMFBlocked (Maybe (Metavar (Exp o) (RefInfo o))) (HNExp o) - -comp' :: forall o . Bool -> CExp o -> CExp o -> EE (MyPB o) -comp' ineq lhs@(TrBr trs1 e1) rhs@(TrBr trs2 e2) = comp ineq e1 e2 - where - comp :: Bool -> ICExp o -> ICExp o -> EE (MyPB o) - comp ineq e1 e2 = - proc e1 e2 - - where - proc e1 e2 = f True e1 CALNil [] $ \res1 -> f True e2 CALNil [] $ \res2 -> g res1 res2 - f semifok e as seenuids cont = - mbpcase prioCompBeta Nothing (hnc True e as seenuids) $ \res -> - case res of - HNDone mexpmeta hne -> fhn semifok mexpmeta hne cont - - HNMeta ce@(Clos cl m) cargs seenuids -> do - b1 <- boringClos cl - b2 <- boringArgs cargs - if b1 && b2 then - cont $ CMFlex m (CMFFlex ce cargs seenuids) - else - mbpcase prioCompBetaStructured Nothing (hnc False ce cargs seenuids) $ \res -> - case res of - HNDone mexpmeta hne -> cont $ CMFlex m (CMFBlocked mexpmeta hne) - HNMeta{} -> __IMPOSSIBLE__ - - - fhn semifok mexpmeta hne cont = - mmbpcase (iotastep True hne) - (\m -> do - let sf = False {- semiflex hne -} - if semifok && sf then - cont (CMFlex m (CMFSemi mexpmeta hne)) - else - cont (CMFlex m (CMFBlocked mexpmeta hne)) - ) - (\res -> case res of - Right _ -> cont (CMRigid mexpmeta hne) - Left (e, as) -> f semifok e as [] cont - ) - g res1 res2 = - case (res1, res2) of - (CMRigid mexpmeta1 hne1, CMRigid mexpmeta2 hne2) -> comphn ineq mexpmeta1 hne1 mexpmeta2 hne2 - (CMFlex m1 (CMFBlocked mexpmeta1 hne1), _) -> mstp False mexpmeta1 hne1 $ \res1 -> g res1 res2 - (_, CMFlex m2 (CMFBlocked mexpmeta2 hne2)) -> mstp False mexpmeta2 hne2 $ \res2 -> g res1 res2 - (CMRigid mexpmeta1 hne1, CMFlex _ fl2) -> unif True mexpmeta1 hne1 fl2 - (CMFlex _ fl1, CMRigid mexpmeta2 hne2) -> unif False mexpmeta2 hne2 fl1 - - - (CMFlex m1 fl1, CMFlex m2 fl2) -> doubleblock m1 m2 $ fcm fl1 $ \res1 -> fcm fl2 $ \res2 -> g res1 res2 - fcm (CMFFlex ce cargs seenuids) = f True ce cargs seenuids - fcm (CMFSemi mexpmeta hne) = fhn True mexpmeta hne - fcm (CMFBlocked _ hne) = __IMPOSSIBLE__ -- not used. if so should be: fhn False hne - mstp semif mexpmeta hne cont = - mpret $ Or prioCompChoice - (mpret $ And (Just [Term lhs, Term rhs]) - (noiotastep hne) - (cont (CMRigid mexpmeta hne)) - ) - (stp semif hne cont) - stp semif hne cont = - mbpcase prioCompIota (Just $ RIIotaStep semif) (iotastep True hne) $ \res -> case res of - Right _ -> mpret $ Error "no iota step possible, contrary to assumed" - Left (e, as) -> f semif e as [] cont - unif oppis1 oppmexpmeta opphne res = - let iter res = if oppis1 then - g (CMRigid oppmexpmeta opphne) res - else - g res (CMRigid oppmexpmeta opphne) - in case res of - CMFFlex ce cargs seenuids -> do - poss <- iotapossmeta ce cargs - maybeor poss prioCompChoice - (loop ce cargs seenuids) --- (mbpcase prioCompBeta (Just $ RIIotaStep False) (hnb ce cargs) $ \hne -> - (mbpcase prioCompBeta (Just $ RIIotaStep False) (hnc False ce cargs seenuids) $ \res -> - -- RIIotaStep here on beta-norm to make cost high when guessing elim const in type par - case res of - HNDone mexpmeta hne -> stp False hne iter - HNMeta{} -> __IMPOSSIBLE__ - ) - where - loop ce@(Clos cl m) cargs seenuids = - mmpcase (False, prioCompUnif, Just (RIUnifInfo cl opphne)) m $ \_ -> - mbpcase prioCompBeta Nothing (hnc True ce cargs seenuids) $ \res -> case res of - HNDone mexpmeta hne -> - mpret $ And (Just [Term lhs, Term rhs]) - (noiotastep hne) - (iter (CMRigid mexpmeta hne)) - HNMeta ce cargs seenuids -> loop ce cargs seenuids - CMFSemi _ hne -> - __IMPOSSIBLE__ -- CMFSemi disabled, if used should be: stp True hne iter - CMFBlocked{} -> __IMPOSSIBLE__ - comphn :: Bool -> Maybe (Metavar (Exp o) (RefInfo o)) -> HNExp o -> Maybe (Metavar (Exp o) (RefInfo o)) -> HNExp o -> EE (MyPB o) - comphn ineq mexpmeta1 hne1 mexpmeta2 hne2 = - case (rawValue hne1, rawValue hne2) of - (HNApp elr1 args1, HNApp elr2 args2) -> - let ce = case (elr1, elr2) of - (Var v1, Var v2) -> - if v1 == v2 then Nothing - else Just "comphn, elr, vars not equal" - (Const c1, Const c2) -> - if c1 == c2 then Nothing - else Just "comphn, elr, consts not equal" - (_, _) -> Just "comphn, elrs not equal" - in case ce of - Nothing -> compargs args1 args2 - Just msg -> mpret $ Error msg - (HNLam hid1 (Abs id1 b1), HNLam hid2 (Abs id2 b2)) -> comp False b1 b2 - (HNLam _ (Abs _ b1), HNApp elr2 args2) -> - f True b1 CALNil (seenUIds hne1) $ \res1 -> - fhn True mexpmeta2 (WithSeenUIds (seenUIds hne2) $ HNApp (weak 1 elr2) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args2))) $ \res2 -> g res1 res2 - (HNApp elr1 args1, HNLam _ (Abs _ b2)) -> - fhn True mexpmeta1 (WithSeenUIds (seenUIds hne1) $ HNApp (weak 1 elr1) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args1))) $ \res1 -> f True b2 CALNil (seenUIds hne2) $ \res2 -> g res1 res2 -{- - (HNLam _ (Abs _ b1), HNApp uid2 elr2 args2) -> - f True b1 CALNil $ \res1 -> g res1 - (CMRigid mexpmeta2 (HNApp uid2 (weak 1 elr2) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args2)))) - (HNApp uid1 elr1 args1, HNLam _ (Abs _ b2)) -> - f True b2 CALNil $ \res2 -> g - (CMRigid mexpmeta1 (HNApp uid1 (weak 1 elr1) (addtrailingargs (Clos [] $ NotM $ ALCons NotHidden{- arbitrary -} (NotM $ App Nothing (NotM OKVal) (Var 0) (NotM ALNil)) (NotM ALNil)) (weak 1 args1)))) - res2 --} - (HNPi hid1 _ it1 (Abs id1 ot1), HNPi hid2 _ it2 (Abs id2 ot2)) -> mpret $ - And (Just [Term trs1, Term trs2]) (comp False it1 it2) (comp ineq ot1 ot2) - (HNSort s1, HNSort s2) -> mpret $ - case (s1, s2) of - (Set i1, Set i2) -> if i1 == i2 || ineq && i1 > i2 then OK else Error "comphn, set levels not matching" - (Set _, UnknownSort) -> OK - (UnknownSort, Set _) -> OK - (UnknownSort, UnknownSort) -> OK - (Type, Set _) | ineq -> OK - (Type, UnknownSort) | ineq -> OK - _ -> __IMPOSSIBLE__ - (HNApp (Const c1) _, _) -> case mexpmeta2 of - Nothing -> mpret $ Error "comphn, not equal (2)" - Just m2 -> mpret $ AddExtraRef "comphn: not equal, adding extra ref" - m2 (extraref m2 (seenUIds hne1) c1) - (_, HNApp (Const c2) _) -> case mexpmeta1 of - Nothing -> mpret $ Error "comphn, not equal (3)" - Just m1 -> mpret $ AddExtraRef "comphn: not equal, adding extra ref" - m1 (extraref m1 (seenUIds hne2) c2) - (_, _) -> mpret $ Error "comphn, not equal" - - compargs :: ICArgList o -> ICArgList o -> EE (MyPB o) - compargs args1 args2 = - mbpcase prioCompareArgList Nothing (hnarglist args1) $ \hnargs1 -> - mbpcase prioCompareArgList Nothing (hnarglist args2) $ \hnargs2 -> - case (hnargs1, hnargs2) of - (HNALNil, HNALNil) -> mpret OK - (HNALCons hid1 arg1 args1b, HNALCons hid2 arg2 args2b) -> mpret $ - And (Just [Term trs1, Term trs2]) (comp False arg1 arg2) (compargs args1b args2b) - - (HNALConPar args1b, HNALCons _ _ args2b) -> compargs args1b args2b - (HNALCons _ _ args1b, HNALConPar args2b) -> compargs args1b args2b - (HNALConPar args1', HNALConPar args2') -> compargs args1' args2' - - (_, _) -> mpret $ Error $ "comphnargs, not equal" - - - boringExp :: ICExp o -> EE Bool - boringExp (Clos cl e) = do - e <- expandbind e - case e of - Meta{} -> boringClos cl - NotM e -> case e of - App _ _ (Var v) as -> do - as <- expandbind as - case as of - Meta{} -> return False - NotM as -> case as of - ALNil -> case doclos cl v of - Left _ -> return True - Right e -> boringExp e - ALCons{} -> return False - ALProj{} -> return False - ALConPar{} -> return False - - _ -> return False - - boringClos :: [CAction o] -> EE Bool - boringClos cl = and <$> mapM f cl - where f (Sub e) = boringExp e - f Skip = return True - f (Weak _) = return True - - boringArgs :: ICArgList o -> EE Bool - boringArgs CALNil = return True - boringArgs (CALConcat (Clos cl as) as2) = do - b1 <- f cl as - b2 <- boringArgs as2 - return $ b1 && b2 - where - f cl as = do - as <- expandbind as - case as of - Meta{} -> return False - NotM as -> case as of - ALNil -> return True - ALCons _ a as -> do - b1 <- boringExp (Clos cl a) - b2 <- f cl as - return $ b1 && b2 - - ALProj{} -> return False -- Not impossible: #2966 - - - ALConPar as -> f cl as --- --------------------------------- - -checkeliminand :: MExp o -> EE (MyPB o) -checkeliminand = f [] [] - where - f uids used e = - mmpcase (False, prioNo, Just (RIUsedVars uids used)) e $ \e -> case e of - App uid _ elr@(Var{}) args -> fs (adduid uid uids) (elr : used) args - App uid _ elr@(Const c) args -> do - cd <- readIORef c - case cdcont cd of - Def _ _ (Just i) _ -> mpret $ Sidecondition (fs (adduid uid uids) (elr : used) args) (g i args) - where - g i as = mmpcase (False, prioNo, Nothing) as $ \as -> case as of - ALNil -> mpret OK - ALCons _ a as -> case i of - 0 -> mmpcase (False, prioNo, Just RINotConstructor) a $ \_ -> - mpret OK - _ -> g (i - 1) as - - ALProj eas _ _ as -> mpret OK - - - ALConPar as -> case i of - 0 -> __IMPOSSIBLE__ - _ -> g (i - 1) as - - _ -> fs (adduid uid uids) (elr : used) args - Lam _ (Abs _ e) -> f uids (w used) e - Pi uid _ _ e1 (Abs _ e2) -> mpret $ Sidecondition (f (adduid uid uids) used e1) (f (adduid uid uids) (w used) e2) - Sort _ -> mpret OK - - AbsurdLambda{} -> mpret OK - - - fs uids used as = - mmpcase (False, prioNo, Nothing) as $ \as -> case as of - ALNil -> mpret OK - ALCons _ a as -> mpret $ Sidecondition (f uids used a) (fs uids used as) - - ALProj eas _ _ as -> mpret $ Sidecondition (fs uids used eas) (fs uids used as) - - - ALConPar as -> fs uids used as - - w = map (\x -> case x of {Var v -> Var (v + 1); Const{} -> x}) - adduid (Just uid) uids = uid : uids - adduid Nothing uids = uids - --- --------------------------------- - -maybeor :: Bool -> Prio -> IO (PB (RefInfo o)) -> IO (PB (RefInfo o)) -> - IO (PB (RefInfo o)) -maybeor _ _ mainalt _ = mainalt - -iotapossmeta :: ICExp o -> ICArgList o -> EE Bool -iotapossmeta ce@(Clos cl _) cargs = do - xs <- mapM ncaction cl - y <- nccargs cargs - return $ not (and xs && y) - where - ncaction (Sub ce) = nonconstructor ce - ncaction Skip = return True - ncaction (Weak{}) = return True - nccargs CALNil = return True - nccargs (CALConcat (Clos cl margs) cargs) = do - x <- ncmargs cl margs - y <- nccargs cargs - return $ x && y - ncmargs cl (Meta m) = do - mb <- readIORef (mbind m) - case mb of - Nothing -> return False - Just x -> ncargs cl x - ncmargs cl (NotM args) = ncargs cl args - ncargs cl ALNil = return True - ncargs cl (ALCons _ a args) = do - x <- nonconstructor (Clos cl a) - y <- ncmargs cl args - return $ x && y - - ncargs _ (ALProj{}) = __IMPOSSIBLE__ - - - ncargs cl (ALConPar args) = ncmargs cl args - - nonconstructor :: ICExp o -> EE Bool - nonconstructor ce = do - res <- hnc True ce CALNil [] - case res of - Blocked{} -> return False - Failed{} -> return False - NotB res -> case res of - HNMeta ce _ _ -> do - let (Clos _ (Meta m)) = ce - infos <- extractblkinfos m - if any (\info -> case info of {RINotConstructor -> True; _ -> False}) infos then do - return True - else - return False - -- return False -- return True -- ?? removes completeness - Yes, in DavidW1.additionRight - HNDone{} -> do - res <- hnn ce - case res of - NotB hne -> case rawValue hne of - HNApp (Const c) _ -> do - cd <- readIORef c - case cdcont cd of - Constructor{} -> return False - _ -> return True - _ -> return True - Blocked m _ -> return False -- not necessary to do check here because already done by hnn (!! if it's known that m stands for an eliminator then it cannot be constructor so True instead) - Failed _ -> return False - -meta_not_constructor :: ICExp o -> EE (MB Bool (RefInfo o)) -meta_not_constructor a = - mbcase (hnc True a CALNil []) $ \res -> case res of - HNMeta ce _ _ -> do - let (Clos _ (Meta m)) = ce - infos <- extractblkinfos m - if any (\info -> case info of {RINotConstructor -> True; _ -> False}) infos then do - b <- iotapossmeta ce CALNil - mbret $ not b - else - mbret False - HNDone{} -> mbret False - --- --------------------------------- - -calcEqRState :: EqReasoningConsts o -> MExp o -> EE (MyPB o) -calcEqRState cs = f EqRSNone - where - f s e = - mmpcase (False, prioNo, Just (RIEqRState s)) e $ \e -> case e of - App _ _ (Const c) args -> case () of - _ | c == eqrcBegin cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSChain] args - _ | c == eqrcStep cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSPrf1, EqRSChain] args - _ | c == eqrcSym cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSPrf2] args - _ | c == eqrcCong cs -> fs [EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSNone, EqRSPrf3] args - _ -> fs [] args - App _ _ (Var{}) args -> fs [] args - Lam _ (Abs _ b) -> f EqRSNone b - Pi _ _ _ it (Abs _ ot) -> mpret $ Sidecondition (f EqRSNone it) (f EqRSNone ot) - Sort{} -> mpret OK - - AbsurdLambda{} -> mpret OK - - - fs ss args = - mmpcase (False, prioNo, Nothing) args $ \args -> case (ss, args) of - (_, ALNil) -> mpret OK - (s : ss, ALCons _ a args) -> mpret $ Sidecondition (f s a) (fs ss args) - ([], ALCons _ a args) -> mpret $ Sidecondition (f EqRSNone a) (fs [] args) - - (_, ALProj eas _ _ as) -> mpret $ Sidecondition (fs [] eas) (fs [] as) -- when eqr-hint is given manually, ss can be non-empty here - - - (_ : ss, ALConPar args) -> fs ss args - ([], ALConPar args) -> fs [] args - --- --------------------------------- - -pickid :: MId -> MId -> MId -pickid mid1@(Id _) _ = mid1 -pickid _ mid2 = mid2 - --- --------------------------------- - -tcSearch :: Bool -> Ctx o -> CExp o -> MExp o -> EE (MyPB o) -tcSearch isdep ctx typ trm = mpret $ Sidecondition (checkeliminand trm) - (tcExp isdep ctx typ trm) - --- ---------------------------- diff --git a/src/full/Agda/Benchmarking.hs b/src/full/Agda/Benchmarking.hs --- a/src/full/Agda/Benchmarking.hs +++ b/src/full/Agda/Benchmarking.hs @@ -51,7 +51,7 @@ -- ^ Writing interface files. | DeadCode -- ^ Dead code elimination. - | DeadCodeInstantiateFull + | InterfaceInstantiateFull -- ^ Unfolding all metas before serialization. | DeadCodeReachable -- ^ Dead code reachable definitions subphase. @@ -97,11 +97,22 @@ -- ^ Subphase for 'Typing': generalizing over `variable`s | InstanceSearch -- ^ Subphase for 'Typing': solving instance goals + | Reflection + -- ^ Subphase for 'Typing': evaluating elaborator reflection + | InitialCandidates + -- ^ Subphase for 'InstanceSearch': collecting initial candidates + | FilterCandidates + -- ^ Subphase for 'InstanceSearch': checking candidates for validity + | OrderCandidates + -- ^ Subphase for 'InstanceSearch': ordering candidates for specificity + | CheckOverlap + -- ^ Subphase for 'InstanceSearch': reducing overlapping instances | UnifyIndices -- ^ Subphase for 'CheckLHS': unification of the indices | InverseScopeLookup -- ^ Pretty printing names. | TopModule TopLevelModuleName + | Typeclass QName | Definition QName deriving (Eq, Ord, Show, Generic) diff --git a/src/full/Agda/Compiler/Backend.hs b/src/full/Agda/Compiler/Backend.hs --- a/src/full/Agda/Compiler/Backend.hs +++ b/src/full/Agda/Compiler/Backend.hs @@ -1,11 +1,9 @@ {-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PolyKinds #-} - -- | Interface for compiler backend writers. module Agda.Compiler.Backend - ( Backend(..), Backend'(..), Recompile(..), IsMain(..) + ( module Agda.Compiler.Backend.Base + , Backend, Backend', Recompile(..), IsMain(..) , Flag , toTreeless , module Agda.Syntax.Treeless @@ -22,22 +20,19 @@ , activeBackend ) where +import Agda.Compiler.Backend.Base + import Control.DeepSeq -import Control.Monad ( (<=<) ) import Control.Monad.Trans ( lift ) import Control.Monad.Trans.Maybe import qualified Data.List as List import Data.Maybe -import Data.Map (Map) import qualified Data.Map as Map -import GHC.Generics (Generic) - import System.Console.GetOpt -import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Treeless import Agda.TypeChecking.Errors (getAllWarnings) -- Agda.TypeChecking.Monad.Base imports us, relying on the .hs-boot file to @@ -68,49 +63,9 @@ -- Public interface ------------------------------------------------------- -data Backend where - Backend :: NFData opts => Backend' opts env menv mod def -> Backend - -data Backend' opts env menv mod def = Backend' - { backendName :: String - , backendVersion :: Maybe String - -- ^ Optional version information to be printed with @--version@. - , options :: opts - -- ^ Default options - , commandLineFlags :: [OptDescr (Flag opts)] - -- ^ Backend-specific command-line flags. Should at minimum contain a - -- flag to enable the backend. - , isEnabled :: opts -> Bool - -- ^ Unless the backend has been enabled, @runAgda@ will fall back to - -- vanilla Agda behaviour. - , preCompile :: opts -> TCM env - -- ^ Called after type checking completes, but before compilation starts. - , postCompile :: env -> IsMain -> Map 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. - } - deriving Generic +type Backend = Backend_boot TCM -data Recompile menv mod = Recompile menv | Skip mod +type Backend' opts env menv mod def = Backend'_boot TCM opts env menv mod def -- | Call the 'compilerMain' function of the given backend. @@ -154,23 +109,6 @@ Backend b <- fromMaybe __IMPOSSIBLE__ <$> activeBackend mayEraseType b q -instance NFData Backend where - rnf (Backend b) = rnf b - -instance NFData opts => NFData (Backend' opts env menv mod def) where - rnf (Backend' a b c d e f g h i j k l) = - rnf a `seq` rnf b `seq` rnf c `seq` rnf' d `seq` rnf e `seq` - rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq` - rnf k `seq` rnf l - where - rnf' [] = () - rnf' (Option a b c d : e) = - rnf a `seq` rnf b `seq` rnf'' c `seq` rnf d `seq` rnf' e - - rnf'' (NoArg a) = rnf a - rnf'' (ReqArg a b) = rnf a `seq` rnf b - rnf'' (OptArg a b) = rnf a `seq` rnf b - -- Internals -------------------------------------------------------------- data BackendWithOpts opts where @@ -247,11 +185,11 @@ "The --only-scope-checking flag cannot be combined with " ++ backendName backend ++ "." - let i = crInterface checkResult + !i <- instantiateFull $ crInterface checkResult -- Andreas, 2017-08-23, issue #2714 -- If the backend is invoked from Emacs, we can only get the --no-main -- pragma option now, coming from the interface file. - isMain <- ifM (optCompileNoMain <$> pragmaOptions) + !isMain <- ifM (optCompileNoMain <$> pragmaOptions) {-then-} (return NotMain) {-else-} (return isMain0) @@ -281,7 +219,7 @@ Skip m -> return m Recompile menv -> do defs <- map snd . sortDefs <$> curDefs - res <- mapM (compileDef' backend env menv isMain <=< instantiateFull) defs + 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 diff --git a/src/full/Agda/Compiler/Backend.hs-boot b/src/full/Agda/Compiler/Backend.hs-boot --- a/src/full/Agda/Compiler/Backend.hs-boot +++ b/src/full/Agda/Compiler/Backend.hs-boot @@ -8,7 +8,7 @@ ) where -import Control.DeepSeq +import Agda.Compiler.Backend.Base -- Explicitly adding the Agda.Syntax.Treeless import to the .hs-boot file -- so that the `Args` symbol can be hidden by the `SOURCE` import in @@ -26,9 +26,7 @@ import Agda.Syntax.Abstract.Name (QName) import {-# SOURCE #-} Agda.TypeChecking.Monad.Base (TCM, BackendName) -data Backend - -instance NFData Backend +type Backend = Backend_boot TCM activeBackendMayEraseType :: QName -> TCM Bool lookupBackend :: BackendName -> TCM (Maybe Backend) diff --git a/src/full/Agda/Compiler/Backend/Base.hs b/src/full/Agda/Compiler/Backend/Base.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Compiler/Backend/Base.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -Wunused-imports #-} + +module Agda.Compiler.Backend.Base where + +import Agda.Interaction.Options (ArgDescr(..), OptDescr(..), Flag) +import Agda.Syntax.Abstract.Name (QName) +import Agda.Syntax.Common (IsMain) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) +import {-# SOURCE #-} Agda.TypeChecking.Monad.Base (Definition) + + +import Control.DeepSeq (NFData, rnf) +import Data.Map (Map) + +import GHC.Generics (Generic) + +data Backend_boot tcm where + Backend :: NFData opts => Backend'_boot tcm opts env menv mod def -> Backend_boot tcm + +data Backend'_boot tcm opts env menv mod def = Backend' + { backendName :: String + , backendVersion :: Maybe String + -- ^ Optional version information to be printed with @--version@. + , options :: opts + -- ^ Default options + , commandLineFlags :: [OptDescr (Flag opts)] + -- ^ Backend-specific command-line flags. Should at minimum contain a + -- flag to enable the backend. + , isEnabled :: opts -> Bool + -- ^ Unless the backend has been enabled, @runAgda@ will fall back to + -- vanilla Agda behaviour. + , preCompile :: opts -> tcm env + -- ^ Called after type checking completes, but before compilation starts. + , postCompile :: env -> IsMain -> Map 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. + } + deriving Generic + +data Recompile menv mod = Recompile menv | Skip mod + + +instance NFData (Backend_boot tcm) where + rnf (Backend b) = rnf b + +instance NFData opts => NFData (Backend'_boot tcm opts env menv mod def) where + rnf (Backend' a b c d e f g h i j k l) = + rnf a `seq` rnf b `seq` rnf c `seq` rnf' d `seq` rnf e `seq` + rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j `seq` + rnf k `seq` rnf l + where + rnf' [] = () + rnf' (Option a b c d : e) = + rnf a `seq` rnf b `seq` rnf'' c `seq` rnf d `seq` rnf' e + + rnf'' (NoArg a) = rnf a + rnf'' (ReqArg a b) = rnf a `seq` rnf b + rnf'' (OptArg a b) = rnf a `seq` rnf b diff --git a/src/full/Agda/Compiler/Common.hs b/src/full/Agda/Compiler/Common.hs --- a/src/full/Agda/Compiler/Common.hs +++ b/src/full/Agda/Compiler/Common.hs @@ -1,6 +1,10 @@ {-# OPTIONS_GHC -Wunused-imports #-} -module Agda.Compiler.Common where +module Agda.Compiler.Common + ( module Agda.Compiler.Common + , IsMain(..) + ) + where import Prelude hiding ((!!)) @@ -34,19 +38,6 @@ import Agda.Utils.WithDefault ( lensCollapseDefault ) import Agda.Utils.Impossible - -data IsMain = IsMain | NotMain - deriving (Eq, Show) - --- | Conjunctive semigroup ('NotMain' is absorbing). -instance Semigroup IsMain where - NotMain <> _ = NotMain - _ <> NotMain = NotMain - IsMain <> IsMain = IsMain - -instance Monoid IsMain where - mempty = IsMain - mappend = (<>) doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r doCompile f isMain i = do diff --git a/src/full/Agda/Compiler/JS/Compiler.hs b/src/full/Agda/Compiler/JS/Compiler.hs --- a/src/full/Agda/Compiler/JS/Compiler.hs +++ b/src/full/Agda/Compiler/JS/Compiler.hs @@ -68,7 +68,7 @@ import Agda.Compiler.Treeless.GuardsToPrims import Agda.Compiler.Treeless.Erase ( computeErasedConstructorArgs ) import Agda.Compiler.Treeless.Subst () -import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..)) +import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..)) import Agda.Compiler.JS.Syntax ( Exp(Self,Local,Global,Undefined,Null,String,Char,Integer,Double,Lambda,Object,Array,Apply,Lookup,If,BinOp,PlainJS), @@ -159,7 +159,7 @@ jsPreCompile :: JSOptions -> TCM JSOptions jsPreCompile opts = do - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption let notSupported s = typeError $ GenericError $ "Compilation of code that uses " ++ s ++ " is not supported." @@ -221,7 +221,7 @@ JSOptions -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module) jsPreModule _opts _ m mifile = do - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption let compile = case cubical of -- Code that uses --cubical is not compiled. Just CFull -> False diff --git a/src/full/Agda/Compiler/JS/Pretty.hs b/src/full/Agda/Compiler/JS/Pretty.hs --- a/src/full/Agda/Compiler/JS/Pretty.hs +++ b/src/full/Agda/Compiler/JS/Pretty.hs @@ -82,7 +82,7 @@ punctuation = (`elem` ("(){}[];:, " :: String)) - go i Space = if minify then [] else [(i, " ")] + go i Space = [(i, " ") | not minify] go i Empty = [] go i (Doc s) = [(i, s)] go i (Beside d d') = joinBy (\(i, s) (_, s') -> [(i, s ++ s')]) (go i d) (go i d') diff --git a/src/full/Agda/Compiler/MAlonzo/Compiler.hs b/src/full/Agda/Compiler/MAlonzo/Compiler.hs --- a/src/full/Agda/Compiler/MAlonzo/Compiler.hs +++ b/src/full/Agda/Compiler/MAlonzo/Compiler.hs @@ -218,7 +218,7 @@ ghcPreCompile :: GHCFlags -> TCM GHCEnv ghcPreCompile flags = do - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption let notSupported s = typeError $ GenericError $ "Compilation of code that uses " ++ s ++ " is not supported." @@ -305,9 +305,11 @@ , builtinAgdaTCMFormatErrorParts , builtinAgdaTCMDebugPrint , builtinAgdaTCMNoConstraints + , builtinAgdaTCMWorkOnTypes , builtinAgdaTCMRunSpeculative , builtinAgdaTCMExec , builtinAgdaTCMGetInstances + , builtinAgdaTCMSolveInstances , builtinAgdaTCMPragmaForeign , builtinAgdaTCMPragmaCompile , builtinAgdaBlocker @@ -382,7 +384,7 @@ -- ^ Could we confirm the existence of a main function? ghcPreModule cenv isMain m mifile = (do let check = ifM uptodate noComp yesComp - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption case cubical of -- Code that uses --cubical is not compiled. Just CFull -> noComp @@ -437,9 +439,9 @@ hsModuleName <- curHsMod writeModule $ HS.Module hsModuleName - (map HS.OtherPragma headerPragmas) + (map HS.OtherPragma $ List.nub headerPragmas) imps - (map fakeDecl (hsImps ++ code) ++ decls) + (map fakeDecl (List.nub hsImps ++ code) ++ decls) return $ GHCModule menv mainDefs @@ -567,8 +569,7 @@ -- Compiling List Datatype{ dataPars = np } | is ghcEnvList -> do sequence_ [primNil, primCons] -- Just to get the proper error for missing NIL/CONS - caseMaybe pragma (return ()) $ \ p -> setCurrentRange p $ warning . GenericWarning =<< do - fsep $ pwords "Ignoring GHC pragma for builtin lists; they always compile to Haskell lists." + whenJust pragma $ \ p -> setCurrentRange p $ warning PragmaCompileList let d = dname q t = unqhname TypeK q Just nil <- getBuiltinName builtinNil @@ -582,8 +583,7 @@ -- Compiling Maybe Datatype{ dataPars = np } | is ghcEnvMaybe -> do sequence_ [primNothing, primJust] -- Just to get the proper error for missing NOTHING/JUST - caseMaybe pragma (return ()) $ \ p -> setCurrentRange p $ warning . GenericWarning =<< do - fsep $ pwords "Ignoring GHC pragma for builtin maybe; they always compile to Haskell lists." + whenJust pragma $ \ p -> setCurrentRange p $ warning PragmaCompileMaybe let d = dname q t = unqhname TypeK q Just nothing <- getBuiltinName builtinNothing @@ -1341,9 +1341,7 @@ let isMain = modIsMain && modHasMainFunc -- both need to be IsMain -- Warn if no main function and not --no-main - when (modIsMain /= isMain) $ - genericWarning =<< fsep (pwords "No main function defined in" ++ [prettyTCM agdaMod <> "."] ++ - pwords "Use --no-main to suppress this warning.") + when (modIsMain /= isMain) $ warning $ NoMain agdaMod let overridableArgs = [ "-O"] ++ diff --git a/src/full/Agda/Compiler/ToTreeless.hs b/src/full/Agda/Compiler/ToTreeless.hs --- a/src/full/Agda/Compiler/ToTreeless.hs +++ b/src/full/Agda/Compiler/ToTreeless.hs @@ -2,7 +2,11 @@ module Agda.Compiler.ToTreeless ( toTreeless + , toTreelessWith , closedTermToTreeless + , Pipeline(..) + , CompilerPass(..) + , compilerPass ) where import Prelude hiding ((!!)) @@ -71,43 +75,85 @@ "-- using split tree" $$ pretty st CC.compileClauses' translate cs mst +-- ** Types of pipelines; different backends might use their own custom pipeline. +type BuildPipeline = Int -> QName -> Pipeline + +data Pipeline = FixedPoint Int Pipeline + | Sequential [Pipeline] + | SinglePass CompilerPass + +data CompilerPass = CompilerPass + { passTag :: String + , passVerbosity :: Int + , passName :: String + , passCode :: EvaluationStrategy -> TTerm -> TCM TTerm + } + +type CC = ReaderT CCEnv TCM +type CCContext = [Int] +data CCSubst = EraseUnused | IgnoreUnused deriving Eq + +-- | Environment for treeless conversion. +data CCEnv = CCEnv + { ccCxt :: CCContext + -- ^ Maps case tree de-bruijn indices to TTerm de-bruijn indices. + , ccCatchAll :: Maybe Int + -- ^ TTerm de-bruijn index of the current catch all. + -- If an inner case has no catch-all clause, we use the one from its parent. + , ccEvaluation :: EvaluationStrategy + -- ^ Which evaluation strategy does the backend assumes. + , ccSubstUnused :: CCSubst + -- ^ Whether to erase unused arguments. + } + +type CCConfig = (EvaluationStrategy, CCSubst) + +-- | Initial environment for expression generation. +initCCEnv :: CCConfig -> CCEnv +initCCEnv (eval, su) = CCEnv + { ccCxt = [] + , ccCatchAll = Nothing + , ccEvaluation = eval + , ccSubstUnused = su + } + -- | Converts compiled clauses to treeless syntax. -- -- Note: Do not use any of the concrete names in the returned -- term for identification purposes! If you wish to do so, -- first apply the Agda.Compiler.Treeless.NormalizeNames -- transformation. +toTreelessWith :: BuildPipeline -> CCConfig -> QName -> TCM (Maybe C.TTerm) +toTreelessWith pl cfg q + = ifM (alwaysInline q) (pure Nothing) + $ Just <$> toTreelessWith' pl cfg q + toTreeless :: EvaluationStrategy -> QName -> TCM (Maybe C.TTerm) -toTreeless eval q = ifM (alwaysInline q) (pure Nothing) $ Just <$> toTreeless' eval q +toTreeless eval = toTreelessWith compilerPipeline (eval, EraseUnused) -toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm -toTreeless' eval q = +toTreelessWith' :: BuildPipeline -> CCConfig -> QName -> TCM C.TTerm +toTreelessWith' pl cfg q = flip fromMaybeM (getTreeless q) $ verboseBracket "treeless.convert" 20 ("compiling " ++ prettyShow q) $ do cc <- getCompiledClauses q unlessM (alwaysInline q) $ setTreeless q (C.TDef q) -- so recursive inlining doesn't loop, but not for always inlined -- functions, since that would risk inlining to fail. - ccToTreeless eval q cc + ccToTreelessWith pl cfg q cc --- | Does not require the name to refer to a function. -cacheTreeless :: EvaluationStrategy -> QName -> TCM () -cacheTreeless eval q = do - def <- theDef <$> getConstInfo q - case def of - Function{} -> () <$ toTreeless' eval q - _ -> return () +toTreeless' :: EvaluationStrategy -> QName -> TCM C.TTerm +toTreeless' eval = toTreelessWith' compilerPipeline (eval, EraseUnused) -ccToTreeless :: EvaluationStrategy -> QName -> CC.CompiledClauses -> TCM C.TTerm -ccToTreeless eval q cc = do +ccToTreelessWith :: BuildPipeline -> CCConfig -> QName -> CC.CompiledClauses -> TCM C.TTerm +ccToTreelessWith pl cfg@(eval, su) q cc = do let pbody b = pbody' "" b pbody' suf b = sep [ text (prettyShow q ++ suf) <+> "=", nest 2 $ prettyPure b ] v <- ifM (alwaysInline q) (return 20) (return 0) reportSDoc "treeless.convert" (30 + v) $ "-- compiled clauses of" <+> prettyTCM q $$ nest 2 (prettyPure cc) - body <- casetreeTop eval cc + body <- casetreeTop cfg cc reportSDoc "treeless.opt.converted" (30 + v) $ "-- converted" $$ pbody body - body <- runPipeline eval q (compilerPipeline v q) body + body <- runPipeline eval q (pl v q) body used <- usedArguments q body - when (ArgUnused `elem` used) $ + when (su == EraseUnused && ArgUnused `elem` used) $ reportSDoc "treeless.opt.unused" (30 + v) $ "-- used args:" <+> hsep [ if u == ArgUsed then text [x] else "_" | (x, u) <- zip ['a'..] used ] $$ pbody' "[stripped]" (stripUnusedArguments used body) @@ -116,21 +162,13 @@ setCompiledArgUse q used return body -data Pipeline = FixedPoint Int Pipeline - | Sequential [Pipeline] - | SinglePass CompilerPass - -data CompilerPass = CompilerPass - { passTag :: String - , passVerbosity :: Int - , passName :: String - , passCode :: EvaluationStrategy -> TTerm -> TCM TTerm - } +ccToTreeless :: EvaluationStrategy -> QName -> CC.CompiledClauses -> TCM C.TTerm +ccToTreeless eval = ccToTreelessWith compilerPipeline (eval, EraseUnused) compilerPass :: String -> Int -> String -> (EvaluationStrategy -> TTerm -> TCM TTerm) -> Pipeline compilerPass tag v name code = SinglePass (CompilerPass tag v name code) -compilerPipeline :: Int -> QName -> Pipeline +compilerPipeline :: BuildPipeline compilerPipeline v q = Sequential -- Issue #4967: No simplification step before builtin translation! Simplification relies @@ -177,9 +215,9 @@ return t' | otherwise -> go (i + 1) t' -closedTermToTreeless :: EvaluationStrategy -> I.Term -> TCM C.TTerm -closedTermToTreeless eval t = do - substTerm t `runReaderT` initCCEnv eval +closedTermToTreeless :: CCConfig -> I.Term -> TCM C.TTerm +closedTermToTreeless cfg t = do + substTerm t `runReaderT` initCCEnv cfg alwaysInline :: QName -> TCM Bool alwaysInline q = do @@ -190,25 +228,6 @@ recursive = any (fromMaybe True . clauseRecursive) cs _ -> False --- | Initial environment for expression generation. -initCCEnv :: EvaluationStrategy -> CCEnv -initCCEnv eval = CCEnv - { ccCxt = [] - , ccCatchAll = Nothing - , ccEvaluation = eval - } - --- | Environment for naming of local variables. -data CCEnv = CCEnv - { ccCxt :: CCContext -- ^ Maps case tree de-bruijn indices to TTerm de-bruijn indices - , ccCatchAll :: Maybe Int -- ^ TTerm de-bruijn index of the current catch all - -- If an inner case has no catch-all clause, we use the one from its parent. - , ccEvaluation :: EvaluationStrategy - } - -type CCContext = [Int] -type CC = ReaderT CCEnv TCM - shift :: Int -> CCContext -> CCContext shift n = map (+ n) @@ -225,8 +244,8 @@ lookupLevel l xs = fromMaybe __IMPOSSIBLE__ $ xs !!! (length xs - 1 - l) -- | Compile a case tree into nested case and record expressions. -casetreeTop :: EvaluationStrategy -> CC.CompiledClauses -> TCM C.TTerm -casetreeTop eval cc = flip runReaderT (initCCEnv eval) $ do +casetreeTop :: CCConfig -> CC.CompiledClauses -> TCM C.TTerm +casetreeTop cfg cc = flip runReaderT (initCCEnv cfg) $ do let a = commonArity cc lift $ reportSLn "treeless.convert.arity" 40 $ "-- common arity: " ++ show a lambdasUpTo a $ casetree cc @@ -582,6 +601,14 @@ if static then normalise v else pure v normaliseStatic v = pure v +-- | Does not require the name to refer to a function. +cacheTreeless :: EvaluationStrategy -> QName -> TCM () +cacheTreeless eval q = do + def <- theDef <$> getConstInfo q + case def of + Function{} -> () <$ toTreeless' eval q + _ -> return () + maybeInlineDef :: I.QName -> I.Args -> CC C.TTerm maybeInlineDef q vs = do eval <- asks ccEvaluation @@ -594,8 +621,12 @@ | otherwise -> do -- If ArgUsage hasn't been computed yet, we assume all arguments are used. used <- lift $ fromMaybe [] <$> getCompiledArgUse q - let substUsed _ ArgUnused = pure C.TErased - substUsed arg ArgUsed = substArg arg + su <- asks ccSubstUnused + let substUsed arg used + | used == ArgUnused && su == EraseUnused + = pure C.TErased + | otherwise + = substArg arg C.mkTApp (C.TDef q) <$> zipWithM substUsed vs (used ++ repeat ArgUsed) _ -> C.mkTApp (C.TDef q) <$> substArgs vs where diff --git a/src/full/Agda/Interaction/Base.hs b/src/full/Agda/Interaction/Base.hs --- a/src/full/Agda/Interaction/Base.hs +++ b/src/full/Agda/Interaction/Base.hs @@ -5,7 +5,6 @@ import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar - import Control.Monad ( mplus, liftM2, liftM4 ) import Control.Monad.Except import Control.Monad.Identity @@ -17,7 +16,7 @@ import Data.Maybe (listToMaybe) import {-# SOURCE #-} Agda.TypeChecking.Monad.Base - (HighlightingLevel, HighlightingMethod, TCM, Comparison, Polarity, TCErr) + (HighlightingLevel, HighlightingMethod, Comparison, Polarity) import Agda.Syntax.Abstract (QName) import Agda.Syntax.Common (InteractionId (..), Modality) @@ -76,12 +75,6 @@ , commandQueue = commandQueue } --- | Monad for computing answers to interactive commands. --- --- 'CommandM' is 'TCM' extended with state 'CommandState'. - -type CommandM = StateT CommandState TCM - -- | Information about the current main module. data CurrentFile = CurrentFile { currentFilePath :: AbsolutePath @@ -175,9 +168,9 @@ | Cmd_solveAll Rewrite | Cmd_solveOne Rewrite InteractionId range String - -- | Solve (all goals / the goal at point) by using Auto. - | Cmd_autoOne InteractionId range String - | Cmd_autoAll + -- | Solve (all goals / the goal at point) by using Mimer proof search. + | Cmd_autoOne Rewrite InteractionId range String + | Cmd_autoAll Rewrite -- | Parse the given expression (as if it were defined at the -- top-level of the current module) and infer its type. @@ -462,10 +455,10 @@ | WithoutForce -- ^ Don't ignore any checks. deriving (Eq, Read, Show) -data OutputForm a b = OutputForm Range [ProblemId] Blocker (OutputConstraint a b) +data OutputForm_boot tcErr a b = OutputForm Range [ProblemId] Blocker (OutputConstraint_boot tcErr a b) deriving (Functor) -data OutputConstraint a b +data OutputConstraint_boot tcErr a b = OfType b a | CmpInType Comparison a b b | CmpElim [Polarity] a [b] [b] | JustType b | CmpTypes Comparison b b @@ -476,8 +469,9 @@ | IsEmptyType a | SizeLtSat a | FindInstanceOF b a [(a,a,a)] + | ResolveInstanceOF QName | PTSInstance b b - | PostponedCheckFunDef QName a TCErr + | PostponedCheckFunDef QName a tcErr | CheckLock b b | DataSort QName b | UsableAtMod Modality b diff --git a/src/full/Agda/Interaction/BasicOps.hs b/src/full/Agda/Interaction/BasicOps.hs --- a/src/full/Agda/Interaction/BasicOps.hs +++ b/src/full/Agda/Interaction/BasicOps.hs @@ -24,6 +24,7 @@ import qualified Data.Text as T import Agda.Interaction.Base +import Agda.Interaction.Output import Agda.Interaction.Options import Agda.Interaction.Response (Goals, ResponseContextEntry(..)) @@ -166,7 +167,7 @@ unless (force == WithForce) $ redoChecks mii wakeupConstraints mi solveSizeConstraints DontDefaultToInfty - cubical <- isJust . optCubical <$> pragmaOptions + cubical <- isJust <$> cubicalOption -- don't double check with cubical, because it gets in the way too often. unless (cubical || force == WithForce) $ do -- Double check. @@ -296,6 +297,7 @@ -- should be something else. , metaNumber = Nothing -- in order to print just as ?, not ?n , metaNameSuggestion = "" + , metaKind = Info.UnificationMeta } metaVar = QuestionMark info ii @@ -367,9 +369,11 @@ computeIgnoreAbstract DefaultCompute = False computeIgnoreAbstract HeadCompute = False computeIgnoreAbstract IgnoreAbstract = True -computeIgnoreAbstract UseShowInstance = True - -- UseShowInstance requires the result to be a string literal so respecting - -- abstract can only ever break things. +computeIgnoreAbstract UseShowInstance = False + -- WRONG: UseShowInstance requires the result to be a string literal so respecting abstract can + -- only ever break things. + -- See #7191. Abstract definitions can come with rewrite rules to give nice show behaviour that + -- breaks if we don't respect abstract. computeWrapInput :: ComputeMode -> String -> String computeWrapInput UseShowInstance s = "show (" ++ s ++ ")" @@ -379,7 +383,7 @@ showComputed UseShowInstance e = case e of A.Lit _ (LitString s) -> pure (text $ T.unpack s) - _ -> ("Not a string:" $$) <$> prettyATop e + _ -> ("Expected applying `show` to the given value to produce a string literal, but got:" $$) <$> prettyATop e showComputed _ e = prettyATop e -- | Modifier for interactive commands, @@ -404,6 +408,7 @@ IsEmptyType _ -> __IMPOSSIBLE__ -- Should never be used on IsEmpty constraints SizeLtSat{} -> __IMPOSSIBLE__ FindInstanceOF _ _ _ -> __IMPOSSIBLE__ + ResolveInstanceOF _ -> __IMPOSSIBLE__ PTSInstance i _ -> i PostponedCheckFunDef{} -> __IMPOSSIBLE__ DataSort _ i -> i @@ -471,14 +476,14 @@ DoQuoteTerm cmp v t -> do tm <- A.App defaultAppInfo_ (A.QuoteTerm exprNoRange) . defaultNamedArg <$> reify v OfType tm <$> reify t - Open{} -> __IMPOSSIBLE__ - OpenInstance{} -> __IMPOSSIBLE__ + 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 @@ -545,6 +550,8 @@ [ "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 ] @@ -590,6 +597,7 @@ 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 @@ -662,6 +670,7 @@ SortCmp cmp a b -> Nothing UnBlock{} -> Nothing FindInstance{} -> Nothing + ResolveInstanceHead{} -> Nothing IsEmpty r t -> isMeta (unEl t) CheckSizeLtSat t -> isMeta t CheckFunDef{} -> Nothing @@ -743,7 +752,8 @@ withMetaInfo mv $ do mi <- interactionIdToMetaId ii let m = QuestionMark emptyMetaInfo{ metaNumber = Just mi } ii - abstractToConcrete_ $ OutputForm noRange [] alwaysUnblock $ Assign m e + 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. @@ -890,8 +900,7 @@ unsol = return [] case mvInstantiation mv of InstV{} -> sol (MetaV m $ map Apply args) - Open{} -> unsol - OpenInstance{} -> unsol + OpenMeta{} -> unsol BlockedConst{} -> unsol PostponedTypeCheckingProblem{} -> unsol @@ -949,8 +958,7 @@ implicit is x m = case mvInstantiation m of M.InstV{} -> __IMPOSSIBLE__ - M.Open -> x `notElem` is - M.OpenInstance -> x `notElem` is -- OR: True !? + M.OpenMeta _ -> x `notElem` is -- OR: True in case of InstanceMeta !? M.BlockedConst{} -> False M.PostponedTypeCheckingProblem{} -> False @@ -1178,7 +1186,7 @@ TelV tel' t <- telViewUpTo' (-1) notVisible t -- if we cannot introduce a constructor, we try a lambda let fallback = do - cubical <- isJust . optCubical <$> pragmaOptions + cubical <- isJust <$> cubicalOption TelV tel _ <- (if cubical then telViewPath else telView) t reportSDoc "interaction.intro" 20 $ TP.sep [ "introTactic/fallback" @@ -1244,7 +1252,7 @@ -- 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 . optCubical <$> pragmaOptions + cubical <- isJust <$> cubicalOption r <- (if cubical then id else locallyTCState (stPragmaOptions . lensOptWithoutK) (const (Value False))) $ splitLast CoInductive tel pat @@ -1375,12 +1383,10 @@ -- context extension, -- names paired up with corresponding types. getRecordContents norm ce = do - e <- toAbstract ce - (_, t) <- inferExpr e - let notRecordType = typeError $ ShouldBeRecordType t - (q, vs, defn) <- fromMaybeM notRecordType $ isRecordType t - case defn of - Record{ recFields = fs, recTel = rtel } -> do + (_, t) <- inferExpr =<< toAbstract ce + isRecordType t >>= \case + Nothing -> typeError $ ShouldBeRecordType t + Just (q, vs, RecordData{ _recFields = fs, _recTel = rtel }) -> do let xs = map (nameConcrete . qnameName . unDom) fs tel = apply rtel vs doms = flattenTel tel @@ -1395,7 +1401,6 @@ ] ts <- mapM (normalForm norm . unDom) doms return ([], tel, zip xs ts) - _ -> __IMPOSSIBLE__ -- | Returns the contents of the given module. diff --git a/src/full/Agda/Interaction/EmacsTop.hs b/src/full/Agda/Interaction/EmacsTop.hs --- a/src/full/Agda/Interaction/EmacsTop.hs +++ b/src/full/Agda/Interaction/EmacsTop.hs @@ -25,9 +25,8 @@ 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, renderTCWarnings') +import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings) import Agda.TypeChecking.Monad -import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors(..)) import Agda.Interaction.AgdaTop import Agda.Interaction.Base import Agda.Interaction.BasicOps as B @@ -109,6 +108,16 @@ ] where prn (ii,e)= [showNumIId ii, A $ quote $ prettyShow e] +-- TODO: For now, I piggy-back on the Resp_SolveAll implementation +lispifyResponse (Resp_Mimer ii msol) = return $ case msol of + Nothing -> + [ lastTag 1 $ -- TODO: What is this lastTag used for? + L [ A "agda2-info-action", A $ quote "*Mimer*", A $ quote "No solution found" ] + ] + Just str -> + [ lastTag 1 $ -- TODO: What is this lastTag used for? + L [ A "agda2-solve-action", showNumIId ii, A $ quote str ] + ] lispifyDisplayInfo :: DisplayInfo -> TCM [Lisp String] lispifyDisplayInfo info = case info of @@ -284,7 +293,7 @@ body = List.intercalate "\n" $ catMaybes [ g <$ guard isG - , delimiter "Errors" <$ guard (isE && (isG || isW)) + , delimiter "Error" <$ guard (isE && (isG || isW)) , e <$ guard isE , delimiter "Warnings" <$ guard (isW && (isG || isE)) , w <$ guard isW @@ -295,24 +304,16 @@ showInfoError :: Info_Error -> TCM String showInfoError (Info_GenericError err) = do e <- renderError err - w <- renderTCWarnings' =<< getAllWarningsOfTCErr err - - let errorMsg = if null w - then e - else delimiter "Error" ++ "\n" ++ e - let warningMsg = List.intercalate "\n" $ delimiter "Warning(s)" - : filter (not . null) w - return $ if null w - then errorMsg - else errorMsg ++ "\n\n" ++ warningMsg + w <- prettyTCWarnings =<< getAllWarningsOfTCErr err + let (body, _) = formatWarningsAndErrors "" w e + return body showInfoError (Info_CompilationError warnings) = do s <- prettyTCWarnings warnings return $ unlines - [ "You need to fix the following errors before you can compile" - , "the module:" - , "" - , s - ] + [ "You need to fix the following errors before you can compile the module:" + , "" + , s + ] showInfoError (Info_HighlightingParseError ii) = return $ "Highlighting failed to parse expression in " ++ show ii showInfoError (Info_HighlightingScopeCheckError ii) = diff --git a/src/full/Agda/Interaction/FindFile.hs b/src/full/Agda/Interaction/FindFile.hs --- a/src/full/Agda/Interaction/FindFile.hs +++ b/src/full/Agda/Interaction/FindFile.hs @@ -273,14 +273,11 @@ then do m <- runPM (fst <$> parse moduleNameParser defaultName) `catchError` \_ -> - typeError $ GenericError $ - "The file name " ++ prettyShow file ++ - " is invalid because it does not correspond to a valid module name." + typeError $ InvalidFileName file DoesNotCorrespondToValidModuleName case m of Qual {} -> - typeError $ GenericError $ - "The file name " ++ prettyShow file ++ " is invalid because " ++ - defaultName ++ " is not an unqualified module name." + typeError $ InvalidFileName file $ + RootNameModuleNotAQualifiedModuleName $ T.pack defaultName QName {} -> return $ RawTopLevelModuleName { rawModuleNameRange = getRange m diff --git a/src/full/Agda/Interaction/Highlighting/Dot/Backend.hs b/src/full/Agda/Interaction/Highlighting/Dot/Backend.hs --- a/src/full/Agda/Interaction/Highlighting/Dot/Backend.hs +++ b/src/full/Agda/Interaction/Highlighting/Dot/Backend.hs @@ -27,7 +27,7 @@ import GHC.Generics (Generic) -import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..)) +import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Definition, Recompile(..)) import Agda.Compiler.Common (curIF, IsMain) import Agda.Interaction.FindFile (findFile, srcFilePath) diff --git a/src/full/Agda/Interaction/Highlighting/Dot/Base.hs b/src/full/Agda/Interaction/Highlighting/Dot/Base.hs --- a/src/full/Agda/Interaction/Highlighting/Dot/Base.hs +++ b/src/full/Agda/Interaction/Highlighting/Dot/Base.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} -- | Generate an import dependency graph for a given module. module Agda.Interaction.Highlighting.Dot.Base diff --git a/src/full/Agda/Interaction/Highlighting/FromAbstract.hs b/src/full/Agda/Interaction/Highlighting/FromAbstract.hs --- a/src/full/Agda/Interaction/Highlighting/FromAbstract.hs +++ b/src/full/Agda/Interaction/Highlighting/FromAbstract.hs @@ -27,7 +27,7 @@ import Agda.Syntax.Abstract ( IsProjP(..) ) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common as Common -import Agda.Syntax.Concrete ( FieldAssignment'(..) ) +import Agda.Syntax.Concrete ( FieldAssignment'(..), TacticAttribute' ) import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Info ( ModuleInfo(..) ) import Agda.Syntax.Literal @@ -102,6 +102,7 @@ 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 @@ -225,17 +226,19 @@ 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.NotProjectionLikePragma x -> hilite x - A.InlinePragma _inline x -> hilite x - A.DisplayPragma x ps e -> hilite x <> hilite ps <> hilite e + A.OptionsPragma _strings -> mempty + A.BuiltinPragma b x -> singleAspect Keyword b <> hilite x + A.BuiltinNoDefPragma b k x -> singleAspect Keyword b <> hiliteQName (Just $ kindOfNameToNameKind k) x + A.CompilePragma b x _foreign -> singleAspect Keyword b <> hilite x + A.RewritePragma r xs -> singleAspect Keyword r <> hilite xs + A.StaticPragma x -> hilite x + A.EtaPragma x -> hilite x + A.InjectivePragma x -> hilite x + A.InjectiveForInferencePragma x -> hilite x + A.NotProjectionLikePragma x -> hilite x + A.OverlapPragma x _ -> hilite x + A.InlinePragma _inline x -> hilite x + A.DisplayPragma x ps e -> hilite x <> hilite ps <> hilite e instance Hilite A.Expr where hilite = \case @@ -327,6 +330,7 @@ hilite = \case Rewrite es -> hilite $ fmap snd es Invert _x pes -> hilite pes + LeftLet pes -> hilite pes instance Hilite a => Hilite (A.Clause' a) where hilite (A.Clause lhs strippedPats rhs wh _catchall) = diff --git a/src/full/Agda/Interaction/Highlighting/Generate.hs b/src/full/Agda/Interaction/Highlighting/Generate.hs --- a/src/full/Agda/Interaction/Highlighting/Generate.hs +++ b/src/full/Agda/Interaction/Highlighting/Generate.hs @@ -412,6 +412,8 @@ warningHighlighting' b w = case tcWarning w of TerminationIssue terrs -> terminationErrorHighlighting terrs NotStrictlyPositive d ocs -> positivityErrorHighlighting d ocs + ConstructorDoesNotFitInData c s1 s2 err -> errorWarningHighlighting c + CoinductiveEtaRecord _x -> deadcodeHighlighting w -- #3965 highlight each unreachable clause independently: they -- may be interleaved with actually reachable clauses! UnreachableClauses _ rs -> foldMap deadcodeHighlighting rs @@ -421,7 +423,8 @@ UnsolvedConstraints cs -> if b then constraintsHighlighting [] cs else mempty UnsolvedMetaVariables rs -> if b then metasHighlighting rs else mempty AbsurdPatternRequiresNoRHS{} -> deadcodeHighlighting w - ModuleDoesntExport{} -> 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 @@ -429,6 +432,7 @@ UnsolvedInteractionMetas{} -> mempty InteractionMetaBoundaries{} -> mempty OldBuiltin{} -> mempty + BuiltinDeclaresIdentifier{} -> mempty EmptyRewritePragma{} -> deadcodeHighlighting w EmptyWhere{} -> deadcodeHighlighting w IllformedAsClause{} -> deadcodeHighlighting w @@ -446,7 +450,6 @@ InstanceArgWithExplicitArg{} -> mempty InversionDepthReached{} -> mempty NoGuardednessFlag{} -> mempty - GenericWarning{} -> mempty -- Andreas, 2020-03-21, issue #4456: -- Error warnings that do not have dedicated highlighting -- are highlighted as errors. @@ -457,14 +460,21 @@ InfectiveImport{} -> errorWarningHighlighting w CoInfectiveImport{} -> errorWarningHighlighting w 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{} -> deadcodeHighlighting w PragmaCompileErased{} -> deadcodeHighlighting w + PragmaCompileList{} -> deadcodeHighlighting w + PragmaCompileMaybe{} -> deadcodeHighlighting w + NoMain{} -> mempty NotInScopeW{} -> deadcodeHighlighting w UnsupportedIndexedMatch{} -> mempty AsPatternShadowsConstructorOrPatternSynonym{} @@ -478,6 +488,7 @@ Pa.UnsupportedAttribute{} -> deadcodeHighlighting w Pa.MultipleAttributes{} -> deadcodeHighlighting w Pa.OverlappingTokensWarning{} -> mempty + MissingTypeSignatureForOpaque{} -> errorWarningHighlighting w NotAffectedByOpaque{} -> deadcodeHighlighting w UselessOpaque{} -> deadcodeHighlighting w UnfoldTransparentName r -> deadcodeHighlighting r @@ -507,6 +518,7 @@ -- suggesting that it is not generalized over. UselessAbstract{} -> deadcodeHighlighting w UselessInstance{} -> deadcodeHighlighting w + UselessMacro{} -> deadcodeHighlighting w UselessPrivate{} -> deadcodeHighlighting w InvalidNoPositivityCheckPragma{} -> deadcodeHighlighting w InvalidNoUniverseCheckPragma{} -> deadcodeHighlighting w @@ -514,7 +526,6 @@ InvalidCoverageCheckPragma{} -> deadcodeHighlighting w InvalidConstructor{} -> deadcodeHighlighting w InvalidConstructorBlock{} -> deadcodeHighlighting w - InvalidRecordDirective{} -> deadcodeHighlighting w OpenPublicAbstract{} -> deadcodeHighlighting w OpenPublicPrivate{} -> deadcodeHighlighting w SafeFlagEta {} -> errorWarningHighlighting w @@ -541,6 +552,9 @@ -- Not source code related DuplicateInterfaceFiles{} -> mempty + + -- Backends + CustomBackendWarning{} -> mempty recordFieldWarningHighlighting :: RecordFieldWarning -> HighlightingInfoBuilder diff --git a/src/full/Agda/Interaction/Highlighting/HTML/Backend.hs b/src/full/Agda/Interaction/Highlighting/HTML/Backend.hs --- a/src/full/Agda/Interaction/Highlighting/HTML/Backend.hs +++ b/src/full/Agda/Interaction/Highlighting/HTML/Backend.hs @@ -23,7 +23,7 @@ , OptDescr(..) , Flag ) -import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..)) +import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Recompile(..)) import Agda.Compiler.Common (IsMain(..), curIF) import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) diff --git a/src/full/Agda/Interaction/Highlighting/HTML/Base.hs b/src/full/Agda/Interaction/Highlighting/HTML/Base.hs --- a/src/full/Agda/Interaction/Highlighting/HTML/Base.hs +++ b/src/full/Agda/Interaction/Highlighting/HTML/Base.hs @@ -21,7 +21,6 @@ import Control.Monad.Trans ( MonadIO(..), lift ) import Control.Monad.Trans.Reader ( ReaderT(runReaderT), ask ) -import Data.Function ( on ) import Data.Foldable (toList, concatMap) import Data.Maybe import qualified Data.IntMap as IntMap diff --git a/src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs b/src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs --- a/src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs +++ b/src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs @@ -25,7 +25,7 @@ import System.FilePath ( () ) -import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..)) +import Agda.Compiler.Backend (Backend,Backend_boot(..), Backend',Backend'_boot(..), Definition, Recompile(..)) import Agda.Compiler.Common (curIF, IsMain(IsMain, NotMain)) import Agda.Interaction.Options diff --git a/src/full/Agda/Interaction/Highlighting/Range.hs b/src/full/Agda/Interaction/Highlighting/Range.hs --- a/src/full/Agda/Interaction/Highlighting/Range.hs +++ b/src/full/Agda/Interaction/Highlighting/Range.hs @@ -65,7 +65,7 @@ -- The ranges are assumed to be well-formed. overlapping :: Range -> Range -> Bool -overlapping r1 r2 = (not $ r1 `isLeftOf` r2) && (not $ r2 `isLeftOf` r1) +overlapping r1 r2 = not (r1 `isLeftOf` r2) && not (r2 `isLeftOf` r1) isLeftOf :: Range -> Range -> Bool isLeftOf r1 r2 = to r1 <= from r2 diff --git a/src/full/Agda/Interaction/Imports.hs b/src/full/Agda/Interaction/Imports.hs --- a/src/full/Agda/Interaction/Imports.hs +++ b/src/full/Agda/Interaction/Imports.hs @@ -64,6 +64,7 @@ import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Translation.ConcreteToAbstract as CToA +import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Errors import Agda.TypeChecking.Warnings hiding (warnings) import Agda.TypeChecking.Reduce @@ -168,11 +169,14 @@ ] -- | Set options from a 'Source' pragma, using the source --- ranges of the pragmas for error reporting. -setOptionsFromSourcePragmas :: Source -> TCM () -setOptionsFromSourcePragmas src = do - mapM_ setOptionsFromPragma (srcDefaultPragmas src) - mapM_ setOptionsFromPragma (srcFilePragmas src) +-- ranges of the pragmas for error reporting. Flag to check consistency. +setOptionsFromSourcePragmas :: Bool -> Source -> TCM () +setOptionsFromSourcePragmas checkOpts src = do + mapM_ setOpts (srcDefaultPragmas src) + mapM_ setOpts (srcFilePragmas src) + where + setOpts | checkOpts = checkAndSetOptionsFromPragma + | otherwise = setOptionsFromPragma -- | Is the aim to type-check the top-level module, or only to -- scope-check it? @@ -277,7 +281,6 @@ stTCWarnings `modifyTCLens` \ imp -> imp `List.union` warnings stOpaqueBlocks `modifyTCLens` \ imp -> imp `Map.union` oblock stOpaqueIds `modifyTCLens` \ imp -> imp `Map.union` oid - addImportedInstances isig -- | Scope checks the given module. A proper version of the module -- name (with correct definition sites) is returned. @@ -419,7 +422,7 @@ -- liftIO . putStrLn . show =<< getVerbosity -- For the main interface, we also remember the pragmas from the file - setOptionsFromSourcePragmas src + setOptionsFromSourcePragmas True src loadPrims <- optLoadPrimitives <$> pragmaOptions when loadPrims $ do @@ -537,10 +540,17 @@ let recheck = \reason -> do reportSLn "import.iface" 5 $ concat [" ", prettyShow x, " is not up-to-date because ", reason, "."] setCommandLineOptions . stPersistentOptions . stPersistentState =<< getTC - case isMain of + modl <- case isMain of MainInterface _ -> createInterface x file isMain msrc NotMainInterface -> createInterfaceIsolated x file msrc + -- Ensure that the given module name matches the one in the file. + let topLevelName = iTopLevelModuleName (miInterface modl) + unless (topLevelName == x) $ + typeError $ OverlappingProjects (srcFilePath file) topLevelName x + + return modl + either recheck pure stored -- | Check if the options used for checking an imported module are @@ -654,7 +664,7 @@ Bench.billTo [Bench.Deserialization] $ do checkSourceHashET (iSourceHash i) - reportSLn "import.iface" 5 $ " using stored version of " ++ (filePath $ intFilePath ifile) + reportSLn "import.iface" 5 $ " using stored version of " ++ filePath (intFilePath ifile) loadDecodedModule file mi Left whyNotCached -> withExceptT (\e -> concat [whyNotCached, " and ", e]) $ do @@ -680,18 +690,13 @@ -- Ensure that the given module name matches the one in the file. let topLevelName = iTopLevelModuleName i unless (topLevelName == x) $ - -- Andreas, 2014-03-27 This check is now done in the scope checker. - -- checkModuleName topLevelName file lift $ typeError $ OverlappingProjects (srcFilePath file) topLevelName x isPrimitiveModule <- lift $ Lens.isPrimitiveModule (filePath $ srcFilePath file) lift $ chaseMsg "Loading " x $ Just ifp -- print imported warnings - let ws = filter ((Strict.Just (Just x) ==) . - fmap rangeFileName . tcWarningOrigin) $ - iWarnings i - unless (null ws) $ alwaysReportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws + reportWarningsForModule x $ iWarnings i loadDecodedModule file $ ModuleInfo { miInterface = i @@ -700,7 +705,14 @@ , miMode = ModuleTypeChecked } +-- | Report those given warnings that come from the given module. +reportWarningsForModule :: MonadDebug m => TopLevelModuleName -> [TCWarning] -> m () +reportWarningsForModule x warns = do + unlessNull (filter ((Strict.Just (Just x) ==) . fmap rangeFileName . tcWarningOrigin) warns) \ ws -> + alwaysReportSDoc "warning" 1 $ P.vsep $ map P.prettyTCM ws + + loadDecodedModule :: SourceFile -- ^ File we process. @@ -921,7 +933,9 @@ -- [Old: Andreas, 2016-02-02 this causes issue #1804, so don't do it:] -- Andreas, 2020-05-13, #1804, #4647: removed private declarations -- only when we actually write the interface. - let filteredIface = i { iInsideScope = withoutPrivates $ iInsideScope i } + let + filteredIface = i { iInsideScope = withoutPrivates $ iInsideScope i } + filteredIface <- pruneTemporaryInstances filteredIface reportSLn "import.iface.write" 50 $ "Writing interface file with hash " ++ show (iFullHash filteredIface) ++ "." encodedIface <- encodeFile fp filteredIface @@ -957,11 +971,7 @@ (chaseMsg checkMsg x $ Just fp) (const $ do ws <- getAllWarnings AllWarnings let classified = classifyWarnings ws - let wa' = filter ((Strict.Just (Just mname) ==) . - fmap rangeFileName . tcWarningOrigin) $ - tcWarnings classified - unless (null wa') $ - alwaysReportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> wa' + reportWarningsForModule mname $ tcWarnings classified when (null (nonFatalErrors classified)) $ chaseMsg "Finished" x Nothing) withMsgs $ @@ -987,7 +997,11 @@ (TL.unpack $ srcText src) stTokens `modifyTCLens` (fileTokenInfo <>) - setOptionsFromSourcePragmas src + -- Only check consistency if not main (we check consistency for the main module in + -- `typeCheckMain`. + let checkConsistency | MainInterface{} <- isMain = False + | otherwise = True + setOptionsFromSourcePragmas checkConsistency src checkAttributes (srcAttributes src) syntactic <- optSyntacticEquality <$> pragmaOptions localTC (\env -> env { envSyntacticEqualityFuel = syntactic }) $ do @@ -1201,8 +1215,7 @@ i{ iScope = publicModules $ iInsideScope i } -- | Builds an interface for the current module, which should already --- have been successfully type checked. - +-- have been successfully type checked. buildInterface :: Source -- ^ 'Source' for the current module. @@ -1216,6 +1229,7 @@ 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 @@ -1226,82 +1240,77 @@ -- that introduced this change seems to have made Agda a bit -- faster and interface file sizes a bit smaller, at least for the -- standard library). - builtin <- useTC stLocalBuiltins - mhs <- mapM (\top -> (top,) <$> moduleHash top) . - Set.toAscList =<< - useR stImportedModules - foreignCode <- useTC stForeignCode + !mhs <- mapM (\top -> (top,) <$> moduleHash top) . Set.toAscList =<< useR stImportedModules + !foreignCode <- useTC stForeignCode + + let !scope = topLevelScope topLevel + + (!solvedMetas, !definitions) <- 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 + -- Ulf, 2016-04-12: -- Non-closed display forms are not applicable outside the module anyway, -- and should be dead-code eliminated (#1928). - origDisplayForms <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms - -- TODO: Kill some ranges? - let scope = topLevelScope topLevel - -- Andreas, Oskar, 2023-10-19, issue #6931: - -- To not delete module telescopes of empty public modules, - -- we need to pass the public modules to the dead-code elimination - -- (to be mined for additional roots for the reachability analysis). - (display, sig, solvedMetas) <- - eliminateDeadCode (publicModules scope) builtin origDisplayForms ==<< - (getSignature, useR stSolvedMetaStore) - userwarns <- useTC stLocalUserWarnings - importwarn <- useTC stWarningOnImport - syntaxInfo <- useTC stSyntaxInfo - optionsUsed <- useTC stPragmaOptions - partialDefs <- useTC stLocalPartialDefs + !importedDisplayForms <- + HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms + !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 + !opaqueBlocks' <- useTC stOpaqueBlocks + !opaqueIds' <- useTC stOpaqueIds let - mh = moduleNameId (srcModuleName src) - opaqueBlocks = Map.filterWithKey (\(OpaqueId _ mod) _ -> mod == mh) opaqueBlocks' + !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' + !opaqueIds = Map.filterWithKey (\qnm (OpaqueId _ mod) -> isLocal qnm || mod == mh) opaqueIds' - -- Andreas, 2015-02-09 kill ranges in pattern synonyms before - -- serialization to avoid error locations pointing to external files - -- when expanding a pattern synonym. - patsyns <- killRange <$> getPatternSyns - let builtin' = Map.mapWithKey (\ x b -> primName x <$> b) builtin - warnings <- 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 = display - , iUserWarnings = userwarns - , iImportWarning = importwarn - , iBuiltin = builtin' - , iForeignCode = foreignCode - , iHighlighting = syntaxInfo + !builtin <- Map.mapWithKey (\ x b -> primName x <$> b) <$> useTC stLocalBuiltins + !warnings <- 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 = importedDisplayForms + , 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 + , iOptionsUsed = optionsUsed + , iPatternSyns = patsyns + , iWarnings = warnings + , iPartialDefs = partialDefs + , iOpaqueBlocks = opaqueBlocks + , iOpaqueNames = opaqueIds } - i <- + !i <- ifM (optSaveMetas <$> pragmaOptions) (return i) (do reportSLn "import.iface" 7 - " instantiating all meta variables" - -- Note that the meta-variables in the definitions in - -- "sig" have already been instantiated (by - -- eliminateDeadCode). - instantiateFullExceptForDefinitions i) + " instantiating all metavariables in interface" + Bench.billTo [Bench.InterfaceInstantiateFull] $ liftReduce $ instantiateFull' i) reportSLn "import.iface" 7 " interface complete" return i diff --git a/src/full/Agda/Interaction/InteractionTop.hs b/src/full/Agda/Interaction/InteractionTop.hs --- a/src/full/Agda/Interaction/InteractionTop.hs +++ b/src/full/Agda/Interaction/InteractionTop.hs @@ -13,7 +13,6 @@ import Control.Concurrent.Async import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TVar - import qualified Control.Exception as E import Control.Monad @@ -22,6 +21,7 @@ import Control.Monad.Fail ( MonadFail ) import Control.Monad.State ( MonadState(..), gets, modify, runStateT ) import Control.Monad.STM +import Control.Monad.State ( StateT ) import Control.Monad.Trans ( lift ) import qualified Data.Char as Char @@ -72,12 +72,14 @@ import Agda.Compiler.Backend -import Agda.Auto.Auto as Auto +import Agda.Mimer.Mimer as Mimer +import qualified Control.DeepSeq as DeepSeq import Agda.Utils.Either import Agda.Utils.FileName import Agda.Utils.Function import Agda.Utils.Hash +import Agda.Utils.IO (showIOException) import Agda.Utils.Lens import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad @@ -91,10 +93,13 @@ import Agda.Utils.WithDefault (lensCollapseDefault, lensKeepDefault) import Agda.Utils.Impossible +import Agda.TypeChecking.Opacity (saturateOpaqueBlocks) ------------------------------------------------------------------------ -- The CommandM monad +type CommandM = StateT CommandState TCM + -- | Restore both 'TCState' and 'CommandState'. localStateCommandM :: CommandM a -> CommandM a @@ -235,9 +240,9 @@ handleNastyErrors :: CommandM () -> CommandM () handleNastyErrors m = commandMToIO $ \ toIO -> do let handle e = - Right <$> - toIO (handleErr (Just Direct) $ - Exception noRange $ text $ E.displayException e) + Right <$> do + toIO $ handleErr (Just Direct) $ + Exception noRange $ text $ showIOException e asyncHandler e@AsyncCancelled = return (Left e) @@ -253,6 +258,11 @@ -- error. Because this function may switch the focus to another file -- the status information is also updated. handleErr method e = do + + -- TODO: make a better predicate for this + noError <- lift $ null <$> renderError e + unless noError do + unsolved <- lift $ computeUnsolvedInfo err <- lift $ errorHighlighting e modFile <- lift $ useTC stModuleToSource @@ -262,12 +272,9 @@ let info = convert $ err <> unsolved -- Errors take precedence over unsolved things. - -- TODO: make a better predicate for this - noError <- lift $ null <$> renderError e - showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions - unless noError $ do + do mapM_ putResponse $ [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] ++ tellEmacsToJumpToError (getRange e) ++ @@ -691,55 +698,42 @@ let s' = trim s in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s' -interpret (Cmd_autoOne ii rng hint) = do - -- Andreas, 2014-07-05 Issue 1226: - -- Save the state to have access to even those interaction ids - -- that Auto solves (since Auto gives the solution right away). - st <- getTC - (time , res) <- maybeTimed $ Auto.auto ii rng hint - case autoProgress res of - Solutions sols -> do - lift $ reportSLn "auto" 10 $ "Auto produced the following solutions " ++ show sols - forM_ sols $ \(ii', sol) -> do - -- Andreas, 2014-07-05 Issue 1226: - -- For highlighting, Resp_GiveAction needs to access - -- the @oldInteractionScope@s of the interaction points solved by Auto. - -- We dig them out from the state before Auto was invoked. - insertOldInteractionScope ii' =<< liftLocalState (putTC st >> getInteractionScope ii') - -- Andreas, 2014-07-07: NOT TRUE: - -- -- Andreas, 2014-07-05: The following should be obsolete, - -- -- as Auto has removed the interaction points already: - -- modifyTheInteractionPoints $ filter (/= ii) - putResponse $ Resp_GiveAction ii' $ Give_String sol - -- Andreas, 2014-07-07: Remove the interaction points in one go. - modifyTheInteractionPoints (List.\\ (map fst sols)) - case autoMessage res of - Nothing -> interpret $ Cmd_metas AsIs - Just msg -> display_info $ Info_Auto msg - FunClauses cs -> do - case autoMessage res of - Nothing -> return () - Just msg -> display_info $ Info_Auto msg - putResponse $ Resp_MakeCase ii R.Function cs - Refinement s -> give_gen WithoutForce ii rng s Refine - maybe (return ()) (display_info . Info_Time) time +interpret (Cmd_autoOne norm ii rng str) = do + iscope <- getInteractionScope ii + (time, result) <- maybeTimed $ Mimer.mimer norm ii rng str + case result of + MimerNoResult -> display_info $ Info_Auto "No solution found" + MimerExpr str -> do + insertOldInteractionScope ii iscope + putResponse $ Resp_GiveAction ii $ Give_String str + modifyTheInteractionPoints (List.delete ii) + maybe (return ()) (display_info . Info_Time) time + MimerList sols -> do + display_info $ Info_Auto $ unlines $ + [ "Solutions:" ] ++ + [ " " ++ show i ++ ". " ++ s | (i, s) <- sols ] + MimerClauses{} -> __IMPOSSIBLE__ -- Mimer can't do case splitting yet -interpret Cmd_autoAll = do +interpret (Cmd_autoAll norm) = do iis <- getInteractionPoints + getOldScope <- do + st <- getTC + pure $ \ ii -> liftLocalState $ putTC st >> getInteractionScope ii unless (null iis) $ do let time = 1000 `div` length iis st <- getTC - solved <- forM iis $ \ ii -> do + solved <- fmap concat $ forM iis $ \ ii -> do rng <- getInteractionRange ii - res <- Auto.auto ii rng ("-t " ++ show time ++ "ms") - case autoProgress res of - Solutions sols -> forM sols $ \ (jj, s) -> do - oldInteractionScope <- liftLocalState (putTC st >> getInteractionScope jj) - insertOldInteractionScope jj oldInteractionScope - putResponse $ Resp_GiveAction ii $ Give_String s - return jj - _ -> return [] - modifyTheInteractionPoints (List.\\ concat solved) + res <- Mimer.mimer norm ii rng ("-t " ++ show time ++ "ms") + case res of + MimerNoResult -> pure [] + MimerExpr str -> do + insertOldInteractionScope ii =<< getOldScope ii + 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) @@ -816,26 +810,8 @@ ] ] putResponse $ Resp_MakeCase ii (makeCaseVariant casectxt) pcs' - where - decorate = renderStyle (style { mode = OneLineMode }) - makeCaseVariant :: CaseContext -> MakeCaseVariant - makeCaseVariant Nothing = R.Function - makeCaseVariant Just{} = R.ExtendedLambda - -- very dirty hack, string manipulation by dropping the function name - -- and replacing the last " = " with " -> ". It's important not to replace - -- the equal sign in named implicit with an arrow! - extlam_dropName :: UnicodeOrAscii -> CaseContext -> String -> String - extlam_dropName _ Nothing x = x - extlam_dropName glyphMode Just{} x - = unwords $ reverse $ replEquals $ reverse $ drop 1 $ words x - where - arrow = render $ _arrow $ specialCharactersForGlyphs glyphMode - replEquals ("=" : ws) = arrow : ws - replEquals (w : ws) = w : replEquals ws - replEquals [] = [] - interpret (Cmd_compute cmode ii rng s) = do expr <- liftLocalState $ do e <- B.parseExprIn ii rng $ B.computeWrapInput cmode s @@ -847,6 +823,27 @@ interpret Cmd_abort = return () interpret Cmd_exit = return () + +decorate :: Doc -> String +decorate = renderStyle (style { mode = OneLineMode }) + +makeCaseVariant :: CaseContext -> MakeCaseVariant +makeCaseVariant Nothing = R.Function +makeCaseVariant Just{} = R.ExtendedLambda + +-- very dirty hack, string manipulation by dropping the function name +-- and replacing the last " = " with " -> ". It's important not to replace +-- the equal sign in named implicit with an arrow! +extlam_dropName :: UnicodeOrAscii -> CaseContext -> String -> String +extlam_dropName _ Nothing x = x +extlam_dropName glyphMode Just{} x + = unwords $ reverse $ replEquals $ reverse $ drop 1 $ words x + where + arrow = render $ _arrow $ specialCharactersForGlyphs glyphMode + replEquals ("=" : ws) = arrow : ws + replEquals (w : ws) = w : replEquals ws + replEquals [] = [] + -- | Solved goals already instantiated internally -- The second argument potentially limits it to one specific goal. solveInstantiatedGoals :: Rewrite -> Maybe InteractionId -> CommandM () @@ -1022,6 +1019,13 @@ [ "ce = " ++ show ce , "scopePrecedence = " ++ show (scope ^. scopePrecedence) ] + + -- Issue 7218: if the give/refine command creates an extended + -- lambda, it also needs to be added to the relevant unfolding sets. + -- The easiest way to make sure this is consistent is to just re-run + -- the saturation procedures. + saturateOpaqueBlocks + -- if the command was @Give@, use the literal user input; -- Andreas, 2014-01-15, see issue 1020: -- Refine could solve a goal by introducing the sole constructor diff --git a/src/full/Agda/Interaction/JSONTop.hs b/src/full/Agda/Interaction/JSONTop.hs --- a/src/full/Agda/Interaction/JSONTop.hs +++ b/src/full/Agda/Interaction/JSONTop.hs @@ -14,7 +14,9 @@ import Agda.Interaction.AgdaTop import Agda.Interaction.Base - ( CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..) ) + ( CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..) + , OutputConstraint_boot(..), OutputForm_boot(..)) +import Agda.Interaction.Output (OutputConstraint, OutputForm) import qualified Agda.Interaction.BasicOps as B import Agda.Interaction.EmacsTop import Agda.Interaction.JSON @@ -242,6 +244,9 @@ [ "value" #= encPrettyTCM v , "type" #= encPrettyTCM t ] + ResolveInstanceOF q -> kind "ResolveInstanceOF" + [ "name" @= encodePretty q + ] PTSInstance a b -> kind "PTSInstance" [ "constraintObjs" #= traverse f [a, b] ] @@ -459,6 +464,9 @@ [ "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 diff --git a/src/full/Agda/Interaction/Library.hs b/src/full/Agda/Interaction/Library.hs --- a/src/full/Agda/Interaction/Library.hs +++ b/src/full/Agda/Interaction/Library.hs @@ -61,6 +61,7 @@ import System.Directory import System.FilePath import System.Environment +import System.IO.Error ( isPermissionError ) import Agda.Interaction.Library.Base import Agda.Interaction.Library.Parse @@ -109,9 +110,7 @@ (x, ews) <- lift $ lift $ runWriterT m let (errs, warns) = partitionEithers ews tell warns - unless (null errs) $ do - let doc = vcat $ map (formatLibError libs) errs - throwError doc + () <- List1.unlessNull errs \ errs -> throwError $ LibErrors libs errs return x ------------------------------------------------------------------------ @@ -193,7 +192,7 @@ findProjectConfig' root = do getCachedProjectConfig root >>= \case Just conf -> return conf - Nothing -> do + Nothing -> handlePermissionException do libFiles <- liftIO $ getDirectoryContents root >>= filterM (\file -> and2M (pure $ takeExtension file == ".agda-lib") @@ -217,6 +216,13 @@ return conf 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 :: LibErrorIO ProjectConfig -> LibErrorIO 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. -- diff --git a/src/full/Agda/Interaction/Library/Base.hs b/src/full/Agda/Interaction/Library/Base.hs --- a/src/full/Agda/Interaction/Library/Base.hs +++ b/src/full/Agda/Interaction/Library/Base.hs @@ -26,9 +26,11 @@ import Agda.Syntax.Position +import Agda.Utils.IO ( showIOException ) import Agda.Utils.Lens import Agda.Utils.List1 ( List1, toList ) import Agda.Utils.List2 ( List2, toList ) +import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null import Agda.Syntax.Common.Pretty @@ -42,7 +44,7 @@ , lfExists :: Bool -- ^ The libraries file might not exist, -- but we may print its assumed location in error messages. - } deriving (Show) + } deriving (Show, Generic) -- | A symbolic executable name. -- @@ -187,6 +189,7 @@ -- * Errors data LibError = LibError (Maybe LibPositionInfo) LibError' + deriving (Show, Generic) -- | Collected errors while processing library files. -- @@ -215,7 +218,7 @@ -- ^ Name of the executable that is defined twice. (List2 (LineNumber, FilePath)) -- ^ The resolutions of the executable. - -- deriving (Show) + deriving (Show, Generic) -- | Exceptions thrown by the @.agda-lib@ parser. -- @@ -237,6 +240,7 @@ -- ^ 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 @@ -265,8 +269,8 @@ -- type LibErrorIO = WriterT LibErrWarns (StateT LibState IO) --- | Throws 'Doc' exceptions, still collects 'LibWarning's. -type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO)) +-- | Throws 'LibErrors' exceptions, still collects 'LibWarning's. +type LibM = ExceptT LibErrors (WriterT [LibWarning] (StateT LibState IO)) -- | Cache locations of project configurations and parsed @.agda-lib@ files. type LibState = @@ -274,6 +278,13 @@ , Map FilePath AgdaLibFile ) +-- | Collected errors when processing an @.agda-lib@ file. +-- +data LibErrors = LibErrors + { libErrorsInstalledLibraries :: [AgdaLibFile] + , libErrors :: List1 LibError + } deriving (Show, Generic) + getCachedProjectConfig :: (MonadState LibState m, MonadIO m) => FilePath -> m (Maybe ProjectConfig) @@ -315,6 +326,12 @@ (_ , 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 @@ -401,7 +418,7 @@ ReadError e msg -> vcat [ text $ msg - , text $ E.displayException e + , text $ showIOException e ] DuplicateExecutable exeFile exe paths -> vcat $ @@ -417,7 +434,7 @@ [ "Bad library name:", quotes (text s) ] ReadFailure file e -> vcat [ hsep [ "Failed to read library file", text file <> "." ] - , "Reason:" <+> text (E.displayException e) + , "Reason:" <+> text (showIOException e) ] MissingFields xs -> "Missing" <+> listFields xs @@ -451,8 +468,14 @@ ------------------------------------------------------------------------ instance NFData ExecutablesFile +instance NFData LibrariesFile instance NFData ProjectConfig instance NFData AgdaLibFile 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 _ = () diff --git a/src/full/Agda/Interaction/MakeCase.hs b/src/full/Agda/Interaction/MakeCase.hs --- a/src/full/Agda/Interaction/MakeCase.hs +++ b/src/full/Agda/Interaction/MakeCase.hs @@ -9,7 +9,6 @@ import Control.Monad import Data.Either -import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Monoid @@ -142,11 +141,11 @@ -- has been refined to a module parameter we do allow splitting -- on it, since the instantiation could as well have been the -- other way around (see #2183). - (Just (Var i []), PatternBound) -> return (i, C.InScope) + (Just (Var i []), PatternBound _) -> return (i, C.InScope) -- Case 1b: the variable has been refined. - (Just v , PatternBound) -> failInstantiatedVar s v + (Just v , PatternBound _) -> failInstantiatedVar s v -- Case 1c: the variable is bound locally (e.g. a record let) - (Nothing , PatternBound) -> failCaseLet s + (Nothing , PatternBound _) -> failCaseLet s -- Case 1d: module parameter (Just (Var i []), LambdaBound ) -> failModuleBound s -- Case 1e: locally lambda-bound variable diff --git a/src/full/Agda/Interaction/Options/Base.hs b/src/full/Agda/Interaction/Options/Base.hs --- a/src/full/Agda/Interaction/Options/Base.hs +++ b/src/full/Agda/Interaction/Options/Base.hs @@ -31,6 +31,8 @@ , InfectiveCoinfective(..) , InfectiveCoinfectiveOption(..) , infectiveCoinfectiveOptions + , ImpliedPragmaOption(..) + , impliedPragmaOptions , safeFlag , mapFlag , usage @@ -77,11 +79,12 @@ , lensOptCubical , lensOptGuarded , lensOptFirstOrder + , lensOptRequireUniqueMetaSolutions , lensOptPostfixProjections , lensOptKeepPatternVariables , lensOptInferAbsurdClauses , lensOptInstanceSearchDepth - , lensOptOverlappingInstances + , lensOptBacktrackingInstances , lensOptQualifiedInstances , lensOptInversionMaxDepth , lensOptSafe @@ -138,10 +141,11 @@ , optRewriting , optGuarded , optFirstOrder + , optRequireUniqueMetaSolutions , optPostfixProjections , optKeepPatternVariables , optInferAbsurdClauses - , optOverlappingInstances + , optBacktrackingInstances , optQualifiedInstances , optSafe , optDoubleCheck @@ -344,7 +348,7 @@ -- ^ Allow definitions by copattern matching? , _optPatternMatching :: WithDefault 'True -- ^ Is pattern matching allowed in the current file? - , _optExactSplit :: WithDefault 'False + , _optExactSplit :: WithDefault 'True , _optHiddenArgumentPuns :: WithDefault 'False -- ^ Should patterns of the form @{x}@ or @⦃ x ⦄@ be interpreted as puns? , _optEta :: WithDefault 'True @@ -364,18 +368,21 @@ , _optCubical :: Maybe Cubical , _optGuarded :: WithDefault 'False , _optFirstOrder :: WithDefault 'False - -- ^ Should we speculatively unify function applications as if they were injective? - , _optPostfixProjections :: 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 '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 - , _optOverlappingInstances :: WithDefault 'False + , _optBacktrackingInstances :: WithDefault 'False , _optQualifiedInstances :: WithDefault 'True -- ^ Should instance search consider instances with qualified names? , _optInversionMaxDepth :: Int @@ -418,7 +425,7 @@ -- This is a stronger form of 'optImportSorts'. , _optAllowExec :: WithDefault 'False -- ^ Allow running external @executables@ from meta programs. - , _optSaveMetas :: WithDefault 'False + , _optSaveMetas :: WithDefault 'True -- ^ Save meta-variables to interface files. , _optShowIdentitySubstitutions :: WithDefault 'False -- ^ Show identity substitutions when pretty-printing terms @@ -453,6 +460,32 @@ instance NFData PrintAgdaVersion +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 @@ -489,10 +522,11 @@ optRewriting :: PragmaOptions -> Bool optGuarded :: PragmaOptions -> Bool optFirstOrder :: PragmaOptions -> Bool +optRequireUniqueMetaSolutions :: PragmaOptions -> Bool optPostfixProjections :: PragmaOptions -> Bool optKeepPatternVariables :: PragmaOptions -> Bool optInferAbsurdClauses :: PragmaOptions -> Bool -optOverlappingInstances :: PragmaOptions -> Bool +optBacktrackingInstances :: PragmaOptions -> Bool optQualifiedInstances :: PragmaOptions -> Bool optSafe :: PragmaOptions -> Bool optDoubleCheck :: PragmaOptions -> Bool @@ -550,10 +584,12 @@ 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 -optOverlappingInstances = collapseDefault . _optOverlappingInstances +optBacktrackingInstances = collapseDefault . _optBacktrackingInstances optQualifiedInstances = collapseDefault . _optQualifiedInstances optSafe = collapseDefault . _optSafe optDoubleCheck = collapseDefault . _optDoubleCheck @@ -724,6 +760,9 @@ 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 } @@ -736,8 +775,8 @@ lensOptInstanceSearchDepth :: Lens' PragmaOptions _ lensOptInstanceSearchDepth f o = f (_optInstanceSearchDepth o) <&> \ i -> o{ _optInstanceSearchDepth = i } -lensOptOverlappingInstances :: Lens' PragmaOptions _ -lensOptOverlappingInstances f o = f (_optOverlappingInstances o) <&> \ i -> o{ _optOverlappingInstances = 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 } @@ -892,11 +931,12 @@ , _optCubical = Nothing , _optGuarded = Default , _optFirstOrder = Default + , _optRequireUniqueMetaSolutions = Default , _optPostfixProjections = Default , _optKeepPatternVariables = Default , _optInferAbsurdClauses = Default , _optInstanceSearchDepth = 500 - , _optOverlappingInstances = Default + , _optBacktrackingInstances = Default , _optQualifiedInstances = Default , _optInversionMaxDepth = 50 , _optSafe = Default @@ -944,6 +984,9 @@ 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 @@ -951,13 +994,15 @@ instance Pretty OptionWarning where pretty = \case OptionRenamed old new -> hsep - [ "Option", name old, "is deprecated, please use", name new, "instead" ] + [ "Option", option old, "is deprecated, please use", option new, "instead" ] + WarningProblem err -> pretty (prettyWarningModeError err) <+> "See --help=warning." where - name = text . ("--" ++) + 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). @@ -1305,10 +1350,10 @@ withKFlag :: Flag PragmaOptions withKFlag = -- with-K is the opposite of --without-K, so collapse default when disabling --without-K - (lensOptWithoutK $ lensCollapseDefault $ const $ pure False) + lensOptWithoutK (lensCollapseDefault $ const $ pure False) >=> -- with-K only restores any unsetting of --erased-matches, so keep its default - (lensOptErasedMatches $ lensKeepDefault $ const $ pure True) + lensOptErasedMatches (lensKeepDefault $ const $ pure True) withoutKFlag :: Flag PragmaOptions @@ -1405,7 +1450,7 @@ warningModeFlag :: String -> Flag PragmaOptions warningModeFlag s o = case warningModeUpdate s of Right upd -> return $ o { _optWarningMode = upd (_optWarningMode o) } - Left err -> throwError $ prettyWarningModeError err ++ " See --help=warning." + Left err -> o <$ tell1 (WarningProblem err) terminationDepthFlag :: String -> Flag PragmaOptions terminationDepthFlag s o = @@ -1728,6 +1773,7 @@ "enable @lock/@tick attributes" "" $ Just "disable @lock/@tick attributes" , lossyUnificationOption + , requireUniqueMetaSolutionsOptions , pragmaFlag "postfix-projections" lensOptPostfixProjections "prefer postfix projection notation" "" $ Just "prefer prefix projection notation" @@ -1740,9 +1786,7 @@ , [ Option [] ["instance-search-depth"] (ReqArg instanceDepthFlag "N") "set instance search depth to N (default: 500)" ] - , pragmaFlag "overlapping-instances" lensOptOverlappingInstances - "consider recursive instance arguments during pruning of instance candidates" "" - Nothing + , backtrackingInstancesOption , pragmaFlag "qualified-instances" lensOptQualifiedInstances "use instances with qualified names" "" Nothing @@ -1824,6 +1868,20 @@ "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)] @@ -1844,6 +1902,9 @@ , map (uncurry renamedNoArgOption) [ ( "experimental-lossy-unification" , headWithDefault __IMPOSSIBLE__ lossyUnificationOption + ) + , ( "overlapping-instances" + , headWithDefault __IMPOSSIBLE__ backtrackingInstancesOption ) ] ] diff --git a/src/full/Agda/Interaction/Options/Warnings.hs b/src/full/Agda/Interaction/Options/Warnings.hs --- a/src/full/Agda/Interaction/Options/Warnings.hs +++ b/src/full/Agda/Interaction/Options/Warnings.hs @@ -28,11 +28,14 @@ import Control.Arrow ( (&&&) ) import Control.DeepSeq import Control.Monad ( guard, when ) +import Control.Monad.Except ( throwError ) -import Data.Set (Set) -import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap import Data.List ( stripPrefix, intercalate, partition, sort ) +import Data.Set ( Set ) +import qualified Data.Set as Set +import Data.Text ( Text ) +import qualified Data.Text as Text import GHC.Generics (Generic) @@ -77,14 +80,23 @@ ws = fst $ fromMaybe __IMPOSSIBLE__ $ lookup defaultWarningSet warningSets -- | Some warnings are errors and cannot be turned off. -data WarningModeError = Unknown String | NoNoError String +data WarningModeError + = Unknown Text + -- ^ Unknown warning. + | NoNoError Text + -- ^ Warning that cannot be disabled. + deriving (Show, Generic) -prettyWarningModeError :: WarningModeError -> String +instance NFData WarningModeError + +prettyWarningModeError :: WarningModeError -> Text prettyWarningModeError = \case - Unknown str -> concat [ "Unknown warning flag: ", str, "." ] - NoNoError str -> concat [ "You may only turn off benign warnings. The warning " - , str - ," is a non-fatal error and thus cannot be ignored." ] + Unknown w -> Text.concat [ "Unknown warning flag: ", w, "." ] + NoNoError w -> Text.concat + [ "You may only turn off benign warnings. The warning " + , w + , " is a non-fatal error and thus cannot be ignored." + ] -- | From user-given directives we compute WarningMode updates type WarningModeUpdate = WarningMode -> WarningMode @@ -101,13 +113,18 @@ -> pure $ set warningSet ws _ -> case stripPrefix "no" str of Nothing -> do - wname :: WarningName <- maybeToEither (Unknown str) $ string2WarningName str + wname <- stringToWarningName str pure (over warningSet $ Set.insert wname) Just str' -> do - wname :: WarningName <- maybeToEither (Unknown str') $ string2WarningName str' - when (wname `elem` errorWarnings) (Left (NoNoError str')) + wname <- stringToWarningName str' + when (wname `elem` errorWarnings) $ + throwError $ NoNoError $ Text.pack str' pure (over warningSet $ Set.delete wname) + where + stringToWarningName :: String -> Either WarningModeError WarningName + stringToWarningName str = maybeToEither (Unknown $ Text.pack str) $ string2WarningName str + -- | Common sets of warnings warningSets :: [(String, (Set WarningName, String))] @@ -137,6 +154,7 @@ , MissingDeclarations_ , NotAllowedInMutual_ , NotStrictlyPositive_ + , ConstructorDoesNotFitInData_ , OverlappingTokensWarning_ , PragmaCompiled_ , SafeFlagPostulate_ @@ -156,6 +174,9 @@ , 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_ @@ -186,6 +207,8 @@ data WarningName -- Option Warnings = OptionRenamed_ + | WarningProblem_ + -- ^ Some warning could not be set or unset. -- Parser Warnings | OverlappingTokensWarning_ | UnsupportedAttribute_ @@ -212,7 +235,7 @@ | InvalidCoverageCheckPragma_ | InvalidNoPositivityCheckPragma_ | InvalidNoUniverseCheckPragma_ - | InvalidRecordDirective_ + | DuplicateRecordDirective_ | InvalidTerminationCheckPragma_ | MissingDeclarations_ | MissingDefinitions_ @@ -228,6 +251,7 @@ | UnknownNamesInPolarityPragmas_ | UselessAbstract_ | UselessInstance_ + | UselessMacro_ | UselessPrivate_ -- Scope and Type Checking Warnings | AbsurdPatternRequiresNoRHS_ @@ -243,7 +267,6 @@ | FixityInRenamingModule_ | InvalidCharacterLiteral_ | UselessPragma_ - | GenericWarning_ | IllformedAsClause_ | InstanceArgWithExplicitArg_ | InstanceWithExplicitArg_ @@ -254,14 +277,38 @@ | NoGuardednessFlag_ | NotInScope_ | NotStrictlyPositive_ + | ConstructorDoesNotFitInData_ + | CoinductiveEtaRecord_ | UnsupportedIndexedMatch_ | OldBuiltin_ + | BuiltinDeclaresIdentifier_ | PlentyInHardCompileTimeMode_ | PragmaCompileErased_ + | PragmaCompileList_ + | PragmaCompileMaybe_ + | NoMain_ + | RewriteLHSNotDefinitionOrConstructor_ + | RewriteVariablesNotBoundByLHS_ + | RewriteVariablesBoundMoreThanOnce_ + | RewriteLHSReduces_ + | RewriteHeadSymbolIsProjection_ + | RewriteHeadSymbolIsProjectionLikeFunction_ + | RewriteHeadSymbolIsTypeConstructor_ + | RewriteHeadSymbolContainsMetas_ + | RewriteConstructorParametersNotGeneral_ + | RewriteContainsUnsolvedMetaVariables_ + | RewriteBlockedOnProblems_ + | RewriteRequiresDefinitions_ + | RewriteDoesNotTargetRewriteRelation_ + | RewriteBeforeFunctionDefinition_ + | RewriteBeforeMutualFunctionDefinition_ + | ConfluenceCheckingIncompleteBecauseOfMeta_ + | ConfluenceForCubicalNotSupported_ | RewriteMaybeNonConfluent_ | RewriteNonConfluent_ | RewriteAmbiguousRules_ | RewriteMissingRule_ + | DuplicateRewriteRule_ | SafeFlagEta_ | SafeFlagInjective_ | SafeFlagNoCoverageCheck_ @@ -284,6 +331,7 @@ | UselessPublic_ | UserWarning_ | WithoutKFlagPrimEraseEquality_ + | ConflictingPragmaOptions_ | WrongInstanceDeclaration_ -- Checking consistency of options | CoInfectiveImport_ @@ -292,6 +340,7 @@ | DuplicateFields_ | TooManyFields_ -- Opaque/unfolding + | MissingTypeSignatureForOpaque_ | NotAffectedByOpaque_ | UnfoldTransparentName_ | UselessOpaque_ @@ -300,6 +349,8 @@ | FaceConstraintCannotBeNamed_ -- Not source code related | DuplicateInterfaceFiles_ + -- Backends + | CustomBackendWarning_ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) instance NFData WarningName @@ -369,6 +420,7 @@ 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." UnsupportedAttribute_ -> "Unsupported attributes." @@ -395,7 +447,7 @@ 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." - InvalidRecordDirective_ -> "Record directives outside of record definitions or below field declarations." + DuplicateRecordDirective_ -> "Conflicting directives in a record declaration." InvalidTerminationCheckPragma_ -> "Termination checking pragmas before non-function or `mutual' blocks." MissingDeclarations_ -> "Definitions not associated to a declaration." MissingDefinitions_ -> "Declarations not associated to a definition." @@ -413,8 +465,9 @@ UselessHiding_ -> "Names in `hiding' directive that are anyway not imported." UselessInline_ -> "`INLINE' pragmas where they have no effect." UselessInstance_ -> "`instance' blocks where they have no effect." + UselessMacro_ -> "`macro' blocks where they have no effect." UselessPrivate_ -> "`private' blocks where they have no effect." - UselessPublic_ -> "`public' blocks where they have no effect." + UselessPublic_ -> "`public' directives that have no effect." UselessPatternDeclarationForRecord_ -> "`pattern' attributes where they have no effect." -- Scope and Type Checking Warnings AbsurdPatternRequiresNoRHS_ -> "Clauses with an absurd pattern that have a right hand side." @@ -428,7 +481,6 @@ DeprecationWarning_ -> "Deprecated features." InvalidCharacterLiteral_ -> "Illegal character literals." UselessPragma_ -> "Pragmas that get ignored." - GenericWarning_ -> "" 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." @@ -440,14 +492,38 @@ 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'." + NoMain_ -> "Compilation of modules that do not define `main'." + 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." + RewriteHeadSymbolIsProjection_ -> "Rewrite rule head symbol is a record projection." + 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." @@ -459,6 +535,7 @@ 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." @@ -475,6 +552,7 @@ 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." UnfoldTransparentName_ -> "Non-`opaque` names mentioned in an `unfolding` clause." UselessOpaque_ -> "`opaque` blocks that have no effect." @@ -483,3 +561,5 @@ FaceConstraintCannotBeNamed_ -> "Face constraint patterns that are given as named arguments." -- Not source code related DuplicateInterfaceFiles_ -> "Duplicate interface files." + -- Backends + CustomBackendWarning_ -> "Custom warnings from backends." diff --git a/src/full/Agda/Interaction/Output.hs b/src/full/Agda/Interaction/Output.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Interaction/Output.hs @@ -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 diff --git a/src/full/Agda/Interaction/Response.hs b/src/full/Agda/Interaction/Response.hs --- a/src/full/Agda/Interaction/Response.hs +++ b/src/full/Agda/Interaction/Response.hs @@ -1,219 +1,25 @@ ------------------------------------------------------------------------- --- | Data type for all interactive responses ------------------------------------------------------------------------- module Agda.Interaction.Response - ( Response (..) - , RemoveTokenBasedHighlighting (..) - , MakeCaseVariant (..) - , DisplayInfo (..) - , GoalDisplayInfo(..) - , Goals - , WarningsAndNonFatalErrors - , Info_Error(..) - , GoalTypeAux(..) - , ResponseContextEntry(..) - , Status (..) - , GiveResult (..) - , InteractionOutputCallback - , defaultInteractionOutputCallback - ) where - -import Agda.Interaction.Base - ( CommandState - , CompilerBackend - , ComputeMode - , OutputConstraint - , OutputConstraint' - , OutputForm - , Rewrite - ) -import Agda.Interaction.Highlighting.Precise -import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common (InteractionId(..), Arg) -import Agda.Syntax.Concrete (Expr) -import Agda.Syntax.Concrete.Name (Name, QName, NameInScope) -import Agda.Syntax.Scope.Base (WhyInScopeData) -import qualified Agda.Syntax.Internal as I -import {-# SOURCE #-} Agda.TypeChecking.Monad.Base - (TCM, TCErr, TCWarning, HighlightingMethod, ModuleToSource, NamedMeta, TCWarning, IPFace') -import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors) -import Agda.Utils.Impossible -import Agda.Utils.Time - -import Control.Monad.Trans ( MonadIO(liftIO) ) -import Data.Int -import System.IO - --- | Responses for any interactive interface --- --- Note that the response is given in pieces and incrementally, --- so the user can have timely response even during long computations. - -data Response - = Resp_HighlightingInfo - HighlightingInfo - RemoveTokenBasedHighlighting - HighlightingMethod - ModuleToSource - | Resp_Status Status - | Resp_JumpToError FilePath Int32 - | Resp_InteractionPoints [InteractionId] - | Resp_GiveAction InteractionId GiveResult - | Resp_MakeCase InteractionId MakeCaseVariant [String] - -- ^ Response is list of printed clauses. - | Resp_SolveAll [(InteractionId, Expr)] - -- ^ Solution for one or more meta-variables. - | Resp_DisplayInfo DisplayInfo - | Resp_RunningInfo Int String - -- ^ The integer is the message's debug level. - | Resp_ClearRunningInfo - | Resp_ClearHighlighting TokenBased - -- ^ Clear highlighting of the given kind. - | Resp_DoneAborting - -- ^ A command sent when an abort command has completed - -- successfully. - | Resp_DoneExiting - -- ^ A command sent when an exit command is about to be - -- completed. - --- | Should token-based highlighting be removed in conjunction with --- the application of new highlighting (in order to reduce the risk of --- flicker)? - -data RemoveTokenBasedHighlighting - = RemoveHighlighting - -- ^ Yes, remove all token-based highlighting from the file. - | KeepHighlighting - -- ^ No. - --- | There are two kinds of \"make case\" commands. - -data MakeCaseVariant = Function | ExtendedLambda - --- | Info to display at the end of an interactive command - -data DisplayInfo - = Info_CompilationOk CompilerBackend WarningsAndNonFatalErrors - | Info_Constraints [OutputForm Expr Expr] - | Info_AllGoalsWarnings Goals WarningsAndNonFatalErrors - | Info_Time CPUTime - | Info_Error Info_Error - -- ^ When an error message is displayed this constructor should be - -- used, if appropriate. - | Info_Intro_NotFound - | Info_Intro_ConstructorUnknown [String] - | Info_Auto String - -- ^ 'Info_Auto' denotes either an error or a success (when 'Resp_GiveAction' is present) - -- TODO: split these into separate constructors - | Info_ModuleContents [Name] I.Telescope [(Name, I.Type)] - | Info_SearchAbout [(Name, I.Type)] String - | Info_WhyInScope 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 - -data GoalDisplayInfo - = Goal_HelperFunction (OutputConstraint' A.Expr A.Expr) - | Goal_NormalForm ComputeMode A.Expr - | Goal_GoalType Rewrite GoalTypeAux [ResponseContextEntry] [IPFace' Expr] [OutputForm Expr Expr] - | Goal_CurrentGoal Rewrite - | Goal_InferredType A.Expr - --- | Goals & Warnings -type Goals = ( [OutputConstraint A.Expr InteractionId] -- visible metas (goals) - , [OutputConstraint A.Expr NamedMeta] -- hidden (unsolved) metas - ) - --- | Errors that goes into Info_Error --- --- When an error message is displayed this constructor should be --- used, if appropriate. -data Info_Error - = Info_GenericError TCErr - | Info_CompilationError [TCWarning] - | Info_HighlightingParseError InteractionId - | Info_HighlightingScopeCheckError InteractionId - --- | Auxiliary information that comes with Goal Type - -data GoalTypeAux - = GoalOnly - | GoalAndHave A.Expr [IPFace' Expr] - | GoalAndElaboration I.Term - --- | Entry in context. - -data ResponseContextEntry = ResponseContextEntry - { respOrigName :: Name -- ^ The original concrete name. - , respReifName :: Name -- ^ The name reified from abstract syntax. - , respType :: Arg A.Expr -- ^ The type. - , respLetValue :: Maybe A.Expr -- ^ The value (if it is a let-bound variable) - , respInScope :: NameInScope -- ^ Whether the 'respReifName' is in scope. - } - - --- | Status information. - -data Status = Status - { sShowImplicitArguments :: Bool - -- ^ Are implicit arguments displayed? - , sShowIrrelevantArguments :: Bool - -- ^ Are irrelevant arguments displayed? - , sChecked :: Bool - -- ^ Has the module been successfully type checked? - } - --- | Give action result --- --- Comment derived from agda2-mode.el --- --- If 'GiveResult' is 'Give_String s', then the goal is replaced by 's', --- and otherwise the text inside the goal is retained (parenthesised --- if 'GiveResult' is 'Give_Paren'). - -data GiveResult - = Give_String String - | Give_Paren - | Give_NoParen + ( module Agda.Interaction.Response + , module Agda.Interaction.Response.Base + , WarningsAndNonFatalErrors + , InteractionOutputCallback + , defaultInteractionOutputCallback + ) + where --- | Callback fuction to call when there is a response --- to give to the interactive frontend. --- --- Note that the response is given in pieces and incrementally, --- so the user can have timely response even during long computations. --- --- Typical 'InteractionOutputCallback' functions: --- --- * Convert the response into a 'String' representation and --- print it on standard output --- (suitable for inter-process communication). --- --- * Put the response into a mutable variable stored in the --- closure of the 'InteractionOutputCallback' function. --- (suitable for intra-process communication). +import Agda.Interaction.Response.Base -type InteractionOutputCallback = Response -> TCM () +import Agda.TypeChecking.Monad.Base + (TCM, TCErr, TCWarning, InteractionOutputCallback, defaultInteractionOutputCallback) +import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors) --- | The default 'InteractionOutputCallback' function prints certain --- things to stdout (other things generate internal errors). +-------------------------- +-- * TCM-aware aliases +-------------------------- -defaultInteractionOutputCallback :: InteractionOutputCallback -defaultInteractionOutputCallback = \case - Resp_HighlightingInfo {} -> __IMPOSSIBLE__ - Resp_Status {} -> __IMPOSSIBLE__ - Resp_JumpToError {} -> __IMPOSSIBLE__ - Resp_InteractionPoints {} -> __IMPOSSIBLE__ - Resp_GiveAction {} -> __IMPOSSIBLE__ - Resp_MakeCase {} -> __IMPOSSIBLE__ - Resp_SolveAll {} -> __IMPOSSIBLE__ - Resp_DisplayInfo {} -> __IMPOSSIBLE__ - Resp_RunningInfo _ s -> liftIO $ do - putStr s - hFlush stdout - Resp_ClearRunningInfo {} -> __IMPOSSIBLE__ - Resp_ClearHighlighting {} -> __IMPOSSIBLE__ - Resp_DoneAborting {} -> __IMPOSSIBLE__ - Resp_DoneExiting {} -> __IMPOSSIBLE__ +type Response = Response_boot TCErr TCWarning WarningsAndNonFatalErrors +type DisplayInfo = DisplayInfo_boot TCErr TCWarning WarningsAndNonFatalErrors +type Info_Error = Info_Error_boot TCErr TCWarning +type GoalDisplayInfo = GoalDisplayInfo_boot TCErr +type Goals = Goals_boot TCErr diff --git a/src/full/Agda/Interaction/Response.hs-boot b/src/full/Agda/Interaction/Response.hs-boot deleted file mode 100644 --- a/src/full/Agda/Interaction/Response.hs-boot +++ /dev/null @@ -1,40 +0,0 @@ -module Agda.Interaction.Response where - -import Data.Int (Int32) - -import Agda.Syntax.Common (InteractionId) -import Agda.Syntax.Concrete (Expr) - -import {-# SOURCE #-} Agda.TypeChecking.Monad.Base - (TCM, ModuleToSource, HighlightingMethod) - -import Agda.Interaction.Highlighting.Precise - (TokenBased, HighlightingInfo) - -data Response - = Resp_HighlightingInfo - HighlightingInfo - RemoveTokenBasedHighlighting - HighlightingMethod - ModuleToSource - | Resp_Status Status - | Resp_JumpToError FilePath Int32 - | Resp_InteractionPoints [InteractionId] - | Resp_GiveAction InteractionId GiveResult - | Resp_MakeCase InteractionId MakeCaseVariant [String] - | Resp_SolveAll [(InteractionId, Expr)] - | Resp_DisplayInfo DisplayInfo - | Resp_RunningInfo Int String - | Resp_ClearRunningInfo - | Resp_ClearHighlighting TokenBased - | Resp_DoneAborting - | Resp_DoneExiting - -data MakeCaseVariant -data DisplayInfo -data RemoveTokenBasedHighlighting -data GiveResult -data Status - -type InteractionOutputCallback = Response -> TCM () -defaultInteractionOutputCallback :: InteractionOutputCallback diff --git a/src/full/Agda/Interaction/Response/Base.hs b/src/full/Agda/Interaction/Response/Base.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Interaction/Response/Base.hs @@ -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 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 {-# SOURCE #-} Agda.TypeChecking.Monad.Base + (HighlightingMethod, ModuleToSource, NamedMeta, IPFace') +import Agda.Utils.Impossible +import Agda.Utils.Time + +import Control.Monad.Trans ( MonadIO(liftIO) ) +import Data.Int +import System.IO + +-- | Responses for any interactive interface +-- +-- Note that the response is given in pieces and incrementally, +-- so the user can have timely response even during long computations. + +data Response_boot tcErr tcWarning warningsAndNonFatalErrors + = Resp_HighlightingInfo + HighlightingInfo + RemoveTokenBasedHighlighting + HighlightingMethod + ModuleToSource + | Resp_Status Status + | Resp_JumpToError FilePath Int32 + | Resp_InteractionPoints [InteractionId] + | Resp_GiveAction InteractionId GiveResult + | Resp_MakeCase InteractionId MakeCaseVariant [String] + -- ^ Response is list of printed clauses. + | Resp_SolveAll [(InteractionId, Expr)] + -- ^ Solution for one or more meta-variables. + | Resp_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 [tcWarning] + | Info_HighlightingParseError InteractionId + | Info_HighlightingScopeCheckError InteractionId + +-- | Auxiliary information that comes with Goal Type + +data GoalTypeAux + = GoalOnly + | GoalAndHave A.Expr [IPFace' Expr] + | GoalAndElaboration I.Term + +-- | Entry in context. + +data ResponseContextEntry = ResponseContextEntry + { respOrigName :: Name -- ^ The original concrete name. + , respReifName :: Name -- ^ The name reified from abstract syntax. + , respType :: Arg A.Expr -- ^ The type. + , respLetValue :: Maybe A.Expr -- ^ The value (if it is a let-bound variable) + , respInScope :: NameInScope -- ^ Whether the 'respReifName' is in scope. + } + + +-- | Status information. + +data Status = Status + { sShowImplicitArguments :: Bool + -- ^ Are implicit arguments displayed? + , sShowIrrelevantArguments :: Bool + -- ^ Are irrelevant arguments displayed? + , sChecked :: Bool + -- ^ Has the module been successfully type checked? + } + +-- | Give action result +-- +-- Comment derived from agda2-mode.el +-- +-- If 'GiveResult' is 'Give_String s', then the goal is replaced by 's', +-- and otherwise the text inside the goal is retained (parenthesised +-- if 'GiveResult' is 'Give_Paren'). + +data GiveResult + = Give_String String + | Give_Paren + | Give_NoParen diff --git a/src/full/Agda/Main.hs b/src/full/Agda/Main.hs --- a/src/full/Agda/Main.hs +++ b/src/full/Agda/Main.hs @@ -330,12 +330,12 @@ `catchError` \err -> do s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err s1 <- prettyError err - ANSI.putDoc (P.vcat s2s P.$+$ s1) + ANSI.putDoc $ P.vsep $ s2s ++ [ s1 ] liftIO $ do helpForLocaleError err return (Just TCMError) ) `catchImpossible` \e -> do - liftIO $ putStr $ E.displayException e + printException e return (Just ImpossibleError) ) `E.catches` -- Catch all exceptions except for those of type ExitCode @@ -345,7 +345,7 @@ [ E.Handler $ \(e :: ExitCode) -> E.throw e , E.Handler $ \(e :: E.AsyncException) -> E.throw e , E.Handler $ \(e :: E.SomeException) -> do - liftIO $ putStr $ E.displayException e + printException e return $ Right (Just UnknownError) ] case r of @@ -357,6 +357,15 @@ putStrLn $ tcErrString err helpForLocaleError err exitAgdaWith UnknownError + where + printException e = liftIO $ putStr $ + -- Andreas, 2024-07-03, issue #7299 + -- Regression in base-4.20: printing of exception produces trailing whitespace. + -- https://gitlab.haskell.org/ghc/ghc/-/issues/25052 +#if MIN_VERSION_base(4,20,0) + rtrim $ +#endif + E.displayException e -- | If the error is an IO error, and the error message suggests that -- the problem is related to locales or code pages, print out some diff --git a/src/full/Agda/Mimer/Mimer.hs b/src/full/Agda/Mimer/Mimer.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Mimer/Mimer.hs @@ -0,0 +1,1705 @@ +module Agda.Mimer.Mimer + ( MimerResult(..) + , mimer + ) + where + +import Control.DeepSeq (force, NFData(..)) +import Control.Monad +import Control.Monad.Except (catchError) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Fail (MonadFail) +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) +import qualified Agda.Syntax.Scope.Base as Scope +import Agda.Syntax.Translation.InternalToAbstract (reify, NamedClause(..)) +import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcrete_) +import Agda.TypeChecking.Constraints (noConstraints) +import Agda.TypeChecking.Conversion (equalType) +import qualified Agda.TypeChecking.Empty as 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 (lambdaAddContext) +import Agda.TypeChecking.Substitute.Class (apply, applyE, NoSubst(..)) +import Agda.TypeChecking.Telescope (piApplyM, flattenTel, teleArgs) +import Agda.Utils.Benchmark (billTo) +import Agda.Utils.FileName (filePath) +import Agda.Utils.Impossible (__IMPOSSIBLE__) +import Agda.Utils.Maybe (catMaybes) +import Agda.Utils.Monad (ifM) +import qualified Agda.Utils.Maybe.Strict as SMaybe +-- import Agda.Utils.Permutation (idP, permute, takeP) +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 + +mimer :: MonadTCM tcm + => Rewrite + -> InteractionId + -> Range + -> String + -> tcm MimerResult +mimer norm ii rng argStr = liftTCM $ do + reportSDoc "mimer.top" 10 ("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) + + oldState <- getTC + + sols <- runSearch norm opts ii rng + putTC oldState + + 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 + + putTC oldState + + 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 + } + +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 + + +-- TODO: Change the signature in original module instead. +isEmptyType :: Type -> SM Bool +isEmptyType = liftTCM . Empty.isEmptyType + +-- TODO: Currently not using this function. Is it useful anywhere? +getDomainType :: Type -> Type +getDomainType typ = case unEl typ of + Pi dom _ -> unDom dom + _ -> __IMPOSSIBLE__ + +allOpenMetas :: (AllMetas t, ReadTCState tcm) => t -> tcm [MetaId] +allOpenMetas t = do + openMetas <- getOpenMetas + return $ allMetas (:[]) t `intersect` openMetas + +getOpenComponent :: MonadTCM tcm => Open Component -> tcm Component +getOpenComponent openComp = do + let comp = openThing openComp + term <- getOpen $ compTerm <$> openComp + typ <- getOpen $ compType <$> openComp + 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 = withMetaId (goalMeta goal) + +nextBranchMeta' :: SearchBranch -> SM (Goal, SearchBranch) +nextBranchMeta' = fmap (fromMaybe __IMPOSSIBLE__) . nextBranchMeta + +nextBranchMeta :: SearchBranch -> SM (Maybe (Goal, SearchBranch)) +nextBranchMeta branch = case sbGoals branch of + [] -> return Nothing + (goal : goals) -> + return $ Just (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 >=> go + where + -- TODO: Cleaner way of juggling the maybes here? + go Nothing = return Nothing + go (Just term) = do + expr <- instantiateFull term >>= reify + return $ Just expr + +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 + +isTypeDatatype :: (MonadTCM tcm, MonadReduce tcm, HasConstInfo tcm) => Type -> tcm Bool +isTypeDatatype typ = do + typ' <- reduce typ + case unEl typ' of + Def qname _ -> theDef <$> getConstInfo qname >>= \case + Datatype{} -> return True + _ -> return False + _ -> return 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 ] + 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, typ) -> + ((argInfoHiding (domInfo typ) == NotHidden) &&) <$> isTypeDatatype (unDom typ)) + typedLhsVars + reportSDoc "mimer.components" 40 $ + "Splittable variables" <+> prettyList (map prettyTCMTypedTerm splitVarsTyped) <+> parens ("or" + <+> prettyList (map prettyTypedTerm splitVarsTyped)) + + splitVars <- makeOpen $ map fst splitVarsTyped + + letVars <- getLetVars (costLet costs) + + + let components = BaseComponents + { hintFns = [] + , hintDataTypes = [] + , hintRecordTypes = [] + , hintProjections = [] + , hintAxioms = [] + , hintLevel = [] + , hintThisFn = Nothing + , hintRecVars = recVars + , hintLetVars = letVars + , hintSplitVars = splitVars + } + metaVar <- lookupLocalMeta metaId + hintNames <- getEverythingInScope metaVar + components' <- foldM go 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 comps qname = do + info <- getConstInfo qname + typ <- typeOfConst qname + scope <- getScope + let 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} + case theDef info of + Axiom{} | isToLevel typ -> addLevel + | shouldKeep scope -> addAxiom + | otherwise -> return comps + -- TODO: Check if we want to use these + DataOrRecSig{} -> return comps + GeneralizableVar -> return comps + AbstractDefn{} -> return comps + -- If the function is in the same mutual block, do not include it. + f@Function{} + | Just qname == mDefName -> addThisFn + | isToLevel typ && isNotMutual qname f -> addLevel + | isNotMutual qname f && shouldKeep scope -> addFn + | otherwise -> return comps + 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{} -> return comps + -- TODO: special treatment for primitives? + Primitive{} | isToLevel typ -> addLevel + | shouldKeep scope -> addFn + | otherwise -> return comps + PrimitiveSort{} -> return comps + where + shouldKeep scope = or + [ qname `elem` explicitHints + , qname `elem` whereNames + , case hintMode of + Unqualified -> Scope.isNameInScopeUnqualified qname scope + AllModules -> True + Module -> Just (qnameModule qname) == mThisModule + NoHints -> False + ] + + -- TODO: There is probably a better way of finding the module name + mThisModule = qnameModule <$> mDefName + + -- NOTE: We do not reduce the type before checking, so some user definitions + -- will not be included here. + isToLevel :: Type -> Bool + isToLevel typ = case unEl typ of + Pi _ abs -> isToLevel (unAbs abs) + Def qname _ -> P.prettyShow qname == builtinLevelName + _ -> False + + prettyTCMTypedTerm :: (PrettyTCM tm, PrettyTCM ty) => (tm, ty) -> TCM Doc + prettyTCMTypedTerm (term, typ) = prettyTCM term <+> ":" <+> prettyTCM typ + prettyTypedTerm (term, typ) = pretty term <+> ":" <+> pretty typ + +qnameToComponent :: (HasConstInfo tcm, ReadTCState tcm, MonadFresh CompId tcm, MonadTCM tcm) + => Cost -> QName -> tcm Component +qnameToComponent cost qname = do + info <- getConstInfo qname + typ <- typeOfConst qname + -- #7120: typeOfConst is the type inside the module, so we need to apply the module params here + mParams <- freeVarsToApply qname + let def = (Def qname [] `apply` mParams, 0) + (term, pars) = case theDef info 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 typ + +getEverythingInScope :: MonadTCM tcm => MetaVariable -> tcm [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 + return qnames + +getLetVars :: (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 _ term typ) -> + mkComponent cId [] cost (Just name) 0 term (unDom typ) + +builtinLevelName :: String +builtinLevelName = "Agda.Primitive.Level" + +-- IDEA: +-- [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. + +-- | 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 :: (MonadFail tcm, 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 + info <- getConstInfo fnName + typ <- typeOfConst 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 + -- TODO: Difference between teleArgs and telToArgs? + 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 + return 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 + 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 + } + + 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 + 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 + 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) + let newTerm = applyE (compTerm comp') [Proj ProjSystem 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 + ctx <- getContextTelescope + compTyp <- reduce $ compType comp + case unEl compTyp of + Pi dom abs -> do + let domainType = unDom dom + (metaId, metaTerm) <- createMeta domainType + let arg = setOrigin Inserted $ metaTerm <$ argFromDom dom + newType <- reduce =<< piApplyM (compType comp) metaTerm + -- Constructors the 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 + (goal1, branch1) <- nextBranchMeta' 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 + -- Abstracted with absurd pattern: solution found. + Left expr -> do + reportSDoc "mimer.refine" 30 $ "Abstracted with absurd lambda. Result:" <+> prettyTCM expr + return [ResultExpr expr] + -- 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 Expr (Goal, Type, SearchBranch)) +tryLamAbs goal goalType branch = + case unEl goalType of + Pi dom abs -> do + e <- isEmptyType (unDom dom) + isEmptyType (unDom dom) >>= \case -- TODO: Is this the correct way of checking if absurd lambda is applicable? + True -> do + let argInf = defaultArgInfo{argInfoOrigin = Inserted} -- domInfo dom + term = Lam argInf absurdBody + newMetaIds <- assignMeta (goalMeta goal) term goalType + unless (null newMetaIds) (__IMPOSSIBLE__) + -- TODO: Represent absurd lambda as a Term instead of Expr. + -- Left . fromMaybe __IMPOSSIBLE__ <$> getMetaInstantiation (goalMeta metaId) + return $ Left $ AbsurdLam exprNoRange NotHidden + False -> do + let bindName | isNoName (absName abs) = "z" + | otherwise = absName abs + newName <- freshName_ bindName + (metaId', bodyType, metaTerm, env) <- lambdaAddContext newName bindName dom $ do + goalType' <- getMetaTypeInContext (goalMeta goal) + bodyType <- bench [Bench.Reduce] $ reduce =<< piApplyM goalType' (Var 0 []) -- TODO: Good place to reduce? + (metaId', metaTerm) <- bench [Bench.Free] $ newValueMeta DontRunMetaOccursCheck CmpLeq bodyType + env <- askTC + return (metaId', bodyType, metaTerm, env) + + let argInf = domInfo dom -- TODO: is this the correct arg info? + newAbs = Abs{absName = bindName, unAbs = metaTerm } --MetaV metaId' [] } + -- 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' + _ -> do + branch' <- updateBranch [] branch -- TODO: Is this necessary? + return $ Right (goal, goalType, branch') + + +genRecCalls :: Component -> SM [Component] +genRecCalls thisFn = do + -- 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 + d@Axiom{} + | P.prettyShow qname == "Agda.Primitive.Level" -> do + tryLevel + | otherwise -> do + return [] + d@DataOrRecSig{} -> do + return [] + d@GeneralizableVar -> do + return [] + d@AbstractDefn{} -> do + return [] + d@Function{} -> do + return [] + d@Constructor{} -> do + return [] + d@PrimitiveSort{} -> do + return [] + sort@(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 + cost <- asks (costDataCon . searchCosts) + comps <- mapM (qnameToComponent cost) $ dataCons dataDefn + 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 + topMetaId <- asks searchTopMeta + topMeta <- lookupLocalMeta topMetaId + ii <- asks searchInteractionId + withInteractionId ii $ withBranchState branch $ do + metaArgs <- getMetaContextArgs topMeta + inst <- normaliseSolution $ apply (MetaV topMetaId []) metaArgs + case allMetas (:[]) inst of + [] -> ResultExpr <$> reify inst + metaIds -> do + return $ OpenBranch $ branch{sbGoals = map Goal $ reverse metaIds} + +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) . reverse . zip [0..] =<< getContext + 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 :: (MonadFail m, 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 diff --git a/src/full/Agda/Mimer/Options.hs b/src/full/Agda/Mimer/Options.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Mimer/Options.hs @@ -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 diff --git a/src/full/Agda/Syntax/Abstract.hs b/src/full/Agda/Syntax/Abstract.hs --- a/src/full/Agda/Syntax/Abstract.hs +++ b/src/full/Agda/Syntax/Abstract.hs @@ -24,7 +24,7 @@ import GHC.Generics (Generic) -import Agda.Syntax.Concrete (FieldAssignment'(..)) +import Agda.Syntax.Concrete (FieldAssignment'(..), TacticAttribute'(..)) import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Abstract.Name import qualified Agda.Syntax.Internal as I @@ -180,7 +180,7 @@ -- ^ The 'Type' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Dummy@, -- and the optional name is the constructor's name. -- The optional 'Range' is for the @pattern@ attribute. - | PatternSynDef QName [Arg BindName] (Pattern' Void) + | PatternSynDef QName [WithHiding BindName] (Pattern' Void) -- ^ Only for highlighting purposes | UnquoteDecl MutualInfo [DefInfo] [QName] Expr | UnquoteDef [DefInfo] [QName] Expr @@ -219,9 +219,12 @@ -- ^ 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 + -- ^ 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) @@ -247,7 +250,7 @@ type Constructor = TypeSignature type Field = TypeSignature -type TacticAttr = Maybe (Ranged Expr) +type TacticAttribute = TacticAttribute' Expr -- A Binder @x\@p@, the pattern is optional data Binder' a = Binder @@ -268,21 +271,21 @@ -- | A lambda binding is either domain free or typed. data LamBinding - = DomainFree TacticAttr (NamedArg Binder) + = DomainFree TacticAttribute (NamedArg Binder) -- ^ . @x@ or @{x}@ or @.x@ or @{x = y}@ or @x\@p@ or @(p)@ | DomainFull TypedBinding -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@ deriving (Show, Eq, Generic) mkDomainFree :: NamedArg Binder -> LamBinding -mkDomainFree = DomainFree Nothing +mkDomainFree = DomainFree empty -- | Extra information that is attached to a typed binding, that plays a -- role during type checking but strictly speaking is not part of the -- @name : type@" relation which a makes up a binding. data TypedBindingInfo = TypedBindingInfo - { tbTacticAttr :: TacticAttr + { tbTacticAttr :: TacticAttribute -- ^ Does this binding have a tactic annotation? , tbFinite :: Bool -- ^ Does this binding correspond to a Partial binder, rather than @@ -291,11 +294,9 @@ } deriving (Show, Eq, Generic) -defaultTbInfo :: TypedBindingInfo -defaultTbInfo = TypedBindingInfo - { tbTacticAttr = Nothing - , tbFinite = False - } +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 @@ -319,7 +320,7 @@ deriving (Show, Eq, Generic) mkTBind :: Range -> List1 (NamedArg Binder) -> Type -> TypedBinding -mkTBind r = TBind r defaultTbInfo +mkTBind r = TBind r empty mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding mkTLet _ [] = Nothing @@ -516,7 +517,7 @@ | AbsurdP PatInfo | LitP PatInfo Literal | PatternSynP PatInfo AmbiguousQName (NAPs e) - | RecP PatInfo [FieldAssignment' (Pattern' e)] + | RecP ConPatInfo [FieldAssignment' (Pattern' e)] | EqualP PatInfo [(e, e)] | WithP PatInfo (Pattern' e) -- ^ @| p@, for with-patterns. | AnnP PatInfo e (Pattern' e) -- ^ Pattern with type annotation @@ -613,7 +614,9 @@ instance Underscore Expr where underscore = Underscore emptyMetaInfo - isUnderscore = __IMPOSSIBLE__ + isUnderscore = \case + Underscore _ -> True + _ -> False instance LensHiding LamBinding where getHiding (DomainFree _ x) = getHiding x @@ -747,7 +750,7 @@ setRange r (AbsurdP _) = AbsurdP (PatRange r) setRange r (LitP _ l) = LitP (PatRange r) l setRange r (PatternSynP _ n as) = PatternSynP (PatRange r) n as - setRange r (RecP i as) = RecP (PatRange r) as + setRange r (RecP i as) = RecP (setRange r i) as setRange r (EqualP _ es) = EqualP (PatRange r) es setRange r (WithP i p) = WithP (setRange r i) p setRange r (AnnP i a p) = AnnP (setRange r i) a p @@ -994,33 +997,15 @@ mkLet _ [] e = e mkLet i (d:ds) e = Let i (d :| ds) e -patternToExpr :: Pattern -> Expr -patternToExpr = \case - VarP x -> Var (unBind x) - ConP _ c ps -> Con c `app` map (fmap (fmap patternToExpr)) ps - ProjP _ o ds -> Proj o ds - DefP _ fs ps -> Def (headAmbQ fs) `app` map (fmap (fmap patternToExpr)) ps - WildP _ -> Underscore emptyMetaInfo - AsP _ _ p -> patternToExpr p - DotP _ e -> e - AbsurdP _ -> Underscore emptyMetaInfo -- TODO: could this happen? - LitP (PatRange r) l-> Lit (ExprRange r) l - PatternSynP _ c ps -> PatternSyn c `app` (map . fmap . fmap) patternToExpr ps - RecP _ as -> Rec exprNoRange $ map (Left . fmap patternToExpr) as - EqualP{} -> __IMPOSSIBLE__ -- Andrea TODO: where is this used? - WithP r p -> __IMPOSSIBLE__ - AnnP _ _ p -> patternToExpr p - -type PatternSynDefn = ([Arg Name], Pattern' Void) +type PatternSynDefn = ([WithHiding Name], Pattern' Void) type PatternSynDefns = Map QName PatternSynDefn -lambdaLiftExpr :: [Name] -> Expr -> Expr -lambdaLiftExpr ns e - = foldr - (\ n -> Lam exprNoRange (mkDomainFree $ defaultNamedArg $ mkBinder_ n)) - e - ns +lambdaLiftExpr :: [WithHiding Name] -> Expr -> Expr +lambdaLiftExpr ns e = foldr f e ns + where + f (WithHiding h n) = Lam exprNoRange $ setHiding h $ mkDomainFree $ defaultNamedArg $ mkBinder_ n + -- NOTE: This is only used on expressions that come from right-hand sides of pattern synonyms, and -- thus does not have to handle all forms of expressions. class SubstExpr a where @@ -1082,31 +1067,45 @@ Macro{} -> __IMPOSSIBLE__ -- TODO: more informative failure -insertImplicitPatSynArgs - :: HasRange a - => (Range -> a) +insertImplicitPatSynArgs :: forall a. HasRange a + => (Hiding -> Range -> a) + -- ^ Thing to insert (wildcard). -> Range - -> [Arg Name] + -- ^ Range of the whole pattern synonym expression/pattern. + -> [WithHiding Name] + -- ^ The parameters of the pattern synonym (from its definition). -> [NamedArg a] - -> Maybe ([(Name, a)], [Arg Name]) + -- ^ The arguments it is used with. + -> Maybe ([(Name, a)], [WithHiding Name]) + -- ^ Substitution and left-over parameters. insertImplicitPatSynArgs wild r ns as = matchArgs r ns as where + matchNextArg :: Range -> WithHiding Name -> [NamedArg a] -> Maybe (a, [NamedArg a]) matchNextArg r n as@(~(a : as')) - | matchNext n as = return (namedArg a, as') + | not (null as) + , matchNext n a = return (namedArg a, as') | visible n = Nothing - | otherwise = return (wild r, as) + | otherwise = return (wild (getHiding n) r, as) - matchNext _ [] = False - matchNext n (a:as) = sameHiding n a && maybe True (x ==) (bareNameOf a) + matchNext :: + WithHiding Name -- Pattern synonym parameter + -> NamedArg a -- Argument given to pattern synonym + -> Bool + matchNext n a = sameHiding n a && maybe True (x ==) (bareNameOf a) where - x = C.nameToRawName $ nameConcrete $ unArg n + x = C.nameToRawName $ nameConcrete $ whThing n + matchArgs :: + Range + -> [WithHiding Name] + -> [NamedArg a] + -> Maybe ([(Name, a)], [WithHiding Name]) matchArgs r [] [] = return ([], []) matchArgs r [] as = Nothing matchArgs r (n:ns) [] | visible n = return ([], n : ns) -- under-applied matchArgs r (n:ns) as = do (p, as) <- matchNextArg r n as - first ((unArg n, p) :) <$> matchArgs (getRange p) ns as + first ((whThing n, p) :) <$> matchArgs (getRange p) ns as ------------------------------------------------------------------------ -- Declaration spines diff --git a/src/full/Agda/Syntax/Abstract/Pattern.hs b/src/full/Agda/Syntax/Abstract/Pattern.hs --- a/src/full/Agda/Syntax/Abstract/Pattern.hs +++ b/src/full/Agda/Syntax/Abstract/Pattern.hs @@ -10,6 +10,7 @@ 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 ) @@ -290,6 +291,54 @@ 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 _ as -> Rec exprNoRange . map Left <$> patToExpr as + EqualP{} -> __IMPOSSIBLE__ -- Andrea TODO: where is this used? + WithP r p -> __IMPOSSIBLE__ + AnnP _ _ p -> patToExpr p -- * Other pattern utilities diff --git a/src/full/Agda/Syntax/Abstract/PatternSynonyms.hs b/src/full/Agda/Syntax/Abstract/PatternSynonyms.hs --- a/src/full/Agda/Syntax/Abstract/PatternSynonyms.hs +++ b/src/full/Agda/Syntax/Abstract/PatternSynonyms.hs @@ -33,8 +33,8 @@ mergeDef :: PatternSynDefn -> PatternSynDefn -> Maybe PatternSynDefn mergeDef (xs, p) (ys, q) = do - guard $ map getArgInfo xs == map getArgInfo ys - let ren = zip (map unArg xs) (map unArg ys) + guard $ map whHiding xs == map whHiding ys + let ren = zip (map whThing xs) (map whThing ys) (xs,) <$> merge ren p q where merge ren p@(VarP x) (VarP y) = p <$ guard ((unBind x, unBind y) `elem` ren) @@ -48,7 +48,7 @@ mergeArg ren p q = setNamedArg p <$> merge ren (namedArg p) (namedArg q) -- | Match an expression against a pattern synonym. -matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [Arg Expr] +matchPatternSyn :: PatternSynDefn -> Expr -> Maybe [WithHiding Expr] matchPatternSyn = runMatch match where match (VarP x) e = unBind x ==> e @@ -61,7 +61,7 @@ match _ _ = empty -- | Match a pattern against a pattern synonym. -matchPatternSynP :: PatternSynDefn -> Pattern' e -> Maybe [Arg (Pattern' e)] +matchPatternSynP :: PatternSynDefn -> Pattern' e -> Maybe [WithHiding (Pattern' e)] matchPatternSynP = runMatch match where match (VarP x) q = unBind x ==> q @@ -78,7 +78,7 @@ (==>) :: Name -> e -> Match e () x ==> e = tell (Map.singleton x e) -runMatch :: (Pattern' Void -> e -> Match e ()) -> PatternSynDefn -> e -> Maybe [Arg e] +runMatch :: (Pattern' Void -> e -> Match e ()) -> PatternSynDefn -> e -> Maybe [WithHiding e] runMatch match (xs, pat) e = do sub <- execWriterT (match pat e) - forM xs $ \ x -> (<$ x) <$> Map.lookup (unArg x) sub + forM xs $ \ x -> (<$ x) <$> Map.lookup (whThing x) sub diff --git a/src/full/Agda/Syntax/Abstract/UsedNames.hs b/src/full/Agda/Syntax/Abstract/UsedNames.hs --- a/src/full/Agda/Syntax/Abstract/UsedNames.hs +++ b/src/full/Agda/Syntax/Abstract/UsedNames.hs @@ -133,6 +133,7 @@ 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 diff --git a/src/full/Agda/Syntax/Abstract/Views.hs b/src/full/Agda/Syntax/Abstract/Views.hs --- a/src/full/Agda/Syntax/Abstract/Views.hs +++ b/src/full/Agda/Syntax/Abstract/Views.hs @@ -13,7 +13,7 @@ import Agda.Syntax.Common import Agda.Syntax.Abstract as A -import Agda.Syntax.Concrete (FieldAssignment', exprFieldA) +import Agda.Syntax.Concrete (FieldAssignment', exprFieldA, TacticAttribute') import Agda.Syntax.Info import Agda.Syntax.Scope.Base (KindOfName(..), conKindOfName, WithKind(..)) @@ -41,7 +41,7 @@ where (f, es) = appView'' e - appView'' e = case e of + appView'' = \case App i e1 e2 | Dot _ e2' <- unScope $ namedArg e2 , Just f <- maybeProjTurnPostfix e2' @@ -50,7 +50,7 @@ App i e1 arg | (f, es) <- appView'' e1 -> (f, es `DL.snoc` (fmap . fmap) (i,) arg) ScopedExpr _ e -> appView'' e - _ -> (Application e, mempty) + e -> (Application e, mempty) maybeProjTurnPostfix :: Expr -> Maybe Expr maybeProjTurnPostfix e = @@ -257,6 +257,7 @@ 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 @@ -385,6 +386,7 @@ 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 @@ -410,9 +412,11 @@ CompilePragma{} -> pure p StaticPragma{} -> pure p InjectivePragma{} -> pure p + InjectiveForInferencePragma{} -> pure p InlinePragma{} -> pure p EtaPragma{} -> pure p NotProjectionLikePragma{} -> pure p + OverlapPragma{} -> pure p DisplayPragma f xs e -> DisplayPragma f <$> rec xs <*> rec e where rec :: RecurseExprRecFn m @@ -513,7 +517,7 @@ 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 + 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 @@ -536,10 +540,12 @@ 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 diff --git a/src/full/Agda/Syntax/Builtin.hs b/src/full/Agda/Syntax/Builtin.hs --- a/src/full/Agda/Syntax/Builtin.hs +++ b/src/full/Agda/Syntax/Builtin.hs @@ -237,9 +237,11 @@ | BuiltinAgdaTCMFormatErrorParts | BuiltinAgdaTCMDebugPrint | BuiltinAgdaTCMNoConstraints + | BuiltinAgdaTCMWorkOnTypes | BuiltinAgdaTCMRunSpeculative | BuiltinAgdaTCMExec | BuiltinAgdaTCMGetInstances + | BuiltinAgdaTCMSolveInstances | BuiltinAgdaTCMPragmaForeign | BuiltinAgdaTCMPragmaCompile | BuiltinAgdaBlocker @@ -456,9 +458,11 @@ BuiltinAgdaTCMFormatErrorParts -> "AGDATCMFORMATERRORPARTS" BuiltinAgdaTCMDebugPrint -> "AGDATCMDEBUGPRINT" BuiltinAgdaTCMNoConstraints -> "AGDATCMNOCONSTRAINTS" + BuiltinAgdaTCMWorkOnTypes -> "AGDATCMWORKONTYPES" BuiltinAgdaTCMRunSpeculative -> "AGDATCMRUNSPECULATIVE" BuiltinAgdaTCMExec -> "AGDATCMEXEC" BuiltinAgdaTCMGetInstances -> "AGDATCMGETINSTANCES" + BuiltinAgdaTCMSolveInstances -> "AGDATCMSOLVEINSTANCES" BuiltinAgdaTCMPragmaForeign -> "AGDATCMPRAGMAFOREIGN" BuiltinAgdaTCMPragmaCompile -> "AGDATCMPRAGMACOMPILE" BuiltinAgdaBlocker -> "AGDABLOCKER" @@ -580,9 +584,11 @@ builtinAgdaTCMAskNormalisation, builtinAgdaTCMAskReconstructed, builtinAgdaTCMAskExpandLast, builtinAgdaTCMAskReduceDefs, builtinAgdaTCMNoConstraints, + builtinAgdaTCMWorkOnTypes, builtinAgdaTCMRunSpeculative, builtinAgdaTCMExec, builtinAgdaTCMGetInstances, + builtinAgdaTCMSolveInstances, builtinAgdaTCMPragmaForeign, builtinAgdaTCMPragmaCompile :: BuiltinId @@ -779,9 +785,11 @@ builtinAgdaTCMFormatErrorParts = BuiltinAgdaTCMFormatErrorParts builtinAgdaTCMDebugPrint = BuiltinAgdaTCMDebugPrint builtinAgdaTCMNoConstraints = BuiltinAgdaTCMNoConstraints +builtinAgdaTCMWorkOnTypes = BuiltinAgdaTCMWorkOnTypes builtinAgdaTCMRunSpeculative = BuiltinAgdaTCMRunSpeculative builtinAgdaTCMExec = BuiltinAgdaTCMExec builtinAgdaTCMGetInstances = BuiltinAgdaTCMGetInstances +builtinAgdaTCMSolveInstances = BuiltinAgdaTCMSolveInstances builtinAgdaTCMPragmaForeign = BuiltinAgdaTCMPragmaForeign builtinAgdaTCMPragmaCompile = BuiltinAgdaTCMPragmaCompile builtinAgdaBlocker = BuiltinAgdaBlocker diff --git a/src/full/Agda/Syntax/Common.hs b/src/full/Agda/Syntax/Common.hs --- a/src/full/Agda/Syntax/Common.hs +++ b/src/full/Agda/Syntax/Common.hs @@ -2,6 +2,7 @@ -} module Agda.Syntax.Common ( module Agda.Syntax.Common + , module Agda.Syntax.Common.KeywordRange , module Agda.Syntax.TopLevelModuleName.Boot , Induction(..) ) @@ -30,9 +31,13 @@ import GHC.Generics (Generic) +import Agda.Syntax.Common.Aspect (Induction(..)) +import Agda.Syntax.Common.KeywordRange +import Agda.Syntax.Common.Pretty import Agda.Syntax.Position import Agda.Utils.BiMap (HasTag(..)) +import Agda.Utils.Boolean (Boolean(fromBool), IsBool(toBool)) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) @@ -41,8 +46,6 @@ import Agda.Utils.Null import Agda.Utils.PartialOrd import Agda.Utils.POMonoid -import Agda.Syntax.Common.Aspect (Induction(..)) -import Agda.Syntax.Common.Pretty import Agda.Utils.Impossible @@ -50,6 +53,23 @@ type Arity = 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 --------------------------------------------------------------------------- @@ -99,11 +119,15 @@ data RecordDirectives' a = RecordDirectives { recInductive :: Maybe (Ranged Induction) - , recHasEta :: Maybe HasEta0 + , recHasEta :: Maybe (Ranged HasEta0) , recPattern :: Maybe Range , recConstructor :: Maybe a - } deriving (Functor, Show, Eq) + } deriving (Functor, Show, Eq, Foldable, Traversable) +instance Null (RecordDirectives' a) where + empty = emptyRecordDirectives + null (RecordDirectives a b c d) = and [null a, null b, null c, null d] + emptyRecordDirectives :: RecordDirectives' a emptyRecordDirectives = RecordDirectives empty empty empty empty @@ -206,12 +230,102 @@ patternMatchingAllowed = (== Inductive) --------------------------------------------------------------------------- --- * Hiding +-- * 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) @@ -224,12 +338,8 @@ NotHidden -> "visible" Instance{} -> "instance" --- | Just for the 'Hiding' instance. Should never combine different --- overlapping. -instance Semigroup Overlappable where - NoOverlap <> NoOverlap = NoOverlap - YesOverlap <> YesOverlap = YesOverlap - _ <> _ = __IMPOSSIBLE__ +instance Null Hiding where + empty = NotHidden -- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'. -- 'Instance' and 'NotHidden' are incompatible. @@ -240,12 +350,8 @@ Instance o <> Instance o' = Instance (o <> o') _ <> _ = __IMPOSSIBLE__ -instance Monoid Overlappable where - mempty = NoOverlap - mappend = (<>) - instance Monoid Hiding where - mempty = NotHidden + mempty = empty mappend = (<>) instance HasRange Hiding where @@ -254,10 +360,6 @@ instance KillRange Hiding where killRange = id -instance NFData Overlappable where - rnf NoOverlap = () - rnf YesOverlap = () - instance NFData Hiding where rnf Hidden = () rnf (Instance o) = rnf o @@ -353,8 +455,8 @@ makeInstance' :: LensHiding a => Overlappable -> a -> a makeInstance' o = setHiding (Instance o) -isOverlappable :: LensHiding a => a -> Bool -isOverlappable x = +isYesOverlap :: LensHiding a => a -> Bool +isYesOverlap x = case getHiding x of Instance YesOverlap -> True _ -> False @@ -976,6 +1078,11 @@ rnf (Quantity1 o) = rnf o rnf (Quantityω o) = rnf o +isQuantityω :: LensQuantity a => a -> Bool +isQuantityω a = case getQuantity a of + Quantityω{} -> True + _ -> False + -- ** Erased. -- | A special case of 'Quantity': erased or not. @@ -1393,6 +1500,9 @@ setCohesion = const mapCohesion = id +isContinuous :: LensCohesion a => a -> Bool +isContinuous = (Continuous ==) . getCohesion + -- | Information ordering. -- @Flat \`moreCohesion\` -- Continuous \`moreCohesion\` @@ -2029,6 +2139,7 @@ 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 @@ -2237,16 +2348,17 @@ -- | Access modifier. data Access - = PrivateAccess Origin + = 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" + PrivateAccess _ _ -> "private" + PublicAccess -> "public" instance NFData Access where rnf _ = () @@ -2257,6 +2369,9 @@ instance KillRange Access where killRange = id +privateAccessInserted :: Access +privateAccessInserted = PrivateAccess empty Inserted + -- ** abstract blocks -- | Abstract or concrete. @@ -2273,6 +2388,14 @@ 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 @@ -2301,18 +2424,18 @@ -- | Is this definition eligible for instance search? data IsInstance - = InstanceDef Range -- ^ Range of the @instance@ keyword. + = InstanceDef KwRange -- ^ Range of the @instance@ keyword. | NotInstanceDef deriving (Show, Eq, Ord) instance KillRange IsInstance where killRange = \case - InstanceDef _ -> InstanceDef noRange + InstanceDef _ -> InstanceDef empty i@NotInstanceDef -> i instance HasRange IsInstance where getRange = \case - InstanceDef r -> r + InstanceDef r -> getRange r NotInstanceDef -> noRange instance NFData IsInstance where @@ -2694,7 +2817,9 @@ , using :: Using' n m , hiding :: HidingDirective' n m , impRenaming :: RenamingDirective' n m - , publicOpen :: Maybe Range -- ^ Only for @open@. Exports the opened names from the current module. + , publicOpen :: Maybe KwRange + -- ^ Only for @open@. Exports the opened names from the current module. + -- Range of the @public@ keyword. } deriving Eq @@ -2817,7 +2942,7 @@ 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) u h r + 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 @@ -2952,16 +3077,19 @@ 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)) = @@ -2974,11 +3102,13 @@ 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 (@...@) diff --git a/src/full/Agda/Syntax/Common/KeywordRange.hs b/src/full/Agda/Syntax/Common/KeywordRange.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/Common/KeywordRange.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | 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 diff --git a/src/full/Agda/Syntax/Common/Pretty.hs b/src/full/Agda/Syntax/Common/Pretty.hs --- a/src/full/Agda/Syntax/Common/Pretty.hs +++ b/src/full/Agda/Syntax/Common/Pretty.hs @@ -10,6 +10,7 @@ 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 @@ -102,7 +103,7 @@ pretty _ = P.empty instance Pretty a => Pretty (Maybe a) where - prettyPrec p Nothing = "(nothing)" + prettyPrec p Nothing = P.empty prettyPrec p (Just x) = prettyPrec p x instance Pretty a => Pretty [a] where @@ -182,6 +183,9 @@ punctuate d = P.punctuate d . Fold.toList -- * 'Doc' utilities + +vsep :: [Doc] -> Doc +vsep = vcat . List.intersperse "" pwords :: String -> [Doc] pwords = map text . words diff --git a/src/full/Agda/Syntax/Concrete.hs b/src/full/Agda/Syntax/Concrete.hs --- a/src/full/Agda/Syntax/Concrete.hs +++ b/src/full/Agda/Syntax/Concrete.hs @@ -37,6 +37,7 @@ , ModuleAssignment(..) , BoundName(..), mkBoundName_, mkBoundName , TacticAttribute + , TacticAttribute'(..) , Telescope, Telescope1 , lamBindingsToTelescope , makePi @@ -44,7 +45,6 @@ -- * Declarations , Declaration(..) , isPragma - , isRecordDirective , RecordDirective(..) , RecordDirectives , ModuleApplication(..) @@ -63,6 +63,7 @@ , ThingWithFixity(..) , HoleContent, HoleContent'(..) , spanAllowedBeforeModule + , ungatherRecordDirectives ) where @@ -70,8 +71,12 @@ 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.Set ( Set ) import Data.Text ( Text ) -- import Data.Traversable ( forM ) @@ -269,18 +274,26 @@ data BoundName = BName { boundName :: Name , bnameFixity :: Fixity' - , bnameTactic :: TacticAttribute -- From @tactic attribute + , bnameTactic :: TacticAttribute + -- ^ From @\@tactic@ attribute. , bnameIsFinite :: Bool + -- ^ The @\@finite@ cannot be parsed, it comes from the builtin @Partial@ only. } deriving Eq -type TacticAttribute = Maybe (Ranged Expr) +newtype TacticAttribute' a = TacticAttribute { theTacticAttribute :: Maybe (Ranged a) } + deriving (Eq, Show, NFData, Functor, Foldable, Traversable, KillRange) +type TacticAttribute = TacticAttribute' Expr +instance Null (TacticAttribute' a) where + null = isNothing . theTacticAttribute + empty = TacticAttribute Nothing + mkBoundName_ :: Name -> BoundName mkBoundName_ x = mkBoundName x noFixity' mkBoundName :: Name -> Fixity' -> BoundName -mkBoundName x f = BName x f Nothing False +mkBoundName x f = BName x f empty False -- | A typed binding. @@ -456,6 +469,15 @@ type RecordDirectives = RecordDirectives' (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. -} @@ -464,36 +486,35 @@ = TypeSig ArgInfo TacticAttribute Name Expr -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden) | FieldSig IsInstance TacticAttribute Name (Arg Expr) - | Generalize Range [TypeSignature] -- ^ Variables to be generalized, can be hidden and/or irrelevant. - | Field Range [FieldSignature] + | Generalize KwRange [TypeSignature] -- ^ Variables to be generalized, can be hidden and/or irrelevant. + | Field KwRange [FieldSignature] | FunClause LHS RHS WhereClause Bool | 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 RecordDirectives [LamBinding] [Declaration] - | Record Range Erased Name RecordDirectives [LamBinding] Expr + | RecordDef Range Name [RecordDirective] [LamBinding] [Declaration] + | Record Range Erased Name [RecordDirective] [LamBinding] Expr [Declaration] - | RecordDirective RecordDirective -- ^ Should not survive beyond the parser | Infix Fixity (List1 Name) | Syntax Name Notation -- ^ notation declaration for a name - | PatternSyn Range Name [Arg Name] Pattern - | Mutual Range [Declaration] -- @Range@ of the whole @mutual@ block. - | InterleavedMutual Range [Declaration] - | Abstract Range [Declaration] - | Private Range Origin [Declaration] + | PatternSyn Range Name [WithHiding Name] Pattern + | Mutual KwRange [Declaration] + | InterleavedMutual KwRange [Declaration] + | Abstract KwRange [Declaration] + | Private KwRange Origin [Declaration] -- ^ In "Agda.Syntax.Concrete.Definitions" we generate private blocks -- temporarily, which should be treated different that user-declared -- private blocks. Thus the 'Origin'. - | InstanceB Range [Declaration] - -- ^ The 'Range' here (exceptionally) only refers to the range of the + | InstanceB KwRange [Declaration] + -- ^ The 'KwRange' here only refers to the range of the -- @instance@ keyword. The range of the whole block @InstanceB r ds@ -- is @fuseRange r ds@. - | LoneConstructor Range [Declaration] - | Macro Range [Declaration] - | Postulate Range [TypeSignatureOrInstanceBlock] - | Primitive Range [TypeSignature] + | LoneConstructor KwRange [Declaration] + | Macro KwRange [Declaration] + | Postulate KwRange [TypeSignatureOrInstanceBlock] + | Primitive KwRange [TypeSignature] | Open Range QName ImportDirective | Import Range QName (Maybe AsName) !OpenShortHand ImportDirective | ModuleMacro Range Erased Name ModuleApplication !OpenShortHand @@ -506,18 +527,12 @@ | UnquoteData Range Name [Name] Expr -- ^ @unquoteDecl data d constructor xs = e@ | Pragma Pragma - | Opaque Range [Declaration] + | Opaque KwRange [Declaration] -- ^ @opaque ...@ - | Unfolding Range [QName] + | Unfolding KwRange [QName] -- ^ @unfolding ...@ deriving Eq --- | Extract a record directive -isRecordDirective :: Declaration -> Maybe RecordDirective -isRecordDirective (RecordDirective r) = Just r -isRecordDirective (InstanceB r [RecordDirective (Constructor n p)]) = Just (Constructor n (InstanceDef r)) -isRecordDirective _ = Nothing - -- | Return 'Pragma' if 'Declaration' is 'Pragma'. {-# SPECIALIZE isPragma :: Declaration -> Maybe Pragma #-} {-# SPECIALIZE isPragma :: Declaration -> [Pragma] #-} @@ -541,7 +556,6 @@ Data _ _ _ _ _ _ -> empty DataDef _ _ _ _ -> empty RecordSig _ _ _ _ _ -> empty - RecordDirective _ -> empty Infix _ _ -> empty Syntax _ _ -> empty PatternSyn _ _ _ _ -> empty @@ -571,45 +585,50 @@ -- Pragmas ---------------------------------------------------------------- data Pragma - = OptionsPragma Range [String] - | BuiltinPragma Range RString QName - | RewritePragma Range Range [QName] -- ^ Second Range is for REWRITE keyword. - | ForeignPragma Range RString String -- ^ first string is backend name - | CompilePragma Range RString QName String -- ^ first string is backend name - | StaticPragma Range QName - | InlinePragma Range Bool QName -- ^ INLINE or NOINLINE + = OptionsPragma Range [String] + | BuiltinPragma Range RString QName + | RewritePragma Range Range [QName] -- ^ Second Range is for REWRITE keyword. + | ForeignPragma Range RString String -- ^ first string is backend name + | CompilePragma Range RString QName String -- ^ first string is backend name + | StaticPragma Range QName + | InlinePragma Range Bool QName -- ^ INLINE or NOINLINE - | ImpossiblePragma Range [String] + | ImpossiblePragma Range [String] -- ^ Throws an internal error in the scope checker. -- The 'String's are words to be displayed with the error. - | EtaPragma Range QName + | EtaPragma Range QName -- ^ For coinductive records, use pragma instead of regular -- @eta-equality@ definition (as it is might make Agda loop). - | WarningOnUsage Range QName Text + | WarningOnUsage Range QName Text -- ^ Applies to the named function - | WarningOnImport Range Text + | WarningOnImport Range Text -- ^ Applies to the current module - | InjectivePragma Range QName + | InjectivePragma Range QName -- ^ Mark a definition as injective for the pattern matching unifier. - | DisplayPragma Range Pattern Expr + | InjectiveForInferencePragma Range QName + -- ^ Mark a definition as injective for the conversion checker + | DisplayPragma Range Pattern Expr -- ^ Display lhs as rhs (modifies the printer). -- Attached (more or less) pragmas handled in the nicifier (Concrete.Definitions): - | CatchallPragma Range + | CatchallPragma Range -- ^ Applies to the following function clause. - | TerminationCheckPragma Range (TerminationCheck Name) + | TerminationCheckPragma Range (TerminationCheck Name) -- ^ Applies to the following function (and all that are mutually recursive with it) -- or to the functions in the following mutual block. - | NoCoverageCheckPragma Range + | NoCoverageCheckPragma Range -- ^ Applies to the following function (and all that are mutually recursive with it) -- or to the functions in the following mutual block. - | NoPositivityCheckPragma Range + | NoPositivityCheckPragma Range -- ^ Applies to the following data/record type or mutual block. - | PolarityPragma Range Name [Occurrence] - | NoUniverseCheckPragma Range + | PolarityPragma Range Name [Occurrence] + | NoUniverseCheckPragma Range -- ^ Applies to the following data/record type. - | NotProjectionLikePragma Range QName + | 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 --------------------------------------------------------------------------- @@ -672,14 +691,13 @@ where (f, ess) = appView' e + appView' :: Expr -> ([NamedArg Expr] -> AppView, DList (NamedArg Expr)) appView' = \case - App r e1 e2 -> vApp (appView' e1) e2 + App r e1 e2 -> appView' e1 & second (`DL.snoc` e2) RawApp _ (List2 e1 e2 es) -> (AppView e1, DL.fromList (map arg (e2 : es))) e -> (AppView e, mempty) - vApp (f, es) arg = (f, es `DL.snoc` arg) - arg (HiddenArg _ e) = hide $ defaultArg e arg (InstanceArg _ e) = makeInstance $ defaultArg e arg e = defaultArg (unnamed e) @@ -939,7 +957,7 @@ instance HasRange Declaration where getRange (TypeSig _ _ x t) = fuseRange x t getRange (FieldSig _ _ x t) = fuseRange x t - getRange (Field r _) = r + getRange (Field kwr ds) = fuseRange kwr ds getRange (FunClause lhs rhs wh _) = fuseRange lhs rhs `fuseRange` wh getRange (DataSig r _ _ _ _) = r getRange (Data r _ _ _ _ _) = r @@ -947,21 +965,20 @@ getRange (RecordSig r _ _ _ _) = r getRange (RecordDef r _ _ _ _) = r getRange (Record r _ _ _ _ _ _) = r - getRange (RecordDirective r) = getRange r - getRange (Mutual r _) = r - getRange (InterleavedMutual r _) = r - getRange (LoneConstructor r _) = r - getRange (Abstract r _) = r - getRange (Generalize r _) = r + getRange (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 r _) = r - getRange (Macro r _) = r - getRange (Private r _ _) = r - getRange (Postulate r _) = r - getRange (Primitive 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 @@ -970,8 +987,8 @@ getRange (UnquoteDef r _ _) = r getRange (UnquoteData r _ _ _) = r getRange (Pragma p) = getRange p - getRange (Opaque r _) = r - getRange (Unfolding r _) = r + 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 @@ -1002,6 +1019,7 @@ getRange (ForeignPragma r _ _) = r getRange (StaticPragma r _) = r getRange (InjectivePragma r _) = r + getRange (InjectiveForInferencePragma r _) = r getRange (InlinePragma r _ _) = r getRange (ImpossiblePragma r _) = r getRange (EtaPragma r _) = r @@ -1015,6 +1033,7 @@ 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) @@ -1091,29 +1110,28 @@ 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 noRange) ds - killRange (Field r fs) = killRangeN (Field noRange) fs + 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 (RecordDirective a) = killRangeN RecordDirective a 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 noRange) d - killRange (InterleavedMutual _ d) = killRangeN (InterleavedMutual noRange) d - killRange (LoneConstructor _ d) = killRangeN (LoneConstructor noRange) d - killRange (Abstract _ d) = killRangeN (Abstract noRange) d - killRange (Private _ o d) = killRangeN (Private noRange) o d - killRange (InstanceB _ d) = killRangeN (InstanceB noRange) d - killRange (Macro _ d) = killRangeN (Macro noRange) d - killRange (Postulate _ t) = killRangeN (Postulate noRange) t - killRange (Primitive _ t) = killRangeN (Primitive noRange) t + 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) @@ -1125,8 +1143,8 @@ 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 r xs - killRange (Unfolding r xs) = killRangeN Unfolding r xs + 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 @@ -1213,6 +1231,7 @@ 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 @@ -1228,6 +1247,7 @@ 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 @@ -1327,7 +1347,6 @@ 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 (RecordDirective a) = rnf a 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 @@ -1364,6 +1383,7 @@ rnf (ForeignPragma _ b s) = rnf b `seq` rnf s rnf (StaticPragma _ a) = rnf a rnf (InjectivePragma _ a) = rnf a + rnf (InjectiveForInferencePragma _ a) = rnf a rnf (InlinePragma _ _ a) = rnf a rnf (ImpossiblePragma _ a) = rnf a rnf (EtaPragma _ a) = rnf a @@ -1377,6 +1397,7 @@ 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. diff --git a/src/full/Agda/Syntax/Concrete/Attribute.hs b/src/full/Agda/Syntax/Concrete/Attribute.hs --- a/src/full/Agda/Syntax/Concrete/Attribute.hs +++ b/src/full/Agda/Syntax/Concrete/Attribute.hs @@ -13,6 +13,7 @@ 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 @@ -216,8 +217,9 @@ _ -> Nothing isTacticAttribute :: Attribute -> TacticAttribute -isTacticAttribute (TacticAttribute t) = Just t -isTacticAttribute _ = Nothing +isTacticAttribute = C.TacticAttribute . \case + TacticAttribute t -> Just t + _ -> Nothing relevanceAttributes :: [Attribute] -> [Attribute] relevanceAttributes = filter $ isJust . isRelevanceAttribute @@ -226,4 +228,4 @@ quantityAttributes = filter $ isJust . isQuantityAttribute tacticAttributes :: [Attribute] -> [Attribute] -tacticAttributes = filter $ isJust . isTacticAttribute +tacticAttributes = filter $ isJust . C.theTacticAttribute . isTacticAttribute diff --git a/src/full/Agda/Syntax/Concrete/Definitions.hs b/src/full/Agda/Syntax/Concrete/Definitions.hs --- a/src/full/Agda/Syntax/Concrete/Definitions.hs +++ b/src/full/Agda/Syntax/Concrete/Definitions.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE GADTs #-} - -- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's. -- -- * Attach fixity and syntax declarations to the definition they refer to. @@ -110,11 +108,11 @@ -- equipped with MEASURE pragmas, or whether there is a -- NO_TERMINATION_CHECK pragma. combineTerminationChecks :: Range -> [TerminationCheck] -> Nice TerminationCheck -combineTerminationChecks r tcs = loop tcs where +combineTerminationChecks r = loop + where loop :: [TerminationCheck] -> Nice TerminationCheck loop [] = return TerminationCheck loop (tc : tcs) = do - let failure r = declarationException $ InvalidMeasureMutual r tc' <- loop tcs case (tc, tc') of (TerminationCheck , tc' ) -> return tc' @@ -135,6 +133,7 @@ (Terminating , NonTerminating ) -> failure r (NonTerminating , NoTerminationCheck ) -> failure r (NonTerminating , Terminating ) -> failure r + failure r = declarationException $ InvalidMeasureMutual r combineCoverageChecks :: [CoverageCheck] -> CoverageCheck combineCoverageChecks = Fold.fold @@ -258,7 +257,7 @@ tc <- combineTerminationChecks (getRange d) (mutualTermination checks) let cc = combineCoverageChecks (mutualCoverage checks) let pc = combinePositivityChecks (mutualPositivity checks) - (NiceMutual (getRange ds0) tc cc pc ds0 :) <$> inferMutualBlocks ds1 + (NiceMutual empty tc cc pc ds0 :) <$> inferMutualBlocks ds1 where untilAllDefined :: MutualChecks -> [NiceDeclaration] -> Nice InferredMutual untilAllDefined checks ds = do @@ -307,7 +306,7 @@ FieldSig{} -> __IMPOSSIBLE__ Generalize r [] -> justWarning $ EmptyGeneralize r - Generalize r sigs -> do + Generalize _ sigs -> do gs <- forM sigs $ \case sig@(TypeSig info tac x t) -> do -- Andreas, 2022-03-25, issue #5850: @@ -436,8 +435,6 @@ (flip NiceRecSig defaultErased) return r x ((tel,) <$> mt) (Just (tel, cs)) - RecordDirective r -> justWarning $ InvalidRecordDirective (getRange r) - Mutual r ds' -> do -- The lone signatures encountered so far are not in scope -- for the mutual definition @@ -718,8 +715,8 @@ instanceBlock r =<< niceAxioms InstanceBlock decls Private r o decls | PostulateBlock <- b -> do privateBlock r o =<< niceAxioms b decls - Pragma p@(RewritePragma r _ _) -> do - return [ NicePragma r p ] + 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 @@ -853,21 +850,22 @@ -- Turn a new style `interleaved mutual' block into a new style mutual block -- by grouping the declarations in blocks. mkInterleavedMutual - :: Range -- Range of the whole @mutual@ block. + :: KwRange -- Range of the @interleaved mutual@ keywords. -> [NiceDeclaration] -- Declarations inside the block. -> Nice NiceDeclaration -- Returns a 'NiceMutual'. - mkInterleavedMutual r ds' = do - (other, (m, checks, _)) <- runStateT (groupByBlocks r ds') (empty, mempty, 0) + mkInterleavedMutual kwr ds' = do + (other, (m, checks, _)) <- runStateT (groupByBlocks kwr ds') (empty, mempty, 0) let idecls = other ++ concatMap (uncurry interleavedDecl) (Map.toList m) let decls0 = map snd $ List.sortBy (compare `on` fst) idecls ps <- use loneSigs checkLoneSigs ps let decls = replaceSigs ps decls0 -- process the checks + let r = fuseRange kwr ds' tc <- combineTerminationChecks r (mutualTermination checks) let cc = combineCoverageChecks (mutualCoverage checks) let pc = combinePositivityChecks (mutualPositivity checks) - pure $ NiceMutual r tc cc pc decls + pure $ NiceMutual kwr tc cc pc decls where @@ -944,8 +942,10 @@ _ -> __IMPOSSIBLE__ -- A FunDef always come after an existing FunSig! addFunDef _ = __IMPOSSIBLE__ - addFunClauses :: Range -> [NiceDeclaration] - -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)] + addFunClauses :: + KwRange + -> [NiceDeclaration] + -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)] addFunClauses r (nd@(NiceFunClause _ _ _ tc cc _ d@(FunClause lhs _ _ _)) : ds) = do -- get the candidate functions that are in this interleaved mutual block (m, checks, i) <- get @@ -981,22 +981,24 @@ $ List1.reverse $ fmap (\ (a,_,_) -> a) $ xf :| xfs addFunClauses _ _ = __IMPOSSIBLE__ - groupByBlocks :: Range -> [NiceDeclaration] - -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)] - groupByBlocks r [] = pure [] - groupByBlocks r (d : ds) = do + groupByBlocks :: + KwRange + -> [NiceDeclaration] + -> StateT (InterleavedMutual, MutualChecks, DeclNum) Nice [(DeclNum, NiceDeclaration)] + groupByBlocks kwr [] = pure [] + groupByBlocks kwr (d : ds) = do -- for most branches we deal with the one declaration and move on - let oneOff act = act >>= \ ns -> (ns ++) <$> groupByBlocks r ds + let oneOff act = act >>= \ ns -> (ns ++) <$> groupByBlocks kwr ds case d of NiceDataSig{} -> oneOff $ [] <$ addDataType d NiceDataDef r _ _ _ _ n _ ds -> oneOff $ [] <$ addDataConstructors (Just r) (Just n) ds - NiceLoneConstructor r ds -> oneOff $ [] <$ addDataConstructors Nothing Nothing ds + NiceLoneConstructor _ ds -> oneOff $ [] <$ addDataConstructors Nothing Nothing ds FunSig{} -> oneOff $ [] <$ addFunType d FunDef _ _ _ _ _ _ n cs | not (isNoName n) -> oneOff $ [] <$ addFunDef d -- It's a bit different for fun clauses because we may need to grab a lot -- of clauses to handle ellipses properly. - NiceFunClause{} -> addFunClauses r (d:ds) + NiceFunClause{} -> addFunClauses kwr (d:ds) -- We do not need to worry about RecSig vs. RecDef: we know there's exactly one -- of each for record definitions and leaving them in place should be enough! _ -> oneOff $ do @@ -1025,10 +1027,10 @@ -- Turn an old-style mutual block into a new style mutual block -- by pushing the definitions to the end. mkOldMutual - :: Range -- Range of the whole @mutual@ block. + :: KwRange -- Range of the @mutual@ keyword (if any). -> [NiceDeclaration] -- Declarations inside the block. -> Nice NiceDeclaration -- Returns a 'NiceMutual'. - mkOldMutual r ds' = do + mkOldMutual kwr ds' = do -- Postulate the missing definitions let ps = loneSigsFromLoneNames loneNames checkLoneSigs ps @@ -1094,8 +1096,8 @@ -- Opaque blocks can not participate in old-style mutual -- recursion. If some of the definitions are opaque then -- they all need to be. - NiceOpaque{} -> - In3 d <$ do declarationException $ OpaqueInMutual (getRange d) + NiceOpaque r _ _ -> + In3 d <$ do declarationException $ OpaqueInMutual r NicePragma r pragma -> case pragma of OptionsPragma{} -> top -- error thrown in the type checker @@ -1117,11 +1119,14 @@ 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. @@ -1149,6 +1154,7 @@ -- Compute termination checking flag for mutual block tc0 <- use terminationCheckPragma let tcs = map termCheck ds + let r = fuseRange kwr ds' tc <- combineTerminationChecks r (tc0:tcs) -- Compute coverage checking flag for mutual block @@ -1161,15 +1167,9 @@ let pcs = map positivityCheckOldMutual ds let pc = combinePositivityChecks (pc0:pcs) - return $ NiceMutual r tc cc pc $ top ++ bottom - -- return $ NiceMutual r tc pc $ other ++ defs - -- return $ NiceMutual r tc pc $ sigs ++ other - where - - -- isTypeSig Axiom{} = True - -- isTypeSig d | LoneSig{} <- declKind d = True - -- isTypeSig _ = False + return $ NiceMutual kwr tc cc pc $ top ++ bottom + where sigNames = [ (r, x, k) | LoneSigDecl r k x <- map declKind ds' ] defNames = [ (x, k) | LoneDefs k xs <- map declKind ds', x <- xs ] -- compute the set difference with equality just on names @@ -1244,27 +1244,33 @@ -- A mutual block cannot have a measure, -- but it can skip termination check. - abstractBlock _ [] = return [] + abstractBlock + :: KwRange -- Range of @abstract@ keyword. + -> [NiceDeclaration] + -> Nice [NiceDeclaration] abstractBlock r ds = do (ds', anyChange) <- runChangeT $ mkAbstract ds - let inherited = r == noRange + let inherited = null r if anyChange then return ds' else do -- hack to avoid failing on inherited abstract blocks in where clauses unless inherited $ declarationWarning $ UselessAbstract r return ds -- no change! - privateBlock _ _ [] = return [] + privateBlock + :: KwRange -- Range of @private@ keyword. + -> Origin -- Origin of the private block. + -> [NiceDeclaration] + -> Nice [NiceDeclaration] privateBlock r o ds = do - (ds', anyChange) <- runChangeT $ mkPrivate o ds + (ds', anyChange) <- runChangeT $ mkPrivate r o ds if anyChange then return ds' else do when (o == UserWritten) $ declarationWarning $ UselessPrivate r return ds -- no change! instanceBlock - :: Range -- Range of @instance@ keyword. + :: KwRange -- Range of @instance@ keyword. -> [NiceDeclaration] -> Nice [NiceDeclaration] - instanceBlock _ [] = return [] instanceBlock r ds = do let (ds', anyChange) = runChange $ mapM (mkInstance r) ds if anyChange then return ds' else do @@ -1273,7 +1279,7 @@ -- Make a declaration eligible for instance search. mkInstance - :: Range -- Range of @instance@ keyword. + :: KwRange -- Range of @instance@ keyword. -> Updater NiceDeclaration mkInstance r0 = \case Axiom r p a i rel x e -> (\ i -> Axiom r p a i rel x e) <$> setInstance r0 i @@ -1301,20 +1307,36 @@ d@NiceUnquoteData{} -> return d setInstance - :: Range -- Range of @instance@ keyword. + :: KwRange -- Range of @instance@ keyword. -> Updater IsInstance setInstance r0 = \case i@InstanceDef{} -> return i _ -> dirty $ InstanceDef r0 - macroBlock r ds = mapM mkMacro ds + macroBlock + :: KwRange -- Range of @macro@ keyword. + -> [NiceDeclaration] + -> Nice [NiceDeclaration] + macroBlock r ds = do + (ds', anyChange) <- runChangeT $ mkMacro ds + if anyChange then return ds' else do + declarationWarning $ UselessMacro r + return ds -- no change! - mkMacro :: NiceDeclaration -> Nice NiceDeclaration - mkMacro = \case - FunSig r p a i _ rel tc cc x e -> return $ FunSig r p a i MacroDef rel tc cc x e - d@FunDef{} -> return d - d -> declarationException (BadMacroDef d) +class MakeMacro a where + mkMacro :: UpdaterT Nice a + default mkMacro :: (Traversable f, MakeMacro a', a ~ f a') => UpdaterT Nice a + mkMacro = traverse mkMacro + +instance MakeMacro a => MakeMacro [a] + +instance MakeMacro NiceDeclaration where + mkMacro = \case + FunSig r p a i _ rel tc cc x e -> dirty $ FunSig r p a i MacroDef rel tc cc x e + d@FunDef{} -> return d + d -> lift $ declarationException $ BadMacroDef d + -- | Make a declaration abstract. -- -- Mark computation as 'dirty' if there was a declaration that could be made abstract. @@ -1379,12 +1401,15 @@ Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with -- | Contents of a @where@ clause are abstract if the parent is. +-- +-- These are inherited 'Abstract' blocks, indicated by an empty range +-- for the @abstract@ keyword. instance MakeAbstract WhereClause where mkAbstract NoWhere = return $ NoWhere mkAbstract (AnyWhere r ds) = dirty $ AnyWhere r - [Abstract noRange ds] + [Abstract empty ds] mkAbstract (SomeWhere r e m a ds) = dirty $ SomeWhere r e m a - [Abstract noRange ds] + [Abstract empty ds] -- | Make a declaration private. -- @@ -1396,10 +1421,10 @@ -- Then, nested @private@s would sometimes also be complained about. class MakePrivate a where - mkPrivate :: Origin -> UpdaterT Nice a + mkPrivate :: KwRange -> Origin -> UpdaterT Nice a - default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> UpdaterT Nice a - mkPrivate o = traverse $ mkPrivate o + default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => KwRange -> Origin -> UpdaterT Nice a + mkPrivate kwr o = traverse $ mkPrivate kwr o instance MakePrivate a => MakePrivate [a] @@ -1408,28 +1433,28 @@ -- mkPrivate = traverse mkPrivate instance MakePrivate Access where - mkPrivate o = \case + mkPrivate kwr o = \case p@PrivateAccess{} -> return p -- OR? return $ PrivateAccess o - _ -> dirty $ PrivateAccess o + _ -> dirty $ PrivateAccess kwr o instance MakePrivate NiceDeclaration where - mkPrivate o = \case - Axiom r p a i rel x e -> (\ p -> Axiom r p a i rel x e) <$> mkPrivate o p - NiceField r p a i tac x e -> (\ p -> NiceField r p a i tac x e) <$> mkPrivate o p - PrimitiveFunction r p a x e -> (\ p -> PrimitiveFunction r p a x e) <$> mkPrivate o p - NiceMutual r tc cc pc ds -> (\ ds-> NiceMutual r tc cc pc ds) <$> mkPrivate o ds - NiceLoneConstructor r ds -> NiceLoneConstructor r <$> mkPrivate o ds - NiceModule r p a e x tel ds -> (\ p -> NiceModule r p a e x tel ds) <$> mkPrivate o p - NiceModuleMacro r p e x ma op is -> (\ p -> NiceModuleMacro r p e x ma op is) <$> mkPrivate o p - FunSig r p a i m rel tc cc x e -> (\ p -> FunSig r p a i m rel tc cc x e) <$> mkPrivate o p - NiceRecSig r er p a pc uc x ls t -> (\ p -> NiceRecSig r er p a pc uc x ls t) <$> mkPrivate o p - NiceDataSig r er p a pc uc x ls t -> (\ p -> NiceDataSig r er p a pc uc x ls t) <$> mkPrivate o p - NiceFunClause r p a tc cc catchall d -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate o p - NiceUnquoteDecl r p a i tc cc x e -> (\ p -> NiceUnquoteDecl r p a i tc cc x e) <$> mkPrivate o p - NiceUnquoteDef r p a tc cc x e -> (\ p -> NiceUnquoteDef r p a tc cc x e) <$> mkPrivate o p - NicePatternSyn r p x xs p' -> (\ p -> NicePatternSyn r p x xs p') <$> mkPrivate o p - NiceGeneralize r p i tac x t -> (\ p -> NiceGeneralize r p i tac x t) <$> mkPrivate o p - NiceOpaque r ns ds -> (\ p -> NiceOpaque r ns p) <$> mkPrivate o ds + mkPrivate kwr o = \case + Axiom r p a i rel x e -> (\ p -> Axiom r p a i rel x e) <$> mkPrivate kwr o p + NiceField r p a i tac x e -> (\ p -> NiceField r p a i tac x e) <$> mkPrivate kwr o p + PrimitiveFunction r p a x e -> (\ p -> PrimitiveFunction r p a x e) <$> mkPrivate kwr o p + NiceMutual r tc cc pc ds -> (\ ds-> NiceMutual r tc cc pc ds) <$> mkPrivate kwr o ds + NiceLoneConstructor r ds -> NiceLoneConstructor r <$> mkPrivate kwr o ds + NiceModule r p a e x tel ds -> (\ p -> NiceModule r p a e x tel ds) <$> mkPrivate kwr o p + NiceModuleMacro r p e x ma op is -> (\ p -> NiceModuleMacro r p e x ma op is) <$> mkPrivate kwr o p + FunSig r p a i m rel tc cc x e -> (\ p -> FunSig r p a i m rel tc cc x e) <$> mkPrivate kwr o p + NiceRecSig r er p a pc uc x ls t -> (\ p -> NiceRecSig r er p a pc uc x ls t) <$> mkPrivate kwr o p + NiceDataSig r er p a pc uc x ls t -> (\ p -> NiceDataSig r er p a pc uc x ls t) <$> mkPrivate kwr o p + NiceFunClause r p a tc cc catchall d -> (\ p -> NiceFunClause r p a tc cc catchall d) <$> mkPrivate kwr o p + NiceUnquoteDecl r p a i tc cc x e -> (\ p -> NiceUnquoteDecl r p a i tc cc x e) <$> mkPrivate kwr o p + NiceUnquoteDef r p a tc cc x e -> (\ p -> NiceUnquoteDef r p a tc cc x e) <$> mkPrivate kwr o p + NicePatternSyn r p x xs p' -> (\ p -> NicePatternSyn r p x xs p') <$> mkPrivate kwr o p + NiceGeneralize r p i tac x t -> (\ p -> NiceGeneralize r p i tac x t) <$> mkPrivate kwr o p + NiceOpaque r ns ds -> (\ p -> NiceOpaque r ns p) <$> mkPrivate kwr o ds d@NicePragma{} -> return d d@(NiceOpen _ _ directives) -> do whenJust (publicOpen directives) $ lift . declarationWarning . OpenPublicPrivate @@ -1437,17 +1462,17 @@ d@NiceImport{} -> return d -- Andreas, 2016-07-08, issue #2089 -- we need to propagate 'private' to the named where modules - FunDef r ds a i tc cc x cls -> FunDef r ds a i tc cc x <$> mkPrivate o cls + FunDef r ds a i tc cc x cls -> FunDef r ds a i tc cc x <$> mkPrivate kwr o cls d@NiceDataDef{} -> return d d@NiceRecDef{} -> return d d@NiceUnquoteData{} -> return d instance MakePrivate Clause where - mkPrivate o (Clause x catchall lhs rhs wh with) = do - Clause x catchall lhs rhs <$> mkPrivate o wh <*> mkPrivate o with + mkPrivate kwr o (Clause x catchall lhs rhs wh with) = do + Clause x catchall lhs rhs <$> mkPrivate kwr o wh <*> mkPrivate kwr o with instance MakePrivate WhereClause where - mkPrivate o = \case + mkPrivate kwr o = \case d@NoWhere -> return d -- @where@-declarations are protected behind an anonymous module, -- thus, they are effectively private by default. @@ -1457,7 +1482,7 @@ -- 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 o a <&> \a' -> 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. @@ -1466,9 +1491,9 @@ -- 'Declaration's. notSoNiceDeclarations :: NiceDeclaration -> [Declaration] notSoNiceDeclarations = \case - Axiom _ _ _ i rel x e -> inst i [TypeSig rel Nothing x e] + Axiom _ _ _ i rel x e -> inst i [TypeSig rel empty x e] NiceField _ _ _ i tac x argt -> [FieldSig i tac x argt] - PrimitiveFunction r _ _ x e -> [Primitive r [TypeSig (argInfo e) Nothing x (unArg e)]] + PrimitiveFunction _ _ _ x e -> [Primitive empty [TypeSig (argInfo e) empty x (unArg e)]] NiceMutual r _ _ _ ds -> [Mutual r $ concatMap notSoNiceDeclarations ds] NiceLoneConstructor r ds -> [LoneConstructor r $ concatMap notSoNiceDeclarations ds] NiceModule r _ _ e x tel ds -> [Module r e x tel ds] @@ -1480,12 +1505,12 @@ NiceRecSig r er _ _ _ _ x bs e -> [RecordSig r er x bs e] NiceDataSig r er _ _ _ _ x bs e -> [DataSig r er x bs e] NiceFunClause _ _ _ _ _ _ d -> [d] - FunSig _ _ _ i _ rel _ _ x e -> inst i [TypeSig rel Nothing x e] + FunSig _ _ _ i _ rel _ _ x e -> inst i [TypeSig rel empty x e] FunDef _ ds _ _ _ _ _ _ -> ds NiceDataDef r _ _ _ _ x bs cs -> [DataDef r x bs $ concatMap notSoNiceDeclarations cs] NiceRecDef r _ _ _ _ x dir bs ds -> [RecordDef r x dir bs ds] NicePatternSyn r _ n as p -> [PatternSyn r n as p] - NiceGeneralize r _ i tac n e -> [Generalize r [TypeSig i tac n e]] + NiceGeneralize _ _ i tac n e -> [Generalize empty [TypeSig i tac n e]] NiceUnquoteDecl r _ _ i _ _ x e -> inst i [UnquoteDecl r x e] NiceUnquoteDef r _ _ _ _ x e -> [UnquoteDef r x e] NiceUnquoteData r _ _ _ _ x xs e -> [UnquoteData r x xs e] diff --git a/src/full/Agda/Syntax/Concrete/Definitions/Errors.hs b/src/full/Agda/Syntax/Concrete/Definitions/Errors.hs --- a/src/full/Agda/Syntax/Concrete/Definitions/Errors.hs +++ b/src/full/Agda/Syntax/Concrete/Definitions/Errors.hs @@ -44,16 +44,17 @@ -- ^ In an interleaved mutual block, a constructor could belong to any of the data signatures ('Name') | InvalidMeasureMutual Range -- ^ In a mutual block, all or none need a MEASURE pragma. - -- Range is of mutual block. + -- 'Range' is the one of the offending pragma or the mutual block. | UnquoteDefRequiresSignature (List1 Name) | BadMacroDef NiceDeclaration - | UnfoldingOutsideOpaque Range + | UnfoldingOutsideOpaque KwRange -- ^ An unfolding declaration was not the first declaration -- contained in an opaque block. - | OpaqueInMutual Range - -- ^ @opaque@ block nested in a @mutual@ block. This can never - -- happen, even with reordering. - | DisallowedInterleavedMutual Range String (List1 Name) + | 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. @@ -70,16 +71,16 @@ -- | Non-fatal errors encountered in the Nicifier. data DeclarationWarning' -- Please keep in alphabetical order. - = EmptyAbstract Range -- ^ Empty @abstract@ block. - | EmptyConstructor Range -- ^ Empty @constructor@ block. - | EmptyField Range -- ^ Empty @field@ block. - | EmptyGeneralize Range -- ^ Empty @variable@ block. - | EmptyInstance Range -- ^ Empty @instance@ block - | EmptyMacro Range -- ^ Empty @macro@ block. - | EmptyMutual Range -- ^ Empty @mutual@ block. - | EmptyPostulate Range -- ^ Empty @postulate@ block. - | EmptyPrivate Range -- ^ Empty @private@ block. - | EmptyPrimitive Range -- ^ Empty @primitive@ block. + = 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. | HiddenGeneralize Range -- ^ A 'Hidden' identifier in a @variable@ declaration. -- Hiding has no effect there as generalized variables are always hidden @@ -99,8 +100,6 @@ | InvalidNoUniverseCheckPragma Range -- ^ A {-\# NO_UNIVERSE_CHECK \#-} pragma -- that does not apply to a data or record type. - | InvalidRecordDirective Range - -- ^ A record directive outside of a record / below existing fields. | InvalidTerminationCheckPragma Range -- ^ A {-\# TERMINATING \#-} and {-\# NON_TERMINATING \#-} pragma -- that does not apply to any function. @@ -109,10 +108,12 @@ | MissingDefinitions [(Name, Range)] -- ^ Declarations (e.g. type signatures) without a definition. | NotAllowedInMutual Range String - | OpenPublicPrivate Range + | OpenPublicPrivate KwRange -- ^ @private@ has no effect on @open public@. (But the user might think so.) - | OpenPublicAbstract Range + -- 'KwRange' is the range of the @public@ keyword. + | OpenPublicAbstract KwRange -- ^ @abstract@ has no effect on @open public@. (But the user might think so.) + -- 'KwRange' is the range of the @public@ keyword. | PolarityPragmasButNotPostulates [Name] | PragmaNoTerminationCheck Range -- ^ Pragma @{-\# NO_TERMINATION_CHECK \#-}@ has been replaced @@ -131,11 +132,13 @@ | UnknownFixityInMixfixDecl [Name] | UnknownNamesInFixityDecl [Name] | UnknownNamesInPolarityPragmas [Name] - | UselessAbstract Range + | UselessAbstract KwRange -- ^ @abstract@ block with nothing that can (newly) be made abstract. - | UselessInstance Range + | UselessInstance KwRange -- ^ @instance@ block with nothing that can (newly) become an instance. - | UselessPrivate Range + | UselessMacro KwRange + -- ^ @macro@ block with nothing that can (newly) be made macro. + | UselessPrivate KwRange -- ^ @private@ block with nothing that can (newly) be made private. deriving (Show, Generic) @@ -161,7 +164,6 @@ InvalidConstructorBlock{} -> InvalidConstructorBlock_ InvalidNoPositivityCheckPragma{} -> InvalidNoPositivityCheckPragma_ InvalidNoUniverseCheckPragma{} -> InvalidNoUniverseCheckPragma_ - InvalidRecordDirective{} -> InvalidRecordDirective_ InvalidTerminationCheckPragma{} -> InvalidTerminationCheckPragma_ InvalidCoverageCheckPragma{} -> InvalidCoverageCheckPragma_ MissingDeclarations{} -> MissingDeclarations_ @@ -186,6 +188,7 @@ UnknownNamesInPolarityPragmas{} -> UnknownNamesInPolarityPragmas_ UselessAbstract{} -> UselessAbstract_ UselessInstance{} -> UselessInstance_ + UselessMacro{} -> UselessMacro_ UselessPrivate{} -> UselessPrivate_ -- | Nicifier warnings turned into errors in @--safe@ mode. @@ -211,7 +214,6 @@ InvalidConstructorBlock{} -> False InvalidNoPositivityCheckPragma{} -> False InvalidNoUniverseCheckPragma{} -> False - InvalidRecordDirective{} -> False InvalidTerminationCheckPragma{} -> False InvalidCoverageCheckPragma{} -> False MissingDeclarations{} -> True -- not safe @@ -236,6 +238,7 @@ UnknownNamesInPolarityPragmas{} -> False UselessAbstract{} -> False UselessInstance{} -> False + UselessMacro{} -> False UselessPrivate{} -> False -- | Pragmas not allowed in @--safe@ mode produce an 'unsafeDeclarationWarning'. @@ -251,6 +254,7 @@ ForeignPragma{} -> empty ImpossiblePragma{} -> empty InjectivePragma{} -> singleton $ SafeFlagInjective r + InjectiveForInferencePragma{} -> empty InlinePragma{} -> empty NoCoverageCheckPragma{} -> singleton $ SafeFlagNoCoverageCheck r NoPositivityCheckPragma{} -> singleton $ SafeFlagNoPositivityCheck r @@ -273,6 +277,7 @@ NoTerminationCheck -> empty WarningOnImport{} -> empty WarningOnUsage{} -> empty + OverlapPragma{} -> empty where r = getRange p @@ -296,25 +301,25 @@ getRange (InvalidMeasureMutual r) = r getRange (UnquoteDefRequiresSignature x) = getRange x getRange (BadMacroDef d) = getRange d - getRange (UnfoldingOutsideOpaque r) = r - getRange (OpaqueInMutual r) = r - getRange (DisallowedInterleavedMutual r _ _) = r + 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 r -> r - EmptyConstructor r -> r - EmptyField r -> r - EmptyGeneralize r -> r - EmptyInstance r -> r - EmptyMacro r -> r - EmptyMutual r -> r - EmptyPostulate r -> r - EmptyPrimitive r -> r - EmptyPrivate r -> r + 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 HiddenGeneralize r -> r InvalidCatchallPragma r -> r InvalidConstructor r -> r @@ -322,13 +327,12 @@ InvalidCoverageCheckPragma r -> r InvalidNoPositivityCheckPragma r -> r InvalidNoUniverseCheckPragma r -> r - InvalidRecordDirective r -> r InvalidTerminationCheckPragma r -> r MissingDeclarations xs -> getRange xs MissingDefinitions xs -> getRange xs NotAllowedInMutual r x -> r - OpenPublicAbstract r -> r - OpenPublicPrivate r -> r + OpenPublicAbstract kwr -> getRange kwr + OpenPublicPrivate kwr -> getRange kwr PolarityPragmasButNotPostulates xs -> getRange xs PragmaCompiled r -> r PragmaNoTerminationCheck r -> r @@ -344,9 +348,10 @@ UnknownFixityInMixfixDecl xs -> getRange xs UnknownNamesInFixityDecl xs -> getRange xs UnknownNamesInPolarityPragmas xs -> getRange xs - UselessAbstract r -> r - UselessInstance r -> r - UselessPrivate r -> r + 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. @@ -444,6 +449,9 @@ 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." @@ -466,17 +474,14 @@ HiddenGeneralize _ -> fsep $ pwords "Declaring a variable as hidden has no effect in a variable block. Generalization never introduces visible arguments." - InvalidRecordDirective{} -> fsep $ - pwords "Record directives can only be used inside record definitions and before field declarations." - InvalidTerminationCheckPragma _ -> fsep $ pwords "Termination checking pragmas can only precede a function definition or a mutual block (that contains a function definition)." InvalidConstructor{} -> fsep $ - pwords "`constructor' blocks may only contain type signatures for constructors." + pwords "`data _ where' blocks may only contain type signatures for constructors." InvalidConstructorBlock{} -> fsep $ - pwords "No `constructor' blocks outside of `interleaved mutual' blocks." + 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)." diff --git a/src/full/Agda/Syntax/Concrete/Definitions/Monad.hs b/src/full/Agda/Syntax/Concrete/Definitions/Monad.hs --- a/src/full/Agda/Syntax/Concrete/Definitions/Monad.hs +++ b/src/full/Agda/Syntax/Concrete/Definitions/Monad.hs @@ -171,7 +171,7 @@ -- | Ensure that all forward declarations have been given a definition, -- raising an error indicating *why* they would have had to have been -- defined. -breakImplicitMutualBlock :: Range -> String -> Nice () +breakImplicitMutualBlock :: KwRange -> String -> Nice () breakImplicitMutualBlock r why = do m <- use loneSigs List1.unlessNull (Map.elems m) $ \ xs -> diff --git a/src/full/Agda/Syntax/Concrete/Definitions/Types.hs b/src/full/Agda/Syntax/Concrete/Definitions/Types.hs --- a/src/full/Agda/Syntax/Concrete/Definitions/Types.hs +++ b/src/full/Agda/Syntax/Concrete/Definitions/Types.hs @@ -52,7 +52,7 @@ -- ('Hiding' should be 'NotHidden'.) | NiceField Range Access IsAbstract IsInstance TacticAttribute Name (Arg Expr) | PrimitiveFunction Range Access IsAbstract Name (Arg Expr) - | NiceMutual Range TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration] + | NiceMutual KwRange TerminationCheck CoverageCheck PositivityCheck [NiceDeclaration] | NiceModule Range Access IsAbstract Erased QName Telescope [Declaration] | NiceModuleMacro Range Access Erased Name ModuleApplication @@ -76,15 +76,15 @@ -- Andreas, 2017-01-01: Because of issue #2372, we add 'IsInstance' here. -- An alias should know that it is an instance. | NiceDataDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [LamBinding] [NiceConstructor] - | NiceLoneConstructor Range [NiceConstructor] - | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name RecordDirectives [LamBinding] [Declaration] + | NiceLoneConstructor KwRange [NiceConstructor] + | NiceRecDef Range Origin IsAbstract PositivityCheck UniverseCheck Name [RecordDirective] [LamBinding] [Declaration] -- ^ @(Maybe Range)@ gives range of the 'pattern' declaration. - | NicePatternSyn Range Access Name [Arg Name] Pattern + | NicePatternSyn Range Access Name [WithHiding Name] Pattern | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr | NiceUnquoteData Range Access IsAbstract PositivityCheck UniverseCheck Name [Name] Expr - | NiceOpaque Range [QName] [NiceDeclaration] + | NiceOpaque KwRange [QName] [NiceDeclaration] deriving (Show, Generic) instance NFData NiceDeclaration @@ -204,7 +204,7 @@ instance HasRange NiceDeclaration where getRange (Axiom r _ _ _ _ _ _) = r getRange (NiceField r _ _ _ _ _ _) = r - getRange (NiceMutual r _ _ _ _) = r + getRange (NiceMutual kwr _ _ _ ds) = fuseRange kwr ds getRange (NiceModule r _ _ _ _ _ _ ) = r getRange (NiceModuleMacro r _ _ _ _ _ _) = r getRange (NiceOpen r _ _) = r @@ -214,7 +214,7 @@ getRange (FunSig r _ _ _ _ _ _ _ _ _) = r getRange (FunDef r _ _ _ _ _ _ _) = r getRange (NiceDataDef r _ _ _ _ _ _ _) = r - getRange (NiceLoneConstructor r _) = r + getRange (NiceLoneConstructor kwr ds) = fuseRange kwr ds getRange (NiceRecDef r _ _ _ _ _ _ _ _) = r getRange (NiceRecSig r _ _ _ _ _ _ _ _) = r getRange (NiceDataSig r _ _ _ _ _ _ _ _) = r @@ -224,7 +224,7 @@ getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r getRange (NiceUnquoteDef r _ _ _ _ _ _) = r getRange (NiceUnquoteData r _ _ _ _ _ _ _) = r - getRange (NiceOpaque r _ _) = r + getRange (NiceOpaque kwr xs ds) = getRange (kwr, xs, ds) instance Pretty NiceDeclaration where pretty = \case @@ -244,7 +244,7 @@ FunSig _ _ _ _ _ _ _ _ x _ -> pretty x <+> colon <+> text "_" FunDef _ _ _ _ _ _ x _ -> pretty x <+> text "= _" NiceDataDef _ _ _ _ _ x _ _ -> text "data" <+> pretty x <+> text "where" - NiceLoneConstructor _ ds -> text "constructor" + NiceLoneConstructor _ _ -> text "data _ where" NiceRecDef _ _ _ _ _ x _ _ _ -> text "record" <+> pretty x <+> text "where" NicePatternSyn _ _ x _ _ -> text "pattern" <+> pretty x NiceGeneralize _ _ _ _ x _ -> text "variable" <+> pretty x diff --git a/src/full/Agda/Syntax/Concrete/Fixity.hs b/src/full/Agda/Syntax/Concrete/Fixity.hs --- a/src/full/Agda/Syntax/Concrete/Fixity.hs +++ b/src/full/Agda/Syntax/Concrete/Fixity.hs @@ -14,6 +14,7 @@ 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 @@ -171,7 +172,6 @@ RecordSig {} -> mempty RecordDef {} -> mempty Record {} -> mempty - RecordDirective {} -> mempty LoneConstructor {} -> mempty PatternSyn {} -> mempty Postulate {} -> mempty @@ -223,9 +223,8 @@ DataDef _ _ _ cs -> foldMap declaredNames cs Data _ _ x _ _ cs -> declaresName x <> foldMap declaredNames cs RecordSig _ _ x _ _ -> declaresName x - RecordDef _ x d _ _ -> declaresNames $ foldMap (:[]) (fst <$> recConstructor d) - Record _ _ x d _ _ _ -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d) - RecordDirective _ -> mempty + RecordDef _ x ds _ _ -> declaresNames $ maybeToList (recDirConstructor ds) + Record _ _ x ds _ _ _ -> declaresNames $ x : maybeToList (recDirConstructor ds) Infix _ _ -> mempty Syntax _ _ -> mempty PatternSyn _ x _ _ -> declaresName x @@ -253,3 +252,8 @@ 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 diff --git a/src/full/Agda/Syntax/Concrete/Generic.hs b/src/full/Agda/Syntax/Concrete/Generic.hs --- a/src/full/Agda/Syntax/Concrete/Generic.hs +++ b/src/full/Agda/Syntax/Concrete/Generic.hs @@ -87,6 +87,7 @@ 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) @@ -197,7 +198,8 @@ instance (ExprLike qn, ExprLike e) => ExprLike (RewriteEqn' qn nm p e) where mapExpr f = \case Rewrite es -> Rewrite (mapExpr f es) - Invert qn pes -> Invert qn (fmap (fmap $ fmap $ mapExpr f) pes) + Invert qn pes -> Invert qn $ (fmap . fmap . fmap . mapExpr) f pes + LeftLet pes -> LeftLet $ (fmap . fmap . mapExpr) f pes foldExpr = __IMPOSSIBLE__ traverseExpr = __IMPOSSIBLE__ @@ -238,7 +240,6 @@ Record r er n dir tel e ds -> Record r er n dir (mapE tel) (mapE e) $ mapE ds - e@RecordDirective{} -> e e@Infix{} -> e e@Syntax{} -> e e@PatternSyn{} -> e @@ -320,7 +321,6 @@ Data _ _ _ _ _ _ -> mempty DataDef _ _ _ _ -> mempty RecordSig _ _ _ _ _ -> mempty - RecordDirective _ -> mempty Infix _ _ -> mempty Syntax _ _ -> mempty PatternSyn _ _ _ _ -> mempty @@ -376,7 +376,6 @@ Data _ _ _ _ _ _ -> return d DataDef _ _ _ _ -> return d RecordSig _ _ _ _ _ -> return d - RecordDirective _ -> return d Infix _ _ -> return d Syntax _ _ -> return d PatternSyn _ _ _ _ -> return d diff --git a/src/full/Agda/Syntax/Concrete/Operators.hs b/src/full/Agda/Syntax/Concrete/Operators.hs --- a/src/full/Agda/Syntax/Concrete/Operators.hs +++ b/src/full/Agda/Syntax/Concrete/Operators.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-| The parser doesn't know about operators and parses everything as normal diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs --- a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs +++ b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} module Agda.Syntax.Concrete.Operators.Parser where diff --git a/src/full/Agda/Syntax/Concrete/Pretty.hs b/src/full/Agda/Syntax/Concrete/Pretty.hs --- a/src/full/Agda/Syntax/Concrete/Pretty.hs +++ b/src/full/Agda/Syntax/Concrete/Pretty.hs @@ -84,11 +84,14 @@ prettyQuantity :: LensQuantity a => a -> Doc -> Doc prettyQuantity a = (pretty (getQuantity a) <+>) +instance Pretty Lock where + pretty = \case + IsLock LockOLock -> "@lock" + IsLock LockOTick -> "@tick" + IsNotLock -> empty + prettyLock :: LensLock a => a -> Doc -> Doc -prettyLock a doc = case getLock a of - IsLock LockOLock -> "@lock" <+> doc - IsLock LockOTick -> "@tick" <+> doc - IsNotLock -> doc +prettyLock a = (pretty (getLock a) <+>) prettyErased :: Erased -> Doc -> Doc prettyErased = prettyQuantity . asQuantity @@ -105,9 +108,12 @@ | otherwise = id prettyTactic' :: TacticAttribute -> Doc -> Doc -prettyTactic' Nothing d = d -prettyTactic' (Just t) d = "@" <> (parens ("tactic" <+> pretty t) <+> d) +prettyTactic' t = (pretty t <+>) +instance Pretty a => Pretty (TacticAttribute' a) where + pretty (TacticAttribute t) = + ifNull (pretty t) empty \ d -> "@" <> parens ("tactic" <+> d) + instance (Pretty a, Pretty b) => Pretty (a, b) where pretty (a, b) = parens $ (pretty a <> comma) <+> pretty b @@ -282,8 +288,10 @@ pretty' (RHS e) = arrow <+> pretty e pretty' AbsurdRHS = empty +-- Andreas, 2024-02-25 +-- Q: Can we always ignore the tactic and the finiteness here? instance Pretty BoundName where - pretty BName{ boundName = x } = pretty x + pretty (BName x _fix _tac _fin) = pretty x data NamedBinding = NamedBinding { withHiding :: Bool @@ -297,29 +305,31 @@ | otherwise = Nothing instance Pretty a => Pretty (Binder' a) where - pretty (Binder mpat n) = let d = pretty n in case mpat of - Nothing -> d - Just pat -> d <+> "@" <+> parens (pretty pat) + pretty (Binder mpat n) = + applyWhenJust mpat (\ pat -> (<+> ("@" <+> parens (pretty pat)))) $ pretty n instance Pretty NamedBinding where - pretty (NamedBinding withH x) = prH $ - if | Just l <- isLabeled x -> text l <+> "=" <+> pretty xb - | otherwise -> pretty xb - + pretty (NamedBinding withH + x@(Arg (ArgInfo h (Modality r q c) _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 = (pretty r <>) + . prettyHiding h mparens + . (coh <+>) + . (qnt <+>) + . (lck <+>) + . (tac <+>) + coh = pretty c + qnt = pretty q + tac = pretty t + lck = pretty lock + -- Parentheses are needed when an attribute @... is printed + mparens = applyUnless (null coh && null qnt && null lck && null tac) parens - xb = namedArg x - bn = binderName xb - prH | withH = prettyRelevance x - . prettyHiding x mparens - . prettyCohesion x - . prettyQuantity x - . prettyTactic bn - | otherwise = id - -- Parentheses are needed when an attribute @... is present - mparens - | noUserQuantity x, Nothing <- bnameTactic bn = id - | otherwise = parens instance Pretty LamBinding where pretty (DomainFree x) = pretty (NamedBinding True x) @@ -377,10 +387,14 @@ = 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 $ applyWhen (a == PrivateAccess UserWritten) ("private" :) + vcat [ hsep $ privateWhenUserWritten a [ "module", prettyErased erased (pretty m), "where" ] , nest 2 (vcat $ map pretty ds) ] + where + privateWhenUserWritten = \case + PrivateAccess _ UserWritten -> ("private" :) + _ -> id instance Pretty LHS where pretty (LHS p eqs es) = sep @@ -435,8 +449,8 @@ mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ] mkInst NotInstanceDef d = d - mkOverlap i d | isOverlappable i = "overlap" <+> d - | otherwise = d + mkOverlap i d | isYesOverlap i = "overlap" <+> d + | otherwise = d Field _ fs -> sep [ "field" , nest 2 $ vcat (map pretty fs) @@ -487,7 +501,6 @@ pRecord erased x dir tel (Just e) cs RecordDef _ x dir tel cs -> pRecord defaultErased x dir tel Nothing cs - RecordDirective r -> pRecordDirective r Infix f xs -> pretty f <+> fsep (punctuate comma $ fmap pretty xs) Syntax n xs -> "syntax" <+> pretty n <+> "..." @@ -495,7 +508,7 @@ <+> "=" <+> pretty p Mutual _ ds -> namedBlock "mutual" ds InterleavedMutual _ ds -> namedBlock "interleaved mutual" ds - LoneConstructor _ ds -> namedBlock "constructor" ds + LoneConstructor _ ds -> namedBlock "data _ where" ds Abstract _ ds -> namedBlock "abstract" ds Private _ _ ds -> namedBlock "private" ds InstanceB _ ds -> namedBlock "instance" ds @@ -550,6 +563,9 @@ YesEta -> "eta-equality" NoEta () -> "no-eta-equality" +instance Pretty RecordDirective where + pretty = pRecordDirective + pRecordDirective :: RecordDirective -> Doc pRecordDirective = \case Induction ind -> pretty (rangedThing ind) @@ -563,12 +579,12 @@ pRecord :: Erased -> Name - -> RecordDirectives + -> [RecordDirective] -> [LamBinding] -> Maybe Expr -> [Declaration] -> Doc -pRecord erased x (RecordDirectives ind eta pat con) tel me ds = vcat +pRecord erased x directives tel me ds = vcat [ sep [ hsep [ "record" , prettyErased erased (pretty x) @@ -577,10 +593,7 @@ , nest 2 $ pType me ] , nest 2 $ vcat $ concat - [ pInd - , pEta - , pPat - , pCon + [ map pretty directives , map pretty ds ] ] @@ -591,16 +604,6 @@ ] pType Nothing = "where" - pInd = maybeToList $ pretty . rangedThing <$> ind - pEta = maybeToList $ eta <&> pHasEta0 - pPat = maybeToList $ "pattern" <$ pat - -- pEta = caseMaybe eta [] $ \case - -- YesEta -> [ "eta-equality" ] - -- NoEta -> "no-eta-equality" : pPat - -- pPat = \case - -- PatternMatching -> [ "pattern" ] - -- CopatternMatching -> [] - pCon = maybeToList $ (("constructor" <+>) . pretty) . fst <$> con instance Pretty OpenShortHand where pretty DoOpen = "open" @@ -619,6 +622,8 @@ 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) = @@ -645,6 +650,7 @@ pretty (PolarityPragma _ q occs) = hsep ("POLARITY" : pretty q : map pretty occs) pretty (NoUniverseCheckPragma _) = "NO_UNIVERSE_CHECK" + pretty (OverlapPragma _ x m) = hsep [pretty m, pretty x] instance Pretty Associativity where pretty = \case diff --git a/src/full/Agda/Syntax/Info.hs b/src/full/Agda/Syntax/Info.hs --- a/src/full/Agda/Syntax/Info.hs +++ b/src/full/Agda/Syntax/Info.hs @@ -20,7 +20,7 @@ import Agda.Syntax.Position import Agda.Syntax.Concrete import Agda.Syntax.Fixity -import Agda.Syntax.Scope.Base (ScopeInfo, emptyScopeInfo) +import Agda.Syntax.Scope.Base (ScopeInfo) import Agda.Utils.Functor import Agda.Utils.Null @@ -29,29 +29,60 @@ 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 (Show, Eq, Generic) emptyMetaInfo :: MetaInfo emptyMetaInfo = MetaInfo { metaRange = noRange - , metaScope = emptyScopeInfo + , metaScope = empty , metaNumber = Nothing , metaNameSuggestion = "" + , metaKind = empty } +instance Null MetaInfo where + empty = emptyMetaInfo + instance HasRange MetaInfo where getRange = metaRange instance KillRange MetaInfo where killRange m = m { metaRange = noRange } -instance NFData MetaInfo +instance NFData MetaInfo where + rnf (MetaInfo _ a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d {-------------------------------------------------------------------------- General expression information @@ -154,7 +185,7 @@ , defInstance :: IsInstance , defMacro :: IsMacro , defInfo :: DeclInfo - , defTactic :: Maybe (Ranged t) + , defTactic :: TacticAttribute' t } deriving (Show, Eq, Generic) @@ -163,7 +194,7 @@ -- | Same as @mkDefInfo@ but where we can also give the @IsInstance@ mkDefInfoInstance :: Name -> Fixity' -> Access -> IsAbstract -> IsInstance -> IsMacro -> Range -> DefInfo' t -mkDefInfoInstance x f a ab i m r = DefInfo f a ab TransparentDef i m (DeclInfo x r) Nothing +mkDefInfoInstance x f a ab i m r = DefInfo f a ab TransparentDef i m (DeclInfo x r) empty instance HasRange (DefInfo' t) where getRange = getRange . defInfo diff --git a/src/full/Agda/Syntax/Internal.hs b/src/full/Agda/Syntax/Internal.hs --- a/src/full/Agda/Syntax/Internal.hs +++ b/src/full/Agda/Syntax/Internal.hs @@ -1049,12 +1049,12 @@ -- | Convert top-level postfix projections into prefix projections. unSpine :: Term -> Term -unSpine = unSpine' $ const True +unSpine = unSpine' $ \_ _ -> True -- | Convert 'Proj' projection eliminations -- according to their 'ProjOrigin' into -- 'Def' projection applications. -unSpine' :: (ProjOrigin -> Bool) -> Term -> Term +unSpine' :: (ProjOrigin -> QName -> Bool) -> Term -> Term unSpine' p v = case hasElims v of Just (h, es) -> loop h [] es @@ -1063,9 +1063,9 @@ loop :: (Elims -> Term) -> Elims -> Elims -> Term loop h res es = case es of - [] -> v - Proj o f : es' | p o -> loop (Def f) [Apply (defaultArg v)] es' - e : es' -> loop h (e : res) es' + [] -> v + Proj o f : es' | p o f -> loop (Def f) [Apply (defaultArg v)] es' + e : es' -> loop h (e : res) es' where v = h $ reverse res -- | A view distinguishing the neutrals @Var@, @Def@, and @MetaV@ which diff --git a/src/full/Agda/Syntax/Internal/Names.hs b/src/full/Agda/Syntax/Internal/Names.hs --- a/src/full/Agda/Syntax/Internal/Names.hs +++ b/src/full/Agda/Syntax/Internal/Names.hs @@ -161,7 +161,7 @@ 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 _ _ _ + Function cl cc _ _ _ _ _ _ _ _ el _ _ _ -> namesAndMetasIn' sg (cl, cc, el) Datatype _ _ cl cs s _ _ _ trX trD -> namesAndMetasIn' sg (cl, cs, s, trX, trD) @@ -192,7 +192,7 @@ VarP _ _ -> mempty LitP _ l -> namesAndMetasIn' sg l DotP _ v -> namesAndMetasIn' sg v - ConP c _ args -> namesAndMetasIn' sg (c, args) + 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) @@ -372,6 +372,9 @@ newtype PSyn = PSyn A.PatternSynDefn instance NamesIn PSyn where 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 namesAndMetasIn' sg = \case diff --git a/src/full/Agda/Syntax/Parser.hs b/src/full/Agda/Syntax/Parser.hs --- a/src/full/Agda/Syntax/Parser.hs +++ b/src/full/Agda/Syntax/Parser.hs @@ -149,11 +149,11 @@ forM_ (map fst overlaps) $ \c -> warning $ OverlappingTokensWarning { warnRange = getRange c } - (, coh) <$> (return $ forMaybe terms $ \case - Left t -> Just t - Right (Layer Comment interval s) -> Just $ TokTeX (interval, s) - Right (Layer Markup interval s) -> Just $ TokMarkup (interval, s) - Right (Layer Code _ _) -> Nothing) + return . (,coh) . forMaybe terms $ \case + Left t -> Just t + Right (Layer Comment interval s) -> Just $ TokTeX (interval, s) + Right (Layer Markup interval s) -> Just $ TokMarkup (interval, s) + Right (Layer Code _ _) -> Nothing parseLiterateFile diff --git a/src/full/Agda/Syntax/Parser/Helpers.hs b/src/full/Agda/Syntax/Parser/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/Parser/Helpers.hs @@ -0,0 +1,658 @@ +-- | Utility functions used in the Happy parser. + +module Agda.Syntax.Parser.Helpers where + +import Prelude hiding (null) + +import Control.Applicative ( (<|>) ) +import Control.Monad +import Control.Monad.State + +import Data.Bifunctor (first, second) +import Data.Char +import qualified Data.List as List +import Data.Maybe +import Data.Semigroup ((<>), sconcat) +import qualified Data.Traversable as T + +import Agda.Syntax.Position +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 ) +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. + +mkName :: (Interval, String) -> Parser Name +mkName (i, s) = do + let xs = C.stringNameParts s + mapM_ isValidId xs + unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores" + return $ Name (getRange i) InScope xs + where + isValidId Hole = return () + isValidId (Id y) = do + let x = rawNameToString y + err = "in the name " ++ s ++ ", the part " ++ x ++ " is not valid" + case parse defaultParseFlags [0] (lexer return) x of + ParseOk _ TokId{} -> return () + ParseFailed{} -> parseError err + ParseOk _ TokEOF{} -> parseError err + ParseOk _ t -> parseError . ((err ++ " because it is ") ++) $ case t of + TokQId{} -> __IMPOSSIBLE__ -- "qualified" + TokKeyword{} -> "a keyword" + TokLiteral{} -> "a literal" + TokSymbol s _ -> case s of + SymDot -> __IMPOSSIBLE__ -- "reserved" + SymSemi -> "used to separate declarations" + SymVirtualSemi -> __IMPOSSIBLE__ + SymBar -> "used for with-arguments" + SymColon -> "part of declaration syntax" + SymArrow -> "the function arrow" + SymEqual -> "part of declaration syntax" + SymLambda -> "used for lambda-abstraction" + SymUnderscore -> "used for anonymous identifiers" + SymQuestionMark -> "a meta variable" + SymAs -> "used for as-patterns" + SymOpenParen -> "used to parenthesize expressions" + SymCloseParen -> "used to parenthesize expressions" + SymOpenIdiomBracket -> "an idiom bracket" + SymCloseIdiomBracket -> "an idiom bracket" + 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 -> __IMPOSSIBLE__ -- "used for pragmas" + SymClosePragma -> __IMPOSSIBLE__ -- "used for pragmas" + SymEllipsis -> "used for function clauses" + SymDotDot -> __IMPOSSIBLE__ -- "a modality" + SymEndComment -> "the end-of-comment brace" + TokString{} -> __IMPOSSIBLE__ + TokTeX{} -> __IMPOSSIBLE__ -- used by the LaTeX backend only + TokMarkup{} -> __IMPOSSIBLE__ -- ditto + TokComment{} -> __IMPOSSIBLE__ + TokDummy{} -> __IMPOSSIBLE__ + + -- we know that there are no two Ids in a row + alternating (Hole :| Hole : _) = False + alternating (_ :| x : xs) = alternating $ x :| xs + alternating (_ :| []) = True + +-- | Create a qualified name from a list of strings +mkQName :: [(Interval, String)] -> Parser QName +mkQName ss = do + xs <- mapM mkName ss + return $ foldr Qual (QName $ last xs) (init xs) + +mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> NamedArg Binder +mkDomainFree_ f p n = f $ defaultNamedArg $ Binder p $ mkBoundName_ n + +mkRString :: (Interval, String) -> RString +mkRString (i, s) = Ranged (getRange i) s + +-- | Create a qualified name from a string (used in pragmas). +-- Range of each name component is range of whole string. +-- TODO: precise ranges! + +pragmaQName :: (Interval, String) -> Parser QName +pragmaQName (r, s) = do + let ss = chopWhen (== '.') s + mkQName $ map (r,) ss + +mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName) +mkNamedArg x y = do + lbl <- case x of + Nothing -> return $ Just $ WithOrigin UserWritten $ unranged "_" + Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x + _ -> parseError "expected unqualified variable name" + var <- case y of + Left (QName y) -> return $ mkBoundName y noFixity' + Right r -> return $ mkBoundName (noName r) noFixity' + _ -> parseError "expected unqualified variable name" + return $ defaultArg $ Named lbl var + +-- | Polarity parser. + +polarity :: (Interval, String) -> Parser (Range, Occurrence) +polarity (i, s) = + case s of + "_" -> ret Unused + "++" -> ret StrictPos + "+" -> ret JustPos + "-" -> ret JustNeg + "*" -> ret Mixed + _ -> parseError $ "Not a valid polarity: " ++ s + where + ret x = return (getRange i, x) + +recoverLayout :: [(Interval, String)] -> String +recoverLayout [] = "" +recoverLayout xs@((i, _) : _) = go (iStart i) xs + where + c0 = posCol (iStart i) + + go cur [] = "" + go cur ((i, s) : xs) = padding cur (iStart i) ++ s ++ go (iEnd i) xs + + padding Pn{ posLine = l1, posCol = c1 } Pn{ posLine = l2, posCol = c2 } + | l1 < l2 = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' ' + | l1 == l2 = List.genericReplicate (c2 - c1) ' ' + | 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" + QuantityAttribute q -> maybe (unsup "Linearity") (return . Just) $ erasedFromQuantity q + where + unsup s = do + parseWarning $ UnsupportedAttribute (attrRange a) (Just s) + return Nothing + +-- | Constructs extended lambdas. + +extLam + :: Range -- ^ The range of the lambda symbol and @where@ or + -- the braces. + -> [Attr] -- ^ The attributes in reverse order. + -> List1 LamClause -- ^ The clauses in reverse order. + -> Parser Expr +extLam symbolRange attrs cs = do + e <- onlyErased attrs + let cs' = List1.reverse cs + return $ ExtendedLam (getRange (symbolRange, e, cs')) e cs' + +-- | Constructs extended or absurd lambdas. + +extOrAbsLam + :: Range -- ^ The range of the lambda symbol. + -> [Attr] -- ^ The attributes, in reverse order. + -> Either ([LamBinding], Hiding) (List1 Expr) + -> Parser Expr +extOrAbsLam lambdaRange attrs cs = case cs of + Right es -> do + -- It is of the form @\ { p1 ... () }@. + e <- onlyErased attrs + cl <- mkAbsurdLamClause False es + return $ ExtendedLam (getRange (lambdaRange, e, es)) e $ singleton cl + Left (bs, h) -> do + mapM_ (\a -> parseWarning $ + UnsupportedAttribute (attrRange a) Nothing) + (reverse attrs) + List1.ifNull bs + {-then-} (return $ AbsurdLam r h) + {-else-} $ \ bs -> return $ Lam r bs (AbsurdLam r h) + where + r = fuseRange lambdaRange bs + +-- | Interpret an expression as a list of names and (not parsed yet) as-patterns + +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 (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) UserWritten UnknownFVs (Annotation IsNotLock) -> + return $ WithHiding h n + + -- Error cases: + ArgInfo _ _ _ _ (Annotation (IsLock _)) -> + abort $ noAnn "Lock" + + ArgInfo h (Modality r q c) _ _ _ + | not (isRelevant r) -> + abort "Arguments to pattern synonyms must be relevant" + | not (isQuantityω q) -> + abort $ noAnn "Quantity" + | 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 + :: Bool -- ^ Catch-all? + -> [Expr] -- ^ Possibly empty list of patterns. + -> RHS + -> Parser LamClause +mkLamClause catchAll es rhs = mapM exprToPattern es <&> \ ps -> + LamClause{ lamLHS = ps, lamRHS = rhs, lamCatchAll = catchAll } + +mkAbsurdLamClause :: Bool -> List1 Expr -> Parser LamClause +mkAbsurdLamClause catchAll es = mkLamClause catchAll (List1.toList es) AbsurdRHS + +{- RHS or type signature -} + +data RHSOrTypeSigs + = JustRHS RHS + | TypeSigsRHS Expr + deriving Show + +patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name)) +patternToNames = \case + IdentP _ (QName i) -> return $ singleton $ (defaultArgInfo, i) + WildP r -> return $ singleton $ (defaultArgInfo, C.noName r) + DotP _ (Ident (QName i)) -> return $ singleton $ (setRelevance Irrelevant defaultArgInfo, i) + RawAppP _ ps -> sconcat . List2.toList1 <$> mapM patternToNames ps + p -> parseError $ + "Illegal name in type signature: " ++ prettyShow p + +funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS) + -> [Either RewriteEqn (List1 (Named Name Expr))] + -> RHSOrTypeSigs + -> WhereClause -> Parser (List1 Declaration) +funClauseOrTypeSigs attrs lhs' with mrhs wh = do + (rs , es) <- buildWithBlock with + let lhs = lhs' rs (map (fmap observeModifiers) es) + -- traceShowM lhs + case mrhs of + JustRHS rhs -> do + unless (null attrs) $ parseErrorRange attrs $ "A function clause cannot have attributes" + return $ singleton $ FunClause lhs rhs wh False + TypeSigsRHS e -> case wh of + NoWhere -> case lhs of + LHS p _ _ | hasEllipsis p -> parseError "The ellipsis ... cannot have a type signature" + LHS _ _ (_:_) -> parseError "Illegal: with in type signature" + LHS _ (_:_) _ -> parseError "Illegal: rewrite in type signature" + LHS p _ _ | hasWithPatterns p -> parseError "Illegal: with patterns in type signature" + LHS p [] [] -> forMM (patternToNames p) $ \ (info, x) -> do + info <- applyAttrs attrs info + return $ typeSig info (getTacticAttr attrs) x e + _ -> parseError "A type signature cannot have a where clause" + +typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration +typeSig i tac n e = TypeSig i tac n (Generalized e) + +------------------------------------------------------------------------ +-- * Attributes + +-- | Parsed attribute. + +data Attr = Attr + { attrRange :: Range -- ^ Range includes the @. + , attrName :: String -- ^ Concrete, user written attribute for error reporting. + , theAttr :: Attribute -- ^ Parsed attribute. + } + +instance HasRange Attr where + getRange = attrRange + +instance SetRange Attr where + setRange r (Attr _ x a) = Attr r x a + +-- | Parse an attribute. +toAttribute :: Range -> Expr -> Parser Attr +toAttribute r e = do + attr <- maybe failure (return . Attr r s) $ exprToAttribute e + modify' (\ st -> st{ parseAttributes = (theAttr attr, r, s) : parseAttributes st }) + return attr + where + s = prettyShow e + failure = parseErrorRange e $ "Unknown attribute: " ++ s + +-- | 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 :: List1 Attr -> NamedArg Binder -> NamedArg Binder +setTacticAttr as = updateNamedArg $ fmap $ \ b -> + case getTacticAttr $ List1.toList 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: " ++ attrName a + +-- | Report attributes as conflicting (e.g., with each other). +-- Precondition: List not emtpy. +errorConflictingAttributes :: [Attr] -> Parser a +errorConflictingAttributes [a] = errorConflictingAttribute a +errorConflictingAttributes as = parseErrorRange as $ + "Conflicting attributes: " ++ unwords (map attrName as) diff --git a/src/full/Agda/Syntax/Parser/LexActions.hs b/src/full/Agda/Syntax/Parser/LexActions.hs --- a/src/full/Agda/Syntax/Parser/LexActions.hs +++ b/src/full/Agda/Syntax/Parser/LexActions.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wunused-imports #-} {-| This module contains the building blocks used to construct the lexer. @@ -24,7 +26,9 @@ import Data.Bifunctor import Data.Char +#if !MIN_VERSION_base(4,20,0) import Data.Foldable (foldl') +#endif import Data.Maybe import Agda.Syntax.Common (pattern Ranged) diff --git a/src/full/Agda/Syntax/Parser/Lexer.x b/src/full/Agda/Syntax/Parser/Lexer.x --- a/src/full/Agda/Syntax/Parser/Lexer.x +++ b/src/full/Agda/Syntax/Parser/Lexer.x @@ -88,7 +88,9 @@ "ETA" { keyword KwETA } "IMPOSSIBLE" { keyword KwIMPOSSIBLE } "INJECTIVE" { keyword KwINJECTIVE } + "INJECTIVE_FOR_INFERENCE" { keyword KwINJECTIVE_FOR_INFERENCE } "INLINE" { keyword KwINLINE } + "INCOHERENT" { keyword KwINCOHERENT } "NOINLINE" { keyword KwNOINLINE } "NOT_PROJECTION_LIKE" { keyword KwNOT_PROJECTION_LIKE } "LINE" { keyword KwLINE } @@ -100,6 +102,9 @@ "NON_TERMINATING" { keyword KwNON_TERMINATING } "OPTIONS" { keyword KwOPTIONS } "POLARITY" { keyword KwPOLARITY } + "OVERLAPPABLE" { keyword KwOVERLAPPABLE } + "OVERLAPPING" { keyword KwOVERLAPPING } + "OVERLAPS" { keyword KwOVERLAPS } "REWRITE" { keyword KwREWRITE } "STATIC" { keyword KwSTATIC } "TERMINATING" { keyword KwTERMINATING } diff --git a/src/full/Agda/Syntax/Parser/Monad.hs b/src/full/Agda/Syntax/Parser/Monad.hs --- a/src/full/Agda/Syntax/Parser/Monad.hs +++ b/src/full/Agda/Syntax/Parser/Monad.hs @@ -45,6 +45,7 @@ import Agda.Syntax.Position import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ) ) +import Agda.Utils.IO ( showIOException ) import Agda.Utils.List ( tailWithDefault ) import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Syntax.Common.Pretty @@ -239,7 +240,7 @@ ] pretty ReadFileError{errPath,errIOError} = vcat [ "Cannot read file" <+> pretty errPath - , "Error:" <+> text (displayException errIOError) + , "Error:" <+> text (showIOException errIOError) ] instance HasRange ParseError where diff --git a/src/full/Agda/Syntax/Parser/Parser.y b/src/full/Agda/Syntax/Parser/Parser.y --- a/src/full/Agda/Syntax/Parser/Parser.y +++ b/src/full/Agda/Syntax/Parser/Parser.y @@ -24,7 +24,6 @@ , exprWhereParser , tokensParser , holeContentParser - , splitOnDots -- only used by the internal test-suite ) where import Prelude hiding ( null ) @@ -43,6 +42,7 @@ 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 @@ -162,7 +162,9 @@ '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 $$ } @@ -174,6 +176,9 @@ '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 $$ } @@ -293,7 +298,9 @@ | '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 } @@ -304,6 +311,9 @@ | '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 } @@ -400,7 +410,6 @@ } } - {-------------------------------------------------------------------------- Names --------------------------------------------------------------------------} @@ -597,6 +606,9 @@ PragmaQNames :: { [QName] } PragmaQNames : Strings {% mapM pragmaQName $1 } +PragmaQNames1 :: { [QName] } +PragmaQNames1 : PragmaQName PragmaQNames { $1:$2 } + {-------------------------------------------------------------------------- Expressions (terms and types) --------------------------------------------------------------------------} @@ -1025,7 +1037,7 @@ | {- empty -} { mempty } ImportDirective1 :: { ImportDirective } - : 'public' { defaultImportDir { importDirRange = getRange $1, publicOpen = Just (getRange $1) } } + : '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 } } @@ -1093,19 +1105,11 @@ LHS :: { [RewriteEqn] -> [WithExpr] -> LHS } LHS : Expr1 {% exprToLHS $1 } -WithClause :: { [Either RewriteEqn (List1 (Named Name Expr))] } -WithClause - : 'with' WithExprs WithClause - {% fmap (++ $3) (buildWithStmt $2) } - | 'rewrite' UnnamedWithExprs WithClause - { Left (Rewrite $ fmap ((),) $2) : $3 } - | {- empty -} { [] } - -- Parsing either an expression @e@ or a @(rewrite | with p <-) e1 | ... | en@. HoleContent :: { HoleContent } HoleContent : Expr { HoleContentExpr $1 } - | WithClause + | WHS {% fmap HoleContentRewrite $ forM $1 $ \case Left r -> pure r Right{} -> parseError "Cannot declare a 'with' abstraction from inside a hole." @@ -1200,8 +1204,11 @@ WHS :: { [Either RewriteEqn (List1 (Named Name Expr))] } WHS : {- empty -} { [] } - | 'with' WithExprs WithClause {% fmap (++ $3) (buildWithStmt $2) } - | 'rewrite' UnnamedWithExprs WithClause { Left (Rewrite $ fmap ((),) $2) : $3 } + | '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 @@ -1271,12 +1278,12 @@ Constructor :: { Declaration } Constructor : 'data' '_' 'where' Declarations0 - { LoneConstructor (getRange ($1,$4)) $4 } + { 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 (getRange $1)) } + | 'instance' vopen 'constructor' Id close { ($4, InstanceDef (kwRange $1)) } -- Fixity declarations. @@ -1290,60 +1297,53 @@ Fields : 'field' ArgTypeSignaturesOrEmpty { let inst i = case getHiding i of - Instance _ -> InstanceDef noRange -- no @instance@ keyword here + 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 (fuseRange $1 $2) $ map toField $2 } - -- | 'field' ModalArgTypeSignatures - -- { let - -- inst i = case getHiding i of - -- Instance _ -> InstanceDef - -- _ -> NotInstanceDef - -- toField (Arg info (TypeSig info' x t)) = FieldSig (inst info') x (Arg info t) - -- in Field (fuseRange $1 $2) $ map toField $2 } + 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 (fuseRange $1 $2) (map toGeneralize $2) } + in Generalize (kwRange $1) (map toGeneralize $2) } -- Mutually recursive declarations. Mutual :: { Declaration } -Mutual : 'mutual' Declarations0 { Mutual (fuseRange $1 $2) $2 } - | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (getRange ($1,$2,$3)) $3 } +Mutual : 'mutual' Declarations0 { Mutual (kwRange $1) $2 } + | 'interleaved' 'mutual' Declarations0 { InterleavedMutual (kwRange ($1,$2)) $3 } -- Abstract declarations. Abstract :: { Declaration } -Abstract : 'abstract' Declarations0 { Abstract (fuseRange $1 $2) $2 } +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 (fuseRange $1 $2) UserWritten $2 } +Private : 'private' Declarations0 { Private (kwRange $1) UserWritten $2 } -- Instance declarations. Instance :: { Declaration } -Instance : 'instance' Declarations0 { InstanceB (getRange $1) $2 } +Instance : 'instance' Declarations0 { InstanceB (kwRange $1) $2 } -- Macro declarations. Macro :: { Declaration } -Macro : 'macro' Declarations0 { Macro (fuseRange $1 $2) $2 } +Macro : 'macro' Declarations0 { Macro (kwRange $1) $2 } -- Postulates. Postulate :: { Declaration } -Postulate : 'postulate' Declarations0 { Postulate (fuseRange $1 $2) $2 } +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 (fuseRange $1 $2) (map setArg $2) } + Primitive (kwRange $1) (map setArg $2) } -- Unquoting declarations. UnquoteDecl :: { Declaration } @@ -1371,7 +1371,7 @@ return (PatternSyn (getRange ($1,$2,$3,$4,$5)) $2 $3 p) } -PatternSynArgs :: { [Arg Name] } +PatternSynArgs :: { [WithHiding Name] } PatternSynArgs : DomainFreeBindings {% patternSynArgs $1 } -- The list should be reversed. @@ -1441,9 +1441,9 @@ -- TODO: Don't use (insecure) hashes in this way. ; fresh = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show unique ; fresh' = Name mr NotInScope $ singleton $ Id $ stringToRawName $ ".#" ++ prettyShow m ++ "-" ++ show (unique + 1) - ; impStm asR = Import noRange m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir + ; impStm asR = Import (getRange ($2, $3)) m (Just (AsName (Right fresh) asR)) DontOpen defaultImportDir ; appStm m' es = - Private r Inserted + Private empty Inserted [ ModuleMacro r defaultErased m' (SectionApp (getRange es) [] (rawApp (Ident (QName fresh) :| es))) @@ -1490,7 +1490,7 @@ } in singleton $ case es of { [] -> Open r m dir - ; _ -> Private r Inserted + ; _ -> Private empty Inserted [ ModuleMacro r defaultErased (noName $ beginningOf $ getRange m) (SectionApp (getRange (m , es)) [] @@ -1501,7 +1501,7 @@ } | 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective { let r = getRange $2 in singleton $ - Private r Inserted + Private empty Inserted [ ModuleMacro r defaultErased (noName $ beginningOf $ getRange $2) (RecordModuleInstance r $2) DoOpen $6 ] @@ -1571,6 +1571,7 @@ | ForeignPragma { $1 } | StaticPragma { $1 } | InjectivePragma { $1 } + | InjectiveForInferencePragma { $1 } | InlinePragma { $1 } | NoInlinePragma { $1 } | ImpossiblePragma { $1 } @@ -1588,6 +1589,7 @@ | 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. @@ -1643,11 +1645,23 @@ : '{-#' '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 '#-}' @@ -1769,12 +1783,11 @@ | {- empty -} { [] } -- Record declarations, including an optional record constructor name. -RecordDeclarations :: { (RecordDirectives, [Declaration]) } +RecordDeclarations :: { ([RecordDirective], [Declaration]) } RecordDeclarations - : vopen RecordDirectives close {% verifyRecordDirectives $2 <&> (,[]) } - | vopen RecordDirectives semi Declarations1 close {% verifyRecordDirectives $2 <&> (, List1.toList $4) } - | vopen Declarations1 close { (emptyRecordDirectives, List1.toList $2) } - + : vopen RecordDirectives close { (reverse $2, []) } + | vopen RecordDirectives semi Declarations1 close { (reverse $2, List1.toList $4) } + | vopen Declarations1 close { ([], List1.toList $2) } RecordDirectives :: { [RecordDirective] } RecordDirectives @@ -1812,10 +1825,10 @@ | 'coinductive' { Ranged (getRange $1) CoInductive } Opaque :: { Declaration } - : 'opaque' Declarations0 { Opaque (getRange ($1, $2)) $2 } + : 'opaque' Declarations0 { Opaque (kwRange $1) $2 } Unfolding :: { Declaration } - : 'unfolding' UnfoldingNames { Unfolding (getRange ($1, $2)) $2 } + : 'unfolding' UnfoldingNames { Unfolding (kwRange $1) $2 } UnfoldingNames :: { [QName] } UnfoldingNames @@ -1862,6 +1875,13 @@ -- | Parse a module. moduleParser :: Parser Module +-- | Parse a display pragma. +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 #-}." {-------------------------------------------------------------------------- Happy stuff @@ -1876,651 +1896,8 @@ Utility functions --------------------------------------------------------------------------} --- | Grab leading OPTIONS pragmas. -takeOptionsPragmas :: [Declaration] -> Module -takeOptionsPragmas = uncurry Mod . spanJust (\ d -> case d of - Pragma p@OptionsPragma{} -> Just p - _ -> Nothing) - --- | Insert a top-level module if there is none. --- Also fix-up for the case the declarations in the top-level module --- are not indented (this is allowed as a special case). -figureOutTopLevelModule :: [Declaration] -> [Declaration] -figureOutTopLevelModule ds = - case spanAllowedBeforeModule ds of - -- Andreas 2016-02-01, issue #1388. - -- We need to distinguish two additional cases. - - -- Case 1: Regular file layout: imports followed by one module. Nothing to do. - (ds0, [ Module{} ]) -> ds - - -- Case 2: The declarations in the module are not indented. - -- This is allowed for the top level module, and thus rectified here. - (ds0, Module r 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. - -mkName :: (Interval, String) -> Parser Name -mkName (i, s) = do - let xs = C.stringNameParts s - mapM_ isValidId xs - unless (alternating xs) $ parseError $ "a name cannot contain two consecutive underscores" - return $ Name (getRange i) InScope xs - where - isValidId Hole = return () - isValidId (Id y) = do - let x = rawNameToString y - err = "in the name " ++ s ++ ", the part " ++ x ++ " is not valid" - case parse defaultParseFlags [0] (lexer return) x of - ParseOk _ TokId{} -> return () - ParseFailed{} -> parseError err - ParseOk _ TokEOF{} -> parseError err - ParseOk _ t -> parseError . ((err ++ " because it is ") ++) $ case t of - TokId{} -> __IMPOSSIBLE__ - TokQId{} -> __IMPOSSIBLE__ -- "qualified" - TokKeyword{} -> "a keyword" - TokLiteral{} -> "a literal" - TokSymbol s _ -> case s of - SymDot -> __IMPOSSIBLE__ -- "reserved" - SymSemi -> "used to separate declarations" - SymVirtualSemi -> __IMPOSSIBLE__ - SymBar -> "used for with-arguments" - SymColon -> "part of declaration syntax" - SymArrow -> "the function arrow" - SymEqual -> "part of declaration syntax" - SymLambda -> "used for lambda-abstraction" - SymUnderscore -> "used for anonymous identifiers" - SymQuestionMark -> "a meta variable" - SymAs -> "used for as-patterns" - SymOpenParen -> "used to parenthesize expressions" - SymCloseParen -> "used to parenthesize expressions" - SymOpenIdiomBracket -> "an idiom bracket" - SymCloseIdiomBracket -> "an idiom bracket" - SymDoubleOpenBrace -> "used for instance arguments" - SymDoubleCloseBrace -> "used for instance arguments" - SymOpenBrace -> "used for hidden arguments" - SymCloseBrace -> "used for hidden arguments" - SymOpenVirtualBrace -> __IMPOSSIBLE__ - SymCloseVirtualBrace -> __IMPOSSIBLE__ - SymOpenPragma -> __IMPOSSIBLE__ -- "used for pragmas" - SymClosePragma -> __IMPOSSIBLE__ -- "used for pragmas" - SymEllipsis -> "used for function clauses" - SymDotDot -> __IMPOSSIBLE__ -- "a modality" - SymEndComment -> "the end-of-comment brace" - TokString{} -> __IMPOSSIBLE__ - TokTeX{} -> __IMPOSSIBLE__ -- used by the LaTeX backend only - TokMarkup{} -> __IMPOSSIBLE__ -- ditto - TokComment{} -> __IMPOSSIBLE__ - TokDummy{} -> __IMPOSSIBLE__ - TokEOF{} -> __IMPOSSIBLE__ - - -- we know that there are no two Ids in a row - alternating (Hole :| Hole : _) = False - alternating (_ :| x : xs) = alternating $ x :| xs - alternating (_ :| []) = True - --- | Create a qualified name from a list of strings -mkQName :: [(Interval, String)] -> Parser QName -mkQName ss = do - xs <- mapM mkName ss - return $ foldr Qual (QName $ last xs) (init xs) - -mkDomainFree_ :: (NamedArg Binder -> NamedArg Binder) -> Maybe Pattern -> Name -> NamedArg Binder -mkDomainFree_ f p n = f $ defaultNamedArg $ Binder p $ mkBoundName_ n - -mkRString :: (Interval, String) -> RString -mkRString (i, s) = Ranged (getRange i) s - --- | Create a qualified name from a string (used in pragmas). --- Range of each name component is range of whole string. --- TODO: precise ranges! - -pragmaQName :: (Interval, String) -> Parser QName -pragmaQName (r, s) = do - let ss = chopWhen (== '.') s - mkQName $ map (r,) ss - -mkNamedArg :: Maybe QName -> Either QName Range -> Parser (NamedArg BoundName) -mkNamedArg x y = do - lbl <- case x of - Nothing -> return $ Just $ WithOrigin UserWritten $ unranged "_" - Just (QName x) -> return $ Just $ WithOrigin UserWritten $ Ranged (getRange x) $ prettyShow x - _ -> parseError "expected unqualified variable name" - var <- case y of - Left (QName y) -> return $ mkBoundName y noFixity' - Right r -> return $ mkBoundName (noName r) noFixity' - _ -> parseError "expected unqualified variable name" - return $ defaultArg $ Named lbl var - --- | Polarity parser. - -polarity :: (Interval, String) -> Parser (Range, Occurrence) -polarity (i, s) = - case s of - "_" -> ret Unused - "++" -> ret StrictPos - "+" -> ret JustPos - "-" -> ret JustNeg - "*" -> ret Mixed - _ -> parseError $ "Not a valid polarity: " ++ s - where - ret x = return (getRange i, x) - -recoverLayout :: [(Interval, String)] -> String -recoverLayout [] = "" -recoverLayout xs@((i, _) : _) = go (iStart i) xs - where - c0 = posCol (iStart i) - - go cur [] = "" - go cur ((i, s) : xs) = padding cur (iStart i) ++ s ++ go (iEnd i) xs - - padding Pn{ posLine = l1, posCol = c1 } Pn{ posLine = l2, posCol = c2 } - | l1 < l2 = List.genericReplicate (l2 - l1) '\n' ++ List.genericReplicate (max 0 (c2 - c0)) ' ' - | l1 == l2 = List.genericReplicate (c2 - c1) ' ' - -ensureUnqual :: QName -> Parser Name -ensureUnqual (QName x) = return x -ensureUnqual q@Qual{} = parseError' (rStart' $ getRange q) "Qualified name not allowed here" - --- | Match a particular name. -isName :: String -> (Interval, String) -> Parser () -isName s (_,s') - | s == s' = return () - | otherwise = parseError $ "expected " ++ s ++ ", found " ++ s' - --- Lambinds - --- | Result of parsing @LamBinds@. -data LamBinds' a = LamBinds - { lamBindings :: a -- ^ A number of domain-free or typed bindings or record patterns. - , absurdBinding :: Maybe Hiding -- ^ Followed by possibly a final absurd pattern. - } deriving (Functor) -type LamBinds = LamBinds' [LamBinding] - -mkAbsurdBinding :: Hiding -> LamBinds -mkAbsurdBinding = LamBinds [] . Just - -mkLamBinds :: a -> LamBinds' a -mkLamBinds bs = LamBinds bs Nothing - --- | Build a forall pi (forall x y z -> ...) -forallPi :: List1 LamBinding -> Expr -> Expr -forallPi bs e = Pi (fmap addType bs) e - --- | Converts lambda bindings to typed bindings. -addType :: LamBinding -> TypedBinding -addType (DomainFull b) = b -addType (DomainFree x) = TBind r (singleton x) $ Underscore r Nothing - where r = getRange x - --- | Returns the value of the first erasure attribute, if any, or else --- the default value of type 'Erased'. --- --- Raises warnings for all attributes except for erasure attributes, --- and for multiple erasure attributes. - -onlyErased - :: [Attr] -- ^ The attributes, in reverse order. - -> Parser Erased -onlyErased as = do - es <- catMaybes <$> mapM onlyErased' (reverse as) - case es of - [] -> return defaultErased - [e] -> return e - e : es -> do - parseWarning $ MultipleAttributes (getRange es) (Just "erasure") - return e - where - onlyErased' a = case theAttr a of - RelevanceAttribute{} -> unsup "Relevance" - CohesionAttribute{} -> unsup "Cohesion" - LockAttribute{} -> unsup "Lock" - TacticAttribute{} -> unsup "Tactic" - QuantityAttribute q -> maybe (unsup "Linearity") (return . Just) $ erasedFromQuantity q - where - unsup s = do - parseWarning $ UnsupportedAttribute (attrRange a) (Just s) - return Nothing - --- | Constructs extended lambdas. - -extLam - :: Range -- ^ The range of the lambda symbol and @where@ or - -- the braces. - -> [Attr] -- ^ The attributes in reverse order. - -> List1 LamClause -- ^ The clauses in reverse order. - -> Parser Expr -extLam symbolRange attrs cs = do - e <- onlyErased attrs - let cs' = List1.reverse cs - return $ ExtendedLam (getRange (symbolRange, e, cs')) e cs' - --- | Constructs extended or absurd lambdas. - -extOrAbsLam - :: Range -- ^ The range of the lambda symbol. - -> [Attr] -- ^ The attributes, in reverse order. - -> Either ([LamBinding], Hiding) (List1 Expr) - -> Parser Expr -extOrAbsLam lambdaRange attrs cs = case cs of - Right es -> do - -- It is of the form @\ { p1 ... () }@. - e <- onlyErased attrs - cl <- mkAbsurdLamClause False es - return $ ExtendedLam (getRange (lambdaRange, e, es)) e $ singleton cl - Left (bs, h) -> do - mapM_ (\a -> parseWarning $ - UnsupportedAttribute (attrRange a) Nothing) - (reverse attrs) - List1.ifNull bs - {-then-} (return $ AbsurdLam r h) - {-else-} $ \ bs -> return $ Lam r bs (AbsurdLam r h) - where - r = fuseRange lambdaRange bs - --- | Interpret an expression as a list of names and (not parsed yet) as-patterns - -exprAsTele :: Expr -> List1 Expr -exprAsTele (RawApp _ es) = List2.toList1 es -exprAsTele e = singleton e - -exprAsNamesAndPatterns :: Expr -> Maybe (List1 (Name, Maybe Expr)) -exprAsNamesAndPatterns = mapM exprAsNameAndPattern . exprAsTele - -exprAsNameAndPattern :: Expr -> Maybe (Name, Maybe Expr) -exprAsNameAndPattern (Ident (QName x)) = Just (x, Nothing) -exprAsNameAndPattern (Underscore r _) = Just (setRange r simpleHole, Nothing) -exprAsNameAndPattern (As _ n e) = Just (n, Just e) -exprAsNameAndPattern (Paren r e) = Just (setRange r simpleHole, Just e) -exprAsNameAndPattern _ = Nothing - --- interpret an expression as name or list of hidden / instance names -exprAsNameOrHiddenNames :: Expr -> Maybe (List1 (NamedArg (Name, Maybe Expr))) -exprAsNameOrHiddenNames = \case - HiddenArg _ (Named Nothing e) -> - fmap (hide . defaultNamedArg) <$> exprAsNamesAndPatterns e - InstanceArg _ (Named Nothing e) -> - fmap (makeInstance . defaultNamedArg) <$> exprAsNamesAndPatterns e - e -> - singleton . defaultNamedArg <$> exprAsNameAndPattern e - -boundNamesOrAbsurd :: List1 Expr -> Parser (Either (List1 (NamedArg Binder)) (List1 Expr)) -boundNamesOrAbsurd es - | any isAbsurd es = return $ Right es - | otherwise = - case mapM exprAsNameAndPattern es of - Nothing -> parseError $ "expected sequence of bound identifiers" - Just good -> fmap Left $ forM good $ \ (n, me) -> do - p <- traverse exprToPattern me - return (defaultNamedArg (Binder p (mkBoundName_ n))) - - where - - isAbsurd :: Expr -> Bool - isAbsurd (Absurd _) = True - isAbsurd (HiddenArg _ (Named _ e)) = isAbsurd e - isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e - isAbsurd (Paren _ e) = isAbsurd e - isAbsurd (As _ _ e) = isAbsurd e - isAbsurd (RawApp _ es) = any isAbsurd es - isAbsurd _ = False - --- | Match a pattern-matching "assignment" statement @p <- e@ -exprToAssignment :: Expr -> Parser (Maybe (Pattern, Range, Expr)) -exprToAssignment e@(RawApp r es) - | (es1, arr : es2) <- List2.break isLeftArrow es = - case filter isLeftArrow es2 of - arr : _ -> parseError' (rStart' $ getRange arr) $ "Unexpected " ++ prettyShow arr - [] -> - -- Andreas, 2021-05-06, issue #5365 - -- Handle pathological cases like @do <-@ and @do x <-@. - case (es1, es2) of - (e1:rest1, e2:rest2) -> do - p <- exprToPattern $ rawApp $ e1 :| rest1 - pure $ Just (p, getRange arr, rawApp (e2 :| rest2)) - _ -> parseError' (rStart' $ getRange e) $ "Incomplete binding " ++ prettyShow e - where - isLeftArrow (Ident (QName (Name _ _ (Id arr :| [])))) = - arr `elem` ["<-", "\x2190"] -- \leftarrow [issue #5465, unicode might crash happy] - isLeftArrow _ = False -exprToAssignment _ = pure Nothing - --- | Build a with-block -buildWithBlock :: - [Either RewriteEqn (List1 (Named Name Expr))] -> - Parser ([RewriteEqn], [Named Name Expr]) -buildWithBlock rees = case groupByEither rees of - (Left rs : rest) -> (List1.toList rs,) <$> finalWith rest - rest -> ([],) <$> finalWith rest - - where - - finalWith :: (HasRange a, HasRange b) => - [Either (List1 a) (List1 (List1 b))] -> Parser [b] - finalWith [] = pure $ [] - finalWith [Right ees] = pure $ List1.toList $ sconcat ees - finalWith (Right{} : tl) = parseError' (rStart' $ getRange tl) - "Cannot use rewrite / pattern-matching with after a with-abstraction." - --- | Build a with-statement -buildWithStmt :: List1 (Named Name Expr) -> - Parser [Either RewriteEqn (List1 (Named Name Expr))] -buildWithStmt nes = do - ws <- mapM buildSingleWithStmt (List1.toList nes) - let rws = groupByEither ws - pure $ map (first (Invert ())) rws - -buildSingleWithStmt :: - Named Name Expr -> - Parser (Either (Named Name (Pattern, Expr)) (Named Name Expr)) -buildSingleWithStmt e = do - mpatexpr <- exprToAssignment (namedThing e) - pure $ case mpatexpr of - Just (pat, _, expr) -> Left ((pat, expr) <$ e) - Nothing -> Right e - -fromWithApp :: Expr -> List1 Expr -fromWithApp = \case - WithApp _ e es -> e :| es - e -> singleton e - --- | Build a do-statement -defaultBuildDoStmt :: Expr -> [LamClause] -> Parser DoStmt -defaultBuildDoStmt e (_ : _) = parseError' (rStart' $ getRange e) "Only pattern matching do-statements can have where clauses." -defaultBuildDoStmt e [] = pure $ DoThen e - -buildDoStmt :: Expr -> [LamClause] -> Parser DoStmt -buildDoStmt (Let r ds Nothing) [] = return $ DoLet r ds -buildDoStmt e@(RawApp r _) cs = do - mpatexpr <- exprToAssignment e - case mpatexpr of - Just (pat, r, expr) -> pure $ DoBind r pat expr cs - Nothing -> defaultBuildDoStmt e cs -buildDoStmt e cs = defaultBuildDoStmt e cs - - --- | Extract record directives -extractRecordDirectives :: [Declaration] -> Parser (RecordDirectives, [Declaration]) -extractRecordDirectives ds = do - let (dirs, rest) = spanJust isRecordDirective ds - dir <- verifyRecordDirectives dirs - pure (dir, rest) - --- | Check for duplicate record directives. -verifyRecordDirectives :: [RecordDirective] -> Parser RecordDirectives -verifyRecordDirectives ds - | null rs = return (RecordDirectives (listToMaybe is) (listToMaybe es) (listToMaybe ps) (listToMaybe cs)) - -- Here, all the lists is, es, cs, ps are at most singletons. - | otherwise = parseErrorRange (head rs) $ unlines $ "Repeated record directives at:" : map prettyShow rs - where - errorFromList [] = [] - errorFromList [x] = [] - errorFromList xs = map getRange xs - rs = List.sort $ concat [ errorFromList is, errorFromList es', errorFromList cs, errorFromList ps ] - es = map rangedThing es' - is = [ i | Induction i <- ds ] - es' = [ e | Eta e <- ds ] - cs = [ (c, i) | Constructor c i <- ds ] - ps = [ r | PatternOrCopattern r <- ds ] - - --- | Breaks up a string into substrings. Returns every maximal --- subsequence of zero or more characters distinct from @'.'@. +-- Utilites have been moved to Agda.Syntax.Parser.Helpers. -- --- > splitOnDots "" == [""] --- > splitOnDots "foo.bar" == ["foo", "bar"] --- > splitOnDots ".foo.bar" == ["", "foo", "bar"] --- > splitOnDots "foo.bar." == ["foo", "bar", ""] --- > splitOnDots "foo..bar" == ["foo", "", "bar"] -splitOnDots :: String -> [String] -splitOnDots "" = [""] -splitOnDots ('.' : s) = [] : splitOnDots s -splitOnDots (c : s) = case splitOnDots s of - p : ps -> (c : p) : ps - - --- | Returns 'True' iff the name is a valid Haskell (hierarchical) --- module name. -validHaskellModuleName :: String -> Bool -validHaskellModuleName = all ok . splitOnDots - where - -- Checks if a dot-less module name is well-formed. - ok :: String -> Bool - ok [] = False - ok (c : s) = - isUpper c && - all (\c -> isLower c || c == '_' || - isUpper c || - generalCategory c == DecimalNumber || - c == '\'') - s - -{-------------------------------------------------------------------------- - Patterns - --------------------------------------------------------------------------} - --- | Turn an expression into a left hand side. -exprToLHS :: Expr -> Parser ([RewriteEqn] -> [WithExpr] -> LHS) -exprToLHS e = LHS <$> exprToPattern e - --- | Turn an expression into a pattern. Fails if the expression is not a --- valid pattern. -exprToPattern :: Expr -> Parser Pattern -exprToPattern e = case C.isPattern e of - Nothing -> parseErrorRange e $ "Not a valid pattern: " ++ prettyShow e - Just p -> pure p - -opAppExprToPattern :: OpApp Expr -> Parser Pattern -opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern" -opAppExprToPattern (Ordinary e) = exprToPattern e - --- | Turn an expression into a name. Fails if the expression is not a --- valid identifier. -exprToName :: Expr -> Parser Name -exprToName (Ident (QName x)) = return x -exprToName e = parseErrorRange e $ "Not a valid identifier: " ++ prettyShow e - -isEqual :: Expr -> Maybe (Expr, Expr) -isEqual = \case - Equal _ a b -> Just (a, b) - _ -> Nothing - --- | When given expression is @e1 = e2@, turn it into a named expression. --- Call this inside an implicit argument @{e}@ or @{{e}}@, where --- an equality must be a named argument (rather than a cubical partial match). -maybeNamed :: Expr -> Parser (Named_ Expr) -maybeNamed e = - case isEqual e of - Nothing -> return $ unnamed e - Just (e1, e2) -> do - let succeed x = return $ named (WithOrigin UserWritten $ Ranged (getRange e1) x) e2 - case e1 of - Ident (QName x) -> succeed $ nameToRawName x - -- We could have the following, but names of arguments cannot be _. - -- Underscore{} -> succeed $ "_" - _ -> parseErrorRange e $ "Not a valid named argument: " ++ prettyShow e - -patternSynArgs :: [NamedArg Binder] -> Parser [Arg Name] -patternSynArgs = mapM pSynArg - where - pSynArg x - | let h = getHiding x, h `notElem` [Hidden, NotHidden] = - abort $ prettyShow h ++ " arguments not allowed to pattern synonyms" - | not (isRelevant x) = - abort "Arguments to pattern synonyms must be relevant" - | Just p <- binderPattern (namedArg x) = - abort "Arguments to pattern synonyms cannot be patterns themselves" - | otherwise = return $ fmap (boundName . binderName . namedThing) x - where - abort s = parseError $ - "Illegal pattern synonym argument " ++ prettyShow x ++ "\n" ++ - "(" ++ s ++ ".)" - -mkLamClause - :: Bool -- ^ Catch-all? - -> [Expr] -- ^ Possibly empty list of patterns. - -> RHS - -> Parser LamClause -mkLamClause catchAll es rhs = mapM exprToPattern es <&> \ ps -> - LamClause{ lamLHS = ps, lamRHS = rhs, lamCatchAll = catchAll } - -mkAbsurdLamClause :: Bool -> List1 Expr -> Parser LamClause -mkAbsurdLamClause catchAll es = mkLamClause catchAll (List1.toList es) AbsurdRHS - -parsePanic s = parseError $ "Internal parser error: " ++ s ++ ". Please report this as a bug." - -{- RHS or type signature -} - -data RHSOrTypeSigs - = JustRHS RHS - | TypeSigsRHS Expr - deriving Show - -patternToNames :: Pattern -> Parser (List1 (ArgInfo, Name)) -patternToNames = \case - IdentP _ (QName i) -> return $ singleton $ (defaultArgInfo, i) - WildP r -> return $ singleton $ (defaultArgInfo, C.noName r) - DotP _ (Ident (QName i)) -> return $ singleton $ (setRelevance Irrelevant defaultArgInfo, i) - RawAppP _ ps -> sconcat . List2.toList1 <$> mapM patternToNames ps - p -> parseError $ - "Illegal name in type signature: " ++ prettyShow p - -funClauseOrTypeSigs :: [Attr] -> ([RewriteEqn] -> [WithExpr] -> LHS) - -> [Either RewriteEqn (List1 (Named Name Expr))] - -> RHSOrTypeSigs - -> WhereClause -> Parser (List1 Declaration) -funClauseOrTypeSigs attrs lhs' with mrhs wh = do - (rs , es) <- buildWithBlock with - let lhs = lhs' rs (map (fmap observeModifiers) es) - -- traceShowM lhs - case mrhs of - JustRHS rhs -> do - unless (null attrs) $ parseErrorRange attrs $ "A function clause cannot have attributes" - return $ singleton $ FunClause lhs rhs wh False - TypeSigsRHS e -> case wh of - NoWhere -> case lhs of - LHS p _ _ | hasEllipsis p -> parseError "The ellipsis ... cannot have a type signature" - LHS _ _ (_:_) -> parseError "Illegal: with in type signature" - LHS _ (_:_) _ -> parseError "Illegal: rewrite in type signature" - LHS p _ _ | hasWithPatterns p -> parseError "Illegal: with patterns in type signature" - LHS p [] [] -> forMM (patternToNames p) $ \ (info, x) -> do - info <- applyAttrs attrs info - return $ typeSig info (getTacticAttr attrs) x e - _ -> parseError "A type signature cannot have a where clause" - -parseDisplayPragma :: Range -> Position -> String -> Parser Pragma -parseDisplayPragma r pos s = - case parsePosString pos defaultParseFlags [normal] funclauseParser s of - ParseOk s (FunClause (LHS lhs [] []) (RHS rhs) NoWhere ca :| []) | null (parseInp s) -> - return $ DisplayPragma r lhs rhs - _ -> parseError "Invalid DISPLAY pragma. Should have form {-# DISPLAY LHS = RHS #-}." - -typeSig :: ArgInfo -> TacticAttribute -> Name -> Expr -> Declaration -typeSig i tac n e = TypeSig i tac n (Generalized e) - --- * Attributes - --- | Parsed attribute. - -data Attr = Attr - { attrRange :: Range -- ^ Range includes the @. - , attrName :: String -- ^ Concrete, user written attribute for error reporting. - , theAttr :: Attribute -- ^ Parsed attribute. - } - -instance HasRange Attr where - getRange = attrRange - -instance SetRange Attr where - setRange r (Attr _ x a) = Attr r x a - --- | Parse an attribute. -toAttribute :: Range -> Expr -> Parser Attr -toAttribute r e = do - attr <- maybe failure (return . Attr r s) $ exprToAttribute e - modify' (\ st -> st{ parseAttributes = (theAttr attr, r, s) : parseAttributes st }) - return attr - where - s = prettyShow e - failure = parseErrorRange e $ "Unknown attribute: " ++ s - --- | 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 (isJust . isTacticAttribute) attrs - foldM (flip applyAttr) arg attrs - -applyAttrs1 :: LensAttribute a => List1 Attr -> a -> Parser a -applyAttrs1 = applyAttrs . List1.toList - --- | Set the tactic attribute of a binder -setTacticAttr :: List1 Attr -> NamedArg Binder -> NamedArg Binder -setTacticAttr as = updateNamedArg $ fmap $ \ b -> - case getTacticAttr $ List1.toList as of - Just t -> b { bnameTactic = Just t } - Nothing -> b - --- | Get the tactic attribute if present. -getTacticAttr :: [Attr] -> TacticAttribute -getTacticAttr as = - case tacticAttributes [ a | Attr _ _ a <- as ] of - [TacticAttribute e] -> Just e - [] -> Nothing - _ -> __IMPOSSIBLE__ - --- | Report a parse error if two attributes in the list are of the same kind, --- thus, present conflicting information. -checkForUniqueAttribute :: (Attribute -> Bool) -> [Attr] -> Parser () -checkForUniqueAttribute p attrs = do - let pAttrs = filter (p . theAttr) attrs - when (length pAttrs >= 2) $ - errorConflictingAttributes pAttrs - --- | Report an attribute as conflicting (e.g., with an already set value). -errorConflictingAttribute :: Attr -> Parser a -errorConflictingAttribute a = parseErrorRange a $ "Conflicting attribute: " ++ attrName a +-- Add Haskell functions used in the parser there, not here. --- | Report attributes as conflicting (e.g., with each other). --- Precondition: List not emtpy. -errorConflictingAttributes :: [Attr] -> Parser a -errorConflictingAttributes [a] = errorConflictingAttribute a -errorConflictingAttributes as = parseErrorRange as $ - "Conflicting attributes: " ++ unwords (map attrName as) } diff --git a/src/full/Agda/Syntax/Parser/Tokens.hs b/src/full/Agda/Syntax/Parser/Tokens.hs --- a/src/full/Agda/Syntax/Parser/Tokens.hs +++ b/src/full/Agda/Syntax/Parser/Tokens.hs @@ -24,7 +24,7 @@ | KwOpaque | KwUnfolding | KwOPTIONS | KwBUILTIN | KwLINE | KwFOREIGN | KwCOMPILE - | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINLINE | KwNOINLINE + | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINJECTIVE_FOR_INFERENCE | KwINLINE | KwNOINLINE | KwETA | KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING | KwNOT_PROJECTION_LIKE @@ -32,6 +32,7 @@ | KwWARNING_ON_USAGE | KwWARNING_ON_IMPORT | KwMEASURE | KwDISPLAY | KwREWRITE + | KwOVERLAPPABLE | KwOVERLAPPING | KwOVERLAPS | KwINCOHERENT | KwQuote | KwQuoteTerm | KwUnquote | KwUnquoteDecl | KwUnquoteDef | KwSyntax diff --git a/src/full/Agda/Syntax/Scope/Base.hs b/src/full/Agda/Syntax/Scope/Base.hs --- a/src/full/Agda/Syntax/Scope/Base.hs +++ b/src/full/Agda/Syntax/Scope/Base.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} {-| This module defines the notion of a scope and operations on scopes. -} @@ -86,7 +85,7 @@ localNameSpace PrivateAccess{} = PrivateNS nameSpaceAccess :: NameSpaceId -> Access -nameSpaceAccess PrivateNS = PrivateAccess Inserted +nameSpaceAccess PrivateNS = privateAccessInserted nameSpaceAccess _ = PublicAccess -- | Get a 'NameSpace' from 'Scope'. @@ -150,16 +149,23 @@ -- | For each bound variable, we want to know whether it was bound by a -- λ, Π, module telescope, pattern, or @let@. data BindingSource - = LambdaBound -- ^ @λ@ (currently also used for @Π@ and module parameters) - | PatternBound -- ^ @f ... =@ - | LetBound -- ^ @let ... in@ - | WithBound -- ^ @| ... in q@ + = 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@ deriving (Show, Eq, Generic) instance Pretty BindingSource where pretty = \case LambdaBound -> "local" - PatternBound -> "pattern" + PatternBound _ -> "pattern" LetBound -> "let-bound" WithBound -> "with-bound" @@ -195,7 +201,7 @@ -- | Treat patternBound variable as a module parameter patternToModuleBound :: LocalVar -> LocalVar patternToModuleBound x - | localBindingSource x == PatternBound = + | PatternBound _ <- localBindingSource x = x { localBindingSource = LambdaBound } | otherwise = x @@ -627,13 +633,41 @@ instance Null Scope where empty = emptyScope - null = __IMPOSSIBLE__ - -- TODO: define when needed, careful about scopeNameSpaces! + -- -- Use default implementation of null + -- null Scope{ scopeName, scopeParents, scopeNameSpaces, scopeImports, scopeDatatypeModule } = and + -- [ null scopeName + -- , null scopeParents + -- , null scopeNameSpaces || all (null . snd) scopeNameSpaces + -- , null scopeImports + -- , null scopeDatatypeModule + -- ] instance Null ScopeInfo where empty = emptyScopeInfo - null = __IMPOSSIBLE__ - -- TODO: define when needed, careful about _scopeModules! + -- -- Use default implementation of null + -- null ScopeInfo + -- { _scopeCurrent + -- , _scopeModules + -- , _scopeVarsToBind + -- , _scopeLocals + -- , _scopePrecendence + -- , _scopeInverseName + -- , _scopeInverseModule + -- , _scopeInScope + -- , _scopeFixities + -- , _scopePolarities + -- } = and + -- [ null _scopeCurrent + -- , null _scopeModules || all null (Map.values _scopeModules) + -- , null _scopeVarsToBind + -- , null _scopeLocals + -- , null _scopePrecendence + -- , null _scopeInverseName + -- , null _scopeInverseModule + -- , null _scopeInScope + -- , null _scopeFixities + -- , null _scopePolarities + -- ] -- | The empty scope. emptyScope :: Scope @@ -1044,6 +1078,9 @@ 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 $ diff --git a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs --- a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs +++ b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs @@ -564,13 +564,13 @@ . addInstanceB (case A.defInstance i of InstanceDef r -> Just r; NotInstanceDef -> Nothing) <$> m where - priv (PrivateAccess UserWritten) - ds = [ C.Private (getRange ds) UserWritten ds ] + priv (PrivateAccess kwr UserWritten) + ds = [ C.Private kwr UserWritten ds ] priv _ ds = ds - abst AbstractDef ds = [ C.Abstract (getRange ds) ds ] + abst AbstractDef ds = [ C.Abstract empty ds ] abst ConcreteDef ds = ds -addInstanceB :: Maybe Range -> [C.Declaration] -> [C.Declaration] +addInstanceB :: Maybe KwRange -> [C.Declaration] -> [C.Declaration] addInstanceB (Just r) ds = [ C.InstanceB r ds ] addInstanceB Nothing ds = ds @@ -619,7 +619,7 @@ Hidden -> bindToConcreteTop Instance{} -> bindToConcreteTop --- General instances ------------------------------------------------------ +-- Base type instances ------------------------------------------------------ instance ToConcrete () where type ConOfAbs () = () @@ -633,6 +633,8 @@ type ConOfAbs Char = Char toConcrete = pure +-- Functors --------------------------------------------------------------- + instance ToConcrete a => ToConcrete [a] where type ConOfAbs [a] = [ConOfAbs a] @@ -655,6 +657,14 @@ bindToConcrete as $ \ cs -> ret (c :| cs) +instance ToConcrete a => ToConcrete (Maybe a) where + type ConOfAbs (Maybe a) = Maybe (ConOfAbs a) + toConcrete = traverse toConcrete + bindToConcrete (Just x) ret = bindToConcrete x $ ret . Just + bindToConcrete Nothing ret = ret Nothing + +-- Bifunctors etc. -------------------------------------------------------- + instance (ToConcrete a1, ToConcrete a2) => ToConcrete (Either a1 a2) where type ConOfAbs (Either a1 a2) = Either (ConOfAbs a1) (ConOfAbs a2) @@ -686,6 +696,8 @@ where reorder (x,(y,z)) = (x,y,z) +-- Decorations ------------------------------------------------------------ + instance ToConcrete a => ToConcrete (Arg a) where type ConOfAbs (Arg a) = Arg (ConOfAbs a) @@ -711,6 +723,28 @@ 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 @@ -968,19 +1002,7 @@ _ -> b makeDomainFree b = b --- Christian Sattler, 2017-08-05, fixing #2669 --- Both methods of ToConcrete (FieldAssignment' a) (FieldAssignment' c) need --- to be implemented, each in terms of the corresponding one of ToConcrete a c. --- This mirrors the instance ToConcrete (Arg a) (Arg c). --- The default implementations of ToConcrete are not valid semantically. -instance ToConcrete a => ToConcrete (FieldAssignment' a) where - type ConOfAbs (FieldAssignment' a) = FieldAssignment' (ConOfAbs a) - toConcrete = traverse toConcrete - bindToConcrete (FieldAssignment name a) ret = - bindToConcrete a $ ret . FieldAssignment name - - -- Binder instances ------------------------------------------------------- -- If there is no label we set it to the bound name, to make renaming the bound @@ -1033,8 +1055,8 @@ bindToConcrete (A.LetBind i info x t e) ret = bindToConcrete x $ \ x -> do (t, (e, [], [], [])) <- toConcrete (t, A.RHS e Nothing) - ret $ addInstanceB (if isInstance info then Just noRange else Nothing) $ - [ C.TypeSig info Nothing (C.boundName x) t + 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 False @@ -1134,17 +1156,9 @@ Rewrite es -> Rewrite <$> mapM (toConcrete . (\ (_, e) -> ((),e))) es Invert qn pes -> fmap (Invert ()) $ forM pes $ \ (Named n pe) -> do pe <- toConcrete pe - n <- toConcrete n + n <- fmap C.boundName <$> toConcrete n pure $ Named n pe - -instance ToConcrete (Maybe A.BindName) where - type ConOfAbs (Maybe A.BindName) = Maybe C.Name - toConcrete = traverse (C.boundName <.> toConcrete) - -instance ToConcrete (Maybe A.QName) where - type ConOfAbs (Maybe A.QName) = Maybe C.Name - - toConcrete = mapM (toConcrete . qnameName) + LeftLet pes -> LeftLet <$> mapM toConcrete pes instance ToConcrete (Constr A.Constructor) where type ConOfAbs (Constr A.Constructor) = C.Declaration @@ -1154,7 +1168,7 @@ toConcrete (Constr (A.Axiom _ i info Nothing x t)) = do x' <- unsafeQNameToName <$> toConcrete x t' <- toConcreteTop t - return $ C.TypeSig info Nothing x' t' + return $ C.TypeSig info empty x' t' toConcrete (Constr (A.Axiom _ _ _ (Just _) _ _)) = __IMPOSSIBLE__ toConcrete (Constr d) = headWithDefault __IMPOSSIBLE__ <$> toConcrete d @@ -1182,6 +1196,15 @@ 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 :: A.QName -> AbsToCon (C.Name, IsInstance) + f = (,NotInstanceDef) <.> C.unqualify <.> toConcrete + + instance ToConcrete A.Declaration where type ConOfAbs A.Declaration = [C.Declaration] @@ -1197,19 +1220,19 @@ (case mp of Nothing -> [] Just occs -> [C.Pragma (PolarityPragma noRange x' occs)]) ++ - [C.Postulate (getRange i) [C.TypeSig info Nothing x' t']] + [C.Postulate empty [C.TypeSig info empty x' t']] toConcrete (A.Generalize s i j x t) = do x' <- unsafeQNameToName <$> toConcrete x - tac <- traverse toConcrete (defTactic i) + tac <- toConcrete (defTactic i) withAbstractPrivate i $ withInfixDecl i x' $ do t' <- toConcreteTop t - return [C.Generalize (getRange i) [C.TypeSig j tac x' $ C.Generalized t']] + return [C.Generalize empty [C.TypeSig j tac x' $ C.Generalized t']] toConcrete (A.Field i x t) = do x' <- unsafeQNameToName <$> toConcrete x - tac <- traverse toConcrete (defTactic i) + tac <- toConcrete (defTactic i) withAbstractPrivate i $ withInfixDecl i x' $ do t' <- toConcreteTop t @@ -1220,7 +1243,7 @@ withAbstractPrivate i $ withInfixDecl i x' $ do t' <- traverse toConcreteTop t - return [C.Primitive (getRange i) [C.TypeSig (argInfo t') Nothing x' (unArg t')]] + return [C.Primitive empty [C.TypeSig (argInfo t') empty x' (unArg t')]] -- Primitives are always relevant. toConcrete (A.FunDef i _ cs) = @@ -1251,10 +1274,11 @@ toConcrete (A.RecDef i x uc dir bs t cs) = withAbstractPrivate i $ bindToConcrete (map makeDomainFree $ dataDefParams bs) $ \ tel' -> do + dirs <- toConcrete dir (x',cs') <- first unsafeQNameToName <$> toConcrete (x, map Constr cs) - return [ C.RecordDef (getRange i) x' (dir { recConstructor = Nothing }) (catMaybes tel') cs' ] + return [ C.RecordDef (getRange i) x' dirs (catMaybes tel') cs' ] - toConcrete (A.Mutual i ds) = pure . C.Mutual noRange <$> declsToConcrete ds + 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 @@ -1320,8 +1344,10 @@ return $ C.CompilePragma r b x s A.StaticPragma x -> C.StaticPragma r <$> toConcrete x A.InjectivePragma x -> C.InjectivePragma r <$> toConcrete x + A.InjectiveForInferencePragma x -> C.InjectiveForInferencePragma r <$> toConcrete x A.InlinePragma b x -> C.InlinePragma r b <$> toConcrete x A.NotProjectionLikePragma q -> C.NotProjectionLikePragma r <$> toConcrete q + A.OverlapPragma q i -> C.OverlapPragma r <$> (fmap pure (toConcrete q)) <*> pure i A.EtaPragma x -> C.EtaPragma r <$> toConcrete x A.DisplayPragma f ps rhs -> C.DisplayPragma r <$> toConcrete (A.DefP (PatRange noRange) (unambiguous f) ps) <*> toConcrete rhs @@ -1387,7 +1413,9 @@ | otherwise -> bindToConcrete (map UserPattern args) $ ret . A.ConP i c A.DefP i f args -> bindToConcrete (map UserPattern args) $ ret . A.DefP i f A.PatternSynP i f args -> bindToConcrete (map UserPattern args) $ ret . A.PatternSynP i f - A.RecP i args -> bindToConcrete ((map . fmap) UserPattern args) $ ret . A.RecP i + A.RecP i args + | conPatOrigin i == ConOSplit -> ret p + | otherwise -> bindToConcrete ((map . fmap) UserPattern args) $ ret . A.RecP i A.AsP i x p -> bindName' (unBind x) $ bindToConcrete (UserPattern p) $ \ p -> ret (A.AsP i x p) @@ -1424,7 +1452,10 @@ | otherwise -> bindToConcrete (map SplitPattern args) $ ret . A.ConP i c A.DefP i f args -> bindToConcrete (map SplitPattern args) $ ret . A.DefP i f A.PatternSynP i f args -> bindToConcrete (map SplitPattern args) $ ret . A.PatternSynP i f - A.RecP i args -> bindToConcrete ((map . fmap) SplitPattern args) $ ret . A.RecP i + A.RecP i args + | conPatOrigin i == ConOSplit + -> bindToConcrete ((map . fmap) BindingPat args) $ ret . A.RecP i + | otherwise -> bindToConcrete ((map . fmap) SplitPattern args) $ ret . A.RecP 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 @@ -1576,11 +1607,6 @@ arg -> arg) (return arg) -instance ToConcrete (Maybe A.Pattern) where - type ConOfAbs (Maybe A.Pattern) = Maybe C.Pattern - - toConcrete = traverse toConcrete - -- Helpers for recovering natural number literals tryToRecoverNatural :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr @@ -1823,11 +1849,13 @@ tryToRecoverPatternSynP = recoverPatternSyn apply matchPatternSynP where apply c args = PatternSynP patNoRange (unambiguous c) args --- | General pattern synonym recovery parameterised over expression type -recoverPatternSyn :: ToConcrete a => - (A.QName -> [NamedArg a] -> a) -> -- applySyn - (PatternSynDefn -> a -> Maybe [Arg a]) -> -- match - a -> AbsToCon (ConOfAbs a) -> AbsToCon (ConOfAbs a) +-- | General pattern synonym recovery parameterised over expression type. +recoverPatternSyn :: forall a. ToConcrete a + => (A.QName -> [NamedArg a] -> a) -- applySyn + -> (PatternSynDefn -> a -> Maybe [WithHiding a]) -- match + -> a -- expressions + -> AbsToCon (ConOfAbs a) -- fallback + -> AbsToCon (ConOfAbs a) recoverPatternSyn applySyn match e fallback = do doFold <- asks foldPatternSynonyms if not doFold then fallback else do @@ -1854,8 +1882,9 @@ , prettyList_ $ map (\ (q,_,_) -> q) cands ] case sortBy cmp cands of - (q, args, _) : _ -> toConcrete $ applySyn q $ (map . fmap) unnamed args - [] -> fallback + (q, args, _) : _ -> toConcrete $ applySyn q $ + for args $ \ (WithHiding h arg) -> setHiding h $ defaultNamedArg arg + [] -> fallback where -- Heuristic to pick the best pattern synonym: the one that folds the most -- constructors. diff --git a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs --- a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +++ b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs @@ -25,6 +25,8 @@ import Control.Monad ( (>=>), (<=<), foldM, forM, forM_, zipWithM, zipWithM_ ) import Control.Applicative ( liftA2, liftA3 ) import Control.Monad.Except ( MonadError(..) ) +import Control.Monad.State ( StateT, execStateT, get, put ) +import Control.Monad.Trans ( lift ) import Data.Bifunctor import Data.Foldable (traverse_) @@ -39,7 +41,7 @@ import Data.Void import Agda.Syntax.Concrete as C -import Agda.Syntax.Concrete.Attribute +import Agda.Syntax.Concrete.Attribute as CA import Agda.Syntax.Concrete.Generic import Agda.Syntax.Concrete.Operators import Agda.Syntax.Concrete.Pattern @@ -91,7 +93,7 @@ import Agda.Utils.Char import Agda.Utils.Either import Agda.Utils.FileName -import Agda.Utils.Function ( applyWhen ) +import Agda.Utils.Function ( applyWhen, applyWhenM ) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List @@ -109,6 +111,7 @@ import Agda.Utils.Impossible import Agda.ImpossibleTest (impossibleTest, impossibleTestReduceM) +import qualified Agda.Syntax.Common as A {-------------------------------------------------------------------------- Exceptions @@ -129,13 +132,10 @@ {-------------------------------------------------------------------------- Helpers --------------------------------------------------------------------------} ---UNUSED Liang-Ting Chen 2019-07-16 ---annotateDecl :: ScopeM A.Declaration -> ScopeM A.Declaration ---annotateDecl m = annotateDecls $ (:[]) <$> m -- | Make sure that there are no dot patterns (called on pattern synonyms). -noDotorEqPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void) -noDotorEqPattern err = dot +noDotorEqPattern :: A.Pattern' e -> ScopeM (A.Pattern' Void) +noDotorEqPattern = dot where dot :: A.Pattern' e -> ScopeM (A.Pattern' Void) dot = \case @@ -144,15 +144,17 @@ A.ProjP i o d -> pure $ A.ProjP i o d A.WildP i -> pure $ A.WildP i A.AsP i x p -> A.AsP i x <$> dot p - A.DotP{} -> genericError err - A.EqualP{} -> genericError err -- Andrea: so we also disallow = patterns, reasonable? + A.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 i fs -> A.RecP i <$> (traverse $ traverse dot) fs A.WithP i p -> A.WithP i <$> dot p - A.AnnP i a p -> genericError err -- TODO: should this be allowed? + A.AnnP i a p -> err -- TODO: should this be allowed? + err = typeError DotPatternInPatternSynonym + --UNUSED Liang-Ting Chen 2019-07-16 ---- | Make sure that there are no dot patterns (WAS: called on pattern synonyms). --noDotPattern :: String -> A.Pattern' e -> ScopeM (A.Pattern' Void) @@ -550,9 +552,10 @@ -- | Wrapper to resolve a name to a 'ResolvedName' (rather than an 'A.Expr'). data ResolveQName = ResolveQName C.QName -data PatName = PatName C.QName (Maybe (Set A.Name)) +data PatName = PatName C.QName (Maybe (Set A.Name)) Hiding -- ^ If a set is given, then the first name must correspond to one -- of the names in the set. + -- If pattern variable is hidden, its status is indicated in 'Hiding'. instance ToAbstract (NewName C.Name) where type AbsOfCon (NewName C.Name) = A.Name @@ -612,7 +615,7 @@ return $ Just $ f $ AmbQ xs -- Note: user warnings on ambiguous names will be raised by the type checker, - -- see storeDiamsbiguatedName. + -- see 'storeDisambiguatedName'. raiseWarningsOnUsageIfUnambiguous :: List1 A.QName -> ScopeM () raiseWarningsOnUsageIfUnambiguous = \case x :| [] -> raiseWarningsOnUsage x @@ -631,7 +634,7 @@ instance ToAbstract PatName where type AbsOfCon PatName = APatName - toAbstract (PatName x ns) = do + toAbstract (PatName x ns h) = do reportSLn "scope.pat" 10 $ "checking pattern name: " ++ prettyShow x rx <- resolveName' (someKindsOfNames [ConName, CoConName, PatternSynName]) ns x -- Andreas, 2013-03-21 ignore conflicting names which cannot @@ -639,27 +642,19 @@ -- Andreas, 2020-04-11 CoConName: -- coinductive constructors will be rejected later, in the type checker reportSLn "scope.pat" 20 $ "resolved as " ++ prettyShow rx - case (rx, x) of - (VarName y _, C.QName x) -> bindPatVar x - (FieldName d, C.QName x) -> bindPatVar x - (DefinedName _ d _, C.QName x) | isDefName (anameKind d) -> bindPatVar x - (UnknownName, C.QName x) -> bindPatVar x - (ConstructorName _ ds, _) -> patCon ds - (PatternSynResName d, _) -> patSyn d - _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x - where - bindPatVar = VarPatName <.> bindPatternVariable - patCon ds = do + case rx of + ConstructorName _ ds -> ConPatName ds <$ do reportSLn "scope.pat" 10 $ "it was a con: " ++ prettyShow (fmap anameName ds) - return $ ConPatName ds - patSyn ds = do + PatternSynResName ds -> PatternSynPatName ds <$ do reportSLn "scope.pat" 10 $ "it was a pat syn: " ++ prettyShow (fmap anameName ds) - return $ PatternSynPatName ds + _ -> 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 :: C.Name -> ScopeM A.Name -bindPatternVariable x = do +bindPatternVariable :: Hiding -> C.Name -> ScopeM A.Name +bindPatternVariable h x = do y <- (AssocList.lookup x <$> getVarsToBind) >>= \case Just (LocalVar y _ _) -> do reportSLn "scope.pat" 10 $ "it was a old var: " ++ prettyShow x @@ -667,7 +662,7 @@ Nothing -> do reportSLn "scope.pat" 10 $ "it was a new var: " ++ prettyShow x freshAbstractName_ x - addVarToBind x $ LocalVar y PatternBound [] + addVarToBind x $ LocalVar y (PatternBound h) [] return y class ToQName a where @@ -835,7 +830,7 @@ forM_ cs $ \ c -> do reportSLn "scope.extendedLambda" 60 $ "extended lambda lhs: " ++ show (C.lamLHS c) qname <- qualifyName_ name - bindName (PrivateAccess Inserted) FunName cname qname + bindName privateAccessInserted FunName cname qname -- Andreas, 2019-08-20 -- Keep the following __IMPOSSIBLE__, which is triggered by -v scope.decl.trace:80, @@ -843,7 +838,7 @@ 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 + killRange (IdentP True $ C.QName cname) :| ps let lhs = C.LHS p [] [] return $ C.Clause cname ca lhs rhs NoWhere [] scdef <- toAbstract d @@ -909,6 +904,7 @@ , metaScope = scope , metaNumber = Nothing , metaNameSuggestion = "" + , metaKind = UnificationMeta } return $ A.QuestionMark info ii C.Underscore r n -> do @@ -918,6 +914,7 @@ , metaScope = scope , metaNumber = __IMPOSSIBLE__ =<< n , metaNameSuggestion = fromMaybe "" n + , metaKind = UnificationMeta } -- Raw application @@ -1110,10 +1107,11 @@ toAbstract (C.TBind r xs t) = do t' <- toAbstractCtx TopCtx t - tac <- traverse toAbstract $ + tac <- C.TacticAttribute <$> do + traverse toAbstract $ -- Invariant: all tactics are the same -- (distributed in the parser, TODO: don't) - case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of + case List1.mapMaybe (theTacticAttribute . bnameTactic . C.binderName . namedArg) xs of [] -> Nothing tac : _ -> Just tac @@ -1159,7 +1157,7 @@ (name, p', open) <- do if isNoName name then do (i :: NameId) <- fresh - return (C.NoName (getRange name) i, PrivateAccess Inserted, True) + 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. @@ -1173,7 +1171,7 @@ when open $ void $ -- We can discard the returned default A.ImportDirective. openModule TopOpenModule (Just aname) (C.QName name) $ - defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) noRange } + defaultImportDir { publicOpen = boolToMaybe (p == PublicAccess) empty } return d -- | Check whether a telescope has open declarations or module macros. @@ -1381,7 +1379,7 @@ -- encountered several (possibly nested) opaque blocks. We -- must now ensure that these have transitively-closed -- unfolding sets. - saturateOpaqueBlocks (outsideDecls ++ [ insideDecl ]) + saturateOpaqueBlocks return $ TopLevelInfo (primitiveImport ++ outsideDecls ++ [ insideDecl ]) scope @@ -1517,7 +1515,7 @@ Left err -> case definedName p0 of Nothing -> throwError err - Just x -> toAbstract $ LetDef $ NiceMutual r tc cc YesPositivityCheck + Just x -> toAbstract $ LetDef $ 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__ @@ -1562,7 +1560,7 @@ -- Andreas, 2014-10-09, Issue 1299: module macros in lets need -- to be private singleton <$> checkModuleMacro LetApply LetOpenModule r - (PrivateAccess Inserted) erased x modapp open dir + privateAccessInserted erased x modapp open dir _ -> notAValidLetBinding d where @@ -1705,12 +1703,12 @@ return [ A.Primitive di y t' ] -- Definitions (possibly mutual) - NiceMutual r tc cc pc ds -> do + NiceMutual kwr tc cc pc ds -> do reportSLn "scope.mutual" 20 ("starting checking mutual definitions: " ++ prettyShow ds) ds' <- toAbstract ds reportSLn "scope.mutual" 20 ("finishing checking mutual definitions") -- We only termination check blocks that do not have a measure. - return [ A.Mutual (MutualInfo tc cc pc r) ds' ] + 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 @@ -1810,16 +1808,17 @@ conName d = errorNotConstrDecl d -- Record definitions (mucho interesting) - C.NiceRecDef r o a _ uc x (RecordDirectives ind eta pat cm) pars fields -> notAffectedByOpaque $ do + C.NiceRecDef r o a _ uc x directives pars fields -> notAffectedByOpaque $ do reportSLn "scope.rec.def" 20 ("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 YesEta <- eta -> Nothing <$ warn "eta" + | Just (Ranged _ YesEta) <- eta -> Nothing <$ warn "eta" | otherwise -> return pat where warn = setCurrentRange r . warning . UselessPatternDeclarationForRecord Nothing -> return pat @@ -1954,12 +1953,12 @@ (name, theAsSymbol, theAsName) <- case as of Just a | let y = asName a, not (isNoName y) -> do - bindModule (PrivateAccess Inserted) y m + 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 (PrivateAccess Inserted) x m + whenNothing as $ bindQModule (privateAccessInserted) x m return (x, noRange, Nothing) -- Open if specified, otherwise apply import directives @@ -2077,18 +2076,17 @@ (as, p) <- withLocalVars $ do -- Expand puns if optHiddenArgumentPuns is True. puns <- optHiddenArgumentPuns <$> pragmaOptions - p <- return $ if puns then expandPuns p else p - p <- toAbstract =<< parsePatternSyn p + p <- parsePatternSyn $ applyWhen puns expandPuns p + p <- toAbstract p when (containsAsPattern p) $ - typeError $ GenericError $ - "@-patterns are not allowed in pattern synonyms" + typeError AsPatternInPatternSynonym checkPatternLinearity p $ \ys -> typeError $ RepeatedVariablesInPattern ys + -- Bind the pattern variables accumulated by @ToAbstract Pattern@ applied to the rhs. bindVarsToBind - let err = "Dot or equality patterns are not allowed in pattern synonyms. Maybe use '_' instead." - p <- noDotorEqPattern err p - as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as - unlessNull (patternVars p List.\\ map unArg as) $ \ xs -> do + p <- noDotorEqPattern p + as <- mapM checkPatSynParam as + unlessNull (patternVars p List.\\ map whThing as) $ \ xs -> do typeError $ UnboundVariablesInPatternSynonym xs return (as, p) y <- freshAbstractQName' n @@ -2098,17 +2096,29 @@ ep <- expandPatternSynonyms p modifyPatternSyns (Map.insert y (as, ep)) return [A.PatternSynDef y (map (fmap BindName) as) p] -- only for highlighting, so use unexpanded version - where unVarName (VarName a _) = return a - unVarName _ = typeError $ UnusedVariableInPatternSynonym + 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 $ PatternSynonymArgumentShadowsConstructorOrPatternSynonym IsLHS x ys + PatternSynResName ys -> err $ PatternSynonymArgumentShadowsConstructorOrPatternSynonym IsPatSyn 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 [] - NiceOpaque r names decls -> do + NiceOpaque kwr names decls -> do -- The names in an 'unfolding' clause must be unambiguous names of -- definitions: let + r = getRange (kwr, names, decls) findName c = resolveName c >>= \case A.DefinedName _ an _ -> pure (anameName an) A.FieldName (an :| []) -> pure (anameName an) @@ -2137,8 +2147,8 @@ -- Keep going! localTC (\e -> e { envCurrentOpaqueId = Just oid }) $ do out <- traverse toAbstract decls - unless (any interestingOpaqueDecl out) $ warning UselessOpaque - pure $ UnfoldingDecl r names:out + unless (any interestingOpaqueDecl out) $ setCurrentRange kwr $ warning UselessOpaque + pure $ UnfoldingDecl r names : out where -- checking postulate or type sig. without checking safe flag toAbstractNiceAxiom :: KindOfName -> C.NiceDeclaration -> ScopeM A.Declaration @@ -2164,6 +2174,9 @@ interestingOpaqueDecl _ = False +-- ** Helper functions for @opaque@ +------------------------------------------------------------------------ + -- | Add a 'QName' to the set of declarations /contained in/ the current -- opaque block. unfoldFunction :: A.QName -> ScopeM () @@ -2190,6 +2203,9 @@ maybe (pure ()) (const (warning NotAffectedByOpaque)) =<< asksTC envCurrentOpaqueId notUnderOpaque k +-- * Helper functions for @variable@ generalization +------------------------------------------------------------------------ + unGeneralized :: A.Expr -> (Set.Set I.QName, A.Expr) unGeneralized (A.Generalized s t) = (s, t) unGeneralized (A.ScopedExpr si e) = A.ScopedExpr si <$> unGeneralized e @@ -2265,6 +2281,33 @@ (,) <$> 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 () @@ -2280,7 +2323,7 @@ , " current module: " ++ prettyShow m ] unless (A.qnameModule x == m) $ - genericError $ "Definition in different module than its type signature" + typeError $ DefinitionInDifferentModule x -- | Unless the resolved 'AbstractName' has the given 'KindOfName', -- report a 'ClashingDefinition' for the 'C.Name'. @@ -2301,6 +2344,9 @@ 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. @@ -2322,10 +2368,10 @@ -- An abstract constructor is private (abstract constructor means -- abstract datatype, so the constructor should not be exported). p' = case a of - AbstractDef -> PrivateAccess Inserted + AbstractDef -> privateAccessInserted _ -> p p'' = case a of - AbstractDef -> PrivateAccess Inserted + AbstractDef -> privateAccessInserted _ -> PublicAccess -- | Record constructors do not live in the record module (as it is parameterized). @@ -2339,7 +2385,7 @@ -- An abstract constructor is private (abstract constructor means -- abstract datatype, so the constructor should not be exported). p' = case a of - AbstractDef -> PrivateAccess Inserted + AbstractDef -> privateAccessInserted _ -> p bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> TCM A.QName @@ -2351,14 +2397,17 @@ 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 typeError $ ClashingDefinition (C.QName c) (anameName $ List1.head ds) Nothing - _ -> typeError $ GenericError $ - "The name " ++ prettyShow c ++ " already has non-constructor definitions" + 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 @@ -2383,6 +2432,9 @@ errorNotConstrDecl d = setCurrentRange d $ typeError $ IllegalDeclarationInDataDefinition $ notSoNiceDeclarations d +-- ** More scope checking +------------------------------------------------------------------------ + instance ToAbstract C.Pragma where type AbsOfCon C.Pragma = [A.Pragma] @@ -2439,6 +2491,12 @@ "INJECTIVE used on ambiguous name " ++ prettyShow x _ -> genericError "Target of INJECTIVE pragma should be a defined symbol" return [ A.InjectivePragma y ] + toAbstract (C.InjectiveForInferencePragma _ x) = do + e <- toAbstract $ OldQName x Nothing + y <- case e of + A.Def x -> return x + _ -> genericError "Target of INJECTIVE_FOR_INFERENCE pragma should be a defined symbol" + return [ A.InjectiveForInferencePragma y ] toAbstract (C.InlinePragma _ b x) = do e <- toAbstract $ OldQName x Nothing let sINLINE = if b then "INLINE" else "NOINLINE" @@ -2459,6 +2517,32 @@ "NOT_PROJECTION_LIKE used on ambiguous name " ++ prettyShow x _ -> genericError $ "Target of NOT_PROJECTION_LIKE pragma should be a function" return [ A.NotProjectionLikePragma y ] + toAbstract (C.OverlapPragma _ xs i) = do + let + name = case i of + Overlappable -> "OVERLAPPABLE" + Overlapping -> "OVERLAPPING" + Overlaps -> "OVERLAPS" + Incoherent -> "INCOHERENT" + + -- Never written by the user: + DefaultOverlap -> __IMPOSSIBLE__ + FieldOverlap -> __IMPOSSIBLE__ + + single x = do + e <- toAbstract $ OldQName x Nothing + flip A.OverlapPragma i <$> case e of + A.Def x -> return x + A.Con c | Just x <- getUnambiguous c -> return x + A.Con x -> genericError $ + name <> " used on ambiguous name " ++ prettyShow x + A.Proj _ p | Just x <- getUnambiguous p -> return x + A.Proj _ x -> genericError $ + name <> " used on ambiguous name " ++ prettyShow x + _ -> genericError $ "Target of " <> name <> " pragma should be a function, constructor, or projection" + + traverse single xs + toAbstract (C.BuiltinPragma _ rb qx) | Just b' <- b, isUntypedBuiltin b' = do q <- toAbstract $ ResolveQName qx @@ -2473,9 +2557,7 @@ -- The name shouldn't exist yet. If it does, we raise a warning -- and drop the existing definition. unlessM ((UnknownName ==) <$> resolveName qx) $ do - genericWarning $ P.text $ - "BUILTIN " ++ getBuiltinId b' ++ " declares an identifier " ++ - "(no longer expects an already defined identifier)" + warning $ BuiltinDeclaresIdentifier b' modifyCurrentScope $ removeNameFromScope PublicNS x -- We then happily bind the name y <- freshAbstractQName' x @@ -2618,7 +2700,7 @@ -- where-declarations are automatically private. -- This allows their type signature to be checked InAbstractMode. whereToAbstract1 r defaultErased Nothing - (singleton $ C.Private noRange Inserted ds) inner + (singleton $ C.Private empty Inserted ds) inner SomeWhere _ e m a ds0 -> enter $ List1.ifNull ds0 warnEmptyWhere {-else-} $ \ds -> do -- Named where-modules do not default to private. @@ -2646,7 +2728,7 @@ (m, acc) <- do case whname of Just (m, acc) | not (isNoName m) -> return (m, acc) - _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, PrivateAccess Inserted) + _ -> fresh <&> \ x -> (C.NoName (getRange whname) x, privateAccessInserted) -- unnamed where's are private old <- getCurrentModule am <- toAbstract (NewModuleName m) @@ -2661,7 +2743,7 @@ when anonymousSomeWhere $ void $ -- We can ignore the returned default A.ImportDirective. openModule TopOpenModule (Just am) (C.QName m) $ - defaultImportDir { publicOpen = Just noRange } + defaultImportDir { publicOpen = Just empty } return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d) data TerminationOrPositivity = Termination | Positivity @@ -2700,12 +2782,14 @@ 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] @@ -2745,6 +2829,7 @@ 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 @@ -2761,6 +2846,20 @@ -- 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. puns <- optHiddenArgumentPuns <$> pragmaOptions p <- return $ if puns then expandPuns p else p @@ -2768,12 +2867,7 @@ p <- toAbstract p checkPatternLinearity p (typeError . RepeatedVariablesInPattern) bindVarsToBind - p <- toAbstract p - -- and then the name - n <- toAbstract $ fmap (NewName WithBound . C.mkBoundName_) n - pure (n, p) - -- we finally reassemble the telescope - pure $ List1.zipWith (\ (n,p) e -> Named n (p, e)) nps es + toAbstract p instance ToAbstract AbstractRHS where type AbsOfCon AbstractRHS = A.RHS @@ -3003,13 +3097,19 @@ 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)? - -> Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr) -resolvePatternIdentifier canBeConstructor r x ns = do +resolvePatternIdentifier :: + Bool + -- ^ Is the identifier allowed to refer to a constructor (or a pattern synonym)? + -> Hiding + -- ^ Is the pattern variable hidden? + -> C.QName + -- ^ Identifier. + -> Maybe (Set A.Name) + -- ^ Possibly precomputed resolutions of the identifier (from the operator parser). + -> ScopeM (A.Pattern' C.Expr) +resolvePatternIdentifier canBeConstructor h x ns = do reportSLn "scope.pat" 60 $ "resolvePatternIdentifier " ++ prettyShow x ++ " at source position " ++ prettyShow r - px <- toAbstract (PatName x ns) + px <- toAbstract (PatName x ns h) case px of VarPatName y -> do reportSLn "scope.pat" 60 $ " resolved to VarPatName " ++ prettyShow y ++ " with range " ++ prettyShow (getRange y) @@ -3025,6 +3125,7 @@ (AmbQ $ fmap anameName ds) [] else err "pattern synonym" where + r = getRange x err s = setCurrentRange r $ typeError $ GenericError $ @@ -3067,11 +3168,26 @@ 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 h x Nothing + + toAbstract (WithHidingInfo _ p) = toAbstract p + instance ToAbstract C.Pattern where type AbsOfCon C.Pattern = A.Pattern' C.Expr toAbstract (C.IdentP canBeConstructor x) = - resolvePatternIdentifier canBeConstructor (getRange x) x Nothing + resolvePatternIdentifier canBeConstructor empty x Nothing toAbstract (AppP (QuoteP _) p) | IdentP _ x <- namedArg p, @@ -3086,7 +3202,9 @@ reportSLn "scope.pat" 50 $ "distributeDots before = " ++ show p p <- distributeDots p reportSLn "scope.pat" 50 $ "distributeDots after = " ++ show p - (p', q') <- toAbstract (p, q) + p' <- toAbstract p + -- Remember hiding info in argument to propagate to 'PatternBound'. + q' <- toAbstract $ propagateHidingInfo q applyAPattern p0 p' $ singleton q' where @@ -3117,8 +3235,9 @@ toAbstract p0@(OpAppP r op ns ps) = do reportSLn "scope.pat" 60 $ "ConcreteToAbstract.toAbstract OpAppP{}: " ++ show p0 - p <- resolvePatternIdentifier True (getRange op) op (Just ns) - ps <- toAbstract ps + p <- resolvePatternIdentifier True empty op (Just ns) + -- Remember hiding info in arguments to propagate to 'PatternBound'. + ps <- toAbstract $ map propagateHidingInfo ps applyAPattern p0 p ps toAbstract (EllipsisP _ mp) = maybe __IMPOSSIBLE__ toAbstract mp @@ -3139,10 +3258,10 @@ -- x <- toAbstract (NewName PatternBound x) -- Andreas, 2020-05-01, issue #4631: as-variables should not shadow constructors. -- x <- bindPatternVariable x - toAbstract (PatName (C.QName x) Nothing) >>= \case + toAbstract (PatName (C.QName x) Nothing empty) >>= \case VarPatName x -> A.AsP (PatRange r) (A.mkBindName x) <$> toAbstract p - ConPatName{} -> ignoreAsPat False - PatternSynPatName{} -> ignoreAsPat True + ConPatName{} -> ignoreAsPat IsLHS + PatternSynPatName{} -> ignoreAsPat IsPatSyn where -- An @-bound name which shadows a constructor is illegal and becomes dead code. ignoreAsPat b = do @@ -3165,7 +3284,7 @@ _ -> fallback toAbstract p0@(C.AbsurdP r) = return $ A.AbsurdP (PatRange r) - toAbstract (C.RecP r fs) = A.RecP (PatRange r) <$> mapM (traverse toAbstract) fs + toAbstract (C.RecP r fs) = A.RecP (ConPatInfo ConORec (PatRange r) ConPatEager) <$> mapM (traverse toAbstract) fs toAbstract (C.WithP r p) = A.WithP (PatRange r) <$> toAbstract p -- | An argument @OpApp C.Expr@ to an operator can have binders, @@ -3219,6 +3338,10 @@ 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 @@ -3227,17 +3350,26 @@ 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 + -- 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__ + 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 @@ -3271,7 +3403,7 @@ checkAttributes ((attr, r, s) : attrs) = case attr of RelevanceAttribute{} -> cont - TacticAttribute{} -> cont + CA.TacticAttribute{} -> cont LockAttribute IsNotLock -> cont LockAttribute IsLock{} -> do unlessM (optGuarded <$> pragmaOptions) $ diff --git a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs --- a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs +++ b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs @@ -40,7 +40,7 @@ import Agda.Syntax.Position import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C -import Agda.Syntax.Concrete (FieldAssignment'(..)) +import Agda.Syntax.Concrete (FieldAssignment'(..), TacticAttribute'(..)) import Agda.Syntax.Info as Info import Agda.Syntax.Abstract as A hiding (Binder) import qualified Agda.Syntax.Abstract as A @@ -190,12 +190,14 @@ reifyWhen = reifyWhenE reify x = do b <- asksTC envPrintMetasBare - mi <- mvInfo <$> lookupLocalMeta x + mvar <- lookupLocalMeta x + let mi = mvInfo mvar let mi' = Info.MetaInfo { metaRange = getRange $ miClosRange mi , metaScope = clScope $ miClosRange mi , metaNumber = if b then Nothing else Just x , metaNameSuggestion = if b then "" else miNameSuggestion mi + , metaKind = metaInstantiationToMetaKind (mvInstantiation mvar) } underscore = return $ A.Underscore mi' -- If we are printing a term that will be pasted into the user @@ -413,7 +415,7 @@ -- even the pattern variables @n < len@ can be -- applied to some args @vs@. e <- if n < len - then return $ A.patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n + then return $ patternToExpr $ namedArg $ indexWithDefault __IMPOSSIBLE__ ps n else reify (I.var (n - len)) apps e =<< argsToExpr vs _ -> return underscore @@ -481,12 +483,26 @@ -- 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) - reportSDoc "reify.term" 80 $ pure $ "reifyTerm (unSpine v) = " <+> pretty (unSpine' pred v) - case unSpine' pred v of + + -- Amy, 2024-01-07: postfix and system projections should still be + -- turned into head symbols *if* they have display forms attached. + hasDisplay <- liftReduce $ unKleisli hasDisplayForms + let + prefixize :: ProjOrigin -> QName -> Bool + prefixize orig name = or + [ if havePfp then orig == ProjPrefix else orig /= ProjPostfix + , isOperator name + -- Andreas, 2024-06-13, issue #7318: + -- print e.g. G .|_| as | G | + , hasDisplay name + ] + reportSDoc "reify.term" 80 $ pure $ "reifyTerm (unSpine v) = " <+> pretty (unSpine' prefixize v) + + case unSpine' prefixize v of -- Hack to print generalized field projections with nicer names. Should -- only show up in errors. Check the spined form! _ | I.Var n (I.Proj _ p : es) <- v, @@ -500,18 +516,33 @@ reportSDoc "reify.def" 80 $ return $ "reifying def" <+> pretty x (x, es) <- reifyPathPConstAsPath x es reifyDisplayForm x es $ reifyDef expandAnonDefs x es - I.Con c ci vs -> do - let x = conName c - isR <- isGeneratedRecordConstructor x - if isR || ci == ConORec - then do + + I.Con c ci es -> do + + -- If the origin is a record expression, print a record expression. + if ci == ConORec then recordExpression Nothing else do + isRecordConstructor x >>= \case + + -- If it is a generated constructor, print a record expression. + Just (r, def) | not (_recNamedCon def) -> recordExpression $ Just (r, def) + + -- Otherwise, print a constructor application. + _ -> constructorApplication + where + x = conName c + + recordExpression mrdef = do + (r, def) <- maybe (fromMaybe __IMPOSSIBLE__ <$> isRecordConstructor x) pure mrdef showImp <- showImplicitArguments let keep (a, v) = showImp || visible a - r <- getConstructorData x - xs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r - vs <- map unArg <$> reify (fromMaybe __IMPOSSIBLE__ $ allApplyElims vs) - return $ A.Rec noExprInfo $ map (Left . uncurry FieldAssignment . mapFst unDom) $ filter keep $ zip xs vs - else reifyDisplayForm x vs $ do + A.Rec 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 @@ -521,10 +552,10 @@ -- extra parameters) or equal (if not) to n when (n > np) __IMPOSSIBLE__ let h = A.Con (unambiguous x) - if null vs + if null es then return h else do - es <- reify (map (fromMaybe __IMPOSSIBLE__ . isApplyElim) vs) + es <- reify $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es -- Andreas, 2012-04-20: do not reify parameter arguments of constructor -- if the first regular constructor argument is hidden -- we turn it into a named argument, in order to avoid confusion @@ -585,7 +616,7 @@ {- else -} (reify a) where mkPi b (Arg info a') = ifM (skipGeneralizedParameter info) (snd <$> reify b) $ do - tac <- traverse (Ranged noRange <.> reify) $ domTactic a + 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 @@ -1322,10 +1353,10 @@ -- If the record constructor is generated or the user wrote a record pattern, -- print record pattern. -- Otherwise, print constructor pattern. - if recNamedCon def && conPatOrigin ci /= ConORec then fallback else do - fs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r + if _recNamedCon def && conPatOrigin ci /= ConORec then fallback else do + let fs = recordFieldNames def unless (length fs == length ps) __IMPOSSIBLE__ - return $ A.RecP patNoRange $ zipWith mkFA fs ps + return $ A.RecP ci $ zipWith mkFA fs ps where mkFA ax nap = FieldAssignment (unDom ax) (namedArg nap) _ -> __IMPOSSIBLE__ @@ -1341,8 +1372,8 @@ -- If the record constructor is generated or the user wrote a record expression, -- print record expression. -- Otherwise, print constructor expression. - if recNamedCon def && co /= ConORec then fallback else do - fs <- fromMaybe __IMPOSSIBLE__ <$> getRecordFieldNames_ r + if _recNamedCon def && co /= ConORec then fallback else do + let fs = recordFieldNames def unless (length fs == length es) __IMPOSSIBLE__ return $ A.Rec empty $ zipWith mkFA fs es where @@ -1523,7 +1554,7 @@ (x, bs) <- reify tel let r = getRange e name = domName arg - tac <- traverse (Ranged noRange <.> reify) $ domTactic arg + tac <- TacticAttribute <$> do traverse (Ranged noRange <.> reify) $ domTactic arg let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x return $ TBind r (TypedBindingInfo tac (domIsFinite arg)) xs e : bs {-# SPECIALIZE reify :: I.Telescope -> TCM (ReifiesTo I.Telescope) #-} diff --git a/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs b/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs --- a/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs +++ b/src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs @@ -145,7 +145,7 @@ -- TODO(Amy): Anyone know why this discards the tactic? It was like -- that when I got here! return $ A.TBind noRange - (A.TypedBindingInfo Nothing isfin) + (A.TypedBindingInfo empty isfin) (singleton $ unnamedArg i $ A.mkBinder_ name) dom diff --git a/src/full/Agda/Termination/Monad.hs b/src/full/Agda/Termination/Monad.hs --- a/src/full/Agda/Termination/Monad.hs +++ b/src/full/Agda/Termination/Monad.hs @@ -427,11 +427,11 @@ Just Projection{ projProper = Just{}, projFromType = Arg _ r, projIndex = n } -> caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do -- no for inductive or non-recursive record - if recInduction rdef /= Just CoInductive then return False else do + if _recInduction rdef /= Just CoInductive then return False else do reportSLn "term.guardedness" 40 $ prettyShow q ++ " is coinductive; record type is " ++ prettyShow r if not mustBeRecursive then return True else do reportSLn "term.guardedness" 40 $ prettyShow q ++ " must be recursive" - if not (safeRecRecursive rdef) then return False else do + if notSafeRecRecursive rdef then return False else do reportSLn "term.guardedness" 40 $ prettyShow q ++ " has been declared recursive, doing actual check now..." -- TODO: the following test for recursiveness of a projection should be cached. -- E.g., it could be stored in the @Projection@ component. @@ -439,7 +439,7 @@ -- Get the type of the field by dropping record parameters and record argument. let TelV tel core = telView' (defType pdef) (pars, tel') = splitAt n $ telToList tel - mut = fromMaybe __IMPOSSIBLE__ $ recMutual rdef + mut = fromMaybe __IMPOSSIBLE__ $ _recMutual rdef -- Check if any recursive symbols appear in the record type. -- Q (2014-07-01): Should we normalize the type? -- A (2017-01-13): Yes, since we also normalize during positivity check? @@ -476,9 +476,9 @@ -- that has not happened. To avoid crashing (as in Agda 2.5.3), -- we rather give the possibly wrong answer here, -- restoring the behavior of Agda 2.5.2. TODO: fix record declaration checking. - safeRecRecursive :: Defn -> Bool - safeRecRecursive (Record { recMutual = Just qs }) = not $ null qs - safeRecRecursive _ = False + notSafeRecRecursive :: RecordData -> Bool + notSafeRecRecursive = maybe True null . _recMutual + -- @_recMutual@ should be something (@Just (_:_)@) to be safe -- * De Bruijn pattern stuff diff --git a/src/full/Agda/Termination/RecCheck.hs b/src/full/Agda/Termination/RecCheck.hs --- a/src/full/Agda/Termination/RecCheck.hs +++ b/src/full/Agda/Termination/RecCheck.hs @@ -163,7 +163,6 @@ where -- TODO: Is it bad to ignore the lambdas? inst (InstV i) = instBody i - inst Open = __IMPOSSIBLE__ - inst OpenInstance = __IMPOSSIBLE__ + inst OpenMeta{} = __IMPOSSIBLE__ inst BlockedConst{} = __IMPOSSIBLE__ inst PostponedTypeCheckingProblem{} = __IMPOSSIBLE__ diff --git a/src/full/Agda/Termination/TermCheck.hs b/src/full/Agda/Termination/TermCheck.hs --- a/src/full/Agda/Termination/TermCheck.hs +++ b/src/full/Agda/Termination/TermCheck.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NondecreasingIndentation #-} @@ -255,7 +254,7 @@ -- could be turned into actual splits, because no-confusion -- would make the other cases impossible, so I do not disable -- this for --without-K entirely. - ifM (isJust . optCubical <$> pragmaOptions) (return r) {- else -} $ + ifM (isJust <$> cubicalOption) (return r) {- else -} $ case r of r@Right{} -> return r Left{} -> do @@ -414,7 +413,7 @@ -- this for --without-K entirely. -- -- Andreas, 2022-03-21: The check for --cubical was missing here. - ifM (isJust . optCubical <$> pragmaOptions) (return r) {- else -} $ case r of + ifM (isJust <$> cubicalOption) (return r) {- else -} $ case r of Right () -> return $ Right () Left{} -> do -- Try again, but include the dot patterns this time. @@ -436,7 +435,7 @@ 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) + map (nest 2 . prettyTCM) (List.sortOn getRange calls) mempty -- Functions must terminate, so we report the error. @@ -1034,10 +1033,10 @@ 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 + 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) + ifM (targetElem . fromMaybe __IMPOSSIBLE__ $ _recMutual def) {-then-} coinductive {-else-} inductive constructor c ind argsg diff --git a/src/full/Agda/TypeChecking/Abstract.hs b/src/full/Agda/TypeChecking/Abstract.hs --- a/src/full/Agda/TypeChecking/Abstract.hs +++ b/src/full/Agda/TypeChecking/Abstract.hs @@ -64,7 +64,7 @@ eqTy <- defType <$> getConstInfo eqName -- E.g. @eqTy = eqTel → Set a@ where @eqTel = {a : Level} {A : Set a} (x y : A)@. TelV eqTel _ <- telView eqTy - tel <- newTelMeta (telFromList $ dropEnd 2 $ telToList eqTel) + tel <- newTelMeta (telFromList $ dropEnd 3 $ telToList eqTel) let eq = Def eqName $ map Apply $ map (setHiding Hidden) tel -- we write `v ≡ w` because this equality is typically used to @@ -72,12 +72,15 @@ -- in a with-clause. -- If we were to write `w ≡ v`, we would often need to take the -- symmetric of the proof we get to make use of `rewrite`. - ++ [ defaultArg (raise 1 v) + ++ [ setHiding Hidden $ defaultArg $ raise 1 $ unEl a + , defaultArg (raise 1 v) , defaultArg (var 0) ] + -- Since the result of this function will be type-checked in + -- `withFunctionType`, we can be a little lazy here and put + -- a meta for the sort. sort <- newSortMeta - let ty = El sort eq - ty <$ checkType ty + return $ El sort eq pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a)) $ mkPi (setHiding NotHidden $ defaultDom ("eq", eq)) diff --git a/src/full/Agda/TypeChecking/CompiledClause/Match.hs b/src/full/Agda/TypeChecking/CompiledClause/Match.hs --- a/src/full/Agda/TypeChecking/CompiledClause/Match.hs +++ b/src/full/Agda/TypeChecking/CompiledClause/Match.hs @@ -156,7 +156,7 @@ -- mo <- getBuiltinName' builtinIOne -- return $ Set.fromList $ catMaybes [mi,mo] - fallThrough <- return $ (Just True ==) (fallThrough bs) && isJust (catchAllBranch bs) + fallThrough <- return $ Just True == fallThrough bs && isJust (catchAllBranch bs) let isCon b = diff --git a/src/full/Agda/TypeChecking/Constraints.hs b/src/full/Agda/TypeChecking/Constraints.hs --- a/src/full/Agda/TypeChecking/Constraints.hs +++ b/src/full/Agda/TypeChecking/Constraints.hs @@ -143,9 +143,22 @@ noConstraints :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => m a -> m a -noConstraints problem = do +noConstraints = noConstraints' False + +-- | As noConstraints but also fail for non-blocking constraints. +reallyNoConstraints + :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) + => m a -> m a +reallyNoConstraints = noConstraints' True + +noConstraints' + :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) + => Bool -> m a -> m a +noConstraints' includingNonBlocking problem = do (pid, x) <- newProblem problem - cs <- getConstraintsForProblem pid + let counts | includingNonBlocking = const True + | otherwise = isBlockingConstraint . clValue . theConstraint + cs <- filter counts <$> getConstraintsForProblem pid unless (null cs) $ do withCurrentCallStack $ \loc -> do w <- warning'_ loc (UnsolvedConstraints cs) @@ -285,10 +298,9 @@ -- Ulf, 2018-04-30: The size solver shouldn't touch blocked terms! They have -- a twin meta that it's safe to solve. InstV{} -> __IMPOSSIBLE__ - -- Open (whatever that means) - Open -> __IMPOSSIBLE__ - OpenInstance -> __IMPOSSIBLE__ + 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. diff --git a/src/full/Agda/TypeChecking/Conversion.hs b/src/full/Agda/TypeChecking/Conversion.hs --- a/src/full/Agda/TypeChecking/Conversion.hs +++ b/src/full/Agda/TypeChecking/Conversion.hs @@ -54,6 +54,7 @@ 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 @@ -211,9 +212,15 @@ | otherwise = (assign rid y vs u, assign dir x us v) (MetaV x us, _) -> unlessSubtyping $ assign dir x us v `orelse` fallback (_, MetaV y vs) -> unlessSubtyping $ assign rid y vs u `orelse` fallback - (Def f es, Def f' es') | f == f' -> - ifNotM (optFirstOrder <$> pragmaOptions) fallback $ {- else -} unlessSubtyping $ do + (Def 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. @@ -223,7 +230,7 @@ cubicalProjs <- traverse getName' [builtin_unglue, builtin_unglueU] let notFirstOrder = isJust (isRelevantProjection_ def) - || any (Just f ==) cubicalProjs + || (Just f) `elem` cubicalProjs if notFirstOrder then fallback else do pol <- getPolarity' cmp f whenProfile Profile.Conversion $ tick "compare first-order shortcut" @@ -324,38 +331,89 @@ then do whenProfile Profile.Conversion $ tick "compare at eta record" sig <- getSignature - let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem - -- to change Agda's behavior - -- isNeutral Blocked{} = False - isNeutral (NotBlocked _ Con{}) = return False - -- Andreas, 2013-09-18 / 2015-06-29: a Def by copatterns is - -- not neutral if it is blocked (there can be missing projections - -- to trigger a reduction. - isNeutral (NotBlocked r (Def q _)) = do -- Andreas, 2014-12-06 optimize this using r !! - not <$> usesCopatterns q -- a def by copattern can reduce if projected - isNeutral _ = return True - isMeta b = case ignoreBlocking b of - MetaV{} -> True - _ -> False + 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) - | mNeutral && nNeutral -> do + + -- 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 + 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 @@ -518,12 +576,13 @@ dir = fromCmp cmp rid = flipCmp dir -- The reverse direction. Bad name, I know. - assign dir x es v = assignE dir x es v t $ compareAtomDir dir t + 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 @@ -1891,7 +1950,7 @@ , " s2 =" <+> prettyTCM s2 ] sizedTypesEnabled <- sizedTypesOption - cubicalEnabled <- isJust . optCubical <$> pragmaOptions + cubicalEnabled <- isJust <$> cubicalOption levelUnivEnabled <- optLevelUniverse <$> pragmaOptions let postpone = patternViolation blocker err :: m () diff --git a/src/full/Agda/TypeChecking/Coverage.hs b/src/full/Agda/TypeChecking/Coverage.hs --- a/src/full/Agda/TypeChecking/Coverage.hs +++ b/src/full/Agda/TypeChecking/Coverage.hs @@ -862,7 +862,7 @@ -- -> 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 . optCubicalCompatible <$> pragmaOptions + withK <- not <$> cubicalCompatibleOption if withK then return Nothing else do -- Get the type of the datatype -- Δ1 ⊢ dtype @@ -1036,7 +1036,7 @@ Right{} -> return () Left SplitOnStrict -> return () Left x -> do - whenM (optCubicalCompatible <$> pragmaOptions) $ do + whenM cubicalCompatibleOption $ do -- re #3733: TODO better error msg. lift $ warning . UnsupportedIndexedMatch =<< prettyTCM x @@ -1458,9 +1458,10 @@ -- if we want to split projections, but have no target type, we give up let failure = return . Left caseMaybe target (failure CosplitNoTarget) $ \ t -> do - isR <- addContext tel $ isRecordType $ unDom t - case isR of - Just (_r, vs, Record{ recFields = fs }) -> do + (addContext tel $ isRecordType $ unDom t) >>= \case + Nothing -> addContext tel $ do + failure . CosplitNoRecordType =<< buildClosure (unDom t) + Just (_r, vs, RecordData{ _recFields = fs }) -> do reportSDoc "tc.cover" 20 $ sep [ text $ "we are of record type _r = " ++ prettyShow _r , text "applied to parameters vs =" <+> addContext tel (prettyTCM vs) @@ -1506,8 +1507,6 @@ [ "fieldSub for" <+> prettyTCM (unDom proj) , nest 2 $ pretty fieldSub ] return (SplitCon (unDom proj), (sc', NoInfo)) - _ -> addContext tel $ do - buildClosure (unDom t) >>= failure . CosplitNoRecordType -- 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. diff --git a/src/full/Agda/TypeChecking/Coverage/Cubical.hs b/src/full/Agda/TypeChecking/Coverage/Cubical.hs --- a/src/full/Agda/TypeChecking/Coverage/Cubical.hs +++ b/src/full/Agda/TypeChecking/Coverage/Cubical.hs @@ -203,7 +203,7 @@ bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do params <- pure params `applyN` (fmap unArg <$> g1) x <- sequence x - s <- s `applyN` (map (pure . unArg) $ params ++ x) + s <- s `applyN` map (pure . unArg) (params ++ x) pure $ El s $ Def d [] `apply` (params ++ x) return $ (params, xTel,dT) @@ -242,7 +242,7 @@ 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 + 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 @@ -320,14 +320,14 @@ Abs n (data_ty,lines) <- 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) + 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` (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` (max phi_k (neg j): for p_k (\ p -> lam "h" $ \ h -> p <@> (min h j))) `applyN` [x0]] pure (data_ty,[line1,line2]) data_ty <- open $ Abs n data_ty @@ -492,7 +492,7 @@ bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do params <- pure params `applyN` (fmap unArg <$> g1) x <- sequence x - s <- s `applyN` (map (pure . unArg) $ params ++ x) + s <- s `applyN` map (pure . unArg) (params ++ x) pure $ El s $ Def d [] `apply` (params ++ x) return $ (params, xTel,dT) @@ -935,7 +935,7 @@ hdelta <- open hdelta params <- open params abstractN (pure gamma) $ \ args -> do - pTel <- open =<< (lift $ pathTelescope (infoEqTel info) (map defaultArg $ infoEqLHS info) (map defaultArg $ infoEqRHS info)) + pTel <- open =<< lift (pathTelescope (infoEqTel info) (map defaultArg $ infoEqLHS info) (map defaultArg $ infoEqRHS info)) abstractN (pure (telFromList [defaultDom ("phi",interval)] :: Telescope)) $ \ [phi] -> abstractN pTel $ \ [p] -> do [l,bA,x,y] <- mapM open =<< applyN params args @@ -1023,7 +1023,7 @@ delta_args_f <- bind "i" $ \ i -> do m <- trFillTel' True <$> delta_f <*> phi <*> delta_args <*> i - either __IMPOSSIBLE__ id <$> (lift $ runExceptT m) + either __IMPOSSIBLE__ id <$> lift (runExceptT m) delta_args_f <- open delta_args_f old_t_f <- (open =<<) $ bind "i" $ \ i -> do g <- lazyAbsApp <$> gamma_args_left <*> i @@ -1068,7 +1068,7 @@ [phi,psi] <- mapM open [phi,psi] pure tPOr <#> l <@> phi <@> psi - <#> (ilam "o" $ \ _ -> ty) <@> noilam u0 <@> u1 + <#> ilam "o" (\ _ -> ty) <@> noilam u0 <@> u1 noilam u = do u <- open u @@ -1086,12 +1086,12 @@ n <- length . unAbs <$> sides -- TODO don't comp if the family and the sides "j. [ α ↦ u ]" are constant? if n > 1 then - pure tComp <#> l <@> (lam "i" $ \ i -> unEl . unDom <$> ty i) + pure tComp <#> l <@> lam "i" (\ i -> unEl . unDom <$> ty i) <@> (cl primIMax <@> phi <@> alphas) - <@> (lam "i" $ \ i -> combine (l <@> i) (unEl . unDom <$> ty i) =<< (lazyAbsApp <$> sides <*> i)) + <@> lam "i" (\ i -> combine (l <@> i) (unEl . unDom <$> ty i) =<< (lazyAbsApp <$> sides <*> i)) <@> (lazyAbsApp <$> w <*> primIZero) else - pure tTrans <#> l <@> (lam "i" $ \ i -> unEl . unDom <$> ty i) + pure tTrans <#> l <@> lam "i" (\ i -> unEl . unDom <$> ty i) <@> phi <@> (lazyAbsApp <$> w <*> primIZero) diff --git a/src/full/Agda/TypeChecking/Datatypes.hs b/src/full/Agda/TypeChecking/Datatypes.hs --- a/src/full/Agda/TypeChecking/Datatypes.hs +++ b/src/full/Agda/TypeChecking/Datatypes.hs @@ -17,7 +17,7 @@ import Agda.TypeChecking.Pretty import Agda.Utils.Either -import Agda.Utils.Functor ( (<.>) ) +import Agda.Utils.Functor import Agda.Syntax.Common.Pretty ( prettyShow ) import Agda.Utils.Size @@ -223,13 +223,13 @@ getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo) getConstructorInfo' c = do - (theDef <$> getConstInfo c) >>= \case + getConstInfo c <&> theDef >>= \case Constructor{ conData = d, conArity = n } -> Just <$> do - (theDef <$> getConstInfo d) >>= \case - r@Record{ recFields = fs } -> - return $ RecordCon (recPatternMatching r) (recEtaEquality r) n fs - Datatype{} -> - return $ DataCon n + getConstInfo d <&> theDef <&> \case + RecordDefn (r@RecordData{ _recFields = fs, _recPatternMatching = pat }) -> + RecordCon pat (_recEtaEquality r) n fs + DatatypeDefn _ -> + DataCon n _ -> __IMPOSSIBLE__ _ -> return Nothing diff --git a/src/full/Agda/TypeChecking/DeadCode.hs b/src/full/Agda/TypeChecking/DeadCode.hs --- a/src/full/Agda/TypeChecking/DeadCode.hs +++ b/src/full/Agda/TypeChecking/DeadCode.hs @@ -2,24 +2,14 @@ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where -import Control.Monad ((<$!>)) +import Control.Monad ((<$!>), filterM) import Control.Monad.Trans import Data.Maybe -import Data.Monoid (All(..)) -import Data.Map (Map) -import qualified Data.Map as Map import qualified Data.Map.Strict as MapS -import Data.Set (Set) -import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap -import Agda.Interaction.Options - -import qualified Agda.Syntax.Abstract as A - import Agda.Syntax.Common -import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Internal import Agda.Syntax.Internal.Names import Agda.Syntax.Scope.Base @@ -28,100 +18,60 @@ import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Monad -import Agda.TypeChecking.Reduce +import Agda.Utils.Monad (mapMaybeM) import Agda.Utils.Impossible import Agda.Utils.Lens import Agda.Utils.HashTable (HashTable) import qualified Agda.Utils.HashTable as HT --- | Run before serialisation to remove any definitions and --- meta-variables that are not reachable from the module's public --- interface. --- --- Things that are reachable only from warnings are removed. - -eliminateDeadCode :: - Map ModuleName a - -- ^ Exported modules whose telescopes should not be mutilated by the dead-code removal. - -> BuiltinThings PrimFun - -> DisplayForms - -> Signature - -> LocalMetaStore - -> TCM (DisplayForms, Signature, RemoteMetaStore) -eliminateDeadCode publicModules bs disp sig ms = Bench.billTo [Bench.DeadCode] $ do - !patsyn <- getPatternSyns - !public <- Set.mapMonotonic anameName . publicNames <$> getScope - !save <- optSaveMetas <$> pragmaOptions - !defs <- if save then return (sig ^. sigDefinitions) - else Bench.billTo [Bench.DeadCode, Bench.DeadCodeInstantiateFull] - (traverse (\x -> instantiateFull x) (sig ^. sigDefinitions)) +-- | 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 names (for definitions and pattern synonyms) +-- - definitions marked as primitive +-- - definitions with COMPILE pragma +-- - all parameter sections (because all sections go into interfaces!) +-- (see also issues #6931 and #7382) +-- - local builtins +-- - all rewrite rules +-- We only ever prune dead metavariables and definitions. The reachable ones +-- are returned from this function. +eliminateDeadCode :: ScopeInfo -> TCM (RemoteMetaStore, Definitions) +eliminateDeadCode !scope = Bench.billTo [Bench.DeadCode] $ do + !sig <- getSignature + let !defs = sig ^. sigDefinitions + !psyns <- getPatternSyns + !metas <- useR stSolvedMetaStore -- #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). + -- Simple solution: retain all primitives (shouldn't be many). let hasCompilePragma = not . MapS.null . defCompiledRep + isPrimitive = \case Primitive{} -> True PrimitiveSort{} -> True - _ -> False + _ -> False + extraRootsFilter (name, def) | hasCompilePragma def || isPrimitive (theDef def) = Just name | otherwise = Nothing - extraRoots = - Set.fromList $ mapMaybe extraRootsFilter $ HMap.toList defs - rootSections = Map.elems $ (sig ^. sigSections) `Map.intersection` publicModules - rootNames = Set.union public extraRoots - rootMetas = - if not save then Set.empty else metasIn - ( bs - , sig ^. sigSections - , sig ^. sigRewriteRules - , HMap.filterWithKey (\x _ -> Set.member x rootNames) disp - ) - - (!rns, !rms) <- Bench.billTo [Bench.DeadCode, Bench.DeadCodeReachable] $ liftIO $ - reachableFrom rootSections rootNames rootMetas patsyn disp defs ms - - let !dead = Set.fromList (HMap.keys defs) `Set.difference` rns - !valid = getAll . namesIn' (All . (`Set.notMember` dead)) -- no used name is dead - !defs' = HMap.map ( \ d -> d { defDisplay = filter valid (defDisplay d) } ) - $ HMap.filterWithKey (\ x _ -> Set.member x rns) defs - !disp' = HMap.filter (not . null) $ HMap.map (filter valid) disp - !ms' = HMap.fromList $ - mapMaybe - (\(m, mv) -> - if not (Set.member m rms) - then Nothing - else Just (m, remoteMetaVariable mv)) $ - MapS.toList ms + let !pubModules = publicModules scope - reportSLn "tc.dead" 10 $ - "Removed " ++ show (HMap.size defs - HMap.size defs') ++ - " unused definitions and " ++ show (MapS.size ms - HMap.size ms') ++ - " unused meta-variables." - reportSLn "tc.dead" 90 $ unlines $ - "Removed the following definitions from the signature:" : - map (("- " ++) . prettyShow) (Set.toList dead) - let !sig' = set sigDefinitions defs' sig - return (disp', sig', ms') + let !rootPubNames = map anameName $ publicNamesOfModules pubModules + let !rootExtraDefs = mapMaybe extraRootsFilter $ HMap.toList defs + let !rootRewrites = sig ^. sigRewriteRules -reachableFrom :: - [Section] -- ^ Root modules. - -> Set QName -- ^ Root names. - -> Set MetaId -- ^ Root metas. - -> A.PatternSynDefns - -> DisplayForms - -> Definitions - -> LocalMetaStore - -> IO (Set QName, Set MetaId) -reachableFrom sections ids ms psyns disp defs insts = do + let !rootModSections = sig ^. sigSections + !rootBuiltins <- useTC stLocalBuiltins - !seenNames <- HT.empty :: IO (HashTable QName ()) - !seenMetas <- HT.empty :: IO (HashTable MetaId ()) + !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 @@ -131,7 +81,6 @@ HT.insert seenNames x () go (HMap.lookup x defs) go (PSyn <$!> MapS.lookup x psyns) - go (HMap.lookup x disp) goMeta :: MetaId -> IO () goMeta !m = HT.lookup seenMetas m >>= \case @@ -139,40 +88,50 @@ pure () Nothing -> do HT.insert seenMetas m () - case MapS.lookup m insts of + case MapS.lookup m metas of Nothing -> pure () - Just mv -> go (instBody (theInstantiation mv)) + Just mv -> do + go (instBody (theInstantiation mv)) + go (jMetaType (mvJudgement mv)) go :: NamesIn a => a -> IO () - go = namesAndMetasIn' (either goName goMeta) + go !x = namesAndMetasIn' (either goName goMeta) x {-# INLINE go #-} - go sections - foldMap goName ids - foldMap goMeta ms - !ids' <- HT.keySet seenNames - !ms' <- HT.keySet seenMetas - pure (ids', ms') + Bench.billTo [Bench.DeadCode, Bench.DeadCodeReachable] $ liftIO $ do + foldMap goName rootPubNames + foldMap goName rootExtraDefs + go rootRewrites + go rootModSections + go rootBuiltins + 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') --- | Returns the instantiation. --- --- Precondition: The instantiation must be of the form @'InstV' inst@. + 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) + +-- | 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 - Open{} -> __IMPOSSIBLE__ - OpenInstance{} -> __IMPOSSIBLE__ + OpenMeta{} -> __IMPOSSIBLE__ BlockedConst{} -> __IMPOSSIBLE__ PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__ -- | Converts from 'MetaVariable' to 'RemoteMetaVariable'. --- --- Precondition: The instantiation must be of the form @'InstV' inst@. - +-- Precondition: The instantiation must be of the form @'InstV' inst@. remoteMetaVariable :: MetaVariable -> RemoteMetaVariable -remoteMetaVariable mv = RemoteMetaVariable +remoteMetaVariable !mv = RemoteMetaVariable { rmvInstantiation = theInstantiation mv , rmvModality = getModality mv , rmvJudgement = mvJudgement mv diff --git a/src/full/Agda/TypeChecking/DiscrimTree.hs b/src/full/Agda/TypeChecking/DiscrimTree.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/DiscrimTree.hs @@ -0,0 +1,429 @@ +-- | 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{} -> 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, [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 :: Bool -> Int -> [Key] -> [Term] -> TCM [Key] +termPath toplevel local acc [] = pure $! reverse acc +termPath 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, _) <- + 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 + ] + termPath False local (k:acc) (as <> todo) + +-- | 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 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 => DiscrimTree a -> Set.Set a -> DiscrimTree a +deleteFromDT dt gone = case dt of + EmptyDT -> EmptyDT + DoneDT s -> + let s' = Set.difference s gone + in doneDT s' + CaseDT i s k -> + let + del x = case deleteFromDT x gone of + EmptyDT -> Nothing + dt' -> Just dt' + + s' = Map.mapMaybe del s + k' = deleteFromDT k gone + in if | Map.null s' -> k' + | otherwise -> CaseDT i s' k' diff --git a/src/full/Agda/TypeChecking/DiscrimTree/Types.hs b/src/full/Agda/TypeChecking/DiscrimTree/Types.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/DiscrimTree/Types.hs @@ -0,0 +1,139 @@ +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.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 + -- ^ 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 diff --git a/src/full/Agda/TypeChecking/Empty.hs b/src/full/Agda/TypeChecking/Empty.hs --- a/src/full/Agda/TypeChecking/Empty.hs +++ b/src/full/Agda/TypeChecking/Empty.hs @@ -100,8 +100,8 @@ -- If t is a record type, see if any of the field types is empty Right (r, pars, def) -> do - if | NoEta{} <- recEtaEquality def -> return $ Left Fail - | otherwise -> void <$> do checkEmptyTel range $ recTel def `apply` pars + ifNotM (isEtaRecordDef def) (return $ Left Fail) $ + 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). diff --git a/src/full/Agda/TypeChecking/Errors.hs b/src/full/Agda/TypeChecking/Errors.hs --- a/src/full/Agda/TypeChecking/Errors.hs +++ b/src/full/Agda/TypeChecking/Errors.hs @@ -40,9 +40,11 @@ import qualified Data.Set as Set import qualified Text.PrettyPrint.Boxes as Boxes +import Agda.Interaction.Options + import Agda.Syntax.Common import Agda.Syntax.Concrete.Definitions (notSoNiceDeclarations) -import Agda.Syntax.Concrete.Pretty (prettyHiding, prettyRelevance) +import Agda.Syntax.Concrete.Pretty (attributesForModality, prettyHiding, prettyRelevance) import Agda.Syntax.Notation import Agda.Syntax.Position import qualified Agda.Syntax.Concrete as C @@ -63,13 +65,17 @@ 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) + 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.List ( initLast, lastMaybe ) import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 @@ -116,17 +122,19 @@ r = nameBindingSite $ qnameName q tcErrString :: TCErr -> String -tcErrString err = prettyShow (getRange err) ++ " " ++ case err of - TypeError _ _ cl -> errorString $ clValue cl - Exception r s -> prettyShow r ++ " " ++ show s - IOException _ r e -> prettyShow r ++ " " ++ E.displayException e - PatternErr{} -> "PatternErr" +tcErrString err = + unwords . filter (not . null) . (prettyShow (getRange err) :) $ + case err of + TypeError _ _ cl -> [ errorString $ clValue cl ] + Exception r s -> [ prettyShow r, show s ] + IOException _ r e -> [ prettyShow r, showIOException e ] + PatternErr{} -> [ "PatternErr" ] stringTCErr :: String -> TCErr stringTCErr = Exception noRange . P.text errorString :: TypeError -> String -errorString err = case err of +errorString = \case AmbiguousModule{} -> "AmbiguousModule" AmbiguousName{} -> "AmbiguousName" AmbiguousField{} -> "AmbiguousField" @@ -137,9 +145,12 @@ AmbiguousConstructor{} -> "AmbiguousConstructor" -- AmbiguousParseForPatternSynonym{} -> "AmbiguousParseForPatternSynonym" AmbiguousTopLevelModuleName {} -> "AmbiguousTopLevelModuleName" + AsPatternInPatternSynonym{} -> "AsPatternInPatternSynonym" + DotPatternInPatternSynonym{} -> "DotPatternInPatternSynonym" BadArgumentsToPatternSynonym{} -> "BadArgumentsToPatternSynonym" TooFewArgumentsToPatternSynonym{} -> "TooFewArgumentsToPatternSynonym" CannotResolveAmbiguousPatternSynonym{} -> "CannotResolveAmbiguousPatternSynonym" + PatternSynonymArgumentShadowsConstructorOrPatternSynonym{} -> "PatternSynonymArgumentShadowsConstructorOrPatternSynonym" UnboundVariablesInPatternSynonym{} -> "UnboundVariablesInPatternSynonym" BothWithAndRHS -> "BothWithAndRHS" BuiltinInParameterisedModule{} -> "BuiltinInParameterisedModule" @@ -155,11 +166,13 @@ DataMustEndInSort{} -> "DataMustEndInSort" -- UNUSED: DataTooManyParameters{} -> "DataTooManyParameters" CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype" + DefinitionInDifferentModule{} -> "DefinitionInDifferentModule" DoesNotConstructAnElementOf{} -> "DoesNotConstructAnElementOf" DuplicateBuiltinBinding{} -> "DuplicateBuiltinBinding" DuplicateConstructors{} -> "DuplicateConstructors" DuplicateFields{} -> "DuplicateFields" DuplicateImports{} -> "DuplicateImports" + DuplicateOverlapPragma{} -> "DuplicateOverlapPragma" FieldOutsideRecord -> "FieldOutsideRecord" FileNotFound{} -> "FileNotFound" GenericError{} -> "GenericError" @@ -175,6 +188,8 @@ -- UNUSED: IncompletePatternMatching{} -> "IncompletePatternMatching" InternalError{} -> "InternalError" InvalidPattern{} -> "InvalidPattern" + InvalidFileName{} -> "InvalidFileName" + LibraryError{} -> "LibraryError" LocalVsImportedModuleClash{} -> "LocalVsImportedModuleClash" MetaCannotDependOn{} -> "MetaCannotDependOn" MetaOccursInItself{} -> "MetaOccursInItself" @@ -209,6 +224,9 @@ NotAProperTerm -> "NotAProperTerm" InvalidType{} -> "InvalidType" InvalidTypeSort{} -> "InvalidTypeSort" + CannotSolveSizeConstraints{} -> "CannotSolveSizeConstraints" + ContradictorySizeConstraint{} -> "ContradictorySizeConstraint" + EmptyTypeOfSizes{} -> "EmptyTypeOfSizes" FunctionTypeInSizeUniv{} -> "FunctionTypeInSizeUniv" NotAValidLetBinding{} -> "NotAValidLetBinding" NotValidBeforeField{} -> "NotValidBeforeField" @@ -239,6 +257,8 @@ ImpossibleConstructor{} -> "ImpossibleConstructor" TooManyFields{} -> "TooManyFields" TooManyPolarities{} -> "TooManyPolarities" + RecursiveRecordNeedsInductivity{} -> "RecursiveRecordNeedsInductivity" + SplitOnCoinductive{} -> "SplitOnCoinductive" SplitOnIrrelevant{} -> "SplitOnIrrelevant" SplitOnUnusableCohesion{} -> "SplitOnUnusableCohesion" -- UNUSED: -- SplitOnErased{} -> "SplitOnErased" @@ -250,6 +270,7 @@ SplitInProp{} -> "SplitInProp" DefinitionIsIrrelevant{} -> "DefinitionIsIrrelevant" DefinitionIsErased{} -> "DefinitionIsErased" + ProjectionIsIrrelevant{} -> "ProjectionIsIrrelevant" VariableIsIrrelevant{} -> "VariableIsIrrelevant" VariableIsErased{} -> "VariableIsErased" VariableIsOfUnusableCohesion{} -> "VariableIsOfUnusableCohesion" @@ -269,7 +290,8 @@ UninstantiatedDotPattern{} -> "UninstantiatedDotPattern" ForcedConstructorNotInstantiated{} -> "ForcedConstructorNotInstantiated" SolvedButOpenHoles{} -> "SolvedButOpenHoles" - UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym" + IllegalInstanceVariableInPatternSynonym _ -> "IllegalInstanceVariableInPatternSynonym" + UnusedVariableInPatternSynonym _ -> "UnusedVariableInPatternSynonym" UnquoteFailed{} -> "UnquoteFailed" DeBruijnIndexOutOfScope{} -> "DeBruijnIndexOutOfScope" WithClausePatternMismatch{} -> "WithClausePatternMismatch" @@ -305,7 +327,6 @@ IllTypedPatternAfterWithAbstraction{} -> "IllTypedPatternAfterWithAbstraction" ComatchingDisabledForRecord{} -> "ComatchingDisabledForRecord" BuiltinMustBeIsOne{} -> "BuiltinMustBeIsOne" - IllegalRewriteRule{} -> "IllegalRewriteRule" IncorrectTypeForRewriteRelation{} -> "IncorrectTypeForRewriteRelation" UnexpectedParameter{} -> "UnexpectedParameter" NoParameterOfName{} -> "NoParameterOfName" @@ -314,6 +335,8 @@ SortCannotDependOnItsIndex{} -> "SortCannotDependOnItsIndex" ExpectedBindingForParameter{} -> "ExpectedBindingForParameter" UnexpectedTypeSignatureForParameter{} -> "UnexpectedTypeSignatureForParameter" + UnusableAtModality{} -> "UnusableAtModality" + CustomBackendError{} -> "CustomBackendError" instance PrettyTCM TCErr where prettyTCM err = case err of @@ -330,7 +353,7 @@ reportSLn "error" 2 $ "Error raised at " ++ prettyShow loc sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e Exception r s -> sayWhere r $ return s - IOException _ r e -> sayWhere r $ fwords $ show e + 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. @@ -590,10 +613,25 @@ InvalidTypeSort s -> fsep $ prettyTCM s : pwords "is not a valid sort" InvalidType v -> fsep $ prettyTCM v : pwords "is not a valid type" + 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" + 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] @@ -647,6 +685,11 @@ 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" @@ -726,6 +769,12 @@ 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 @@ -832,6 +881,8 @@ "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 + LocalVsImportedModuleClash m -> fsep $ pwords "The module" ++ [prettyTCM m] ++ pwords "can refer to either a local module or an imported module" @@ -905,6 +956,14 @@ ++ [prettyTCM x] ++ pwords "found:" ) $$ nest 2 (vcat $ map (text . filePath) files) + 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 $ pwords "You tried to load" ++ [text (filePath file)] ++ pwords "which defines the module" ++ [pretty mod <> "."] ++ @@ -1003,6 +1062,9 @@ pwords "where M is a module name. The expression" ++ [pretty e, "doesn't."] + DefinitionInDifferentModule _x -> fsep $ + pwords "Definition in different module than its type signature" + FieldOutsideRecord -> fsep $ pwords "Field appearing outside record declaration." @@ -1068,6 +1130,11 @@ 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] @@ -1085,9 +1152,28 @@ prDef (x, (xs, p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) ("at" <+> pretty r) where r = nameBindingSite $ qnameName x - UnusedVariableInPatternSynonym -> fsep $ - pwords "Unused variable in pattern synonym." + IllegalInstanceVariableInPatternSynonym x -> fsep $ concat + [ pwords "Variable is bound as instance in pattern synonym," + , pwords "but does not resolve as instance in pattern: " + , [pretty x] + ] + PatternSynonymArgumentShadowsConstructorOrPatternSynonym kind x (y :| _ys) -> vcat + [ fsep $ concat + [ pwords "Pattern synonym variable" + , [ pretty x ] + , [ "shadows" ] + , case kind of + IsLHS -> [ "constructor" ] + IsPatSyn -> pwords "pattern synonym" + , 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 (map prettyA xs)] @@ -1099,16 +1185,11 @@ where prettyLhsOrPatSyn = pwords $ case lhsOrPatSyn of IsLHS -> "left-hand side" - IsPatSyn -> "pattern synonym" + IsPatSyn -> "pattern synonym right-hand side" prettyErrs = case errs of [] -> empty p0 : _ -> fsep $ pwords "Problematic expression:" ++ [pretty p0] -{- UNUSED - NoParseForPatternSynonym p -> fsep $ - pwords "Could not parse the pattern synonym" ++ [pretty p] --} - AmbiguousParseForLHS lhsOrPatSyn p ps -> do d <- pretty p vcat $ @@ -1258,6 +1339,12 @@ [prettyTCM x] ++ pwords "(at most" ++ [text (show n)] ++ pwords "allowed)." + 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 ] @@ -1286,6 +1373,9 @@ BlockedOnMeta _ m -> fsep $ pwords $ "Unquote failed because of unsolved meta variables." + PatLamWithoutClauses _ -> fsep $ + pwords "Cannot unquote pattern lambda without clauses. Use a single `absurd-clause` for absurd lambdas." + UnquotePanic err -> __IMPOSSIBLE__ DeBruijnIndexOutOfScope i EmptyTel [] -> fsep $ @@ -1453,69 +1543,6 @@ BuiltinMustBeIsOne builtin -> prettyTCM builtin <+> " is not IsOne." - IllegalRewriteRule q reason -> case reason of - LHSNotDefOrConstr -> 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?" - LHSReducesTo v v' -> fsep - [ prettyTCM q <+> " is not a legal rewrite rule, since the left-hand side " - , prettyTCM v <+> " reduces to " <+> prettyTCM v' ] - HeadSymbolIsProjection f -> hsep - [ prettyTCM q , " is not a legal rewrite rule, since the head symbol" - , prettyTCM f , "is a projection" - ] - 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 - HeadSymbolNotPostulateFunctionConstructor f -> hsep - [ prettyTCM q , " is not a legal rewrite rule, since the head symbol" - , prettyTCM f , "is not a postulate, a function, or a constructor" - ] - HeadSymbolDefContainsMetas 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." - ] - ConstructorParamsNotGeneral 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_ (map prettyTCM $ Set.toList ms) - ] - BlockedOnProblems ps -> hsep - [ prettyTCM q , " is not a legal rewrite rule, since" - , "it is blocked on problem(s)", prettyList_ (map prettyTCM $ Set.toList ps) - ] - RequiresDefinitions qs -> hsep - [ prettyTCM q , " is not a legal rewrite rule, since" - , "it requires the definition(s) of", prettyList_ (map prettyTCM $ Set.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" - ] - EmptyReason -> hsep - [ prettyTCM q , " is not a legal rewrite rule" ] - IncorrectTypeForRewriteRelation v reason -> case reason of ShouldAcceptAtLeastTwoArguments -> sep [ prettyTCM v <+> " does not have the right type for a rewriting relation" @@ -1563,6 +1590,57 @@ let s | length xs > 1 = "s" | otherwise = "" text ("Unexpected type signature for parameter" ++ s) <+> 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" + ++ [pure (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" + ++ [pure (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" + <+> pure (attributesForModality mod) + _ -> prettyTCM t <+> "is not usable at the required modality" + <+> pure (attributesForModality mod) + + CustomBackendError backend err -> (text backend <> ":") pure err where mpar n args diff --git a/src/full/Agda/TypeChecking/Errors.hs-boot b/src/full/Agda/TypeChecking/Errors.hs-boot --- a/src/full/Agda/TypeChecking/Errors.hs-boot +++ b/src/full/Agda/TypeChecking/Errors.hs-boot @@ -6,6 +6,9 @@ import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug) +import {-# SOURCE #-} Agda.TypeChecking.Pretty (PrettyTCM) + +instance PrettyTCM TCErr -- Misplaced SPECIALISE pragma: -- {-# SPECIALIZE renderError :: TCErr -> TCM String #-} diff --git a/src/full/Agda/TypeChecking/Forcing.hs b/src/full/Agda/TypeChecking/Forcing.hs --- a/src/full/Agda/TypeChecking/Forcing.hs +++ b/src/full/Agda/TypeChecking/Forcing.hs @@ -63,11 +63,15 @@ isForced, nextIsForced ) where +import Control.Monad +import Control.Monad.Fail +import Control.Monad.Reader +import Control.Monad.State + import Data.Bifunctor -import Data.DList (DList) -import qualified Data.DList as DL -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap +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 @@ -76,21 +80,25 @@ import Agda.Syntax.Internal import Agda.TypeChecking.Monad +import Agda.TypeChecking.Datatypes (consOfHIT) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +import Agda.Utils.Boolean (implies) +import Agda.Utils.IArray (Array, listArray) +import qualified Agda.Utils.IArray as Array import Agda.Utils.List +import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Size +import Agda.Utils.Singleton import Agda.Utils.Impossible -- | Given the type of a constructor (excluding the parameters), -- decide which arguments are forced. --- Precondition: the type is of the form @Γ → D vs@ and the @vs@ --- are in normal form. computeForcingAnnotations :: QName -> Type -> TCM [IsForced] computeForcingAnnotations c t = ifNotM (optForcing <$> pragmaOptions {-then-}) (return []) $ {-else-} do @@ -99,50 +107,117 @@ -- Andreas, 2015-03-28 Issue 1469: Normalization too costly. -- Instantiation also fixes Issue 1454. -- Note that normalization of s0 below does not help. - t <- instantiateFull t + -- t <- instantiateFull t -- Ulf, 2018-01-28 (#2919): We do need to reduce the target type enough to -- get to the actual data type. -- Also #2947: The type might reduce to a pi type. + -- Andreas, 2024-07-07, issue #6744, iteratively reduce. TelV tel (El _ a) <- telViewPath t + erasureOn <- optErasure <$> pragmaOptions + -- Modalities of constructor arguments: + let n = size tel + -- Candidates for forced arguments, indexed by their de Bruijn index. + -- 'Nothing' means cannot possibly be forced. + forcedArgCands :: ForcedVariableCandidates + forcedArgCands = listArray (0,n-1) + [ -- Jesper, 2023-09-20 (#6867): With --erasure, only arguments with @0 can be forced. + if (erasureOn `implies` hasQuantity0 m) + -- Also the argument shouldn't be irrelevant, since in that + -- case it isn't really forced. + && (getRelevance m /= Irrelevant) + then Just m else Nothing + | m <- map getModality $ reverse $ telToList tel + ] + -- Computation of forced arguments: let vs = case a of Def _ us -> us _ -> __IMPOSSIBLE__ - n = size tel - xs :: [(Modality, Nat)] - xs = DL.toList $ forcedVariables vs - xs' :: IntMap [Modality] - xs' = IntMap.map DL.toList $ IntMap.fromListWith (<>) $ - map (\(m, i) -> (i, DL.singleton m)) xs - -- #2819: We can only mark an argument as forced if it appears in the - -- type with a relevance below (i.e. more relevant) than the one of the - -- constructor argument. Otherwise we can't actually get the value from - -- the type. Also the argument shouldn't be irrelevant, since in that - -- case it isn't really forced. - isForced :: Modality -> Nat -> Bool - isForced m i = - (hasQuantity0 m || noUserQuantity m) - && (getRelevance m /= Irrelevant) - && case IntMap.lookup i xs' of - Nothing -> False - Just ms -> any (`moreUsableModality` m) ms - forcedArgs = - [ if isForced m i then Forced else NotForced - | (i, m) <- zip (downFrom n) $ map getModality (telToList tel) + forcedVars <- + -- No candidates, no winners! + if all isNothing forcedArgCands then pure IntSet.empty + else runReduceM $ execForcedVariableCollection forcedArgCands $ forcedVariables vs + let forcedArgs = + [ if IntSet.member i forcedVars then Forced else NotForced + | i <- downFrom n ] reportS "tc.force" 60 [ "Forcing analysis for " ++ prettyShow c - , " xs = " ++ show (map snd xs) + , " forcedVars = " ++ show (IntSet.toList forcedVars) , " forcedArgs = " ++ show forcedArgs ] return forcedArgs +-- | Candidates for forced constructor arguments (@Just m@) with their modality (@m@) +-- in the constructor telescope. +-- +type ForcedVariableCandidates = Array Nat (Maybe Modality) + +-- | Environment for forced variable collection. +-- +data ForcedVariableContext = ForcedVariableContext + { fvcModality :: Modality + -- ^ Modality of current position. (Accumulated from traversed 'Arg's.) + , fvcCandidates :: ForcedVariableCandidates + -- ^ Candidates for forced variables. (Immutable.) + } + +-- | Which candidates are actually forced? +-- +type ForcedVariableState = IntSet + +-- | Monad for forced variable analysis. +-- +newtype ForcedVariableCollection' a = ForcedVariableCollection + { runForcedVariableCollection :: ReaderT ForcedVariableContext (StateT ForcedVariableState ReduceM) a } + deriving + ( Functor, Applicative, Monad + , MonadReader ForcedVariableContext, MonadState ForcedVariableState + -- Needed for HasConstInfo: + , MonadFail, 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 -> DList (Modality, Nat) + forcedVariables :: a -> ForcedVariableCollection default forcedVariables :: (ForcedVariables b, Foldable t, a ~ t b) => - a -> DList (Modality, Nat) + a -> ForcedVariableCollection forcedVariables = foldMap forcedVariables instance ForcedVariables a => ForcedVariables [a] where @@ -155,14 +230,15 @@ instance ForcedVariables a => ForcedVariables (Arg a) where forcedVariables x = - fmap (first (composeModality m)) (forcedVariables (unArg x)) + underModality m $ forcedVariables $ unArg x where m = getModality x -- | Assumes that the term is in normal form. instance ForcedVariables Term where - forcedVariables = \case - Var i [] -> DL.singleton (unitModality, i) - Con _ _ vs -> forcedVariables vs + -- Andreas, 2024-07-07, issue #6744, add reduction. + forcedVariables v = reduce v >>= \case + Var i [] -> singleton (i, unitModality) + Con c _ vs -> ifM (consOfHIT $ conName c) mempty $ {-else-} forcedVariables vs _ -> mempty isForced :: IsForced -> Bool diff --git a/src/full/Agda/TypeChecking/Generalize.hs b/src/full/Agda/TypeChecking/Generalize.hs --- a/src/full/Agda/TypeChecking/Generalize.hs +++ b/src/full/Agda/TypeChecking/Generalize.hs @@ -138,6 +138,7 @@ 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 @@ -529,7 +530,7 @@ r <- getMetaRange x genericDocError =<< (fwords (msg ++ " The problematic unsolved meta is") $$ - (nest 2 $ prettyTCM (MetaV x []) <+> "at" <+> pretty r) + nest 2 (prettyTCM (MetaV x []) <+> "at" <+> pretty r) ) -- If one of the fields depend on this meta, we have to make sure that this meta doesn't depend @@ -930,29 +931,18 @@ inTopContext $ forM_ (zip sortedMetas genRecFields) $ \ (meta, fld) -> do fieldTy <- getMetaType meta let field = unDom fld - addConstant' field (getArgInfo fld) field fieldTy $ - let proj = Projection { projProper = Just genRecName - , projOrig = field - , projFromType = defaultArg genRecName - , projIndex = projIx - , projLams = ProjLams [defaultArg "gtel"] } in - Function { funClauses = [] - , funCompiled = Nothing - , funSplitTree = Nothing - , funTreeless = Nothing - , funInv = NotInjective - , funMutual = Just [] - , funAbstr = ConcreteDef - , funProjection = Right proj - , funErasure = erasure - , funFlags = Set.empty - , funTerminates = Just True - , funExtLam = Nothing - , funWith = Nothing - , funCovering = [] - , funIsKanOp = Nothing - , funOpaque = TransparentDef - } + addConstant' field (getArgInfo fld) field 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 (conName genRecCon) __DUMMY_TYPE__ $ -- Filled in later Constructor { conPars = 0 , conArity = length genRecFields @@ -1016,5 +1006,26 @@ 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 = False + , clauseExact = Just True + , clauseRecursive = Just False + , clauseUnreachable = Just False + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing + }] where setType q ty = modifyGlobalDefinition q $ \ d -> d { defType = ty } diff --git a/src/full/Agda/TypeChecking/IApplyConfluence.hs b/src/full/Agda/TypeChecking/IApplyConfluence.hs --- a/src/full/Agda/TypeChecking/IApplyConfluence.hs +++ b/src/full/Agda/TypeChecking/IApplyConfluence.hs @@ -42,7 +42,7 @@ checkIApplyConfluence_ :: QName -> TCM () -checkIApplyConfluence_ f = whenM (isJust . optCubical <$> pragmaOptions) $ do +checkIApplyConfluence_ f = whenM (isJust <$> cubicalOption) $ do -- Andreas, 2019-03-27, iapply confluence should only be checked -- when --cubical or --erased-cubical is active. See -- test/Succeed/CheckIApplyConfluence.agda. @@ -203,7 +203,7 @@ -- | Like @unifyElims@ but @Γ@ is from the meta's @MetaInfo@ and -- the context extension @Δ@ is taken from the @Closure@. unifyElimsMeta :: MetaId -> Args -> Closure Constraint -> ([(Term,Term)] -> Constraint -> TCM a) -> TCM a -unifyElimsMeta m es_m cl k = ifM (isNothing . optCubical <$> pragmaOptions) (enterClosure cl $ k []) $ do +unifyElimsMeta m es_m cl k = ifM (isNothing <$> cubicalOption) (enterClosure cl $ k []) $ do mv <- lookupLocalMeta m enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢ ty <- metaType m diff --git a/src/full/Agda/TypeChecking/Implicit.hs b/src/full/Agda/TypeChecking/Implicit.hs --- a/src/full/Agda/TypeChecking/Implicit.hs +++ b/src/full/Agda/TypeChecking/Implicit.hs @@ -11,6 +11,7 @@ import Agda.Syntax.Position (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 @@ -111,7 +112,7 @@ case unEl t0' of Pi dom@Dom{domInfo = info, domTactic = tac, unDom = a} b | let x = bareNameWithDefault "_" dom, expand (getHiding info) x -> do - info' <- if hidden info then return info else do + kind <- if hidden info then return UnificationMeta else do reportSDoc "tc.term.args.ifs" 15 $ "inserting instance meta for type" <+> prettyTCM a reportSDoc "tc.term.args.ifs" 40 $ nest 2 $ vcat @@ -119,51 +120,47 @@ , "hiding = " <+> text (show $ getHiding info) ] - return $ makeInstance info - (_, v) <- newMetaArg info' x CmpLeq a + return InstanceMeta + (_, v) <- newMetaArg kind info x CmpLeq a whenJust tac $ \ tac -> liftTCM $ applyModalityToContext info $ unquoteTactic tac v a let narg = Arg info (Named (Just $ WithOrigin Inserted $ unranged x) v) mapFst (narg :) <$> implicitNamedArgs (n-1) expand (absApp b v) _ -> return ([], t0') --- | Create a metavariable according to the 'Hiding' info. +-- | Create a metavariable of 'MetaKind'. newMetaArg :: (PureTCM m, MonadMetaSolver m) - => ArgInfo -- ^ Kind/relevance of meta. + => MetaKind -- ^ Kind of meta. + -> ArgInfo -- ^ Rrelevance of meta. -> ArgName -- ^ Name suggestion for meta. -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the type. -> Type -- ^ Type of meta. -> m (MetaId, Term) -- ^ The created meta as id and as term. -newMetaArg info x cmp a = do +newMetaArg kind info x cmp a = do prp <- runBlocked $ isPropM a let irrelevantIfProp = applyWhen (prp == Right True) $ applyRelevanceToContext Irrelevant applyModalityToContext info $ irrelevantIfProp $ - newMeta (getHiding info) (argNameToString x) a + newMeta (argNameToString x) kind a where - newMeta :: MonadMetaSolver m => Hiding -> String -> Type -> m (MetaId, Term) - newMeta Instance{} n = newInstanceMeta n - newMeta Hidden n = newNamedValueMeta RunMetaOccursCheck n cmp - newMeta NotHidden n = newNamedValueMeta RunMetaOccursCheck n cmp + newMeta :: MonadMetaSolver m => String -> MetaKind -> Type -> m (MetaId, Term) + newMeta n = \case + InstanceMeta -> newInstanceMeta n + UnificationMeta -> newNamedValueMeta RunMetaOccursCheck n cmp --- | Create a questionmark according to the 'Hiding' info. +-- | Create a questionmark (always 'UnificationMeta'). newInteractionMetaArg - :: ArgInfo -- ^ Kind/relevance of meta. + :: ArgInfo -- ^ Relevance of meta. -> ArgName -- ^ Name suggestion for meta. -> Comparison -- ^ Check (@CmpLeq@) or infer (@CmpEq@) the type. -> Type -- ^ Type of meta. -> TCM (MetaId, Term) -- ^ The created meta as id and as term. newInteractionMetaArg info x cmp a = do applyModalityToContext info $ - newMeta (getHiding info) (argNameToString x) a - where - newMeta :: Hiding -> String -> Type -> TCM (MetaId, Term) - newMeta Instance{} n = newInstanceMeta n - newMeta Hidden n = newNamedValueMeta' RunMetaOccursCheck n cmp - newMeta NotHidden n = newNamedValueMeta' RunMetaOccursCheck n cmp + newNamedValueMeta' RunMetaOccursCheck (argNameToString x) cmp a --------------------------------------------------------------------------- diff --git a/src/full/Agda/TypeChecking/Injectivity.hs b/src/full/Agda/TypeChecking/Injectivity.hs --- a/src/full/Agda/TypeChecking/Injectivity.hs +++ b/src/full/Agda/TypeChecking/Injectivity.hs @@ -145,7 +145,7 @@ , builtin_glue , builtin_glueU ] case theDef defn of - _ | any (Just qn ==) prims -> pure True + _ | (Just qn) `elem` prims -> pure True Function{funIsKanOp = Just _} -> pure True _ -> pure False @@ -318,7 +318,7 @@ functionInverse = \case Def f es -> do inv <- defInverse <$> getConstInfo f - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption case inv of NotInjective -> return NoInv Inverse m -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m) diff --git a/src/full/Agda/TypeChecking/InstanceArguments.hs b/src/full/Agda/TypeChecking/InstanceArguments.hs --- a/src/full/Agda/TypeChecking/InstanceArguments.hs +++ b/src/full/Agda/TypeChecking/InstanceArguments.hs @@ -9,18 +9,26 @@ , shouldPostponeInstanceSearch , postponeInstanceConstraints , getInstanceCandidates + , getInstanceDefs + , OutputTypeName(..) + , getOutputTypeName + , addTypedInstance + , addTypedInstance' + , pruneTemporaryInstances + , resolveInstanceHead ) where -import Control.Monad ( forM ) -import Control.Monad.Except ( ExceptT(..), runExceptT, MonadError(..) ) -import Control.Monad.Trans ( lift ) +import Control.Monad (forM, filterM) +import Control.Monad.Except (ExceptT(..), runExceptT, MonadError(..)) +import Control.Monad.Trans (lift ) +-- import Control.Monad.IO.Class (liftIO) -import qualified Data.Map as Map +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 (foldrM) +import Data.Foldable (toList, foldrM) import Agda.Interaction.Options (optQualifiedInstances) @@ -31,6 +39,7 @@ 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 (pureEqualTerm) import Agda.TypeChecking.Errors () --instance only import Agda.TypeChecking.Implicit (implicitArgs) @@ -40,6 +49,8 @@ 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 @@ -50,17 +61,23 @@ import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Tuple import Agda.Syntax.Common.Pretty (prettyShow) -import Agda.Utils.Null (empty) +import qualified Agda.Utils.ProfileOptions as Profile +-- import qualified Agda.Utils.HashTable as HashTable 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 :: Type -> TCM (Either Blocker [Candidate]) -initialInstanceCandidates t = do - (_ , otn) <- getOutputTypeName t +initialInstanceCandidates :: Bool -> Type -> TCM (Either Blocker [Candidate]) +initialInstanceCandidates blockOverlap instTy = do + (_, _, otn) <- getOutputTypeName instTy case otn of NoOutputTypeName -> typeError $ GenericError $ "Instance search can only be used to find elements in a named type" @@ -69,23 +86,41 @@ return (Left b) OutputTypeVisiblePi -> typeError $ GenericError $ "Instance search cannot be used to find elements in an explicit function type" - OutputTypeVar -> do + OutputTypeVar -> do reportSDoc "tc.instance.cands" 30 $ "Instance type is a variable. " - runBlocked getContextVars - OutputTypeName n -> do + runBlocked (getContextVars Nothing) + OutputTypeName n -> Bench.billTo [Bench.Typing, Bench.InstanceSearch, Bench.InitialCandidates] do reportSDoc "tc.instance.cands" 30 $ "Found instance type head: " <+> prettyTCM n - runBlocked getContextVars >>= \case - Left b -> return $ Left b - Right ctxVars -> Right . (ctxVars ++) <$> getScopeDefs n + runBlocked do + local <- getContextVars (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 - getContextVars :: BlockT TCM [Candidate] - getContextVars = do + getContextVars :: Maybe QName -> BlockT TCM [Candidate] + getContextVars 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 = [ (var i, raise (i + 1) t) | (i, t) <- zip [0..] ctx ] - vars = [ Candidate LocalCandidate x t (isOverlappable info) + vars = [ Candidate LocalCandidate x t (infoOverlapMode info) | (x, Dom{domInfo = info, unDom = (_, t)}) <- varsAndRaisedTypes , isInstance info ] @@ -96,23 +131,28 @@ reportSDoc "tc.instance.fields" 30 $ if null fields then "no instance field candidates" else "instance field candidates" $$ do - nest 2 $ vcat - [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" - , nest 2 $ prettyTCM t - ] - | c@(Candidate q v t overlap) <- fields - ] + 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 False + let lets = [ Candidate LocalCandidate v t DefaultOverlap | (_, LetBinding _ v Dom{domInfo = info, unDom = t}) <- env , isInstance info , usableModality info ] - return $ vars ++ fields ++ lets + 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 = @@ -139,17 +179,47 @@ (tel, args) <- lift $ forceEtaExpandRecord r pars v let types = map unDom $ applySubst (parallelS $ reverse $ map unArg args) (flattenTel tel) fmap concat $ forM (zip args types) $ \ (arg, t) -> - ([ Candidate LocalCandidate (unArg arg) t (isOverlappable arg) - | isInstance arg ] ++) <$> + ([ Candidate LocalCandidate (unArg arg) t (infoOverlapMode arg) + | isInstance arg + ] ++) <$> instanceFields' False (LocalCandidate, unArg arg, t) - getScopeDefs :: QName -> TCM [Candidate] + getScopeDefs :: QName -> BlockT TCM [Candidate] getScopeDefs n = do - instanceDefs <- getInstanceDefs - rel <- viewTC eRelevance - let qs = maybe [] Set.toList $ Map.lookup n instanceDefs - catMaybes <$> mapM (candidate rel) qs + rel <- viewTC eRelevance + InstanceTable tree counts <- lift getInstanceDefs + QueryResult qs blocker <- lift $ lookupDT (unEl instTy) tree + + mutual <- caseMaybeM (asksTC envMutualBlock) (pure mempty) \mb -> + mutualNames <$> lookupMutualBlock mb + + 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) + , "mutual block:" + , nest 2 (prettyTCM mutual) + ] + + cands <- catMaybes <$> mapM (lift . candidate rel) (toList qs) + + -- 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, @@ -167,18 +237,26 @@ -- if we anyway get the freeVarsToApply -- WAS: t <- defType <$> instantiateDef def args <- freeVarsToApply q - let t = defType def `piApply` args - rel = getRelevance $ defArgInfo def - let v = case theDef def of - -- drop parameters if it's a projection function... - Function{ funProjection = 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 - return $ Just $ Candidate (GlobalCandidate q) v t False + 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 + + return $ Just $ Candidate (GlobalCandidate q) v t mode where -- unbound constant throws an internal error handle (TypeError _ _ (Closure {clValue = InternalError _})) = return Nothing @@ -206,7 +284,10 @@ -- 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 +findInstance m Nothing = + ifM canDropRecursiveInstance (addConstraint neverUnblock (FindInstance m Nothing)) $ + -- Getting initial candidates can fail, in which case we should postpone (#7286) + catchConstraint (FindInstance m Nothing) $ do -- Andreas, 2015-02-07: New metas should be created with range of the -- current instance meta, thus, we set the range. mv <- lookupLocalMeta m @@ -219,7 +300,7 @@ -- potential candidates, so we add them to the context to make -- initialInstanceCandidates pick them up. TelV tel t <- telViewUpTo' (-1) notVisible t - cands <- addContext tel $ initialInstanceCandidates t + 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." @@ -239,27 +320,37 @@ 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 t') + cands <- ExceptT (initialInstanceCandidates False t') cands <- lift (checkCandidates m t' cands) <&> \case Nothing -> cands Just (_, cands) -> fst <$> cands - cands <- lift (foldrM insertCandidate [] cands) - reportSDoc "tc.instance.sort" 20 $ nest 2 $ vcat - [ "sorted candidates" - , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t - | c@(Candidate q v t overlap) <- 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. +-- | @'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 @@ -269,23 +360,26 @@ -- "flexible"; then calling the conversion checker. let - handle _ = do + 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) - . postponeInstanceConstraints - -- Don't spend any time looking for instances in the contexts + -- 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 (args, t2) <- implicitArgs (-1) (\h -> notVisible h) t2 - reportSDoc "tc.instance.sort" 30 $ "Does" <+> prettyTCM c1 <+> "specialise" <+> (prettyTCM c2 <> "?") + 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) @@ -297,36 +391,55 @@ reportSDoc "tc.instance.sort" 30 $ nest 2 "=> IS specialisation" pure True -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 +-- | 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 = ifM (isFrozen m) (do - reportSLn "tc.instance" 20 "Refusing to solve frozen instance meta." - return (Just (cands, neverUnblock))) $ do - ifM shouldPostponeInstanceSearch (do - reportSLn "tc.instance" 20 "Postponing possibly recursive instance search." - return $ Just (cands, neverUnblock)) $ billTo [Benchmark.Typing, Benchmark.InstanceSearch] $ do +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 - [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" - , nest 2 $ prettyTCM t ] | c@(Candidate q v t overlap) <- cands ] + reportSDoc "tc.instance" 60 $ nest 2 $ vcat $ map debugCandidate cands reportSDoc "tc.instance" 70 $ "raw" $$ do - nest 2 $ vcat - [ sep [ (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" - , nest 2 $ pretty t ] | c@(Candidate q v t overlap) <- cands ] + 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 @@ -339,11 +452,11 @@ 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..." @@ -356,14 +469,15 @@ setCurrentRange (take 1 $ map snd sortedErrs) $ typeError $ InstanceNoCandidate t [ (candidateTerm c, err) | (c, err) <- sortedErrs ] - Just (_, [(c@(Candidate q term t' _), v)]) -> do - + 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 @@ -384,6 +498,7 @@ 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 @@ -400,7 +515,7 @@ DontCare{} -> __IMPOSSIBLE__ Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s --- | Apply the computation to every argument in turn by reseting the state every +-- | 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 @@ -410,8 +525,12 @@ -- Also returns the candidates that pass type checking but fails constraints, -- so that the error messages can be reported if there are no successful -- candidates. -filterResetingState :: MetaId -> [Candidate] -> (Candidate -> TCM YesNo) -> TCM ([(Candidate, TCErr)], [(Candidate, Term)]) -filterResetingState m cands f = do +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 @@ -425,40 +544,179 @@ -- r : YesNo -- a : Type (fully instantiated) -- s : TCState - let result' = [ (c, v, s) | (c, (r, s)) <- result, v <- maybeToList (fromYes r) ] - result'' <- dropSameCandidates m result' + 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 + [(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 guards (`doesCandidateOverlap` new) + + 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 -> [(Candidate, Term, a)] -> TCM [(Candidate, Term, a)] -dropSameCandidates m cands0 = verboseBracket "tc.instance" 30 "dropSameCandidates" $ do +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))) + let freshMetas = getAny . allMetas (\m -> Any (not (isRemoteMeta m || m < nextMeta))) + rel <- getRelevance <$> lookupMetaModality m + -- Take overlappable candidates into account - let cands = - case List.partition (\ (c, _, _) -> candidateOverlappable c) cands0 of - (cand : _, []) -> [cand] -- only overlappable candidates: pick the first one - _ -> cands0 -- otherwise require equality + 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 ] ] - rel <- getRelevance <$> lookupMetaModality m + case cands of - [] -> return cands + [] -> return cands cvd : _ | isIrrelevant rel -> do reportSLn "tc.instance" 30 "dropSameCandidates: Meta is irrelevant so any candidate will do." return [cvd] @@ -469,9 +727,10 @@ | otherwise -> (cvd :) <$> dropWhileM equal vas where equal :: (Candidate, Term, a) -> TCM Bool - equal (_, v', _) - | freshMetas v' = return False -- If there are fresh metas we can't compare - | otherwise = + 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) @@ -479,13 +738,37 @@ Left{} -> False Right b -> b -data YesNo = Yes Term | No | NoBecause TCErr | HellNo TCErr +data YesNo = Yes Term Bool | No | NoBecause TCErr | HellNo TCErr deriving (Show) fromYes :: YesNo -> Maybe Term -fromYes (Yes t) = Just t -fromYes _ = Nothing +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. @@ -495,18 +778,16 @@ ifM (anyMetaTypes cands) (return Nothing) $ Just <$> do reportSDoc "tc.instance.candidates" 20 $ nest 2 $ "target:" <+> prettyTCM t reportSDoc "tc.instance.candidates" 20 $ nest 2 $ vcat - [ "candidates" - , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t - | c@(Candidate q v t overlap) <- cands ] ] - cands' <- filterResetingState m cands (checkCandidateForMeta m t) + [ "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 [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM c <+> ":" <+> prettyTCM t - | c@(Candidate q v t overlap) <- map fst (snd cands') ] ] + [ "valid candidates", vcat (map (debugCandidate . fst) okay) ] reportSDoc "tc.instance.candidates" 60 $ nest 2 $ vcat - [ "valid candidates" - , vcat [ "-" <+> (if overlap then "overlap" else empty) <+> prettyTCM v <+> ":" <+> prettyTCM t - | c@(Candidate q v t overlap) <- map fst (snd cands') ] ] + [ "valid candidates", vcat (map (debugCandidateTerm . fst) okay) ] + return cands' where anyMetaTypes :: [Candidate] -> TCM Bool @@ -526,6 +807,9 @@ 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 @@ -557,7 +841,24 @@ , nest 2 $ "<=" , nest 4 $ pretty t ] - leqType t'' 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 @@ -570,7 +871,13 @@ reportSDoc "tc.instance" 15 $ sep [ ("instance search: found solution for" <+> prettyTCM m) <> ":" , nest 2 $ prettyTCM v ] - return $ Yes v + + 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 @@ -583,17 +890,26 @@ handle :: TCErr -> TCM YesNo handle err - | hardFailure err = return $ HellNo 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 - return No + 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 = isInstanceConstraint . clValue . theConstraint +isInstanceProblemConstraint c = case clValue (theConstraint c) of + FindInstance{} -> True + UnquoteTactic{} -> True + _ -> False wakeupInstanceConstraints :: TCM () wakeupInstanceConstraints = @@ -634,3 +950,149 @@ 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 Nothing + +-- | Register the definition with the given type as an instance. +addTypedInstance' + :: Bool -- ^ Should we print warnings for unusable instance declarations? + -> Maybe InstanceInfo -- ^ Is this instance a copy? + -> QName -- ^ Name of instance. + -> Type -- ^ Type of instance. + -> TCM () +addTypedInstance' w orig x t = do + reportSDoc "tc.instance.add" 30 $ vcat + [ "adding typed instance" <+> prettyTCM x <+> "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 <- insertDT (length tele) hdt x =<< getsTC (view stInstanceTree) + setTCLens stInstanceTree tree + + modifyTCLens' (stSignature . sigInstances . itableCounts) $ + Map.insertWith (+) n 1 + + 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 x \ 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 x + -- 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 x + + OutputTypeNameNotYetKnown b -> do + addUnknownInstance x + addConstraint b $ ResolveInstanceHead x + + NoOutputTypeName -> when w $ warning $ WrongInstanceDeclaration + OutputTypeVar -> when w $ warning $ WrongInstanceDeclaration + OutputTypeVisiblePi -> when w $ warning $ InstanceWithExplicitArg x + +resolveInstanceHead :: QName -> TCM () +resolveInstanceHead q = do + clearUnknownInstance q + -- Andreas, 2022-12-04, issue #6380: + -- Do not warn about unusable instances here. + addTypedInstance' False 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) (flip deleteFromDT todo) (iSignature int) + pure int{ iSignature = sig' } diff --git a/src/full/Agda/TypeChecking/InstanceArguments.hs-boot b/src/full/Agda/TypeChecking/InstanceArguments.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/InstanceArguments.hs-boot @@ -0,0 +1,7 @@ +module Agda.TypeChecking.InstanceArguments where + +import Agda.TypeChecking.Monad.Base (TCM, InstanceInfo) + +import Agda.Syntax.Internal (QName, Type) + +addTypedInstance' :: Bool -> Maybe InstanceInfo -> QName -> Type -> TCM () diff --git a/src/full/Agda/TypeChecking/Irrelevance.hs b/src/full/Agda/TypeChecking/Irrelevance.hs --- a/src/full/Agda/TypeChecking/Irrelevance.hs +++ b/src/full/Agda/TypeChecking/Irrelevance.hs @@ -77,16 +77,14 @@ import Control.Monad.Except -import Agda.Interaction.Options - import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.Syntax.Concrete.Pretty import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute.Class +import Agda.TypeChecking.Telescope import Agda.Utils.Lens import Agda.Utils.Maybe @@ -298,8 +296,7 @@ instance UsableModality a => UsableModality (Dom a) where usableMod mod Dom{unDom = u} = usableMod mod u -usableAtModality' - :: MonadConstraint TCM +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. @@ -309,61 +306,9 @@ whenM (maybe (pure True) isFibrant ms) $ do res <- runExceptT $ usableMod mod t case res of - Right b -> unless b $ - typeError . GenericDocError =<< formatWhy + Right b -> unless b $ typeError $ UnusableAtModality why mod t Left blocker -> patternViolation blocker - where - formatWhy = do - compatible <- optCubicalCompatible <$> pragmaOptions - cubical <- isJust . optCubical <$> pragmaOptions - 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" - ++ [pure (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" - ++ [pure (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" - <+> pure (attributesForModality mod) - _ -> prettyTCM t <+> "is not usable at the required modality" - <+> pure (attributesForModality mod) - - usableAtModality :: MonadConstraint TCM => WhyCheckModality -> Modality -> Term -> TCM () usableAtModality = usableAtModality' Nothing @@ -386,6 +331,12 @@ :: (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 diff --git a/src/full/Agda/TypeChecking/MetaVars.hs b/src/full/Agda/TypeChecking/MetaVars.hs --- a/src/full/Agda/TypeChecking/MetaVars.hs +++ b/src/full/Agda/TypeChecking/MetaVars.hs @@ -1,7 +1,6 @@ {-# OPTIONS_GHC -Wunused-imports #-} {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GADTs #-} module Agda.TypeChecking.MetaVars where @@ -12,7 +11,6 @@ import Control.Monad.Trans ( lift ) import Control.Monad.Trans.Maybe -import Data.Function (on) import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap import qualified Data.List as List @@ -25,10 +23,12 @@ 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) +import Agda.Syntax.Position (getRange, killRange) import Agda.TypeChecking.Monad -- import Agda.TypeChecking.Monad.Builtin @@ -112,18 +112,17 @@ BlockedConst{} -> True PostponedTypeCheckingProblem{} -> True InstV{} -> False - Open{} -> False - OpenInstance{} -> False + OpenMeta{} -> False reportSLn "tc.meta.blocked" 12 $ if r then " yes, because " ++ prettyShow i else " no" return r -isEtaExpandable :: [MetaKind] -> MetaId -> TCM Bool -isEtaExpandable kinds x = do +isEtaExpandable :: [MetaClass] -> MetaId -> TCM Bool +isEtaExpandable classes x = do i <- lookupMetaInstantiation x return $ case i of - Open{} -> True - OpenInstance{} -> Records `notElem` kinds + OpenMeta UnificationMeta -> True + OpenMeta InstanceMeta -> Records `notElem` classes InstV{} -> False BlockedConst{} -> False PostponedTypeCheckingProblem{} -> False @@ -245,7 +244,7 @@ let i = i0 { miNameSuggestion = s } TelV tel _ <- telView t let perm = idP (size tel) - x <- newMeta' OpenInstance Instantiable i normalMetaPriority perm (HasType () CmpLeq t) + x <- newMeta' (OpenMeta InstanceMeta) Instantiable i normalMetaPriority perm (HasType () CmpLeq t) reportSDoc "tc.meta.new" 50 $ fsep [ nest 2 $ pretty x <+> ":" <+> prettyTCM t ] @@ -268,6 +267,17 @@ 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) @@ -382,10 +392,12 @@ -> Args -- ^ Parameters of record type. -> Telescope -> Permutation -> Args -> TCM Term newRecordMetaCtx pref frozen r pars tel perm ctx = do - ftel <- flip apply pars <$> getRecordFieldTypes r + rdef <- getRecordDef r + let con = killRange $ _recConHead rdef + -- Get the record field types as telescope. + let ftel = apply (_recTel rdef) pars fields <- newArgsMetaCtx'' pref frozen trueCondition (telePi_ ftel __DUMMY_TYPE__) tel perm ctx - con <- getRecordConstructor r return $ Con con ConOSystem (map Apply fields) newQuestionMark :: InteractionId -> Comparison -> Type -> TCM (MetaId, Term) @@ -650,7 +662,7 @@ -- | 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 :: [MetaKind] -> MetaId -> TCM () +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 @@ -810,7 +822,7 @@ let boundary v = do - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption isip <- isInteractionMetaB x args case (,) <$> cubical <*> isip of Just (_, (x, ip, args)) -> tryAddBoundary dir x ip args v target @@ -1354,8 +1366,7 @@ case mvInstantiation m of BlockedConst{} -> postpone PostponedTypeCheckingProblem{} -> postpone - Open{} -> postpone - OpenInstance{} -> postpone + OpenMeta{} -> postpone InstV inst -> do let n = size (instTel inst) t = jMetaType $ mvJudgement m @@ -1668,10 +1679,10 @@ | skip tm = return vars | otherwise = failure tm irrProj <- optIrrelevantProjections <$> pragmaOptions - lift (isRecordConstructor $ conName c) >>= \case - Just (_, r@Record{ recFields = fs }) - | YesEta <- recEtaEquality r -- Andreas, 2019-11-10, issue #4185: only for eta-records - , length fs == length es + 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} = diff --git a/src/full/Agda/TypeChecking/MetaVars/Mention.hs b/src/full/Agda/TypeChecking/MetaVars/Mention.hs --- a/src/full/Agda/TypeChecking/MetaVars/Mention.hs +++ b/src/full/Agda/TypeChecking/MetaVars/Mention.hs @@ -113,6 +113,7 @@ -- problem and we don't have a handle on -- what metas it depends on FindInstance{} -> True -- this needs to be woken up for any meta + ResolveInstanceHead q -> True -- TODO IsEmpty r t -> mm t CheckSizeLtSat t -> mm t CheckFunDef{} -> True -- not sure what metas this depends on diff --git a/src/full/Agda/TypeChecking/Modalities.hs b/src/full/Agda/TypeChecking/Modalities.hs --- a/src/full/Agda/TypeChecking/Modalities.hs +++ b/src/full/Agda/TypeChecking/Modalities.hs @@ -22,6 +22,8 @@ import Agda.TypeChecking.Pretty import Agda.TypeChecking.Substitute +import Agda.Utils.Function +import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad @@ -34,19 +36,18 @@ drel -> do -- Andreas,, 2018-06-09, issue #2170 -- irrelevant projections are only allowed if --irrelevant-projections - ifM (return (isJust $ isProjection_ $ theDef def) `and2M` + 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 = Just . GenericDocError <$> do - sep [ "Projection " , prettyTCM x, " is irrelevant." - , " Turn on option --irrelevant-projections to use it (unsafe)." - ] + needIrrProj = return $ Just $ ProjectionIsIrrelevant x -- | The second argument is the definition of the first. -- Returns 'Nothing' if ok, otherwise the error message. diff --git a/src/full/Agda/TypeChecking/Monad/Base.hs b/src/full/Agda/TypeChecking/Monad/Base.hs --- a/src/full/Agda/TypeChecking/Monad/Base.hs +++ b/src/full/Agda/TypeChecking/Monad/Base.hs @@ -4,6 +4,7 @@ module Agda.TypeChecking.Monad.Base ( module Agda.TypeChecking.Monad.Base + , module Agda.TypeChecking.Monad.Base.Types , HasOptions (..) , RecordFieldWarning ) where @@ -62,6 +63,8 @@ import GHC.Generics (Generic) +import System.IO (hFlush, stdout) + import Agda.Benchmarking (Benchmark, Phase) import {-# SOURCE #-} Agda.Compiler.Treeless.Pretty () -- Instances only @@ -82,38 +85,39 @@ import Agda.Syntax.Notation import Agda.Syntax.Position import Agda.Syntax.Scope.Base -import qualified Agda.Syntax.Info as Info +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) +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) --- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend --- conflicts with Args, defined in Agda.Syntax.Internal and also imported here. --- This only matters when interpreted in ghci, which sees all of the module's --- exported symbols, not just the ones defined in the `.hs-boot`. See the --- comment in ../../Compiler/Backend.hs-boot -import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args) +import Agda.TypeChecking.DiscrimTree.Types +import Agda.Compiler.Backend.Base + import Agda.Interaction.Options import Agda.Interaction.Options.Warnings -import {-# SOURCE #-} Agda.Interaction.Response - (InteractionOutputCallback, defaultInteractionOutputCallback) +import Agda.Interaction.Response.Base (Response_boot(..)) import Agda.Interaction.Highlighting.Precise (HighlightingInfo, NameKind) import Agda.Interaction.Library +import Agda.Interaction.Library.Base (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.FileName import Agda.Utils.Functor import Agda.Utils.Hash +import Agda.Utils.IO ( showIOException ) import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.ListT @@ -125,9 +129,9 @@ import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Syntax.Common.Pretty -import Agda.Utils.Singleton -import Agda.Utils.SmallSet (SmallSet) +import Agda.Utils.SmallSet (SmallSet, SmallSetElement) import qualified Agda.Utils.SmallSet as SmallSet +import Agda.Utils.Singleton import Agda.Utils.Update import Agda.Utils.Impossible @@ -206,10 +210,6 @@ , stPreImportedBuiltins :: !(BuiltinThings PrimFun) , stPreImportedDisplayForms :: !DisplayForms -- ^ Display forms added by someone else to imported identifiers - , stPreImportedInstanceDefs :: !InstanceTable - , stPreForeignCode :: !(Map BackendName ForeignCodeStack) - -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output. - -- Does not include code for imported modules. , stPreFreshInteractionId :: !InteractionId , stPreImportedUserWarnings :: !(Map A.QName Text) -- ^ Imported @UserWarning@s, not to be stored in the @Interface@ @@ -274,11 +274,18 @@ -- context of the module parameters. , stPostImportsDisplayForms :: !DisplayForms -- ^ Display forms we add for imported identifiers + , stPostForeignCode :: !(Map BackendName ForeignCodeStack) + -- ^ @{-\# 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. - , stPostInstanceDefs :: !TempInstanceTable + + , 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) @@ -321,7 +328,7 @@ -- | A mutual block of names in the signature. data MutualBlock = MutualBlock - { mutualInfo :: Info.MutualInfo + { mutualInfo :: MutualInfo -- ^ The original info of the mutual block. , mutualNames :: Set QName } deriving (Show, Eq, Generic) @@ -350,7 +357,7 @@ , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache) -- ^ Cached typechecking state from the last loaded file. -- Should be @Nothing@ when checking imports. - , stPersistBackends :: [Backend] + , stPersistBackends :: [Backend_boot TCM] -- ^ Current backends with their options } deriving Generic @@ -426,8 +433,6 @@ , stPrePragmaOptions = defaultInteractionOptions , stPreImportedBuiltins = Map.empty , stPreImportedDisplayForms = HMap.empty - , stPreImportedInstanceDefs = Map.empty - , stPreForeignCode = Map.empty , stPreFreshInteractionId = 0 , stPreImportedUserWarnings = Map.empty , stPreLocalUserWarnings = Map.empty @@ -455,7 +460,8 @@ , stPostModuleCheckpoints = Map.empty , stPostImportsDisplayForms = HMap.empty , stPostCurrentModule = empty - , stPostInstanceDefs = (Map.empty , Set.empty) + , stPostPendingInstances = Set.empty + , stPostTemporaryInstances = Set.empty , stPostConcreteNames = Map.empty , stPostUsedNames = Map.empty , stPostShadowingNames = Map.empty @@ -477,6 +483,7 @@ , stPostLocalPartialDefs = Set.empty , stPostOpaqueBlocks = Map.empty , stPostOpaqueIds = Map.empty + , stPostForeignCode = Map.empty } initState :: TCState @@ -547,8 +554,8 @@ stForeignCode :: Lens' TCState (Map BackendName ForeignCodeStack) stForeignCode f s = - f (stPreForeignCode (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}} + f (stPostForeignCode (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostForeignCode = x}} stFreshInteractionId :: Lens' TCState InteractionId stFreshInteractionId f s = @@ -597,7 +604,7 @@ f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&> \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}} -stBackends :: Lens' TCState [Backend] +stBackends :: Lens' TCState [Backend_boot TCM] stBackends f s = f (stPersistBackends (stPersistentState s)) <&> \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}} @@ -731,16 +738,22 @@ Nothing -> Nothing Just (!m, !top) -> Just (m, top)}} -stImportedInstanceDefs :: Lens' TCState InstanceTable -stImportedInstanceDefs f s = - f (stPreImportedInstanceDefs (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}} - stInstanceDefs :: Lens' TCState TempInstanceTable stInstanceDefs f s = - f (stPostInstanceDefs (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}} + 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 f s = f (stPostTemporaryInstances (stPostScopeState s)) <&> \x -> s { + stPostScopeState = (stPostScopeState s) { stPostTemporaryInstances = x } } + +stInstanceTree :: Lens' TCState (DiscrimTree QName) +stInstanceTree = stSignature . sigInstances . itableTree + stConcreteNames :: Lens' TCState ConcreteNames stConcreteNames f s = f (stPostConcreteNames (stPostScopeState s)) <&> @@ -1017,7 +1030,7 @@ } deriving (Show, Generic, NFData) data Interface = Interface - { iSourceHash :: Hash + { iSourceHash :: !Hash -- ^ Hash of the source code. , iSource :: TL.Text -- ^ The source code. The source code is stored so that the HTML @@ -1209,6 +1222,8 @@ | FindInstance MetaId (Maybe [Candidate]) -- ^ the first argument is the instance argument and the second one is the list of candidates -- (or Nothing if we haven’t determined the list of candidates yet) + | 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 @@ -1243,6 +1258,7 @@ 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) @@ -1266,6 +1282,7 @@ 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) @@ -1457,12 +1474,13 @@ | Instantiable deriving (Eq, Show, Generic) +-- | Solution status of meta. data MetaInstantiation - = InstV Instantiation -- ^ solved - | Open -- ^ unsolved - | OpenInstance -- ^ open, to be instantiated by instance search - | BlockedConst Term -- ^ solution blocked by unsolved constraints - | PostponedTypeCheckingProblem (Closure TypeCheckingProblem) + = 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. @@ -1538,8 +1556,8 @@ instance Pretty MetaInstantiation where pretty = \case - Open -> "Open" - OpenInstance -> "OpenInstance" + 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) ] @@ -1582,9 +1600,6 @@ instance LensRelevance MetaInfo where mapRelevance f = mapModality (mapRelevance f) --- | Name suggestion for meta variable. Empty string means no suggestion. -type MetaNameSuggestion = String - -- | For printing, we couple a meta with its name suggestion. data NamedMeta = NamedMeta { nmSuggestion :: MetaNameSuggestion @@ -1782,9 +1797,10 @@ --------------------------------------------------------------------------- data Signature = Sig - { _sigSections :: Sections - , _sigDefinitions :: Definitions - , _sigRewriteRules:: RewriteRuleMap -- ^ The rewrite rules defined in this file. + { _sigSections :: Sections + , _sigDefinitions :: Definitions + , _sigRewriteRules :: RewriteRuleMap -- ^ The rewrite rules defined in this file. + , _sigInstances :: InstanceTable } deriving (Show, Generic) @@ -1798,6 +1814,9 @@ 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) <&> @@ -1826,7 +1845,7 @@ \x -> s {_secTelescope = x} emptySignature :: Signature -emptySignature = Sig Map.empty HMap.empty HMap.empty +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 @@ -2024,6 +2043,13 @@ } 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. @@ -2084,8 +2110,8 @@ , defDisplay :: [LocalDisplayForm] , defMutual :: MutualId , defCompiledRep :: CompiledRepresentation - , defInstance :: Maybe QName - -- ^ @Just q@ when this definition is an instance of class q + , defInstance :: Maybe InstanceInfo + -- ^ @Just q@ when this definition is an instance. , defCopy :: Bool -- ^ Has this function been created by a module -- instantiation? @@ -2238,7 +2264,7 @@ -- 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@. + -- 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. @@ -2293,8 +2319,21 @@ = 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 (Eq, Ord, Enum, Show, Generic) + | 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 @@ -2382,7 +2421,6 @@ -- Does include this function. -- Empty list if not recursive. -- @Nothing@ if not yet computed (by positivity checker). - , _funAbstr :: IsAbstract , _funProjection :: Either ProjectionLikenessMissing Projection -- ^ Is it a record projection? -- If yes, then return the name of the record type and index of @@ -2390,10 +2428,8 @@ -- it is already applied to the record. (Can happen in module -- instantiation.) This information is used in the termination -- checker. - , _funErasure :: !Bool - -- ^ Was @--erasure@ in effect when the function was defined? - -- (This can affect the type of a projection.) - , _funFlags :: Set FunctionFlag + , _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 @@ -2419,10 +2455,8 @@ -> [Clause] -> FunctionInverse -> Maybe [QName] - -> IsAbstract -> Either ProjectionLikenessMissing Projection - -> Bool - -> Set FunctionFlag + -> SmallSet FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName @@ -2437,9 +2471,7 @@ , funCovering , funInv , funMutual - , funAbstr , funProjection - , funErasure , funFlags , funTerminates , funExtLam @@ -2454,9 +2486,7 @@ funCovering funInv funMutual - funAbstr funProjection - funErasure funFlags funTerminates funExtLam @@ -2761,6 +2791,10 @@ 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 @@ -2811,9 +2845,7 @@ _funCovering funInv funMutual - funAbstr funProjection - funErasure funFlags funTerminates _funExtLam @@ -2828,9 +2860,7 @@ , "funTreeless =" pretty funTreeless , "funInv =" pretty funInv , "funMutual =" pshow funMutual - , "funAbstr =" pshow funAbstr , "funProjection =" pretty funProjection - , "funErasure =" pretty funErasure , "funFlags =" pshow funFlags , "funTerminates =" pshow funTerminates , "funWith =" pretty funWith @@ -2960,28 +2990,34 @@ -- | Is the record type recursive? recRecursive :: Defn -> Bool -recRecursive (Record { recMutual = Just qs }) = not $ null qs +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 = do - erasure <- optErasure <$> pragmaOptions - return $ FunctionData +emptyFunctionData = emptyFunctionData_ . optErasure <$> pragmaOptions + +emptyFunctionData_ :: Bool -> FunctionData +emptyFunctionData_ erasure = FunctionData { _funClauses = [] , _funCompiled = Nothing , _funSplitTree = Nothing , _funTreeless = Nothing , _funInv = NotInjective , _funMutual = Nothing - , _funAbstr = ConcreteDef , _funProjection = Left MaybeProjection - , _funErasure = erasure - , _funFlags = Set.empty + , _funFlags = SmallSet.fromList [ FunErasure | erasure ] , _funTerminates = Nothing , _funExtLam = Nothing , _funWith = Nothing @@ -2993,17 +3029,59 @@ 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 def@Function{ funFlags = flags } = - f (Set.member flag flags) <&> - \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags } -funFlag _ f def = f False $> def +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) @@ -3214,17 +3292,17 @@ defTerminationUnconfirmed _ = False defAbstract :: Definition -> IsAbstract -defAbstract d = case theDef d of - Axiom{} -> ConcreteDef - DataOrRecSig{} -> ConcreteDef - GeneralizableVar{} -> ConcreteDef - AbstractDefn{} -> AbstractDef - Function{funAbstr = a} -> a - Datatype{dataAbstr = a} -> a - Record{recAbstr = a} -> a - Constructor{conAbstr = a} -> a - Primitive{primAbstr = a} -> a - PrimitiveSort{} -> ConcreteDef +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 @@ -3434,10 +3512,35 @@ -- ** 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) +-- | 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 + +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 @@ -3582,6 +3685,12 @@ , 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. @@ -3659,8 +3768,8 @@ -- 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. + -- ^ 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 @@ -3721,6 +3830,7 @@ , envSolvingConstraints = False , envCheckingWhere = False , envActiveProblems = Set.empty + , envUnquoteProblem = Nothing , envWorkingOnTypes = False , envAssignMetas = True , envAbstractMode = ConcreteMode @@ -3976,14 +4086,6 @@ } --------------------------------------------------------------------------- --- ** Context ---------------------------------------------------------------------------- - --- | The @Context@ is a stack of 'ContextEntry's. -type Context = [ContextEntry] -type ContextEntry = Dom (Name, Type) - ---------------------------------------------------------------------------- -- ** Let bindings --------------------------------------------------------------------------- @@ -4085,16 +4187,19 @@ -- | A candidate solution for an instance meta is a term with its type. -- It may be the case that the candidate is not fully applied yet or -- of the wrong type, hence the need for the type. -data Candidate = Candidate { candidateKind :: CandidateKind - , candidateTerm :: Term - , candidateType :: Type - , candidateOverlappable :: Bool - } +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 @@ -4136,6 +4241,11 @@ -- ^ '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 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 [Range] -- ^ Do not use directly with 'warning' | UnsolvedInteractionMetas [Range] -- ^ Do not use directly with 'warning' @@ -4147,7 +4257,11 @@ | CantGeneralizeOverSorts [MetaId] | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern] | OldBuiltin BuiltinId BuiltinId - -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new + -- ^ 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 @@ -4192,15 +4306,14 @@ -- ^ A coinductive record was declared but neither --guardedness nor -- --sized-types is enabled. - -- Generic warnings for one-off things - | GenericWarning Doc - -- ^ Harmless generic warning (not an error) - -- Safe flag errors | SafeFlagPostulate C.Name | SafeFlagPragma [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 @@ -4221,6 +4334,12 @@ -- ^ 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. + | IllegalRewriteRule QName IllegalRewriteRuleReason | RewriteNonConfluent Term Term Term Doc -- ^ Confluence checker found critical pair and equality checking -- resulted in a type error @@ -4235,14 +4354,20 @@ -- ^ 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 + -- ^ COMPILE directive for an erased symbol. + | PragmaCompileList + -- ^ @COMPILE GHC@ pragma for lists; ignored. + | PragmaCompileMaybe + -- ^ @COMPILE GHC@ pragma for @MAYBE@; ignored. + | NoMain TopLevelModuleName + -- ^ Compiler run on module that does not have a @main@ function. | NotInScopeW [C.QName] - -- ^ Out of scope error we can recover from + -- ^ Out of scope error we can recover from. | UnsupportedIndexedMatch Doc -- ^ Was not able to compute a full equivalence when splitting. - | AsPatternShadowsConstructorOrPatternSynonym Bool - -- ^ The as-name in an as-pattern may not shadow a constructor (@False@) - -- or pattern synonym name (@True@), + | AsPatternShadowsConstructorOrPatternSynonym LHSOrPatSyn + -- ^ The as-name in an as-pattern may not shadow a constructor ('IsLHS') + -- or pattern synonym name ('IsPatSyn'), -- because this can be confusing to read. | PatternShadowsConstructor C.Name A.QName -- ^ A pattern variable has the name of a constructor @@ -4250,6 +4375,9 @@ | PlentyInHardCompileTimeMode QωOrigin -- ^ Explicit use of @@ω@ or @@plenty@ in hard compile-time mode. | RecordFieldWarning RecordFieldWarning + + | MissingTypeSignatureForOpaque QName IsOpaque + -- ^ An @abstract@ or @opaque@ definition lacks a type signature. | NotAffectedByOpaque | UnfoldTransparentName QName | UselessOpaque @@ -4263,6 +4391,8 @@ -- Not source code related | DuplicateInterfaceFiles AbsolutePath AbsolutePath -- ^ `DuplicateInterfaceFiles selectedInterfaceFile ignoredInterfaceFile` + | CustomBackendWarning String Doc + -- ^ Used for backend-specific warnings. The string is the backend name. deriving (Show, Generic) recordFieldWarningToError :: RecordFieldWarning -> TypeError @@ -4286,6 +4416,7 @@ CoverageNoExactSplit{} -> CoverageNoExactSplit_ InlineNoExactSplit{} -> InlineNoExactSplit_ DeprecationWarning{} -> DeprecationWarning_ + DuplicateRecordDirective{} -> DuplicateRecordDirective_ EmptyRewritePragma -> EmptyRewritePragma_ EmptyWhere -> EmptyWhere_ IllformedAsClause{} -> IllformedAsClause_ @@ -4297,18 +4428,21 @@ FixityInRenamingModule{} -> FixityInRenamingModule_ InvalidCharacterLiteral{} -> InvalidCharacterLiteral_ UselessPragma{} -> UselessPragma_ - GenericWarning{} -> GenericWarning_ InversionDepthReached{} -> InversionDepthReached_ InteractionMetaBoundaries{} -> InteractionMetaBoundaries_{} ModuleDoesntExport{} -> ModuleDoesntExport_ NoGuardednessFlag{} -> NoGuardednessFlag_ 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_ @@ -4323,11 +4457,17 @@ UserWarning{} -> UserWarning_ InfectiveImport{} -> InfectiveImport_ CoInfectiveImport{} -> CoInfectiveImport_ + ConfluenceCheckingIncompleteBecauseOfMeta{} -> ConfluenceCheckingIncompleteBecauseOfMeta_ + ConfluenceForCubicalNotSupported{} -> ConfluenceForCubicalNotSupported_ + IllegalRewriteRule _ reason -> illegalRewriteWarningName reason RewriteNonConfluent{} -> RewriteNonConfluent_ RewriteMaybeNonConfluent{} -> RewriteMaybeNonConfluent_ RewriteAmbiguousRules{} -> RewriteAmbiguousRules_ RewriteMissingRule{} -> RewriteMissingRule_ PragmaCompileErased{} -> PragmaCompileErased_ + PragmaCompileList{} -> PragmaCompileList_ + PragmaCompileMaybe{} -> PragmaCompileMaybe_ + NoMain{} -> NoMain_ PlentyInHardCompileTimeMode{} -> PlentyInHardCompileTimeMode_ -- record field warnings @@ -4335,6 +4475,7 @@ W.DuplicateFields{} -> DuplicateFields_ W.TooManyFields{} -> TooManyFields_ + MissingTypeSignatureForOpaque{} -> MissingTypeSignatureForOpaque_ NotAffectedByOpaque{} -> NotAffectedByOpaque_ UselessOpaque{} -> UselessOpaque_ UnfoldTransparentName{} -> UnfoldTransparentName_ @@ -4346,11 +4487,37 @@ -- Not source code related DuplicateInterfaceFiles{} -> DuplicateInterfaceFiles_ --- Indicates wether changes in the source code can silence or influence the --- warning. + -- Backend warnings + CustomBackendWarning{} -> CustomBackendWarning_ + +illegalRewriteWarningName :: IllegalRewriteRuleReason -> WarningName +illegalRewriteWarningName = \case + LHSNotDefinitionOrConstructor{} -> RewriteLHSNotDefinitionOrConstructor_ + VariablesNotBoundByLHS{} -> RewriteVariablesNotBoundByLHS_ + VariablesBoundMoreThanOnce{} -> RewriteVariablesBoundMoreThanOnce_ + LHSReduces{} -> RewriteLHSReduces_ + HeadSymbolIsProjection{} -> RewriteHeadSymbolIsProjection_ + 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 DuplicateInterfaceFiles_{} = False -isSourceCodeWarning _ = True +isSourceCodeWarning = \case + DuplicateInterfaceFiles_ -> False + WarningProblem_ -> False + _ -> True data TCWarning = TCWarning @@ -4465,6 +4632,7 @@ | DefInsteadOfCon QName String String | NonCanonical String I.Term | BlockedOnMeta TCState Blocker + | PatLamWithoutClauses I.Term | UnquotePanic String deriving (Show, Generic) @@ -4538,9 +4706,7 @@ -- ^ 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. + | SplitOnCoinductive | SplitOnIrrelevant (Dom Type) | SplitOnUnusableCohesion (Dom Type) -- UNUSED: -- | SplitOnErased (Dom Type) @@ -4552,6 +4718,7 @@ | SplitInProp DataOrRecordE | DefinitionIsIrrelevant QName | DefinitionIsErased QName + | ProjectionIsIrrelevant QName | VariableIsIrrelevant Name | VariableIsErased Name | VariableIsOfUnusableCohesion Name Cohesion @@ -4600,6 +4767,7 @@ -- ^ Record type, fields not supplied by user, non-fields but supplied. | DuplicateFields [C.Name] | DuplicateConstructors [C.Name] + | DuplicateOverlapPragma QName OverlapMode OverlapMode | WithOnFreeVariable A.Expr Term | UnexpectedWithPatterns [A.Pattern] | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern) @@ -4627,7 +4795,6 @@ | TooManyArgumentsToUnivOmega QName | ComatchingDisabledForRecord QName | BuiltinMustBeIsOne Term - | IllegalRewriteRule QName IllegalRewriteRuleReason | IncorrectTypeForRewriteRelation Term IncorrectTypeForRewriteRelationReason -- Data errors | UnexpectedParameter A.LamBinding @@ -4637,13 +4804,32 @@ | 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 errors | TooManyPolarities QName Int + | 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. -- Import errors + | LibraryError LibErrors + -- ^ Collected errors when processing the @.agda-lib@ file. | LocalVsImportedModuleClash ModuleName | SolvedButOpenHoles -- ^ Some interaction points (holes) have not been filled by user. @@ -4661,6 +4847,8 @@ | 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. -- Scope errors | BothWithAndRHS | AbstractConstructorNotInScope A.QName @@ -4674,6 +4862,8 @@ | ClashingModule A.ModuleName A.ModuleName | ClashingImport C.Name A.QName | ClashingModuleImport C.Name A.ModuleName + | DefinitionInDifferentModule A.QName + -- ^ The given data/record definition rests in a different module than its signature. | DuplicateImports C.QName [C.ImportedName] | InvalidPattern C.Pattern | RepeatedVariablesInPattern [C.Name] @@ -4691,11 +4881,24 @@ | NothingAppliedToHiddenArg C.Expr | NothingAppliedToInstanceArg C.Expr -- Pattern synonym errors + | AsPatternInPatternSynonym + | DotPatternInPatternSynonym | BadArgumentsToPatternSynonym A.AmbiguousQName | TooFewArgumentsToPatternSynonym A.AmbiguousQName | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn)) - | UnusedVariableInPatternSynonym + | 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. + | PatternSynonymArgumentShadowsConstructorOrPatternSynonym LHSOrPatSyn 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 [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) @@ -4727,8 +4930,17 @@ -- Instance search errors | InstanceSearchDepthExhausted Term Type Int | TriedToCopyConstrainedPrim QName + -- Backend errors + | CustomBackendError String Doc + -- ^ Used for backend-specific errors. The string is the backend name. deriving (Show, Generic) +-- | Extra information for 'InvalidFileName' error. +data InvalidFileNameReason + = DoesNotCorrespondToValidModuleName + | RootNameModuleNotAQualifiedModuleName Text + deriving (Show, Generic) + type DataOrRecordE = DataOrRecord' InductionAndEta data InductionAndEta = InductionAndEta @@ -4738,21 +4950,22 @@ -- Reason, why rewrite rule is invalid data IllegalRewriteRuleReason - = LHSNotDefOrConstr + = LHSNotDefinitionOrConstructor | VariablesNotBoundByLHS IntSet | VariablesBoundMoreThanOnce IntSet - | LHSReducesTo Term Term + | LHSReduces Term Term | HeadSymbolIsProjection QName | HeadSymbolIsProjectionLikeFunction QName - | HeadSymbolNotPostulateFunctionConstructor QName - | HeadSymbolDefContainsMetas QName - | ConstructorParamsNotGeneral ConHead Args + | HeadSymbolIsTypeConstructor QName + | HeadSymbolContainsMetas QName + | ConstructorParametersNotGeneral ConHead Args | ContainsUnsolvedMetaVariables (Set MetaId) | BlockedOnProblems (Set ProblemId) | RequiresDefinitions (Set QName) | DoesNotTargetRewriteRelation | BeforeFunctionDefinition - | EmptyReason + | BeforeMutualFunctionDefinition QName + | DuplicateRewriteRule deriving (Show, Generic) -- Reason, why type for rewrite rule is incorrect @@ -4764,7 +4977,7 @@ -- | Distinguish error message when parsing lhs or pattern synonym, resp. data LHSOrPatSyn = IsLHS | IsPatSyn - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Bounded, Enum) -- | Type-checking errors. @@ -4791,8 +5004,7 @@ instance Show TCErr where show (TypeError _ _ e) = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e) show (Exception r d) = prettyShow r ++ ": " ++ render d - show (IOException _ r e) = prettyShow r ++ ": " ++ - E.displayException e + show (IOException _ r e) = prettyShow r ++ ": " ++ showIOException e show PatternErr{} = "Pattern violation (you shouldn't see this)" instance HasRange TCErr where @@ -4803,6 +5015,12 @@ instance E.Exception TCErr +-- | Assorted warnings and errors to be displayed to the user +data WarningsAndNonFatalErrors = WarningsAndNonFatalErrors + { tcWarnings :: [TCWarning] + , nonFatalErrors :: [TCWarning] + } + ----------------------------------------------------------------------------- -- * Accessing options ----------------------------------------------------------------------------- @@ -4832,6 +5050,10 @@ 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 #-} @@ -4879,6 +5101,8 @@ 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) @@ -5522,6 +5746,50 @@ liftIO $ void $ C.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 --------------------------------------------------------------------------- @@ -5561,8 +5829,11 @@ --------------------------------------------------------------------------- instance KillRange Signature where - killRange (Sig secs defs rews) = killRangeN Sig secs defs rews + 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 @@ -5575,6 +5846,10 @@ 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 gens gpars displ mut compiled inst copy ma nc inj copat blk lang def) = killRangeN Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def @@ -5639,8 +5914,8 @@ DataOrRecSig n -> DataOrRecSig n GeneralizableVar -> GeneralizableVar AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'! - Function a b c d e f g h i j k l m n o p -> - killRangeN Function a b c d e f g h i j k l m n o p + 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 @@ -5737,6 +6012,7 @@ instance NFData WhyCheckModality instance NFData Constraint instance NFData Signature +instance NFData InstanceTable instance NFData Comparison instance NFData CompareAs instance NFData a => NFData (Open a) @@ -5764,6 +6040,7 @@ instance NFData NLPType instance NFData NLPSort instance NFData RewriteRule +instance NFData InstanceInfo instance NFData Definition instance NFData Polarity instance NFData IsForced @@ -5814,6 +6091,7 @@ instance NFData UnificationFailure instance NFData UnquoteError instance NFData TypeError +instance NFData InvalidFileNameReason instance NFData LHSOrPatSyn instance NFData DataOrRecordE instance NFData InductionAndEta diff --git a/src/full/Agda/TypeChecking/Monad/Base.hs-boot b/src/full/Agda/TypeChecking/Monad/Base.hs-boot --- a/src/full/Agda/TypeChecking/Monad/Base.hs-boot +++ b/src/full/Agda/TypeChecking/Monad/Base.hs-boot @@ -9,6 +9,7 @@ import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.FileName (AbsolutePath) +data Definition data Warning data TCErr diff --git a/src/full/Agda/TypeChecking/Monad/Base/Types.hs b/src/full/Agda/TypeChecking/Monad/Base/Types.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Monad/Base/Types.hs @@ -0,0 +1,17 @@ +-- | Data structures for the type checker. +-- +-- Part of "Agda.TypeChecking.Monad.Base", extracted to avoid import cycles. + +module Agda.TypeChecking.Monad.Base.Types where + +import Agda.Syntax.Internal + +--------------------------------------------------------------------------- +-- ** Context +--------------------------------------------------------------------------- + +-- | The @Context@ is a stack of 'ContextEntry's. +type Context = [ContextEntry] +type ContextEntry = Dom (Name, Type) + +-- Feel free to move more types from Agda.TypeChecking.Monad.Base here when needed... diff --git a/src/full/Agda/TypeChecking/Monad/Builtin.hs b/src/full/Agda/TypeChecking/Monad/Builtin.hs --- a/src/full/Agda/TypeChecking/Monad/Builtin.hs +++ b/src/full/Agda/TypeChecking/Monad/Builtin.hs @@ -139,8 +139,13 @@ Map.insertWith unionBuiltin (BuiltinName builtinRewrite) (BuiltinRewriteRelations $ singleton x) -- | Get the currently registered rewrite relation symbols. -getBuiltinRewriteRelations :: HasBuiltins m => m (Maybe (Set QName)) -getBuiltinRewriteRelations = fmap rels <$> getBuiltinThing (BuiltinName builtinRewrite) +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 @@ -286,9 +291,11 @@ primAgdaTCMAskNormalisation, primAgdaTCMAskReconstructed, primAgdaTCMAskExpandLast, primAgdaTCMAskReduceDefs, primAgdaTCMNoConstraints, + primAgdaTCMWorkOnTypes, primAgdaTCMRunSpeculative, primAgdaTCMExec, primAgdaTCMGetInstances, + primAgdaTCMSolveInstances, primAgdaTCMPragmaForeign, primAgdaTCMPragmaCompile :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term @@ -502,9 +509,11 @@ primAgdaTCMFormatErrorParts = getBuiltin builtinAgdaTCMFormatErrorParts primAgdaTCMDebugPrint = getBuiltin builtinAgdaTCMDebugPrint primAgdaTCMNoConstraints = getBuiltin builtinAgdaTCMNoConstraints +primAgdaTCMWorkOnTypes = getBuiltin builtinAgdaTCMWorkOnTypes primAgdaTCMRunSpeculative = getBuiltin builtinAgdaTCMRunSpeculative primAgdaTCMExec = getBuiltin builtinAgdaTCMExec primAgdaTCMGetInstances = getBuiltin builtinAgdaTCMGetInstances +primAgdaTCMSolveInstances = getBuiltin builtinAgdaTCMSolveInstances primAgdaTCMPragmaForeign = getBuiltin builtinAgdaTCMPragmaForeign primAgdaTCMPragmaCompile = getBuiltin builtinAgdaTCMPragmaCompile diff --git a/src/full/Agda/TypeChecking/Monad/Constraints.hs b/src/full/Agda/TypeChecking/Monad/Constraints.hs --- a/src/full/Agda/TypeChecking/Monad/Constraints.hs +++ b/src/full/Agda/TypeChecking/Monad/Constraints.hs @@ -35,9 +35,20 @@ return x isProblemSolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool -isProblemSolved pid = +isProblemSolved = isProblemSolved' False + +isProblemCompletelySolved :: (MonadTCEnv m, ReadTCState m) => ProblemId -> m Bool +isProblemCompletelySolved = isProblemSolved' True + +isProblemSolved' :: (MonadTCEnv m, ReadTCState m) => Bool -> ProblemId -> m Bool +isProblemSolved' completely pid = and2M (not . Set.member pid <$> asksTC envActiveProblems) - (not . any (Set.member pid . constraintProblems) <$> getAllConstraints) + (not . any belongsToUs <$> getAllConstraints) + where + belongsToUs c + | Set.notMember pid (constraintProblems c) = False + | isBlockingConstraint (clValue $ theConstraint c) = True + | otherwise = completely -- Ignore non-blocking unless `completely` {-# SPECIALIZE getConstraintsForProblem :: ProblemId -> TCM Constraints #-} getConstraintsForProblem :: ReadTCState m => ProblemId -> m Constraints @@ -181,32 +192,38 @@ addConstraintTo :: Lens' TCState Constraints -> Blocker -> Constraint -> TCM () addConstraintTo bucket unblock c = do - pc <- build + pc <- buildConstraint unblock c stDirty `setTCLens` True bucket `modifyTCLens` (pc :) - where - build | isBlocking c = buildConstraint unblock c - | otherwise = buildProblemConstraint_ unblock c - isBlocking = \case - SortCmp{} -> False - LevelCmp{} -> False - FindInstance{} -> False - HasBiggerSort{} -> False - HasPTSRule{} -> False - 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 +-- | A problem is considered solved if there are no unsolved blocking constraints belonging to it. +-- There's no really good principle for what constraints are blocking and which are not, but the +-- general idea is that nothing bad should happen if you assume a non-blocking constraint is +-- solvable, but it turns out it isn't. For instance, assuming an equality constraint between two +-- types that turns out to be false can lead to ill typed terms in places where we don't expect +-- them. +isBlockingConstraint :: Constraint -> Bool +isBlockingConstraint = \case + SortCmp{} -> False + LevelCmp{} -> False + FindInstance{} -> False + ResolveInstanceHead{} -> False + HasBiggerSort{} -> False + HasPTSRule{} -> False + CheckDataSort{} -> False + ValueCmp{} -> True + ValueCmpOnFace{} -> True + ElimCmp{} -> True + UnBlock{} -> True + IsEmpty{} -> True + CheckSizeLtSat{} -> True + CheckFunDef{} -> True + UnquoteTactic{} -> True + CheckMetaInst{} -> True + CheckType{} -> True + CheckLockedVars{} -> True + UsableAtModality{} -> True + -- | Start solving constraints nowSolvingConstraints :: MonadTCEnv m => m a -> m a nowSolvingConstraints = localTC $ \e -> e { envSolvingConstraints = True } @@ -222,11 +239,13 @@ isInstanceConstraint FindInstance{} = True isInstanceConstraint _ = False -shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool -shouldPostponeInstanceSearch = +canDropRecursiveInstance :: (ReadTCState m, HasOptions m) => m Bool +canDropRecursiveInstance = and2M ((^. stConsideringInstance) <$> getTCState) - (not . optOverlappingInstances <$> pragmaOptions) - `or2M` ((^. stPostponeInstanceSearch) <$> 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'). diff --git a/src/full/Agda/TypeChecking/Monad/Context.hs b/src/full/Agda/TypeChecking/Monad/Context.hs --- a/src/full/Agda/TypeChecking/Monad/Context.hs +++ b/src/full/Agda/TypeChecking/Monad/Context.hs @@ -485,11 +485,12 @@ -- | get type of bound variable (i.e. deBruijn index) -- +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 = do - ctx <- getContext - return $ raise (n + 1) <$> ctx !!! n +lookupBV' n = lookupBV_ n <$> getContext {-# SPECIALIZE lookupBV :: Nat -> TCM (Dom (Name, Type)) #-} lookupBV :: (MonadFail m, MonadTCEnv m) => Nat -> m (Dom (Name, Type)) diff --git a/src/full/Agda/TypeChecking/Monad/Debug.hs b/src/full/Agda/TypeChecking/Monad/Debug.hs --- a/src/full/Agda/TypeChecking/Monad/Debug.hs +++ b/src/full/Agda/TypeChecking/Monad/Debug.hs @@ -20,14 +20,13 @@ import Data.Maybe import Data.Time ( getCurrentTime, getCurrentTimeZone, utcToLocalTime ) -import Data.Time.Format.ISO8601.Compat ( iso8601Show ) - -- This is also exported from Data.Time.Format.ISO8601, but only from time >= 1.9 +import Data.Time.Format.ISO8601 ( iso8601Show ) import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base import Agda.Interaction.Options -import {-# SOURCE #-} Agda.Interaction.Response (Response(..)) +import Agda.Interaction.Response.Base (Response_boot(..)) import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack ) import Agda.Utils.Lens diff --git a/src/full/Agda/TypeChecking/Monad/MetaVars.hs b/src/full/Agda/TypeChecking/Monad/MetaVars.hs --- a/src/full/Agda/TypeChecking/Monad/MetaVars.hs +++ b/src/full/Agda/TypeChecking/Monad/MetaVars.hs @@ -24,6 +24,7 @@ import GHC.Stack (HasCallStack) import Agda.Syntax.Common +import Agda.Syntax.Info ( MetaKind (InstanceMeta, UnificationMeta), MetaNameSuggestion ) import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Position @@ -56,9 +57,9 @@ import Agda.Utils.Impossible --- | Various kinds of metavariables. +-- | Various classes of metavariables. -data MetaKind = +data MetaClass = Records -- ^ Meta variables of record type. | SingletonRecords @@ -67,10 +68,10 @@ -- ^ Meta variables of level type, if type-in-type is activated. deriving (Eq, Enum, Bounded, Show) --- | All possible metavariable kinds. +-- | All possible metavariable classes. -allMetaKinds :: [MetaKind] -allMetaKinds = [minBound .. maxBound] +allMetaClasses :: [MetaClass] +allMetaClasses = [minBound .. maxBound] data KeepMetas = KeepMetas | RollBackMetas @@ -108,8 +109,8 @@ assignTerm' :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m () -- | 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. - etaExpandMeta :: [MetaKind] -> MetaId -> m () + -- 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 () @@ -304,6 +305,15 @@ 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 @@ -418,6 +428,7 @@ -- 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 @@ -647,7 +658,7 @@ -- | Generate new meta variable. newMeta :: MonadMetaSolver m => Frozen -> MetaInfo -> MetaPriority -> Permutation -> Judgement a -> m MetaId -newMeta = newMeta' Open +newMeta = newMeta' (OpenMeta UnificationMeta) -- | Generate a new meta variable with some instantiation given. -- For instance, the instantiation could be a 'PostponedTypeCheckingProblem'. @@ -716,8 +727,7 @@ getOpenMetas = MapS.keys <$> useR stOpenMetaStore isOpenMeta :: MetaInstantiation -> Bool -isOpenMeta Open = True -isOpenMeta OpenInstance = True +isOpenMeta OpenMeta{} = True isOpenMeta BlockedConst{} = True isOpenMeta PostponedTypeCheckingProblem{} = True isOpenMeta InstV{} = False diff --git a/src/full/Agda/TypeChecking/Monad/Options.hs b/src/full/Agda/TypeChecking/Monad/Options.hs --- a/src/full/Agda/TypeChecking/Monad/Options.hs +++ b/src/full/Agda/TypeChecking/Monad/Options.hs @@ -58,6 +58,24 @@ 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). -- @@ -103,7 +121,7 @@ unless (null warns) $ warnings $ map LibraryWarning warns case z of - Left s -> typeError $ GenericDocError s + Left s -> typeError $ LibraryError s Right x -> return x -- | Returns the library files for a given file. @@ -205,14 +223,29 @@ -- or is a security risk. return o{ optTrustedExecutables = trustedExes } +-- | Set pragma options without checking for consistency. setOptionsFromPragma :: OptionsPragma -> TCM () -setOptionsFromPragma ps = setCurrentRange (pragmaRange ps) $ do +setOptionsFromPragma = setOptionsFromPragma' False + +-- | Set pragma options and check them for consistency. +checkAndSetOptionsFromPragma :: OptionsPragma -> TCM () +checkAndSetOptionsFromPragma = setOptionsFromPragma' True + +setOptionsFromPragma' :: Bool -> OptionsPragma -> TCM () +setOptionsFromPragma' checkConsistency ps = setCurrentRange (pragmaRange ps) $ do opts <- commandLineOptions let (z, warns) = runOptM (parsePragmaOptions ps opts) mapM_ (warning . OptionWarning) warns case z of Left err -> typeError $ GenericError err - Right opts' -> setPragmaOptions opts' + Right opts' -> do + + -- Check consistency of implied options + when checkConsistency $ do + oldOpts <- pragmaOptions + checkPragmaOptionConsistency oldOpts opts' + + setPragmaOptions opts' -- | Disable display forms. enableDisplayForms :: MonadTCEnv m => m a -> m a diff --git a/src/full/Agda/TypeChecking/Monad/Pure.hs-boot b/src/full/Agda/TypeChecking/Monad/Pure.hs-boot --- a/src/full/Agda/TypeChecking/Monad/Pure.hs-boot +++ b/src/full/Agda/TypeChecking/Monad/Pure.hs-boot @@ -10,7 +10,7 @@ import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Builtin import {-# SOURCE #-} Agda.TypeChecking.Monad.Context -import Agda.TypeChecking.Monad.Debug +import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug import {-# SOURCE #-} Agda.TypeChecking.Monad.Signature class diff --git a/src/full/Agda/TypeChecking/Monad/Signature.hs b/src/full/Agda/TypeChecking/Monad/Signature.hs --- a/src/full/Agda/TypeChecking/Monad/Signature.hs +++ b/src/full/Agda/TypeChecking/Monad/Signature.hs @@ -51,6 +51,7 @@ 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 @@ -281,13 +282,17 @@ markInjective :: QName -> TCM () markInjective q = modifyGlobalDefinition q $ \def -> def { defInjective = True } +markFirstOrder :: QName -> TCM () +markFirstOrder = setFunctionFlag FunFirstOrder True + unionSignatures :: [Signature] -> Signature unionSignatures ss = foldr unionSignature emptySignature ss where - unionSignature (Sig a b c) (Sig a' b' c') = + unionSignature (Sig a b c d) (Sig a' b' c' d') = Sig (Map.union a a') - (HMap.union b b') -- definitions are unique (in at most one module) - (HMap.unionWith mappend c c') -- rewrite rules are accumulated + (HMap.union b b') -- definitions are unique (in at most one module) + (HMap.unionWith mappend c c') -- rewrite rules are accumulated + (d <> d') -- instances are accumulated -- | Add a section to the signature. -- @@ -445,30 +450,40 @@ -- and if a constructor is copied its datatype needs to be. closeConstructors :: Ren QName -> TCM (Ren QName) closeConstructors rd = do - ds <- nubOn id . catMaybes <$> traverse constructorData (Map.keys rd) - cs <- nubOn id . concat <$> traverse dataConstructors (Map.keys rd) + ds <- nubOn snd . catMaybes <$> traverse constructorData (Map.toList rd) + cs <- nubOn snd . concat <$> traverse dataConstructors (Map.toList rd) new <- Map.unionsWith (<>) <$> traverse rename (ds ++ cs) reportSDoc "tc.mod.apply.complete" 30 $ "also copying: " <+> pretty new return $ Map.unionWith (<>) new rd where - rename :: QName -> TCM (Ren QName) - rename x + rename :: (ModuleName, QName) -> TCM (Ren QName) + rename (m, x) | x `Map.member` rd = pure mempty | otherwise = - Map.singleton x . pure . qnameFromList . singleton <$> freshName_ (prettyShow $ qnameName x) + -- Ulf, 2024-06-24 (#7329): + -- Here we used to generate an unqualified name, but this breaks things if the new + -- module shows up in a module application later on. This is because we use the + -- module name to figure out which arguments from the application are relevant for + -- the current symbol (see argsToUse in applySection' below). + -- + -- Instead we use the target module name of the thing that required x to be copied. + -- For instance, if we are copying a data type A.B.D to X.Y.Z.D and its constructor + -- mkD is not in the renaming, we add `A.B.mkD -> X.Y.Z.mkD` (instead of `A.B.mkD -> + -- mkD` which we did before). + Map.singleton x . pure . qualify m <$> freshName_ (prettyShow $ qnameName x) - constructorData :: QName -> TCM (Maybe QName) - constructorData x = do + constructorData :: (QName, List1.List1 QName) -> TCM (Maybe (ModuleName, QName)) + constructorData (x, y List1.:| _) = do -- All new names share the same module, so we can safely grab the first one (theDef <$> getConstInfo x) <&> \case - Constructor{ conData = d } -> Just d + Constructor{ conData = d } -> Just (qnameModule y, d) _ -> Nothing - dataConstructors :: QName -> TCM [QName] - dataConstructors x = do + dataConstructors :: (QName, List1.List1 QName) -> TCM [(ModuleName, QName)] + dataConstructors (x, y List1.:| _) = do (theDef <$> getConstInfo x) <&> \case - Datatype{ dataCons = cs } -> cs - Record{ recConHead = h } -> [conName h] + Datatype{ dataCons = cs } -> map (qnameModule y,) cs + Record{ recConHead = h } -> [(qnameModule y, conName h)] _ -> [] applySection' :: ModuleName -> Telescope -> ModuleName -> Args -> ScopeCopyInfo -> TCM () @@ -502,6 +517,8 @@ -- equivalent valid names and either can be used. copyName x = maybe x List1.head (Map.lookup x rd) + copyConHead c = c { conName = copyName (conName c) } + argsToUse x = do let m = commonParentModule old x reportSDoc "tc.mod.apply" 80 $ "Common prefix: " <+> pretty m @@ -545,7 +562,7 @@ -- Issue5583: Don't skip constructures, because the original constructor doesn't always -- work. For instance if it's only available in an anonymous module generated by -- `open import M args`. - whenJust inst $ \ c -> addNamedInstance y c + whenJust inst $ \_ -> addTypedInstance' False 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 @@ -632,16 +649,19 @@ , dataClause = Just cl , dataCons = map copyName cs } - Record{ recPars = np, recTel = tel } -> return $ + Record{ recPars = np, recTel = tel, recConHead = c, recFields = fs } -> return $ oldDef { recPars = np - size ts' , recClause = Just cl , recTel = apply tel ts' + , recConHead = copyConHead c + , recFields = (map . fmap) copyName fs } GeneralizableVar -> return GeneralizableVar _ -> 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 $ @@ -743,6 +763,9 @@ ifM (isLocal q) (return $ ds ++ ds1 ++ ds2) (return $ ds1 ++ ds ++ ds2) +hasDisplayForms :: (HasConstInfo m, ReadTCState m) => QName -> m Bool +hasDisplayForms = fmap (not . null) . getDisplayForms + -- | Find all names used (recursively) by display forms of a given name. chaseDisplayForms :: QName -> TCM (Set QName) chaseDisplayForms q = go Set.empty [q] @@ -1083,6 +1106,11 @@ _ -> Nothing -- | Set the mutually recursive identifiers. +-- +-- TODO: This produces data of quadratic size (which has to be processed upon serialization). +-- Presumably qs is usually short, but in some cases (for instance for generated code) it may be +-- long. It would be better to assign a unique identifier to each SCC, and store the names +-- separately. setMutual :: QName -> [QName] -> TCM () setMutual d m = modifySignature $ updateDefinition d $ updateTheDef $ \ def -> case def of @@ -1392,7 +1420,7 @@ projectionArgs = maybe 0 (max 0 . pred . projIndex) . isRelevantProjection_ -- | Check whether a definition uses copatterns. -usesCopatterns :: (HasConstInfo m) => QName -> m Bool +usesCopatterns :: (HasConstInfo m, HasBuiltins m) => QName -> m Bool usesCopatterns q = defCopatternLHS <$> getConstInfo q -- | Apply a function @f@ to its first argument, producing the proper diff --git a/src/full/Agda/TypeChecking/Monad/Signature.hs-boot b/src/full/Agda/TypeChecking/Monad/Signature.hs-boot --- a/src/full/Agda/TypeChecking/Monad/Signature.hs-boot +++ b/src/full/Agda/TypeChecking/Monad/Signature.hs-boot @@ -13,7 +13,7 @@ ( TCM, ReadTCState, HasOptions, MonadTCEnv , Definition, RewriteRules ) -import Agda.TypeChecking.Monad.Debug (MonadDebug) +import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug) import Agda.Syntax.Common.Pretty (prettyShow) diff --git a/src/full/Agda/TypeChecking/Monad/State.hs b/src/full/Agda/TypeChecking/Monad/State.hs --- a/src/full/Agda/TypeChecking/Monad/State.hs +++ b/src/full/Agda/TypeChecking/Monad/State.hs @@ -6,6 +6,8 @@ import Control.Monad (void, when) import Control.Monad.Trans (MonadIO, liftIO) +import Control.Exception (evaluate) +import Control.DeepSeq (rnf) import Data.Maybe @@ -290,6 +292,12 @@ where setMatchable def = def { defMatchable = Set.insert f $ defMatchable def } +-- ** 'modify' methods for the signature + +modifyRecEta :: MonadTCState m => QName -> (EtaEquality -> EtaEquality) -> m () +modifyRecEta q f = + modifySignature $ updateDefinition q $ over (lensTheDef . lensRecord . lensRecEta) f + -- ** Modifiers for parts of the signature lookupDefinition :: QName -> Signature -> Maybe Definition @@ -507,14 +515,6 @@ -- * Instance definitions --------------------------------------------------------------------------- --- | Look through the signature and reconstruct the instance table. -addImportedInstances :: Signature -> TCM () -addImportedInstances sig = do - let itable = Map.fromListWith Set.union - [ (c, Set.singleton i) - | (i, Defn{ defInstance = Just c }) <- HMap.toList $ sig ^. sigDefinitions ] - stImportedInstanceDefs `modifyTCLens` Map.unionWith Set.union itable - -- | Lens for 'stInstanceDefs'. updateInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> (TCState -> TCState) updateInstanceDefs = over stInstanceDefs @@ -524,17 +524,18 @@ getAllInstanceDefs :: TCM TempInstanceTable getAllInstanceDefs = do - (table,xs) <- useTC stInstanceDefs - itable <- useTC stImportedInstanceDefs - let !table' = Map.unionWith Set.union itable table + (table, xs) <- useTC stInstanceDefs + itable <- useTC (stImports . sigInstances) + let table' = table <> itable + () <- liftIO $ evaluate (rnf table') return (table', xs) getAnonInstanceDefs :: TCM (Set QName) getAnonInstanceDefs = snd <$> getAllInstanceDefs --- | Remove all instances whose type is still unresolved. -clearAnonInstanceDefs :: TCM () -clearAnonInstanceDefs = modifyInstanceDefs $ mapSnd $ const Set.empty +-- | Remove an instance from the set of unresolved instances. +clearUnknownInstance :: QName -> TCM () +clearUnknownInstance q = modifyInstanceDefs $ mapSnd $ Set.delete q -- | Add an instance whose type is still unresolved. addUnknownInstance :: QName -> TCM () @@ -543,16 +544,3 @@ "adding definition " ++ prettyShow x ++ " to the instance table (the type is not yet known)" modifyInstanceDefs $ mapSnd $ Set.insert x - --- | Add instance to some ``class''. -addNamedInstance - :: QName -- ^ Name of the instance. - -> QName -- ^ Name of the class. - -> TCM () -addNamedInstance x n = do - reportSLn "tc.decl.instance" 10 $ - "adding definition " ++ prettyShow x ++ " to instance table for " ++ prettyShow n - -- Mark x as instance for n. - modifySignature $ updateDefinition x $ \ d -> d { defInstance = Just n } - -- Add x to n's instances. - modifyInstanceDefs $ mapFst $ Map.insertWith Set.union n $ Set.singleton x diff --git a/src/full/Agda/TypeChecking/Names.hs b/src/full/Agda/TypeChecking/Names.hs --- a/src/full/Agda/TypeChecking/Names.hs +++ b/src/full/Agda/TypeChecking/Names.hs @@ -168,7 +168,7 @@ {-# INLINABLE absAppN #-} absAppN :: Subst a => AbsN a -> [SubstArg a] -> a -absAppN f xs = (parallelS $ reverse xs) `applySubst` unAbsN f +absAppN f xs = parallelS (reverse xs) `applySubst` unAbsN f type ArgVars m = (forall b. (Subst b, DeBruijn b) => [NamesT m (Arg b)]) diff --git a/src/full/Agda/TypeChecking/Opacity.hs b/src/full/Agda/TypeChecking/Opacity.hs --- a/src/full/Agda/TypeChecking/Opacity.hs +++ b/src/full/Agda/TypeChecking/Opacity.hs @@ -39,9 +39,8 @@ -- saturated unfolding sets. saturateOpaqueBlocks :: forall m. (MonadTCState m, ReadTCState m, MonadFresh OpaqueId m, MonadDebug m, MonadTrace m, MonadWarning m, MonadIO m) - => [A.Declaration] - -> m () -saturateOpaqueBlocks moddecs = entry where + => m () +saturateOpaqueBlocks = entry where entry = do known <- useTC stOpaqueBlocks inverse <- useTC stOpaqueIds diff --git a/src/full/Agda/TypeChecking/Patterns/Abstract.hs b/src/full/Agda/TypeChecking/Patterns/Abstract.hs --- a/src/full/Agda/TypeChecking/Patterns/Abstract.hs +++ b/src/full/Agda/TypeChecking/Patterns/Abstract.hs @@ -7,6 +7,7 @@ import Control.Monad.Except import qualified Data.List as List +import Data.Functor import Data.Void import qualified Agda.Syntax.Abstract as A @@ -19,6 +20,7 @@ import Agda.Syntax.Position import Agda.TypeChecking.Monad +import Agda.TypeChecking.Pretty import Agda.TypeChecking.Warnings (raiseWarningsOnUsage) import Agda.Utils.Impossible @@ -88,7 +90,12 @@ -- synonyms could get into dot patterns (which is __IMPOSSIBLE__). p <- expandPatternSynonyms' (vacuous p :: A.Pattern' e) - case A.insertImplicitPatSynArgs (A.WildP . PatRange) (getRange x) ns as of + reportSDoc "scope.patsyn" 80 $ vcat + [ "calling insertImplicitPatSynArgs" + , "- patsyn parameters: " <+> (text . show) (killRange ns) + , "- patsyn arguments: " <+> (text . show) (fmap (fmap void) as) + ] + case A.insertImplicitPatSynArgs (\ _h r -> A.WildP (PatRange r)) (getRange x) ns as of Nothing -> typeError $ BadArgumentsToPatternSynonym x Just (_, _:_) -> typeError $ TooFewArgumentsToPatternSynonym x Just (s, []) -> do diff --git a/src/full/Agda/TypeChecking/Patterns/Internal.hs b/src/full/Agda/TypeChecking/Patterns/Internal.hs --- a/src/full/Agda/TypeChecking/Patterns/Internal.hs +++ b/src/full/Agda/TypeChecking/Patterns/Internal.hs @@ -1,7 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE GADTs #-} - -- | Tools to manipulate patterns in internal syntax -- in the TCM (type checking monad). diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs b/src/full/Agda/TypeChecking/Patterns/Match.hs --- a/src/full/Agda/TypeChecking/Patterns/Match.hs +++ b/src/full/Agda/TypeChecking/Patterns/Match.hs @@ -33,11 +33,11 @@ import Agda.Utils.Impossible --- | If matching is inconclusive (@DontKnow@) we want to know whether --- it is due to a particular meta variable. +-- | If matching is inconclusive (@DontKnow@) we want to know whether it is on a +-- lazy pattern and whether it is due to a particular meta variable. data Match a = Yes Simplification (IntMap (Arg a)) | No - | DontKnow (Blocked ()) + | DontKnow OnlyLazy (Blocked ()) deriving Functor instance Null (Match a) where @@ -64,10 +64,10 @@ instance Semigroup (Match a) where -- @NotBlocked (StuckOn e)@ means blocked by a variable. -- In this case, no instantiation of meta-variables will make progress. - DontKnow b <> DontKnow b' = DontKnow $ b <> b' - DontKnow m <> _ = DontKnow m - _ <> DontKnow m = DontKnow m - -- One could imagine DontKnow _ <> No = No, but would break the + DontKnow l b <> DontKnow l' b' = DontKnow (l <> l') (b <> b') + DontKnow l m <> _ = DontKnow l m + _ <> DontKnow l m = DontKnow l m + -- One could imagine DontKnow _ _ <> No = No, but would break the -- equivalence to case-trees (Issue 2964). No <> _ = No _ <> No = No @@ -77,6 +77,18 @@ mempty = empty mappend = (<>) +-- | Whether the inconclusive matches are only on lazy patterns. +data OnlyLazy = OnlyLazy | NonLazy + +instance Semigroup OnlyLazy where + NonLazy <> _ = NonLazy + _ <> NonLazy = NonLazy + OnlyLazy <> OnlyLazy = OnlyLazy + +instance Monoid OnlyLazy where + mempty = OnlyLazy + mappend = (<>) + -- | Instead of 'zipWithM', we need to use this lazy version -- of combining pattern matching computations. @@ -118,7 +130,10 @@ -- contain ill-typed terms due to eta-expansion at wrong -- type. return (r <> r', v' : vs) - DontKnow m -> return (DontKnow m, v' : vs) + DontKnow OnlyLazy _ -> do + (r', _vs') <- loop ps vs + return (r <> r', v' : vs) + DontKnow NonLazy m -> return (DontKnow NonLazy m, v' : vs) Yes{} -> do (r', vs') <- loop ps vs return (r <> r', v' : vs') @@ -222,43 +237,48 @@ NotBlocked _ (Lit l') | l == l' -> return (Yes YesSimplification empty , arg') | otherwise -> return (No , arg') - Blocked b _ -> return (DontKnow $ Blocked b () , arg') - NotBlocked r t -> return (DontKnow $ NotBlocked r' () , arg') + Blocked b _ -> return (DontKnow NonLazy $ Blocked b () , arg') + NotBlocked r t -> return (DontKnow NonLazy $ NotBlocked r' () , arg') where r' = stuckOn (Apply arg') r -- Case constructor pattern. (ConP c cpi ps, Arg info v) -> do - if not (conPRecord cpi) then fallback c ps (Arg info v) else do - isEtaRecordCon (conName c) >>= \case - Nothing -> fallback c ps (Arg info v) - Just fs -> do - -- Case: Eta record constructor. - -- This case is necessary if we want to use the clauses before - -- record pattern translation (e.g., in type-checking definitions by copatterns). - unless (size fs == size ps) __IMPOSSIBLE__ - mapSnd (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do - matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f] - where - isEtaRecordCon :: HasConstInfo m => QName -> m (Maybe [Arg QName]) - isEtaRecordCon c = do - (theDef <$> getConstInfo c) >>= \case - Constructor{ conData = d } -> do - (theDef <$> getConstInfo d) >>= \case - r@Record{ recFields = fs } | YesEta <- recEtaEquality r -> return $ Just $ map argFromDom fs - _ -> return Nothing - _ -> __IMPOSSIBLE__ + let lazy = if conPLazy cpi then OnlyLazy else NonLazy + if not (conPRecord cpi) then fallback c lazy ps (Arg info v) else do + isEtaRecordConstructor (conName c) >>= \case + Nothing -> fallback c lazy ps (Arg info v) + -- Case: Eta record constructor. + -- This case is necessary if we want to use the clauses before + -- record pattern translation (e.g., in type-checking definitions by copatterns). + Just (_r, def) -> do + reportSDoc "tc.match" 50 $ vcat + [ "matchPattern: eta record" + , nest 2 $ "c = " <+> prettyTCM c + , nest 2 $ "ps = " <+> prettyTCMPatternList ps + , nest 2 $ "v = " <+> prettyTCM v + ] + -- Issue #7266: in case we are brazenly matching potentially ill-typed arguments, + -- `v` might be an application of a *different* constructor. + -- In that case we certainly have no match. + case v of + Con c' _ _ | c /= c' -> return (No, u) + _ -> do + let fs = map argFromDom $ _recFields def + unless (size fs == size ps) __IMPOSSIBLE__ + mapSnd (Arg info . Con c (fromConPatternInfo cpi) . map Apply) <$> do + matchPatterns ps $ for fs $ \ (Arg ai f) -> Arg ai $ v `applyE` [Proj ProjSystem f] (DefP o q ps, v) -> do let f (Def q' vs) | q == q' = Just (Def q, vs) f _ = Nothing - fallback' f ps v + fallback' f NonLazy ps v where -- Default: not an eta record constructor. fallback :: MonadMatch m - => ConHead -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term) - fallback c ps v = do + => ConHead -> OnlyLazy -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term) + fallback c lazy ps v = do let f (Con c' ci' vs) | c == c' = Just (Con c' ci',vs) f _ = Nothing - fallback' f ps v + fallback' f lazy ps v -- Regardless of blocking, constructors and a properly applied @hcomp@ -- can be matched on. @@ -279,10 +299,11 @@ -- DefP hcomp and ConP matching. fallback' :: MonadMatch m => (Term -> Maybe (Elims -> Term , Elims)) + -> OnlyLazy -> [NamedArg DeBruijnPattern] -> Arg Term -> m (Match Term, Arg Term) - fallback' mtc ps (Arg info v) = do + fallback' mtc lazy ps (Arg info v) = do isMatchable <- isMatchable' w <- reduceB v @@ -314,8 +335,8 @@ return (yesSimplification m, Arg info $ bld (mergeElims vs vs1)) Nothing -> return (No , arg) - Blocked b _ -> return (DontKnow $ Blocked b () , arg) - NotBlocked r _ -> return (DontKnow $ NotBlocked r' () , arg) + Blocked b _ -> return (DontKnow lazy $ Blocked b () , arg) + NotBlocked r _ -> return (DontKnow lazy $ NotBlocked r' () , arg) where r' = stuckOn (Apply arg) r yesSimplification :: Match a -> Match a diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs-boot b/src/full/Agda/TypeChecking/Patterns/Match.hs-boot --- a/src/full/Agda/TypeChecking/Patterns/Match.hs-boot +++ b/src/full/Agda/TypeChecking/Patterns/Match.hs-boot @@ -11,7 +11,9 @@ import Agda.Utils.Impossible -data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow (Blocked ()) +data Match a = Yes Simplification (IntMap (Arg a)) | No | DontKnow OnlyLazy (Blocked ()) + +data OnlyLazy = OnlyLazy | NonLazy buildSubstitution :: (DeBruijn a) => Impossible -> Int -> IntMap (Arg a) -> Substitution' a diff --git a/src/full/Agda/TypeChecking/Positivity.hs b/src/full/Agda/TypeChecking/Positivity.hs --- a/src/full/Agda/TypeChecking/Positivity.hs +++ b/src/full/Agda/TypeChecking/Positivity.hs @@ -103,16 +103,24 @@ ] reportSLn "tc.pos.graph.sccs" 15 $ " sccs = " ++ prettyShow [ scc | CyclicSCC scc <- sccs ] - forM_ sccs $ \case - -- If the mutuality information has never been set, we set it to [] - AcyclicSCC (DefNode q) -> whenM (isNothing <$> getMutual q) $ do - reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to non-recursive" - -- Andreas, 2017-04-26, issue #2555 - -- We should not have @DefNode@s pointing outside our formal mutual block. - unless (Set.member q qset) __IMPOSSIBLE__ - setMutual q [] - AcyclicSCC (ArgNode{}) -> return () - CyclicSCC scc -> setMut [ q | DefNode q <- scc ] + + -- #7133: Note that the graph doesn't necessarily contain all of qs in the case where there are no + -- occurrences of a name, but we still need to setMutual for them. + let sccMap = Map.unions [ case scc of + AcyclicSCC (DefNode q) -> Map.singleton q [] + AcyclicSCC ArgNode{} -> mempty + CyclicSCC scc -> Map.fromList [ (q, qs) | q <- qs ] + where qs = [ q | DefNode q <- scc ] + | scc <- sccs ] + inAbstractMode $ forM_ qs $ \ q -> + whenM (isNothing <$> getMutual q) $ do + let qs = fromMaybe [] $ Map.lookup q sccMap + reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to " ++ + if | null qs -> "non-recursive" + | length qs == 1 -> "recursive" + | otherwise -> "mutually recursive" + setMutual q qs + mapM_ (checkPos g gstar) qs reportSDoc "tc.pos.tick" 100 $ "checked positivity" @@ -120,9 +128,9 @@ checkPos :: Graph Node (Edge OccursWhere) -> Graph Node Occurrence -> QName -> TCM () - checkPos g gstar q = inConcreteOrAbstractMode q $ \ _def -> do + checkPos g gstar q = inConcreteOrAbstractMode q $ \ def -> do -- we check positivity only for data or record definitions - whenJustM (isDatatype q) $ \ dr -> do + whenJust (isDatatype def) $ \ dr -> do reportSDoc "tc.pos.check" 10 $ "Checking positivity of" <+> prettyTCM q let loop :: Maybe Occurrence @@ -193,31 +201,16 @@ -- 'Inductive' or 'Coinductive'. Otherwise, error. unlessM (isJust . recInduction . theDef <$> getConstInfo q) $ setCurrentRange (nameBindingSite $ qnameName q) $ - typeError . GenericDocError =<< - "Recursive record" <+> prettyTCM q <+> - "needs to be declared as either inductive or coinductive" + typeError $ RecursiveRecordNeedsInductivity q occ (Edge o _) = o - isDatatype :: QName -> TCM (Maybe DataOrRecord) - isDatatype q = do - def <- theDef <$> getConstInfo q - return $ case def of + isDatatype :: Definition -> Maybe DataOrRecord + isDatatype def = do + case theDef def of Datatype{dataClause = Nothing} -> Just IsData Record {recClause = Nothing, recPatternMatching } -> Just $ IsRecord recPatternMatching _ -> Nothing - - -- Set the mutually recursive identifiers for a SCC. - setMut :: [QName] -> TCM () - setMut [] = return () -- nothing to do - setMut qs = forM_ qs $ \ q -> do - reportSLn "tc.pos.mutual" 10 $ "setting " ++ prettyShow q ++ " to (mutually) recursive" - setMutual q qs - -- TODO: The previous line produces data of quadratic size - -- (which has to be processed upon serialization). Presumably qs is - -- usually short, but in some cases (for instance for generated - -- code) it may be long. Wouldn't it be better to assign a - -- unique identifier to each SCC, and avoid storing lists? -- Set the polarity of the arguments to a couple of definitions setArgOccs :: Set QName -> [QName] -> Graph Node Occurrence -> TCM () diff --git a/src/full/Agda/TypeChecking/Pretty.hs b/src/full/Agda/TypeChecking/Pretty.hs --- a/src/full/Agda/TypeChecking/Pretty.hs +++ b/src/full/Agda/TypeChecking/Pretty.hs @@ -32,7 +32,7 @@ import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract.Pretty as AP -import Agda.Syntax.Concrete.Pretty (bracesAndSemicolons) +import Agda.Syntax.Concrete.Pretty (bracesAndSemicolons, prettyHiding) import qualified Agda.Syntax.Concrete.Pretty as CP import qualified Agda.Syntax.Info as A import Agda.Syntax.Scope.Base (AbstractName(..)) @@ -42,6 +42,7 @@ import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad import Agda.TypeChecking.Positivity.Occurrence +import Agda.TypeChecking.DiscrimTree.Types import Agda.TypeChecking.Substitute import qualified Agda.Utils.BiMap as BiMap @@ -51,9 +52,11 @@ import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Null +import Agda.Utils.Trie import Agda.Utils.Permutation ( Permutation ) import Agda.Syntax.Common.Pretty ( Pretty, prettyShow ) import qualified Agda.Syntax.Common.Pretty as P +import qualified Agda.Utils.Maybe.Strict as S import Agda.Utils.Size ( natSize ) import Agda.Utils.Impossible @@ -94,12 +97,13 @@ fwords :: Applicative m => String -> m Doc fwords s = pure $ P.fwords s -sep, fsep, hsep, hcat, vcat :: (Applicative m, Foldable t) => t (m Doc) -> m Doc +sep, fsep, hsep, hcat, vcat, vsep :: (Applicative m, Foldable t) => t (m Doc) -> m Doc sep ds = P.sep <$> sequenceA (Fold.toList ds) fsep ds = P.fsep <$> sequenceA (Fold.toList ds) hsep ds = P.hsep <$> sequenceA (Fold.toList ds) hcat ds = P.hcat <$> sequenceA (Fold.toList ds) vcat ds = P.vcat <$> sequenceA (Fold.toList ds) +vsep ds = P.vsep <$> sequenceA (Fold.toList ds) hang :: Applicative m => m Doc -> Int -> m Doc -> m Doc hang p n q = P.hang <$> p <*> pure n <*> q @@ -146,6 +150,13 @@ ds = Fold.toList ts n = length ds - 1 +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 --------------------------------------------------------------------------- @@ -486,12 +497,17 @@ prettyTCM (PVar x bvs) = prettyTCM (Var x (map (Apply . fmap var) bvs)) prettyTCM (PDef f es) = parens $ prettyTCM f <+> fsep (map prettyTCM es) - prettyTCM (PLam i u) = parens $ - text ("λ " ++ absName u ++ " →") <+> - addContext (absName u) (prettyTCM $ absBody u) - prettyTCM (PPi a b) = parens $ - text ("(" ++ absName b ++ " :") <+> (prettyTCM (unDom a) <> ") →") <+> - addContext (absName b) (prettyTCM $ unAbs b) + prettyTCM (PLam i u) = parens $ fsep + [ "λ" + , prettyHiding i id <$> text (absName u) + , "→" + , addContext (absName u) $ prettyTCM $ absBody u + ] + prettyTCM (PPi a b) = parens $ fsep + [ prettyHiding a P.parens <$> fsep [ text $ absName b, ":", prettyTCM $ unDom a ] + , "→" + , addContext (absName b) $ prettyTCM $ unAbs b + ] prettyTCM (PSort s) = prettyTCM s prettyTCM (PBoundVar i []) = prettyTCM (var i) prettyTCM (PBoundVar i es) = parens $ prettyTCM (var i) <+> fsep (map prettyTCM es) @@ -515,7 +531,7 @@ instance PrettyTCM (Elim' NLPat) where prettyTCM (IApply x y v) = prettyTCM v - prettyTCM (Apply v) = prettyTCM (unArg v) + prettyTCM (Apply v) = prettyHiding v id <$> prettyTCM (unArg v) prettyTCM (Proj _ f)= "." <> prettyTCM f {-# SPECIALIZE prettyTCM :: Elim' NLPat -> TCM Doc #-} @@ -572,3 +588,29 @@ (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 -> "Pi" + ConstK -> "Const" + SortK -> "Sort" + FlexK -> "_" + +{-# SPECIALIZE prettyTCM :: Key -> TCM Doc #-} + +instance PrettyTCM a => PrettyTCM (Set.Set a) where + prettyTCM = braces . prettyList_ . map prettyTCM . Set.toList + +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__ diff --git a/src/full/Agda/TypeChecking/Pretty/Constraint.hs b/src/full/Agda/TypeChecking/Pretty/Constraint.hs --- a/src/full/Agda/TypeChecking/Pretty/Constraint.hs +++ b/src/full/Agda/TypeChecking/Pretty/Constraint.hs @@ -100,8 +100,7 @@ BlockedConst t -> prettyCmp ":=" m t PostponedTypeCheckingProblem cl -> enterClosure cl $ \p -> prettyCmp ":=" m p - Open{} -> __IMPOSSIBLE__ - OpenInstance{} -> __IMPOSSIBLE__ + OpenMeta{} -> __IMPOSSIBLE__ InstV{} -> empty -- Andreas, 2017-01-11, issue #2637: -- The size solver instantiates some metas with infinity @@ -114,25 +113,35 @@ -- , 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 - ] + t <- getMetaTypeInContext m + TelV tel _ <- telViewUpTo' (-1) notVisible t + sep [ "Resolve instance argument" prettyCmp ":" m t + -- #4071: Non-visible arguments to the meta are in scope of the candidates add + -- those here to not get out of scope deBruijn indices when printing + -- unsolved constraints. + , addContext tel cands + ] where - cands = - case mcands of - Nothing -> "No candidates yet" - Just cnds -> - hang "Candidates" 2 $ vcat - [ hang (overlap c <+> prettyTCM c <+> ":") 2 $ - prettyTCM (candidateType c) | c <- cnds ] - where overlap c | candidateOverlappable c = "overlap" - | otherwise = empty + overlap c = case candidateOverlap c of + FieldOverlap -> "overlap" + Incoherent -> "[incoherent]" + Overlappable -> "[overlappable]" + Overlapping -> "[overlapping]" + Overlaps -> "[overlaps]" + DefaultOverlap -> empty + + cands = case mcands of + Nothing -> "No candidates yet" + Just cnds -> hang "Candidates" 2 $ vcat + [ hang (overlap c <+> prettyTCM c <+> ":") 2 $ + prettyTCM (candidateType c) + | c <- cnds + ] + + ResolveInstanceHead q -> + "Resolve target type of instance: " prettyTCM q IsEmpty r t -> "Is empty:" prettyTCMCtx TopCtx t CheckSizeLtSat t -> diff --git a/src/full/Agda/TypeChecking/Pretty/Warning.hs b/src/full/Agda/TypeChecking/Pretty/Warning.hs --- a/src/full/Agda/TypeChecking/Pretty/Warning.hs +++ b/src/full/Agda/TypeChecking/Pretty/Warning.hs @@ -10,6 +10,8 @@ import Data.Char ( toLower ) import Data.Function (on) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet import Data.Maybe import qualified Data.Set as Set @@ -35,7 +37,7 @@ import Agda.TypeChecking.Warnings (MonadWarning, isUnsolvedWarning, onlyShowIfUnsolved, classifyWarning, WhichWarnings(..), warning_) import {-# SOURCE #-} Agda.TypeChecking.MetaVars -import Agda.Syntax.Common ( getHiding, ImportedName'(..), fromImportedName, partitionImportedNames ) +import Agda.Syntax.Common ( IsOpaque(OpaqueDef, TransparentDef), getHiding, ImportedName'(..), fromImportedName, partitionImportedNames ) import Agda.Syntax.Position import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Scope.Base ( concreteNamesInScope, NameOrModule(..) ) @@ -45,7 +47,8 @@ import Agda.Interaction.Options import Agda.Interaction.Options.Warnings -import Agda.Utils.FileName (filePath) +import Agda.Utils.FileName ( filePath ) +import Agda.Utils.Functor ( (<.>) ) import Agda.Utils.Lens import Agda.Utils.List ( editDistance ) import qualified Agda.Utils.List1 as List1 @@ -133,6 +136,13 @@ [prettyTCM d] ++ pwords "is not strictly positive, because it occurs" ++ [prettyTCM ocs] + ConstructorDoesNotFitInData c s1 s2 err -> prettyTCM err + + 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." @@ -156,6 +166,10 @@ "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)" @@ -215,8 +229,6 @@ pwords "this type will likely be rejected by the termination" ++ pwords "checker unless this flag is enabled." - GenericWarning d -> return d - InvalidCharacterLiteral c -> fsep $ pwords "Invalid character literal" ++ [text $ show c] ++ pwords "(surrogate code points are not supported)" @@ -236,6 +248,14 @@ 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 @@ -277,6 +297,84 @@ CoInfectiveImport msg -> return msg + 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' ] + HeadSymbolIsProjection f -> hsep + [ prettyTCM q , " is not a legal rewrite rule, since the head symbol" + , prettyTCM f , "is a projection" + ] + 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_ (map prettyTCM $ Set.toList ms) + ] + BlockedOnProblems ps -> hsep + [ prettyTCM q , " is not a legal rewrite rule, since" + , "it is blocked on problem(s)", prettyList_ (map prettyTCM $ Set.toList ps) + ] + RequiresDefinitions qs -> hsep + [ prettyTCM q , " is not a legal rewrite rule, since" + , "it requires the definition(s) of", prettyList_ (map prettyTCM $ Set.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" @@ -319,6 +417,9 @@ ] ] + DuplicateRecordDirective dir -> + "Ignoring duplicate record directive: " <+> pretty dir + PragmaCompileErased bn qn -> fsep $ concat [ pwords "The backend" , [ text bn @@ -328,6 +429,17 @@ , 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." + + NoMain topLevelModule -> vcat + [ fsep $ pwords "No main function defined in" ++ [prettyTCM topLevelModule <> "."] + , fsep $ pwords "Use option --no-main to suppress this warning." + ] + NotInScopeW xs -> vcat [ fsep $ pwords "Not in scope:" , do @@ -348,7 +460,9 @@ AsPatternShadowsConstructorOrPatternSynonym patsyn -> fsep $ concat [ pwords "Name bound in @-pattern ignored because it shadows" - , if patsyn then pwords "pattern synonym" else [ "constructor" ] + , case patsyn of + IsPatSyn -> pwords "pattern synonym" + IsLHS -> [ "constructor" ] ] PatternShadowsConstructor x c -> fsep $ @@ -361,6 +475,18 @@ 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." UnfoldTransparentName qn -> fsep $ @@ -374,6 +500,8 @@ FaceConstraintCannotBeNamed x -> fsep $ pwords "Ignoring name" ++ ["`" <> pretty x <> "`"] ++ pwords "given to face constraint pattern" + CustomBackendWarning backend warn -> (text backend <> ":") pure warn + {-# SPECIALIZE prettyRecordFieldWarning :: RecordFieldWarning -> TCM Doc #-} prettyRecordFieldWarning :: MonadPretty m => RecordFieldWarning -> m Doc prettyRecordFieldWarning = \case @@ -449,10 +577,7 @@ prettyTCWarnings :: [TCWarning] -> TCM String -prettyTCWarnings = fmap (unlines . List.intersperse "" . map P.render) . prettyTCWarnings' - -renderTCWarnings' :: [TCWarning] -> TCM [String] -renderTCWarnings' = fmap (map P.render) . prettyTCWarnings' +prettyTCWarnings = List.intercalate "\n" <.> map P.render <.> prettyTCWarnings' prettyTCWarnings' :: [TCWarning] -> TCM [Doc] prettyTCWarnings' = traverse prettyTCM . filterTCWarnings diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical.hs b/src/full/Agda/TypeChecking/Primitive/Cubical.hs --- a/src/full/Agda/TypeChecking/Primitive/Cubical.hs +++ b/src/full/Agda/TypeChecking/Primitive/Cubical.hs @@ -183,8 +183,8 @@ let forward la bA r u = pure tTrans - <#> (lam "i" $ \i -> la <@> (i `imax` r)) - <@> (lam "i" $ \i -> bA <@> (i `imax` r)) + <#> lam "i" (\i -> la <@> (i `imax` r)) + <@> lam "i" (\i -> bA <@> (i `imax` r)) <@> r <@> u @@ -556,7 +556,7 @@ -- 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 + 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 @@ -872,7 +872,7 @@ 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 + <#> 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 diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs b/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs --- a/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs @@ -46,8 +46,6 @@ import Agda.TypeChecking.Reduce (Reduce(..), reduceB', reduce', reduce) import Agda.TypeChecking.Names (NamesT, runNamesT, ilam, lam) -import Agda.Interaction.Options.Base (optCubical) - import Agda.Syntax.Common (Cubical(..), Arg(..), Relevance(..), setRelevance, defaultArgInfo, hasQuantity0) @@ -65,7 +63,7 @@ -> String -- ^ Why, exactly, do we need Cubical to be enabled? -> TCM () requireCubical wanted s = do - cubical <- optCubical <$> pragmaOptions + cubical <- cubicalOption inErasedContext <- hasQuantity0 <$> viewTC eQuantity case cubical of Just CFull -> return () @@ -323,13 +321,13 @@ let pOr l ty phi psi u0 u1 = pure tPOr - <#> l <@> phi <@> psi <#> (ilam "o" $ \ _ -> ty) + <#> 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 [] = (iz,) <$> (pure tEmpty <#> l <#> ilam "o" (\ _ -> ty)) combine [(psi, u)] = (,) <$> psi <*> u combine ((psi, u):xs) = do (phi, c) <- combine xs diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs b/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs --- a/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs @@ -104,8 +104,8 @@ hPi' "x" (el' a bA) $ \ x -> hPi' "y" (el' a bA) $ \ y -> primIntervalType -- Cofibration - --> (el' a $ cl primPath <#> a <#> bA <@> x <@> y) - --> (el' a $ cl primId <#> a <#> bA <@> x <@> y) + --> el' a (cl primPath <#> a <#> bA <@> x <@> y) + --> el' a (cl primId <#> a <#> bA <@> x <@> y) -- Implementation note: conId, as the name implies, is a constructor. -- It's not represented as a constructor because users can't match on diff --git a/src/full/Agda/TypeChecking/ProjectionLike.hs b/src/full/Agda/TypeChecking/ProjectionLike.hs --- a/src/full/Agda/TypeChecking/ProjectionLike.hs +++ b/src/full/Agda/TypeChecking/ProjectionLike.hs @@ -81,6 +81,7 @@ import Agda.TypeChecking.DropArgs +import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad @@ -271,7 +272,7 @@ def@Function{funProjection = Left MaybeProjection, funClauses = cls, funSplitTree = st0, funCompiled = cc0, funInv = NotInjective, funMutual = Just [], -- Andreas, 2012-09-28: only consider non-mutual funs - funAbstr = ConcreteDef, funOpaque = TransparentDef} -> do + funOpaque = TransparentDef} | not (def ^. funAbstract) -> do ps0 <- filterM validProj $ candidateArgs [] t reportSLn "tc.proj.like" 30 $ if null ps0 then " no candidates found" else " candidates: " ++ prettyShow ps0 @@ -326,7 +327,7 @@ } 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{funOpaque = OpaqueDef _} -> reportSLn "tc.proj.like" 30 $ " opaque functions can't be projections" @@ -338,6 +339,7 @@ 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" diff --git a/src/full/Agda/TypeChecking/Quote.hs b/src/full/Agda/TypeChecking/Quote.hs --- a/src/full/Agda/TypeChecking/Quote.hs +++ b/src/full/Agda/TypeChecking/Quote.hs @@ -179,8 +179,8 @@ quoteSort PiSort{} = pure unsupportedSort quoteSort FunSort{} = pure unsupportedSort quoteSort UnivSort{} = pure unsupportedSort - quoteSort (MetaS x es) = quoteTerm $ MetaV x es - quoteSort (DefS d es) = quoteTerm $ Def d es + quoteSort (MetaS x es) = pure unsupportedSort + quoteSort (DefS d es) = pure unsupportedSort quoteSort (DummyS s) =__IMPOSSIBLE_VERBOSE__ s quoteType :: Type -> ReduceM Term @@ -262,12 +262,15 @@ Lam info t -> lam !@ quoteHiding (getHiding info) @@ quoteAbs quoteTerm t Def x es -> do defn <- getConstInfo x + patlams <- viewTC ePrintingPatternLambdas + let isSeenPatLam = elem x patlams r <- isReconstructed -- #2220: remember to restore dropped parameters let conOrProjPars = defParameters defn r ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - qx Function{ funExtLam = Just (ExtLamInfo m False _), funClauses = cs } = do + qx Function{ funExtLam = Just (ExtLamInfo m False _), 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 @@ -275,7 +278,8 @@ 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 _), funCompiled = Just Fail{}, funClauses = [cl] } = do + qx df@Function{ funExtLam = Just (ExtLamInfo _ True _), 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 @@ -339,8 +343,9 @@ agdaDefinitionFunDef !@ quoteList (quoteClause (Left ())) cs Primitive{} -> pure agdaDefinitionPrimitive PrimitiveSort{} -> pure agdaDefinitionPrimitive - Constructor{conData = d} -> - agdaDefinitionDataConstructor !@! quoteName d + Constructor{conData = d, conSrcCon = c} -> do + q <- getQuantity <$> getConstInfo (conName c) + agdaDefinitionDataConstructor !@! quoteName d @@ quoteQuantity q return $ QuotingKit quoteTerm quoteType (quoteDom quoteType) quoteDefn quoteList diff --git a/src/full/Agda/TypeChecking/ReconstructParameters.hs b/src/full/Agda/TypeChecking/ReconstructParameters.hs --- a/src/full/Agda/TypeChecking/ReconstructParameters.hs +++ b/src/full/Agda/TypeChecking/ReconstructParameters.hs @@ -23,9 +23,10 @@ import Agda.TypeChecking.Records import Agda.TypeChecking.Datatypes -import Agda.Utils.Size import Agda.Utils.Either import Agda.Utils.Function (applyWhen) +import Agda.Utils.Lens +import Agda.Utils.Size import Agda.Utils.Impossible @@ -156,8 +157,8 @@ -- Case: regular projection | isProperProjection (theDef info) -> case theDef info of - Function{ funErasure = e } -> - return $ map (mkParam e) postPs + d@Function{} -> + return $ map (mkParam (d ^. funErasure)) postPs _ -> __IMPOSSIBLE__ -- Case: projection-like function | otherwise -> do diff --git a/src/full/Agda/TypeChecking/RecordPatterns.hs b/src/full/Agda/TypeChecking/RecordPatterns.hs --- a/src/full/Agda/TypeChecking/RecordPatterns.hs +++ b/src/full/Agda/TypeChecking/RecordPatterns.hs @@ -371,8 +371,6 @@ -- -- go from level (i + n - 1) to index (subtract from |xs|-1) -- index = length xs - (i + n) -- in Done xs' $ applySubst (liftS (length xs2) $ us ++# raiseS 1) v --- -- The body is NOT guarded by lambdas! --- -- WRONG: underLambdas i (flip apply) (map defaultArg us) v -- -- Fail -> Fail -- @@ -386,22 +384,6 @@ -- } -- in loop i cc --- UNUSED Liang-Ting 2019-07-16 ----- | Check if a split is on a record constructor, and return the projections ----- if yes. ---isRecordCase :: Case c -> TCM (Maybe ([QName], c)) ---isRecordCase (Branches { conBranches = conMap --- , litBranches = litMap --- , catchAllBranch = Nothing }) --- | Map.null litMap --- , [(con, WithArity _ br)] <- Map.toList conMap = do --- isRC <- isRecordConstructor con --- case isRC of --- Just (r, Record { recFields = fs }) -> return $ Just (map unArg fs, br) --- Just (r, _) -> __IMPOSSIBLE__ --- Nothing -> return Nothing ---isRecordCase _ = return Nothing - --------------------------------------------------------------------------- -- * Record pattern translation for split trees --------------------------------------------------------------------------- @@ -516,24 +498,6 @@ 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 - --} --------------------------------------------------------------------------- diff --git a/src/full/Agda/TypeChecking/Records.hs b/src/full/Agda/TypeChecking/Records.hs --- a/src/full/Agda/TypeChecking/Records.hs +++ b/src/full/Agda/TypeChecking/Records.hs @@ -52,6 +52,9 @@ import Agda.Utils.Impossible +--------------------------------------------------------------------------- +-- * Tools to build record values + mkCon :: ConHead -> ConInfo -> Args -> Term mkCon h info args = Con h info (map Apply args) @@ -179,10 +182,23 @@ insertMissingFieldsFail r placeholder fs axs = failOnRecordFieldWarnings $ insertMissingFields r placeholder fs axs +--------------------------------------------------------------------------- +-- * Query information about records from signature + +-- | Check if a name refers to a record. +-- If yes, return record definition. +{-# SPECIALIZE isRecord :: QName -> TCM (Maybe RecordData) #-} +{-# SPECIALIZE isRecord :: QName -> ReduceM (Maybe RecordData) #-} +isRecord :: HasConstInfo m => QName -> m (Maybe RecordData) +isRecord r = do + getConstInfo r <&> theDef <&> \case + RecordDefn rd -> Just rd + _ -> Nothing + -- | Get the definition for a record. Throws an exception if the name -- does not refer to a record or the record is abstract. -getRecordDef :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m Defn -getRecordDef r = maybe err return =<< isRecord r +getRecordDef :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m RecordData +getRecordDef r = fromMaybeM err $ isRecord r where err = typeError $ ShouldBeRecordType (El __DUMMY_SORT__ $ Def r []) -- | Get the record name belonging to a field name. @@ -193,15 +209,12 @@ -- | Get the field names of a record. getRecordFieldNames :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) - => QName -> m [Dom C.Name] + => QName + -> m [Dom C.Name] getRecordFieldNames r = recordFieldNames <$> getRecordDef r -getRecordFieldNames_ :: (HasConstInfo m, ReadTCState m) - => QName -> m (Maybe [Dom C.Name]) -getRecordFieldNames_ r = fmap recordFieldNames <$> isRecord r - -recordFieldNames :: Defn -> [Dom C.Name] -recordFieldNames = map (fmap (nameConcrete . qnameName)) . recFields +recordFieldNames :: RecordData -> [Dom C.Name] +recordFieldNames = map (fmap (nameConcrete . qnameName)) . _recFields -- | Find all records with at least the given fields. findPossibleRecords :: [C.Name] -> TCM [QName] @@ -221,10 +234,6 @@ _ -> False given = Set.fromList fields --- | Get the field types of a record. -getRecordFieldTypes :: QName -> TCM Telescope -getRecordFieldTypes r = recTel <$> getRecordDef r - -- | Get the field names belonging to a record type. getRecordTypeFields :: Type -- ^ Record type. Need not be reduced. @@ -242,30 +251,19 @@ -- | Returns the given record type's constructor name (with an empty -- range). getRecordConstructor :: (HasConstInfo m, ReadTCState m, MonadError TCErr m) => QName -> m ConHead -getRecordConstructor r = killRange . recConHead <$> getRecordDef r - --- | Check if a name refers to a record. --- If yes, return record definition. -{-# SPECIALIZE isRecord :: QName -> TCM (Maybe Defn) #-} -{-# SPECIALIZE isRecord :: QName -> ReduceM (Maybe Defn) #-} -isRecord :: HasConstInfo m => QName -> m (Maybe Defn) -isRecord r = do - def <- theDef <$> getConstInfo r - return $ case def of - Record{} -> Just def - _ -> Nothing +getRecordConstructor r = killRange . _recConHead <$> getRecordDef r -- | Reduce a type and check whether it is a record type. -- Succeeds only if type is not blocked by a meta var. -- If yes, return its name, parameters, and definition. -isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, Defn)) +isRecordType :: PureTCM m => Type -> m (Maybe (QName, Args, RecordData)) isRecordType t = either (const Nothing) Just <$> tryRecordType t -- | Reduce a type and check whether it is a record type. -- Succeeds only if type is not blocked by a meta var. -- If yes, return its name, parameters, and definition. -- If no, return the reduced type (unless it is blocked). -tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, Defn)) +tryRecordType :: PureTCM m => Type -> m (Either (Blocked Type) (QName, Args, RecordData)) tryRecordType t = ifBlocked t (\ m a -> return $ Left $ Blocked m a) $ \ nb t -> do let no = return $ Left $ NotBlocked nb t case unEl t of @@ -448,41 +446,39 @@ {-# SPECIALIZE isEtaRecord :: QName -> ReduceM Bool #-} isEtaRecord :: HasConstInfo m => QName -> m Bool isEtaRecord r = do - isRec <- isRecord r - case isRec of + isRecord r >>= \case Nothing -> return False - Just r - | recEtaEquality r /= YesEta -> return False - | otherwise -> do - constructorQ <- getQuantity <$> - getConstInfo (conName (recConHead r)) - currentQ <- viewTC eQuantity - return $ constructorQ `moreQuantity` currentQ + Just r -> isEtaRecordDef r +isEtaRecordDef :: HasConstInfo m => RecordData -> m Bool +isEtaRecordDef r + | _recEtaEquality r /= YesEta = return False + | otherwise = do + constructorQ <- getQuantity <$> getConstInfo (conName (_recConHead r)) + currentQ <- viewTC eQuantity + return $ constructorQ `moreQuantity` currentQ + + {-# SPECIALIZE isEtaCon :: QName -> TCM Bool #-} isEtaCon :: HasConstInfo m => QName -> m Bool -isEtaCon c = getConstInfo' c >>= \case - Left (SigUnknown err) -> __IMPOSSIBLE__ - Left SigCubicalNotErasure -> __IMPOSSIBLE__ - Left SigAbstract -> return False - Right def -> case theDef def of - Constructor {conData = r} -> isEtaRecord r - _ -> return False +isEtaCon c = isJust <$> isEtaRecordConstructor c -- | Going under one of these does not count as a decrease in size for the termination checker. isEtaOrCoinductiveRecordConstructor :: HasConstInfo m => QName -> m Bool isEtaOrCoinductiveRecordConstructor c = - caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) -> return $ - recEtaEquality def == YesEta || recInduction def /= Just Inductive + caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) -> + 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 :: HasConstInfo m => QName -> m Bool -isInductiveRecord r = maybe False ((Just CoInductive /=) . recInduction) <$> isRecord r +isInductiveRecord r = maybe False ((Just CoInductive /=) . _recInduction) <$> isRecord r -- | Check if a type is an eta expandable record and return the record identifier and the parameters. isEtaRecordType :: (HasConstInfo m) - => Type -> m (Maybe (QName, Args)) + => Type + -> m (Maybe (QName, Args)) isEtaRecordType a = case unEl a of Def d es -> do let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es @@ -491,7 +487,8 @@ -- | Check if a name refers to a record constructor. -- If yes, return record definition. -isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, Defn)) +-- +isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData)) isRecordConstructor c = getConstInfo' c >>= \case Left (SigUnknown err) -> __IMPOSSIBLE__ Left SigCubicalNotErasure -> __IMPOSSIBLE__ @@ -500,24 +497,15 @@ Constructor{ conData = r } -> fmap (r,) <$> isRecord r _ -> return Nothing --- | Check if a constructor name is the internally generated record constructor. --- --- Works also for abstract constructors. -isGeneratedRecordConstructor :: (MonadTCEnv m, HasConstInfo m) - => QName -> m Bool -isGeneratedRecordConstructor c = ignoreAbstractMode $ do - caseMaybeM (isRecordConstructor c) (return False) $ \ (_, def) -> - case def of - Record{ recNamedCon = False } -> return True - _ -> return False - +isEtaRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData)) +isEtaRecordConstructor c = isRecordConstructor c >>= \case + Nothing -> return Nothing + Just (d, def) -> ifM (isEtaRecordDef def) (return $ Just (d, def)) (return Nothing) -- | Turn off eta for unguarded recursive records. -- Projections do not preserve guardedness. unguardedRecord :: QName -> PatternOrCopattern -> TCM () -unguardedRecord q pat = modifySignature $ updateDefinition q $ updateTheDef $ \case - r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) $ NoEta pat } - _ -> __IMPOSSIBLE__ +unguardedRecord q pat = modifyRecEta q \ eta -> setEtaEquality eta $ NoEta pat -- | Turn on eta for non-recursive and inductive guarded recursive records, -- unless user declared otherwise. @@ -532,9 +520,7 @@ | otherwise -> False _ -> __IMPOSSIBLE__ - when switchEta $ do - modifySignature $ updateDefinition q $ over (lensTheDef . lensRecord) $ \ d -> - d{ _recEtaEquality' = Inferred YesEta } + when switchEta $ modifyRecEta q $ const $ Inferred YesEta -- | Turn on eta for inductive guarded recursive records. -- Projections do not preserve guardedness. @@ -549,7 +535,10 @@ -- -- Precondition: record type identifier exists in signature. isRecursiveRecord :: QName -> TCM Bool -isRecursiveRecord q = recRecursive . theDef . fromMaybe __IMPOSSIBLE__ . lookupDefinition q <$> getSignature +isRecursiveRecord q = + getSignature <&> lookupDefinition q <&> fmap theDef <&> \case + Just (RecordDefn r) -> recRecursive_ r + _ -> __IMPOSSIBLE__ {- | @etaExpandBoundVar i = (Δ, σ, τ)@ @@ -587,17 +576,17 @@ " since its type " <+> prettyTCM a <+> " is not a record type" return Nothing - caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> case recEtaEquality def of - NoEta{} -> return Nothing - YesEta -> Just <$> do + caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> isEtaRecordDef def >>= \case + False -> return Nothing + True -> Just <$> do -- Get the record fields @Γ₁ ⊢ tel@ (@tel = Γ'@). -- TODO: compose argInfo ai with tel. - let tel = recTel def `apply` pars + let tel = _recTel def `apply` pars m = size tel - fs = map argFromDom $ recFields def + fs = map argFromDom $ _recFields def -- Construct the record pattern @Γ₁, Γ' ⊢ u := c ys@. ys = zipWith (\ f i -> f $> var i) fs $ downFrom m - u = mkCon (recConHead def) ConOSystem ys + u = mkCon (_recConHead def) ConOSystem ys -- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@ tau0 = consS u $ raiseS m -- @Γ₁, Γ', Γ₂ ⊢ τ₀ : Γ₁, x:_, Γ₂@ @@ -657,14 +646,14 @@ -- This might trigger another call to @etaExpandProjectedVar@ later. -- A more efficient version does all the eta-expansions at once here. (r, pars, def) <- fromMaybe __IMPOSSIBLE__ <$> isRecordType a - if | NoEta _ <- recEtaEquality def -> __IMPOSSIBLE__ + if | NoEta _ <- _recEtaEquality def -> __IMPOSSIBLE__ | otherwise -> return () -- TODO: compose argInfo ai with tel. - let tel = recTel def `apply` pars + let tel = _recTel def `apply` pars m = size tel - fs = map argFromDom $ recFields def + fs = map argFromDom $ _recFields def ys = zipWith (\ f i -> f $> var i) fs $ downFrom m - u = mkCon (recConHead def) ConOSystem ys + u = mkCon (killRange $ _recConHead def) ConOSystem ys b' = raise m b `absApp` u t' = gamma `telePi` (tel `telePi` b') gammai = map domInfo $ telToList gamma @@ -693,35 +682,60 @@ where @tel@ is the record telescope instantiated at the parameters @pars@. -} etaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m) - => QName -> Args -> Term -> m (Telescope, Args) + => QName -- ^ Name of record type. + -> Args -- ^ Parameters applied to record type. + -> Term -- ^ Term to eta-expand. + -> m (Telescope, Args) + -- ^ Field types instantiated to parameters, field values. etaExpandRecord = etaExpandRecord' False -- | Eta expand a record regardless of whether it's an eta-record or not. forceEtaExpandRecord :: (HasConstInfo m, MonadDebug m, ReadTCState m, MonadError TCErr m) - => QName -> Args -> Term -> m (Telescope, Args) + => QName -- ^ Name of record type. + -> Args -- ^ Parameters applied to record type. + -> Term -- ^ Term to eta-expand. + -> m (Telescope, Args) + -- ^ Field types instantiated to parameters, field values. forceEtaExpandRecord = etaExpandRecord' True +-- | Eta-expand a value at the given record type (must match). etaExpandRecord' :: (HasConstInfo m, MonadDebug m, ReadTCState m) - => Bool -> QName -> Args -> Term -> m (Telescope, Args) + => Bool -- ^ Force expansion, overriding '_recEtaEquality'? + -> QName -- ^ Name of record type. + -> Args -- ^ Parameters applied to record type. + -> Term -- ^ Term to eta-expand. + -> m (Telescope, Args) + -- ^ Field types instantiated to parameters, field values. etaExpandRecord' forceEta r pars u = do def <- fromMaybe __IMPOSSIBLE__ <$> isRecord r (tel, _, _, args) <- etaExpandRecord'_ forceEta r pars def u return (tel, args) +-- | Eta-expand a value at the given eta record type (must match). etaExpandRecord_ :: HasConstInfo m - => QName -> Args -> Defn -> Term -> m (Telescope, ConHead, ConInfo, Args) + => QName -- ^ Name of record type. + -> Args -- ^ Parameters applied to record type. + -> RecordData -- ^ Definition of record type. + -> Term -- ^ Term to eta-expand. + -> m (Telescope, ConHead, ConInfo, Args) + -- ^ Field types instantiated to parameters, disassembled constructor term. etaExpandRecord_ = etaExpandRecord'_ False +-- | Eta-expand a value at the given record type (must match). etaExpandRecord'_ :: HasConstInfo m - => Bool -> QName -> Args -> Defn -> Term -> m (Telescope, ConHead, ConInfo, Args) -etaExpandRecord'_ forceEta r pars def u = do - let Record{ recConHead = con - , recFields = xs - , recTel = tel - } = def - tel' = apply tel pars + => Bool -- ^ Force expansion, overriding '_recEtaEquality'? + -> QName -- ^ Name of record type. + -> Args -- ^ Parameters applied to record type. + -> RecordData -- ^ Definition of record type. + -> Term -- ^ Term to eta-expand. + -> m (Telescope, ConHead, ConInfo, Args) + -- ^ Field types instantiated to parameters, disassembled constructor term. +etaExpandRecord'_ forceEta r pars + def@RecordData{ _recConHead = con, _recFields = xs, _recTel = tel } + u = do + let tel' = apply tel pars -- Make sure we do not expand non-eta records (unless forced to): - unless (recEtaEquality def == YesEta || forceEta) __IMPOSSIBLE__ + unless (_recEtaEquality def == YesEta || forceEta) __IMPOSSIBLE__ case u of -- Already expanded. @@ -778,7 +792,7 @@ {-# SPECIALIZE etaContractRecord :: QName -> ConHead -> ConInfo -> Args -> ReduceM Term #-} etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term etaContractRecord r c ci args = if all (not . usableModality) args then fallBack else do - Just Record{ recFields = xs } <- isRecord r + Just RecordData{ _recFields = xs } <- isRecord r reportSDoc "tc.record.eta.contract" 20 $ vcat [ "eta contracting record" , nest 2 $ vcat @@ -822,11 +836,16 @@ -- -- Precondition: The name should refer to a record type, and the -- arguments should be the parameters to the type. -isSingletonRecord :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool +isSingletonRecord :: (PureTCM m, MonadBlock m) + => QName -- ^ Name of record type to check. + -> Args -- ^ Parameters given to the record type. + -> m Bool isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps mempty isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m) - => QName -> Args -> m Bool + => 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. @@ -853,18 +872,18 @@ 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 + 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 + 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 + fmap (mkCon (_recConHead def) ConOSystem) <$> do + check (applyWhen (recursive && nonTerminating) (Set.insert r) rs) $ _recTel def `apply` ps where -- Check that all entries of the constructor telescope are singletons. check :: Set QName -> Telescope -> m (Maybe [Arg Term]) @@ -909,7 +928,7 @@ record :: m (Maybe Term) record = runMaybeT $ do (r, ps, def) <- MaybeT $ isRecordType t - guard (YesEta == recEtaEquality def) + guardM $ isEtaRecordDef def abstract tel <$> MaybeT (isSingletonRecord' regardIrrelevance r ps rs) -- Slightly harder case: η for Sub {level} tA phi elt. diff --git a/src/full/Agda/TypeChecking/Records.hs-boot b/src/full/Agda/TypeChecking/Records.hs-boot --- a/src/full/Agda/TypeChecking/Records.hs-boot +++ b/src/full/Agda/TypeChecking/Records.hs-boot @@ -6,9 +6,10 @@ import qualified Agda.Syntax.Concrete.Name as C import Agda.TypeChecking.Monad -isRecord :: HasConstInfo m => QName -> m (Maybe Defn) -isEtaRecord :: HasConstInfo m => QName -> m Bool -getRecordFieldNames_ :: (HasConstInfo m, ReadTCState m) => QName -> m (Maybe [Dom C.Name]) etaContractRecord :: HasConstInfo m => QName -> ConHead -> ConInfo -> Args -> m Term -isGeneratedRecordConstructor :: (MonadTCEnv m, HasConstInfo m) => QName -> m Bool -isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, Defn)) + +isRecord :: HasConstInfo m => QName -> m (Maybe RecordData) +isEtaRecord :: HasConstInfo m => QName -> m Bool +isRecordConstructor :: HasConstInfo m => QName -> m (Maybe (QName, RecordData)) + +recordFieldNames :: RecordData -> [Dom C.Name] diff --git a/src/full/Agda/TypeChecking/Reduce.hs b/src/full/Agda/TypeChecking/Reduce.hs --- a/src/full/Agda/TypeChecking/Reduce.hs +++ b/src/full/Agda/TypeChecking/Reduce.hs @@ -5,7 +5,6 @@ ( Instantiate, instantiate', instantiate, instantiateWhen -- Recursive meta instantiation , InstantiateFull, instantiateFull', instantiateFull - , instantiateFullExceptForDefinitions -- Check for meta (no reduction) , IsMeta, isMeta -- Reduction and blocking @@ -213,9 +212,7 @@ _ | Just m' <- mvTwin mv, blocking -> instantiate' (MetaV m' es) - Open -> return t - - OpenInstance -> return t + OpenMeta _ -> return t BlockedConst u | blocking -> instantiate' . unBrave $ @@ -303,6 +300,7 @@ instantiate' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> instantiate' (a,b) instantiate' (UnBlock m) = return $ UnBlock m instantiate' (FindInstance m cs) = FindInstance m <$> mapM instantiate' cs + instantiate' (ResolveInstanceHead q) = return $ ResolveInstanceHead q instantiate' (IsEmpty r t) = IsEmpty r <$> instantiate' t instantiate' (CheckSizeLtSat t) = CheckSizeLtSat <$> instantiate' t instantiate' c@CheckFunDef{} = return c @@ -925,8 +923,15 @@ (m, es0) <- matchCopatterns pats es0 let es = es0 ++ es1 case m of - No -> goCls cls es - DontKnow b -> rewrite b (applyE v) rewr es + No -> goCls cls es + -- Szumi, 2024-03-29, issue #7181: + -- If a lazy match is stuck and all non-lazy matches are conclusive, + -- then reduction should not be stuck on the current clause and it + -- should be fine to continue matching on the next clause. + -- This assumes it's impossible for a lazy match to be stuck if + -- all non-lazy matches succeed. + DontKnow OnlyLazy _ -> goCls cls es + DontKnow NonLazy b -> rewrite b (applyE v) rewr es Yes simpl vs -- vs is the subst. for the variables bound in body | Just w <- body -> do -- clause has body? -- TODO: let matchPatterns also return the reduced forms @@ -959,6 +964,7 @@ reduce' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> reduce' (a,b) reduce' (UnBlock m) = return $ UnBlock m reduce' (FindInstance m cs) = FindInstance m <$> mapM reduce' cs + reduce' (ResolveInstanceHead q) = return $ ResolveInstanceHead q reduce' (IsEmpty r t) = IsEmpty r <$> reduce' t reduce' (CheckSizeLtSat t) = CheckSizeLtSat <$> reduce' t reduce' c@CheckFunDef{} = return c @@ -1125,6 +1131,7 @@ simplify' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> simplify' (a,b) simplify' (UnBlock m) = return $ UnBlock m simplify' (FindInstance m cs) = FindInstance m <$> mapM simplify' cs + simplify' (ResolveInstanceHead q) = return $ ResolveInstanceHead q simplify' (IsEmpty r t) = IsEmpty r <$> simplify' t simplify' (CheckSizeLtSat t) = CheckSizeLtSat <$> simplify' t simplify' c@CheckFunDef{} = return c @@ -1306,6 +1313,7 @@ normalise' (SortCmp cmp a b) = uncurry (SortCmp cmp) <$> normalise' (a,b) normalise' (UnBlock m) = return $ UnBlock m normalise' (FindInstance m cs) = FindInstance m <$> mapM normalise' cs + normalise' (ResolveInstanceHead q) = return $ ResolveInstanceHead q normalise' (IsEmpty r t) = IsEmpty r <$> normalise' t normalise' (CheckSizeLtSat t) = CheckSizeLtSat <$> normalise' t normalise' c@CheckFunDef{} = return c @@ -1546,6 +1554,7 @@ SortCmp cmp a b -> uncurry (SortCmp cmp) <$> instantiateFull' (a,b) UnBlock m -> return $ UnBlock m FindInstance m cs -> FindInstance 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 @@ -1565,7 +1574,11 @@ instantiateFull' AsTypes = return AsTypes instance InstantiateFull Signature where - instantiateFull' (Sig a b c) = uncurry3 Sig <$> instantiateFull' (a, b, c) + instantiateFull' (Sig a b c d) = Sig + <$> instantiateFull' a + <*> instantiateFull' b + <*> instantiateFull' c + <*> pure d -- The instance table only stores names instance InstantiateFull Section where instantiateFull' (Section tel) = Section <$> instantiateFull' tel @@ -1702,47 +1715,27 @@ <*> instantiateFull' c instance InstantiateFull Interface where - instantiateFull' i = do - defs <- instantiateFull' (i ^. intSignature . sigDefinitions) - instantiateFullExceptForDefinitions' - (set (intSignature . sigDefinitions) defs i) - --- | Instantiates everything except for definitions in the signature. - -instantiateFullExceptForDefinitions' :: Interface -> ReduceM Interface -instantiateFullExceptForDefinitions' - (Interface h s ft ms mod tlmod scope inside sig metas display userwarn - importwarn b foreignCode highlighting libPragmas filePragmas - usedOpts patsyns warnings partialdefs oblocks onames) = - Interface h s ft ms mod tlmod scope inside - <$> ((\s r -> Sig { _sigSections = s - , _sigDefinitions = sig ^. sigDefinitions - , _sigRewriteRules = r - }) - <$> instantiateFull' (sig ^. sigSections) - <*> instantiateFull' (sig ^. sigRewriteRules)) - <*> instantiateFull' metas - <*> 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 - --- | Instantiates everything except for definitions in the signature. - -instantiateFullExceptForDefinitions :: - MonadReduce m => Interface -> m Interface -instantiateFullExceptForDefinitions = - liftReduce . instantiateFullExceptForDefinitions' + 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 diff --git a/src/full/Agda/TypeChecking/Reduce/Fast.hs b/src/full/Agda/TypeChecking/Reduce/Fast.hs --- a/src/full/Agda/TypeChecking/Reduce/Fast.hs +++ b/src/full/Agda/TypeChecking/Reduce/Fast.hs @@ -394,7 +394,7 @@ , 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 + , ffallThrough = Just True == fT , fcatchAllBranch = fmap (fastCompiledClauses env) wild } where stripSuc | Just c <- bSuc env = Map.delete (conName c) @@ -467,9 +467,6 @@ compactDef bEnv info rewr ReduceM $ \ redEnv -> reduceTm redEnv bEnv (memoQName constInfo) norm v -unKleisli :: (a -> ReduceM b) -> ReduceM (a -> b) -unKleisli f = ReduceM $ \ env x -> unReduceM (f x) env - -- * Closures -- | The abstract machine represents terms as closures containing a 'Term', an environment, and a @@ -989,8 +986,7 @@ spine' <- elimsToSpine env es let (zs, env, !spine'') = buildEnv (instTel i) (spine' <> spine) runAM (evalClosure (lams zs (instBody i)) env spine'' ctrl) - Just Open{} -> __IMPOSSIBLE__ - Just OpenInstance{} -> __IMPOSSIBLE__ + Just OpenMeta{} -> __IMPOSSIBLE__ Just BlockedConst{} -> __IMPOSSIBLE__ Just PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__ diff --git a/src/full/Agda/TypeChecking/Rewriting.hs b/src/full/Agda/TypeChecking/Rewriting.hs --- a/src/full/Agda/TypeChecking/Rewriting.hs +++ b/src/full/Agda/TypeChecking/Rewriting.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -47,7 +46,10 @@ import Prelude hiding (null) import Control.Monad +import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT ) +import Control.Monad.Trans ( lift ) +import Data.Either (partitionEithers) import Data.Foldable (toList) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -136,7 +138,7 @@ addRewriteRules qs = do -- Check the rewrite rules - rews <- mapM checkRewriteRule qs + rews <- mapMaybeM checkRewriteRule qs -- Add rewrite rules to the signature forM_ rews $ \rew -> do @@ -152,8 +154,7 @@ -- (should be done after adding all rules, see #3795) whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do -- Warn if --cubical is enabled - whenJustM (optCubical <$> pragmaOptions) $ \_ -> genericWarning - "Confluence checking for --cubical is not yet supported, confluence checking might be incomplete" + whenJustM cubicalOption $ \_ -> warning ConfluenceForCubicalNotSupported -- Global confluence checker requires rules to be sorted -- according to the generality of their lhs when (confChk == GlobalConfluenceCheck) $ @@ -183,12 +184,10 @@ -- Remember that @rel : Δ → A → A → Set i@, so -- @rel us : (lhs rhs : A[us/Δ]) → Set i@. -- Returns the checked rewrite rule to be added to the signature. -checkRewriteRule :: QName -> TCM RewriteRule -checkRewriteRule q = do - requireOptionRewriting - let failNoBuiltin = typeError $ GenericError $ - "Cannot add rewrite rule without prior BUILTIN REWRITE" - rels <- fromMaybeM failNoBuiltin getBuiltinRewriteRelations +checkRewriteRule :: QName -> TCM (Maybe RewriteRule) +checkRewriteRule q = runMaybeT $ do + lift requireOptionRewriting + rels <- lift getBuiltinRewriteRelations reportSDoc "rewriting.relations" 40 $ vcat [ "Rewrite relations:" , prettyList $ map prettyTCM $ toList rels @@ -197,7 +196,16 @@ -- 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 $ IllegalRewriteRule q BeforeFunctionDefinition + illegalRule BeforeFunctionDefinition + -- Issue 6643: Also check that there are no mututal definitions + -- that are not yet defined. + whenJustM (asksTC envMutualBlock) \ mb -> do + qs <- mutualNames <$> lookupMutualBlock mb + when (Set.member q qs) $ forM_ qs $ \r -> do + whenM (isEmptyFunction . theDef <$> getConstInfo r) $ + illegalRule $ BeforeMutualFunctionDefinition r + + -- Get rewrite rule (type of q). TelV gamma1 core <- telView $ defType def reportSDoc "rewriting" 30 $ vcat @@ -205,27 +213,25 @@ , prettyTCM gamma1 , " |- " <+> do addContext gamma1 $ prettyTCM core ] - let failureBlocked :: Blocker -> TCM a + let failureBlocked :: Blocker -> MaybeT TCM a failureBlocked b - | not (null ms) = typeError $ IllegalRewriteRule q (ContainsUnsolvedMetaVariables ms) - | not (null ps) = typeError $ IllegalRewriteRule q (BlockedOnProblems ps) - | not (null qs) = typeError $ IllegalRewriteRule q (RequiresDefinitions qs) + | not (null ms) = illegalRule $ ContainsUnsolvedMetaVariables ms + | not (null ps) = illegalRule $ BlockedOnProblems ps + | not (null qs) = illegalRule $ RequiresDefinitions qs | otherwise = __IMPOSSIBLE__ where ms = allBlockingMetas b ps = allBlockingProblems b qs = allBlockingDefs b - let failureFreeVars :: IntSet -> TCM a - failureFreeVars xs = typeError $ IllegalRewriteRule q (VariablesNotBoundByLHS xs) - let failureNonLinearPars :: IntSet -> TCM a - failureNonLinearPars xs = typeError $ IllegalRewriteRule q (VariablesBoundMoreThanOnce xs) - let failureIllegalRule :: TCM a -- TODO:: Defined but not used - failureIllegalRule = typeError $ IllegalRewriteRule q EmptyReason + let failureFreeVars :: IntSet -> MaybeT TCM a + failureFreeVars xs = illegalRule $ VariablesNotBoundByLHS xs + let failureNonLinearPars :: IntSet -> MaybeT TCM a + failureNonLinearPars xs = illegalRule $ VariablesBoundMoreThanOnce xs -- Check that type of q targets rel. case unEl core of Def rel es@(_:_:_) | rel `elem` rels -> do - (delta, a) <- rewriteRelationDom rel + (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. @@ -256,7 +262,7 @@ ~(Just ((_ , _ , pars) , t)) <- getFullyAppliedConType c $ unDom b pars <- addContext gamma1 $ checkParametersAreGeneral c pars return (conName c , hd , t , pars , vs) - _ -> typeError $ IllegalRewriteRule q LHSNotDefOrConstr + _ -> illegalRule LHSNotDefinitionOrConstructor ifNotAlreadyAdded f $ do @@ -264,8 +270,9 @@ checkNoLhsReduction f hd es - ps <- catchPatternErr failureBlocked $ - patternFrom Relevant 0 (t , Def f) es + ps <- fromRightM failureBlocked $ lift $ + catchPatternErr (pure . Left) $ + Right <$> patternFrom Relevant 0 (t , Def f) es reportSDoc "rewriting" 30 $ "Pattern generated from lhs: " <+> prettyTCM (PDef f ps) @@ -310,58 +317,69 @@ return rew - _ -> typeError $ IllegalRewriteRule q DoesNotTargetRewriteRelation + _ -> illegalRule DoesNotTargetRewriteRelation where - checkNoLhsReduction :: QName -> (Elims -> Term) -> Elims -> TCM () + illegalRule :: IllegalRewriteRuleReason -> MaybeT TCM a + illegalRule reason = do + lift $ warning $ IllegalRewriteRule q reason + mzero + + checkNoLhsReduction :: QName -> (Elims -> Term) -> Elims -> MaybeT TCM () checkNoLhsReduction f hd es = do -- Skip this check when global confluence check is enabled, as -- redundant rewrite rules may be required to prove confluence. unlessM ((== Just GlobalConfluenceCheck) . optConfluenceCheck <$> pragmaOptions) $ do let v = hd es v' <- reduce v - let fail :: TCM a + let fail :: MaybeT TCM a fail = do reportSDoc "rewriting" 20 $ "v = " <+> text (show v) reportSDoc "rewriting" 20 $ "v' = " <+> text (show v') - typeError $ IllegalRewriteRule q (LHSReducesTo v v') + illegalRule $ LHSReduces v v' es' <- case v' of Def f' es' | f == f' -> return es' Con c' _ es' | f == conName c' -> return es' _ -> fail unless (null es && null es') $ do - a <- computeElimHeadType f es es' + a <- lift $ computeElimHeadType f es es' pol <- getPolarity' CmpEq f - ok <- dontAssignMetas $ tryConversion $ + ok <- lift $ dontAssignMetas $ tryConversion $ compareElims pol [] a (Def f []) es es' unless ok fail - checkAxFunOrCon :: QName -> Definition -> TCM () + checkAxFunOrCon :: QName -> Definition -> MaybeT TCM () checkAxFunOrCon f def = case theDef def of Axiom{} -> return () def@Function{} -> do whenJust (maybeRight (funProjection def)) $ \proj -> case projProper proj of - Just{} -> typeError $ IllegalRewriteRule q (HeadSymbolIsProjection f) - Nothing -> typeError $ IllegalRewriteRule q (HeadSymbolIsProjectionLikeFunction f) + Just{} -> illegalRule $ HeadSymbolIsProjection f + Nothing -> illegalRule $ HeadSymbolIsProjectionLikeFunction f whenM (isJust . optConfluenceCheck <$> pragmaOptions) $ do let simpleClause cl = (patternsToElims (namedClausePats cl) , clauseBody cl) cls <- instantiateFull $ map simpleClause $ funClauses def - unless (noMetas cls) $ typeError $ IllegalRewriteRule q (HeadSymbolDefContainsMetas f) + unless (noMetas cls) $ illegalRule $ HeadSymbolContainsMetas f Constructor{} -> return () AbstractDefn{} -> return () Primitive{} -> return () -- TODO: is this fine? - _ -> typeError $ IllegalRewriteRule q (HeadSymbolNotPostulateFunctionConstructor f) + Datatype{} -> illegalHead + Record{} -> illegalHead + DatatypeDefn{} -> illegalHead + RecordDefn{} -> illegalHead + DataOrRecSig{} -> illegalHead + PrimitiveSort{}-> illegalHead + GeneralizableVar{} -> __IMPOSSIBLE__ - ifNotAlreadyAdded :: QName -> TCM RewriteRule -> TCM RewriteRule + where + illegalHead = illegalRule $ HeadSymbolIsTypeConstructor f + + ifNotAlreadyAdded :: QName -> MaybeT TCM RewriteRule -> MaybeT TCM RewriteRule ifNotAlreadyAdded f cont = do rews <- getRewriteRulesFor f -- check if q is already an added rewrite rule case List.find ((q ==) . rewName) rews of - Just rew -> do - genericWarning =<< do - "Rewrite rule " <+> prettyTCM q <+> " has already been added" - return rew + Just rew -> illegalRule DuplicateRewriteRule Nothing -> cont usedArgs :: Definition -> IntSet @@ -373,7 +391,7 @@ used Pos.Unused = False used _ = True - checkParametersAreGeneral :: ConHead -> Args -> TCM [Int] + checkParametersAreGeneral :: ConHead -> Args -> MaybeT TCM [Int] checkParametersAreGeneral c vs = do is <- loop vs unless (fastDistinct is) $ errorNotGeneral @@ -384,8 +402,8 @@ Var i [] -> (i :) <$> loop vs _ -> errorNotGeneral - errorNotGeneral :: TCM a - errorNotGeneral = typeError $ IllegalRewriteRule q (ConstructorParamsNotGeneral c vs) + errorNotGeneral :: MaybeT TCM a + errorNotGeneral = illegalRule $ ConstructorParametersNotGeneral c vs -- | @rewriteWith t f es rew@ where @f : t@ -- tries to rewrite @f es@ with @rew@, returning the reduct if successful. diff --git a/src/full/Agda/TypeChecking/Rewriting/Confluence.hs b/src/full/Agda/TypeChecking/Rewriting/Confluence.hs --- a/src/full/Agda/TypeChecking/Rewriting/Confluence.hs +++ b/src/full/Agda/TypeChecking/Rewriting/Confluence.hs @@ -99,11 +99,7 @@ rews <- getClausesAsRewriteRules f let noMetasInPats rew | noMetas (rewPats rew) = return True - | otherwise = do - genericWarning =<< do - text "Confluence checking incomplete because the definition of" <+> - prettyTCM f <+> text "contains unsolved metavariables." - return False + | otherwise = False <$ do warning $ ConfluenceCheckingIncompleteBecauseOfMeta f rews <- filterM noMetasInPats rews let matchables = map getMatchables rews reportSDoc "rewriting.confluence" 30 $ @@ -735,15 +731,14 @@ reportSDoc "rewriting.confluence.eta" 40 $ fsep [ "Forcing" , prettyTCM v , ":" , prettyTCM a , "to be projectible by" , prettyTCM f ] r <- fromMaybe __IMPOSSIBLE__ <$> getRecordOfField f - rdef <- getConstInfo r - let ra = defType rdef + Defn{ defType = ra, theDef = RecordDefn rdef } <- getConstInfo r pars <- newArgsMeta ra s <- ra `piApplyM` pars >>= \s -> ifIsSort s return __IMPOSSIBLE__ equalType a $ El s (Def r $ map Apply pars) -- Eta-expand v at record type r, and get field corresponding to f - (_ , c , ci , fields) <- etaExpandRecord_ r pars (theDef rdef) v - let fs = map argFromDom $ recFields $ theDef rdef + (_ , c , ci , fields) <- etaExpandRecord_ r pars rdef v + let fs = map argFromDom $ _recFields rdef i = fromMaybe __IMPOSSIBLE__ $ elemIndex f $ map unArg fs fContent = unArg $ fromMaybe __IMPOSSIBLE__ $ fields !!! i fUpdate w = Con c ci $ map Apply $ updateAt i (w <$) fields diff --git a/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs b/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs --- a/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs +++ b/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs @@ -119,10 +119,10 @@ | isIrrelevant r' -> nlmSub %= IntMap.insert i (r,v) | otherwise -> whenJustM (equal a v v') matchingBlocked -tellEq :: Telescope -> Telescope -> Type -> Term -> Term -> NLM () +tellEq :: Telescope -> Context -> Type -> Term -> Term -> NLM () tellEq gamma k a u v = do traceSDoc "rewriting.match" 30 (sep - [ "adding equality between" <+> addContext (gamma `abstract` k) (prettyTCM u) + [ "adding equality between" <+> addContext gamma (addContext k $ prettyTCM u) , " and " <+> addContext k (prettyTCM v) ]) $ do nlmEqs %= (PostponedEquation k a u v:) @@ -132,7 +132,7 @@ -- which we have to verify after applying -- the substitution computed by matching. data PostponedEquation = PostponedEquation - { eqFreeVars :: Telescope -- ^ Telescope of free variables in the equation + { eqFreeVars :: Context -- ^ Context of free variables in the equation , eqType :: Type -- ^ Type of the equation, living in same context as the rhs. , eqLhs :: Term -- ^ Term from pattern, living in pattern context. , eqRhs :: Term -- ^ Term from scrutinee, living in context where matching was invoked. @@ -145,7 +145,7 @@ 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 @@ -161,13 +161,13 @@ match r gamma k (t, hd) _ [] = matchingBlocked $ NotBlocked ReallyNotBlocked () match r gamma k (t, hd) (p:ps) (v:vs) = traceSDoc "rewriting.match" 50 (sep - [ "matching elimination " <+> addContext (gamma `abstract` k) (prettyTCM p) + [ "matching elimination " <+> addContext gamma (addContext k $ prettyTCM p) , " with " <+> addContext k (prettyTCM v) , " eliminating head " <+> addContext k (prettyTCM $ hd []) <+> ":" <+> addContext k (prettyTCM t)]) $ do let no = matchingBlocked $ NotBlocked ReallyNotBlocked () case (p,v) of - (Apply p, Apply v) -> (addContext k $ unEl <$> reduce t) >>= \case + (Apply p, Apply v) -> addContext k (unEl <$> reduce t) >>= \case Pi a b -> do match r gamma k a p v let t' = absApp b (unArg v) @@ -176,7 +176,7 @@ t -> traceSDoc "rewriting.match" 20 ("application at non-pi type (possible non-confluence?) " <+> prettyTCM t) mzero - (IApply x y p , IApply u v i) -> (addContext k $ pathView =<< reduce t) >>= \case + (IApply x y p , IApply u v i) -> addContext k (pathView =<< reduce t) >>= \case PathType s q l b _u _v -> do Right interval <- runExceptT primIntervalType match r gamma k interval p i @@ -222,7 +222,7 @@ yes = return () no = matchingBlocked $ NotBlocked ReallyNotBlocked () traceSDoc "rewriting.match" 30 (sep - [ "matching pattern " <+> addContext (gamma `abstract` k) (prettyTCM p) + [ "matching pattern " <+> addContext gamma (addContext k $ prettyTCM p) , " with sort " <+> addContext k (prettyTCM s) ]) $ do case (p , s) of (PUniv u lp , Univ u' l) | u == u' -> match r gamma k () lp l @@ -248,12 +248,19 @@ match r gamma k t p v instance Match NLPat Term where + match :: Relevance -- Are we currently matching in an irrelevant context? + -> Telescope -- The telescope of pattern variables + -> Context -- The context of lambda-bound variables + -> Type -- The type of the pattern + -> NLPat -- The pattern to match + -> Term -- The term to be matched against the pattern + -> NLM () match r0 gamma k t p v = do vbt <- addContext k $ reduceB (v,t) let n = size k b = void vbt (v,t) = ignoreBlocking vbt - prettyPat = withShowAllArguments $ addContext (gamma `abstract` k) (prettyTCM p) + prettyPat = withShowAllArguments $ addContext gamma $ addContext k $ prettyTCM p prettyTerm = withShowAllArguments $ addContext k $ prettyTCM v prettyType = withShowAllArguments $ addContext k $ prettyTCM t etaRecord <- addContext k $ isEtaRecordType t @@ -293,14 +300,15 @@ _ -> no "" case p of PVar i bvs -> traceSDoc "rewriting.match" 60 ("matching a PVar: " <+> text (show i)) $ do + let vars = map unArg bvs let allowedVars :: IntSet - allowedVars = IntSet.fromList (map unArg bvs) + allowedVars = IntSet.fromList vars badVars :: IntSet badVars = IntSet.difference (IntSet.fromList (downFrom n)) allowedVars perm :: Permutation - perm = Perm n $ reverse $ map unArg $ bvs + perm = Perm n $ reverse vars tel :: Telescope - tel = permuteTel perm k + tel = permuteContext perm k ok <- addContext k $ reallyFree badVars v case ok of Left b -> block b @@ -326,17 +334,17 @@ let ai = domInfo a pbody = PDef f $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ] body = raise 1 v `apply` [ Arg (domInfo a) $ var 0 ] - k' = ExtendTel a (Abs (absName b) k) + k' <- extendContext k (absName b) a match r gamma k' (absBody b) pbody body _ | Just (d, pars) <- etaRecord -> do -- If v is not of record constructor form but we are matching at record -- type, e.g., we eta-expand both v to (c vs) and -- the pattern (p = PDef f ps) to @c (p .f1) ... (p .fn)@. - def <- addContext k $ theDef <$> getConstInfo d + RecordDefn def <- addContext k $ theDef <$> getConstInfo d (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v addContext k (getFullyAppliedConType c t) >>= \case Just (_ , ct) -> do - let flds = map argFromDom $ recFields def + 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. @@ -349,17 +357,17 @@ PLam i p' -> case unEl t of Pi a b -> do let body = raise 1 v `apply` [Arg i (var 0)] - k' = ExtendTel a (Abs (absName b) k) + k' <- extendContext k (absName b) a match r gamma k' (absBody b) (absBody p') body _ | Left ((a,b),(x,y)) <- pview t -> do let body = raise 1 v `applyE` [ IApply (raise 1 x) (raise 1 y) $ var 0 ] - k' = ExtendTel a (Abs "i" k) + k' <- extendContext k "i" a match r gamma k' (absBody b) (absBody p') body v -> maybeBlock v PPi pa pb -> case v of Pi a b -> do match r gamma k () pa a - let k' = ExtendTel a (Abs (absName b) k) + k' <- extendContext k (absName b) a match r gamma k' () (absBody pb) (absBody b) v -> maybeBlock v PSort ps -> case v of @@ -367,27 +375,31 @@ v -> maybeBlock v PBoundVar i ps -> case v of Var i' es | i == i' -> do - let ti = unDom $ indexWithDefault __IMPOSSIBLE__ (flattenTel k) i + let ti = maybe __IMPOSSIBLE__ (snd . unDom) $ 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' = ExtendTel a (Abs (absName b) k) + k' <- extendContext k (absName b) a match r gamma k' (absBody b) pbody body _ | Just (d, pars) <- etaRecord -> do - def <- addContext k $ theDef <$> getConstInfo d + RecordDefn def <- addContext k $ theDef <$> getConstInfo d (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v addContext k (getFullyAppliedConType c t) >>= \case Just (_ , ct) -> do - let flds = map argFromDom $ recFields def + let flds = map argFromDom $ _recFields def ps' = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs) Nothing -> no "" v -> maybeBlock v - PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext (gamma `abstract` k) (prettyTCM u)) $ + PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext gamma (addContext k $ prettyTCM u)) $ tellEq gamma k t u v +extendContext :: MonadAddContext m => Context -> ArgName -> Dom Type -> m Context +extendContext cxt x a = withFreshName empty x \ y -> return $ fmap (y,) a : cxt + + makeSubstitution :: Telescope -> Sub -> Maybe Substitution makeSubstitution gamma sub = parallelS <$> traverse val [0 .. size gamma-1] @@ -415,7 +427,7 @@ let no msg b = traceSDoc "rewriting.match" 10 (sep [ "matching failed during" <+> text msg , "blocking: " <+> text (show b) ]) $ return (Left b) - caseEitherM (runNLM $ match Relevant gamma EmptyTel t p v) (no "matching") $ \ s -> do + 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 diff --git a/src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs b/src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs --- a/src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs +++ b/src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs @@ -164,7 +164,7 @@ _ -> done | otherwise -> done (_ , _ ) | Just (d, pars) <- etaRecord -> do - def <- theDef <$> getConstInfo d + RecordDefn def <- theDef <$> getConstInfo d (tel, c, ci, vs) <- etaExpandRecord_ d pars def v ct <- assertConOf c t PDef (conName c) <$> patternFrom r k (ct , Con c ci) (map Apply vs) diff --git a/src/full/Agda/TypeChecking/Rules/Application.hs b/src/full/Agda/TypeChecking/Rules/Application.hs --- a/src/full/Agda/TypeChecking/Rules/Application.hs +++ b/src/full/Agda/TypeChecking/Rules/Application.hs @@ -28,6 +28,7 @@ ( 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 @@ -147,12 +148,12 @@ -- 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 + 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' = A.patternToExpr p - e' = A.lambdaLiftExpr (map unArg ns) (A.substExpr s p') + let p' = patternToExpr p + e' = A.lambdaLiftExpr ns (A.substExpr s p') checkExpr' cmp e' t -- Subcase: macro @@ -203,18 +204,17 @@ -- 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 + -- Check H a b : A tel <- metaTel args -- (x : X) (y : Y x) - target <- addContext tel newTypeMeta_ -- Z x y + target <- addContext tel newTypeMeta_ -- Z x y let holeType = telePi_ tel target -- (x : X) (y : Y x) → Z x y (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ CmpLeq ExpandLast (getRange args) args tel -- a b : (x : X) (y : Y x) - let rho = reverse (map unArg vs) ++# IdS -- [x := a, y := b] - equalType (applySubst rho target) t -- Z a b == A (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq holeType unquoteM (namedArg arg) hole holeType - return $ apply hole vs + 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 @@ -326,8 +326,8 @@ -- So when applying the constructor throw away the parameters. return (applyE u . drop n, a) A.Con{} -> __IMPOSSIBLE__ -- inferHead will only be called on unambiguous constructors - A.QuestionMark i ii -> inferMeta (newQuestionMark ii) i - A.Underscore i -> inferMeta (newValueMeta RunMetaOccursCheck) i + 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) @@ -679,6 +679,11 @@ 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? @@ -1264,9 +1269,8 @@ 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, defn) -> do - case defn of - Record { recFields = fs } -> 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 @@ -1275,7 +1279,6 @@ (, t, CheckedTarget Nothing) <$> checkHeadApplication cmp e t (A.Proj o $ unambiguous d) args _ -> __IMPOSSIBLE__ - _ -> __IMPOSSIBLE__ -- Case: we have a visible argument ((k, arg) : _) -> do diff --git a/src/full/Agda/TypeChecking/Rules/Builtin.hs b/src/full/Agda/TypeChecking/Rules/Builtin.hs --- a/src/full/Agda/TypeChecking/Rules/Builtin.hs +++ b/src/full/Agda/TypeChecking/Rules/Builtin.hs @@ -126,7 +126,7 @@ return (sort $ varSort 1))) , (builtinIntervalUniv |-> BuiltinSort SortIntervalUniv) , (builtinInterval |-> BuiltinData (requireCubical CErased "" >> - (return $ sort IntervalUniv)) [builtinIZero,builtinIOne]) + 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 -> @@ -355,7 +355,7 @@ ,builtinAgdaDefinitionPrimitive]) , (builtinAgdaDefinitionFunDef |-> BuiltinDataCons (tlist tclause --> tdefn)) , (builtinAgdaDefinitionDataDef |-> BuiltinDataCons (tnat --> tlist tqname --> tdefn)) - , (builtinAgdaDefinitionDataConstructor |-> BuiltinDataCons (tqname --> tdefn)) + , (builtinAgdaDefinitionDataConstructor |-> BuiltinDataCons (tqname --> tquantity --> tdefn)) , (builtinAgdaDefinitionRecordDef |-> BuiltinDataCons (tqname --> tlist (targ tqname) --> tdefn)) , (builtinAgdaDefinitionPostulate |-> BuiltinDataCons tdefn) , (builtinAgdaDefinitionPrimitive |-> BuiltinDataCons tdefn) @@ -383,13 +383,13 @@ , 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 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) + , 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) @@ -405,6 +405,7 @@ , 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 --> @@ -412,6 +413,7 @@ (Lam defaultArgInfo . Abs "_" <$> (primSigma <#> primLevelZero <#> primLevelZero <@> primString <@> (Lam defaultArgInfo . Abs "_" <$> primString))))) , builtinAgdaTCMGetInstances |-> builtinPostulate (tmeta --> tTCM_ (list primAgdaTerm)) + , builtinAgdaTCMSolveInstances |-> builtinPostulate (tTCM_ primUnit) , builtinAgdaTCMPragmaForeign |-> builtinPostulate (tstring --> tstring --> tTCM_ primUnit) , builtinAgdaTCMPragmaCompile |-> builtinPostulate (tstring --> tqname --> tstring --> tTCM_ primUnit) ] diff --git a/src/full/Agda/TypeChecking/Rules/Data.hs b/src/full/Agda/TypeChecking/Rules/Data.hs --- a/src/full/Agda/TypeChecking/Rules/Data.hs +++ b/src/full/Agda/TypeChecking/Rules/Data.hs @@ -34,6 +34,7 @@ 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 @@ -44,6 +45,7 @@ import Agda.TypeChecking.Forcing import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Warnings (warning) import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ ) @@ -117,8 +119,7 @@ else throwError err reduce s - withK <- not . optWithoutK <$> - pragmaOptions + withK <- not <$> withoutKOption erasure <- optErasure <$> pragmaOptions -- Parameters are always hidden in constructors. If -- --erasure is used, then the parameters are erased for @@ -188,7 +189,7 @@ let cons = map A.axiomName cs -- get constructor names (mtranspix, transpFun) <- - ifM (optCubicalCompatible <$> pragmaOptions) + ifM cubicalCompatibleOption (do mtranspix <- inTopContext $ defineTranspIx name transpFun <- inTopContext $ defineTranspFun name mtranspix cons @@ -330,7 +331,7 @@ defineProjections d con params names fields dataT -- Andreas, 2024-01-05 issue #7048: -- Only define hcomp when --cubical-compatible. - cubicalCompatible <- optCubicalCompatible <$> pragmaOptions + 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 @@ -728,8 +729,8 @@ -- params.ixs ⊢ dT reportSDoc "tc.data.ixs" 20 $ vcat [ "params :" <+> prettyTCM params - , "ixs :" <+> (addContext params $ prettyTCM ixs) - , "dT :" <+> (addContext params $ addContext ixs $ prettyTCM dT) + , "ixs :" <+> addContext params (prettyTCM ixs) + , "dT :" <+> addContext params (addContext ixs $ prettyTCM dT) ] -- theType <- abstract params <$> undefined interval <- primIntervalType @@ -1078,8 +1079,8 @@ 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)) + 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 @@ -1167,7 +1168,7 @@ 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 <*> (applyN bndry $ map (<@> pure iz) delta ++ map (fmap unArg) as0)) + ps0 <- (open =<<) $ (telePatterns <$> aTel0 <*> applyN bndry (map (<@> pure iz) delta ++ map (fmap unArg) as0)) let deltaArg i = do i <- i @@ -1731,8 +1732,7 @@ -- s' <- instantiateFull (getSort t) -- noConstraints $ s' `leqSort` s - withoutK <- withoutKOption - when withoutK $ do + whenM withoutKOption $ do q <- viewTC eQuantity usableAtModality' (Just s) ConstructorType (setQuantity q unitModality) (unEl conT) @@ -1757,13 +1757,16 @@ sa <- reduce $ getSort dom unless (isPath || uc == NoUniverseCheck || sa == SizeUniv) $ traceCall (CheckConArgFitsIn con isf (unDom dom) s) $ - sa `leqSort` s + fitSort sa s addContext (absName b, dom) $ do succ <$> fitsIn' li forceds' (absBody b) (raise 1 s) _ -> do - getSort t `leqSort` s + fitSort (getSort t) s return 0 + -- catch hard error from sort comparison to turn it into a soft error + fitSort sa s = leqSort sa s `catchError` \ err -> + warning $ ConstructorDoesNotFitInData con sa s err -- | When --without-K is enabled, we should check that the sorts of -- the index types fit into the sort of the datatype. diff --git a/src/full/Agda/TypeChecking/Rules/Decl.hs b/src/full/Agda/TypeChecking/Rules/Decl.hs --- a/src/full/Agda/TypeChecking/Rules/Decl.hs +++ b/src/full/Agda/TypeChecking/Rules/Decl.hs @@ -37,6 +37,7 @@ 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 @@ -73,6 +74,7 @@ import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.Update +import qualified Agda.Syntax.Common.Pretty as P import qualified Agda.Utils.SmallSet as SmallSet import Agda.Utils.Impossible @@ -215,17 +217,18 @@ whenJust finalChecks $ \ theMutualChecks -> do reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing." wakeupConstraints_ -- solve emptiness and instance constraints + checkingWhere <- asksTC envCheckingWhere solveSizeConstraints $ if checkingWhere 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 + case d of + A.Generalize{} -> pure () + _ -> do + reportSLn "tc.decl" 20 $ "Freezing all open metas." + void $ freezeMetas (openMetas metas) + where -- Switch maybe to abstract mode, benchmark, and debug print bracket. @@ -674,7 +677,8 @@ RecName -> DataOrRecSig npars AxiomName -> defaultAxiom -- Old comment: NB: used also for data and record type sigs _ -> __IMPOSSIBLE__ - where fun = FunctionDefn funD{ _funAbstr = Info.defAbstract i, _funOpaque = Info.defOpaque i } + where + fun = FunctionDefn $ set funAbstr_ (Info.defAbstract i) funD{ _funOpaque = Info.defOpaque i } addConstant x =<< do useTerPragma $ defn @@ -746,7 +750,8 @@ -- | Check a pragma. checkPragma :: Range -> A.Pragma -> TCM () -checkPragma r p = +checkPragma r p = do + let uselessPragma = warning . UselessPragma r traceCall (CheckPragma r p) $ case p of A.BuiltinPragma rb x | any isUntypedBuiltin b -> return () @@ -763,44 +768,62 @@ A.CompilePragma b x s -> do -- Check that x resides in the same module (or a child) as the pragma. x' <- defName <$> getConstInfo x -- Get the canonical name of x. - unlessM ((x' `isInModule`) <$> currentModule) $ - typeError $ GenericError $ + ifM ((x' `isInModule`) <$> currentModule) + {- then -} (addPragma (rangedThing b) x s) + {- else -} $ uselessPragma "COMPILE pragmas must appear in the same module as their corresponding definitions," - addPragma (rangedThing b) x s + A.StaticPragma x -> do - def <- getConstInfo x + def <- ignoreAbstractMode $ getConstInfo x case theDef def of Function{} -> markStatic x - _ -> typeError $ GenericError "STATIC directive only works on functions" + _ -> uselessPragma "STATIC directive only applies to functions" A.InjectivePragma x -> markInjective x + A.InjectiveForInferencePragma x -> do + def <- ignoreAbstractMode $ getConstInfo x + case theDef def of + Function{} -> markFirstOrder x + _ -> uselessPragma "INJECTIVE_FOR_INFERENCE directive only applies to functions" A.NotProjectionLikePragma qn -> do - def <- getConstInfo qn + def <- ignoreAbstractMode $ getConstInfo qn case theDef def of it@Function{} -> modifyGlobalDefinition qn $ \def -> def { theDef = it { funProjection = Left NeverProjection } } - _ -> typeError $ GenericError "NOT_PROJECTION_LIKE directive only applies to functions" + _ -> uselessPragma "NOT_PROJECTION_LIKE directive only applies to functions" A.InlinePragma b x -> do - def <- getConstInfo x + def <- ignoreAbstractMode $ getConstInfo x case theDef def of Function{} -> markInline b x d@Constructor{ conSrcCon } | copatternMatchingAllowed conSrcCon -> modifyGlobalDefinition x $ set lensTheDef d{ conInline = b } - _ -> typeError $ GenericError $ applyUnless b ("NO" ++) "INLINE directive only works on functions or constructors of records that allow copattern matching" - A.OptionsPragma{} -> typeError $ GenericError $ "OPTIONS pragma only allowed at beginning of file, before top module declaration" + _ -> uselessPragma $ P.text $ applyUnless b ("NO" ++) "INLINE directive only works on functions or constructors of records that allow copattern matching" + A.OptionsPragma{} -> uselessPragma $ "OPTIONS pragma only allowed at beginning of file, before top module declaration" A.DisplayPragma f ps e -> checkDisplayPragma f ps e - A.EtaPragma r -> do - let noRecord = typeError $ GenericError $ - "ETA pragma is only applicable to coinductive records" - caseMaybeM (isRecord r) noRecord $ \case - Record{ recInduction = ind, recEtaEquality' = eta } -> do - unless (ind == Just CoInductive) $ noRecord - if | Specified NoEta{} <- eta -> typeError $ GenericError $ - "ETA pragma conflicts with no-eta-equality declaration" - | otherwise -> return () - _ -> __IMPOSSIBLE__ - modifySignature $ updateDefinition r $ updateTheDef $ \case - def@Record{} -> def { recEtaEquality' = Specified YesEta } - _ -> __IMPOSSIBLE__ + + A.OverlapPragma q new -> do + ifNotM ((q `isInModule`) <$> currentModule) + (uselessPragma =<< fsep ( + pwords "This" ++ [pretty new] ++ + pwords "pragma must appear in the same module as the definition of" ++ + [prettyTCM q])) + + {- else -} do + + def <- getConstInfo q + case defInstance def of + Just i@InstanceInfo{ instanceOverlap = DefaultOverlap } -> + modifyGlobalDefinition q \x -> x { defInstance = Just i{ instanceOverlap = new } } + Just InstanceInfo{ instanceOverlap = old } -> typeError $ DuplicateOverlapPragma q old new + Nothing -> uselessPragma =<< pretty new <+> "pragma can only be applied to instances" + + A.EtaPragma q -> isRecord q >>= \case + Nothing -> noRecord + Just RecordData{ _recInduction = ind, _recEtaEquality' = eta } + | ind /= Just CoInductive -> noRecord + | Specified NoEta{} <- eta -> uselessPragma "ETA pragma conflicts with no-eta-equality declaration" + | otherwise -> modifyRecEta q $ const $ Specified YesEta + where + noRecord = uselessPragma "ETA pragma is only applicable to coinductive records" -- | Type check a bunch of mutual inductive recursive definitions. -- diff --git a/src/full/Agda/TypeChecking/Rules/Def.hs b/src/full/Agda/TypeChecking/Rules/Def.hs --- a/src/full/Agda/TypeChecking/Rules/Def.hs +++ b/src/full/Agda/TypeChecking/Rules/Def.hs @@ -13,6 +13,8 @@ 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 (Semigroup((<>))) import Agda.Interaction.Options @@ -32,7 +34,7 @@ import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench -import Agda.TypeChecking.Warnings ( warning, genericWarning ) +import Agda.TypeChecking.Warnings ( warning ) import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion @@ -47,6 +49,7 @@ 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) @@ -114,15 +117,8 @@ -- 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. - let - what - | Info.defOpaque i == TransparentDef = "abstract" - | otherwise = "opaque" whenM (isOpenMeta <$> lookupMetaInstantiation x) $ - setCurrentRange i $ genericWarning =<< - "Missing type signature for" <+> text what <+> "definition" <+> (prettyTCM name <> ".") $$ - fsep (pwords ("Types of " ++ what ++ " definitions are never inferred since this would leak") ++ - pwords ("information that should be " ++ what ++ ".")) + setCurrentRange i $ warning $ MissingTypeSignatureForOpaque name (Info.defOpaque i) checkFunDef' t info Nothing Nothing i name cs _ -> checkFunDef' t info Nothing Nothing i name cs @@ -196,9 +192,10 @@ -- Add the definition fun <- emptyFunctionData - addConstant' name ai name t $ set funMacro (Info.defMacro i == MacroDef) $ - FunctionDefn fun - { _funClauses = [ Clause -- trivial clause @name = v@ + addConstant' name ai name 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 @@ -214,7 +211,6 @@ } ] , _funCompiled = Just $ Done [] $ bodyMod v , _funSplitTree = Just $ SplittingDone 0 - , _funAbstr = Info.defAbstract i , _funOpaque = Info.defOpaque i } @@ -250,10 +246,13 @@ -> Maybe QName -- ^ is it a with function (if so, what's the name of the parent function) -> A.DefInfo -- ^ range info -> QName -- ^ the name of the function - -> Maybe Substitution -- ^ substitution (from with abstraction) that needs to be applied to module parameters + -> Maybe (Substitution, Map Name LetBinding) + -- ^ substitution (from with abstraction) that needs to be applied + -- to module parameters, and let-bindings inherited from parent + -- clause -> [A.Clause] -- ^ the clauses to check -> TCM () -checkFunDefS t ai extlam with i name withSub cs = do +checkFunDefS t ai extlam with i name withSubAndLets cs = do traceCall (CheckFunDefCall (getRange i) name cs True) $ do reportSDoc "tc.def.fun" 10 $ @@ -280,9 +279,9 @@ -- Check the clauses cs <- traceCall NoHighlighting $ do -- To avoid flicker. forM (zip cs [0..]) $ \ (c, clauseNo) -> do - atClause name clauseNo t withSub c $ do + atClause name clauseNo t (fst <$> withSubAndLets) c $ do (c,b) <- applyModalityToContextFunBody ai $ do - checkClause t withSub c + checkClause t withSubAndLets c -- Andreas, 2013-11-23 do not solve size constraints here yet -- in case we are checking the body of an extended lambda. -- 2014-04-24: The size solver requires each clause to be @@ -436,14 +435,14 @@ -- If there was a pragma for this definition, we can set the -- funTerminates field directly. fun <- emptyFunctionData - defn <- autoInline $ - set funMacro (ismacro || Info.defMacro i == MacroDef) $ - FunctionDefn fun + defn <- autoInline $ FunctionDefn $ + set funMacro_ (ismacro || Info.defMacro i == MacroDef) $ + set funAbstr_ (Info.defAbstract i) $ + fun { _funClauses = cs , _funCompiled = Just cc , _funSplitTree = mst , _funInv = inv - , _funAbstr = Info.defAbstract i , _funOpaque = Info.defOpaque i , _funExtLam = (\ e -> e { extLamSys = sys }) <$> extlam , _funWith = with @@ -553,6 +552,7 @@ , wfPermFinal :: Permutation -- ^ Final permutation (including permutation for the parent clause). , wfClauses :: List1 A.Clause -- ^ The given clauses for the with function , wfCallSubst :: Substitution -- ^ Subtsitution to generate call for the parent. + , wfLetBindings :: Map Name LetBinding -- ^ The let-bindings in scope of the parent (in the parent context) } checkSystemCoverage @@ -687,19 +687,28 @@ unless (null strippedPats) $ reportSDoc "tc.lhs.top" 50 $ "strippedPats:" <+> vcat [ prettyA p <+> "=" <+> prettyTCM v <+> ":" <+> prettyTCM a | A.ProblemEq p v a <- strippedPats ] closed_t <- flip abstract t <$> getContextTelescope - checkLeftHandSide (CheckLHS lhs) (Just x) aps t withSub strippedPats ret + checkLeftHandSide (CheckLHS lhs) (getRange lhs) (Just x) aps t withSub strippedPats ret -- | Type check a function clause. checkClause :: Type -- ^ Type of function defined by this clause. - -> Maybe Substitution -- ^ Module parameter substitution arising from with-abstraction. + -> Maybe (Substitution, Map Name LetBinding) -- ^ Module parameter substitution arising from with-abstraction, and inherited let-bindings. -> A.SpineClause -- ^ Clause. - -> TCM (Clause,ClausesPostChecks) -- ^ Type-checked clause + -> TCM (Clause, ClausesPostChecks) -- ^ Type-checked clause -checkClause t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do +checkClause t withSubAndLets c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do + let withSub = fst <$> withSubAndLets cxtNames <- reverse . map (fst . unDom) <$> getContext 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. @@ -909,9 +918,16 @@ rewriteEqnRHS qname eq $ List1.ifNull qes {-then-} rs {-else-} $ \ qes -> Rewrite qes : rs Invert qname pes -> invertEqnRHS qname (List1.toList pes) rs + LeftLet pes -> usingEqnRHS (List1.toList pes) rs where + -- @using@ clauses + usingEqnRHS :: [(A.Pattern, A.Expr)] -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem) + usingEqnRHS pes rs = do + let letBindings = for (List1.toList pes) $ \(p, e) -> A.LetPatBind (LetRange $ getRange e) p e + checkLetBindings letBindings $ rewriteEqnsRHS rs strippedPats rhs wh + -- @invert@ clauses invertEqnRHS :: QName -> [Named A.BindName (A.Pattern,A.Expr)] -> [A.RewriteEqn] -> TCM (Maybe Term, WithFunctionProblem) invertEqnRHS qname pes rs = do @@ -1118,13 +1134,16 @@ , " delta2" <+> do escapeContext impossible (size delta) $ addContext delta1 $ prettyTCM delta2 ] - return (v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS) + -- Only inherit user-written let bindings from parent clauses. Others, like @-patterns, + -- should not be carried over. + lets <- Map.filter ((== UserWritten) . letOrigin) <$> (traverse getOpen =<< viewTC eLetBindings) + return (v, WithFunction x aux t delta delta1 delta2 vtys t' ps npars perm' perm finalPerm cs argsS lets) + -- | Invoked in empty context. checkWithFunction :: [Name] -> WithFunctionProblem -> TCM (Maybe Term) checkWithFunction _ NoWithFunction = return Nothing -checkWithFunction cxtNames (WithFunction f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs argsS) = do - +checkWithFunction cxtNames (WithFunction f aux t delta delta1 delta2 vtys b qs npars perm' perm finalPerm cs argsS lets) = do let -- Δ₁ ws Δ₂ ⊢ withSub : Δ′ (where Δ′ is the context of the parent lhs) withSub :: Substitution withSub = let as = map (snd . unArg) vtys in @@ -1185,7 +1204,10 @@ setCurrentRange cs $ traceCall NoHighlighting $ -- To avoid flicker. traceCall (CheckWithFunctionType withFunType) $ - checkType withFunType + -- Jesper, 2024-07-10, issue $6841: + -- Having an ill-typed type can lead to problems in the + -- coverage checker, so we ensure there are no constraints here. + noConstraints $ checkType withFunType -- With display forms are closed df <- inTopContext $ makeOpen =<< withDisplayForm f aux delta1 delta2 n qs perm' perm @@ -1228,7 +1250,7 @@ -- 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) $ List1.toList cs + checkFunDefS withFunType ai Nothing (Just f) info aux (Just (withSub, lets)) $ List1.toList cs return $ Just $ call_in_parent -- | Type check a where clause. diff --git a/src/full/Agda/TypeChecking/Rules/LHS.hs b/src/full/Agda/TypeChecking/Rules/LHS.hs --- a/src/full/Agda/TypeChecking/Rules/LHS.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS.hs @@ -41,7 +41,7 @@ import Agda.Syntax.Abstract.Views (asView, deepUnscope) import Agda.Syntax.Concrete (FieldAssignment'(..),LensInScope(..)) import Agda.Syntax.Common as Common -import Agda.Syntax.Info as A +import qualified Agda.Syntax.Info as A import Agda.Syntax.Literal import Agda.Syntax.Position @@ -85,6 +85,7 @@ 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 @@ -93,13 +94,12 @@ import Agda.Utils.Impossible import Agda.TypeChecking.Free (freeIn) ---UNUSED Liang-Ting Chen 2019-07-16 ----- | Compute the set of flexible patterns in a list of patterns. The result is ----- the deBruijn indices of the flexible patterns. ---flexiblePatterns :: [NamedArg A.Pattern] -> TCM FlexibleVars ---flexiblePatterns nps = do --- forMaybeM (zip (downFrom $ length nps) nps) $ \ (i, Arg ai p) -> do --- runMaybeT $ (\ f -> FlexibleVar (getHiding ai) (getOrigin ai) f (Just i) i) <$> maybeFlexiblePattern p +-- | Extra read-only state for the LHS checker. +-- +data LHSContext = LHSContext + { lhsRange :: Range -- ^ The range of the whole lhs of a clause. + , lhsContextSize :: Nat -- ^ Original size of the context in which the lhs checker runs. + } -- | A pattern is flexible if it is dotted or implicit, or a record pattern -- with only flexible subpatterns. @@ -200,7 +200,7 @@ update eq@(ProblemEq p@(A.AnnP _ _ A.WildP{}) v a) = return [eq] update eq@(ProblemEq p@(A.AnnP info ty p') v a) = - (ProblemEq (A.AnnP info ty (A.WildP patNoRange)) v a :) <$> update (ProblemEq p' v a) + (ProblemEq (A.AnnP info ty (A.WildP empty)) v a :) <$> update (ProblemEq p' v a) update eq@(ProblemEq p v a) = reduce v >>= constructorForm >>= \case Con c ci es -> do @@ -259,7 +259,7 @@ -- In fs omitted explicit fields are replaced by underscores, -- and the fields are put in the correct order. - ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs cxs + ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs cxs -- We also need to insert missing implicit or instance fields. ps <- insertImplicitPatterns ExpandLast ps ctel @@ -464,7 +464,7 @@ let Def d _ = unEl $ unArg $ fromMaybe __IMPOSSIBLE__ mb axs = map (nameConcrete . qnameName . unArg) (conFields c) `withArgsFrom` qs cpi = ConPatternInfo (PatternInfo PatORec asB) r ft mb l - ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs axs + ps <- insertMissingFieldsFail d (const $ A.WildP empty) fs axs ConP c cpi <$> transfers ps qs ((asB , anns , p) , ConP c (ConPatternInfo i r ft mb l) qs) -> do @@ -546,7 +546,7 @@ A.AsP _ x p -> check vars $ [ProblemEq (A.VarP x) u a, ProblemEq p u a] ++ eqs A.AnnP _ _ A.WildP{} -> continue - A.AnnP r t p -> (ProblemEq (A.AnnP r t (A.WildP patNoRange)) u a:) <$> + A.AnnP r t p -> (ProblemEq (A.AnnP r t (A.WildP empty)) u a:) <$> check vars (ProblemEq p u a : eqs) A.WildP{} -> continue A.DotP{} -> continue @@ -648,6 +648,8 @@ checkLeftHandSide :: forall a. Call -- ^ Trace, e.g. 'CheckLHS' or 'CheckPattern'. + -> Range + -- ^ 'Range' of the entire left hand side, for error reporting. -> Maybe QName -- ^ The name of the definition we are checking. -> [NamedArg A.Pattern] @@ -662,7 +664,7 @@ -> (LHSResult -> TCM a) -- ^ Continuation. -> TCM a -checkLeftHandSide call f ps a withSub' strippedPats = +checkLeftHandSide call lhsRng f ps a withSub' strippedPats = Bench.billToCPS [Bench.Typing, Bench.CheckLHS] $ traceCallCPS call $ \ ret -> do @@ -828,7 +830,8 @@ let st = over (lhsProblem . problemEqs) (++ withEqs) st0 -- doing the splits: - (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` (size cxt)) $ checkLHS f st + let initLHSContext = LHSContext { lhsRange = lhsRng, lhsContextSize = size cxt } + (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` initLHSContext) $ checkLHS f st return result -- | Check that this split will generate a modality-correct internal @@ -837,28 +840,30 @@ -- 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 - :: Modality - -- ^ Modality to check at +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 + -- ^ 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 mod rho blocking gamma target = when (any ((/= defaultModality) . getModality) gamma) $ do +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 <+> parens (pretty target) + , "target: " <+> prettyTCM target + , "target (raw): " <+> pretty target , "Δ'target: " <+> prettyTCM (applyPatSubst rho target) , "blocking:" <+> prettyTCM blocking ] - case firstForced rho (length gamma) of - Just ix -> do + 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 @@ -911,7 +916,6 @@ argn <- name arg when docheck $ usableAtModality (IndexedClauseArg forced argn) mod ty' - Nothing -> pure () -- ALways check the target clause type. Specifically, we check it both -- in Δ' and in Γ. The check in Δ' will sometimes let slip by a @@ -919,8 +923,9 @@ -- 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. - usableAtModality IndexedClause mod (unEl (applyPatSubst rho target)) - inTopContext $ addContext gamma $ usableAtModality IndexedClause mod (unEl target) + 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 @@ -958,8 +963,7 @@ -- | The loop (tail-recursive): split at a variable in the problem until problem is solved -checkLHS - :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader Nat tcm) +checkLHS :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader LHSContext tcm) => Maybe QName -- ^ The name of the definition we are checking. -> LHSState a -- ^ The current state. -> tcm a @@ -1175,7 +1179,7 @@ -- newContext = Γ Ξ -- cpSub = raiseS |Ξ| -- - lhsCxtSize <- ask -- size of the context before checkLHS call. + lhsCxtSize <- asks lhsContextSize -- size of the context before checkLHS call. reportSDoc "tc.lhs.split.partial" 10 $ "lhsCxtSize =" <+> prettyTCM lhsCxtSize newContext <- liftTCM $ computeLHSContext names delta1 @@ -1358,7 +1362,7 @@ -- Don't split on lazy (non-eta) constructor case focusPat of - A.ConP cpi _ _ | conPatLazy cpi == ConPatLazy -> + A.ConP cpi _ _ | A.conPatLazy cpi == A.ConPatLazy -> unlessM (isEtaRecord d) $ softTypeError $ ForcedConstructorNotInstantiated focusPat _ -> return () @@ -1378,8 +1382,9 @@ ps <- insertImplicitPatterns ExpandLast ps gamma return $ useNamesFromPattern ps gamma A.RecP _ fs -> do - axs <- map argFromDom . recordFieldNames . theDef <$> getConstInfo d - ps <- insertMissingFieldsFail d (const $ A.WildP patNoRange) fs axs + 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__ @@ -1546,12 +1551,12 @@ Quantity1{} -> __IMPOSSIBLE__ Quantityω{} -> q - liftTCM $ addContext delta' $ do - withoutK <- optWithoutK <$> pragmaOptions - cubical <- optCubicalCompatible <$> pragmaOptions - mod <- currentModality - when ((withoutK || cubical) && not (null ixs)) $ - conSplitModalityCheck mod rho (length delta2) tel (unArg target) + 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 @@ -1576,8 +1581,7 @@ -> m () checkMatchingAllowed d = \case IsRecord InductionAndEta { recordInduction=ind, recordEtaEquality=eta } - | Just CoInductive <- ind -> typeError $ - GenericError "Pattern matching on coinductive types is not allowed" + | Just CoInductive <- ind -> typeError SplitOnCoinductive | not $ patternMatchingAllowed eta -> typeError $ SplitOnNonEtaRecord d | otherwise -> return () IsData -> return () @@ -1713,14 +1717,14 @@ disambiguateProjection h ambD@(AmbQ ds) b = do -- If the target is not a record type, that's an error. -- It could be a meta, but since we cannot postpone lhs checking, we crash here. - caseMaybeM (liftTCM $ isRecordType $ unArg b) notRecord $ \(r, vs, def) -> case def of - Record{ recFields = fs, recInduction, recEtaEquality' = eta } -> do + caseMaybeM (liftTCM $ isRecordType $ unArg b) notRecord + \ (r, vs, RecordData{ _recFields = fs, _recInduction = ind, _recEtaEquality' = eta }) -> do reportSDoc "tc.lhs.split" 20 $ sep - [ text $ "we are of record type r = " ++ prettyShow r - , text "applied to parameters vs = " <+> prettyTCM vs - , text $ "and have fields fs = " ++ prettyShow (map argFromDom fs) + [ "we are of record type r = " <> pure (P.pretty r) + , "applied to parameters vs = " <> prettyTCM vs + , "and have fields fs = " <> pure (P.pretty $ map argFromDom fs) ] - let comatching = recInduction == Just CoInductive + let comatching = ind == Just CoInductive || copatternMatchingAllowed eta -- Try the projection candidates. -- First, we try to find a disambiguation that doesn't produce @@ -1732,8 +1736,6 @@ ([] , [] ) -> __IMPOSSIBLE__ (err:_, [] ) -> throwError err (_ , disambs@((d,a):_)) -> typeError $ AmbiguousProjection d (map fst disambs) - _ -> __IMPOSSIBLE__ - where tryDisambiguate constraintsOk fs r vs comatching failure = do -- Note that tryProj wraps TCM in an ExceptT, collecting errors diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs b/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs @@ -683,8 +683,8 @@ 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 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] ] @@ -715,8 +715,8 @@ unifyStep s EtaExpandEquation{ expandAt = k, expandRecordType = d, expandParameters = pars } = do recd <- fromMaybe __IMPOSSIBLE__ <$> isRecord d - let delta = recTel recd `apply` pars - c = recConHead recd + 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 diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs b/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs @@ -10,8 +10,6 @@ import Control.Monad.State import Control.Monad.Except - -import Agda.Interaction.Options (optCubical) import Agda.Syntax.Common import Agda.Syntax.Internal @@ -57,7 +55,7 @@ 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 <- optCubical <$> pragmaOptions + cubical <- cubicalOption "cubical:" <+> text (show cubical) reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do pathp <- getTerm' builtinPathP @@ -212,7 +210,7 @@ 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) + lift $ runExceptT (map unArg <$> transpSysTel' True tel [(i, leftInv0)] face step0i) addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv :" <+> prettyTCM (absBody leftInv) addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ @@ -349,7 +347,7 @@ 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) + 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 diff --git a/src/full/Agda/TypeChecking/Rules/Record.hs b/src/full/Agda/TypeChecking/Rules/Record.hs --- a/src/full/Agda/TypeChecking/Rules/Record.hs +++ b/src/full/Agda/TypeChecking/Rules/Record.hs @@ -30,6 +30,7 @@ import Agda.TypeChecking.Warnings import Agda.TypeChecking.CompiledClause (hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile +import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Rules.Data ( getGeneralizedParameters, bindGeneralizedParameters, bindParameters @@ -41,6 +42,7 @@ 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 @@ -186,8 +188,8 @@ -- 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 $ NoEta patCopat) Specified eta - -- haveEta = maybe (Inferred $ conInduction == Inductive && etaenabled) Specified eta + noEta = Inferred $ NoEta patCopat + haveEta0 = maybe noEta Specified eta con = ConHead conName (IsRecord patCopat) conInduction $ map argFromDom fs -- A record is irrelevant if all of its fields are. @@ -197,16 +199,18 @@ 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 - when (conInduction == CoInductive && theEtaEquality haveEta == YesEta) $ do - typeError . GenericDocError =<< do - sep [ "Agda doesn't like coinductive records with eta-equality." - , "If you must, use pragma" - , "{-# ETA" <+> prettyTCM name <+> "#-}" - ] + -- 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 -- Jesper, 2021-05-26: Warn when declaring coinductive record @@ -374,7 +378,7 @@ -- we define composition here so that the projections are already in the signature. - whenM (optCubicalCompatible <$> pragmaOptions) do + whenM cubicalCompatibleOption do escapeContext impossible npars do addCompositionForRecord name haveEta con tel (map argFromDom fs) ftel rect @@ -389,7 +393,7 @@ -- 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 <$) <$> eta0 + eta = ((patCopat <$) . rangedThing) <$> eta0 addCompositionForRecord @@ -776,7 +780,8 @@ Quantityω _ -> Quantityω QωInferred q -> q addConstant projname $ - (defaultDefn ai' projname (killRange finalt) lang $ FunctionDefn + (defaultDefn ai' projname (killRange finalt) lang $ FunctionDefn $ + set funProj_ True $ fun { _funClauses = [clause] , _funCompiled = Just cc @@ -790,8 +795,11 @@ } computePolarity [projname] - case Info.defInstance info of - -- fields do not have an @instance@ keyword!? + 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 () diff --git a/src/full/Agda/TypeChecking/Rules/Term.hs b/src/full/Agda/TypeChecking/Rules/Term.hs --- a/src/full/Agda/TypeChecking/Rules/Term.hs +++ b/src/full/Agda/TypeChecking/Rules/Term.hs @@ -21,7 +21,7 @@ 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) +import Agda.Syntax.Concrete (FieldAssignment'(..), nameFieldA, TacticAttribute'(..)) import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Common import Agda.Syntax.Internal as I @@ -41,7 +41,7 @@ import Agda.TypeChecking.EtaContract import Agda.TypeChecking.Generalize import Agda.TypeChecking.Implicit -import Agda.TypeChecking.InstanceArguments (solveAwakeInstanceConstraints) +import Agda.TypeChecking.InstanceArguments import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.IApplyConfluence import Agda.TypeChecking.Level @@ -326,7 +326,7 @@ 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) (tbTacticAttr tac) + 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 @@ -338,7 +338,7 @@ -- 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 + (tel, _, target) <- getOutputTypeName t case target of OutputTypeName{} -> return () OutputTypeVar{} -> return () @@ -385,8 +385,8 @@ expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit) checkExpr e expectedType -checkPath :: A.TypedBinding -> A.Expr -> Type -> TCM Term -checkPath b@(A.TBind _r _tac (xp :| []) typ) body ty = do +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 $ genericError $ "Patterns are not allowed in Path-lambdas" @@ -407,7 +407,6 @@ equalTerm (btyp iZero) lhs' (unArg lhs) equalTerm (btyp iOne) rhs' (unArg rhs) return t -checkPath b body ty = __IMPOSSIBLE__ --------------------------------------------------------------------------- -- * Lambda abstractions @@ -425,47 +424,60 @@ -- Andreas, 2020-03-25, issue #4481: since we have named lambdas now, -- we need to insert skipped hidden arguments. xps <- insertImplicitBindersT1 xps0 target - checkLambda' cmp (A.TBind r tac xps typ) xps typ body target + checkLambda' cmp r tac xps typ body target -checkLambda' - :: Comparison -- ^ @cmp@ - -> A.TypedBinding -- ^ @TBind _ _ xps typ@ - -> List1 (NamedArg Binder) -- ^ @xps@ - -> A.Expr -- ^ @typ@ - -> A.Expr -- ^ @body@ - -> Type -- ^ @target@ +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 b xps typ body target = do +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 - isUnderscore = \case { A.Underscore{} -> True; _ -> False } possiblePath = numbinds == 1 && isUnderscore (unScope typ) && isRelevant info && visible info info = getArgInfo $ List1.head xs trySeeingIfPath = do - cubical <- isJust . optCubical <$> pragmaOptions + cubical <- isJust <$> cubicalOption reportSLn "tc.term.lambda" 60 $ "trySeeingIfPath for " ++ show xps let postpone' = if cubical then postpone else \ _ _ -> dontUseTargetType ifBlocked target postpone' $ \ _ t -> do ifNotM (isPathType <$> pathView t) dontUseTargetType {-else-} $ if cubical - then checkPath b body t + then checkPath (List1.head xps) typ body t else genericError $ unwords [ "Option --cubical/--erased-cubical needed to build" , "a path with a lambda abstraction" @@ -614,7 +626,7 @@ return info -- Andreas, issue #630: take name from function type if lambda name is "_". -lambdaAddContext :: Name -> ArgName -> Dom Type -> TCM a -> TCM a +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 @@ -940,14 +952,7 @@ -- 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 = " ++ prettyShow r - - reportSDoc "tc.term.rec" 30 $ " xs = " <> do - text =<< prettyShow . map unDom <$> getRecordFieldNames r - reportSDoc "tc.term.rec" 30 $ " ftel= " <> do - prettyTCM =<< getRecordFieldTypes r - reportSDoc "tc.term.rec" 30 $ " con = " <> do - text =<< prettyShow <$> getRecordConstructor r + reportSDoc "tc.term.rec" 20 $ " r = " <> pure (P.pretty r) def <- getRecordDef r let -- Field names (C.Name) with ArgInfo from record type definition. @@ -955,11 +960,11 @@ -- Just field names. xs = map unArg cxs -- Record constructor. - con = killRange $ recConHead def + con = killRange $ _recConHead def reportSDoc "tc.term.rec" 20 $ vcat - [ " xs = " <> return (P.pretty xs) - , " ftel= " <> prettyTCM (recTel def) - , " con = " <> return (P.pretty con) + [ " xs = " <> pure (P.pretty xs) + , " ftel= " <> prettyTCM (_recTel def) + , " con = " <> pure (P.pretty con) ] -- Record expressions corresponding to erased record @@ -974,22 +979,22 @@ -- 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) + 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 (map unArg cxs) + fs <- expandModuleAssigns mfs xs -- 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 (prettyShow x) + meta x = A.Underscore $ A.MetaInfo re 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 re es (recTel def `apply` vs) >>= \case + args <- checkArguments_ cmp ExpandLast re es (_recTel def `apply` vs) >>= \case (elims, remainingTel) | null remainingTel , Just args <- allApplyElims elims -> return args _ -> __IMPOSSIBLE__ @@ -1065,7 +1070,7 @@ name <- freshNoName $ getRange recexpr addLetBinding defaultArgInfo Inserted name v t' $ do - let projs = map argFromDom $ recFields defn + let projs = map argFromDom $ _recFields defn -- Andreas, 2018-09-06, issue #3122. -- Associate the concrete record field names used in the record expression @@ -1074,7 +1079,7 @@ -- Desugar record update expression into record expression. let fs' = map (\ (FieldAssignment x e) -> (x, Just e)) fs - axs <- map argFromDom <$> getRecordFieldNames r + 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 ei [ Left (FieldAssignment x e) | (Arg _ x, Just e) <- zip axs es' ] @@ -1151,7 +1156,7 @@ e <- scopedExpr e - irrelevantIfProp <- (runBlocked $ isPropM t) >>= \case + irrelevantIfProp <- runBlocked (isPropM t) >>= \case Right True -> do let mod = unitModality { modRelevance = Irrelevant } return $ fmap dontCare . applyModalityToContext mod @@ -1163,7 +1168,7 @@ -- 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 cmp t i + A.Underscore i -> checkUnderscore i cmp t A.WithApp _ e es -> typeError $ NotImplemented "type checking of with application" @@ -1330,6 +1335,7 @@ -- 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 ] @@ -1371,34 +1377,34 @@ [ "Raw:" , text (show t0) ] - checkMeta (newQuestionMark' new ii) cmp t0 i -- Andreas, 2013-05-22 use unreduced type t0! + checkMeta i (newQuestionMark' new ii) cmp t0 -- Andreas, 2013-05-22 use unreduced type t0! -- | Check an underscore without arguments. -checkUnderscore :: Comparison -> Type -> A.MetaInfo -> TCM Term -checkUnderscore = checkMeta (newValueMeta RunMetaOccursCheck) +checkUnderscore :: A.MetaInfo -> Comparison -> Type -> TCM Term +checkUnderscore i = checkMeta i (newValueMetaOfKind i RunMetaOccursCheck) -- | Type check a meta variable. -checkMeta :: (Comparison -> Type -> TCM (MetaId, Term)) -> Comparison -> Type -> A.MetaInfo -> TCM Term -checkMeta newMeta cmp t i = fst <$> checkOrInferMeta newMeta (Just (cmp , t)) i +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 :: (Comparison -> Type -> TCM (MetaId, Term)) -> A.MetaInfo -> TCM (Elims -> Term, Type) -inferMeta newMeta i = mapFst applyE <$> checkOrInferMeta newMeta Nothing i +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 - :: (Comparison -> Type -> TCM (MetaId, Term)) + :: A.MetaInfo + -> (Comparison -> Type -> TCM (MetaId, Term)) -> Maybe (Comparison , Type) - -> A.MetaInfo -> TCM (Term, Type) -checkOrInferMeta newMeta mt i = do +checkOrInferMeta i newMeta mt = do case A.metaNumber i of Nothing -> do - setScope (A.metaScope i) + unlessNull (A.metaScope i) setScope (cmp , t) <- maybe ((CmpEq,) <$> workOnTypes newTypeMeta_) return mt (x, v) <- newMeta cmp t setMetaNameSuggestion x (A.metaNameSuggestion i) @@ -1428,6 +1434,7 @@ , A.metaScope = emptyScopeInfo , A.metaNumber = Nothing , A.metaNameSuggestion = prettyShow $ A.nameConcrete $ A.binderName x + , A.metaKind = A.UnificationMeta } @@ -1489,8 +1496,10 @@ 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). - let checkU = checkMeta (newMetaArg (setHiding Hidden info) x) CmpLeq t0 - let checkQ = checkQuestionMark (newInteractionMetaArg (setHiding Hidden info) x) CmpLeq t0 + -- 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. @@ -1626,7 +1635,7 @@ ] ] fvs <- getContextSize - checkLeftHandSide (CheckPattern p EmptyTel t) Nothing [p0] t0 Nothing [] $ \ (LHSResult _ delta0 ps _ _t _ asb _ _) -> bindAsPatterns asb $ do + 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 diff --git a/src/full/Agda/TypeChecking/Serialise.hs b/src/full/Agda/TypeChecking/Serialise.hs --- a/src/full/Agda/TypeChecking/Serialise.hs +++ b/src/full/Agda/TypeChecking/Serialise.hs @@ -77,7 +77,7 @@ -- 32-bit machines). Word64 does not have these problems. currentInterfaceVersion :: Word64 -currentInterfaceVersion = 20240102 * 10 + 1 +currentInterfaceVersion = 20240629 * 10 + 0 -- | The result of 'encode' and 'encodeInterface'. diff --git a/src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs b/src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs --- a/src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs +++ b/src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs @@ -18,6 +18,7 @@ import Agda.Utils.Functor import Agda.Utils.Lens +import Agda.Utils.Null import Agda.Utils.Impossible -- Don't serialize the tactic. @@ -51,13 +52,13 @@ _ -> malformed instance EmbPrj Access where - icod_ (PrivateAccess UserWritten) = pure 0 - icod_ PrivateAccess{} = pure 1 - icod_ PublicAccess = pure 2 + icod_ (PrivateAccess _ UserWritten) = pure 0 + icod_ PrivateAccess{} = pure 1 + icod_ PublicAccess = pure 2 value = \case - 0 -> pure $ PrivateAccess UserWritten - 1 -> pure $ PrivateAccess Inserted + 0 -> pure $ PrivateAccess empty UserWritten + 1 -> pure $ privateAccessInserted 2 -> pure PublicAccess _ -> malformed @@ -144,14 +145,15 @@ -- valu _ = malformed instance EmbPrj BindingSource where - icod_ LambdaBound = pure 0 - icod_ PatternBound = pure 1 - icod_ LetBound = pure 2 - icod_ WithBound = pure 3 + icod_ = \case + LambdaBound -> pure 0 + PatternBound _ -> pure 1 + LetBound -> pure 2 + WithBound -> pure 3 value = \case 0 -> pure LambdaBound - 1 -> pure PatternBound + 1 -> pure $ PatternBound empty 2 -> pure LetBound 3 -> pure WithBound _ -> malformed @@ -180,7 +182,7 @@ 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 p a) = icodeN 10 (A.RecP p) a + icod_ (A.RecP a b) = icodeN 10 A.RecP a b icod_ (A.EqualP _ a) = __IMPOSSIBLE__ icod_ (A.WithP i a) = icodeN 11 (A.WithP i) a icod_ (A.AnnP i a p) = icodeN 12 (A.AnnP i) a p @@ -196,7 +198,7 @@ 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] = valuN (A.RecP i) a + valu [10, a, b] = valuN A.RecP a b valu [11, a] = valuN (A.WithP i) a valu [12, a, b] = valuN (A.AnnP i) a b valu _ = malformed diff --git a/src/full/Agda/TypeChecking/Serialise/Instances/Common.hs b/src/full/Agda/TypeChecking/Serialise/Instances/Common.hs --- a/src/full/Agda/TypeChecking/Serialise/Instances/Common.hs +++ b/src/full/Agda/TypeChecking/Serialise/Instances/Common.hs @@ -36,6 +36,7 @@ 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 @@ -53,6 +54,8 @@ import Agda.Utils.List2 (List2(List2)) import qualified Agda.Utils.List2 as List2 import qualified Agda.Utils.Maybe.Strict as Strict +import Agda.Utils.Null +import Agda.Utils.SmallSet (SmallSet(..)) import Agda.Utils.Trie (Trie(..)) import Agda.Utils.WithDefault @@ -269,6 +272,10 @@ 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 @@ -304,6 +311,10 @@ 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 } @@ -411,6 +422,11 @@ 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) $ icodeN' A.QName a b @@ -489,6 +505,7 @@ valu _ = malformed instance EmbPrj PatternOrCopattern +instance EmbPrj OverlapMode instance EmbPrj Induction where icod_ Inductive = icodeN' Inductive @@ -747,3 +764,34 @@ 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 diff --git a/src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs b/src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs --- a/src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs +++ b/src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs @@ -32,6 +32,7 @@ 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__ @@ -40,11 +41,11 @@ EmptyRewritePragma -> icodeN 2 EmptyRewritePragma UselessPublic -> icodeN 3 UselessPublic UselessInline a -> icodeN 4 UselessInline a - GenericWarning a -> icodeN 5 GenericWarning 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 @@ -91,6 +92,18 @@ PatternShadowsConstructor a b -> icodeN 49 PatternShadowsConstructor a b -- Not source code related, therefore they should never be serialized DuplicateInterfaceFiles a b -> __IMPOSSIBLE__ + 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 value = vcase $ \ case [0, a, b] -> valuN UnreachableClauses a b @@ -98,7 +111,7 @@ [2] -> valuN EmptyRewritePragma [3] -> valuN UselessPublic [4, a] -> valuN UselessInline a - [5, a] -> valuN GenericWarning 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 @@ -143,16 +156,74 @@ [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 _ -> malformed +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 + HeadSymbolIsProjection a -> icodeN 4 HeadSymbolIsProjection a + 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, a] -> valuN HeadSymbolIsProjection a + [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' OptionRenamed a b + OptionRenamed a b -> icodeN 0 OptionRenamed a b + WarningProblem a -> icodeN 1 WarningProblem a value = vcase $ \case - [a, b] -> valuN OptionRenamed a b + [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 @@ -212,11 +283,12 @@ OpenPublicAbstract r -> icodeN 26 OpenPublicAbstract r OpenPublicPrivate r -> icodeN 27 OpenPublicPrivate r EmptyConstructor a -> icodeN 28 EmptyConstructor a - InvalidRecordDirective a -> icodeN 29 InvalidRecordDirective a + -- 29 removed InvalidConstructor a -> icodeN 30 InvalidConstructor a InvalidConstructorBlock a -> icodeN 31 InvalidConstructorBlock a MissingDeclarations a -> icodeN 32 MissingDeclarations a HiddenGeneralize r -> icodeN 33 HiddenGeneralize r + UselessMacro r -> icodeN 34 UselessMacro r SafeFlagEta {} -> __IMPOSSIBLE__ SafeFlagInjective {} -> __IMPOSSIBLE__ SafeFlagNoCoverageCheck {} -> __IMPOSSIBLE__ @@ -256,11 +328,12 @@ [26,r] -> valuN OpenPublicAbstract r [27,r] -> valuN OpenPublicPrivate r [28,r] -> valuN EmptyConstructor r - [29,r] -> valuN InvalidRecordDirective r + -- 29 removed [30,r] -> valuN InvalidConstructor r [31,r] -> valuN InvalidConstructorBlock r [32,r] -> valuN MissingDeclarations r [33,r] -> valuN HiddenGeneralize r + [34,r] -> valuN UselessMacro r _ -> malformed instance EmbPrj LibWarning where @@ -310,8 +383,8 @@ 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) = - 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 + 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) = + 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 value = valueN PragmaOptions @@ -319,8 +392,10 @@ icod_ opts = icode (profileOptionsToList opts) value = fmap profileOptionsFromList . value -instance EmbPrj ProfileOption where +instance EmbPrj ProfileOption +instance EmbPrj LHSOrPatSyn + instance EmbPrj UnicodeOrAscii instance EmbPrj ConfluenceCheck where @@ -362,7 +437,7 @@ InvalidCoverageCheckPragma_ -> 20 InvalidNoPositivityCheckPragma_ -> 21 InvalidNoUniverseCheckPragma_ -> 22 - InvalidRecordDirective_ -> 23 + DuplicateRecordDirective_ -> 23 InvalidTerminationCheckPragma_ -> 24 MissingDeclarations_ -> 25 MissingDefinitions_ -> 26 @@ -390,7 +465,6 @@ FixityInRenamingModule_ -> 48 InvalidCharacterLiteral_ -> 49 UselessPragma_ -> 50 - GenericWarning_ -> 51 IllformedAsClause_ -> 52 InstanceArgWithExplicitArg_ -> 53 InstanceWithExplicitArg_ -> 54 @@ -445,6 +519,35 @@ FaceConstraintCannotBeNamed_ -> 103 PatternShadowsConstructor_ -> 104 DuplicateInterfaceFiles_ -> 105 + ConfluenceCheckingIncompleteBecauseOfMeta_ -> 106 + BuiltinDeclaresIdentifier_ -> 107 + ConfluenceForCubicalNotSupported_ -> 108 + PragmaCompileList_ -> 109 + PragmaCompileMaybe_ -> 110 + NoMain_ -> 111 + DuplicateRewriteRule_ -> 112 + MissingTypeSignatureForOpaque_ -> 113 + UselessMacro_ -> 114 + WarningProblem_ -> 115 + ConflictingPragmaOptions_ -> 116 + ConstructorDoesNotFitInData_ -> 117 + CustomBackendWarning_ -> 118 + CoinductiveEtaRecord_ -> 119 + RewriteLHSNotDefinitionOrConstructor_ -> 120 + RewriteVariablesNotBoundByLHS_ -> 121 + RewriteVariablesBoundMoreThanOnce_ -> 122 + RewriteLHSReduces_ -> 123 + RewriteHeadSymbolIsProjection_ -> 124 + RewriteHeadSymbolIsProjectionLikeFunction_ -> 125 + RewriteHeadSymbolIsTypeConstructor_ -> 126 + RewriteHeadSymbolContainsMetas_ -> 127 + RewriteConstructorParametersNotGeneral_ -> 128 + RewriteContainsUnsolvedMetaVariables_ -> 129 + RewriteBlockedOnProblems_ -> 130 + RewriteRequiresDefinitions_ -> 131 + RewriteDoesNotTargetRewriteRelation_ -> 132 + RewriteBeforeFunctionDefinition_ -> 133 + RewriteBeforeMutualFunctionDefinition_ -> 134 value = \case 0 -> return OverlappingTokensWarning_ @@ -470,7 +573,7 @@ 20 -> return InvalidCoverageCheckPragma_ 21 -> return InvalidNoPositivityCheckPragma_ 22 -> return InvalidNoUniverseCheckPragma_ - 23 -> return InvalidRecordDirective_ + 23 -> return DuplicateRecordDirective_ 24 -> return InvalidTerminationCheckPragma_ 25 -> return MissingDeclarations_ 26 -> return MissingDefinitions_ @@ -498,7 +601,6 @@ 48 -> return FixityInRenamingModule_ 49 -> return InvalidCharacterLiteral_ 50 -> return UselessPragma_ - 51 -> return GenericWarning_ 52 -> return IllformedAsClause_ 53 -> return InstanceArgWithExplicitArg_ 54 -> return InstanceWithExplicitArg_ @@ -553,6 +655,35 @@ 103 -> return FaceConstraintCannotBeNamed_ 104 -> return PatternShadowsConstructor_ 105 -> return DuplicateInterfaceFiles_ + 106 -> return ConfluenceCheckingIncompleteBecauseOfMeta_ + 107 -> return BuiltinDeclaresIdentifier_ + 108 -> return ConfluenceForCubicalNotSupported_ + 109 -> return PragmaCompileList_ + 110 -> return PragmaCompileMaybe_ + 111 -> return NoMain_ + 112 -> return DuplicateRewriteRule_ + 113 -> return MissingTypeSignatureForOpaque_ + 114 -> return UselessMacro_ + 115 -> return WarningProblem_ + 116 -> return ConflictingPragmaOptions_ + 117 -> return ConstructorDoesNotFitInData_ + 118 -> return CustomBackendWarning_ + 119 -> return CoinductiveEtaRecord_ + 120 -> return RewriteLHSNotDefinitionOrConstructor_ + 121 -> return RewriteVariablesNotBoundByLHS_ + 122 -> return RewriteVariablesBoundMoreThanOnce_ + 123 -> return RewriteLHSReduces_ + 124 -> return RewriteHeadSymbolIsProjection_ + 125 -> return RewriteHeadSymbolIsProjectionLikeFunction_ + 126 -> return RewriteHeadSymbolIsTypeConstructor_ + 127 -> return RewriteHeadSymbolContainsMetas_ + 128 -> return RewriteConstructorParametersNotGeneral_ + 129 -> return RewriteContainsUnsolvedMetaVariables_ + 130 -> return RewriteBlockedOnProblems_ + 131 -> return RewriteRequiresDefinitions_ + 132 -> return RewriteDoesNotTargetRewriteRelation_ + 133 -> return RewriteBeforeFunctionDefinition_ + 134 -> return RewriteBeforeMutualFunctionDefinition_ _ -> malformed diff --git a/src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs b/src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs --- a/src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs +++ b/src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs @@ -17,6 +17,7 @@ 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 @@ -29,10 +30,15 @@ value = valueN Dom instance EmbPrj Signature where - icod_ (Sig a b c) = icodeN' Sig a b c + icod_ (Sig a b c d) = icodeN' Sig a b c d 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) = icodeN' Section a @@ -213,6 +219,10 @@ 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 m n o p blocked r s) = icodeN' Defn a b (P.killRange c) d e f g h i j k l m n o p (ossify blocked) r s @@ -411,7 +421,7 @@ instance EmbPrj Defn where icod_ (Axiom a) = icodeN 0 Axiom a - icod_ (Function a b s t u c d e f g h i j k l m) = icodeN 1 (\ a b s -> Function a b s t) a b s u c d e f g h i j k l m + 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 @@ -423,8 +433,8 @@ value = vcase valu where valu [0, a] = valuN Axiom a - valu [1, a, b, s, u, c, d, e, f, g, h, i, j, k, l, m] - = valuN (\ a b s -> Function a b s Nothing) a b s u c d e f g h i j k l m + 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 @@ -462,16 +472,7 @@ valu [0, a, b, c] = valuN SplitAt a b c valu _ = malformed -instance EmbPrj FunctionFlag where - icod_ FunStatic = pure 0 - icod_ FunInline = pure 1 - icod_ FunMacro = pure 2 - - value = \case - 0 -> pure FunStatic - 1 -> pure FunInline - 2 -> pure FunMacro - _ -> malformed +instance EmbPrj FunctionFlag instance EmbPrj a => EmbPrj (WithArity a) where icod_ (WithArity a b) = icodeN' WithArity a b @@ -649,3 +650,31 @@ 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 = icodeN 2 PiK + 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] = valuN PiK + 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 diff --git a/src/full/Agda/TypeChecking/SizedTypes.hs b/src/full/Agda/TypeChecking/SizedTypes.hs --- a/src/full/Agda/TypeChecking/SizedTypes.hs +++ b/src/full/Agda/TypeChecking/SizedTypes.hs @@ -77,8 +77,7 @@ reportSLn "tc.size.lt" 20 $ " - size bound is not blocked" catchConstraint (CheckSizeLtSat t) $ do unlessM (checkSizeNeverZero b) $ do - typeError . GenericDocError =<< do - "Possibly empty type of sizes " <+> prettyTCM t + typeError $ EmptyTypeOfSizes t -- | Precondition: Term is reduced and not blocked. -- Throws a 'patternViolation' if undecided diff --git a/src/full/Agda/TypeChecking/SizedTypes/Pretty.hs b/src/full/Agda/TypeChecking/SizedTypes/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/SizedTypes/Pretty.hs @@ -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) +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 = reverse $ map (fst . unDom) cxt + -- text ("[#cxt=" ++ show (size cxt) ++ "]") <+> do + prettyList (map prettyTCM cxtNames) <+> do + applyUnless (null hs) + ((hcat (punctuate ", " $ map prettyTCM hs) <+> "|-") <+>) + (prettyTCM c) diff --git a/src/full/Agda/TypeChecking/SizedTypes/Solve.hs b/src/full/Agda/TypeChecking/SizedTypes/Solve.hs --- a/src/full/Agda/TypeChecking/SizedTypes/Solve.hs +++ b/src/full/Agda/TypeChecking/SizedTypes/Solve.hs @@ -80,9 +80,10 @@ 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.Function @@ -102,8 +103,6 @@ import Agda.Utils.Impossible -type CC = ProblemConstraint - -- | Flag to control the behavior of size solver. data DefaultToInfty = DefaultToInfty -- ^ Instantiate all unconstrained size variables to ∞. @@ -117,16 +116,14 @@ -- 1. Take out the size constraints normalised. - let norm c = mapClosure normalise (theConstraint c) <&> \ cl -> c { theConstraint = cl } - cs0 <- mapM norm =<< S.takeSizeConstraints (== CmpLeq) - -- NOTE: this deletes the size constraints from the constraint set! + -- 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 :: TCM a -- Defined, but not currently used - cannotSolve = typeError . GenericDocError =<< - vcat ("Cannot solve size constraints" : map prettyTCM cs0) -- 2. Cluster the constraints by common size metas. @@ -159,7 +156,7 @@ -- Solve the clusters. constrainedMetas <- Set.unions <$> do - forM (ccs) $ \ (cs :: List1 CC) -> do + forM (ccs) $ \ (cs :: List1 ProblemConstraint) -> do reportSDoc "tc.size.solve" 60 $ vcat $ "size constraint cluster:" <| fmap (text . show) cs @@ -203,6 +200,10 @@ 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 $ @@ -354,27 +355,26 @@ -- | 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 - "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,) $ nonEmpty $ map sizeMetaId $ Set.toList $ flexs c -- @css@ are the clusters of constraints. - css :: [List1 (CC,HypSizeConstraint)] + css :: [List1 (ProblemConstraint, HypSizeConstraint)] css = cluster' csMs -- Check that the closed constraints are valid. @@ -387,16 +387,16 @@ -- | Solve a cluster of constraints sharing some metas. -- -solveCluster :: DefaultToInfty -> List1 (CC, HypSizeConstraint) -> TCM () +solveCluster :: DefaultToInfty -> List1 (ProblemConstraint, HypSizeConstraint) -> TCM () solveCluster flag ccs = do - let cs = fmap snd ccs - let prettyCs = map prettyTCM $ List1.toList cs - let err reason = typeError . GenericDocError =<< do - vcat $ - [ text $ "Cannot solve size constraints" ] ++ prettyCs ++ - [ "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 $ - "Solving constraint cluster" : prettyCs + "Solving constraint cluster" <| fmap prettyTCM cs + -- Find the super context of all contexts. {- -- We use the @'ctxId'@s. @@ -563,13 +563,9 @@ -- Double check. when solvedAll $ do - let cs0 = fmap fst ccs - -- Error for giving up - cannotSolve = typeError . GenericDocError =<< - vcat ("Cannot solve size constraints" <| fmap prettyTCM cs0) - flip catchError (const cannotSolve) $ - noConstraints $ - forM_ cs0 $ withConstraint 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 [(Nat, SizeConstraint)] @@ -651,37 +647,6 @@ _ -> return c -} --- | Identifiers for rigid variables. -data NamedRigid = NamedRigid - { rigidName :: String -- ^ Name for printing in debug messages. - , rigidIndex :: Int -- ^ De Bruijn index. - } deriving (Show) - -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) - --- | 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 - -instance PrettyTCM SizeMeta where - prettyTCM (SizeMeta x es) = prettyTCM (MetaV x $ map (Apply . defaultArg . var) es) - instance Subst SizeMeta where type SubstArg SizeMeta = Term applySubst sigma (SizeMeta x es) = SizeMeta x (map raise es) @@ -691,13 +656,6 @@ 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 (SizeExpr' NamedRigid SizeMeta) where type SubstArg (SizeExpr' NamedRigid SizeMeta) = Term @@ -711,42 +669,11 @@ Var j [] -> Rigid r{ rigidIndex = j } n _ -> __IMPOSSIBLE__ -type SizeConstraint = Constraint' NamedRigid SizeMeta - 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 <+> pretty cmp <+> prettyTCM v - --- | 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@. - } - -instance Flexs HypSizeConstraint where - type FlexOf HypSizeConstraint = SizeMeta - flexs (HypSizeConstraint _ _ hs c) = flexs hs `mappend` flexs c - -instance PrettyTCM HypSizeConstraint where - prettyTCM (HypSizeConstraint cxt _ hs c) = - unsafeModifyContext (const cxt) $ do - let cxtNames = reverse $ map (fst . unDom) cxt - -- text ("[#cxt=" ++ show (size cxt) ++ "]") <+> do - prettyList (map prettyTCM cxtNames) <+> do - applyUnless (null hs) - ((hcat (punctuate ", " $ map prettyTCM hs) <+> "|-") <+>) - (prettyTCM c) - -- | Turn a constraint over de Bruijn indices into a size constraint. computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint) computeSizeConstraint c = do @@ -792,16 +719,3 @@ isVar (Apply v) = case unArg v of Var i [] -> Just i _ -> Nothing - --- | Turn a de 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__ diff --git a/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs b/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs --- a/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs +++ b/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs @@ -6,19 +6,23 @@ 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 Agda.TypeChecking.Monad.Base (TCM) -import qualified Agda.TypeChecking.Pretty as P +import Agda.Syntax.Common + +import Agda.TypeChecking.Monad.Base.Types import Agda.TypeChecking.SizedTypes.Utils +import Agda.Utils.Function import Agda.Utils.Functor import Agda.Utils.Null -import Agda.Syntax.Common.Pretty +import Agda.Syntax.Common.Pretty as P import Agda.Utils.Impossible @@ -26,8 +30,10 @@ -- | 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 @@ -61,25 +67,26 @@ instance Pretty Flex where pretty = text . flexId -instance P.PrettyTCM Flex where - prettyTCM = return . pretty - -- | 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 (Show, 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 (Show, Eq, Bounded, Enum) + deriving (Show, Eq, Generic, Bounded, Enum) +instance NFData Cmp + instance Dioid Cmp where compose = min unitCompose = Le @@ -103,10 +110,12 @@ , cmp :: Cmp , rightExpr :: SizeExpr' rigid flex } - deriving (Show, 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. ------------------------------------------------------------------------ @@ -176,19 +185,14 @@ Flex x n -> Flex x $ n + m Infty -> Infty --- | Error messages produced by the constraint simplification monad. - -type Error = TCM Doc - -- * Constraint simplification -type CTrans r f = Constraint' r f -> Either Error [Constraint' r f] +type CTrans r f = Constraint' r f -> Maybe [Constraint' r f] --- | Returns an error message if we have a contradictory constraint. +-- | 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" P.<+> P.pretty c P.<+> - "is inconsistent" + let err = Nothing case c of -- rhs is Infty Constraint a Le Infty -> return [] @@ -340,3 +344,65 @@ 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 diff --git a/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs b/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs --- a/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs +++ b/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs @@ -15,9 +15,11 @@ import Data.Map (Map) import qualified Data.Map as Map +import Agda.TypeChecking.Monad.Base (TCM) import Agda.TypeChecking.Pretty (PrettyTCM) import qualified Agda.TypeChecking.Pretty as P -import Agda.TypeChecking.SizedTypes.Syntax +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 @@ -424,6 +426,20 @@ 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 @@ -868,7 +884,7 @@ solveGraph - :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) + :: 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 @@ -876,6 +892,7 @@ 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 diff --git a/src/full/Agda/TypeChecking/Substitute.hs b/src/full/Agda/TypeChecking/Substitute.hs --- a/src/full/Agda/TypeChecking/Substitute.hs +++ b/src/full/Agda/TypeChecking/Substitute.hs @@ -857,6 +857,7 @@ -- 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 @@ -1030,6 +1031,7 @@ IsEmpty r a -> IsEmpty r (rf a) CheckSizeLtSat t -> CheckSizeLtSat (rf t) FindInstance m cands -> FindInstance m (rf cands) + ResolveInstanceHead q -> ResolveInstanceHead (rf q) c@UnBlock{} -> c c@CheckFunDef{} -> c HasBiggerSort s -> HasBiggerSort (rf s) @@ -1401,6 +1403,8 @@ 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) diff --git a/src/full/Agda/TypeChecking/Substitute/Class.hs b/src/full/Agda/TypeChecking/Substitute/Class.hs --- a/src/full/Agda/TypeChecking/Substitute/Class.hs +++ b/src/full/Agda/TypeChecking/Substitute/Class.hs @@ -3,6 +3,8 @@ module Agda.TypeChecking.Substitute.Class where import Control.Arrow ((***), second) +import Control.DeepSeq +import GHC.Generics import Agda.Syntax.Common import Agda.Syntax.Internal @@ -93,12 +95,32 @@ 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 --------------------------------------------------------------------------- @@ -326,25 +348,3 @@ 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 a => (a -> b -> b) -> a -> Abs b -> Abs b -underAbs cont a = \case - 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 :: TermSubst a => Int -> (a -> Term -> Term) -> a -> Term -> Term -underLambdas n cont = loop n where - loop 0 a = cont a - loop n a = \case - Lam h b -> Lam h $ underAbs (loop $ n-1) a b - _ -> __IMPOSSIBLE__ diff --git a/src/full/Agda/TypeChecking/Telescope.hs b/src/full/Agda/TypeChecking/Telescope.hs --- a/src/full/Agda/TypeChecking/Telescope.hs +++ b/src/full/Agda/TypeChecking/Telescope.hs @@ -17,6 +17,7 @@ import Data.Monoid import Agda.Syntax.Common +import Agda.Syntax.Common.Pretty (prettyShow) import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern @@ -25,7 +26,6 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free -import Agda.TypeChecking.Warnings import Agda.Utils.CallStack ( withCallerCallStack ) import Agda.Utils.Either @@ -42,13 +42,23 @@ import Agda.Utils.Impossible --- | Flatten telescope: (Γ : Tel) -> [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 (Γ -> Γ~) -- @@ -163,6 +173,15 @@ 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 = unflattenTel names types + where + flatTel = flattenContext ctx + names = permute perm $ map (prettyShow . fst . unDom) flatTel + types = permute perm $ renameP impossible (flipP perm) $ map (fmap snd) flatTel + -- | Recursively computes dependencies of a set of variables in a given -- telescope. Any dependencies outside of the telescope are ignored. varDependencies :: Telescope -> IntSet -> IntSet @@ -692,80 +711,17 @@ TelV tel _ <- telView t return (size tel) ---------------------------------------------------------------------------- --- * Instance definitions ---------------------------------------------------------------------------- - -data OutputTypeName - = OutputTypeName QName - | OutputTypeVar - | OutputTypeVisiblePi - | OutputTypeNameNotYetKnown Blocker - | NoOutputTypeName - --- | Strips all hidden and instance Pi's and return the argument --- telescope and head definition name, if possible. -getOutputTypeName :: Type -> TCM (Telescope, 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 _ -> return (tel , OutputTypeNameNotYetKnown b)) $ \ _ v -> - case v of - -- Possible base types: - Def n _ -> return (tel , OutputTypeName n) - Sort{} -> return (tel , NoOutputTypeName) - Var n _ -> return (tel , OutputTypeVar) - Pi{} -> return (tel , 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 - --- | Register the definition with the given type as an instance. -addTypedInstance' :: - Bool -- ^ Should we print warnings for unusable instance declarations? - -> QName -- ^ Name of instance. - -> Type -- ^ Type of instance. - -> TCM () -addTypedInstance' w x t = do - (tel , n) <- getOutputTypeName t - case n of - OutputTypeName n -> addNamedInstance x n - OutputTypeNameNotYetKnown{} -> addUnknownInstance x - NoOutputTypeName -> when w $ warning $ WrongInstanceDeclaration - OutputTypeVar -> when w $ warning $ WrongInstanceDeclaration - OutputTypeVisiblePi -> when w $ warning $ InstanceWithExplicitArg x - -resolveUnknownInstanceDefs :: TCM () -resolveUnknownInstanceDefs = do - anonInstanceDefs <- getAnonInstanceDefs - clearAnonInstanceDefs - forM_ anonInstanceDefs $ \ n -> do - -- Andreas, 2022-12-04, issue #6380: - -- Do not warn about unusable instances here. - addTypedInstance' False n =<< typeOfConst n +-- | Fold a telescope into a monadic computation, adding variables to the +-- context at each step. --- | 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 +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 diff --git a/src/full/Agda/TypeChecking/Unquote.hs b/src/full/Agda/TypeChecking/Unquote.hs --- a/src/full/Agda/TypeChecking/Unquote.hs +++ b/src/full/Agda/TypeChecking/Unquote.hs @@ -38,6 +38,7 @@ 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 @@ -51,7 +52,7 @@ import Agda.TypeChecking.Primitive import Agda.TypeChecking.ReconstructParameters import Agda.TypeChecking.CheckInternal -import Agda.TypeChecking.InstanceArguments ( getInstanceCandidates ) +import Agda.TypeChecking.InstanceArguments import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Rules.Def @@ -99,7 +100,10 @@ runUnquoteM m = do cxt <- asksTC envContext s <- getTC - z <- unpackUnquoteM m cxt (Clean, s) + 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 ((x, _), decls) -> Right (x, decls) <$ mapM_ isDefined decls @@ -122,14 +126,14 @@ n <- getContextSize escapeContext __IMPOSSIBLE__ (n - length cxt) $ unpackUnquoteM m cxt s -isCon :: ConHead -> TCM Term -> UnquoteM Bool +isCon :: ConHead -> TCM (Maybe Term) -> UnquoteM Bool isCon con tm = do t <- liftTCM tm case t of - Con con' _ _ -> return (con == con') + Just (Con con' _ _) -> return (con == con') _ -> return False -isDef :: QName -> TCM Term -> UnquoteM Bool -isDef f tm = loop <$> liftTCM tm +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 @@ -198,7 +202,7 @@ case t of Con c _ es | Just [r,q] <- allApplyElims es -> choice - [(c `isCon` primModalityConstructor, + [(c `isCon` getBuiltin' builtinModalityConstructor, Modality <$> unquoteN r <*> unquoteN q <*> pure defaultCohesion)] @@ -212,7 +216,7 @@ case t of Con c _ es | Just [h,m] <- allApplyElims es -> choice - [(c `isCon` primArgArgInfo, + [(c `isCon` getBuiltin' builtinArgArgInfo, ArgInfo <$> unquoteN h <*> unquoteN m <*> pure Reflected @@ -228,7 +232,7 @@ case t of Con c _ es | Just [info,x] <- allApplyElims es -> choice - [(c `isCon` primArgArg, Arg <$> unquoteN info <*> unquoteN x)] + [(c `isCon` getBuiltin' builtinArgArg, Arg <$> unquoteN info <*> unquoteN x)] __IMPOSSIBLE__ Con c _ _ -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "arg" t @@ -243,8 +247,8 @@ t <- reduceQuotedTerm t case t of Con c _ [] -> - choice [ (c `isCon` primTrue, pure True) - , (c `isCon` primFalse, pure False) ] + choice [ (c `isCon` getBuiltin' builtinTrue, pure True) + , (c `isCon` getBuiltin' builtinFalse, pure False) ] __IMPOSSIBLE__ _ -> throwError $ NonCanonical "boolean" t @@ -322,10 +326,10 @@ t <- reduceQuotedTerm t case t of Con c _ es | Just [x] <- allApplyElims es -> - choice [ (c `isCon` primAgdaErrorPartString, StrPart . T.unpack <$> unquoteNString x) - , (c `isCon` primAgdaErrorPartTerm, TermPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Term))) - , (c `isCon` primAgdaErrorPartPatt, PattPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Pattern))) - , (c `isCon` primAgdaErrorPartName, NamePart <$> unquoteN x) ] + 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 @@ -335,11 +339,11 @@ case t of Con c _ es | Just [x,xs] <- allApplyElims es -> choice - [(c `isCon` primCons, (:) <$> unquoteN x <*> unquoteN xs)] + [(c `isCon` getBuiltin' builtinCons, (:) <$> unquoteN x <*> unquoteN xs)] __IMPOSSIBLE__ Con c _ [] -> choice - [(c `isCon` primNil, return [])] + [(c `isCon` getBuiltin' builtinNil, return [])] __IMPOSSIBLE__ Con c _ _ -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "list" t @@ -361,9 +365,9 @@ case t of Con c _ [] -> choice - [(c `isCon` primHidden, return Hidden) - ,(c `isCon` primInstance, return (Instance NoOverlap)) - ,(c `isCon` primVisible, return NotHidden)] + [(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 @@ -374,8 +378,8 @@ case t of Con c _ [] -> choice - [(c `isCon` primRelevant, return Relevant) - ,(c `isCon` primIrrelevant, return Irrelevant)] + [(c `isCon` getBuiltin' builtinRelevant, return Relevant) + ,(c `isCon` getBuiltin' builtinIrrelevant, return Irrelevant)] __IMPOSSIBLE__ Con c _ vs -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "relevance" t @@ -386,8 +390,8 @@ case t of Con c _ [] -> choice - [(c `isCon` primQuantityω, return $ Quantityω QωInferred) - ,(c `isCon` primQuantity0, return $ Quantity0 Q0Inferred)] + [(c `isCon` getBuiltin' builtinQuantityω, return $ Quantityω QωInferred) + ,(c `isCon` getBuiltin' builtinQuantity0, return $ Quantity0 Q0Inferred)] __IMPOSSIBLE__ Con c _ vs -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "quantity" t @@ -405,7 +409,7 @@ case t of Con c _ es | Just [x,y] <- allApplyElims es -> choice - [(c `isCon` primAbsAbs, R.Abs <$> (hint . T.unpack <$> unquoteNString x) <*> unquoteN y)] + [(c `isCon` getBuiltin' builtinAbsAbs, R.Abs <$> (hint . T.unpack <$> unquoteNString x) <*> unquoteN y)] __IMPOSSIBLE__ Con c _ _ -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "abstraction" t @@ -419,9 +423,9 @@ case t of Con c _ es | Just [x] <- allApplyElims es -> choice - [ (c `isCon` primAgdaBlockerAny, UnblockOnAny . Set.fromList <$> unquoteN x) - , (c `isCon` primAgdaBlockerAll, UnblockOnAll . Set.fromList <$> unquoteN x) - , (c `isCon` primAgdaBlockerMeta, UnblockOnMeta <$> unquoteN x)] + [ (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 @@ -448,15 +452,15 @@ case t of Con c _ [] -> choice - [(c `isCon` primAgdaSortUnsupported, return R.UnknownS)] + [(c `isCon` getBuiltin' builtinAgdaSortUnsupported, return R.UnknownS)] __IMPOSSIBLE__ Con c _ es | Just [u] <- allApplyElims es -> choice - [ (c `isCon` primAgdaSortSet, R.SetS <$> unquoteN u) - , (c `isCon` primAgdaSortLit, R.LitS <$> unquoteN u) - , (c `isCon` primAgdaSortProp, R.PropS <$> unquoteN u) - , (c `isCon` primAgdaSortPropLit, R.PropLitS <$> unquoteN u) - , (c `isCon` primAgdaSortInf, R.InfS <$> unquoteN u) + [ (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__ @@ -468,12 +472,12 @@ case t of Con c _ es | Just [x] <- allApplyElims es -> choice - [ (c `isCon` primAgdaLitNat, LitNat <$> unquoteN x) - , (c `isCon` primAgdaLitFloat, LitFloat <$> unquoteN x) - , (c `isCon` primAgdaLitChar, LitChar <$> unquoteN x) - , (c `isCon` primAgdaLitString, LitString <$> unquoteNString x) - , (c `isCon` primAgdaLitQName, LitQName <$> unquoteN x) - , (c `isCon` primAgdaLitMeta, + [ (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) @@ -488,25 +492,31 @@ case t of Con c _ [] -> choice - [ (c `isCon` primAgdaTermUnsupported, return R.Unknown) ] + [ (c `isCon` getBuiltin' builtinAgdaTermUnsupported, return R.Unknown) ] __IMPOSSIBLE__ Con c _ es | Just [x] <- allApplyElims es -> choice - [ (c `isCon` primAgdaTermSort, R.Sort <$> unquoteN x) - , (c `isCon` primAgdaTermLit, R.Lit <$> unquoteN x) + [ (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` 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 <$> (List1.fromListSafe __IMPOSSIBLE__ <$> unquoteN x) <*> unquoteN y) + [ (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 @@ -528,15 +538,15 @@ case t of Con c _ es | Just [x] <- allApplyElims es -> choice - [ (c `isCon` primAgdaPatVar, R.VarP . fromInteger <$> unquoteN x) - , (c `isCon` primAgdaPatAbsurd, R.AbsurdP . fromInteger <$> unquoteN x) - , (c `isCon` primAgdaPatDot, R.DotP <$> unquoteN x) - , (c `isCon` primAgdaPatProj, R.ProjP <$> unquoteN x) - , (c `isCon` primAgdaPatLit, R.LitP <$> unquoteN x) ] + [ (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` primAgdaPatCon, R.ConP <$> unquoteN x <*> unquoteN y) ] + [ (c `isCon` getBuiltin' builtinAgdaPatCon, R.ConP <$> unquoteN x <*> unquoteN y) ] __IMPOSSIBLE__ Con c _ _ -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "pattern" t @@ -547,11 +557,11 @@ case t of Con c _ es | Just [x, y] <- allApplyElims es -> choice - [ (c `isCon` primAgdaClauseAbsurd, R.AbsurdClause <$> unquoteN x <*> unquoteN y) ] + [ (c `isCon` getBuiltin' builtinAgdaClauseAbsurd, R.AbsurdClause <$> unquoteN x <*> unquoteN y) ] __IMPOSSIBLE__ Con c _ es | Just [x, y, z] <- allApplyElims es -> choice - [ (c `isCon` primAgdaClauseClause, R.Clause <$> unquoteN x <*> unquoteN y <*> unquoteN z) ] + [ (c `isCon` getBuiltin' builtinAgdaClauseClause, R.Clause <$> unquoteN x <*> unquoteN y <*> unquoteN z) ] __IMPOSSIBLE__ Con c _ _ -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "clause" t @@ -568,73 +578,75 @@ evalTCM (m `apply` [defaultArg qhole]) evalTCM :: I.Term -> UnquoteM I.Term -evalTCM v = do +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` primAgdaTCMGetContext, tcGetContext) - , (f `isDef` primAgdaTCMCommit, tcCommit) - , (f `isDef` primAgdaTCMAskNormalisation, tcAskNormalisation) - , (f `isDef` primAgdaTCMAskReconstructed, tcAskReconstructed) - , (f `isDef` primAgdaTCMAskExpandLast, tcAskExpandLast) - , (f `isDef` primAgdaTCMAskReduceDefs, tcAskReduceDefs) + 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` 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` primAgdaTCMFormatErrorParts, tcFun1 tcFormatErrorParts u) - , (f `isDef` primAgdaTCMIsMacro, tcFun1 tcIsMacro u) - , (f `isDef` primAgdaTCMFreshName, tcFun1 tcFreshName u) - , (f `isDef` primAgdaTCMGetInstances, uqFun1 tcGetInstances 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` primAgdaTCMUnify, tcFun2 tcUnify u v) - , (f `isDef` primAgdaTCMCheckType, tcFun2 tcCheckType u v) - , (f `isDef` primAgdaTCMDeclareDef, uqFun2 tcDeclareDef u v) - , (f `isDef` primAgdaTCMDeclarePostulate, uqFun2 tcDeclarePostulate u v) - , (f `isDef` primAgdaTCMDefineData, uqFun2 tcDefineData u v) - , (f `isDef` primAgdaTCMDefineFun, uqFun2 tcDefineFun u v) - , (f `isDef` primAgdaTCMQuoteOmegaTerm, tcQuoteTerm (sort $ Inf UType 0) (unElim v)) - , (f `isDef` primAgdaTCMPragmaForeign, tcFun2 tcPragmaForeign 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) ] failEval I.Def f [l, a, u] -> - choice [ (f `isDef` primAgdaTCMReturn, return (unElim u)) - , (f `isDef` primAgdaTCMTypeError, tcFun1 tcTypeError u) - , (f `isDef` primAgdaTCMQuoteTerm, tcQuoteTerm (mkT (unElim l) (unElim a)) (unElim u)) - , (f `isDef` primAgdaTCMUnquoteTerm, tcFun1 (tcUnquoteTerm (mkT (unElim l) (unElim a))) u) - , (f `isDef` primAgdaTCMBlock, uqFun1 tcBlock u) - , (f `isDef` primAgdaTCMDebugPrint, tcFun3 tcDebugPrint l a u) - , (f `isDef` primAgdaTCMNoConstraints, tcNoConstraints (unElim u)) - , (f `isDef` primAgdaTCMDeclareData, uqFun3 tcDeclareData l a u) - , (f `isDef` primAgdaTCMRunSpeculative, tcRunSpeculative (unElim u)) - , (f `isDef` primAgdaTCMExec, tcFun3 tcExec l a u) - , (f `isDef` primAgdaTCMPragmaCompile, tcFun3 tcPragmaCompile 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` primAgdaTCMCatchError, tcCatchError (unElim u) (unElim v)) - , (f `isDef` primAgdaTCMWithNormalisation, tcWithNormalisation (unElim u) (unElim v)) - , (f `isDef` primAgdaTCMWithReconstructed, tcWithReconstructed (unElim u) (unElim v)) - , (f `isDef` primAgdaTCMWithExpandLast, tcWithExpandLast (unElim u) (unElim v)) - , (f `isDef` primAgdaTCMWithReduceDefs, tcWithReduceDefs (unElim u) (unElim v)) - , (f `isDef` primAgdaTCMInContext, tcInContext (unElim u) (unElim 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` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v) (unElim w)) + choice [ (f `isDef` getBuiltin' builtinAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v) (unElim w)) ] failEval I.Def f [_, _, _, _, m, k] -> - choice [ (f `isDef` primAgdaTCMBind, tcBind (unElim m) (unElim k)) ] + choice [ (f `isDef` getBuiltin' builtinAgdaTCMBind, tcBind (unElim m) (unElim k)) ] failEval _ -> failEval where @@ -743,8 +755,11 @@ primUnitUnit tcNoConstraints :: Term -> UnquoteM Term - tcNoConstraints m = liftU1 noConstraints (evalTCM m) + 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 @@ -846,6 +861,8 @@ 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 @@ -992,7 +1009,7 @@ (A.GeneralizeTel Map.empty tel) e' primUnitUnit - tcDefineData :: QName -> [(QName, R.Type)] -> UnquoteM Term + tcDefineData :: QName -> [(QName, (Quantity, R.Type))] -> UnquoteM Term tcDefineData x cs = inOriginalContext $ (setDirty >>) $ liftTCM $ do caseEitherM (getConstInfo' x) (const $ genericError $ "Missing declaration for " ++ prettyShow x) $ \def -> do @@ -1004,7 +1021,7 @@ -- 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 <- mapM (toAbstract_ . addDummy npars . snd) cs + es <- mapM (toAbstract_ . addDummy npars . snd . snd) cs alwaysReportSDoc "tc.unquote.def" 10 $ vcat $ [ "declaring constructors of" <+> prettyTCM x <+> ":" ] ++ map prettyA es @@ -1019,8 +1036,9 @@ ac <- asksTC (^. lensIsAbstract) let i = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ac noRange conNames = map fst cs - toAxiom c e = A.Axiom ConName i defaultArgInfo Nothing c e - as = zipWith toAxiom conNames es' + 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 $ @@ -1095,6 +1113,24 @@ 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 -> ([A.TypedBinding], A.Expr) splitPars 0 e = ([] , e) diff --git a/src/full/Agda/TypeChecking/Warnings.hs b/src/full/Agda/TypeChecking/Warnings.hs --- a/src/full/Agda/TypeChecking/Warnings.hs +++ b/src/full/Agda/TypeChecking/Warnings.hs @@ -1,7 +1,6 @@ module Agda.TypeChecking.Warnings ( MonadWarning(..) - , genericWarning , warning'_, warning_, warning', warning, warnings , raiseWarningsOnUsage , isUnsolvedWarning @@ -79,20 +78,24 @@ -- * Raising warnings --------------------------------------------------------------------------- -{-# SPECIALIZE genericWarning :: P.Doc -> TCM () #-} -genericWarning :: MonadWarning m => P.Doc -> m () -genericWarning = warning . GenericWarning - {-# 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 - -- NicifierIssues come with their own error locations. - let r' = case w of { NicifierIssue w0 -> getRange w0 ; _ -> r } + let r' = case w of + -- NicifierIssues come with their own error locations. + NicifierIssue w0 -> getRange w0 + -- ConstructorDoesNotFitInData packages a full TCErr, so skip the sayWhen/Where here. + ConstructorDoesNotFitInData{} -> noRange + _ -> r + let c' = case w of + -- ConstructorDoesNotFitInData packages a full TCErr, so skip the sayWhen/Where here. + ConstructorDoesNotFitInData{} -> Nothing + _ -> c let wn = warningName w - p <- sayWhen r' c $ + p <- sayWhen r' c' $ -- Only benign warnings can be deactivated with -WnoXXX, so don't -- display hint for error warnings. applyUnless (wn `elem` errorWarnings) (prettyWarningName wn $$) $ @@ -189,12 +192,6 @@ if warningName w `Set.member` errorWarnings then ErrorWarnings else AllWarnings - --- | Assorted warnings and errors to be displayed to the user -data WarningsAndNonFatalErrors = WarningsAndNonFatalErrors - { tcWarnings :: [TCWarning] - , nonFatalErrors :: [TCWarning] - } -- | The only way to construct a empty WarningsAndNonFatalErrors diff --git a/src/full/Agda/Utils/BiMap.hs b/src/full/Agda/Utils/BiMap.hs --- a/src/full/Agda/Utils/BiMap.hs +++ b/src/full/Agda/Utils/BiMap.hs @@ -346,7 +346,7 @@ ] ++ [ v2 | (k2, v2) <- toList m2 - , not (k2 `elem` ks1) + , k2 `notElem` ks1 ]) where ks1 = map fst (toList m1) diff --git a/src/full/Agda/Utils/Function.hs b/src/full/Agda/Utils/Function.hs --- a/src/full/Agda/Utils/Function.hs +++ b/src/full/Agda/Utils/Function.hs @@ -2,9 +2,14 @@ {-# LANGUAGE RebindableSyntax #-} -module Agda.Utils.Function where +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 diff --git a/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs b/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs --- a/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs +++ b/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs @@ -75,13 +75,9 @@ import Prelude hiding ( lookup, null, unzip ) - - - import qualified Data.Array.IArray as Array import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Function (on) import qualified Data.Graph as Graph import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap @@ -97,7 +93,8 @@ import qualified Data.Tree as Tree import Agda.Utils.Function - +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 @@ -659,8 +656,21 @@ -- the, at the time of writing undocumented, time complexity of -- 'Graph.stronglyConnComp'). -sccs :: Ord n => Graph 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. -- diff --git a/src/full/Agda/Utils/IArray.hs b/src/full/Agda/Utils/IArray.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/IArray.hs @@ -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 diff --git a/src/full/Agda/Utils/IO.hs b/src/full/Agda/Utils/IO.hs --- a/src/full/Agda/Utils/IO.hs +++ b/src/full/Agda/Utils/IO.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wunused-imports #-} +{-# LANGUAGE CPP #-} -- | Auxiliary functions for the IO monad. @@ -8,6 +8,9 @@ import Control.Monad.State import Control.Monad.Writer +import Agda.Utils.List (dropFrom) +import Agda.Utils.String (rtrim) + -- | Catch 'IOException's. -- class CatchIO m where @@ -27,3 +30,16 @@ -- 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 diff --git a/src/full/Agda/Utils/IO/UTF8.hs b/src/full/Agda/Utils/IO/UTF8.hs --- a/src/full/Agda/Utils/IO/UTF8.hs +++ b/src/full/Agda/Utils/IO/UTF8.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | Text IO using the UTF8 character encoding. module Agda.Utils.IO.UTF8 @@ -55,6 +57,9 @@ 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 diff --git a/src/full/Agda/Utils/Impossible.hs b/src/full/Agda/Utils/Impossible.hs --- a/src/full/Agda/Utils/Impossible.hs +++ b/src/full/Agda/Utils/Impossible.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wunused-imports #-} ------------------------------------------------------------------------ -- | An interface for reporting \"impossible\" errors ------------------------------------------------------------------------ - module Agda.Utils.Impossible where import Control.Exception (Exception(..), throw, catchJust) @@ -59,7 +60,14 @@ , 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 __IMPOSSIBLE__ diff --git a/src/full/Agda/Utils/IndexedList.hs b/src/full/Agda/Utils/IndexedList.hs --- a/src/full/Agda/Utils/IndexedList.hs +++ b/src/full/Agda/Utils/IndexedList.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} diff --git a/src/full/Agda/Utils/Lens.hs b/src/full/Agda/Utils/Lens.hs --- a/src/full/Agda/Utils/Lens.hs +++ b/src/full/Agda/Utils/Lens.hs @@ -55,6 +55,9 @@ 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 using 'StateT'. diff --git a/src/full/Agda/Utils/List.hs b/src/full/Agda/Utils/List.hs --- a/src/full/Agda/Utils/List.hs +++ b/src/full/Agda/Utils/List.hs @@ -11,6 +11,7 @@ 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 (:|), (<|)) @@ -362,6 +363,20 @@ -- | Sublist relation. isSublistOf :: Eq a => [a] -> [a] -> Bool isSublistOf = List.isSubsequenceOf + +-- | @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²). diff --git a/src/full/Agda/Utils/List1.hs b/src/full/Agda/Utils/List1.hs --- a/src/full/Agda/Utils/List1.hs +++ b/src/full/Agda/Utils/List1.hs @@ -21,9 +21,10 @@ ( module Agda.Utils.List1 , module List1 , module IsList + , module Unzip ) where -import Prelude hiding (filter) +import Prelude hiding (filter, unzip) import Control.Arrow ((&&&)) import Control.Monad (filterM) @@ -34,8 +35,15 @@ import qualified Data.List as List import qualified Data.Maybe as Maybe -import Data.List.NonEmpty as List1 hiding (fromList, toList) +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(..) ) diff --git a/src/full/Agda/Utils/Monad.hs b/src/full/Agda/Utils/Monad.hs --- a/src/full/Agda/Utils/Monad.hs +++ b/src/full/Agda/Utils/Monad.hs @@ -2,13 +2,13 @@ module Agda.Utils.Monad ( module Agda.Utils.Monad , when, unless, MonadPlus(..) - , (<$>), (<*>) + , (<$>), (<*>), (<$!>) , (<$) ) where import Control.Applicative ( liftA2 ) -import Control.Monad ( MonadPlus(..), guard, unless, when ) +import Control.Monad ( MonadPlus(..), guard, unless, when, (<$!>) ) import Control.Monad.Except ( MonadError(catchError, throwError) ) import Control.Monad.Identity ( runIdentity ) import Control.Monad.State ( MonadState(get, put) ) @@ -34,6 +34,15 @@ (==<<) :: 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 ------------------------------------------------ whenM :: Monad m => m Bool -> m () -> m () @@ -144,11 +153,17 @@ -- | A monadic version of @'mapMaybe' :: (a -> Maybe b) -> [a] -> [b]@. mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b] -mapMaybeM f xs = catMaybes <$> Trav.mapM f xs +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 :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b] @@ -173,7 +188,7 @@ -- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a]) partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a]) partitionM f = - foldr (\ x mlr -> bool (first (x:)) (second (x:)) <$> f x <*> mlr) + foldr (\ x -> liftA2 (bool (second (x:)) (first (x:))) $ f x) (pure empty) -- MonadPlus ----------------------------------------------------------------- diff --git a/src/full/Agda/Utils/Null.hs b/src/full/Agda/Utils/Null.hs --- a/src/full/Agda/Utils/Null.hs +++ b/src/full/Agda/Utils/Null.hs @@ -45,6 +45,7 @@ import Agda.Utils.Bag (Bag) import qualified Agda.Utils.Bag as Bag +import Agda.Utils.Unsafe (unsafeComparePointers) import Agda.Utils.Impossible class Null a where @@ -52,8 +53,10 @@ 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 = () @@ -182,3 +185,6 @@ 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 diff --git a/src/full/Agda/Utils/ProfileOptions.hs b/src/full/Agda/Utils/ProfileOptions.hs --- a/src/full/Agda/Utils/ProfileOptions.hs +++ b/src/full/Agda/Utils/ProfileOptions.hs @@ -39,6 +39,7 @@ | 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 diff --git a/src/full/Agda/Utils/SmallSet.hs b/src/full/Agda/Utils/SmallSet.hs --- a/src/full/Agda/Utils/SmallSet.hs +++ b/src/full/Agda/Utils/SmallSet.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {-# OPTIONS_GHC -Wunused-imports #-} -- | Small sets represented as a bitmask for fast membership checking. @@ -13,7 +15,7 @@ -- @ module Agda.Utils.SmallSet - ( SmallSet() + ( SmallSet(..) , SmallSetElement , Ix , (\\) @@ -39,7 +41,9 @@ 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 diff --git a/src/full/Agda/Utils/String.hs b/src/full/Agda/Utils/String.hs --- a/src/full/Agda/Utils/String.hs +++ b/src/full/Agda/Utils/String.hs @@ -10,6 +10,10 @@ import Data.String import Agda.Utils.List +import Agda.Utils.List1 (String1, fromList) + +instance IsString String1 where + fromString = fromList -- | 'quote' adds double quotes around the string, replaces newline -- characters with @\n@, and escapes double quotes and backslashes diff --git a/src/full/Agda/Utils/TypeLevel.hs b/src/full/Agda/Utils/TypeLevel.hs --- a/src/full/Agda/Utils/TypeLevel.hs +++ b/src/full/Agda/Utils/TypeLevel.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wunused-imports #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} diff --git a/src/full/Agda/Utils/TypeLits.hs b/src/full/Agda/Utils/TypeLits.hs --- a/src/full/Agda/Utils/TypeLits.hs +++ b/src/full/Agda/Utils/TypeLits.hs @@ -2,7 +2,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -- | Type level literals, inspired by GHC.TypeLits. diff --git a/src/full/Agda/Utils/Unsafe.hs b/src/full/Agda/Utils/Unsafe.hs --- a/src/full/Agda/Utils/Unsafe.hs +++ b/src/full/Agda/Utils/Unsafe.hs @@ -7,6 +7,6 @@ -- | 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 +-- See . unsafeComparePointers :: a -> a -> Bool unsafeComparePointers x y = x `seq` y `seq` isTrue# (reallyUnsafePtrEquality# x y) diff --git a/stack-8.10.7.yaml b/stack-8.10.7.yaml --- a/stack-8.10.7.yaml +++ b/stack-8.10.7.yaml @@ -3,5 +3,6 @@ compiler-check: match-exact extra-deps: +- pqueue-1.5.0.0 - text-icu-0.8.0.2 - vector-hashtables-0.1.1.1 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml deleted file mode 100644 --- a/stack-8.6.5.yaml +++ /dev/null @@ -1,15 +0,0 @@ -resolver: lts-14.27 -compiler: ghc-8.6.5 -compiler-check: match-exact - -extra-deps: -- STMonadTrans-0.4.3 -- data-hash-0.2.0.1 -- equivalence-0.3.4 -- primitive-0.7.4.0 -- regex-base-0.94.0.0 -- regex-tdfa-1.3.1.0 -- strict-0.4.0.1 -- these-1.1.1.1 -- text-icu-0.8.0.2 -- vector-hashtables-0.1.1.1 diff --git a/stack-8.8.4.yaml b/stack-8.8.4.yaml --- a/stack-8.8.4.yaml +++ b/stack-8.8.4.yaml @@ -3,6 +3,7 @@ compiler-check: match-exact extra-deps: +- pqueue-1.4.1.2 - primitive-0.7.4.0 - strict-0.4.0.1 - text-icu-0.8.0.2 diff --git a/stack-9.0.2.yaml b/stack-9.0.2.yaml --- a/stack-9.0.2.yaml +++ b/stack-9.0.2.yaml @@ -3,5 +3,6 @@ compiler-check: match-exact extra-deps: +- pqueue-1.5.0.0 - text-icu-0.8.0.2 - vector-hashtables-0.1.1.1 diff --git a/stack-9.10.1.yaml b/stack-9.10.1.yaml new file mode 100644 --- /dev/null +++ b/stack-9.10.1.yaml @@ -0,0 +1,24 @@ +resolver: nightly-2024-07-13 +compiler: ghc-9.10.1 +compiler-check: match-exact + +# Libraries shipped with GHC 9.10.1: +extra-deps: +- Cabal-3.12.0.0 +- Cabal-syntax-3.12.0.0 +- directory-1.3.8.3 +- filepath-1.5.2.0 +- haskeline-0.8.2.1 +- process-1.6.19.0 +- unix-2.8.5.1 +# For Windows: +- Win32-2.14.0.0 +- time-1.12.2 + +flags: + directory: + os-string: true + unix: + os-string: true + Win32: + os-string: true diff --git a/stack-9.2.8.yaml b/stack-9.2.8.yaml --- a/stack-9.2.8.yaml +++ b/stack-9.2.8.yaml @@ -1,3 +1,6 @@ resolver: lts-20.26 compiler: ghc-9.2.8 compiler-check: match-exact + +extra-deps: +- pqueue-1.5.0.0 diff --git a/stack-9.4.8.yaml b/stack-9.4.8.yaml --- a/stack-9.4.8.yaml +++ b/stack-9.4.8.yaml @@ -7,3 +7,6 @@ win32-2-13-1: false ansi-terminal: win32-2-13-1: false + +extra-deps: +- pqueue-1.5.0.0 diff --git a/stack-9.6.4.yaml b/stack-9.6.4.yaml deleted file mode 100644 --- a/stack-9.6.4.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: lts-22.12 -compiler: ghc-9.6.4 -compiler-check: match-exact diff --git a/stack-9.6.6.yaml b/stack-9.6.6.yaml new file mode 100644 --- /dev/null +++ b/stack-9.6.6.yaml @@ -0,0 +1,3 @@ +resolver: lts-22.28 +compiler: ghc-9.6.6 +compiler-check: match-exact diff --git a/stack-9.8.1.yaml b/stack-9.8.1.yaml deleted file mode 100644 --- a/stack-9.8.1.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: nightly-2024-02-27 -compiler: ghc-9.8.1 -compiler-check: match-exact diff --git a/stack-9.8.2.yaml b/stack-9.8.2.yaml new file mode 100644 --- /dev/null +++ b/stack-9.8.2.yaml @@ -0,0 +1,3 @@ +resolver: nightly-2024-07-13 +compiler: ghc-9.8.2 +compiler-check: match-exact