diff --git a/Agda.cabal b/Agda.cabal --- a/Agda.cabal +++ b/Agda.cabal @@ -1,10 +1,10 @@ name: Agda -version: 2.6.2.2 -cabal-version: >= 1.10 +version: 2.6.3 +cabal-version: 1.24 build-type: Custom license: OtherLicense license-file: LICENSE -copyright: (c) 2005-2022 The Agda Team. +copyright: (c) 2005-2023 The Agda Team. author: Ulf Norell and The Agda Team, see https://agda.readthedocs.io/en/latest/team.html maintainer: The Agda Team homepage: http://wiki.portal.chalmers.se/agda/ @@ -40,13 +40,14 @@ GHC == 8.6.5 GHC == 8.8.4 GHC == 8.10.7 - GHC == 9.0.1 GHC == 9.0.2 - GHC == 9.2.1 - GHC == 9.2.2 + GHC == 9.2.5 + GHC == 9.4.4 extra-source-files: CHANGELOG.md README.md + doc/user-manual/agda.svg + doc/release-notes/2.6.2.2.md doc/release-notes/2.6.2.1.md doc/release-notes/2.6.2.md doc/release-notes/2.6.1.3.md @@ -82,18 +83,15 @@ doc/release-notes/2.2.2.md doc/release-notes/2.2.4.md doc/release-notes/2.2.0.md --- Liang-Ting (2019-11-26): See Issues #4216 --- doc/user-manual.pdf stack-8.0.2.yaml stack-8.2.2.yaml stack-8.4.4.yaml stack-8.6.5.yaml stack-8.8.4.yaml stack-8.10.7.yaml - stack-9.0.1.yaml stack-9.0.2.yaml - stack-9.2.1.yaml - stack-9.2.2.yaml + stack-9.2.5.yaml + stack-9.4.4.yaml data-dir: src/data data-files: emacs-mode/*.el @@ -148,7 +146,7 @@ source-repository this type: git location: https://github.com/agda/agda.git - tag: v2.6.2.2 + tag: v2.6.3 flag cpphs default: False @@ -173,8 +171,8 @@ Enable some expensive optimisations when compiling Agda. custom-setup - setup-depends: base >= 4.9.0.0 && < 4.17 - , Cabal >= 1.24.0.0 && < 3.7 + setup-depends: base >= 4.9.0.0 && < 4.18 + , Cabal >= 1.24.0.0 && < 3.9 , directory >= 1.2.6.2 && < 1.4 , filepath >= 1.4.1.0 && < 1.5 , process >= 1.4.2.0 && < 1.7 @@ -209,10 +207,10 @@ if os(windows) && impl(ghc == 8.6.3) buildable: False - build-depends: aeson >= 1.1.2.0 && < 2.1 + build-depends: aeson >= 1.1.2.0 && < 2.2 , array >= 0.5.1.1 && < 0.6 , async >= 2.2 && < 2.3 - , base >= 4.9.0.0 && < 4.17 + , base >= 4.9.0.0 && < 4.18 , binary >= 0.8.3.0 && < 0.9 , blaze-html >= 0.8 && < 0.10 , boxes >= 0.1.3 && < 0.2 @@ -223,6 +221,7 @@ , data-hash >= 0.2.0.0 && < 0.3 , deepseq >= 1.4.2.0 && < 1.5 , directory >= 1.2.6.2 && < 1.4 + , dlist >= 0.8 && < 1.1 , edit-distance >= 0.2.1.2 && < 0.3 , equivalence >= 0.3.2 && < 0.5 -- exceptions-0.8 instead of 0.10 because of stack @@ -233,12 +232,6 @@ -- slower. The issue was fixed in hashable 1.2.1.0. -- https://github.com/tibbe/hashable/issues/57. , hashable >= 1.2.1.0 && < 1.5 - -- There is a "serious bug" - -- (https://hackage.haskell.org/package/hashtables-1.2.0.2/changelog) - -- in hashtables 1.2.0.0/1.2.0.1. This bug seems to - -- have made Agda much slower (infinitely slower?) in - -- some cases. - , hashtables >= 1.2.0.2 && < 1.4 , haskeline >= 0.7.2.3 && < 0.9 -- monad-control-1.0.1.0 is the first to contain liftThrough , monad-control >= 1.0.1.0 && < 1.1 @@ -252,21 +245,19 @@ , regex-tdfa >= 1.3.1.0 && < 1.4 , split >= 0.2.0.0 && < 0.2.4 , stm >= 2.4.4 && < 2.6 - , strict >= 0.3.2 && < 0.5 - , template-haskell >= 2.11.0.0 && < 2.19 + , STMonadTrans >= 0.4.3 && < 0.5 + , strict >= 0.4.0.1 && < 0.5 , text >= 1.2.3.0 && < 2.1 , time >= 1.6.0.1 && < 1.13 + , time-compat >= 1.9.2 && < 1.10 + -- time-compat adds needed functionality missing in time < 1.9 , transformers >= 0.5 && < 0.7 , unordered-containers >= 0.2.5.0 && < 0.3 , uri-encode >= 1.5.0.4 && < 1.6 + , vector >= 0.12 && < 0.14 + , vector-hashtables == 0.1.* , zlib == 0.6.* - -- Andreas, 2022-02-02, issue #5659: - -- Build failure with transformers-0.6.0.{0,1,2} and GHC 8.6. - -- Transformers-0.6.0.3 might restored GHC 8.6 buildability. - if impl(ghc == 8.6.*) - build-depends: transformers < 0.6 || >= 0.6.0.3 - -- Andreas, 2021-03-10: -- All packages we depend upon should be mentioned in an unconditional -- build-depends field, but additional restrictions on their @@ -422,7 +413,9 @@ Agda.Syntax.Position Agda.Syntax.Reflected Agda.Syntax.Scope.Base + Agda.Syntax.Scope.Flat Agda.Syntax.Scope.Monad + Agda.Syntax.TopLevelModuleName Agda.Syntax.Translation.AbstractToConcrete Agda.Syntax.Translation.ConcreteToAbstract Agda.Syntax.Translation.InternalToAbstract @@ -450,6 +443,8 @@ Agda.TypeChecking.Coverage Agda.TypeChecking.Coverage.Match Agda.TypeChecking.Coverage.SplitTree + Agda.TypeChecking.Coverage.SplitClause + Agda.TypeChecking.Coverage.Cubical Agda.TypeChecking.Datatypes Agda.TypeChecking.DeadCode Agda.TypeChecking.DisplayForm @@ -513,6 +508,10 @@ Agda.TypeChecking.Primitive Agda.TypeChecking.Primitive.Base Agda.TypeChecking.Primitive.Cubical + Agda.TypeChecking.Primitive.Cubical.Id + Agda.TypeChecking.Primitive.Cubical.Glue + Agda.TypeChecking.Primitive.Cubical.Base + Agda.TypeChecking.Primitive.Cubical.HCompU Agda.TypeChecking.ProjectionLike Agda.TypeChecking.Quote Agda.TypeChecking.ReconstructParameters @@ -538,6 +537,8 @@ Agda.TypeChecking.Rules.LHS.Problem Agda.TypeChecking.Rules.LHS.ProblemRest Agda.TypeChecking.Rules.LHS.Unify + Agda.TypeChecking.Rules.LHS.Unify.Types + Agda.TypeChecking.Rules.LHS.Unify.LeftInverse Agda.TypeChecking.Rules.Record Agda.TypeChecking.Rules.Term Agda.TypeChecking.Serialise @@ -570,6 +571,7 @@ Agda.Utils.Bag Agda.Utils.Benchmark Agda.Utils.BiMap + Agda.Utils.BoolSet Agda.Utils.CallStack Agda.Utils.Char Agda.Utils.Cluster @@ -585,6 +587,7 @@ Agda.Utils.Graph.AdjacencyMap.Unidirectional Agda.Utils.Graph.TopSort Agda.Utils.Hash + Agda.Utils.HashTable Agda.Utils.Haskell.Syntax Agda.Utils.Impossible Agda.Utils.IndexedList @@ -614,6 +617,7 @@ Agda.Utils.Pointer Agda.Utils.POMonoid Agda.Utils.Pretty + Agda.Utils.ProfileOptions Agda.Utils.RangeMap Agda.Utils.SemiRing Agda.Utils.Semigroup @@ -652,12 +656,10 @@ ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively - -- NOTE: If adding flags, also add to `.ghci-8.0` if impl(ghc <= 8.0.2) ghc-options: -fprint-potential-instances -- Initially, we disable all the warnings. -w - -Wwarn -- This option must be the first one after disabling the -- warnings. See Issue #2094. -Wunrecognised-warning-flags @@ -669,7 +671,9 @@ -Wduplicate-exports -Wempty-enumerations -Widentities - -Wincomplete-patterns + -- #6137: GHC 8.0 has no COMPLETE pragma, so we have to turn off the completeness checker + -- -Wincomplete-patterns + -- -Wincomplete-record-updates -Winline-rule-shadowing -Wmissing-fields -Wmissing-methods @@ -678,7 +682,8 @@ -Wnoncanonical-monad-instances -Wnoncanonical-monoid-instances -Woverflowed-literals - -Woverlapping-patterns + -- #6137: GHC 8.0 has no COMPLETE pragma, so we have to turn off the completeness checker + -- -Woverlapping-patterns -Wsemigroup -Wtabs -Wtyped-holes @@ -690,73 +695,77 @@ -Wwrong-do-bind else ghc-options: -fprint-potential-instances - -Wwarn=unrecognised-warning-flags - -Wwarn=deprecated-flags - -Wwarn=deriving-typeable - -Wwarn=dodgy-exports - -Wwarn=dodgy-foreign-imports - -Wwarn=dodgy-imports - -Wwarn=duplicate-exports - -Wwarn=empty-enumerations - -Wwarn=identities - -Wwarn=incomplete-patterns - -Wwarn=inline-rule-shadowing - -Wwarn=missing-fields - -Wwarn=missing-methods - -Wwarn=missing-pattern-synonym-signatures - -Wwarn=missing-signatures - -Wwarn=noncanonical-monad-instances - -Wwarn=noncanonical-monoid-instances - -Wwarn=overflowed-literals - -Wwarn=overlapping-patterns - -Wwarn=semigroup - -Wwarn=tabs - -Wwarn=typed-holes - -Wwarn=unrecognised-pragmas - -Wwarn=unticked-promoted-constructors - -Wwarn=unused-do-bind - -Wwarn=unused-foralls - -Wwarn=warnings-deprecations - -Wwarn=wrong-do-bind + -- ASR (2022-05-31). Workaround to Issue #5932. + -Werror=unrecognised-warning-flags + -Werror=deprecated-flags + -Werror=deriving-typeable + -Werror=dodgy-exports + -Werror=dodgy-foreign-imports + -Werror=dodgy-imports + -Werror=duplicate-exports + -Werror=empty-enumerations + -Werror=identities + -Werror=inline-rule-shadowing + -Werror=missing-fields + -Werror=missing-methods + -Werror=missing-pattern-synonym-signatures + -Werror=missing-signatures + -Werror=noncanonical-monad-instances + -Werror=noncanonical-monoid-instances + -Werror=overflowed-literals + -Werror=overlapping-patterns + -Werror=semigroup + -Werror=tabs + -Werror=typed-holes + -Werror=unrecognised-pragmas + -Werror=unticked-promoted-constructors + -Werror=unused-do-bind + -Werror=unused-foralls + -Werror=warnings-deprecations + -Werror=wrong-do-bind - -- NOTE: If adding or removing flags, also change `.ghci-8.2` if impl(ghc >= 8.2) - ghc-options: -Wcpp-undef - -- ASR TODO (2017-07-23): `make haddock` fails when - -- this flag is on. - -- -Wmissing-home-modules - -Wwarn=simplifiable-class-constraints - -Wwarn=unbanged-strict-patterns + ghc-options: -Werror=cpp-undef + -Werror=missing-home-modules + -Werror=simplifiable-class-constraints + -Werror=unbanged-strict-patterns - -- NOTE: If adding or removing flags, also change `.ghci-8.6` if impl(ghc >= 8.6) - ghc-options: -Wwarn=inaccessible-code - -Wwarn=star-binder - -Wwarn=star-is-type + ghc-options: -Werror=inaccessible-code + -Werror=star-binder + -Werror=star-is-type -- The following warning is an error in GHC >= 8.10. if impl(ghc >= 8.6) && impl(ghc < 8.10) - ghc-options: -Wwarn=implicit-kind-vars + ghc-options: -Werror=implicit-kind-vars - -- NOTE: If adding or removing flags, also change `.ghci-8.8` if impl(ghc >= 8.8) - ghc-options: -Wwarn=missed-extra-shared-lib + ghc-options: -Werror=missed-extra-shared-lib - -- NOTE: If adding or removing flags, also change `.ghci-8.10` if impl(ghc >= 8.10) - ghc-options: -Wwarn=deriving-defaults - -Wwarn=redundant-record-wildcards - -Wwarn=unused-packages - -Wwarn=unused-record-wildcards + ghc-options: -Werror=deriving-defaults + -Werror=redundant-record-wildcards + -Werror=unused-packages + -Werror=unused-record-wildcards - -- NOTE: If adding or removing flags, also change `.ghci-9.0` if impl(ghc >= 9.0) - ghc-options: -Wwarn=invalid-haddock + ghc-options: -Werror=invalid-haddock + -- #6137: coverage checker works only sufficiently well from GHC 9.0 + -Werror=incomplete-patterns + -Werror=incomplete-record-updates + -- ASR (2022-04-27). This warning was added in GHC 9.0.2, removed + -- from 9.2.1 and added back in 9.2.2. + if impl(ghc == 9.0.2) + ghc-options: -Werror=unicode-bidirectional-format-characters + + if impl(ghc >= 9.2.2) + ghc-options: -Werror=redundant-bang-patterns + -Werror=unicode-bidirectional-format-characters + default-language: Haskell2010 -- NOTE: If adding or removing default extensions, also change: - -- .ghci-8.0 -- .hlint.yaml -- This should also use the same extensions as the `test-suite` target below. default-extensions: BangPatterns @@ -766,7 +775,6 @@ -- slightly shorter, see PR #3920. --, DataKinds , DefaultSignatures - , DeriveDataTypeable , DeriveFoldable , DeriveFunctor , DeriveGeneric @@ -789,6 +797,7 @@ , StandaloneDeriving , TupleSections , TypeFamilies + , TypeOperators , TypeSynonymInstances executable agda @@ -821,7 +830,7 @@ hs-source-dirs: src/agda-mode main-is: Main.hs other-modules: Paths_Agda - build-depends: base >= 4.9.0.0 && < 4.17 + build-depends: base >= 4.9.0.0 && < 4.18 , directory >= 1.2.6.2 && < 1.4 , filepath >= 1.4.1.0 && < 1.5 , process >= 1.4.2.0 && < 1.7 diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,54 +1,202 @@ -Release notes for Agda version 2.6.2.2 -====================================== +Release notes for Agda version 2.6.3 +==================================== Highlights ---------- -* Agda 2.6.2.2 catches up to changes in the Haskell ecosystem - (`bytestring-0.11.2.0`, `mtl-2.3-rc3/4`, `text-icu-0.8.0.1`, - stackage `lts-19.0` and `nightly`). - -* Fixes inconsistency [#5838](https://github.com/agda/agda/issues/5838) - in `--cubical`. - -* Fixes some regressions introduced in 2.6.1: +* Added support for [Erased Cubical + Agda](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#cubical-agda-with-erased-glue), + a variant of Cubical Agda that is supported by the GHC backend, + under the flag `--erased-cubical`. - - [#5809](https://github.com/agda/agda/issues/5809): - internal error with `--irrelevant-projections`. +* Added a new flag `--cubical-compatible` to turn on generation of + Cubical Agda-specific support code (previously this behaviour was + part of `--without-K`). -* Fixes some regressions introduced in 2.6.2: + Since `--cubical-compatible` mode implies that functions should work + with the preliminary support for [indexed inductive types in Cubical + Agda](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#indexed-inductive-types), + many pattern matching functions will now emit an + `UnsupportedIndexedMatch` warning, indicating that the function will + not compute when applied to transports (from `--cubical` code). - - [#5705](https://github.com/agda/agda/issues/5705) and - [#5706](https://github.com/agda/agda/issues/5706): - inconsistency from universe level `Int` overflow. + This warning can be disabled with `-WnoUnsupportedIndexedMatch`, which + can be used either in an `OPTIONS` pragma or in your `agda-lib` file. + The latter is recommended if your project is only + `--cubical-compatible`, or if it is already making extensive use of + indexed types. - - [#5784](https://github.com/agda/agda/issues/5784): - `primEraseEquality` does not compute. + Note that code that uses (only) `--without-K` can no longer be + imported from code that uses `--cubical`. Thus it may make sense to + replace `--without-K` with `--cubical-compatible` in library code, + if possible. - - [#5805](https://github.com/agda/agda/issues/5805): - internal error involving holes and `with`. + Note also that Agda tends to be quite a bit faster if `--without-K` + is used instead of `--cubical-compatible`. - - [#5819](https://github.com/agda/agda/issues/5819): - internal error when reducing in termination checker. +* Agda 2.6.3 seems to type-check one variant of the standard library + about [30% + faster](https://github.com/agda/agda/issues/6049#issuecomment-1329163727) + than Agda 2.6.2.2 (on one system; the library was changed in a small + way between the tests to accommodate changes to Agda). In that test + the standard library did not use the new flag + `--cubical-compatible`. With that flag enabled in all the files that + used to use `--without-K` (and the warning `UnsupportedIndexedMatch` + turned off) Agda 2.6.3 was still about 10% faster. -* Other - [fixes](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.2+is%3Aclosed) - and improvements (see below). +* New primitives `declareData`, `defineData`, and `unquoteDecl data` + for generating new data types have been added to the [reflection + API](https://agda.readthedocs.io/en/v2.6.3/language/reflection.html#metaprogramming). Installation and infrastructure ------------------------------- -Agda supports GHC versions 8.0.2 to 9.2.2. +Agda supports GHC versions 8.0.2 to 9.4.4. -* UTF-8 encoding is now used for the `libraries` and `executables` - configuration files (issue - [#5741](https://github.com/agda/agda/issues/5741)). +Erasure +------- -Language --------- +* The new option `--erased-cubical` turns on a variant of Cubical Agda + (see [#4701](https://github.com/agda/agda/issues/4701)). -* `macro` definitions can now be used even when they are declared as erased - (PR [#5744](https://github.com/agda/agda/pull/5744)). + When this variant of Cubical Agda is used glue (and some related + builtins) may only be used in erased settings. One can import + regular Cubical Agda code from this variant of Cubical Agda, but + names defined using Cubical Agda are (mostly) treated as if they had + been marked as erased. See the [reference + manual](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#cubical-agda-with-erased-glue-and-erased-higher-constructors) + for more details. + + The GHC backend can compile code that uses `--erased-cubical` if the + top-level module uses this flag. + + This feature is experimental. + +* Added an option `--erase-record-parameters` that marks parameters to + record fields and definitions in a record module as erased (see + [#4786](https://github.com/agda/agda/issues/4786) and + [#5770](https://github.com/agda/agda/issues/5770)). For example: + + ```agda + {-# OPTIONS --erase-record-parameters #-} + + record R (A : Set) : Set where + field + f : A + + test : {@0 A : Set} → R A → A + test = R.f + ``` + +Cubical Agda +------------ + +* [**Breaking**] The generation of Cubical Agda-specific support code was removed + from `--without-K` and transferred to its own flag, + `--cubical-compatible` (see + [#5843](https://github.com/agda/agda/issues/5843) and + [#6049](https://github.com/agda/agda/issues/6049) for the + rationale). + +* Cubical Agda now has experimental support for indexed inductive types + ([#3733](https://github.com/agda/agda/issues/3733)). + See the [user guide](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#indexed-inductive-types) + for caveats. + +* The cubical interval `I` now belongs to its own sort, `IUniv`, rather + than `SSet`. For `J : IUniv` and `A : J → Set l`, we have + `(j : J) → A j : Set l`, that is, the type of functions from a type in `IUniv` + to a fibrant type is fibrant. + +* The option `--experimental-irrelevance` is now perhaps incompatible + with Cubical Agda and perhaps also postulated univalence (see + [#5611](https://github.com/agda/agda/issues/5611) and + [#5861](https://github.com/agda/agda/pull/5861)). + + This is not meant to imply that the option was not already + incompatible with those things. Note that + `--experimental-irrelevance` cannot be used together with `--safe`. + +* A new built-in constructor `REFLID` was added to the cubical identity + types. This is definitionally equal to the reflexivity identification + built with `conid`, with the difference being that matching on + `REFLID` is allowed. + + ```agda + symId : ∀ {a} {A : Set a} {x y : A} → Id x y → Id y x + symId reflId = reflId + ``` + +* Definitions which pattern match on higher-inductive types are no + longer considered for injectivity analysis. + ([#6219](https://github.com/agda/agda/pull/6219)) + +* [**Breaking**] Higher constructors are no longer considered as guarding in the productivity check. + ([#6108](https://github.com/agda/agda/issues/6108)) + +* Rewrite rules with interval arguments are now supported. + ([#4384](https://github.com/agda/agda/issues/4384)) + +The flat modality +----------------- + +* [**Breaking**] The `@flat`/`@♭` modality is now by default disabled (see + [#4927](https://github.com/agda/agda/issues/4927)). + + It can be enabled using the infective flag `--cohesion`. + +* [**Breaking**] Matching on `@flat` arguments is now disabled by default, the flag + `--no-flat-split` has been removed, and the flag `--flat-split` is + now infective (see [#6238](https://github.com/agda/agda/issues/6238) + and [#6263](https://github.com/agda/agda/issues/6263)). + + Matching can be enabled using the `--flat-split` flag. Note that in + Cubical Agda functions that match on an argument marked with `@flat` + trigger the `UnsupportedIndexedMatch` warning, and the code might + not compute properly. + +Reflection +---------- + +* Two new reflection primitives + + ```agda + declareData : Name → Nat → Type → TC ⊤ + defineData : Name → List (Σ Name (λ _ → Type)) → TC ⊤ + ``` + + are added for declaring and defining datatypes, similar to + `declareDef` and `defineDef`. + +* The construct `unquoteDecl` is extended with the ability of bringing + a datatype `d` and its constructors `c₁ ... cₙ` given by a `TC` + computation `m` into scope by the following syntax: + + ```agda + unquoteDecl data x constructor c₁ .. cₙ = m + ``` + +* A new reflection primitive `getInstances : Meta → TC (List Term)` + was added to `Agda.Builtin.Reflection`. This operation returns the + list of all possibly valid instance candidates for a given + metavariable. For example, the following macro instantiates the goal + with the first instance candidate, even if there are several: + ```agda + macro + pickWhatever : Term → TC ⊤ + pickWhatever hole@(meta m _) = do + (cand ∷ _) ← getInstances m + where [] -> typeError (strErr "No candidates!" ∷ []) + unify hole cand + pickWhatever _ = typeError (strErr "Already solved!" ∷ []) + ``` + +* [**Breaking**] The reflection primitives `getContext` and `inContext` use a nominal context + `List (Σ String λ _ → Arg Type)` instead of `List (Arg Type)` for printing + type information better. Similarly, `extendContext` takes an extra argument + of type `String`. + +* `macro` definitions can now be used even when they are declared as erased. For example, this is now accepted: ```agda macro @@ -59,51 +207,316 @@ test = trivial ``` -* Fixed inconsistent `--cubical` reductions for `transp`: - issue [#5838](https://github.com/agda/agda/issues/5838). +* A new reflection primitive `formatErrorParts : List ErrorPart → TC String` + is added. It takes a list of `ErrorPart` and return its formatted string. -* Fixed issues with reflection: +* [**Breaking**] A new constructor `pattErr : Pattern → ErrorPart` of `ErrorPart` for reflection + is added. - - [#5762](https://github.com/agda/agda/issues/5762): - do not eagerly check existence of commands in `executables` file. +* [**Breaking**] The reflection primitives `getType` and + `getDefinition` respect the module context they are invoked from + instead of returning information that would be expected in the top + context. - - [#5695](https://github.com/agda/agda/issues/5695): - fix `elaborate-and-give` interaction command. +* [**Breaking**] The reflection primitive `inContext` cannot step + outside of the context that the `TC` computation is invoked from + anymore. The telescope is now relative to that context instead. - - [#5700](https://github.com/agda/agda/issues/5700): - scope of metas created during macro expansion. +Syntax +------ - - [#5712](https://github.com/agda/agda/issues/5712): - internal error with tactics on record fields of function type. +* It is now OK to put lambda-bound variables anywhere in the + right-hand side of a syntax declaration. However, there must always + be at least one "identifier" between any two regular "holes". For + instance, the following syntax declaration is accepted because `-` + is between the holes `B` and `D`. -* Fixed issues with instance search: + ```agda + postulate + F : (Set → Set) → (Set → Set) → Set - - [#5583](https://github.com/agda/agda/issues/5583): - constructor instances from parameterized modules. + syntax F (λ A → B) (λ C → D) = B A C - D + ``` - - [#5787](https://github.com/agda/agda/issues/5787): - erased instance arguments. +* Syntax can now use lambdas with multiple arguments + ([#394](https://github.com/agda/agda/issues/394)). -* Fixed issue [#5683](https://github.com/agda/agda/issues/5683) with - generalization in `let`. + Example: + ```agda + postulate + Σ₂ : (A : Set) → (A → A → Set) → Set + + syntax Σ₂ A (λ x₁ x₂ → P) = [ x₁ x₂ ⦂ A ] × P + ``` + +Builtins +-------- + +* [**Breaking**] Change `primFloatToWord64` to return `Maybe Word64`. + (See [#6093](https://github.com/agda/agda/issues/6093).) + + The new type is + ```agda + primFloatToWord64 : Float → Maybe Word64 + ``` + and it returns `nothing` for `NaN`. + +* [**Breaking**] The type expected by the builtin `EQUIVPROOF` has been changed to + properly encode the condition that `EQUVIFUN` is an equivalence. + ([#5661](https://github.com/agda/agda/issues/5661), + [#6032](https://github.com/agda/agda/pull/6032)) + +* [**Breaking**] The primitive `primIdJ` has been removed + ([#6032](https://github.com/agda/agda/pull/6032)) in favour of + matching on the cubical identity type. + +* [**Breaking**] The builtin `SUBIN` is now exported from `Agda.Builtin.Cubical.Sub` as + **`inS`** rather than `inc`. Similarly, the internal modules refer to + `primSubOut` as `outS`. ([#6032](https://github.com/agda/agda/pull/6032)) + +Pragmas and options +------------------- + +* It is now possible to declare several `BUILTIN REWRITE` relations. + Example: + ```agda + {-# OPTIONS --rewriting #-} + + open import Agda.Builtin.Equality + open import Agda.Builtin.Equality.Rewrite -- 1st rewrite relation + + postulate + R : (A : Set) → A → A → Set + A : Set + a b c : A + foo : R A a b -- using 2nd rewrite relation + bar : b ≡ c -- using 1st rewrite relation + + {-# BUILTIN REWRITE R #-} -- 2nd rewrite relation + {-# REWRITE foo bar #-} + + test : a ≡ c + test = refl + ``` + +* [**Breaking**] The option `--experimental-lossy-unification` that + makes Agda sometimes use first-order unification has been renamed to + `--lossy-unification` + ([#1625](https://github.com/agda/agda/issues/1625)). + + Note that use of this option is associated with some potential + [drawbacks](https://agda.readthedocs.io/en/v2.6.3/language/lossy-unification.html#drawbacks). + +* The new option `--no-load-primitives` complements `--no-import-sorts` + by foregoing loading of the primitive modules altogether. This option + leaves Agda in a very fragile state, as the built-in sorts are used + extensively throughout the implementation. It is intended to be used + by Literate Agda projects which want to bind `BUILTIN TYPE` (and + other primitives) in their own literate files. + +* If `--interaction-exit-on-error` is used, then Agda exits with a + non-zero exit code if `--interaction` or `--interaction-json` are + used and a type error is encountered. The option also makes Agda + exit with exit code 113 if Agda fails to parse a command. + + This option might for instance be used if Agda is controlled from a + script. + +* Add a `NOT_PROJECTION_LIKE` pragma, which marks a function as not + suitable for projection-likeness. Projection-like functions have some of + their arguments erased, which can cause confusing behaviour when they + are printed instantiated (see [#6203](https://github.com/agda/agda/issues/6203)). + +* [**Breaking**] The options `--subtyping` and `--no-subtyping` have been removed + (see [#5427](https://github.com/agda/agda/issues/5427)). + +Profiling and performance +------------------------- + +* New verbosity `-v debug.time:100` adds time stamps to debugging output. + +* [**Breaking**] Profiling options are now turned on with a new `--profile` flag + instead of abusing the debug verbosity option. (See + [#5781](https://github.com/agda/agda/issues/5781).) + +* The new profiling option `--profile=conversion` collects statistics + on how often various steps of the conversion algorithm are used + (reduction, eta-expansion, syntactic equality, etc). + +* Meta-variables can now be saved in `.agdai` files, instead + of being expanded. This can affect performance. (See + [#5731](https://github.com/agda/agda/issues/5731).) + + Meta-variables are saved if the pragma option `--save-metas` is + used. This option can be overridden by `--no-save-metas`. + +* The new option `--syntactic-equality[=FUEL]` can be used to limit + how many times the syntactic equality shortcut is allowed to fail + (see [#5801](https://github.com/agda/agda/issues/5801)). + + If `FUEL` is omitted, then the syntactic equality shortcut is + enabled without any restrictions. + + If `FUEL` is given, then the syntactic equality shortcut is given + `FUEL` units of fuel. The exact meaning of this is + implementation-dependent, but successful uses of the shortcut do not + affect the amount of fuel. Currently the fuel is decreased in the + failure continuations of the implementation of the syntactic + equality shortcut. When a failure continuation completes the fuel is + restored to its previous amount. + + The idea for this option comes from András Kovács' + [smalltt](https://github.com/AndrasKovacs/smalltt/blob/989b020309686e04374f1ab7844f468386d2eb2f/README.md#approximate-conversion-checking). + + Note that this option is experimental and subject to change. + +Library management +------------------ + +* Library files below the "project root" are now ignored + (see [#5644](https://github.com/agda/agda/issues/5644)). + + For instance, if you have a module called `A.B.C` in the directory + `Root/A/B`, then `.agda-lib` files in `Root/A` or `Root/A/B` do not + affect what options are used to type-check `A.B.C`: `.agda-lib` + files for `A.B.C` have to reside in `Root`, or further up the + directory hierarchy. + +Interaction +----------- + +* Agsy ([automatic proof search](https://agda.readthedocs.io/en/v2.6.3/tools/auto.html)) can + now be invoked in the right-hand-sides of copattern matching clauses. + ([#5827](https://github.com/agda/agda/pull/5827)) + Compiler backends ----------------- -* `.hs` files generated by the GHC backend now switch off the - `warn-overlapping-patterns` warning (issue - [#5758](https://github.com/agda/agda/issues/5758)). +* [**Breaking**] Both the GHC and JS backends now refuse to compile code that uses + `--cubical`. -* The GHC backend now calls `ghc` with environment setting - `GHC_CHARENC=UTF-8` (issue - [#5742](https://github.com/agda/agda/issues/5742)). + Note that support for compiling code that uses `--erased-cubical` + has been added to the GHC backend (see above). -Performance +* If the GHC backend is invoked when `--interaction` or + `--interaction-json` is active (for instance when the Emacs mode is + used), then GHC is now invoked from the directory containing the + `MAlonzo` directory (see + [#6194](https://github.com/agda/agda/issues/6194)). + + Before GHC was invoked from the Agda process's current working + directory, and that is still the case if `--interaction` and + `--interaction-json` are not used. + +DOT backend ----------- -* Better caching of interfaces - (issue [#2767](https://github.com/agda/agda/issues/2767)). +* The new option `--dependency-graph-include=LIBRARY` can be used to + restrict the dependency graph to modules from one or more libraries + (see [#5634](https://github.com/agda/agda/issues/5634)). -* Various performance improvements concerning meta-variables: - issue [#5388](https://github.com/agda/agda/issues/5388) - and PR [#5733](https://github.com/agda/agda/pull/5733). + Note that the module given on the command line might not be + included. + +* The generated graphs no longer contain "redundant" edges: if a + module is imported both directly and indirectly, then the edge + corresponding to the direct import is omitted. + +JSON API +-------- + +* [**Breaking**] The JSON API now represents meta-variables differently, using + objects containing two keys, `id` and `module`, both with values + that are (natural) numbers. See + [#5731](https://github.com/agda/agda/issues/5731). + + +Other issues closed +-------------------- + +For 2.6.3, the following issues were also closed (see [bug +tracker](https://github.com/agda/agda/issues)): + + - [#3660](https://github.com/agda/agda/issues/3660): Wrong variable name in constraints for higher constructor + - [#3986](https://github.com/agda/agda/issues/3986): Subtyping `.A -> B <= A -> B` leads to wrong `ArgInfo` + - [#4103](https://github.com/agda/agda/issues/4103): Rewrite rule rejected because of projection likeness + - [#4506](https://github.com/agda/agda/issues/4506): Lack of unicode support in locale may result in uncaught `IOException` + - [#4725](https://github.com/agda/agda/issues/4725): Cubical Agda: Program rejected by termination checker due to moved dot pattern + - [#4755](https://github.com/agda/agda/issues/4755): Rewrite rule on constructor uses wrong type for matching + - [#4763](https://github.com/agda/agda/issues/4763): Cubical Agda: Unquote anonymous copattern involving path + - [#5191](https://github.com/agda/agda/issues/5191): Unifier can use erased variables in non-erased data parameters + - [#5257](https://github.com/agda/agda/issues/5257): Internal error when matching on user syntax with binding + - [#5378](https://github.com/agda/agda/issues/5378): Internal error with tactic on record field + - [#5448](https://github.com/agda/agda/issues/5448): Should the predicate be erasable in the subst rule (without-K) + - [#5462](https://github.com/agda/agda/issues/5462): Internal error caused by a REWRITE on a projection-like function + - [#5468](https://github.com/agda/agda/issues/5468): Disallow certain forms of pattern matching when an index is erased + - [#5525](https://github.com/agda/agda/issues/5525): Duplicate entries in `executables` file lead to undefined behavior + - [#5548](https://github.com/agda/agda/issues/5548): Agda infers an incorrect type with subtyping on + - [#5551](https://github.com/agda/agda/issues/5551): Panic when showing module contents with pattern synonym + - [#5563](https://github.com/agda/agda/issues/5563): Allow erased names in the type signatures of let-bound definitions + - [#5577](https://github.com/agda/agda/issues/5577): The "Could not generate equivalence" warning is not always emitted + - [#5581](https://github.com/agda/agda/issues/5581): Lexical error with tab character in literate Agda text + - [#5589](https://github.com/agda/agda/issues/5589): Internal error with REWRITE of function from path + - [#5681](https://github.com/agda/agda/issues/5681): Panic on record declaration with unknown sort + - [#5702](https://github.com/agda/agda/issues/5702): Can't case split an `HitInt` with some already existing cases + - [#5715](https://github.com/agda/agda/issues/5715): Reflection: Use `Telescope` for `getContext`, `inContext`, and `extendContext` + - [#5727](https://github.com/agda/agda/issues/5727): Reducing universe levels before checking is not sufficient + - [#5728](https://github.com/agda/agda/issues/5728): Internal error when pattern matching on `...` in with statement without providing a pattern match + - [#5734](https://github.com/agda/agda/issues/5734): Relevance check in reflection + - [#5751](https://github.com/agda/agda/issues/5751): json interaction produces Haskell output for `SolveAll` + - [#5754](https://github.com/agda/agda/issues/5754): Internal error when compiling program with quoted metavariable + - [#5760](https://github.com/agda/agda/issues/5760): Some code related to Cubical Agda runs also when the K rule is on + - [#5763](https://github.com/agda/agda/issues/5763): Internal parser error using syntax rules + - [#5765](https://github.com/agda/agda/issues/5765): Erasure check failure when pattern matching on refl in erased definition + - [#5775](https://github.com/agda/agda/issues/5775): JSON interaction produces fully qualified terms + - [#5794](https://github.com/agda/agda/issues/5794): Agsy/Auto crashes with `Prelude.!!: index too large` + - [#5823](https://github.com/agda/agda/issues/5823): Singleton check loops on recursive eta record + - [#5828](https://github.com/agda/agda/issues/5828): Agsy/Auto panics with `-r` in the presence of a pattern synonym + - [#5845](https://github.com/agda/agda/issues/5845): Internal error caused by abstracting `variables` + - [#5848](https://github.com/agda/agda/issues/5848): Internal error with `--confluence-check` + - [#5850](https://github.com/agda/agda/issues/5850): Warn about useless hiding in `variable` declaration + - [#5856](https://github.com/agda/agda/issues/5856): Lambda with irrefutable pattern is not rejected when used on Path + - [#5868](https://github.com/agda/agda/issues/5868): Document `--two-level` + - [#5875](https://github.com/agda/agda/issues/5875): Instance Search breaks Termination Highlighting + - [#5891](https://github.com/agda/agda/issues/5891): `SizeUniv : SizeUniv` is inconsistent + - [#5901](https://github.com/agda/agda/issues/5901): Use `emacs --batch` mode in `agda-mode` setup + - [#5920](https://github.com/agda/agda/issues/5920): Erased constructors skipped in modality check + - [#5922](https://github.com/agda/agda/issues/5922): Failure of termination checking for reflection-generated code due to data projections + - [#5923](https://github.com/agda/agda/issues/5923): Internal error in rewriting + - [#5944](https://github.com/agda/agda/issues/5944): Internal error in rewriting with `--two-level` + - [#5953](https://github.com/agda/agda/issues/5953): Recursor of inductive-inductive type does not pass termination check in Cubical Agda + - [#5955](https://github.com/agda/agda/issues/5955): Composition of Glue Type Causes Infinite Loop + - [#5956](https://github.com/agda/agda/issues/5956): Cubical Agda crashes when printing empty system + - [#5966](https://github.com/agda/agda/issues/5966): Improved performance by switching to `vector-hashtables` + - [#5989](https://github.com/agda/agda/issues/5989): Dead-code elimination crashes function with private tactic argument + - [#6003](https://github.com/agda/agda/issues/6003): de Bruijn index out of scope when rewriting + - [#6006](https://github.com/agda/agda/issues/6006): Internal error rewriting with holes + - [#6015](https://github.com/agda/agda/issues/6015): Pi types and Partial types should not be considered inter-convertible + - [#6022](https://github.com/agda/agda/issues/6022): Private bindings in imported modules defeat check for binding of primIdFace/primIdPath + - [#6042](https://github.com/agda/agda/issues/6042): De Bruijn index out of scope when rewriting without-K + - [#6043](https://github.com/agda/agda/issues/6043): de Bruijn error on unexpected implicit argument + - [#6059](https://github.com/agda/agda/issues/6059): Non-terminating function over tuples passed with `--termination-depth=2` + - [#6066](https://github.com/agda/agda/issues/6066): Document the meaning of `pattern` without `no-eta-equality` + - [#6067](https://github.com/agda/agda/issues/6067): Another de Bruijn error in rewriting + - [#6073](https://github.com/agda/agda/issues/6073): Constraint solving does not honour singleton types + - [#6074](https://github.com/agda/agda/issues/6074): `piSort`/`funSort` of `IUniv` should be blocked on the codomain + - [#6076](https://github.com/agda/agda/issues/6076): Agda input mode (emacs): Minibuffer display for `\;` is strange + - [#6080](https://github.com/agda/agda/issues/6080): A space leak due to `absName` + - [#6082](https://github.com/agda/agda/issues/6082): Elaborate-and-give does not respect `--postfix-projections` + - [#6095](https://github.com/agda/agda/issues/6095): Ambiguous pattern synonyms broken with anonymous module + - [#6112](https://github.com/agda/agda/issues/6112): Internal error: non-confluent rewriting to singletons + - [#6200](https://github.com/agda/agda/issues/6200): The reflection machinery does not treat the module telescope consistently + - [#6203](https://github.com/agda/agda/issues/6203): Projection-likeness and instance arguments + - [#6205](https://github.com/agda/agda/issues/6205): Internal error with `withReconstructed` + - [#6244](https://github.com/agda/agda/issues/6244): Make `--no-load-primitives` not `--safe` + - [#6250](https://github.com/agda/agda/issues/6250): Documentation says `--sized-types` is the default when it isn't + - [#6257](https://github.com/agda/agda/issues/6257): Document options `--prop`, `--guarded`, and `--two-level`. + - [#6265](https://github.com/agda/agda/issues/6265): Some options should be listed in `restartOptions` + - [#6273](https://github.com/agda/agda/issues/6273): Missing highlighting when interleaved mutual is used + - [#6276](https://github.com/agda/agda/issues/6276): LaTeX/HTML generation doesn't properly render parameters of pre-declared records + - [#6281](https://github.com/agda/agda/issues/6281): Special treatment of attribute followed by underscore in pretty-printer + - [#6337](https://github.com/agda/agda/issues/6337): `--lossy-unification` in Agda 2.6.3 + - [#6338](https://github.com/agda/agda/issues/6338): internal error in Agda, perhaps related to `--rewriting` + - [#6377](https://github.com/agda/agda/issues/6377): Fix installation docs concerning icu libraries + - [#6379](https://github.com/agda/agda/issues/6379): Weird warning for instance declarations of bad type diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,12 +1,12 @@ -Copyright (c) 2005-2022 remains with the authors. +Copyright (c) 2005-2023 remains with the authors. Agda 2 was originally written by Ulf Norell, partially based on code from Agda 1 by Catarina Coquand and Makoto Takeyama, and from Agdalight by Ulf Norell and Andreas Abel. Agda 2 is currently actively developed mainly by Andreas Abel, -Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt, Nils -Anders Danielsson, Ulf Norell, Andrés Sicard-Ramírez, and Andrea -Vezzosi. +Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt, +Nils Anders Danielsson, Amélia Liao, Ulf Norell, Andrés Sicard-Ramírez, +and Andrea Vezzosi. Further, Agda 2 has received contributions by, amongst others, Stevan Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, Guillaume Brunerie, diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -16,10 +16,11 @@ import System.Environment (getEnvironment) import System.Process import System.Exit +import System.IO import System.IO.Error (isDoesNotExistError) -import Control.Monad (when, forM_, unless) -import Control.Exception (catch, throwIO) +import Control.Monad (forM_, unless) +import Control.Exception (bracket, catch, throwIO) main :: IO () main = defaultMainWithHooks userhooks @@ -96,25 +97,47 @@ -- current directory root of the package. putStrLn "Generating Agda library interface files..." - forM_ (dataFiles pd) $ \fp -> when (takeExtension fp == ".agda") $ do - let fullpath = ddir fp - let fullpathi = toIFile fullpath - -- remove existing interface file - let handleExists e | isDoesNotExistError e = return () + -- The Agda.Primitive* and Agda.Builtin* modules. + let builtins = filter ((== ".agda") . takeExtension) (dataFiles pd) + + -- Remove all existing .agdai files. + forM_ builtins $ \fp -> do + let fullpathi = toIFile (ddir fp) + + handleExists e | isDoesNotExistError e = return () | otherwise = throwIO e removeFile fullpathi `catch` handleExists - putStrLn $ "... " ++ fullpath - ok <- rawSystem' ddir agda [ "--no-libraries", "--local-interfaces" - , "--ignore-all-interfaces" - , "-Werror" - , fullpath, "-v0" - ] - case ok of - ExitSuccess -> return () - ExitFailure _ -> die $ "Error: Failed to typecheck " ++ fullpath ++ "!" + -- Type-check all builtin modules (in a single Agda session to take + -- advantage of caching). + let loadBuiltinCmds = concat + [ [ cmd ("Cmd_load " ++ f ++ " []") + , cmd "Cmd_no_metas" + -- Fail if any meta-variable is unsolved. + ] + | b <- builtins + , let f = show (ddir b) + cmd c = "IOTCM " ++ f ++ " None Indirect (" ++ c ++ ")" + ] + env <- getEnvironment + _output <- readCreateProcess + (proc agda + [ "--interaction" + , "--interaction-exit-on-error" + , "--no-libraries" + , "--local-interfaces" + , "-Werror" + , "-v0" + ]) + { delegate_ctlc = True + -- Make Agda look for data files in a + -- certain place. + , env = Just (("Agda_datadir", ddir) : env) + } + (unlines loadBuiltinCmds) + return () agdaExeExtension :: String #if MIN_VERSION_Cabal(2,3,0) @@ -122,12 +145,3 @@ #else agdaExeExtension = exeExtension #endif - -rawSystem' :: FilePath -> String -> [String] -> IO ExitCode -rawSystem' agda_datadir cmd args = do - -- modify environment with Agda_datadir, so agda-executable will look - -- for data-files in the right place - e <- getEnvironment - let e' = ("Agda_datadir", agda_datadir) : e - (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True, env = Just e' } - waitForProcess p diff --git a/doc/release-notes/2.6.2.2.md b/doc/release-notes/2.6.2.2.md new file mode 100644 --- /dev/null +++ b/doc/release-notes/2.6.2.2.md @@ -0,0 +1,109 @@ +Release notes for Agda version 2.6.2.2 +====================================== + +Highlights +---------- + +* Agda 2.6.2.2 catches up to changes in the Haskell ecosystem + (`bytestring-0.11.2.0`, `mtl-2.3-rc3/4`, `text-icu-0.8.0.1`, + stackage `lts-19.0` and `nightly`). + +* Fixes inconsistency [#5838](https://github.com/agda/agda/issues/5838) + in `--cubical`. + +* Fixes some regressions introduced in 2.6.1: + + - [#5809](https://github.com/agda/agda/issues/5809): + internal error with `--irrelevant-projections`. + +* Fixes some regressions introduced in 2.6.2: + + - [#5705](https://github.com/agda/agda/issues/5705) and + [#5706](https://github.com/agda/agda/issues/5706): + inconsistency from universe level `Int` overflow. + + - [#5784](https://github.com/agda/agda/issues/5784): + `primEraseEquality` does not compute. + + - [#5805](https://github.com/agda/agda/issues/5805): + internal error involving holes and `with`. + + - [#5819](https://github.com/agda/agda/issues/5819): + internal error when reducing in termination checker. + +* Other + [fixes](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.2+is%3Aclosed) + and improvements (see below). + +Installation and infrastructure +------------------------------- + +Agda supports GHC versions 8.0.2 to 9.2.2. + +* UTF-8 encoding is now used for the `libraries` and `executables` + configuration files (issue + [#5741](https://github.com/agda/agda/issues/5741)). + +Language +-------- + +* `macro` definitions can now be used even when they are declared as erased + (PR [#5744](https://github.com/agda/agda/pull/5744)). + For example, this is now accepted: + ```agda + macro + @0 trivial : Term → TC ⊤ + trivial = unify (con (quote refl) []) + + test : 42 ≡ 42 + test = trivial + ``` + +* Fixed inconsistent `--cubical` reductions for `transp`: + issue [#5838](https://github.com/agda/agda/issues/5838). + +* Fixed issues with reflection: + + - [#5762](https://github.com/agda/agda/issues/5762): + do not eagerly check existence of commands in `executables` file. + + - [#5695](https://github.com/agda/agda/issues/5695): + fix `elaborate-and-give` interaction command. + + - [#5700](https://github.com/agda/agda/issues/5700): + scope of metas created during macro expansion. + + - [#5712](https://github.com/agda/agda/issues/5712): + internal error with tactics on record fields of function type. + +* Fixed issues with instance search: + + - [#5583](https://github.com/agda/agda/issues/5583): + constructor instances from parameterized modules. + + - [#5787](https://github.com/agda/agda/issues/5787): + erased instance arguments. + +* Fixed issue [#5683](https://github.com/agda/agda/issues/5683) with + generalization in `let`. + +Compiler backends +----------------- + +* `.hs` files generated by the GHC backend now switch off the + `warn-overlapping-patterns` warning (issue + [#5758](https://github.com/agda/agda/issues/5758)). + +* The GHC backend now calls `ghc` with environment setting + `GHC_CHARENC=UTF-8` (issue + [#5742](https://github.com/agda/agda/issues/5742)). + +Performance +----------- + +* Better caching of interfaces + (issue [#2767](https://github.com/agda/agda/issues/2767)). + +* Various performance improvements concerning meta-variables: + issue [#5388](https://github.com/agda/agda/issues/5388) + and PR [#5733](https://github.com/agda/agda/pull/5733). diff --git a/doc/user-manual/agda.svg b/doc/user-manual/agda.svg new file mode 100644 --- /dev/null +++ b/doc/user-manual/agda.svg @@ -0,0 +1,43 @@ + + + + logotype + Created with Sketch. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/agda-mode/Main.hs b/src/agda-mode/Main.hs --- a/src/agda-mode/Main.hs +++ b/src/agda-mode/Main.hs @@ -122,7 +122,7 @@ -- | Tries to find the user's .emacs file by querying Emacs. findDotEmacs :: IO FilePath -findDotEmacs = askEmacs "(insert (expand-file-name user-init-file))" +findDotEmacs = askEmacs "(expand-file-name user-init-file)" -- | Has the Agda mode already been set up? @@ -167,14 +167,24 @@ (removeFile . fst) $ \(file, h) -> do hClose h exit <- rawSystemWithDiagnostics "emacs" - [ "--no-desktop", "-nw", "--no-splash" - -- Andreas, 2014-01-11: ^ try a leaner startup of emacs - -- Andreas, 2018-09-08: -nw instead of --no-window-system as some emacses do not support the long version - , "--eval" - , "(with-temp-file " ++ escape file ++ " " - ++ query ++ ")" - , "--kill" - ] + [ "--batch" + -- Andreas, 2022-10-15, issue #5901, suggested by Spencer Baugh (catern): + -- Use Emacs batch mode so that it can run without a terminal. + , "--user", "" + -- The flag --user is necessary with --batch so that user-init-file is defined. + -- The empty user is the default user. + -- (Option --batch includes --no-init-file, this is reverted by supplying --user.) + -- Andreas, 2022-05-25, issue #5901 reloaded: + -- Loading the init file without loading the site fails for some users: + -- , "--quick" + -- -- Option --quick includes --no-site-file. + , "--eval" + , apply [ "with-temp-file", escape file, apply [ "insert", query ] ] + -- Short cutting the temp file via just [ "princ", query ] + -- does not work if the loading of the user-init-file prints extra stuff. + -- Going via the temp file we can let this stuff go to stdout without + -- affecting the output we care about. + ] unless (exit == ExitSuccess) $ do informLn "Unable to query Emacs." exitFailure @@ -249,16 +259,16 @@ where compile dataDir f = do exit <- rawSystemWithDiagnostics "emacs" $ - [ "--no-init-file", "--no-site-file" - , "--directory", dataDir - , "--batch" - , "--eval" - , "(progn \ - \(setq byte-compile-error-on-warn t) \ - \(byte-compile-disable-warning 'cl-functions) \ - \(batch-byte-compile))" - , f - ] + [ "--quick" -- 'quick' implies 'no-site-file' + , "--directory", dataDir + , "--batch" -- 'batch' implies 'no-init-file' but not 'no-site-file'. + , "--eval" + , "(progn \ + \(setq byte-compile-error-on-warn t) \ + \(byte-compile-disable-warning 'cl-functions) \ + \(batch-byte-compile))" + , f + ] return $ if exit == ExitSuccess then Nothing else Just f ------------------------------------------------------------------------ @@ -269,3 +279,10 @@ inform = hPutStr stderr informLn = hPutStrLn stderr + +parens :: String -> String +parens s = concat [ "(", s, ")" ] + +-- LISP application +apply :: [String] -> String +apply = parens . unwords diff --git a/src/data/JS/agda-rts.js b/src/data/JS/agda-rts.js --- a/src/data/JS/agda-rts.js +++ b/src/data/JS/agda-rts.js @@ -185,7 +185,6 @@ // These WORD64 values were obtained via `castDoubleToWord64` in Haskell: -const WORD64_NAN = 18444492273895866368n; const WORD64_POS_INF = 9218868437227405312n; const WORD64_NEG_INF = 18442240474082181120n; const WORD64_POS_ZERO = 0n; @@ -193,7 +192,7 @@ exports.primFloatToWord64 = function(x) { if (exports.primFloatIsNaN(x)) { - return WORD64_NAN; + return null; } else if (x < 0.0 && exports.primFloatIsInfinite(x)) { return WORD64_NEG_INF; @@ -350,9 +349,9 @@ exports.primFaceForall = f => f(true) == true && f(false) == false; exports.primDepIMin = i => f => i ? f({ "tt" : a => a["tt"]() }) : false; +exports.primConId = _ => _ => _ => _ => i => p => { return { "i" : i, "p" : p } }; exports.primIdFace = _ => _ => _ => _ => x => x["i"]; exports.primIdPath = _ => _ => _ => _ => x => x["p"]; -exports.primIdJ = _ => _ => _ => _ => _ => x => _ => _ => x; exports.primIdElim = _ => _ => _ => _ => _ => f => x => y => f(y["i"])(x)(y["p"]); @@ -375,3 +374,21 @@ // primQNameFixity : Name -> Fixity exports.primQNameFixity = x => x['fixity']; + +// Meta + +// primShowMeta : Meta -> String +// Should be kept in sync with version in `primitiveFunctions` in +// Agda.TypeChecking.Primitive +exports.primShowMeta = x => "_" + x['id'] + "@" + x['module']; + +// primMetaToNat : Meta -> Nat +// Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive +exports.primMetaToNat = x => x['module'] * 2^64 + x['id']; + +// primMetaEquality : Meta -> Meta -> Bool +exports.primMetaEquality = x => y => x['id'] === y['id'] && x['module'] === y['module']; + +// primMetaLess : Meta -> Meta -> Bool +exports.primMetaLess = x => y => x['id'] === y['id'] ? x['module'] < y['module'] : x['id'] < y['id']; + diff --git a/src/data/MAlonzo/src/MAlonzo/RTE/Float.hs b/src/data/MAlonzo/src/MAlonzo/RTE/Float.hs --- a/src/data/MAlonzo/src/MAlonzo/RTE/Float.hs +++ b/src/data/MAlonzo/src/MAlonzo/RTE/Float.hs @@ -174,8 +174,10 @@ | isNaN x = nan | otherwise = x -doubleToWord64 :: Double -> Word64 -doubleToWord64 = castDoubleToWord64 . normaliseNaN +doubleToWord64 :: Double -> Maybe Word64 +doubleToWord64 x + | isNaN x = Nothing + | otherwise = Just (castDoubleToWord64 x) -- |Denotational equality for floating point numbers, checks bitwise equality. -- 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 @@ -184,11 +184,12 @@ ;; Equality and similar symbols. - ("eq" . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕")) + ("eq" . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕＝")) ("eqn" . ,(agda-input-to-string-list "≠≁ ≉ ≄ ≇≆ ≢ ≭ ")) ("=n" . ("≠")) - ("~" . ("∼")) ("~n" . ("≁")) + ("~" . ,(agda-input-to-string-list "∼～")) + ("~n" . ("≁")) ("~~" . ("≈")) ("~~n" . ("≉")) ("~~~" . ("≋")) (":~" . ("∻")) @@ -198,6 +199,7 @@ ("~~-" . ("≊")) ("==" . ("≡")) ("==n" . ("≢")) ("===" . ("≣")) + ("=" . ("＝")) (".=" . ("≐")) (".=." . ("≑")) (":=" . ("≔")) ("=:" . ("≕")) ("=o" . ("≗")) @@ -211,9 +213,9 @@ ;; Inequality and similar symbols. - ("leq" . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞")) + ("leq" . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞＜")) ("leqn" . ,(agda-input-to-string-list "≮ ≰≨≴⋦≸⊀ ⋨⊄⊈⊊ ⋢⋤ ⋪⋬ ⋠")) - ("geq" . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟")) + ("geq" . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟＞")) ("geqn" . ,(agda-input-to-string-list "≯ ≱≩≵⋧≹⊁ ⋩⊅⊉⊋ ⋣⋥ ⋫⋭ ⋡")) ("<=" . ("≤")) (">=" . ("≥")) @@ -293,23 +295,25 @@ ("x" . ("×")) ("o" . ("∘")) ("comp" . ("∘")) - ("." . ("∙")) + ("." . ,(agda-input-to-string-list "∙．")) ("*" . ("⋆")) (".+" . ("∔")) (".-" . ("∸")) (":" . ,(agda-input-to-string-list "∶⦂ː꞉˸፥፦：﹕︓")) ("," . ,(agda-input-to-string-list "ʻ،⸲⸴⹁⹉、︐︑﹐﹑，､")) - (";" . ,(agda-input-to-string-list "؛⁏፤꛶；︔﹔⍮⸵;")) + (";" . ,(agda-input-to-string-list "⨾⨟⁏፤꛶；︔﹔⍮⸵;")) ("::" . ("∷")) ("::-" . ("∺")) ("-:" . ("∹")) ("+ " . ("⊹")) + ("+" . ("＋")) + ("sqrt" . ("√")) ("surd3" . ("∛")) ("surd4" . ("∜")) ("increment" . ("∆")) ("inf" . ("∞")) ("&" . ("⅋")) - ("z;" . ("⨟")) + ("z;" . ,(agda-input-to-string-list "⨟⨾")) ("z:" . ("⦂")) ;; Circled operators. @@ -344,10 +348,10 @@ ;; Arrows. - ("l" . ,(agda-input-to-string-list "←⇐⇚⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹ ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲ ")) - ("r" . ,(agda-input-to-string-list "→⇒⇛⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴ ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸")) - ("u" . ,(agda-input-to-string-list "↑⇑⟰⇈⇅↥⇧↟↿↾⇡⇞ ↰↱➦ ⇪⇫⇬⇭⇮⇯ ")) - ("d" . ,(agda-input-to-string-list "↓⇓⟱⇊⇵↧⇩↡⇃⇂⇣⇟ ↵↲↳➥ ↯ ")) + ("l" . ,(agda-input-to-string-list "←⇐⇚⭅⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹ ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲ ")) + ("r" . ,(agda-input-to-string-list "→⇒⇛⭆⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴ ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸")) + ("u" . ,(agda-input-to-string-list "↑⇑⤊⟰⇈⇅↥⇧↟↿↾⇡⇞ ↰↱➦ ⇪⇫⇬⇭⇮⇯ ")) + ("d" . ,(agda-input-to-string-list "↓⇓⤋⟱⇊⇵↧⇩↡⇃⇂⇣⇟ ↵↲↳➥ ↯ ")) ("ud" . ,(agda-input-to-string-list "↕⇕ ↨⇳ ")) ("lr" . ,(agda-input-to-string-list "↔⇔ ⇼↭⇿⟷⟺↮⇎⇹ ")) ("ul" . ,(agda-input-to-string-list "↖⇖ ⇱↸ ")) @@ -536,6 +540,112 @@ ("b8" . ("𝟠")) ("b9" . ("𝟡")) + ;; Mathematical bold letters. + + ("BA" . ("𝐀")) + ("BB" . ("𝐁")) + ("BC" . ("𝐂")) + ("BD" . ("𝐃")) + ("BE" . ("𝐄")) + ("BF" . ("𝐅")) + ("BG" . ("𝐆")) + ("BH" . ("𝐇")) + ("BI" . ("𝐈")) + ("BJ" . ("𝐉")) + ("BK" . ("𝐊")) + ("BL" . ("𝐋")) + ("BM" . ("𝐌")) + ("BN" . ("𝐍")) + ("BO" . ("𝐎")) + ("BP" . ("𝐏")) + ("BQ" . ("𝐐")) + ("BR" . ("𝐑")) + ("BS" . ("𝐒")) + ("BT" . ("𝐓")) + ("BU" . ("𝐔")) + ("BV" . ("𝐕")) + ("BW" . ("𝐖")) + ("BX" . ("𝐗")) + ("BY" . ("𝐘")) + ("BZ" . ("𝐙")) + ("Ba" . ("𝐚")) + ("Bb" . ("𝐛")) + ("Bc" . ("𝐜")) + ("Bd" . ("𝐝")) + ("Be" . ("𝐞")) + ("Bf" . ("𝐟")) + ("Bg" . ("𝐠")) + ("Bh" . ("𝐡")) + ("Bi" . ("𝐢")) + ("Bj" . ("𝐣")) + ("Bk" . ("𝐤")) + ("Bl" . ("𝐥")) + ("Bm" . ("𝐦")) + ("Bn" . ("𝐧")) + ("Bo" . ("𝐨")) + ("Bp" . ("𝐩")) + ("Bq" . ("𝐪")) + ("Br" . ("𝐫")) + ("Bs" . ("𝐬")) + ("Bt" . ("𝐭")) + ("Bu" . ("𝐮")) + ("Bv" . ("𝐯")) + ("Bw" . ("𝐰")) + ("Bx" . ("𝐱")) + ("By" . ("𝐲")) + ("Bz" . ("𝐳")) + + ;; Mathematical bold Greek letters. + + ("BGA" . ("𝚨")) + ("BGB" . ("𝚩")) + ("BGC" . ("𝚾")) + ("BGD" . ("𝚫")) + ("BGE" . ("𝚬")) + ("BGG" . ("𝚪")) + ("BGH" . ("𝚮")) + ("BGI" . ("𝚰")) + ("BGK" . ("𝚱")) + ("BGL" . ("𝚲")) + ("BGM" . ("𝚳")) + ("BGN" . ("𝚴")) + ("BGO" . ("𝛀")) + ("BOmicron" . ("𝚶")) + ("BGF" . ("𝚽")) + ("BPi" . ("𝚷")) + ("BGP" . ("𝚿")) + ("BGR" . ("𝚸")) + ("BGS" . ("𝚺")) + ("BGT" . ("𝚻")) + ("BGTH" . ("𝚯")) + ("BGU" . ("𝚼")) + ("BGX" . ("𝚵")) + ("BGZ" . ("𝚭")) + ("BGa" . ("𝛂")) + ("BGb" . ("𝛃")) + ("BGc" . ("𝛘")) + ("BGd" . ("𝛅")) + ("BGe" . ("𝛆")) + ("BGg" . ("𝛄")) + ("BGh" . ("𝛈")) + ("BGi" . ("𝛊")) + ("BGk" . ("𝛋")) + ("BGl" . ("𝛌")) + ("BGm" . ("𝛍")) + ("BGn" . ("𝛎")) + ("BGo" . ("𝛚")) + ("Bomicron" . ("𝛐")) + ("BGf" . ("𝛗")) + ("Bpi" . ("𝛑")) + ("BGp" . ("𝛙")) + ("BGr" . ("𝛒")) + ("BGs" . ("𝛔")) + ("BGt" . ("𝛕")) + ("BGth" . ("𝛉")) + ("BGu" . ("𝛖")) + ("BGx" . ("𝛏")) + ("BGz" . ("𝛇")) + ;; Mathematical bold digits. ("B0" . ("𝟎")) @@ -549,6 +659,74 @@ ("B8" . ("𝟖")) ("B9" . ("𝟗")) + ;; Fullwidth letters + + ("FA" . ("Ａ")) + ("FB" . ("Ｂ")) + ("FC" . ("Ｃ")) + ("FD" . ("Ｄ")) + ("FE" . ("Ｅ")) + ("FF" . ("Ｆ")) + ("FG" . ("Ｇ")) + ("FH" . ("Ｈ")) + ("FI" . ("Ｉ")) + ("FJ" . ("Ｊ")) + ("FK" . ("Ｋ")) + ("FL" . ("Ｌ")) + ("FM" . ("Ｍ")) + ("FN" . ("Ｎ")) + ("FO" . ("Ｏ")) + ("FP" . ("Ｐ")) + ("FQ" . ("Ｑ")) + ("FR" . ("Ｒ")) + ("FS" . ("Ｓ")) + ("FT" . ("Ｔ")) + ("FU" . ("Ｕ")) + ("FV" . ("Ｖ")) + ("FW" . ("Ｗ")) + ("FX" . ("Ｘ")) + ("FY" . ("Ｙ")) + ("FZ" . ("Ｚ")) + ("Fa" . ("ａ")) + ("Fb" . ("ｂ")) + ("Fc" . ("ｃ")) + ("Fd" . ("ｄ")) + ("Fe" . ("ｅ")) + ("Ff" . ("ｆ")) + ("Fg" . ("ｇ")) + ("Fh" . ("ｈ")) + ("Fi" . ("ｉ")) + ("Fj" . ("ｊ")) + ("Fk" . ("ｋ")) + ("Fl" . ("ｌ")) + ("Fm" . ("ｍ")) + ("Fn" . ("ｎ")) + ("Fo" . ("ｏ")) + ("Fp" . ("ｐ")) + ("Fq" . ("ｑ")) + ("Fr" . ("ｒ")) + ("Fs" . ("ｓ")) + ("Ft" . ("ｔ")) + ("Fu" . ("ｕ")) + ("Fv" . ("ｖ")) + ("Fw" . ("ｗ")) + ("Fx" . ("ｘ")) + ("Fy" . ("ｙ")) + ("Fz" . ("ｚ")) + + ;; Fullwidth digits + + ("F0" . ("０")) + ("F1" . ("１")) + ("F2" . ("２")) + ("F3" . ("３")) + ("F4" . ("４")) + ("F5" . ("５")) + ("F6" . ("６")) + ("F7" . ("７")) + ("F8" . ("８")) + ("F9" . ("９")) + ;; Parentheses. ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢❪❬❰❲❴⟮⦅⦗⧼⸨❮⦇⦉")) @@ -556,8 +734,8 @@ ("[[" . ("⟦")) ("]]" . ("⟧")) - ("<" . ("⟨")) - (">" . ("⟩")) + ("<" . ,(agda-input-to-string-list "⟨<≪⋘≺⊂⋐⊏⊰⊲⋖＜")) + (">" . ,(agda-input-to-string-list "⟩>≫⋙≻⊃⋑⊐⊱⊳⋗＞")) ("<<" . ("⟪")) (">>" . ("⟫")) ("{{" . ("⦃")) @@ -575,13 +753,13 @@ ("(|" . ("⦇")) ;; Idiom brackets ("|)" . ("⦈")) - ("((" . ("⦅")) ;; Banana brackets - ("))" . ("⦆")) + ("((" . ,(agda-input-to-string-list "⦅｟")) ;; Banana brackets + ("))" . ,(agda-input-to-string-list "⦆｠")) ;; Primes. - ("'" . ,(agda-input-to-string-list "′″‴⁗")) - ("`" . ,(agda-input-to-string-list "‵‶‷")) + ("'" . ,(agda-input-to-string-list "′″‴⁗＇")) + ("`" . ,(agda-input-to-string-list "‵‶‷｀")) ;; Fractions. @@ -605,12 +783,14 @@ ("\\" . ("\\")) ("en" . ("–")) ("em" . ("—")) + ("!" . ("！")) ("!!" . ("‼")) + ("?" . ("？")) ("??" . ("⁇")) ("?!" . ("‽" "⁈")) ("!?" . ("⁉")) ("die" . ,(agda-input-to-string-list "⚀⚁⚂⚃⚄⚅")) - ("asterisk" . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋")) + ("asterisk" . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋＊")) ("8<" . ("✂" "✄")) ("tie" . ("⁀")) ("undertie" . ("‿")) @@ -618,6 +798,14 @@ ⍉⍊⍋⍌⍍⍎⍏⍐⍑⍒⍓⍔⍕⍖⍗⍘⍙⍚⍛ ⍜⍝⍞⍟⍠⍡⍢⍣⍤⍥⍦⍧⍨⍩⍪⍫⍬⍭⍮ ⍯⍰⍱⍲⍳⍴⍵⍶⍷⍸⍹⍺⎕")) + ("#" . ("＃")) + ("%" . ("％")) + ("&" . ("＆")) + ("*" . ("＊")) + ("/" . ,(agda-input-to-string-list "／＼")) + ("@" . ("＠")) + ("__" . ("＿")) + ("\"" . ("＂")) ;; Some combining 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.2.2" +(define-package "agda2-mode" "2.6.3" "interactive development for Agda, a dependently typed functional programming language" '((emacs "24.3") (annotation "1.0") (eri "1.0"))) 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.2.2" +(defvar agda2-version "2.6.3" "The version of the Agda mode. Note that the same version of the Agda executable must be used.") @@ -108,10 +108,6 @@ :type 'string :group 'agda2) -(defcustom agda2-toplevel-module "Agda.Interaction.GhciTop" - "The name of the Agda toplevel module." - :type 'string :group 'agda2) - (defcustom agda2-information-window-max-height 0.35 "The maximum height of the information window. @@ -1306,7 +1302,8 @@ (agda2-maybe-normalised agda2-elaborate-give - "Elaborate check the given expression against the hole's type and fill in hole with the elaborated term" + "Elaborate check the given expression against the hole's type and fill in the + hole with the elaborated term" "Cmd_elaborate_give" "expression to elaborate and give") @@ -1324,7 +1321,8 @@ (agda2-maybe-normalised agda2-goal-and-context-and-checked - "Shows the context, the goal and check the given expression's against the hole's type" + "Shows the context, the goal and check the given expression's against + the hole's type" "Cmd_goal_type_context_check" "expression to type") @@ -1976,7 +1974,10 @@ This command assumes that the agda and agda-mode executables for Agda version VERSION are called agda-VERSION and agda-mode-VERSION, and that they are located on the PATH. (If -VERSION is empty, then agda and agda-mode are used instead.)" +VERSION is empty, then agda and agda-mode are used instead.) + +An attempt is made to preserve the default value of +`agda2-mode-hook'." (interactive (list (completing-read "Version: " (agda2-get-agda-program-versions)))) @@ -1988,6 +1989,8 @@ (list buf)))) (buffer-list))) + (default-hook (default-value 'agda2-mode-hook)) + (version-suffix (if (or (equal version "") (equal version nil)) "" @@ -2041,6 +2044,10 @@ (load-file agda-mode-path) (require 'agda2-mode) (setq agda2-program-name (concat "agda" version-suffix)) + + ;; Restore the Agda mode's default hook (if any). + (when default-hook + (set-default 'agda2-mode-hook default-hook)) ;; Restart the Agda mode in all former Agda mode buffers. (mapc (lambda (buf) 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.2.2 Formatting LaTeX generated by Agda] + [2021/07/14 version 2.6.3 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/Bool.agda b/src/data/lib/prim/Agda/Builtin/Bool.agda --- a/src/data/lib/prim/Agda/Builtin/Bool.agda +++ b/src/data/lib/prim/Agda/Builtin/Bool.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --safe --no-universe-polymorphism - --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism + --no-sized-types --no-guardedness #-} module Agda.Builtin.Bool where diff --git a/src/data/lib/prim/Agda/Builtin/Char.agda b/src/data/lib/prim/Agda/Builtin/Char.agda --- a/src/data/lib/prim/Agda/Builtin/Char.agda +++ b/src/data/lib/prim/Agda/Builtin/Char.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --safe --no-universe-polymorphism - --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism + --no-sized-types --no-guardedness #-} module Agda.Builtin.Char where diff --git a/src/data/lib/prim/Agda/Builtin/Char/Properties.agda b/src/data/lib/prim/Agda/Builtin/Char/Properties.agda --- a/src/data/lib/prim/Agda/Builtin/Char/Properties.agda +++ b/src/data/lib/prim/Agda/Builtin/Char/Properties.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Char.Properties where diff --git a/src/data/lib/prim/Agda/Builtin/Coinduction.agda b/src/data/lib/prim/Agda/Builtin/Coinduction.agda --- a/src/data/lib/prim/Agda/Builtin/Coinduction.agda +++ b/src/data/lib/prim/Agda/Builtin/Coinduction.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --safe --universe-polymorphism --no-sized-types - --guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --universe-polymorphism --no-sized-types + --guardedness #-} module Agda.Builtin.Coinduction where diff --git a/src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda b/src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda --- a/src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda +++ b/src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Cubical.Glue where @@ -9,7 +8,7 @@ primHComp to hcomp; primTransp to transp; primComp to comp; itIsOne to 1=1) open import Agda.Builtin.Cubical.Path -open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to ouc) +open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]) import Agda.Builtin.Cubical.HCompU as HCompU module Helpers = HCompU.Helpers @@ -41,8 +40,9 @@ -- case. This makes the computational behavior better, in particular -- for transp in Glue. equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A) - → ∀ ψ → (Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a -equivProof A B w a ψ fb = contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb + → ∀ ψ (f : Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a [ ψ ↦ f ] +equivProof A B w a ψ fb = + inS (contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb) where contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i @@ -97,11 +97,11 @@ sys x i (j = i1) = u (~ i) x ω0 = comp ~E (sys x0) ((β0 (~ j))) ω1 = comp ~E (sys x1) ((β1 (~ j))) - θ0 = fill ~E (sys x0) (inc (β0 (~ j))) - θ1 = fill ~E (sys x1) (inc (β1 (~ j))) + θ0 = fill ~E (sys x0) (inS (β0 (~ j))) + θ1 = fill ~E (sys x1) (inS (β1 (~ j))) sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j} ω = hcomp sys (g y) - θ = hfill sys (inc (g y)) + θ = hfill sys (inS (g y)) δ = λ (j : I) → comp E (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i) ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) }) diff --git a/src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda b/src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda --- a/src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda +++ b/src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Cubical.HCompU where @@ -9,7 +8,7 @@ primHComp to hcomp; primTransp to transp; primComp to comp; itIsOne to 1=1) open import Agda.Builtin.Cubical.Path -open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS; inc to inS) +open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS) module Helpers where -- Homogeneous filling diff --git a/src/data/lib/prim/Agda/Builtin/Cubical/Id.agda b/src/data/lib/prim/Agda/Builtin/Cubical/Id.agda --- a/src/data/lib/prim/Agda/Builtin/Cubical/Id.agda +++ b/src/data/lib/prim/Agda/Builtin/Cubical/Id.agda @@ -1,19 +1,22 @@ -{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Cubical.Id where open import Agda.Primitive.Cubical open import Agda.Builtin.Cubical.Path - open import Agda.Builtin.Cubical.Sub renaming (primSubOut to ouc; Sub to _[_↦_]) - - postulate - Id : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ + open import Agda.Builtin.Cubical.Sub renaming (primSubOut to outS; Sub to _[_↦_]) {-# BUILTIN ID Id #-} - {-# BUILTIN CONID conid #-} + {-# BUILTIN REFLID reflId #-} - -- Id x y is treated as a pair of I and x ≡ y, using "i" for the + private + module ConId where + primitive + primConId : ∀ {ℓ} {A : Set ℓ} {x y : A} → I → x ≡ y → Id x y + + open ConId public renaming (primConId to conid) + + -- Id x y is treated as a pair of I and x ≡ y, using "i" for the -- first component and "p" for the second. {-# COMPILE JS conid = _ => _ => _ => _ => i => p => { return { "i" : i, "p" : p } } @@ -25,14 +28,22 @@ primIdPath : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → x ≡ y primitive - primIdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') → - P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p - - - primitive primIdElim : ∀ {a c} {A : Set a} {x : A} (C : (y : A) → Id x y → Set c) → ((φ : I) (y : A [ φ ↦ (λ _ → x) ]) - (w : (x ≡ ouc y) [ φ ↦ (λ { (φ = i1) → \ _ → x}) ]) → - C (ouc y) (conid φ (ouc w))) → + (w : (x ≡ outS y) [ φ ↦ (λ { (φ = i1) → \ _ → x}) ]) → + C (outS y) (conid φ (outS w))) → {y : A} (p : Id x y) → C y p + + -- IdJ can be defined in terms of pattern matching on the reflId + -- constructor. This equality is definitional; For non-reflId + -- identifications, it computes in terms of primIdElim and primComp. + IdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') → + P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p + IdJ {x = x} P prefl reflId = prefl + + -- Test computational behaviour of IdJ: + _ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') + → (a : P x (conid i1 (λ i → x))) + → IdJ P a (conid i1 (λ i → x)) ≡ a + _ = λ P a i → a diff --git a/src/data/lib/prim/Agda/Builtin/Cubical/Path.agda b/src/data/lib/prim/Agda/Builtin/Cubical/Path.agda --- a/src/data/lib/prim/Agda/Builtin/Cubical/Path.agda +++ b/src/data/lib/prim/Agda/Builtin/Cubical/Path.agda @@ -1,14 +1,9 @@ -{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Cubical.Path where - open import Agda.Primitive.Cubical - - postulate - PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ + open import Agda.Primitive.Cubical using (PathP) public - {-# BUILTIN PATHP PathP #-} infix 4 _≡_ diff --git a/src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda b/src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda --- a/src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda +++ b/src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Cubical.Sub where @@ -8,12 +7,12 @@ {-# BUILTIN SUB Sub #-} postulate - inc : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x) + inS : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x) - {-# BUILTIN SUBIN inc #-} + {-# BUILTIN SUBIN inS #-} - -- Sub A φ u is treated as A. - {-# COMPILE JS inc = _ => _ => _ => x => x #-} + -- Sub A φ u is treated as A. + {-# COMPILE JS inS = _ => _ => _ => x => x #-} primitive primSubOut : ∀ {ℓ} {A : Set ℓ} {φ : I} {u : Partial φ A} → Sub _ φ u → A diff --git a/src/data/lib/prim/Agda/Builtin/Equality.agda b/src/data/lib/prim/Agda/Builtin/Equality.agda --- a/src/data/lib/prim/Agda/Builtin/Equality.agda +++ b/src/data/lib/prim/Agda/Builtin/Equality.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Equality where diff --git a/src/data/lib/prim/Agda/Builtin/Equality/Erase.agda b/src/data/lib/prim/Agda/Builtin/Equality/Erase.agda --- a/src/data/lib/prim/Agda/Builtin/Equality/Erase.agda +++ b/src/data/lib/prim/Agda/Builtin/Equality/Erase.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Equality.Erase where diff --git a/src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda b/src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda --- a/src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda +++ b/src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --rewriting --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --rewriting --no-sized-types --no-guardedness #-} module Agda.Builtin.Equality.Rewrite where diff --git a/src/data/lib/prim/Agda/Builtin/Float.agda b/src/data/lib/prim/Agda/Builtin/Float.agda --- a/src/data/lib/prim/Agda/Builtin/Float.agda +++ b/src/data/lib/prim/Agda/Builtin/Float.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Float where @@ -24,7 +23,7 @@ primFloatIsNegativeZero : Float → Bool primFloatIsSafeInteger : Float → Bool -- Conversions - primFloatToWord64 : Float → Word64 + primFloatToWord64 : Float → Maybe Word64 primNatToFloat : Nat → Float primIntToFloat : Int → Float primFloatRound : Float → Maybe Int diff --git a/src/data/lib/prim/Agda/Builtin/Float/Properties.agda b/src/data/lib/prim/Agda/Builtin/Float/Properties.agda --- a/src/data/lib/prim/Agda/Builtin/Float/Properties.agda +++ b/src/data/lib/prim/Agda/Builtin/Float/Properties.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Float.Properties where diff --git a/src/data/lib/prim/Agda/Builtin/FromNat.agda b/src/data/lib/prim/Agda/Builtin/FromNat.agda --- a/src/data/lib/prim/Agda/Builtin/FromNat.agda +++ b/src/data/lib/prim/Agda/Builtin/FromNat.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.FromNat where diff --git a/src/data/lib/prim/Agda/Builtin/FromNeg.agda b/src/data/lib/prim/Agda/Builtin/FromNeg.agda --- a/src/data/lib/prim/Agda/Builtin/FromNeg.agda +++ b/src/data/lib/prim/Agda/Builtin/FromNeg.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.FromNeg where diff --git a/src/data/lib/prim/Agda/Builtin/FromString.agda b/src/data/lib/prim/Agda/Builtin/FromString.agda --- a/src/data/lib/prim/Agda/Builtin/FromString.agda +++ b/src/data/lib/prim/Agda/Builtin/FromString.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.FromString where diff --git a/src/data/lib/prim/Agda/Builtin/IO.agda b/src/data/lib/prim/Agda/Builtin/IO.agda --- a/src/data/lib/prim/Agda/Builtin/IO.agda +++ b/src/data/lib/prim/Agda/Builtin/IO.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.IO where diff --git a/src/data/lib/prim/Agda/Builtin/Int.agda b/src/data/lib/prim/Agda/Builtin/Int.agda --- a/src/data/lib/prim/Agda/Builtin/Int.agda +++ b/src/data/lib/prim/Agda/Builtin/Int.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Int where diff --git a/src/data/lib/prim/Agda/Builtin/List.agda b/src/data/lib/prim/Agda/Builtin/List.agda --- a/src/data/lib/prim/Agda/Builtin/List.agda +++ b/src/data/lib/prim/Agda/Builtin/List.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.List where diff --git a/src/data/lib/prim/Agda/Builtin/Maybe.agda b/src/data/lib/prim/Agda/Builtin/Maybe.agda --- a/src/data/lib/prim/Agda/Builtin/Maybe.agda +++ b/src/data/lib/prim/Agda/Builtin/Maybe.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Maybe where diff --git a/src/data/lib/prim/Agda/Builtin/Nat.agda b/src/data/lib/prim/Agda/Builtin/Nat.agda --- a/src/data/lib/prim/Agda/Builtin/Nat.agda +++ b/src/data/lib/prim/Agda/Builtin/Nat.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --safe --no-universe-polymorphism - --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism + --no-sized-types --no-guardedness #-} module Agda.Builtin.Nat where 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 @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Reflection where @@ -165,6 +164,7 @@ data Pattern : Set data Clause : Set Type = Term +Telescope = List (Σ String λ _ → Arg Type) data Term where var : (x : Nat) (args : List (Arg Term)) → Term @@ -195,8 +195,8 @@ absurd : (x : Nat) → Pattern -- absurd patterns counts as variables data Clause where - clause : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) (t : Term) → Clause - absurd-clause : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) → Clause + clause : (tel : Telescope) (ps : List (Arg Pattern)) (t : Term) → Clause + absurd-clause : (tel : Telescope) (ps : List (Arg Pattern)) → Clause {-# BUILTIN AGDATERM Term #-} {-# BUILTIN AGDASORT Sort #-} @@ -254,11 +254,13 @@ data ErrorPart : Set where strErr : String → ErrorPart termErr : Term → ErrorPart + pattErr : Pattern → ErrorPart nameErr : Name → ErrorPart {-# BUILTIN AGDAERRORPART ErrorPart #-} {-# BUILTIN AGDAERRORPARTSTRING strErr #-} {-# BUILTIN AGDAERRORPARTTERM termErr #-} +{-# BUILTIN AGDAERRORPARTPATT pattErr #-} {-# BUILTIN AGDAERRORPARTNAME nameErr #-} -- TC monad -- @@ -277,12 +279,14 @@ quoteTC : ∀ {a} {A : Set a} → A → TC Term unquoteTC : ∀ {a} {A : Set a} → Term → TC A quoteωTC : ∀ {A : Setω} → A → TC Term - getContext : TC (List (Arg Type)) - extendContext : ∀ {a} {A : Set a} → Arg Type → TC A → TC A - inContext : ∀ {a} {A : Set a} → List (Arg Type) → TC A → TC A + getContext : TC Telescope + extendContext : ∀ {a} {A : Set a} → String → Arg Type → TC A → TC A + inContext : ∀ {a} {A : Set a} → Telescope → TC A → TC A freshName : String → TC Name declareDef : Arg Name → Type → TC ⊤ declarePostulate : Arg Name → Type → TC ⊤ + declareData : Name → Nat → Type → TC ⊤ + defineData : Name → List (Σ Name (λ _ → Type)) → TC ⊤ defineFun : Name → List Clause → TC ⊤ getType : Name → TC Type getDefinition : Name → TC Definition @@ -298,6 +302,7 @@ -- getDefinition, normalise, reduce, inferType, checkType and getContext withReconstructed : ∀ {a} {A : Set a} → TC A → TC A + formatErrorParts : List ErrorPart → TC String -- Prints the third argument if the corresponding verbosity level is turned -- on (with the -v flag to Agda). debugPrint : String → Nat → List ErrorPart → TC ⊤ @@ -317,6 +322,10 @@ -- new TC state if it is 'true'. runSpeculative : ∀ {a} {A : Set a} → TC (Σ A λ _ → Bool) → TC A + -- Get a list of all possible instance candidates for the given meta + -- variable (it does not have to be an instance meta). + getInstances : Meta → TC (List Term) + {-# BUILTIN AGDATCM TC #-} {-# BUILTIN AGDATCMRETURN returnTC #-} {-# BUILTIN AGDATCMBIND bindTC #-} @@ -336,6 +345,8 @@ {-# BUILTIN AGDATCMFRESHNAME freshName #-} {-# BUILTIN AGDATCMDECLAREDEF declareDef #-} {-# BUILTIN AGDATCMDECLAREPOSTULATE declarePostulate #-} +{-# BUILTIN AGDATCMDECLAREDATA declareData #-} +{-# BUILTIN AGDATCMDEFINEDATA defineData #-} {-# BUILTIN AGDATCMDEFINEFUN defineFun #-} {-# BUILTIN AGDATCMGETTYPE getType #-} {-# BUILTIN AGDATCMGETDEFINITION getDefinition #-} @@ -343,12 +354,14 @@ {-# BUILTIN AGDATCMCOMMIT commitTC #-} {-# BUILTIN AGDATCMISMACRO isMacro #-} {-# BUILTIN AGDATCMWITHNORMALISATION withNormalisation #-} +{-# BUILTIN AGDATCMFORMATERRORPARTS formatErrorParts #-} {-# BUILTIN AGDATCMDEBUGPRINT debugPrint #-} {-# BUILTIN AGDATCMONLYREDUCEDEFS onlyReduceDefs #-} {-# BUILTIN AGDATCMDONTREDUCEDEFS dontReduceDefs #-} {-# BUILTIN AGDATCMWITHRECONSPARAMS withReconstructed #-} {-# BUILTIN AGDATCMNOCONSTRAINTS noConstraints #-} {-# BUILTIN AGDATCMRUNSPECULATIVE runSpeculative #-} +{-# BUILTIN AGDATCMGETINSTANCES getInstances #-} -- All the TC primitives are compiled to functions that return -- undefined, rather than just undefined, in an attempt to make sure @@ -367,11 +380,13 @@ {-# COMPILE JS unquoteTC = _ => _ => _ => undefined #-} {-# COMPILE JS quoteωTC = _ => _ => undefined #-} {-# COMPILE JS getContext = undefined #-} -{-# COMPILE JS extendContext = _ => _ => _ => _ => undefined #-} +{-# COMPILE JS extendContext = _ => _ => _ => _ => _ => undefined #-} {-# COMPILE JS inContext = _ => _ => _ => _ => undefined #-} {-# COMPILE JS freshName = _ => undefined #-} {-# COMPILE JS declareDef = _ => _ => undefined #-} {-# COMPILE JS declarePostulate = _ => _ => undefined #-} +{-# COMPILE JS declareData = _ => _ => _ => undefined #-} +{-# COMPILE JS defineData = _ => _ => undefined #-} {-# COMPILE JS defineFun = _ => _ => undefined #-} {-# COMPILE JS getType = _ => undefined #-} {-# COMPILE JS getDefinition = _ => undefined #-} @@ -385,3 +400,4 @@ {-# COMPILE JS dontReduceDefs = _ => _ => _ => _ => undefined #-} {-# COMPILE JS noConstraints = _ => _ => _ => undefined #-} {-# COMPILE JS runSpeculative = _ => _ => _ => undefined #-} +{-# COMPILE JS getInstances = _ => undefined #-} diff --git a/src/data/lib/prim/Agda/Builtin/Reflection/External.agda b/src/data/lib/prim/Agda/Builtin/Reflection/External.agda --- a/src/data/lib/prim/Agda/Builtin/Reflection/External.agda +++ b/src/data/lib/prim/Agda/Builtin/Reflection/External.agda @@ -1,4 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Reflection.External where diff --git a/src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda b/src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda --- a/src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda +++ b/src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Reflection.Properties where diff --git a/src/data/lib/prim/Agda/Builtin/Sigma.agda b/src/data/lib/prim/Agda/Builtin/Sigma.agda --- a/src/data/lib/prim/Agda/Builtin/Sigma.agda +++ b/src/data/lib/prim/Agda/Builtin/Sigma.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Sigma where diff --git a/src/data/lib/prim/Agda/Builtin/Size.agda b/src/data/lib/prim/Agda/Builtin/Size.agda --- a/src/data/lib/prim/Agda/Builtin/Size.agda +++ b/src/data/lib/prim/Agda/Builtin/Size.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --no-universe-polymorphism --sized-types - --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --no-universe-polymorphism --sized-types + --no-guardedness #-} module Agda.Builtin.Size where diff --git a/src/data/lib/prim/Agda/Builtin/Strict.agda b/src/data/lib/prim/Agda/Builtin/Strict.agda --- a/src/data/lib/prim/Agda/Builtin/Strict.agda +++ b/src/data/lib/prim/Agda/Builtin/Strict.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Strict where diff --git a/src/data/lib/prim/Agda/Builtin/String.agda b/src/data/lib/prim/Agda/Builtin/String.agda --- a/src/data/lib/prim/Agda/Builtin/String.agda +++ b/src/data/lib/prim/Agda/Builtin/String.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.String where diff --git a/src/data/lib/prim/Agda/Builtin/String/Properties.agda b/src/data/lib/prim/Agda/Builtin/String/Properties.agda --- a/src/data/lib/prim/Agda/Builtin/String/Properties.agda +++ b/src/data/lib/prim/Agda/Builtin/String/Properties.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.String.Properties where diff --git a/src/data/lib/prim/Agda/Builtin/TrustMe.agda b/src/data/lib/prim/Agda/Builtin/TrustMe.agda --- a/src/data/lib/prim/Agda/Builtin/TrustMe.agda +++ b/src/data/lib/prim/Agda/Builtin/TrustMe.agda @@ -1,4 +1,4 @@ -{-# OPTIONS --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --no-sized-types --no-guardedness #-} module Agda.Builtin.TrustMe where diff --git a/src/data/lib/prim/Agda/Builtin/Unit.agda b/src/data/lib/prim/Agda/Builtin/Unit.agda --- a/src/data/lib/prim/Agda/Builtin/Unit.agda +++ b/src/data/lib/prim/Agda/Builtin/Unit.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --safe --no-universe-polymorphism - --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism + --no-sized-types --no-guardedness #-} module Agda.Builtin.Unit where diff --git a/src/data/lib/prim/Agda/Builtin/Word.agda b/src/data/lib/prim/Agda/Builtin/Word.agda --- a/src/data/lib/prim/Agda/Builtin/Word.agda +++ b/src/data/lib/prim/Agda/Builtin/Word.agda @@ -1,5 +1,5 @@ -{-# OPTIONS --without-K --safe --no-universe-polymorphism - --no-sized-types --no-guardedness --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism + --no-sized-types --no-guardedness #-} module Agda.Builtin.Word where diff --git a/src/data/lib/prim/Agda/Builtin/Word/Properties.agda b/src/data/lib/prim/Agda/Builtin/Word/Properties.agda --- a/src/data/lib/prim/Agda/Builtin/Word/Properties.agda +++ b/src/data/lib/prim/Agda/Builtin/Word/Properties.agda @@ -1,5 +1,4 @@ -{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness - --no-subtyping #-} +{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-} module Agda.Builtin.Word.Properties where diff --git a/src/data/lib/prim/Agda/Primitive.agda b/src/data/lib/prim/Agda/Primitive.agda --- a/src/data/lib/prim/Agda/Primitive.agda +++ b/src/data/lib/prim/Agda/Primitive.agda @@ -1,6 +1,6 @@ -- The Agda primitives (preloaded). -{-# OPTIONS --without-K --no-subtyping --no-import-sorts #-} +{-# OPTIONS --cubical-compatible --no-import-sorts #-} module Agda.Primitive where diff --git a/src/data/lib/prim/Agda/Primitive/Cubical.agda b/src/data/lib/prim/Agda/Primitive/Cubical.agda --- a/src/data/lib/prim/Agda/Primitive/Cubical.agda +++ b/src/data/lib/prim/Agda/Primitive/Cubical.agda @@ -1,8 +1,9 @@ -{-# OPTIONS --erased-cubical --no-subtyping #-} +{-# OPTIONS --erased-cubical #-} module Agda.Primitive.Cubical where -{-# BUILTIN INTERVAL I #-} -- I : Setω +{-# BUILTIN CUBEINTERVALUNIV IUniv #-} -- IUniv : SSet₁ +{-# BUILTIN INTERVAL I #-} -- I : IUniv {-# BUILTIN IZERO i0 #-} {-# BUILTIN IONE i1 #-} @@ -69,3 +70,9 @@ primitive primTransp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (a : A i0) → A i1 primHComp : ∀ {ℓ} {A : Set ℓ} {φ : I} (u : ∀ i → Partial φ A) (a : A) → A + + +postulate + PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ + +{-# BUILTIN PATHP PathP #-} diff --git a/src/full/Agda/Auto/Auto.hs b/src/full/Agda/Auto/Auto.hs --- a/src/full/Agda/Auto/Auto.hs +++ b/src/full/Agda/Auto/Auto.hs @@ -5,7 +5,7 @@ , AutoProgress(..) ) where -import Prelude hiding (null) +import Prelude hiding ((!!), null) import Control.Monad ( filterM, forM, guard, join, when ) import Control.Monad.Except @@ -54,6 +54,7 @@ import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Lens +import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Null import Agda.Utils.Pretty ( prettyShow ) @@ -196,7 +197,7 @@ let getsols :: [I.Term] -> TCM [(MetaId, A.Expr)] getsols sol = do exprs <- forM (zip (Map.keys tccons) sol) $ \ (mi, e) -> do - mv <- lookupMeta mi + mv <- lookupLocalMetaAuto mi e <- etaContract e expr <- modifyAbstractExpr <$> do withMetaInfo (getMetaInfo mv) $ reify e return (mi, expr) @@ -234,7 +235,7 @@ else do aexprss <- mapM getsols rsols cexprss <- forM aexprss $ mapM $ \(mi, e) -> do - mv <- lookupMeta mi + mv <- lookupLocalMetaAuto mi withMetaInfo (getMetaInfo mv) $ do (mi,) <$> abstractToConcrete_ e let ss = dropWhile (== ' ') . dropWhile (/= ' ') . prettyShow @@ -290,7 +291,7 @@ -- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss cexprss <- forM aexprss $ do mapM $ \ (mi, e) -> do - mv <- lookupMeta mi + mv <- lookupLocalMetaAuto mi withMetaInfo (getMetaInfo mv) $ do e' <- abstractToConcrete_ e return (mi, e') @@ -337,7 +338,7 @@ -- (const retry) -- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi))) Just ii' -> do ae <- give WithoutForce ii' Nothing expr - mv <- lookupMeta mi + mv <- lookupLocalMetaAuto mi let scope = getMetaScope mv ce <- abstractToConcreteScope scope ae let cmnt = if ii' == ii then agsyinfo ticks else "" @@ -381,12 +382,12 @@ case cls' of Left{} -> stopWithMsg "No solution found" Right cls' -> do - cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall exact recursive reachable ell) -> do + 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 + 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 @@ -400,7 +401,7 @@ _ -> stopWithMsg "Metavariable is not at top level of clause RHS" MRefine listmode -> do - mv <- lookupMeta mi + mv <- lookupLocalMetaAuto mi let tt = jMetaType $ mvJudgement mv minfo = getMetaInfo mv targettyp <- withMetaInfo minfo $ do @@ -421,13 +422,14 @@ cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n if C.isInScope cn == C.NotInScope then return Nothing - else do - c <- getConstInfo n - ctyp <- normalise $ defType c - cdfv <- withMetaInfo minfo $ getDefFreeVars n - return $ case matchType cdfv tctx ctyp targettyp of - Nothing -> Nothing - Just score -> Just (prettyShow cn, score) + 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) @@ -437,13 +439,14 @@ modnames = case thisdefinfo of Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames Nothing -> qnames - catMaybes <$> mapM (\(cn, n) -> do - c <- getConstInfo n - ctyp <- normalise $ defType c - cdfv <- withMetaInfo minfo $ getDefFreeVars n - return $ case matchType cdfv tctx ctyp targettyp of - Nothing -> Nothing - Just score -> Just (prettyShow cn, score) + 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 @@ -466,14 +469,14 @@ -- Get the functions and axioms defined in the same module as @def@. autohints :: AutoHintMode -> I.MetaId -> Maybe AN.QName -> TCM [Hint] autohints AHMModule mi (Just def) = do - scope <- clScope . getMetaInfo <$> lookupMeta mi + scope <- clScope . getMetaInfo <$> lookupLocalMetaAuto mi let names = Scope.nsNames $ Scope.everythingInScope scope qnames = map (Scope.anameName . head) $ Map.elems names modnames = filter (\n -> AN.qnameModule n == AN.qnameModule def && n /= def) qnames map (Hint False) <$> do - (`filterM` modnames) $ \ n -> do - c <- getConstInfo n - case theDef c of + (`filterM` modnames) $ \ n -> getConstInfo' n >>= \case + Left{} -> return False + Right c -> case theDef c of Axiom{} -> return True AbstractDefn{} -> return True Function{} -> return True diff --git a/src/full/Agda/Auto/CaseSplit.hs b/src/full/Agda/Auto/CaseSplit.hs --- a/src/full/Agda/Auto/CaseSplit.hs +++ b/src/full/Agda/Auto/CaseSplit.hs @@ -1,12 +1,14 @@ 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 +import Data.Function (on) import Data.IORef import Data.Tuple (swap) import Data.List (elemIndex) @@ -24,7 +26,7 @@ import Agda.Utils.Impossible import Agda.Utils.Monad (or2M) -import Agda.Utils.List (last1) +import Agda.Utils.List ((!!), last1) abspatvarname :: String abspatvarname = "\0absurdPattern" @@ -45,6 +47,7 @@ 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 diff --git a/src/full/Agda/Auto/Convert.hs b/src/full/Agda/Auto/Convert.hs --- a/src/full/Agda/Auto/Convert.hs +++ b/src/full/Agda/Auto/Convert.hs @@ -1,6 +1,8 @@ module Agda.Auto.Convert where +import Prelude hiding ((!!)) + import Control.Monad ( when ) import Control.Monad.Except import Control.Monad.IO.Class ( MonadIO(..) ) @@ -27,7 +29,8 @@ 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.MetaVars + (lookupMeta, withMetaInfo, lookupInteractionPoint) import Agda.TypeChecking.Monad.Context (getContextArgs) import Agda.TypeChecking.Monad.Constraints (getAllConstraints) import Agda.TypeChecking.Substitute (applySubst, renamingR) @@ -47,6 +50,7 @@ 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.Utils.Pretty ( prettyShow ) @@ -162,7 +166,7 @@ when (Map.notMember eqi eqsm) $ do modify $ \s -> s {sEqs = (Map.insert eqi Nothing eqsm, eqi : eqsl)} ) (zip eqs [0..]) - mv <- lift $ lookupMeta mi + mv <- lift $ lookupLocalMetaAuto mi msol <- case MB.mvInstantiation mv of MB.InstV{} -> lift $ withMetaInfo (getMetaInfo mv) $ do @@ -264,9 +268,23 @@ getdfv :: I.MetaId -> A.QName -> MB.TCM Cm.Nat getdfv mainm name = do - mv <- lookupMeta mainm + 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) @@ -288,10 +306,6 @@ return $ Just (tomyIneq ineq, ee, ei) _ -> return Nothing -copatternsNotImplemented :: MB.TCM a -copatternsNotImplemented = MB.typeError $ MB.NotImplemented $ - "The Agda synthesizer (Agsy) does not support copatterns yet" - literalsNotImplemented :: MB.TCM a literalsNotImplemented = MB.typeError $ MB.NotImplemented $ "The Agda synthesizer (Agsy) does not support literals yet" @@ -336,9 +350,9 @@ 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.ProjP{} -> lift copatternsNotImplemented I.LitP{} -> lift literalsNotImplemented I.DefP{} -> lift hitsNotImplemented @@ -581,7 +595,10 @@ I.DotP _ t -> do (t2, _) <- runStateT (convert t) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm}) return (ns, HI hid (CSPatExp t2)) - I.ProjP{} -> copatternsNotImplemented + I.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 @@ -651,18 +668,19 @@ Nothing -> return $ Nothing Just e -> Just <$> convert e let cperm = Perm nv perm - return $ I.Clause + 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.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.clauseEllipsis = Cm.NoEllipsis + , I.clauseWhereModule = Nothing } contains_constructor :: [CSPat O] -> Bool diff --git a/src/full/Agda/Auto/Syntax.hs b/src/full/Agda/Auto/Syntax.hs --- a/src/full/Agda/Auto/Syntax.hs +++ b/src/full/Agda/Auto/Syntax.hs @@ -112,10 +112,8 @@ | PatVar String | PatExp -- ^ Dot pattern. -{- TODO: projection patterns. | PatProj (ConstRef o) -- ^ Projection pattern. --} type ConstRef o = IORef (ConstDef o) diff --git a/src/full/Agda/Auto/Typecheck.hs b/src/full/Agda/Auto/Typecheck.hs --- a/src/full/Agda/Auto/Typecheck.hs +++ b/src/full/Agda/Auto/Typecheck.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE NondecreasingIndentation #-} module Agda.Auto.Typecheck where +import Prelude hiding ((!!)) + import Data.IORef import Agda.Syntax.Common (Hiding (..)) @@ -9,6 +12,8 @@ import Agda.Auto.SearchControl import Agda.Utils.Impossible +import Agda.Utils.List +import Agda.Utils.Maybe -- --------------------------------- @@ -16,20 +21,23 @@ tcExp :: Bool -> Ctx o -> CExp o -> MExp o -> EE (MyPB o) tcExp isdep ctx typ@(TrBr typtrs ityp@(Clos _ itypexp)) trm = mbpcase prioTypeUnknown Nothing (hnn_checkstep ityp) $ \(hntyp, iotastepdone) -> - mmpcase (True, prioTypecheck isdep, Just (RIMainInfo (length ctx) hntyp iotastepdone)) trm $ \trm -> case trm of + 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 - (ityp, sc) <- case elr of - Var v -> -- assuming within scope - return (weak (v + 1) (snd $ ctx !! v), id) + 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 (closify (cdtype cdef), \x -> mpret $ And (Just [Term args]) (noiotastep_term c args) x) + 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 -> readIORef c >>= \cd -> return (cddeffreevars cd) + Const c -> cddeffreevars <$> readIORef c isconstructor <- case elr of @@ -408,6 +416,25 @@ 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, []) 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 @@ -13,9 +13,9 @@ import System.IO.Unsafe -import Agda.Syntax.Concrete.Name (TopLevelModuleName) import Agda.Syntax.Concrete.Pretty () --instance only import Agda.Syntax.Abstract.Name +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.Benchmark (MonadBench(..)) import qualified Agda.Utils.Benchmark as B import Agda.Utils.Null 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 @@ -36,6 +36,7 @@ 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 @@ -83,15 +84,18 @@ -- vanilla Agda behaviour. , preCompile :: opts -> TCM env -- ^ Called after type checking completes, but before compilation starts. - , postCompile :: env -> IsMain -> Map ModuleName mod -> TCM () + , 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 -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod) + , 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 -> ModuleName -> [def] -> TCM mod + , 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. @@ -202,7 +206,7 @@ (backends, opts) <- getOptSimple (stripRTS argv) (agdaFlags ++ backendFlags) (embedFlag lSnd . inputFlag) (bs, opts0) - opts <- checkOpts opts + () <- checkOpts opts return (forgetAll forgetOpts backends, opts) backendInteraction :: AbsolutePath -> [Backend] -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM () @@ -254,7 +258,9 @@ mods <- doCompile -- This inner function is called for both `Agda.Primitive` and the module in question, -- and all (distinct) imported modules. So avoid shadowing "isMain" or "i". - (\ifaceIsMain iface -> Map.singleton (iModuleName iface) <$> compileModule backend env ifaceIsMain iface) + (\ifaceIsMain iface -> + Map.singleton (iTopLevelModuleName iface) <$> + compileModule backend env ifaceIsMain iface) isMain i -- Note that `doCompile` calls `setInterface` for each distinct module in the graph prior to calling into -- `compileModule`. This last one is just to ensure it's reset to _this_ module. @@ -263,19 +269,19 @@ compileModule :: Backend' opts env menv mod def -> env -> IsMain -> Interface -> TCM mod compileModule backend env isMain i = do - mName <- toTopLevelModuleName <$> curMName + mName <- curMName -- The interface file will only exist if performing af full type-check, vs scoping. -- FIXME: Expecting backends to read the timestamp of the output path of the interface -- file for dirtiness checking is very roundabout and heavily couples backend -- implementations to the filesystem as the source of cache state. mifile <- (Just . filePath . intFilePath =<<) <$> findInterfaceFile mName - r <- preModule backend env isMain (iModuleName i) mifile + r <- preModule backend env isMain (iTopLevelModuleName i) mifile case r of Skip m -> return m Recompile menv -> do defs <- map snd . sortDefs <$> curDefs res <- mapM (compileDef' backend env menv isMain <=< instantiateFull) defs - postModule backend env menv isMain (iModuleName i) res + postModule backend env menv isMain (iTopLevelModuleName i) res compileDef' :: Backend' opts env menv mod def -> env -> menv -> IsMain -> Definition -> TCM def compileDef' backend env menv isMain def = diff --git a/src/full/Agda/Compiler/CallCompiler.hs b/src/full/Agda/Compiler/CallCompiler.hs --- a/src/full/Agda/Compiler/CallCompiler.hs +++ b/src/full/Agda/Compiler/CallCompiler.hs @@ -32,13 +32,16 @@ -- ^ The path to the compiler -> [String] -- ^ Command-line arguments. + -> Maybe FilePath + -- ^ The working directory that should be used when the compiler + -- is invoked. The default is the current working directory. -> Maybe TextEncoding -- ^ Use the given text encoding, if any, when reading the output -- from the process (stdout and stderr). -> TCM () -callCompiler doCall cmd args enc = +callCompiler doCall cmd args cwd enc = if doCall then do - merrors <- callCompiler' cmd args enc + merrors <- callCompiler' cmd args cwd enc case merrors of Nothing -> return () Just errors -> typeError (CompilationError errors) @@ -52,16 +55,20 @@ -- ^ The path to the compiler -> [String] -- ^ Command-line arguments. + -> Maybe FilePath + -- ^ The working directory that should be used when the compiler + -- is invoked. The default is the current working directory. -> Maybe TextEncoding -- ^ Use the given text encoding, if any, when reading the output -- from the process (stdout and stderr). -> TCM (Maybe String) -callCompiler' cmd args enc = do +callCompiler' cmd args cwd enc = do reportSLn "compile.cmd" 1 $ "Calling: " ++ unwords (cmd : args) (_, out, err, p) <- liftIO $ createProcess (proc cmd args) { std_err = CreatePipe , std_out = CreatePipe + , cwd = cwd } -- In -v0 mode we throw away any progress information printed to 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 @@ -2,13 +2,16 @@ module Agda.Compiler.Common where -import Data.List as List +import Prelude hiding ((!!)) + +import Data.List (sortBy, isPrefixOf) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap +import qualified Data.HashSet as HSet import Data.Char -import Data.Function +import Data.Function (on) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif @@ -19,16 +22,20 @@ import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Internal as I +import Agda.Syntax.TopLevelModuleName import Agda.Interaction.FindFile ( srcFilePath ) import Agda.Interaction.Options -import Agda.Interaction.Imports ( CheckResult, crInterface, crSource, Source(..) ) +import Agda.Interaction.Imports ( CheckResult, crInterface, crSource, Source(..) ) -import Agda.TypeChecking.Monad +import Agda.TypeChecking.Monad as TCM import Agda.Utils.FileName import Agda.Utils.Lens +import Agda.Utils.List +import Agda.Utils.List1 ( pattern (:|) ) import Agda.Utils.Maybe +import Agda.Utils.Monad ( ifNotM ) import Agda.Utils.Pretty import Agda.Utils.Impossible @@ -48,13 +55,24 @@ doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r doCompile f isMain i = do - -- The Agda.Primitive module is implicitly assumed to be always imported, - -- even though it not necesseraly occurs in iImportedModules. - -- TODO: there should be a better way to get hold of Agda.Primitive? - [agdaPrimInter] <- filter (("Agda.Primitive"==) . prettyShow . iModuleName) - . map miInterface . Map.elems - <$> getVisitedModules - flip evalStateT Set.empty $ mappend <$> doCompile' f NotMain agdaPrimInter <*> doCompile' f isMain i + flip evalStateT Set.empty $ compilePrim $ doCompile' f isMain i + where + -- The Agda.Primitive module is only loaded if the --no-load-primitives flag was not given, + -- thus, only try to compile it if we have visited it. + compilePrim cont = do + agdaPrim <- lift $ do + agdaPrim <- TCM.topLevelModuleName agdaPrim + Map.lookup agdaPrim <$> getVisitedModules + case agdaPrim of + Nothing -> cont + Just prim -> + mappend <$> doCompile' f NotMain (miInterface prim) <*> cont + where + agdaPrim = RawTopLevelModuleName + { rawModuleNameRange = mempty + , rawModuleNameParts = "Agda" :| "Primitive" : [] + } + -- N.B. The Range in TopLevelModuleName is ignored for Ord, so we can set it to mempty. -- This helper function is called for both `Agda.Primitive` and the module in question. -- It's also called for each imported module, recursively. (Avoiding duplicates). @@ -66,7 +84,7 @@ if alreadyDone then return mempty else do imps <- lift $ map miInterface . catMaybes <$> - mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i) + mapM (getVisitedModule . fst) (iImportedModules i) ri <- mconcat <$> mapM (doCompile' f NotMain) imps lift $ setInterface i r <- lift $ f isMain i @@ -78,16 +96,21 @@ opts <- getsTC (stPersistentOptions . stPersistentState) setCommandLineOptions opts mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++ iFilePragmaOptions i) - stImportedModules `setTCLens` Set.fromList (map fst $ iImportedModules i) - stCurrentModule `setTCLens` Just (iModuleName i) + -- One could perhaps make the following command lazy. Note, however, + -- that it doesn't suffice to replace setTCLens' with setTCLens, + -- because the stPreImportedModules field is strict. + stImportedModules `setTCLens'` + HSet.fromList (map fst (iImportedModules i)) + stCurrentModule `setTCLens'` + Just (iModuleName i, iTopLevelModuleName i) curIF :: ReadTCState m => m Interface curIF = do name <- curMName - maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule (toTopLevelModuleName name) + maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule name -curMName :: ReadTCState m => m ModuleName -curMName = fromMaybe __IMPOSSIBLE__ <$> useTC stCurrentModule +curMName :: ReadTCState m => m TopLevelModuleName +curMName = maybe __IMPOSSIBLE__ snd <$> useTC stCurrentModule curDefs :: ReadTCState m => m Definitions curDefs = HMap.filter (not . defNoCompilation) . (^. sigDefinitions) . iSignature <$> curIF @@ -97,7 +120,7 @@ -- The list is sorted to ensure that the order of the generated -- definitions does not depend on things like the number of bits -- in an Int (see Issue 1900). - List.sortBy (compare `on` fst) $ + sortBy (compare `on` fst) $ HMap.toList defs compileDir :: HasOptions m => m FilePath @@ -135,9 +158,9 @@ Just dir -> dir Nothing -> -- The default output directory is the project root. - let tm = toTopLevelModuleName $ iModuleName mainI + let tm = iTopLevelModuleName mainI f = srcFilePath $ srcOrigin checkedSource - in filePath $ C.projectRoot f tm + in filePath $ projectRoot f tm setCommandLineOptions $ opts { optCompileDir = Just compileDir } @@ -163,16 +186,18 @@ stTCWarnings `setTCLens` newWarnings return a -topLevelModuleName :: ReadTCState m => ModuleName -> m ModuleName +topLevelModuleName :: + ReadTCState m => ModuleName -> m TopLevelModuleName topLevelModuleName m = do - -- get the names of the visited modules - visited <- List.map (iModuleName . miInterface) . Map.elems <$> - getVisitedModules + -- Interfaces of visited modules. + visited <- map miInterface . Map.elems <$> getVisitedModules -- find the module with the longest matching prefix to m - let ms = sortBy (compare `on` (length . mnameToList)) $ - List.filter (\ m' -> mnameToList m' `isPrefixOf` mnameToList m) visited - case ms of - (m' : _) -> return m' + let is = sortBy (compare `on` (length . mnameToList . iModuleName)) $ + filter (\i -> mnameToList (iModuleName i) `isPrefixOf` + mnameToList m) + visited + case is of + (i : _) -> return (iTopLevelModuleName i) -- if we did not get anything, it may be because m is a section -- (a module _ ), see e.g. #1866 [] -> curMName 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 @@ -9,7 +9,7 @@ import Data.Char ( isSpace ) import Data.Foldable ( forM_ ) -import Data.List ( dropWhileEnd, findIndex, intercalate, partition ) +import Data.List ( dropWhileEnd, elemIndex, intercalate, partition ) import Data.Set ( Set ) import qualified Data.Set as Set @@ -30,12 +30,13 @@ import Agda.Syntax.Common import Agda.Syntax.Concrete.Name ( isNoName ) import Agda.Syntax.Abstract.Name - ( ModuleName, QName, + ( QName, mnameToList, qnameName, qnameModule, nameId ) import Agda.Syntax.Internal ( Name, Type , nameFixity, unDom, telToList ) import Agda.Syntax.Literal ( Literal(..) ) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName(..)) import Agda.Syntax.Treeless ( ArgUsage(..), filterUsed ) import qualified Agda.Syntax.Treeless as T @@ -58,8 +59,9 @@ import Agda.Utils.IO.Directory import Agda.Utils.IO.UTF8 ( writeFile ) import Agda.Utils.Singleton ( singleton ) +import Agda.Utils.Size (size) -import Agda.Compiler.Common +import Agda.Compiler.Common as CC import Agda.Compiler.ToTreeless import Agda.Compiler.Treeless.EliminateDefaults import Agda.Compiler.Treeless.EliminateLiteralPatterns @@ -154,14 +156,15 @@ "Compilation of code that uses " ++ s ++ " is not supported." case cubical of Nothing -> return () - Just CErased -> return () + Just CErased -> notSupported "--erased-cubical" Just CFull -> notSupported "--cubical" return opts -- | After all modules have been compiled, copy RTE modules and verify compiled modules. -jsPostCompile :: JSOptions -> IsMain -> Map.Map ModuleName Module -> TCM () +jsPostCompile :: + JSOptions -> IsMain -> Map.Map TopLevelModuleName Module -> TCM () jsPostCompile opts _ ms = do -- Copy RTE modules. @@ -193,14 +196,6 @@ reportSLn "compile.js.verify" 20 $ unwords [ "calling:", cmd ] liftIO $ callCommand cmd - -mergeModules :: Map.Map ModuleName Module -> [(GlobalId, Export)] -mergeModules ms - = [ (jsMod n, e) - | (n, Module _ _ es _) <- Map.toList ms - , e <- es - ] - --- Module compilation --- data JSModuleEnv = JSModuleEnv @@ -209,7 +204,9 @@ -- ^ Should this module be compiled? } -jsPreModule :: JSOptions -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module) +jsPreModule :: + JSOptions -> IsMain -> TopLevelModuleName -> Maybe FilePath -> + TCM (Recompile JSModuleEnv Module) jsPreModule _opts _ m mifile = do cubical <- optCubical <$> pragmaOptions let compile = case cubical of @@ -241,10 +238,12 @@ , jsCompile = compile } -jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM Module +jsPostModule :: + JSOptions -> JSModuleEnv -> IsMain -> TopLevelModuleName -> + [Maybe Export] -> TCM Module jsPostModule opts _ isMain _ defs = do - m <- jsMod <$> curMName - is <- map (jsMod . fst) . iImportedModules <$> curIF + m <- jsMod <$> curMName + is <- map (jsMod . fst) . iImportedModules <$> curIF let mod = Module m is (reorder es) callMain writeModule (optJSMinify opts) mod return mod @@ -269,8 +268,9 @@ prefix :: [Char] prefix = "jAgda" -jsMod :: ModuleName -> GlobalId -jsMod m = GlobalId (prefix : map prettyShow (mnameToList m)) +jsMod :: TopLevelModuleName -> GlobalId +jsMod m = + GlobalId (prefix : map T.unpack (List1.toList (moduleNameParts m))) jsFileName :: GlobalId -> String jsFileName (GlobalId ms) = intercalate "." ms ++ ".js" @@ -285,17 +285,17 @@ global' :: QName -> TCM (Exp, JSQName) global' q = do - i <- iModuleName <$> curIF - modNm <- topLevelModuleName (qnameModule q) + i <- iTopLevelModuleName <$> curIF + top <- CC.topLevelModuleName (qnameModule q) let -- Global module prefix qms = mnameToList $ qnameModule q -- File-local module prefix - localms = drop (length $ mnameToList modNm) qms + localms = drop (size top) qms nm = fmap jsMember $ List1.snoc localms $ qnameName q - if modNm == i + if top == i then return (Self, nm) - else return (Global (jsMod modNm), nm) + else return (Global (jsMod top), nm) global :: QName -> TCM (Exp, JSQName) global q = do @@ -494,7 +494,7 @@ , optJSOptimize (fst kit) = do q <- canonicalName q cs <- mapM canonicalName $ defConstructors dt - case findIndex (q ==) cs of + case q `elemIndex` cs of Just i -> return $ MemberIndex i (mkComment l) Nothing -> __IMPOSSIBLE_VERBOSE__ $ unwords [ "Constructor", prettyShow q, "not found in", prettyShow cs ] | otherwise = return l @@ -668,7 +668,7 @@ (LitString x) -> String x (LitChar x) -> Char x (LitQName x) -> litqname x - LitMeta{} -> __IMPOSSIBLE__ + (LitMeta _ m) -> litmeta m litqname :: QName -> Exp litqname q = @@ -695,6 +695,13 @@ litPrec Unrelated = String "unrelated" litPrec (Related l) = Double l +litmeta :: MetaId -> Exp +litmeta (MetaId m h) = + Object $ Map.fromListWith __IMPOSSIBLE__ + [ (MemberId "id", Integer $ fromIntegral m) + , (MemberId "module", Integer $ fromIntegral $ moduleNameHash h) ] + + -------------------------------------------------- -- Writing out an ECMAScript module -------------------------------------------------- @@ -832,10 +839,10 @@ , "primQNameFixity" -- , "primQNameToWord64s" -- missing -- , "primQNameToWord64sInjective" -- missing - -- , "primMetaEquality" -- missing - -- , "primMetaLess" -- missing - -- , "primShowMeta" -- missing - -- , "primMetaToNat" -- missing + , "primMetaEquality" + , "primMetaLess" + , "primShowMeta" + , "primMetaToNat" -- , "primMetaToNatInjective" -- missing , builtinIMin , builtinIMax @@ -853,8 +860,8 @@ , "primDepIMin" , "primIdFace" , "primIdPath" - , "primIdJ" , builtinIdElim + , builtinConId -- , builtinGlue -- missing -- , builtin_glue -- missing -- , builtin_unglue -- missing 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 @@ -54,6 +54,7 @@ import Agda.Syntax.Internal.Names (namesIn) import qualified Agda.Syntax.Treeless as T import Agda.Syntax.Literal +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Primitive (getBuiltinName) @@ -70,6 +71,7 @@ import Agda.Utils.IO.Directory import Agda.Utils.Lens import Agda.Utils.List +import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty (prettyShow, render) @@ -192,7 +194,7 @@ , ghcDefDecls :: [HS.Decl] , ghcDefDefinition :: Definition , ghcDefMainDef :: Maybe MainFunctionDef - , ghcDefImports :: Set ModuleName + , ghcDefImports :: Set TopLevelModuleName } --- Top-level compilation --- @@ -245,7 +247,7 @@ msub <- getBuiltinName builtinSub msubin <- getBuiltinName builtinSubIn mid <- getBuiltinName builtinId - mconid <- getBuiltinName builtinConId + mconid <- getPrimitiveName' builtinConId istcbuiltin <- do builtins <- mapM getBuiltinName @@ -267,6 +269,8 @@ , builtinAgdaTCMFreshName , builtinAgdaTCMDeclareDef , builtinAgdaTCMDeclarePostulate + , builtinAgdaTCMDeclareData + , builtinAgdaTCMDefineData , builtinAgdaTCMDefineFun , builtinAgdaTCMGetType , builtinAgdaTCMGetDefinition @@ -275,12 +279,14 @@ , builtinAgdaTCMIsMacro , builtinAgdaTCMWithNormalisation , builtinAgdaTCMWithReconsParams + , builtinAgdaTCMFormatErrorParts , builtinAgdaTCMDebugPrint , builtinAgdaTCMOnlyReduceDefs , builtinAgdaTCMDontReduceDefs , builtinAgdaTCMNoConstraints , builtinAgdaTCMRunSpeculative , builtinAgdaTCMExec + , builtinAgdaTCMGetInstances ] return $ flip HashSet.member $ @@ -320,7 +326,8 @@ , ghcEnvIsTCBuiltin = istcbuiltin } -ghcPostCompile :: GHCEnv -> IsMain -> Map ModuleName GHCModule -> TCM () +ghcPostCompile :: + GHCEnv -> IsMain -> Map TopLevelModuleName GHCModule -> TCM () ghcPostCompile _cenv _isMain mods = do -- FIXME: @curMName@ and @curIF@ are evil TCM state, but there does not appear to be --------- another way to retrieve the compilation root ("main" module or interaction focused). @@ -336,7 +343,7 @@ ghcPreModule :: GHCEnv -> IsMain -- ^ Are we looking at the main module? - -> ModuleName + -> TopLevelModuleName -> Maybe FilePath -- ^ Path to the @.agdai@ file. -> TCM (Recompile GHCModuleEnv GHCModule) -- ^ Could we confirm the existence of a main function? @@ -356,7 +363,8 @@ ifileDesc = fromMaybe "(memory)" mifile noComp = do - reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . prettyShow . A.mnameToConcrete =<< curMName + reportSLn "compile.ghc" 2 . + (++ " : no compilation is needed.") . prettyShow =<< curMName menv <- ask mainDefs <- ifM curIsMainModule (mainFunctionDefs <$> curIF) @@ -364,7 +372,7 @@ return . Skip $ GHCModule menv mainDefs yesComp = do - m <- prettyShow . A.mnameToConcrete <$> curMName + m <- prettyShow <$> curMName out <- curOutFile reportSLn "compile.ghc" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>" asks Recompile @@ -373,7 +381,7 @@ :: GHCEnv -> GHCModuleEnv -> IsMain -- ^ Are we looking at the main module? - -> ModuleName + -> TopLevelModuleName -> [GHCDefinition] -- ^ Compiled module content. -> TCM GHCModule ghcPostModule _cenv menv _isMain _moduleName ghcDefs = do @@ -421,7 +429,9 @@ -- Compilation ------------------------------------------------------------ -imports :: BuiltinThings PrimFun -> Set ModuleName -> [Definition] -> [HS.ImportDecl] +imports :: + BuiltinThings PrimFun -> Set TopLevelModuleName -> [Definition] -> + [HS.ImportDecl] imports builtinThings usedModules defs = hsImps ++ imps where hsImps :: [HS.ImportDecl] hsImps = [unqualRTE, decl mazRTE] @@ -442,7 +452,7 @@ decl :: HS.ModuleName -> HS.ImportDecl decl m = HS.ImportDecl m True Nothing - mnames :: [ModuleName] + mnames :: [TopLevelModuleName] mnames = Set.elems usedModules uniq :: [HS.ModuleName] -> [HS.ModuleName] @@ -657,13 +667,14 @@ -- Id x y is compiled as a pair of a boolean and whatever -- Path x y is compiled to. - Axiom{} | is ghcEnvId -> do + Datatype{} | is ghcEnvId -> do _ <- sequence_ [primInterval] Just int <- getBuiltinName builtinInterval int <- xhqn TypeK int + -- re #3733: implement reflId retDecls $ [ HS.TypeDecl (unqhname TypeK q) - [HS.UnkindedVar (ihname A i) | i <- [0..3]] + [] -- [HS.UnkindedVar (ihname A i) | i <- [0..3]] (HS.TyApp (HS.FakeType "(,) Bool") (HS.TyFun (HS.TyCon int) mazAnyType)) , HS.FunBind @@ -673,7 +684,7 @@ ] -- conid. - Axiom{} | is ghcEnvConId -> do + Primitive{} | is ghcEnvConId -> do strict <- optGhcStrictData <$> askGhcOpts let var = (if strict then HS.PBangPat else id) . HS.PVar retDecls $ @@ -705,7 +716,7 @@ fb axiomErr Primitive{ primName = s } -> (mempty,) . fb <$> (liftTCM . primBody) s - PrimitiveSort{ primName = s } -> retDecls [] + PrimitiveSort{} -> retDecls [] Function{} -> function pragma $ functionViaTreeless q @@ -787,7 +798,7 @@ def <- getConstInfo q (argTypes0, resType) <- hsTelApproximation $ defType def let pars = case theDef def of - Function{ funProjection = Just Projection{ projIndex = i } } | i > 0 -> i - 1 + Function{ funProjection = Right Projection{ projIndex = i } } | i > 0 -> i - 1 _ -> 0 argTypes = drop pars argTypes0 argTypesS = filterUsed used argTypes @@ -1040,6 +1051,7 @@ (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier g] b]) emptyBinds T.TALit { T.aLit = LitQName q } -> mkAlt (litqnamepat q) + T.TALit { T.aLit = LitMeta _ m } -> mkAlt (litmetapat m) T.TALit { T.aLit = l@LitFloat{}, T.aBody = b } -> do tell YesFloat l <- literal l @@ -1071,6 +1083,10 @@ LitFloat x -> floatExp x "Double" LitQName x -> return $ litqname x LitString s -> return $ litString s + LitMeta _ m -> + return $ HS.FakeExp "(,)" `HS.App` + hsTypedInt (metaId m) `HS.App` + (hsTypedInt (moduleNameHash $ metaModule m)) _ -> return $ l' where l' = HS.Lit $ hslit l @@ -1135,6 +1151,12 @@ where NameId n (ModuleNameHash m) = nameId $ qnameName x +litmetapat :: MetaId -> HS.Pat +litmetapat (MetaId m h) = + HS.PApp (hsName "(,)") + [ HS.PLit (HS.Int $ fromIntegral m) + , HS.PLit (HS.Int $ fromIntegral $ moduleNameHash h) ] + condecl :: QName -> Induction -> HsCompileM HS.ConDecl condecl q _ind = do opts <- askGhcOpts @@ -1270,10 +1292,11 @@ callGHC :: ReaderT GHCModule TCM () callGHC = do - opts <- askGhcOpts - hsmod <- prettyPrint <$> curHsMod - agdaMod <- curAgdaMod - let outputName = lastWithDefault __IMPOSSIBLE__ $ mnameToList agdaMod + opts <- askGhcOpts + agdaOpts <- lift commandLineOptions + hsmod <- prettyPrint <$> curHsMod + agdaMod <- curAgdaMod + let outputName = Text.unpack $ List1.last $ moduleNameParts agdaMod (mdir, fp) <- curOutFileAndDir let ghcopts = optGhcFlags opts @@ -1288,7 +1311,7 @@ let overridableArgs = [ "-O"] ++ - (if isMain then ["-o", mdir prettyShow (nameConcrete outputName)] else []) ++ + (if isMain then ["-o", mdir outputName] else []) ++ [ "-Werror"] otherArgs = [ "-i" ++ mdir] ++ @@ -1307,4 +1330,8 @@ -- those versions of GHC we don't print any progress information -- unless an error is encountered. let doCall = optGhcCallGhc opts - liftTCM $ callCompiler doCall ghcBin args (Just utf8) + cwd = if optGHCiInteraction agdaOpts || + optJSONInteraction agdaOpts + then Just mdir + else Nothing + liftTCM $ callCompiler doCall ghcBin args cwd (Just utf8) diff --git a/src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs b/src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs --- a/src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs +++ b/src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs @@ -8,8 +8,9 @@ , hsTelApproximation, hsTelApproximation' ) where -import Control.Monad (zipWithM) -import Control.Monad.Except +import Control.Monad ( zipWithM ) +import Control.Monad.Except ( ExceptT(ExceptT), runExceptT, mapExceptT, catchError, throwError ) +import Control.Monad.Trans ( lift ) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) import Data.Maybe (fromMaybe) diff --git a/src/full/Agda/Compiler/MAlonzo/Misc.hs b/src/full/Agda/Compiler/MAlonzo/Misc.hs --- a/src/full/Agda/Compiler/MAlonzo/Misc.hs +++ b/src/full/Agda/Compiler/MAlonzo/Misc.hs @@ -23,10 +23,11 @@ import qualified Agda.Utils.Haskell.Syntax as HS -import Agda.Compiler.Common +import Agda.Compiler.Common as CC import Agda.Syntax.Common import Agda.Syntax.Internal +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad @@ -39,7 +40,7 @@ -------------------------------------------------- data HsModuleEnv = HsModuleEnv - { mazModuleName :: ModuleName + { mazModuleName :: TopLevelModuleName -- ^ The name of the Agda module , mazIsMainModule :: Bool -- ^ Whether this is the compilation root and therefore should have the `main` function. @@ -133,7 +134,7 @@ instance ReadGHCModuleEnv m => ReadGHCModuleEnv (StateT s m) newtype HsCompileState = HsCompileState - { mazAccumlatedImports :: Set ModuleName + { mazAccumlatedImports :: Set TopLevelModuleName } deriving (Eq, Semigroup, Monoid) -- | Transformer adding read-only module info and a writable set of imported modules @@ -161,7 +162,7 @@ -- | This is the same value as @curMName@, but does not rely on the TCM's state. -- (@curMName@ and co. should be removed, but the current @Backend@ interface -- is not sufficient yet to allow that) -curAgdaMod :: ReadGHCModuleEnv m => m ModuleName +curAgdaMod :: ReadGHCModuleEnv m => m TopLevelModuleName curAgdaMod = mazModuleName <$> askHsModuleEnv -- | Get the Haskell module name of the currently-focused Agda module @@ -237,14 +238,14 @@ -- the toplevel module containing the given one tlmodOf :: ReadTCState m => ModuleName -> m HS.ModuleName -tlmodOf = fmap mazMod . topLevelModuleName +tlmodOf = fmap mazMod . CC.topLevelModuleName -- qualify HS.Name n by the module of QName q, if necessary; -- accumulates the used module in stImportedModules at the same time. xqual :: QName -> HS.Name -> HsCompileM HS.QName xqual q n = do - m1 <- topLevelModuleName (qnameModule q) + m1 <- CC.topLevelModuleName (qnameModule q) m2 <- curAgdaMod if m1 == m2 then return (HS.UnQual n) @@ -331,7 +332,7 @@ mazMod' :: String -> HS.ModuleName mazMod' s = HS.ModuleName $ mazstr ++ "." ++ s -mazMod :: ModuleName -> HS.ModuleName +mazMod :: TopLevelModuleName -> HS.ModuleName mazMod = mazMod' . prettyShow mazCoerceName :: String diff --git a/src/full/Agda/Compiler/MAlonzo/Primitives.hs b/src/full/Agda/Compiler/MAlonzo/Primitives.hs --- a/src/full/Agda/Compiler/MAlonzo/Primitives.hs +++ b/src/full/Agda/Compiler/MAlonzo/Primitives.hs @@ -26,6 +26,8 @@ import Agda.Utils.Either import Agda.Utils.Lens +import Agda.Utils.List (hasElem) +import Agda.Utils.Maybe import Agda.Utils.Pretty (prettyShow) import qualified Agda.Utils.Haskell.Syntax as HS @@ -42,17 +44,17 @@ -- TODO: Also only consider top-level definition (not buried inside a module). asMainFunctionDef :: Definition -> Maybe MainFunctionDef asMainFunctionDef d = case (theDef d) of - Axiom{} -> perhaps - Function{ funProjection = Nothing } -> perhaps - Function{ funProjection = Just{} } -> no - AbstractDefn{} -> no - GeneralizableVar{} -> no - DataOrRecSig{} -> no - Datatype{} -> no - Record{} -> no - Constructor{} -> no - Primitive{} -> no - PrimitiveSort{} -> no + Axiom{} -> perhaps + Function{ funProjection = Left _ } -> perhaps + Function{ funProjection = Right{} } -> no + AbstractDefn{} -> no + GeneralizableVar{} -> no + DataOrRecSig{} -> no + Datatype{} -> no + Record{} -> no + Constructor{} -> no + Primitive{} -> no + PrimitiveSort{} -> no where isNamedMain = "main" == prettyShow (nameConcrete . qnameName . defName $ d) -- ignores the qualification!? perhaps | isNamedMain = Just $ MainFunctionDef d @@ -156,12 +158,14 @@ xForPrim table builtinThings defs = catMaybes [ Map.lookup s table | (s, def) <- Map.toList builtinThings - , getName def `Set.member` qs + , maybe False elemDefs $ getName def ] where - qs = Set.fromList $ map defName defs - getName (Builtin t) = getPrimName t - getName (Prim (PrimFun q _ _)) = q + elemDefs = hasElem $ map defName defs + getName = \case + Builtin t -> Just $ getPrimName t + Prim (PrimFun q _ _) -> Just q + BuiltinRewriteRelations _ -> Nothing -- | Definition bodies for primitive functions @@ -282,10 +286,13 @@ , "primQNameFixity" |-> return "MAlonzo.RTE.qnameFixity" , "primQNameToWord64s" |-> return "\\ qn -> (MAlonzo.RTE.nameId qn, MAlonzo.RTE.moduleId qn)" , "primQNameToWord64sInjective" |-> return mazErasedName - , "primMetaEquality" |-> rel "(==)" "Integer" - , "primMetaLess" |-> rel "(<)" "Integer" - , "primShowMeta" |-> return "\\ x -> Data.Text.pack (\"_\" ++ show (x :: Integer))" - , "primMetaToNat" |-> return "(id :: Integer -> Integer)" + , "primMetaEquality" |-> rel "(==)" "(Integer, Integer)" + , "primMetaLess" |-> rel "(<)" "(Integer, Integer)" + -- Should be kept in sync with version in `primitiveFunctions` in + -- Agda.TypeChecking.Primitive + , "primShowMeta" |-> return "\\ (m, h) -> Data.Text.pack (\"_\" ++ show (m :: Integer) ++ \"@\" ++ show (h :: Integer))" + -- Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive + , "primMetaToNat" |-> return "\\ (m, h) -> (h :: Integer) * 2^64 + (m :: Integer)" , "primMetaToNatInjective" |-> return mazErasedName -- Seq @@ -313,7 +320,6 @@ , "primDepIMin" |-> return "\\i f -> if i then f () else False" , "primIdFace" |-> return "\\_ _ _ _ -> fst" , "primIdPath" |-> return "\\_ _ _ _ -> snd" - , "primIdJ" |-> return "\\_ _ _ _ _ x _ _ -> x" , builtinIdElim |-> return "\\_ _ _ _ _ f x y -> f (fst y) x (snd y)" ] 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 @@ -4,6 +4,8 @@ , closedTermToTreeless ) where +import Prelude hiding ((!!)) + import Control.Arrow ( first ) import Control.Monad ( filterM, foldM, forM, zipWithM ) import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT ) @@ -22,6 +24,7 @@ import Agda.TypeChecking.CompiledClause as CC import qualified Agda.TypeChecking.CompiledClause.Compile as CC +import Agda.TypeChecking.Datatypes import Agda.TypeChecking.EtaContract (binAppView, BinAppView(..)) import Agda.TypeChecking.Monad as TCM import Agda.TypeChecking.Pretty @@ -57,7 +60,7 @@ getCompiledClauses q = do def <- getConstInfo q let cs = defClauses def - isProj | Function{ funProjection = proj } <- theDef def = isJust (projProper =<< proj) + isProj | Function{ funProjection = Right x } <- theDef def = isJust (projProper x) | otherwise = False translate | isProj = CC.DontRunRecordPatternTranslation | otherwise = CC.RunRecordPatternTranslation @@ -253,6 +256,8 @@ CC.Case (Arg _ n) (CC.Branches True conBrs _ _ Nothing _ _) -> lambdasUpTo n $ do mkRecord =<< traverse casetree (CC.content <$> conBrs) CC.Case (Arg i n) (CC.Branches False conBrs etaBr litBrs catchAll _ lazy) -> lambdasUpTo (n + 1) $ do + -- re #3733 TODO: revise when compiling --cubical + conBrs <- fmap Map.fromList $ filterM (isConstructor . fst) (Map.toList conBrs) -- We can treat eta-matches as regular matches here. let conBrs' = caseMaybe etaBr conBrs $ \ (c, br) -> Map.insertWith (\ new old -> old) (conName c) br conBrs if Map.null conBrs' && Map.null litBrs then do diff --git a/src/full/Agda/Compiler/Treeless/Erase.hs b/src/full/Agda/Compiler/Treeless/Erase.hs --- a/src/full/Agda/Compiler/Treeless/Erase.hs +++ b/src/full/Agda/Compiler/Treeless/Erase.hs @@ -277,7 +277,7 @@ typeWithoutParams q = do def <- getConstInfo q let d = case I.theDef def of - Function{ funProjection = Just Projection{ projIndex = i } } -> i - 1 + Function{ funProjection = Right Projection{ projIndex = i } } -> i - 1 Constructor{ conPars = n } -> n _ -> 0 first (drop d) <$> telListView (defType def) @@ -306,6 +306,7 @@ typeInfo :: QName -> E TypeInfo typeInfo q = ifM (erasureForbidden q) (return NotErasable) $ {-else-} do memoRec (typeMap . key q) Erasable $ do -- assume recursive occurrences are erasable + mId <- lift $ getName' builtinId msizes <- lift $ mapM getBuiltinName [builtinSize, builtinSizeLt] def <- lift $ getConstInfo q @@ -314,6 +315,7 @@ I.Record{ recConHead = c } -> Just [conName c] _ -> Nothing case mcs of + _ | Just q == mId -> return NotErasable _ | Just q `elem` msizes -> return Erasable Just [c] -> do (ts, _) <- lift $ typeWithoutParams c diff --git a/src/full/Agda/Compiler/Treeless/Identity.hs b/src/full/Agda/Compiler/Treeless/Identity.hs --- a/src/full/Agda/Compiler/Treeless/Identity.hs +++ b/src/full/Agda/Compiler/Treeless/Identity.hs @@ -6,13 +6,13 @@ import Control.Applicative ( Alternative((<|>), empty) ) import Data.Semigroup -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List as List import Agda.Syntax.Treeless import Agda.TypeChecking.Monad import Agda.Utils.List +import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Impossible diff --git a/src/full/Agda/Interaction/AgdaTop.hs b/src/full/Agda/Interaction/AgdaTop.hs --- a/src/full/Agda/Interaction/AgdaTop.hs +++ b/src/full/Agda/Interaction/AgdaTop.hs @@ -12,6 +12,7 @@ import System.IO import Agda.Interaction.Base +import Agda.Interaction.ExitCode import Agda.Interaction.Response as R import Agda.Interaction.InteractionTop import Agda.Interaction.Options @@ -52,8 +53,14 @@ r <- maybeAbort runInteraction case r of Done -> return True -- Done. - Error s -> liftIO (putStrLn s) >> return False Command _ -> return False + Error s -> do + exit <- optExitOnError <$> commandLineOptions + if exit + then liftIO (exitAgdaWith CommandError) + else do + liftIO (putStrLn s) + return False lift Bench.print unless done interact' @@ -71,7 +78,6 @@ case dropWhile isSpace r of "" -> readCommand ('-':'-':_) -> readCommand - _ -> case listToMaybe $ reads r of - Just (x, "") -> return $ Command x - Just (_, rem) -> return $ Error $ "not consumed: " ++ rem - _ -> return $ Error $ "cannot read: " ++ r + _ -> case parseIOTCM r of + Right cmd -> return $ Command cmd + Left err -> return $ Error err 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 @@ -24,6 +24,7 @@ import Agda.Syntax.Internal (ProblemId, Blocker) import Agda.Syntax.Position import Agda.Syntax.Scope.Base (ScopeInfo) +import Agda.Syntax.TopLevelModuleName import Agda.Interaction.Options (CommandLineOptions, defaultOptions) @@ -85,6 +86,8 @@ data CurrentFile = CurrentFile { currentFilePath :: AbsolutePath -- ^ The file currently loaded into interaction. + , currentFileModule :: TopLevelModuleName + -- ^ The top-level module name of the currently loaded file. , currentFileArgs :: [String] -- ^ The arguments to Agda used for loading the file. , currentFileStamp :: ClockTime @@ -109,6 +112,15 @@ type Command = Command' IOTCM +-- | IOTCM commands. +-- +-- The commands are obtained by applying the functions to the current +-- top-level module name, if any. Note that the top-level module name +-- is not used by independent commands. For other commands the +-- top-level module name should be known. + +type IOTCM = Maybe TopLevelModuleName -> IOTCM' Range + -- | Command queues. data CommandQueue = CommandQueue @@ -143,6 +155,11 @@ -- show those instead. | Cmd_metas Rewrite + -- | A command that fails if there are any unsolved + -- meta-variables. By default no output is generated if the + -- command is successful. + | Cmd_no_metas + -- | Shows all the top-level names in the given module, along with -- their types. Uses the top-level scope. | Cmd_show_module_contents_toplevel @@ -293,7 +310,6 @@ -- ^ Exit the program. deriving (Show, Read, Functor, Foldable, Traversable) -type IOTCM = IOTCM' Range data IOTCM' range = IOTCM FilePath @@ -319,7 +335,19 @@ --------------------------------------------------------- -- Read instances +-- | An 'IOTCM' parser. +-- +-- If the parse fails, then an error message is returned. +parseIOTCM :: + String -> Either String IOTCM +parseIOTCM s = case listToMaybe $ reads s of + Just (x, "") -> Right $ \top -> case x of + IOTCM f l m i -> IOTCM f l m $ + (fmap . fmap . fmap) (\rf -> mkRangeFile (rangeFilePath rf) top) i + Just (_, rem) -> Left $ "not consumed: " ++ rem + _ -> Left $ "cannot read: " ++ s + -- | The 'Parse' monad. -- 'StateT' state holds the remaining input. @@ -384,6 +412,14 @@ exact "mkAbsolute" fmap mkAbsolute readParse +-- | This instance fills in the 'TopLevelModuleName's using 'Nothing'. +-- Note that these occurrences of 'Nothing' are \"overwritten\" by +-- 'parseIOTCM'. + +instance Read RangeFile where + readsPrec = parseToReadsPrec $ + fmap (flip mkRangeFile Nothing) readParse + instance Read a => Read (Position' a) where readsPrec = parseToReadsPrec $ do exact "Pn" @@ -443,6 +479,7 @@ | PTSInstance b b | PostponedCheckFunDef QName a TCErr | CheckLock b b + | DataSort QName b | UsableAtMod Modality b deriving (Functor) 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 @@ -13,8 +13,8 @@ import Control.Monad.State import Control.Monad.Identity -import qualified Data.IntMap as IntMap import qualified Data.Map as Map +import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.List as List import Data.Maybe @@ -46,9 +46,10 @@ import Agda.Syntax.Parser import Agda.TheTypeChecker +import Agda.TypeChecking.ReconstructParameters import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion -import Agda.TypeChecking.Errors ( getAllWarnings, stringTCErr ) +import Agda.TypeChecking.Errors ( getAllWarnings, stringTCErr, Verbalize(..) ) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.MetaVars.Mention @@ -61,6 +62,7 @@ import Agda.TypeChecking.Records import Agda.TypeChecking.Irrelevance (wakeIrrelevantVars) import Agda.TypeChecking.Pretty ( PrettyTCM, prettyTCM ) +import Agda.TypeChecking.Pretty.Constraint (prettyRangeConstraint) import Agda.TypeChecking.IApplyConfluence import Agda.TypeChecking.Primitive import Agda.TypeChecking.Names @@ -80,6 +82,7 @@ import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty as P @@ -88,12 +91,16 @@ import Agda.Utils.String import Agda.Utils.Impossible +import qualified Agda.Utils.SmallSet as SmallSet +import Agda.TypeChecking.ProjectionLike (reduceProjectionLike) -- | Parses an expression. parseExpr :: Range -> String -> TCM C.Expr parseExpr rng s = do - C.ExprWhere e wh <- runPM $ parsePosString exprWhereParser pos s + (C.ExprWhere e wh, coh) <- + runPM $ parsePosString exprWhereParser pos s + checkCohesionAttributes coh unless (null wh) $ typeError $ GenericError $ "where clauses are not supported in holes" return e @@ -103,7 +110,7 @@ parseExprIn ii rng s = do mId <- lookupInteractionId ii updateMetaVarRange mId rng - mi <- getMetaInfo <$> lookupMeta mId + mi <- getMetaInfo <$> lookupLocalMeta mId e <- parseExpr rng s -- Andreas, 2019-08-19, issue #4007 -- We need to be in the TCEnv of the meta variable @@ -117,7 +124,7 @@ -- Precondition: we are in the context where the given meta was created. giveExpr :: UseForce -> Maybe InteractionId -> MetaId -> Expr -> TCM Term giveExpr force mii mi e = do - mv <- lookupMeta mi + mv <- lookupLocalMeta mi let t = case mvJudgement mv of IsSort{} -> __IMPOSSIBLE__ HasType _ _ t -> t @@ -140,6 +147,7 @@ -- when not in a mutual block. v <- locallyTC eMutualBlock (const Nothing) $ checkExpr e t' + reportSDoc "interaction.give" 40 $ "give: checked expression:" TP.<+> pure (pretty v) case mvInstantiation mv of InstV{} -> unlessM ((Irrelevant ==) <$> asksTC getRelevance) $ do @@ -236,7 +244,11 @@ PatternErr{} -> typeError . GenericDocError =<< do withInteractionId ii $ "Failed to give" TP.<+> prettyTCM e err -> throwError err - nv <- normalForm norm v + mv <- lookupLocalMeta mi + -- Reduce projection-likes before quoting, otherwise instance + -- selection may fail on reload (see #6203). + nv <- reduceProjectionLike =<< normalForm norm v + reportSDoc "interaction.give" 40 $ "nv = " TP.<+> pure (pretty v) locallyTC ePrintMetasBare (const True) $ reify nv -- | Try to refine hole by expression @e@. @@ -251,7 +263,7 @@ -> TCM Expr -- ^ The successfully given expression. refine force ii mr e = do mi <- lookupInteractionId ii - mv <- lookupMeta mi + mv <- lookupLocalMeta mi let range = fromMaybe (getRange mv) mr scope = M.getMetaScope mv reportSDoc "interaction.refine" 10 $ @@ -334,7 +346,7 @@ evalInMeta :: InteractionId -> ComputeMode -> Expr -> TCM Expr evalInMeta ii cmode e = do m <- lookupInteractionId ii - mi <- getMetaInfo <$> lookupMeta m + mi <- getMetaInfo <$> lookupLocalMeta m withMetaInfo mi $ evalInCurrent cmode e @@ -395,6 +407,7 @@ FindInstanceOF _ _ _ -> __IMPOSSIBLE__ PTSInstance i _ -> i PostponedCheckFunDef{} -> __IMPOSSIBLE__ + DataSort _ i -> i CheckLock i _ -> i UsableAtMod _ i -> i @@ -434,7 +447,7 @@ tac <- A.App defaultAppInfo_ (A.Unquote exprNoRange) . defaultNamedArg <$> reify tac OfType tac <$> reify goal reify (UnBlock m) = do - mi <- mvInstantiation <$> lookupMeta m + mi <- lookupMetaInstantiation m m' <- reify (MetaV m []) case mi of BlockedConst t -> do @@ -476,13 +489,18 @@ reify (HasPTSRule a b) = do (a,(x,b)) <- reify (unDom a,b) return $ PTSInstance a b + reify (CheckDataSort q s) = DataSort q <$> reify s reify (CheckLockedVars t _ lk _) = CheckLock <$> reify t <*> reify (unArg lk) reify (CheckMetaInst m) = do - t <- jMetaType . mvJudgement <$> lookupMeta m + t <- jMetaType . mvJudgement <$> lookupLocalMeta m OfType <$> reify (MetaV m []) <*> reify t reify (CheckType t) = JustType <$> reify t - reify (UsableAtModality mod t) = UsableAtMod mod <$> reify t + reify (UsableAtModality _ _ mod t) = UsableAtMod mod <$> reify t +instance (Pretty a, Pretty b) => PrettyTCM (OutputForm a b) where + prettyTCM (OutputForm r pids unblock c) = + prettyRangeConstraint r pids unblock (pretty c) + instance (Pretty a, Pretty b) => Pretty (OutputForm a b) where pretty (OutputForm r pids unblock c) = pretty c @@ -530,8 +548,9 @@ PostponedCheckFunDef q a _err -> vcat [ "Check definition of" <+> pretty q <+> ":" <+> pretty a ] -- , nest 2 "stuck because" pretty err ] -- We don't have Pretty for TCErr + DataSort q s -> "Sort" <+> pretty s <+> "allows data/record definitions" CheckLock t lk -> "Check lock" <+> pretty lk <+> "allows" <+> pretty t - UsableAtMod mod t -> "Is usable at" <+> pretty mod <+> pretty t + UsableAtMod mod t -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> pretty t where bin a op b = sep [a, nest 2 $ op <+> b] pcmp cmp a b = bin (pretty a) (pretty cmp) (pretty b) @@ -571,6 +590,7 @@ FindInstanceOF <$> toConcrete s <*> toConcrete t <*> mapM (\(q,tm,ty) -> (,,) <$> toConcrete q <*> toConcrete tm <*> toConcrete ty) cs toConcrete (PTSInstance a b) = PTSInstance <$> toConcrete a <*> toConcrete b + toConcrete (DataSort a b) = DataSort a <$> toConcrete b toConcrete (CheckLock a b) = CheckLock <$> toConcrete a <*> toConcrete b toConcrete (PostponedCheckFunDef q a err) = PostponedCheckFunDef q <$> toConcrete a <*> pure err toConcrete (UsableAtMod a b) = UsableAtMod a <$> toConcrete b @@ -644,15 +664,20 @@ HasBiggerSort a -> Nothing HasPTSRule a b -> Nothing UnquoteTactic{} -> Nothing + CheckDataSort _ s -> isMetaS s CheckMetaInst{} -> Nothing CheckType t -> isMeta (unEl t) CheckLockedVars t _ _ _ -> isMeta t - UsableAtModality _ t -> isMeta t + UsableAtModality _ ms _ t -> caseMaybe ms (isMeta t) $ \ s -> isMetaS s `mplus` isMeta t isMeta (MetaV m' es_m) | m == m' = Just es_m isMeta _ = Nothing + isMetaS (MetaS m' es_m) + | m == m' = Just es_m + isMetaS _ = Nothing + getConstrs g f = liftTCM $ do cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints) reportSDoc "constr.ment" 20 $ "getConstraintsMentioning" @@ -676,6 +701,16 @@ interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c +-- | Converts an 'InteractionId' to a 'MetaId'. + +interactionIdToMetaId :: ReadTCState m => InteractionId -> m MetaId +interactionIdToMetaId i = do + h <- currentModuleNameHash + return MetaId + { metaId = fromIntegral i + , metaModule = h + } + getConstraints' :: (ProblemConstraint -> TCM ProblemConstraint) -> (ProblemConstraint -> Bool) -> TCM [OutputForm C.Expr C.Expr] getConstraints' g f = liftTCM $ do cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints) @@ -686,9 +721,10 @@ return $ ss ++ cs where toOutputForm (ii, mi, e) = do - mv <- getMetaInfo <$> lookupMeta mi + mv <- getMetaInfo <$> lookupLocalMeta mi withMetaInfo mv $ do - let m = QuestionMark emptyMetaInfo{ metaNumber = Just $ fromIntegral ii } ii + mi <- interactionIdToMetaId ii + let m = QuestionMark emptyMetaInfo{ metaNumber = Just mi } ii abstractToConcrete_ $ OutputForm noRange [] alwaysUnblock $ Assign m e @@ -759,7 +795,7 @@ mapM solution =<< getInteractionIdsAndMetas where solution (i, m) = do - mv <- lookupMeta m + mv <- lookupLocalMeta m withMetaInfo (getMetaInfo mv) $ do args <- getContextArgs scope <- getScope @@ -780,7 +816,7 @@ typeOfMetaMI :: Rewrite -> MetaId -> TCM (OutputConstraint Expr NamedMeta) typeOfMetaMI norm mi = - do mv <- lookupMeta mi + do mv <- lookupLocalMeta mi withMetaInfo (getMetaInfo mv) $ rewriteJudg mv (mvJudgement mv) where @@ -825,13 +861,13 @@ typesOfHiddenMetas :: Rewrite -> TCM [OutputConstraint Expr NamedMeta] typesOfHiddenMetas norm = liftTCM $ do is <- getInteractionMetas - store <- IntMap.filterWithKey (openAndImplicit is . MetaId) <$> getMetaStore - mapM (typeOfMetaMI norm . MetaId) $ IntMap.keys store + store <- MapS.filterWithKey (implicit is) <$> useR stOpenMetaStore + mapM (typeOfMetaMI norm) $ MapS.keys store where - openAndImplicit is x m | isJust (mvTwin m) = False - openAndImplicit is x m = + implicit is x m | isJust (mvTwin m) = False + implicit is x m = case mvInstantiation m of - M.InstV{} -> False + M.InstV{} -> __IMPOSSIBLE__ M.Open -> x `notElem` is M.OpenInstance -> x `notElem` is -- OR: True !? M.BlockedConst{} -> False @@ -928,8 +964,8 @@ -- renameVars = onNames (stringToArgName <.> renameVar . argNameToString) renameVars = onNames renameVar - -- onNames :: Applicative m => (ArgName -> m ArgName) -> Type -> m Type - onNames :: Applicative m => (String -> m String) -> Type -> m Type + -- onNames :: Applicative m => (ArgName -> m ArgName) -> I.Type -> m I.Type + onNames :: Applicative m => (String -> m String) -> I.Type -> m I.Type onNames f (El s v) = El s <$> onNamesTm f v -- onNamesTel :: Applicative f => (ArgName -> f ArgName) -> I.Telescope -> f I.Telescope @@ -978,7 +1014,7 @@ contextOfMeta :: InteractionId -> Rewrite -> TCM [ResponseContextEntry] contextOfMeta ii norm = withInteractionId ii $ do - info <- getMetaInfo <$> (lookupMeta =<< lookupInteractionId ii) + info <- getMetaInfo <$> (lookupLocalMeta =<< lookupInteractionId ii) withMetaInfo info $ do -- List of local variables. cxt <- getContext @@ -990,7 +1026,7 @@ <*> forMaybeM letVars mkLet where - mkVar :: Dom (Name, Type) -> TCM (Maybe ResponseContextEntry) + mkVar :: ContextEntry -> TCM (Maybe ResponseContextEntry) mkVar Dom{ domInfo = ai, unDom = (name, t) } = do if shouldHide ai name then return Nothing else Just <$> do let n = nameConcrete name @@ -999,7 +1035,7 @@ ty <- reifyUnblocked =<< normalForm norm t return $ ResponseContextEntry n x (Arg ai ty) Nothing s - mkLet :: (Name, Open (Term, Dom Type)) -> TCM (Maybe ResponseContextEntry) + mkLet :: (Name, Open (Term, Dom I.Type)) -> TCM (Maybe ResponseContextEntry) mkLet (name, lb) = do (tm, !dom) <- getOpen lb if shouldHide (domInfo dom) name then return Nothing else Just <$> do @@ -1027,7 +1063,7 @@ typeInMeta :: InteractionId -> Rewrite -> Expr -> TCM Expr typeInMeta ii norm e = do m <- lookupInteractionId ii - mi <- getMetaInfo <$> lookupMeta m + mi <- getMetaInfo <$> lookupLocalMeta m withMetaInfo mi $ typeInCurrent norm e @@ -1040,7 +1076,7 @@ introTactic :: Bool -> InteractionId -> TCM [String] introTactic pmLambda ii = do mi <- lookupInteractionId ii - mv <- lookupMeta mi + mv <- lookupLocalMeta mi withMetaInfo (getMetaInfo mv) $ case mvJudgement mv of HasType _ _ t -> do t <- reduce =<< piApplyM t =<< getContextArgs @@ -1139,8 +1175,8 @@ atTopLevel :: TCM a -> TCM a atTopLevel m = inConcreteMode $ do let err = typeError $ GenericError "The file has not been loaded yet." - caseMaybeM (useTC stCurrentModule) err $ \ current -> do - caseMaybeM (getVisitedModule $ toTopLevelModuleName current) __IMPOSSIBLE__ $ \ mi -> do + caseMaybeM (useTC stCurrentModule) err $ \(current, topCurrent) -> do + caseMaybeM (getVisitedModule topCurrent) __IMPOSSIBLE__ $ \ mi -> do let scope = iInsideScope $ miInterface mi tel <- lookupSection current -- Get the names of the local variables from @scope@ @@ -1212,7 +1248,7 @@ -- ^ The range of the next argument. -> String -- ^ The module name. - -> TCM ([C.Name], I.Telescope, [(C.Name, Type)]) + -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)]) -- ^ Module names, -- context extension needed to print types, -- names paired up with corresponding types. @@ -1235,7 +1271,7 @@ getRecordContents :: Rewrite -- ^ Amount of normalization in types. -> C.Expr -- ^ Expression presumably of record type. - -> TCM ([C.Name], I.Telescope, [(C.Name, Type)]) + -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)]) -- ^ Module names, -- context extension, -- names paired up with corresponding types. @@ -1269,7 +1305,7 @@ -- ^ Amount of normalization in types. -> Maybe C.QName -- ^ Module name, @Nothing@ if top-level module. - -> TCM ([C.Name], I.Telescope, [(C.Name, Type)]) + -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)]) -- ^ Module names, -- context extension, -- names paired up with corresponding types. @@ -1282,17 +1318,22 @@ names :: ThingsInScope AbstractName names = exportedNamesInScope modScope xns = [ (x,n) | (x, ns) <- Map.toList names, n <- ns ] - types <- forM xns $ \(x, n) -> do - d <- getConstInfo $ anameName n - t <- normalForm norm =<< (defType <$> instantiateDef d) - return (x, t) + types <- forMaybeM xns $ \(x, n) -> do + getConstInfo' (anameName n) >>= \case + Right d -> do + t <- normalForm norm =<< (defType <$> instantiateDef d) + return $ Just (x, t) + Left{} -> return Nothing return (Map.keys modules, EmptyTel, types) -whyInScope :: String -> TCM (Maybe LocalVar, [AbstractName], [AbstractModule]) -whyInScope s = do +whyInScope :: FilePath -> String -> TCM WhyInScopeData +whyInScope cwd s = do x <- parseName noRange s scope <- getScope - return ( lookup x $ map (first C.QName) $ scope ^. scopeLocals - , scopeLookup x scope - , scopeLookup x scope ) + return $ WhyInScopeData + x + cwd + (lookup x $ map (first C.QName) $ scope ^. scopeLocals) + (scopeLookup x scope) + (scopeLookup x scope) diff --git a/src/full/Agda/Interaction/CommandLine.hs b/src/full/Agda/Interaction/CommandLine.hs --- a/src/full/Agda/Interaction/CommandLine.hs +++ b/src/full/Agda/Interaction/CommandLine.hs @@ -233,11 +233,12 @@ metaParseExpr :: InteractionId -> String -> TCM A.Expr metaParseExpr ii s = do m <- lookupInteractionId ii - scope <- getMetaScope <$> lookupMeta m - r <- getRange <$> lookupMeta m + scope <- getMetaScope <$> lookupLocalMeta m + r <- getRange <$> lookupLocalMeta m -- liftIO $ putStrLn $ prettyShow scope let pos = fromMaybe __IMPOSSIBLE__ (rStart r) - e <- runPM $ parsePosString exprParser pos s + (e, coh) <- runPM $ parsePosString exprParser pos s + checkCohesionAttributes coh concreteToAbstract scope e actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a @@ -277,7 +278,8 @@ parseExpr :: String -> TCM A.Expr parseExpr s = do - e <- runPM $ parse exprParser s + (e, coh) <- runPM $ parse exprParser s + checkCohesionAttributes coh localToAbstract e return evalTerm :: String -> TCM (ExitCode a) @@ -306,7 +308,7 @@ showContext :: [String] -> TCM () showContext (meta:args) = do i <- InteractionId <$> readM meta - mi <- lookupMeta =<< lookupInteractionId i + mi <- lookupLocalMeta =<< lookupInteractionId i withMetaInfo (getMetaInfo mi) $ do ctx <- List.map I.unDom . telToList <$> getContextTelescope zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx 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 @@ -21,7 +21,7 @@ import Agda.Syntax.Abstract as A import Agda.Syntax.Concrete as C -import Agda.TypeChecking.Errors (prettyError, getAllWarningsOfTCErr) +import Agda.TypeChecking.Errors ( explainWhyInScope, getAllWarningsOfTCErr, prettyError ) import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Pretty (prettyTCM) import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings, prettyTCWarnings') @@ -124,7 +124,9 @@ -- abusing the goals field since we ignore the title (body, _) = formatWarningsAndErrors msg warnings errors format body "*Compilation result*" - Info_Constraints s -> format (show $ vcat $ map pretty s) "*Constraints*" + Info_Constraints s -> do + doc <- TCP.vcat $ map prettyTCM s + format (render doc) "*Constraints*" Info_AllGoalsWarnings ms ws -> do goals <- showGoals ms warnings <- prettyTCWarnings (tcWarnings ws) @@ -179,8 +181,8 @@ let doc = "Definitions about" <+> text (List.intercalate ", " $ words names) $$ nest 2 (align 10 hitDocs) format (render doc) "*Search About*" - Info_WhyInScope s cwd v xs ms -> do - doc <- explainWhyInScope s cwd v xs ms + Info_WhyInScope why -> do + doc <- explainWhyInScope why format (render doc) "*Scope Info*" Info_Context ii ctx -> do doc <- localTCState (prettyResponseContext ii False ctx) @@ -227,18 +229,19 @@ | otherwise = [ text $ delimiter "Boundary" , vcat $ map pretty bndry ] - let constraintsDoc = if (null constraints) - then [] - else [ text $ delimiter "Constraints" - , vcat $ map pretty constraints - ] - let doc = vcat $ - [ "Goal:" <+> goalDoc - , auxDoc - , vcat boundaryDoc - , text (replicate 60 '\x2014') - , ctxDoc - ] ++ constraintsDoc + let constraintsDoc + | null constraints = [] + | otherwise = + [ TCP.text $ delimiter "Constraints" + , TCP.vcat $ map prettyTCM constraints + ] + doc <- TCP.vcat $ + [ "Goal:" TCP.<+> return goalDoc + , return auxDoc + , return (vcat boundaryDoc) + , TCP.text (replicate 60 '\x2014') + , return ctxDoc + ] ++ constraintsDoc format (render doc) "*Goal type etc.*" Goal_CurrentGoal norm -> do doc <- prettyTypeOfMeta norm ii @@ -314,87 +317,6 @@ return $ "Highlighting failed to parse expression in " ++ show ii showInfoError (Info_HighlightingScopeCheckError ii) = return $ "Highlighting failed to scope check expression in " ++ show ii - -explainWhyInScope :: FilePath - -> String - -> (Maybe LocalVar) - -> [AbstractName] - -> [AbstractModule] - -> TCM Doc -explainWhyInScope s _ Nothing [] [] = TCP.text (s ++ " is not in scope.") -explainWhyInScope s _ v xs ms = TCP.vcat - [ TCP.text (s ++ " is in scope as") - , TCP.nest 2 $ TCP.vcat [variable v xs, modules ms] - ] - where - -- variable :: Maybe _ -> [_] -> TCM Doc - variable Nothing vs = names vs - variable (Just x) vs - | null vs = asVar - | otherwise = TCP.vcat - [ TCP.sep [ asVar, TCP.nest 2 $ shadowing x] - , TCP.nest 2 $ names vs - ] - where - asVar :: TCM Doc - asVar = do - "* a variable bound at" TCP.<+> TCP.prettyTCM (nameBindingSite $ localVar x) - shadowing :: LocalVar -> TCM Doc - shadowing (LocalVar _ _ []) = "shadowing" - shadowing _ = "in conflict with" - names = TCP.vcat . map pName - modules = TCP.vcat . map pMod - - pKind = \case - ConName -> "constructor" - CoConName -> "coinductive constructor" - FldName -> "record field" - PatternSynName -> "pattern synonym" - GeneralizeName -> "generalizable variable" - DisallowedGeneralizeName -> "generalizable variable from let open" - MacroName -> "macro name" - QuotableName -> "quotable name" - -- previously DefName: - DataName -> "data type" - RecName -> "record type" - AxiomName -> "postulate" - PrimName -> "primitive function" - FunName -> "defined name" - OtherDefName -> "defined name" - - pName :: AbstractName -> TCM Doc - pName a = TCP.sep - [ "* a" - TCP.<+> pKind (anameKind a) - TCP.<+> TCP.text (prettyShow $ anameName a) - , TCP.nest 2 $ "brought into scope by" - ] TCP.$$ - TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a)) - pMod :: AbstractModule -> TCM Doc - pMod a = TCP.sep - [ "* a module" TCP.<+> TCP.text (prettyShow $ amodName a) - , TCP.nest 2 $ "brought into scope by" - ] TCP.$$ - TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a)) - - pWhy :: Range -> WhyInScope -> TCM Doc - pWhy r Defined = "- its definition at" TCP.<+> TCP.prettyTCM r - pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w - pWhy r (Opened m w) = - "- the opening of" - TCP.<+> TCP.prettyTCM m - TCP.<+> "at" - TCP.<+> TCP.prettyTCM (getRange m) - TCP.$$ - pWhy r w - pWhy r (Applied m w) = - "- the application of" - TCP.<+> TCP.prettyTCM m - TCP.<+> "at" - TCP.<+> TCP.prettyTCM (getRange m) - TCP.$$ - pWhy r w - -- | Pretty-prints the context of the given meta-variable. diff --git a/src/full/Agda/Interaction/ExitCode.hs b/src/full/Agda/Interaction/ExitCode.hs --- a/src/full/Agda/Interaction/ExitCode.hs +++ b/src/full/Agda/Interaction/ExitCode.hs @@ -12,6 +12,7 @@ data AgdaError = UnknownError -- ^ 1 | TCMError -- ^ 42 | OptionError -- ^ 71 + | CommandError -- ^ 113 | ImpossibleError -- ^ 154 deriving (Show, Eq, Enum, Bounded) @@ -19,6 +20,7 @@ agdaErrorToInt UnknownError = 1 agdaErrorToInt TCMError = 42 agdaErrorToInt OptionError = 71 +agdaErrorToInt CommandError = 113 agdaErrorToInt ImpossibleError = 154 -- ^ Return the error corresponding to an exit code from the @@ -30,5 +32,5 @@ | error <- [minBound..maxBound] ] -exitAgdaWith :: AgdaError -> IO () +exitAgdaWith :: AgdaError -> IO a exitAgdaWith = exitWith . ExitFailure . agdaErrorToInt 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 @@ -25,6 +25,7 @@ import Control.Monad.Trans import Data.Maybe (catMaybes) import qualified Data.Map as Map +import qualified Data.Text as T import System.FilePath import Agda.Interaction.Library ( findProjectRoot ) @@ -33,6 +34,7 @@ import Agda.Syntax.Parser import Agda.Syntax.Parser.Literate (literateExtsShortList) import Agda.Syntax.Position +import Agda.Syntax.TopLevelModuleName import Agda.Interaction.Options ( optLocalInterfaces ) @@ -41,6 +43,7 @@ import qualified Agda.TypeChecking.Monad.Benchmark as Bench import {-# SOURCE #-} Agda.TypeChecking.Monad.Options (getIncludeDirs, libToTCM) +import Agda.TypeChecking.Monad.State (topLevelModuleName) import Agda.TypeChecking.Warnings (runPM) import Agda.Version ( version ) @@ -248,10 +251,12 @@ -> Module -- ^ The parsed module. -> TCM TopLevelModuleName -moduleName file parsedModule = billTo [Bench.ModuleName] $ - case moduleNameParts name of - "_" :| [] -> do - m <- runPM (parse moduleNameParser defaultName) +moduleName file parsedModule = billTo [Bench.ModuleName] $ do + let defaultName = rootNameModule file + raw = rawTopLevelModuleNameForModule parsedModule + topLevelModuleName =<< if isNoName raw + then do + m <- runPM (fst <$> parse moduleNameParser defaultName) `catchError` \_ -> typeError $ GenericError $ "The file name " ++ prettyShow file ++ @@ -262,11 +267,11 @@ "The file name " ++ prettyShow file ++ " is invalid because " ++ defaultName ++ " is not an unqualified module name." QName {} -> - return $ TopLevelModuleName (getRange m) $ singleton defaultName - _ -> return name - where - name = topLevelModuleName parsedModule - defaultName = rootNameModule file + return $ RawTopLevelModuleName + { rawModuleNameRange = getRange m + , rawModuleNameParts = singleton (T.pack defaultName) + } + else return raw parseFileExtsShortList :: [String] parseFileExtsShortList = ".agda" : literateExtsShortList 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 @@ -3,11 +3,7 @@ ( dotBackend ) where -import Agda.Interaction.Highlighting.Dot.Base - ( dottify - , renderDotToFile - , Env(Env, deConnections, deLabel) - ) +import Agda.Interaction.Highlighting.Dot.Base (renderDotToFile) import Control.Monad.Except ( ExceptT @@ -19,8 +15,10 @@ ) import Control.DeepSeq -import Data.Map ( Map ) -import Data.Set ( Set ) +import Data.HashSet (HashSet) +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.HashSet as HashSet import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe @@ -31,27 +29,38 @@ import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..)) import Agda.Compiler.Common (curIF, IsMain) +import Agda.Interaction.FindFile (findFile, srcFilePath) +import Agda.Interaction.Library import Agda.Interaction.Options ( ArgDescr(ReqArg) , Flag , OptDescr(..) ) -import Agda.Syntax.Abstract ( ModuleName ) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.TypeChecking.Monad ( Interface(iImportedModules, iModuleName) , MonadTCError , ReadTCState + , MonadTCM(..) , genericError + , reportSDoc + , getAgdaLibFiles ) +import Agda.TypeChecking.Pretty +import Agda.Utils.Graph.AdjacencyMap.Unidirectional + (Graph, WithUniqueInt) +import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph import Agda.Utils.Pretty ( prettyShow ) -- ------------------------------------------------------------------------ data DotFlags = DotFlags { dotFlagDestination :: Maybe FilePath + , dotFlagLibraries :: Maybe (HashSet String) + -- ^ Only include modules from the given libraries. } deriving (Eq, Generic) instance NFData DotFlags @@ -59,27 +68,43 @@ defaultDotFlags :: DotFlags defaultDotFlags = DotFlags { dotFlagDestination = Nothing + , dotFlagLibraries = Nothing } dotFlagsDescriptions :: [OptDescr (Flag DotFlags)] dotFlagsDescriptions = [ Option [] ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE") "generate a Dot file with a module dependency graph" + , Option [] ["dependency-graph-include"] + (ReqArg includeFlag "LIBRARY") + "include modules from the given library (default: all modules)" ] dependencyGraphFlag :: FilePath -> Flag DotFlags dependencyGraphFlag f o = return $ o { dotFlagDestination = Just f } +includeFlag :: String -> Flag DotFlags +includeFlag l o = return $ + o { dotFlagLibraries = + case dotFlagLibraries o of + Nothing -> Just (HashSet.singleton l) + Just s -> Just (HashSet.insert l s) + } + data DotCompileEnv = DotCompileEnv - { _dotCompileEnvDestination :: FilePath + { dotCompileEnvDestination :: FilePath + , dotCompileEnvLibraries :: Maybe (HashSet String) + -- ^ Only include modules from the given libraries. } -- Currently unused data DotModuleEnv = DotModuleEnv data DotModule = DotModule - { _dotModuleName :: ModuleName - , dotModuleImportedNames :: Set ModuleName + { dotModuleName :: TopLevelModuleName + , dotModuleImportedNames :: Set TopLevelModuleName + , dotModuleInclude :: Bool + -- ^ Include the module in the graph? } -- | Currently unused @@ -112,14 +137,19 @@ :: MonadError String m => DotFlags -> m DotCompileEnv -preCompileDot (DotFlags (Just dest)) = return $ DotCompileEnv dest -preCompileDot (DotFlags Nothing) = throwError "The Dot backend was invoked without being enabled!" +preCompileDot d = case dotFlagDestination d of + Just dest -> return $ DotCompileEnv + { dotCompileEnvDestination = dest + , dotCompileEnvLibraries = dotFlagLibraries d + } + Nothing -> + throwError "The Dot backend was invoked without being enabled!" preModuleDot :: Applicative m => DotCompileEnv -> IsMain - -> ModuleName + -> TopLevelModuleName -> Maybe FilePath -> m (Recompile DotModuleEnv DotModule) preModuleDot _cenv _main _moduleName _ifacePath = pure $ Recompile DotModuleEnv @@ -134,28 +164,83 @@ compileDefDot _cenv _menv _main _def = pure DotDef postModuleDot - :: (MonadIO m, ReadTCState m) + :: (MonadTCM m, ReadTCState m) => DotCompileEnv -> DotModuleEnv -> IsMain - -> ModuleName + -> TopLevelModuleName -> [DotDef] -> m DotModule -postModuleDot _cenv DotModuleEnv _main moduleName _defs = do +postModuleDot cenv DotModuleEnv _main m _defs = do i <- curIF let importedModuleNames = Set.fromList $ fst <$> (iImportedModules i) - return $ DotModule moduleName importedModuleNames + include <- case dotCompileEnvLibraries cenv of + Nothing -> return True + Just ls -> liftTCM $ do + f <- findFile m + libs <- getAgdaLibFiles (srcFilePath f) m + let incLibs = filter (\l -> _libName l `HashSet.member` ls) libs + inLib = not (null incLibs) + + reportSDoc "dot.include" 10 $ do + let name = pretty m + list = nest 2 . vcat . map (text . _libName) + if inLib then + fsep + ([ "Including" + , name + ] ++ + pwords "because it is in the following libraries:") $$ + list incLibs + else + fsep + (pwords "Not including" ++ + [name <> ","] ++ + pwords "which is in the following libraries:") $$ + list libs + + return inLib + + return $ DotModule + { dotModuleName = m + , dotModuleImportedNames = importedModuleNames + , dotModuleInclude = include + } + postCompileDot :: (MonadIO m, ReadTCState m) => DotCompileEnv -> IsMain - -> Map ModuleName DotModule + -> Map TopLevelModuleName DotModule -> m () -postCompileDot (DotCompileEnv fp) _main modulesByName = do - let env = Env - { deConnections = (maybe [] (Set.toList . dotModuleImportedNames) . (flip Map.lookup modulesByName)) - , deLabel = L.pack . prettyShow - } - dot <- dottify env . iModuleName <$> curIF - renderDotToFile dot fp +postCompileDot cenv _main modulesByName = + renderDotToFile moduleGraph (dotCompileEnvDestination cenv) + where + -- Only the keys of this map are used. + modulesToInclude = + Map.filter dotModuleInclude modulesByName + + moduleGraph :: Graph (WithUniqueInt L.Text) () + moduleGraph = + Graph.renameNodesMonotonic (fmap (L.pack . prettyShow)) $ + Graph.transitiveReduction $ + Graph.filterNodesKeepingEdges + (\n -> Graph.otherValue n `Map.member` modulesToInclude) $ + -- The following use of transitive reduction should not affect the + -- semantics. It tends to make the graph smaller, so it might + -- improve the overall performance of the code, but I did not + -- verify this. + Graph.transitiveReduction $ + Graph.addUniqueInts $ + Graph.fromEdges $ + concatMap + (\ (name, m) -> + [ Graph.Edge + { source = name + , target = target + , label = () + } + | target <- Set.toList $ dotModuleImportedNames m + ]) $ + Map.toList modulesByName 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 @@ -2,129 +2,45 @@ -- | Generate an import dependency graph for a given module. module Agda.Interaction.Highlighting.Dot.Base - ( dottify - , renderDotToFile + ( renderDotToFile , renderDot - , DotGraph (..) - , Env(..) + , DotGraph ) where -import Control.Monad (liftM2, when) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Reader (ReaderT, runReaderT, ask) -import Control.Monad.State (State, execState, get, modify, put) - -import qualified Data.Map as M -import Data.Map(Map) +import Control.Monad.IO.Class +import qualified Data.Map.Strict as M import qualified Data.Set as S -import Data.Set (Set) import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Encoding as E import qualified Data.ByteString.Lazy as BS --- | Internal module identifiers for construction of dependency graph. -type NodeId = L.Text +import Agda.Utils.Graph.AdjacencyMap.Unidirectional + (Graph, WithUniqueInt) +import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph -- | Graph structure -data DotGraph = DotGraph - { dgNodeLabels :: Map NodeId L.Text - , dgEdges :: Set (NodeId, NodeId) - } - --- * Graph construction monad - --- Read-only environment when constructing the graph. -data Env n where - Env :: Ord n => - { deConnections :: n -> [n] - -- ^ Names connected to an entity - , deLabel :: n -> L.Text - -- ^ Rendering that entity's name to a label - } -> Env n - -data DotState n = DotState - { dsNodeIds :: Map n NodeId - -- ^ Records already processed entities - -- and maps them to an internal identifier. - , dsNodeIdSupply :: [NodeId] - -- ^ Supply of internal identifiers. - , dsGraph :: DotGraph - } - -initialDotState :: DotState n -initialDotState = DotState - { dsNodeIds = M.empty - , dsNodeIdSupply = map (L.pack . ('m':) . show) [0..] - , dsGraph = DotGraph mempty mempty - } - -type DotM n a = ReaderT (Env n) (State (DotState n)) a - -runDotM :: Env n -> DotM n x -> DotGraph -runDotM env@Env{} = dsGraph . flip execState initialDotState . flip runReaderT env - -getLabel :: n -> DotM n L.Text -getLabel = liftM2 deLabel ask . pure - -getConnections :: n -> DotM n [n] -getConnections = liftM2 deConnections ask . pure - --- | Translate an entity name into an internal 'NodeId'. --- Returns @True@ if the 'ModuleName' is new, i.e., has not been --- encountered before and is thus added to the map of processed modules. -addEntity :: Ord n => n -> DotM n (NodeId, Bool) -addEntity name = do - s@(DotState nodeIds nodeIdSupply graph) <- get - case M.lookup name nodeIds of - Just nodeId -> return (nodeId, False) - Nothing -> do - let newNodeId:remainingNodeIdSupply = nodeIdSupply - label <- getLabel name - put s - { dsNodeIds = M.insert name newNodeId nodeIds - , dsNodeIdSupply = remainingNodeIdSupply - , dsGraph = graph - { dgNodeLabels = M.insert newNodeId label . dgNodeLabels $ graph - } - } - return (newNodeId, True) - --- | Add an arc from importer to imported. -addConnection :: NodeId -> NodeId -> DotM n () -addConnection m1 m2 = modify $ \s -> s - { dsGraph = (dsGraph s) - { dgEdges = S.insert (m1, m2) . dgEdges . dsGraph $ s - } - } - -dottify :: Ord n => Env n -> n -> DotGraph -dottify env root = runDotM env (dottify' root) - -dottify' :: Ord n => n -> DotM n NodeId -dottify' entity = do - (nodeId, continue) <- addEntity entity - -- If we have not visited this interface yet, - -- process its imports recursively and - -- add them as connections to the graph. - when continue $ do - connectedEntities <- getConnections entity - connectedNodeIds <- mapM dottify' connectedEntities - mapM_ (addConnection nodeId) connectedNodeIds - return nodeId +type DotGraph = Graph (WithUniqueInt L.Text) () -- * Graph rendering renderDot :: DotGraph -> L.Text renderDot g = L.unlines $ concat [ [ "digraph dependencies {" ] - , [ L.concat [" ", nodeId, "[label=\"", label, "\"];"] - | (nodeId, label) <- M.toList (dgNodeLabels g) ] - , [ L.concat [" ", r1, " -> ", r2, ";"] - | (r1 , r2) <- S.toList (dgEdges g) ] + , [ L.concat [" ", show' nodeId, "[label=\"", label, "\"];"] + | Graph.WithUniqueInt nodeId label <- S.toList $ Graph.nodes g + ] + , [ L.concat [" ", show' r1, " -> ", show' r2, ";"] + | Graph.Edge + { source = Graph.WithUniqueInt r1 _ + , target = Graph.WithUniqueInt r2 _ + } <- Graph.edges g + ] , ["}"] ] + where + show' = L.pack . ("m" ++) . show renderDotToFile :: MonadIO m => DotGraph -> FilePath -> m () renderDotToFile dot fp = liftIO $ BS.writeFile fp $ E.encodeUtf8 $ renderDot dot 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 @@ -35,6 +35,7 @@ import qualified Agda.Syntax.Position as P import Agda.Syntax.Position ( Range, HasRange, getRange, noRange ) import Agda.Syntax.Scope.Base ( AbstractName(..), ResolvedName(..), exactConName ) +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype) @@ -49,29 +50,29 @@ import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Pretty import Agda.Utils.Singleton +import Agda.Utils.Size -- Entry point: -- | Create highlighting info for some piece of syntax. -runHighlighter :: - Hilite a => - SourceToModule -> AbsolutePath -> NameKinds -> a -> - HighlightingInfoBuilder -runHighlighter modMap fileName kinds x = +runHighlighter + :: Hilite a + => TopLevelModuleName + -- ^ The current top-level module's name. + -> NameKinds -> a -> HighlightingInfoBuilder +runHighlighter top kinds x = runReader (hilite x) $ HiliteEnv - { hleNameKinds = kinds - , hleModMap = modMap - , hleFileName = fileName + { hleNameKinds = kinds + , hleCurrentModuleName = top } -- | Environment of the highlighter. data HiliteEnv = HiliteEnv { hleNameKinds :: NameKinds -- ^ Function mapping qualified names to their kind. - , hleModMap :: SourceToModule - -- ^ Maps source file paths to module names. - , hleFileName :: AbsolutePath - -- ^ The file name of the current module. Used for consistency checking. + , hleCurrentModuleName :: TopLevelModuleName + -- ^ The current top-level module's name. Used for consistency + -- checking. } -- | A function mapping names to the kind of name they stand for. @@ -214,6 +215,7 @@ A.PatternSynDef x xs p -> hl x <> hl xs <> hl p A.UnquoteDecl _mi _di xs e -> hl xs <> hl e A.UnquoteDef _di xs e -> hl xs <> hl e + A.UnquoteData _i xs _uc _j cs e -> hl xs <> hl cs <> hl e A.ScopedDecl s ds -> hl ds A.Pragma _r pragma -> hl pragma where @@ -230,6 +232,7 @@ 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 @@ -250,12 +253,11 @@ A.WithApp _r e es -> hl e <> hl es A.Lam _r bs e -> hl bs <> hl e A.AbsurdLam _r _h -> mempty - A.ExtendedLam _r _di _e _q cs -> hl cs -- No hilighting of generated extended lambda name! + A.ExtendedLam _r _di er _q cs -> hl er <> hl cs -- No hilighting of generated extended lambda name! A.Pi _r tel b -> hl tel <> hl b A.Generalized _qs e -> hl e A.Fun _r a b -> hl a <> hl b A.Let _r bs e -> hl bs <> hl e - A.ETel _tel -> mempty -- Printing only construct A.Rec _r ass -> hl ass A.RecUpdate _r e ass -> hl e <> hl ass A.ScopedExpr _ e -> hl e @@ -333,7 +335,7 @@ hilite (A.ProblemEq p _t _dom) = hilite p instance Hilite A.WhereDeclarations where - hilite (A.WhereDecls m ds) = hilite m <> hilite ds + hilite (A.WhereDecls m _ ds) = hilite m <> hilite ds instance Hilite A.GeneralizeTelescope where hilite (A.GeneralizeTel _gen tel) = hilite tel @@ -356,6 +358,9 @@ where hl x = hilite x +instance Hilite A.TypedBindingInfo where + hilite (A.TypedBindingInfo x _) = hilite x + instance Hilite A.TypedBinding where hilite = \case A.TBind _r tac binds e -> hilite tac <> hilite binds <> hilite e @@ -394,6 +399,10 @@ instance Hilite Quantity where hilite = singleAspect Symbol +-- | Erasure attributes are highlighted as symbols. +instance Hilite Erased where + hilite = singleAspect Symbol + instance Hilite ModuleInfo where hilite (ModuleInfo _r rAsTo asName _open _impDir) = singleAspect Symbol rAsTo -- TODO: 'to' already covered by A.ImportDirective @@ -450,17 +459,14 @@ hilite = hiliteAmbiguousQName Nothing instance Hilite A.ModuleName where - hilite m@(A.MName xs) = do - modMap <- asks hleModMap - hiliteModule (isTopLevelModule modMap, m) + hilite m@(A.MName xs) = hiliteModule (isTopLevelModule, m) where - isTopLevelModule modMap = - case mapMaybe - ((Strict.toLazy . P.srcFile) <=< (P.rStart . A.nameBindingSite)) xs of - f : _ -> - Map.lookup f modMap - == Just (C.toTopLevelModuleName $ A.mnameToConcrete m) - [] -> False + isTopLevelModule = + case mapMaybe (P.rangeModule . A.nameBindingSite) xs of + [] -> False + top : _ -> + rawTopLevelModuleName top == + rawTopLevelModuleNameForModuleName m -- Andreas, 2020-09-29, issue #4952. -- The target of a @renaming@ clause needs to be highlighted in a special way. @@ -563,36 +569,34 @@ -- The argument is 'True' iff the name is an operator. -> Hiliter hiliteCName xs x fr mR asp = do - HiliteEnv _ modMap fileName <- ask + env <- ask -- We don't care if we get any funny ranges. - if all (== Strict.Just fileName) fileNames then pure $ - frFile modMap <> - H.singleton (rToR rs) - (aspects { definitionSite = mFilePos modMap }) - else - mempty + if all (== Just (hleCurrentModuleName env)) moduleNames + then pure $ + frFile <> + H.singleton (rToR rs) (aspects { definitionSite = mFilePos }) + else mempty where - aspects = asp $ C.isOperator x - fileNames = mapMaybe (fmap P.srcFile . P.rStart . getRange) (x : xs) - frFile modMap = H.singleton (rToR fr) (aspects { definitionSite = notHere <$> mFilePos modMap }) - rs = getRange (x : xs) + aspects = asp $ C.isOperator x + moduleNames = mapMaybe (P.rangeModule' . getRange) (x : xs) + frFile = H.singleton (rToR fr) $ + aspects { definitionSite = notHere <$> mFilePos } + rs = getRange (x : xs) -- The fixity declaration should not get a symbolic anchor. notHere d = d { defSiteHere = False } - mFilePos - :: SourceToModule -- Maps source file paths to module names. - -> Maybe DefinitionSite - mFilePos modMap = do + mFilePos :: Maybe DefinitionSite + mFilePos = do r <- mR P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r - mod <- Map.lookup f modMap + mod <- P.rangeFileName f -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors. -- We drop the file name part from the qualifiers, since -- this is contained in the html file name already. -- We want to get anchors of the form: -- @@ - let qualifiers = drop (length $ C.moduleNameParts mod) xs + let qualifiers = drop (size mod) xs -- For bound variables, we do not create symbolic anchors. local = maybe True isLocalAspect $ aspect aspects return $ DefinitionSite @@ -640,13 +644,13 @@ -- ^ The argument is 'True' iff the name is an operator. -> Hiliter hiliteAName x include asp = do - fileName <- asks hleFileName + currentModule <- asks hleCurrentModuleName hiliteCName (concreteQualifier x) (concreteBase x) - (rangeOfFixityDeclaration fileName) + (rangeOfFixityDeclaration currentModule) (if include then Just $ bindingSite x else Nothing) asp - <> (notationFile fileName) + <> notationFile currentModule where -- TODO: Currently we highlight fixity and syntax declarations by -- producing highlighting something like once per occurrence of the @@ -654,14 +658,14 @@ -- avoid doing this for other files). Perhaps it would be better to -- only produce this highlighting once. - rangeOfFixityDeclaration fileName = - if P.rangeFile r == Strict.Just fileName + rangeOfFixityDeclaration currentModule = + if P.rangeModule r == Just currentModule then r else noRange where r = theNameRange $ A.nameFixity $ A.qnameName x - notationFile fileName = pure $ - if P.rangeFile (getRange notation) == Strict.Just fileName + notationFile currentModule = pure $ + if P.rangeModule (getRange notation) == Just currentModule then mconcat $ map genPartFile notation else mempty where @@ -669,10 +673,10 @@ boundAspect = nameAsp Bound False - genPartFile (BindHole r i) = several [rToR r, rToR $ getRange i] boundAspect - genPartFile (NormalHole r i) = several [rToR r, rToR $ getRange i] boundAspect - genPartFile WildHole{} = mempty - genPartFile (IdPart x) = H.singleton (rToR $ getRange x) (asp False) + genPartFile (VarPart r i) = several [rToR r, rToR $ getRange i] boundAspect + genPartFile (HolePart r i) = several [rToR r, rToR $ getRange i] boundAspect + genPartFile WildPart{} = mempty + genPartFile (IdPart x) = H.singleton (rToR $ getRange x) (asp False) -- * Short auxiliary functions. --------------------------------------------------------------------------- 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 @@ -64,7 +64,9 @@ import qualified Agda.Syntax.Parser as Pa import qualified Agda.Syntax.Parser.Tokens as T import qualified Agda.Syntax.Position as P -import Agda.Syntax.Position (Range, HasRange, getRange, noRange) +import Agda.Syntax.Position + (RangeFile, Range, HasRange, getRange, noRange) +import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Scope.Base ( WithKind(..) ) import Agda.Syntax.Abstract.Views ( KName, declaredNames ) @@ -127,19 +129,19 @@ -> TCM () generateAndPrintSyntaxInfo decl _ _ | null $ getRange decl = return () generateAndPrintSyntaxInfo decl hlLevel updateState = do - file <- getCurrentPath + top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule - reportSLn "import.iface.create" 15 $ concat - [ "Generating syntax info for " - , filePath file - , case hlLevel of - Full {} -> " (final)." - Partial{} -> " (first approximation)." - ] + reportSDoc "import.iface.create" 15 $ + TCM.fwords + ("Generating syntax info for the following declaration " ++ + case hlLevel of + Full {} -> "(final):" + Partial{} -> "(first approximation):") + TCM.$$ + TCM.prettyA decl ignoreAbstractMode $ do - modMap <- sourceToModule - kinds <- nameKinds hlLevel decl + kinds <- nameKinds hlLevel decl -- After the code has been type checked more information may be -- available for overloaded constructors, and @@ -147,11 +149,11 @@ -- Note, however, that highlighting for overloaded constructors is -- included also in @nameInfo@. constructorInfo <- case hlLevel of - Full{} -> generateConstructorInfo modMap file kinds decl + Full{} -> generateConstructorInfo top kinds decl _ -> return mempty -- Main source of scope-checker generated highlighting: - let nameInfo = runHighlighter modMap file kinds decl + let nameInfo = runHighlighter top kinds decl reportSDoc "highlighting.warning" 60 $ TCM.hcat [ "current path = " @@ -184,21 +186,31 @@ generateTokenInfo :: AbsolutePath -> TCM HighlightingInfo generateTokenInfo file = - generateTokenInfoFromSource file . Text.unpack =<< - runPM (Pa.readFilePM file) + generateTokenInfoFromSource rf . Text.unpack =<< + runPM (Pa.readFilePM rf) + where + -- Note the use of Nothing here. The file might not even parse, but + -- it should still be possible to obtain token-based highlighting + -- information. The top-level module names seem to be *mostly* + -- unused, but one cannot use __IMPOSSIBLE__ instead of Nothing, + -- because the top-level module names are used by interleaveRanges, + -- which is used by parseLiterateWithComments, which is used by + -- generateTokenInfoFromSource. + rf = P.mkRangeFile file Nothing -- | Generate and return the syntax highlighting information for the -- tokens in the given file. generateTokenInfoFromSource - :: AbsolutePath + :: RangeFile -- ^ The module to highlight. -> String -- ^ The file contents. Note that the file is /not/ read from -- disk. -> TCM HighlightingInfo generateTokenInfoFromSource file input = - runPM $ tokenHighlighting . fst <$> Pa.parseFile Pa.tokensParser file input + runPM $ tokenHighlighting . fst . fst <$> + Pa.parseFile Pa.tokensParser file input -- | Generate and return the syntax highlighting information for the -- tokens in the given string, which is assumed to correspond to the @@ -207,7 +219,8 @@ generateTokenInfoFromString :: Range -> String -> TCM HighlightingInfo generateTokenInfoFromString r _ | r == noRange = return mempty generateTokenInfoFromString r s = do - runPM $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s + runPM $ tokenHighlighting . fst <$> + Pa.parsePosString Pa.tokensParser p s where Just p = P.rStart r @@ -323,12 +336,12 @@ -- the type checker. generateConstructorInfo - :: SourceToModule -- ^ Maps source file paths to module names. - -> AbsolutePath -- ^ The module to highlight. + :: TopLevelModuleName + -- ^ The module to highlight. -> NameKinds -> A.Declaration -> TCM HighlightingInfoBuilder -generateConstructorInfo modMap file kinds decl = do +generateConstructorInfo top kinds decl = do -- Get boundaries of current declaration. -- @noRange@ should be impossible, but in case of @noRange@ @@ -345,7 +358,7 @@ constrs = IntMap.elems m2 -- Return suitable syntax highlighting information. - return $ foldMap (runHighlighter modMap file kinds) constrs + return $ foldMap (runHighlighter top kinds) constrs printSyntaxInfo :: Range -> TCM () printSyntaxInfo r = do @@ -460,9 +473,11 @@ RewriteMissingRule{} -> confluenceErrorHighlighting w PragmaCompileErased{} -> deadcodeHighlighting w NotInScopeW{} -> deadcodeHighlighting w + UnsupportedIndexedMatch{} -> mempty AsPatternShadowsConstructorOrPatternSynonym{} -> deadcodeHighlighting w RecordFieldWarning w -> recordFieldWarningHighlighting w + OptionWarning w -> mempty ParseWarning w -> case w of Pa.UnsupportedAttribute{} -> deadcodeHighlighting w Pa.MultipleAttributes{} -> deadcodeHighlighting w @@ -482,6 +497,12 @@ EmptyPrivate{} -> deadcodeHighlighting w EmptyGeneralize{} -> deadcodeHighlighting w EmptyField{} -> deadcodeHighlighting w + HiddenGeneralize{} -> mempty + -- Andreas, 2022-03-25, issue #5850 + -- We would like @deadcodeHighlighting w@ for the braces in + -- @variable {x} : A@, but these have no range, so we cannot highlight them. + -- Highlighting the variable instead might be misleading, + -- suggesting that it is not generalized over. UselessAbstract{} -> deadcodeHighlighting w UselessInstance{} -> deadcodeHighlighting w UselessPrivate{} -> deadcodeHighlighting w @@ -530,7 +551,7 @@ functionDefs = foldMap (\x -> H.singleton (rToR $ bindingSite x) m) $ concatMap termErrFunctions termErrs callSites = foldMap (\r -> H.singleton (rToR r) m) $ - concatMap (map callInfoRange . termErrCalls) termErrs + concatMap (map getRange . termErrCalls) termErrs bindingSite = A.nameBindingSite . A.qnameName -- | Generate syntax highlighting for not-strictly-positive inductive 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 @@ -25,7 +25,7 @@ import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..)) import Agda.Compiler.Common (IsMain(..), curIF) -import Agda.Syntax.Abstract (ModuleName, toTopLevelModuleName) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.TypeChecking.Monad ( MonadDebug @@ -52,7 +52,7 @@ data HtmlModuleEnv = HtmlModuleEnv { htmlModEnvCompileEnv :: HtmlCompileEnv - , htmlModEnvName :: ModuleName + , htmlModEnvName :: TopLevelModuleName } data HtmlModule = HtmlModule @@ -164,7 +164,7 @@ :: Applicative m => HtmlCompileEnv -> IsMain - -> ModuleName + -> TopLevelModuleName -> Maybe FilePath -> m (Recompile HtmlModuleEnv HtmlModule) preModuleHtml cenv _isMain modName _ifacePath = pure $ Recompile (HtmlModuleEnv cenv modName) @@ -183,12 +183,12 @@ => HtmlCompileEnv -> HtmlModuleEnv -> IsMain - -> ModuleName + -> TopLevelModuleName -> [HtmlDef] -> m HtmlModule postModuleHtml _env menv _isMain _modName _defs = do let generatePage = defaultPageGen . htmlCompileEnvOpts . htmlModEnvCompileEnv $ menv - htmlSrc <- srcFileOfInterface (toTopLevelModuleName . htmlModEnvName $ menv) <$> curIF + htmlSrc <- srcFileOfInterface (htmlModEnvName menv) <$> curIF runLogHtmlWithMonadDebug $ generatePage htmlSrc return HtmlModule @@ -196,6 +196,6 @@ :: Applicative m => HtmlCompileEnv -> IsMain - -> Map ModuleName HtmlModule + -> Map TopLevelModuleName HtmlModule -> m () postCompileHtml _cenv _isMain _modulesByName = pure () 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 @@ -54,8 +54,8 @@ import Agda.Interaction.Highlighting.Precise hiding (toList) -import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Common +import Agda.Syntax.TopLevelModuleName import qualified Agda.TypeChecking.Monad as TCM ( Interface(..) @@ -137,7 +137,7 @@ -- | Internal type bundling the information related to a module source file data HtmlInputSourceFile = HtmlInputSourceFile - { _srcFileModuleName :: C.TopLevelModuleName + { _srcFileModuleName :: TopLevelModuleName , _srcFileType :: FileType -- ^ Source file type , _srcFileText :: Text @@ -148,7 +148,8 @@ -- | Bundle up the highlighting info for a source file -srcFileOfInterface :: C.TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile +srcFileOfInterface :: + TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile srcFileOfInterface m i = HtmlInputSourceFile m (TCM.iFileType i) (TCM.iSource i) (TCM.iHighlighting i) -- | Logging during HTML generation @@ -213,7 +214,7 @@ -- | Converts module names to the corresponding HTML file names. -modToFile :: C.TopLevelModuleName -> String -> FilePath +modToFile :: TopLevelModuleName -> String -> FilePath modToFile m ext = Network.URI.Encode.encode $ render (pretty m) <.> ext -- | Generates a highlighted, hyperlinked version of the given module. @@ -236,7 +237,7 @@ page :: FilePath -- ^ URL to the CSS file. -> Bool -- ^ Highlight occurrences -> Bool -- ^ Whether to reserve literate - -> C.TopLevelModuleName -- ^ Module to be highlighted. + -> TopLevelModuleName -- ^ Module to be highlighted. -> Html -> Text page css 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 @@ -35,8 +35,8 @@ , OptDescr(..) ) -import Agda.Syntax.Abstract.Name (ModuleName, toTopLevelModuleName) -import Agda.Syntax.Concrete.Name (TopLevelModuleName, projectRoot) +import Agda.Syntax.Position (mkRangeFile, rangeFilePath) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName, projectRoot) import Agda.TypeChecking.Monad ( HasOptions(commandLineOptions) @@ -122,14 +122,18 @@ options <- commandLineOptions modFiles <- useTC stModuleToSource let - mSrcFileName = (mkAbsolute . filePath) <$> Map.lookup moduleName modFiles + mSrcFileName = + (\f -> mkRangeFile (mkAbsolute (filePath f)) (Just moduleName)) <$> + Map.lookup moduleName modFiles countClusters = optCountClusters . optPragmaOptions $ options latexDir = latexFlagOutDir flags -- FIXME: This reliance on emacs-mode to decide whether to interpret the output location as project-relative or -- cwd-relative is gross. Also it currently behaves differently for JSON mode :-/ -- And it prevents us from doing a real "one-time" setup. outDir = case (mSrcFileName, optGHCiInteraction options) of - (Just sourceFile, True) -> filePath (projectRoot sourceFile moduleName) latexDir + (Just sourceFile, True) -> + filePath (projectRoot (rangeFilePath sourceFile) moduleName) + latexDir _ -> latexDir return LaTeXOptions { latexOptOutDir = outDir @@ -147,11 +151,11 @@ :: (HasOptions m, ReadTCState m) => LaTeXCompileEnv -> IsMain - -> ModuleName + -> TopLevelModuleName -> Maybe FilePath -> m (Recompile LaTeXModuleEnv LaTeXModule) preModuleLaTeX (LaTeXCompileEnv flags) isMain moduleName _ifacePath = case isMain of - IsMain -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags (toTopLevelModuleName moduleName) + IsMain -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags moduleName NotMain -> return $ Skip LaTeXModule compileDefLaTeX @@ -168,7 +172,7 @@ => LaTeXCompileEnv -> LaTeXModuleEnv -> IsMain - -> ModuleName + -> TopLevelModuleName -> [LaTeXDef] -> m LaTeXModule postModuleLaTeX _cenv (LaTeXModuleEnv latexOpts) _main _moduleName _defs = do @@ -186,6 +190,6 @@ :: Applicative m => LaTeXCompileEnv -> IsMain - -> Map ModuleName LaTeXModule + -> Map TopLevelModuleName LaTeXModule -> m () postCompileLaTeX _cenv _main _modulesByName = pure () diff --git a/src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs b/src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs --- a/src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs +++ b/src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs @@ -20,12 +20,14 @@ import Data.Bifunctor (second) import Data.Char import Data.Maybe -import Data.Function +import Data.Function (on) import Data.Foldable (toList) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif +import qualified Data.Text as T +import Control.Exception.Base (IOException, try) import Control.Monad (forM_, mapM_, unless, when) import Control.Monad.Trans.Reader as R ( ReaderT(runReaderT)) import Control.Monad.RWS.Strict @@ -59,22 +61,22 @@ import Paths_Agda -import Agda.Syntax.Abstract (toTopLevelModuleName) import Agda.Syntax.Common -import Agda.Syntax.Concrete (TopLevelModuleName, moduleNameParts) import Agda.Syntax.Parser.Literate (literateTeX, LayerRole, atomizeLayers) import qualified Agda.Syntax.Parser.Literate as L -import Agda.Syntax.Position (startPos) +import Agda.Syntax.Position (RangeFile, startPos) +import Agda.Syntax.TopLevelModuleName + (TopLevelModuleName, moduleNameParts) import Agda.Interaction.Highlighting.Precise hiding (toList) -import Agda.TypeChecking.Monad (Interface(..)) +import Agda.TypeChecking.Monad (Interface(..)) --, reportSLn) -import Agda.Utils.FileName (AbsolutePath) import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor ((<&>)) import Agda.Utils.List (last1, updateHead, updateLast) import Agda.Utils.Maybe (whenJust) +import Agda.Utils.Monad import qualified Agda.Utils.List1 as List1 import Agda.Utils.Impossible @@ -695,7 +697,7 @@ data LaTeXOptions = LaTeXOptions { latexOptOutDir :: FilePath - , latexOptSourceFileName :: Maybe AbsolutePath + , latexOptSourceFileName :: Maybe RangeFile -- ^ The parser uses a @Position@ which includes a source filename for -- error reporting and such. We don't actually get the source filename -- with an @Interface@, and it isn't necessary to look it up. @@ -718,28 +720,45 @@ -- | Create the common base output directory and check for/install the style file. prepareCommonAssets :: (MonadLogLaTeX m, MonadIO m) => FilePath -> m () prepareCommonAssets dir = do - liftIO $ createDirectoryIfMissing True dir - (code, _, _) <- - liftIO $ - readProcessWithExitCode + -- Make sure @dir@ will exist. + dirExisted <- liftIO $ doesDirectoryExist dir + unless dirExisted $ + -- Create directory @dir@ and parent directories. + liftIO $ createDirectoryIfMissing True dir + + -- Check whether TeX will find @agda.sty@. + texFindsSty <- liftIO $ try $ + readProcess "kpsewhich" - ["--path=" ++ dir, defaultStyFile] + (applyWhen dirExisted (("--path=" ++ dir) :) [defaultStyFile]) "" - when (code /= ExitSuccess) $ do - logLaTeX $ LogMessage FileSystem - (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir]) - [] - liftIO $ do - styFile <- getDataFileName $ - latexDataDir defaultStyFile - copyFile styFile (dir defaultStyFile) + case texFindsSty of + Right _ -> return () + Left (e :: IOException) -> do + -- -- we are lacking MonadDebug here, so no debug printing via reportSLn + -- reportSLn "compile.latex.sty" 70 $ unlines + -- [ unwords [ "Searching for", defaultStyFile, "in", dir, "returns:" ] + -- , show e + -- ] + let agdaSty = dir defaultStyFile + unlessM (pure dirExisted `and2M` liftIO (doesFileExist agdaSty)) $ do + -- It is safe now to create the default style file in @dir@ without overwriting + -- a possibly user-edited copy there. + logLaTeX $ LogMessage FileSystem + (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir]) + [] + liftIO $ do + styFile <- getDataFileName $ + latexDataDir defaultStyFile + copyFile styFile agdaSty -- | Generates a LaTeX file for the given interface. generateLaTeXIO :: (MonadLogLaTeX m, MonadIO m) => LaTeXOptions -> Interface -> m () generateLaTeXIO opts i = do let textWidthEstimator = getTextWidthEstimator (latexOptCountClusters opts) let baseDir = latexOptOutDir opts - let outPath = baseDir (latexOutRelativeFilePath $ toTopLevelModuleName $ iModuleName i) + let outPath = baseDir + latexOutRelativeFilePath (iTopLevelModuleName i) latex <- E.encodeUtf8 <$> toLaTeX (emptyEnv textWidthEstimator) (latexOptSourceFileName opts) @@ -750,7 +769,10 @@ BS.writeFile outPath latex latexOutRelativeFilePath :: TopLevelModuleName -> FilePath -latexOutRelativeFilePath m = List.intercalate [pathSeparator] (List1.toList $ moduleNameParts m) <.> "tex" +latexOutRelativeFilePath m = + List.intercalate [pathSeparator] + (map T.unpack $ List1.toList $ moduleNameParts m) <.> + "tex" groupByFst :: forall a b. Eq a => [(a,b)] -> [(a,[b])] groupByFst = @@ -765,7 +787,7 @@ toLaTeX :: MonadLogLaTeX m => Env - -> Maybe AbsolutePath + -> Maybe RangeFile -> L.Text -> HighlightingInfo -> m L.Text diff --git a/src/full/Agda/Interaction/Highlighting/Precise.hs b/src/full/Agda/Interaction/Highlighting/Precise.hs --- a/src/full/Agda/Interaction/Highlighting/Precise.hs +++ b/src/full/Agda/Interaction/Highlighting/Precise.hs @@ -33,7 +33,7 @@ import Control.DeepSeq import Control.Monad -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Semigroup @@ -51,7 +51,7 @@ import qualified Agda.Syntax.Position as P import qualified Agda.Syntax.Common as Common -import qualified Agda.Syntax.Concrete as C +import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Scope.Base ( KindOfName(..) ) import Agda.Interaction.Highlighting.Range @@ -162,7 +162,7 @@ deriving (Show, Generic) data DefinitionSite = DefinitionSite - { defSiteModule :: C.TopLevelModuleName + { defSiteModule :: TopLevelModuleName -- ^ The defining module. , defSitePos :: Int -- ^ The file position in that module. File positions are 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 @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE RecursiveDo #-} {-| This module deals with finding imported modules and loading their interface files. @@ -35,14 +37,15 @@ import Control.Monad.Fail (MonadFail) #endif -import Data.Either (lefts) -import qualified Data.Map as Map +import Data.Either import qualified Data.List as List -import Data.Set (Set) -import qualified Data.Set as Set import Data.Maybe import Data.Map (Map) +import qualified Data.Map as Map import qualified Data.HashMap.Strict as HMap +import qualified Data.HashSet as HSet +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.Lazy as TL @@ -53,12 +56,14 @@ import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C +import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Parser import Agda.Syntax.Position import Agda.Syntax.Scope.Base -import Agda.Syntax.Translation.ConcreteToAbstract +import Agda.Syntax.TopLevelModuleName +import Agda.Syntax.Translation.ConcreteToAbstract as CToA import Agda.TypeChecking.Errors import Agda.TypeChecking.Warnings hiding (warnings) @@ -94,8 +99,10 @@ import Agda.Utils.Null import Agda.Utils.IO.Binary import Agda.Utils.Pretty hiding (Mode) +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Hash import qualified Agda.Utils.Trie as Trie +import Agda.Utils.WithDefault import Agda.Utils.Impossible @@ -116,19 +123,27 @@ , srcFileType :: FileType -- ^ Source file type , srcOrigin :: SourceFile -- ^ Source location at the time of its parsing , srcModule :: C.Module -- ^ The parsed module. - , srcModuleName :: C.TopLevelModuleName -- ^ The top-level module name. + , srcModuleName :: TopLevelModuleName -- ^ The top-level module name. , srcProjectLibs :: [AgdaLibFile] -- ^ The .agda-lib file(s) of the project this file belongs to. + , srcCohesion :: !CohesionAttributes + -- ^ Every encountered occurrence of a cohesion attribute. } -- | Parses a source file and prepares the 'Source' record. parseSource :: SourceFile -> TCM Source parseSource sourceFile@(SourceFile f) = Bench.billTo [Bench.Parsing] $ do - source <- runPM $ readFilePM f - (parsedMod, fileType) <- runPM $ - parseFile moduleParser f $ TL.unpack source - parsedModName <- moduleName f parsedMod - libs <- getAgdaLibFiles $ takeDirectory $ filePath f + (source, fileType, parsedMod, coh, parsedModName) <- mdo + -- This piece of code uses mdo because the top-level module name + -- (parsedModName) is obtained from the parser's result, but it is + -- also used by the parser. + let rf = mkRangeFile f (Just parsedModName) + source <- runPM $ readFilePM rf + ((parsedMod, coh), fileType) <- runPM $ parseFile moduleParser rf $ + TL.unpack source + parsedModName <- moduleName f parsedMod + return (source, fileType, parsedMod, coh, parsedModName) + libs <- getAgdaLibFiles f parsedModName return Source { srcText = source , srcFileType = fileType @@ -136,6 +151,7 @@ , srcModule = parsedMod , srcModuleName = parsedModName , srcProjectLibs = libs + , srcCohesion = coh } srcDefaultPragmas :: Source -> [OptionsPragma] @@ -196,10 +212,12 @@ mergeInterface i = do let sig = iSignature i builtin = Map.toAscList $ iBuiltin i - prim = [ x | (_,Prim x) <- builtin ] - bi = Map.fromDistinctAscList [ (x, Builtin t) | (x, Builtin t) <- builtin ] - -- Andreas, 2021-08-19: this seeming identity filters out the @Prim@s - -- and converts the type. + primOrBi = \case + (_, Prim x) -> Left x + (x, Builtin t) -> Right (x, Builtin t) + (x, BuiltinRewriteRelations xs) -> Right (x, BuiltinRewriteRelations xs) + (prim, bi') = partitionEithers $ map primOrBi builtin + bi = Map.fromDistinctAscList bi' warns = iWarnings i bs <- getsTC stBuiltinThings reportSLn "import.iface.merge" 10 "Merging interface" @@ -209,9 +227,13 @@ let check b (Builtin x) (Builtin y) | x == y = return () | otherwise = typeError $ DuplicateBuiltinBinding b x y + check _ (BuiltinRewriteRelations xs) (BuiltinRewriteRelations ys) = return () check _ _ _ = __IMPOSSIBLE__ sequence_ $ Map.intersectionWithKey check bs bi - addImportedThings sig bi + addImportedThings + sig + (iMetaBindings i) + bi (iPatternSyns i) (iDisplayForms i) (iUserWarnings i) @@ -230,6 +252,7 @@ addImportedThings :: Signature + -> RemoteMetaStore -> BuiltinThings PrimFun -> A.PatternSynDefns -> DisplayForms @@ -237,8 +260,10 @@ -> Set QName -- ^ Name of imported definitions which are partial -> [TCWarning] -> TCM () -addImportedThings isig ibuiltin patsyns display userwarn partialdefs warnings = do +addImportedThings isig metas ibuiltin patsyns display userwarn + partialdefs warnings = do stImports `modifyTCLens` \ imp -> unionSignatures [imp, isig] + stImportedMetaStore `modifyTCLens` HMap.union metas stImportedBuiltins `modifyTCLens` \ imp -> Map.union imp ibuiltin stImportedUserWarnings `modifyTCLens` \ imp -> Map.union imp userwarn stImportedPartialDefs `modifyTCLens` \ imp -> Set.union imp partialdefs @@ -250,16 +275,18 @@ -- | Scope checks the given module. A proper version of the module -- name (with correct definition sites) is returned. -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope) -scopeCheckImport x = do +scopeCheckImport :: + TopLevelModuleName -> ModuleName -> + TCM (ModuleName, Map ModuleName Scope) +scopeCheckImport top x = do reportSLn "import.scope" 5 $ "Scope checking " ++ prettyShow x verboseS "import.scope" 10 $ do visited <- prettyShow <$> getPrettyVisitedModules reportSLn "import.scope" 10 $ " visited: " ++ visited -- Since scopeCheckImport is called from the scope checker, -- we need to reimburse her account. - i <- Bench.billTo [] $ getNonMainInterface (toTopLevelModuleName x) Nothing - addImport x + i <- Bench.billTo [] $ getNonMainInterface top Nothing + addImport top -- If that interface was supposed to raise a warning on import, do so. whenJust (iImportWarning i) $ warning . UserWarning @@ -273,7 +300,7 @@ -- used to find the interface and the computed interface is stored for -- potential later use. -alreadyVisited :: C.TopLevelModuleName -> +alreadyVisited :: TopLevelModuleName -> MainInterface -> PragmaOptions -> TCM ModuleInfo -> @@ -331,7 +358,7 @@ _ -> storeDecodedModule mi reportS "warning.import" 10 - [ "module: " ++ show (C.moduleNameParts x) + [ "module: " ++ show (moduleNameParts x) , "WarningOnImport: " ++ show (iImportWarning (miInterface mi)) ] @@ -383,33 +410,42 @@ typeCheckMain mode src = do -- liftIO $ putStrLn $ "This is typeCheckMain " ++ prettyShow f -- liftIO . putStrLn . show =<< getVerbosity - reportSLn "import.main" 10 "Importing the primitive modules." - libdirPrim <- liftIO getPrimitiveLibDir - reportSLn "import.main" 20 $ "Library primitive dir = " ++ show libdirPrim - -- Turn off import-chasing messages. - -- We have to modify the persistent verbosity setting, since - -- getInterface resets the current verbosity settings to the persistent ones. - bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do - Lens.modifyPersistentVerbosity (Trie.delete []) -- set root verbosity to 0 - -- We don't want to generate highlighting information for Agda.Primitive. - withHighlightingLevel None $ - forM_ (Set.map (libdirPrim ) Lens.primitiveModules) $ \f -> do - primSource <- parseSource (SourceFile $ mkAbsolute f) - checkModuleName' (srcModuleName primSource) (srcOrigin primSource) - void $ getNonMainInterface (srcModuleName primSource) (Just primSource) + -- For the main interface, we also remember the pragmas from the file + setOptionsFromSourcePragmas src + loadPrims <- optLoadPrimitives <$> pragmaOptions - reportSLn "import.main" 10 $ "Done importing the primitive modules." + when loadPrims $ do + reportSLn "import.main" 10 "Importing the primitive modules." + libdirPrim <- liftIO getPrimitiveLibDir + reportSLn "import.main" 20 $ "Library primitive dir = " ++ show libdirPrim + -- Turn off import-chasing messages. + -- We have to modify the persistent verbosity setting, since + -- getInterface resets the current verbosity settings to the persistent ones. + bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do + Lens.modifyPersistentVerbosity + (Strict.Just . Trie.insert [] 0 . Strict.fromMaybe Trie.empty) + -- set root verbosity to 0 + + -- We don't want to generate highlighting information for Agda.Primitive. + withHighlightingLevel None $ + forM_ (Set.map (libdirPrim ) Lens.primitiveModules) $ \f -> do + primSource <- parseSource (SourceFile $ mkAbsolute f) + checkModuleName' (srcModuleName primSource) (srcOrigin primSource) + void $ getNonMainInterface (srcModuleName primSource) (Just primSource) + + reportSLn "import.main" 10 $ "Done importing the primitive modules." + -- Now do the type checking via getInterface. checkModuleName' (srcModuleName src) (srcOrigin src) - -- For the main interface, we also remember the pragmas from the file - setOptionsFromSourcePragmas src - mi <- getInterface (srcModuleName src) (MainInterface mode) (Just src) - stCurrentModule `setTCLens` Just (iModuleName (miInterface mi)) + stCurrentModule `setTCLens'` + Just ( iModuleName (miInterface mi) + , iTopLevelModuleName (miInterface mi) + ) return $ CheckResult' mi src where @@ -428,7 +464,7 @@ -- Do not use this for the main file, use 'typeCheckMain' instead. getNonMainInterface - :: C.TopLevelModuleName + :: TopLevelModuleName -> Maybe Source -- ^ Optional: the source code and some information about the source code. -> TCM Interface @@ -445,7 +481,7 @@ -- errors. getInterface - :: C.TopLevelModuleName + :: TopLevelModuleName -> MainInterface -> Maybe Source -- ^ Optional: the source code and some information about the source code. @@ -503,25 +539,25 @@ -- | Check if the options used for checking an imported module are -- compatible with the current options. Raises Non-fatal errors if -- not. -checkOptionsCompatible :: PragmaOptions -> PragmaOptions -> ModuleName -> TCM Bool +checkOptionsCompatible :: + PragmaOptions -> PragmaOptions -> TopLevelModuleName -> TCM Bool checkOptionsCompatible current imported importedModule = flip execStateT True $ do reportSDoc "import.iface.options" 5 $ P.nest 2 $ "current options =" P.<+> showOptions current reportSDoc "import.iface.options" 5 $ P.nest 2 $ "imported options =" P.<+> showOptions imported - forM_ coinfectiveOptions $ \ (opt, optName) -> do - unless (opt current `implies` opt imported) $ do - put False - warning (CoInfectiveImport optName importedModule) - forM_ infectiveOptions $ \ (opt, optName) -> do - unless (opt imported `implies` opt current) $ do + forM_ infectiveCoinfectiveOptions $ \opt -> do + unless (icOptionOK opt current imported) $ do put False - warning (InfectiveImport optName importedModule) + warning $ + (case icOptionKind opt of + Infective -> InfectiveImport + Coinfective -> CoInfectiveImport) + (icOptionWarning opt importedModule) where - implies :: Bool -> Bool -> Bool - p `implies` q = p <= q - - showOptions opts = P.prettyList (map (\ (o, n) -> (P.text n <> ": ") P.<+> P.pretty (o opts)) - (coinfectiveOptions ++ infectiveOptions)) - + showOptions opts = + P.prettyList $ + map (\opt -> (P.text (icOptionDescription opt) <> ": ") P.<+> + P.pretty (icOptionActive opt opts)) + infectiveCoinfectiveOptions -- | Compare options and return collected warnings. -- | Returns `Nothing` if warning collection was skipped. @@ -532,14 +568,15 @@ -- They weren't logged before, but they're nice for documenting the early returns. when isPrim $ throwError "Options consistency checking disabled for always-available primitive module" - whenM (lift $ checkOptionsCompatible currentOptions (iOptionsUsed i) (iModuleName i)) $ + whenM (lift $ checkOptionsCompatible currentOptions (iOptionsUsed i) + (iTopLevelModuleName i)) $ throwError "No warnings to collect because options were compatible" lift $ getAllWarnings' isMain ErrorWarnings -- | Try to get the interface from interface file or cache. getStoredInterface - :: C.TopLevelModuleName + :: TopLevelModuleName -- ^ Module name of file we process. -> SourceFile -- ^ File we process. @@ -634,7 +671,7 @@ readInterface ifile -- Ensure that the given module name matches the one in the file. - let topLevelName = toTopLevelModuleName $ iModuleName i + let topLevelName = iTopLevelModuleName i unless (topLevelName == x) $ -- Andreas, 2014-03-27 This check is now done in the scope checker. -- checkModuleName topLevelName file @@ -644,7 +681,9 @@ lift $ chaseMsg "Loading " x $ Just ifp -- print imported warnings - let ws = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (iWarnings i) + let ws = filter ((Strict.Just (Just x) ==) . + fmap rangeFileName . tcWarningOrigin) $ + iWarnings i unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws loadDecodedModule file $ ModuleInfo @@ -673,23 +712,16 @@ -- want the pragmas to apply to interactive commands in the UI. -- Jesper, 2021-04-18: Check for changed options in library files! -- (see #5250) - libOptions <- lift $ getLibraryOptions $ takeDirectory fp + libOptions <- lift $ getLibraryOptions + (srcFilePath file) + (iTopLevelModuleName i) lift $ mapM_ setOptionsFromPragma (libOptions ++ iFilePragmaOptions i) -- Check that options that matter haven't changed compared to -- current options (issue #2487) unlessM (lift $ Lens.isBuiltinModule fp) $ do - currentOptions <- useTC stPragmaOptions - let disagreements = - [ optName | (opt, optName) <- restartOptions, - opt currentOptions /= opt (iOptionsUsed i) ] - unless (null disagreements) $ do - reportSLn "import.iface.options" 4 $ concat - [ " Changes in the following options in " - , prettyShow fp - , ", re-typechecking: " - , prettyShow disagreements - ] + current <- useTC stPragmaOptions + when (recheckBecausePragmaOptionsChanged (iOptionsUsed i) current) $ throwError "options changed" -- If any of the imports are newer we need to retype check @@ -721,7 +753,7 @@ -- in order to forget some state changes after successful type checking. createInterfaceIsolated - :: C.TopLevelModuleName + :: TopLevelModuleName -- ^ Module name of file we process. -> SourceFile -- ^ File we process. @@ -739,6 +771,7 @@ ds <- getDecodedModules opts <- stPersistentOptions . stPersistentState <$> getTC isig <- useTC stImports + metas <- useTC stImportedMetaStore ibuiltin <- useTC stImportedBuiltins display <- useTC stImportsDisplayForms userwarn <- useTC stImportedUserWarnings @@ -768,7 +801,8 @@ setInteractionOutputCallback ho stModuleToSource `setTCLens` mf setVisitedModules vs - addImportedThings isig ibuiltin ipatsyns display userwarn partialdefs [] + addImportedThings isig metas ibuiltin ipatsyns display + userwarn partialdefs [] r <- createInterface x file NotMainInterface msrc mf' <- useTC stModuleToSource @@ -800,7 +834,7 @@ chaseMsg :: String -- ^ The prefix, like @Checking@, @Finished@, @Loading @. - -> C.TopLevelModuleName -- ^ The module name. + -> TopLevelModuleName -- ^ The module name. -> Maybe String -- ^ Optionally: the file name. -> TCM () chaseMsg kind x file = do @@ -897,7 +931,7 @@ -- information. createInterface - :: C.TopLevelModuleName -- ^ The expected module name. + :: TopLevelModuleName -- ^ The expected module name. -> SourceFile -- ^ The file to type check. -> MainInterface -- ^ Are we dealing with the main module? -> Maybe Source -- ^ Optional information about the source code. @@ -912,7 +946,9 @@ (chaseMsg checkMsg x $ Just fp) (const $ do ws <- getAllWarnings AllWarnings let classified = classifyWarnings ws - let wa' = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (tcWarnings classified) + let wa' = filter ((Strict.Just (Just mname) ==) . + fmap rangeFileName . tcWarningOrigin) $ + tcWarnings classified unless (null wa') $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> wa' when (null (nonFatalErrors classified)) $ chaseMsg "Finished" x Nothing) @@ -934,10 +970,16 @@ let srcPath = srcFilePath $ srcOrigin src fileTokenInfo <- Bench.billTo [Bench.Highlighting] $ - generateTokenInfoFromSource srcPath (TL.unpack $ srcText src) + generateTokenInfoFromSource + (let !top = srcModuleName src in + mkRangeFile srcPath (Just top)) + (TL.unpack $ srcText src) stTokens `modifyTCLens` (fileTokenInfo <>) setOptionsFromSourcePragmas src + checkCohesionAttributes (srcCohesion src) + syntactic <- optSyntacticEquality <$> pragmaOptions + localTC (\env -> env { envSyntacticEqualityFuel = syntactic }) $ do verboseS "import.iface.create" 15 $ do nestingLevel <- asksTC (pred . length . envImportPath) @@ -1006,9 +1048,9 @@ unfreezeMetas -- Profiling: Count number of metas. - verboseS "profile.metas" 10 $ do - MetaId n <- fresh - tickN "metas" (fromIntegral n) + whenProfile Profile.Metas $ do + m <- fresh + tickN "metas" (fromIntegral (metaId m)) -- Highlighting from type checker. reportSLn "import.iface.create" 7 "Starting highlighting from type info." @@ -1112,13 +1154,13 @@ -- stMetaStore `setTCLens` savedMetaStore -- Profiling: Print statistics. - printStatistics 30 (Just mname) =<< getStatistics + printStatistics (Just mname) =<< getStatistics -- Get the statistics of the current module -- and add it to the accumulated statistics. localStatistics <- getStatistics lensAccumStatistics `modifyTCLens` Map.unionWith (+) localStatistics - verboseS "profile" 1 $ reportSLn "import.iface" 5 "Accumulated statistics." + reportSLn "import.iface" 5 "Accumulated statistics." isPrimitiveModule <- Lens.isPrimitiveModule (filePath srcPath) @@ -1158,7 +1200,7 @@ -> TCM Interface buildInterface src topLevel = do reportSLn "import.iface" 5 "Building interface..." - let mname = topLevelModuleName topLevel + let mname = CToA.topLevelModuleName topLevel source = srcText src fileType = srcFileType src defPragmas = srcDefaultPragmas src @@ -1174,20 +1216,23 @@ -- faster and interface file sizes a bit smaller, at least for the -- standard library). builtin <- useTC stLocalBuiltins - ms <- getImports - mhs <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms + mhs <- mapM (\top -> (top,) <$> moduleHash top) . + HSet.toList =<< + useR stImportedModules foreignCode <- useTC stForeignCode -- Ulf, 2016-04-12: -- Non-closed display forms are not applicable outside the module anyway, -- and should be dead-code eliminated (#1928). origDisplayForms <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms -- TODO: Kill some ranges? - (display, sig) <- eliminateDeadCode origDisplayForms =<< getSignature - userwarns <- useTC stLocalUserWarnings - importwarn <- useTC stWarningOnImport - syntaxInfo <- useTC stSyntaxInfo - optionsUsed <- useTC stPragmaOptions - partialDefs <- useTC stLocalPartialDefs + (display, sig, solvedMetas) <- + eliminateDeadCode builtin origDisplayForms ==<< + (getSignature, useR stSolvedMetaStore) + userwarns <- useTC stLocalUserWarnings + importwarn <- useTC stWarningOnImport + syntaxInfo <- useTC stSyntaxInfo + optionsUsed <- useTC stPragmaOptions + partialDefs <- useTC stLocalPartialDefs -- Andreas, 2015-02-09 kill ranges in pattern synonyms before -- serialization to avoid error locations pointing to external files @@ -1195,31 +1240,39 @@ patsyns <- killRange <$> getPatternSyns let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin warnings <- getAllWarnings AllWarnings - reportSLn "import.iface" 7 " instantiating all meta variables" - -- Note that the meta-variables in the definitions in "sig" have - -- already been instantiated (by eliminateDeadCode). - i <- instantiateFullExceptForDefinitions Interface - { iSourceHash = hashText source - , iSource = source - , iFileType = fileType - , iImportedModules = mhs - , iModuleName = mname - , iScope = empty -- publicModules scope - , iInsideScope = topLevelScope topLevel - , iSignature = sig - , iDisplayForms = display - , iUserWarnings = userwarns - , iImportWarning = importwarn - , iBuiltin = builtin' - , iForeignCode = foreignCode - , iHighlighting = syntaxInfo - , iDefaultPragmaOptions = defPragmas - , iFilePragmaOptions = filePragmas - , iOptionsUsed = optionsUsed - , iPatternSyns = patsyns - , iWarnings = warnings - , iPartialDefs = partialDefs - } + let i = Interface + { iSourceHash = hashText source + , iSource = source + , iFileType = fileType + , iImportedModules = mhs + , iModuleName = mname + , iTopLevelModuleName = srcModuleName src + , iScope = empty -- publicModules scope + , iInsideScope = topLevelScope topLevel + , iSignature = sig + , iMetaBindings = solvedMetas + , iDisplayForms = display + , iUserWarnings = userwarns + , iImportWarning = importwarn + , iBuiltin = builtin' + , iForeignCode = foreignCode + , iHighlighting = syntaxInfo + , iDefaultPragmaOptions = defPragmas + , iFilePragmaOptions = filePragmas + , iOptionsUsed = optionsUsed + , iPatternSyns = patsyns + , iWarnings = warnings + , iPartialDefs = partialDefs + } + i <- + ifM (collapseDefault . 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) reportSLn "import.iface" 7 " interface complete" return i @@ -1234,5 +1287,5 @@ maybe 0 (uncurry (+)) hs `seq` close return hs -moduleHash :: ModuleName -> TCM Hash -moduleHash m = iFullHash <$> getNonMainInterface (toTopLevelModuleName m) Nothing +moduleHash :: TopLevelModuleName -> TCM Hash +moduleHash m = iFullHash <$> getNonMainInterface m Nothing diff --git a/src/full/Agda/Interaction/Imports.hs-boot b/src/full/Agda/Interaction/Imports.hs-boot --- a/src/full/Agda/Interaction/Imports.hs-boot +++ b/src/full/Agda/Interaction/Imports.hs-boot @@ -5,6 +5,9 @@ import Agda.Syntax.Abstract.Name ( ModuleName ) import Agda.Syntax.Scope.Base ( Scope ) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.TypeChecking.Monad.Base ( TCM ) -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope) +scopeCheckImport :: + TopLevelModuleName -> ModuleName -> + TCM (ModuleName, Map ModuleName Scope) 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 @@ -25,7 +25,7 @@ import Control.Monad.Trans ( lift ) import qualified Data.Char as Char -import Data.Function +import Data.Function (on) import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe @@ -39,7 +39,7 @@ import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Rules.Term (checkExpr, isType_) import Agda.TypeChecking.Errors -import Agda.TypeChecking.Warnings (runPM) +import Agda.TypeChecking.Warnings (runPM, warning) import Agda.Syntax.Fixity import Agda.Syntax.Position @@ -53,8 +53,10 @@ import Agda.Syntax.Translation.ConcreteToAbstract import Agda.Syntax.Translation.AbstractToConcrete hiding (withScope) import Agda.Syntax.Scope.Base +import Agda.Syntax.TopLevelModuleName import Agda.Interaction.Base +import Agda.Interaction.ExitCode import Agda.Interaction.FindFile import Agda.Interaction.Options import Agda.Interaction.Options.Lenses as Lenses @@ -81,6 +83,7 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty hiding (Mode) +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.String import Agda.Utils.Time @@ -233,7 +236,7 @@ let handle e = Right <$> toIO (handleErr (Just Direct) $ - Exception noRange $ text $ show e) + Exception noRange $ text $ E.displayException e) asyncHandler e@AsyncCancelled = return (Left e) @@ -263,7 +266,8 @@ showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions - unless noError $ mapM_ putResponse $ + unless noError $ do + mapM_ putResponse $ [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] ++ tellEmacsToJumpToError (getRange e) ++ [ Resp_HighlightingInfo info KeepHighlighting @@ -272,6 +276,8 @@ , sShowImplicitArguments = showImpl , sShowIrrelevantArguments = showIrr } ] + whenM (optExitOnError <$> commandLineOptions) $ + liftIO $ exitAgdaWith TCMError -- | Run an 'IOTCM' value, catch the exceptions, emit output -- @@ -280,15 +286,17 @@ -- loaded interfaces for example). runInteraction :: IOTCM -> CommandM () -runInteraction (IOTCM current highlighting highlightingMethod cmd) = +runInteraction iotcm = handleCommand inEmacs onFail $ do currentAbs <- liftIO $ absolute current - -- Raises an error if the given file is not the one currently - -- loaded. - cf <- gets theCurrentFile - when (not (independent cmd) && Just currentAbs /= (currentFilePath <$> cf)) $ do + cf <- gets theCurrentFile + cmd <- if independent cmd then return cmd else do + when (Just currentAbs /= (currentFilePath <$> cf)) $ do let mode = TypeCheck cmd_load' current [] True mode $ \_ -> return () + cf <- fromMaybe __IMPOSSIBLE__ <$> gets theCurrentFile + return $ case iotcm (Just (currentFileModule cf)) of + IOTCM _ _ _ cmd -> cmd withCurrentFile $ interpret cmd @@ -299,6 +307,10 @@ putResponse . Resp_InteractionPoints =<< gets theInteractionPoints where + -- The ranges in cmd might be incorrect because of the use of + -- Nothing here. That is taken care of above. + IOTCM current highlighting highlightingMethod cmd = iotcm Nothing + inEmacs :: forall a. CommandM a -> CommandM a inEmacs = liftCommandMT $ withEnv $ initEnv { envHighlightingLevel = highlighting @@ -337,13 +349,14 @@ tcState <- getTC tcEnv <- askTC result <- liftIO $ race - (runTCM tcEnv tcState $ runStateT (m c) commandState) + (runTCM tcEnv tcState $ + runStateT (m c) commandState) (waitForAbort n q) case result of Left ((x, commandState'), tcState') -> do putTC tcState' put commandState' - case c of + case c Nothing of IOTCM _ _ _ Cmd_exit -> do putResponse Resp_DoneExiting return Done @@ -420,7 +433,7 @@ readCommands n = do c <- next case c of - Command (IOTCM _ _ _ Cmd_abort) -> do + Command c | IOTCM _ _ _ Cmd_abort <- c Nothing -> do atomically $ writeTVar abort (Just n) readCommands n _ -> do @@ -455,6 +468,7 @@ updateInteractionPointsAfter Cmd_compile{} = True updateInteractionPointsAfter Cmd_constraints{} = False updateInteractionPointsAfter Cmd_metas{} = False +updateInteractionPointsAfter Cmd_no_metas{} = False updateInteractionPointsAfter Cmd_show_module_contents_toplevel{} = False updateInteractionPointsAfter Cmd_search_about_toplevel{} = False updateInteractionPointsAfter Cmd_solveAll{} = True @@ -524,6 +538,11 @@ ms <- lift $ B.getGoals' norm (max Simplified norm) display_info . Info_AllGoalsWarnings ms =<< lift B.getWarningsAndNonFatalErrors +interpret Cmd_no_metas = do + metas <- getOpenMetas + unless (null metas) $ + typeError $ GenericError "Unsolved meta-variables" + interpret (Cmd_show_module_contents_toplevel norm s) = atTopLevel $ showModuleContents norm noRange s @@ -846,7 +865,7 @@ putResponse $ Resp_SolveAll out where prt (i, m, e) = do - mi <- getMetaInfo <$> lookupMeta m + mi <- getMetaInfo <$> lookupLocalMeta m e' <- withMetaInfo mi $ abstractToConcreteCtx TopCtx e return (i, e') @@ -907,9 +926,10 @@ -- choice of whether or not to display implicit arguments. opts0 <- gets optionsOnReload backends <- useTC stBackends - z <- runOptM $ parseBackendOptions backends argv opts0 + let (z, warns) = runOptM $ parseBackendOptions backends argv opts0 + mapM_ (lift . warning . OptionWarning) warns case z of - Left err -> lift $ typeError $ GenericError err + Left err -> lift $ typeError $ GenericError err Right (_, opts) -> do opts <- lift $ addTrustedExecutables opts let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o} @@ -928,7 +948,12 @@ when (t == t') $ do is <- lift $ sortInteractionPoints =<< getInteractionPoints modify $ \st -> st { theInteractionPoints = is - , theCurrentFile = Just $ CurrentFile fp argv t + , theCurrentFile = Just $ CurrentFile + { currentFilePath = fp + , currentFileModule = Imp.srcModuleName src + , currentFileArgs = argv + , currentFileStamp = t + } } cmd ok @@ -1091,10 +1116,10 @@ whyInScope :: String -> CommandM () whyInScope s = do - Just (CurrentFile file _ _) <- gets theCurrentFile - let cwd = takeDirectory (filePath file) - (v, xs, ms) <- liftLocalState (B.whyInScope s) - display_info $ Info_WhyInScope s cwd v xs ms + Just file <- gets theCurrentFile + let cwd = takeDirectory (filePath $ currentFilePath file) + why <- liftLocalState $ B.whyInScope cwd s + display_info $ Info_WhyInScope why -- | Sets the command line options and updates the status information. @@ -1118,16 +1143,13 @@ -- changed since. Note: This code does not check if any dependencies -- have changed, and uses a time stamp to check for changes. checked <- lift $ case cf of - Nothing -> return False - Just (CurrentFile f _ t) -> do - t' <- liftIO $ getModificationTime $ filePath f - if t == t' + Nothing -> return False + Just f -> do + t <- liftIO $ getModificationTime $ filePath (currentFilePath f) + if currentFileStamp f == t then - do - mm <- lookupModuleFromSource f - case mm of - Nothing -> return False -- work-around for Issue1007 - Just m -> maybe False (null . miWarnings) <$> getVisitedModule m + maybe False (null . miWarnings) <$> + getVisitedModule (currentFileModule f) else return False @@ -1164,13 +1186,14 @@ -> CommandM (Maybe CPUTime, a) parseAndDoAtToplevel cmd s = do localStateCommandM $ do - e <- lift $ runPM $ parse exprParser s + (e, coh) <- lift $ runPM $ parse exprParser s + lift $ checkCohesionAttributes coh maybeTimed $ atTopLevel $ lift $ cmd =<< concreteToAbstract_ e maybeTimed :: CommandM a -> CommandM (Maybe CPUTime, a) maybeTimed work = do - doTime <- lift $ hasVerbosity "profile.interactive" 10 + doTime <- lift $ hasProfileOption Profile.Interactive if not doTime then (Nothing,) <$> work else do @@ -1194,4 +1217,4 @@ Nothing -> [] Just (Pn { srcFile = Strict.Nothing }) -> [] Just (Pn { srcFile = Strict.Just f, posPos = p }) -> - [ Resp_JumpToError (filePath f) p ] + [ Resp_JumpToError (filePath (rangeFilePath f)) p ] 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 @@ -2,8 +2,10 @@ ( jsonREPL ) where -import Control.Monad ( (<=<), forM ) -import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad + ( (<=<), forM ) +import Control.Monad.IO.Class + ( MonadIO(..) ) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as BS @@ -12,31 +14,48 @@ import Agda.Interaction.AgdaTop import Agda.Interaction.Base - (CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..)) + ( CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..) ) import qualified Agda.Interaction.BasicOps as B import Agda.Interaction.EmacsTop import Agda.Interaction.JSON import Agda.Interaction.Response as R import Agda.Interaction.Highlighting.JSON -import Agda.Syntax.Abstract.Pretty (prettyATop) + +import Agda.Syntax.Abstract.Pretty + ( prettyATop ) import Agda.Syntax.Common import qualified Agda.Syntax.Concrete as C -import Agda.Syntax.Concrete.Name (NameInScope(..), Name) -import Agda.Syntax.Internal (telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock) -import Agda.Syntax.Position (Range, rangeIntervals, Interval'(..), Position'(..), noRange) -import Agda.VersionCommit +import Agda.Syntax.Concrete.Name + ( NameInScope(..), Name ) +import Agda.Syntax.Internal + ( telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock ) +import Agda.Syntax.Position + ( Range, rangeIntervals, Interval'(..), Position'(..), noRange ) +import Agda.Syntax.Scope.Base + ( WhyInScopeData(..) ) -import Agda.TypeChecking.Errors (getAllWarningsOfTCErr) -import Agda.TypeChecking.Monad (Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..), withInteractionId) -import Agda.TypeChecking.Monad.MetaVars (getInteractionRange, getMetaRange, withMetaId) -import Agda.TypeChecking.Pretty (PrettyTCM(..), prettyTCM) +import Agda.TypeChecking.Errors + ( getAllWarningsOfTCErr ) +import Agda.TypeChecking.Monad + ( Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..), withInteractionId ) +import Agda.TypeChecking.Monad.MetaVars + ( getInteractionRange, getMetaRange, withMetaId ) +import Agda.TypeChecking.Pretty + ( PrettyTCM(..), prettyTCM ) -- borrowed from EmacsTop, for temporarily serialising stuff -import Agda.TypeChecking.Pretty.Warning (filterTCWarnings) -import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors(..)) -import Agda.Utils.Pretty (Pretty(..)) +import Agda.TypeChecking.Pretty.Warning + ( filterTCWarnings ) +import Agda.TypeChecking.Warnings + ( WarningsAndNonFatalErrors(..) ) + import qualified Agda.Utils.Pretty as P -import Agda.Utils.Time (CPUTime(..)) +import Agda.Utils.Pretty + ( Pretty(..), prettyShow ) +import Agda.Utils.Time + ( CPUTime(..) ) +import Agda.VersionCommit + -------------------------------------------------------------------------------- -- | 'jsonREPL' is a interpreter like 'mimicGHCi', but outputs JSON-encoded strings. @@ -70,7 +89,7 @@ instance EncodeTCM CurrentFile where instance ToJSON CurrentFile where - toJSON (CurrentFile path _ time) = toJSON (path, time) -- backwards compat. + toJSON (CurrentFile path _ _ time) = toJSON (path, time) -- backwards compat. instance EncodeTCM ResponseContextEntry where encodeTCM entry = obj @@ -97,8 +116,16 @@ instance EncodeTCM MetaId where instance ToJSON ProblemId where toJSON (ProblemId i) = toJSON i -instance ToJSON MetaId where toJSON (MetaId i) = toJSON i +instance ToJSON ModuleNameHash where + toJSON (ModuleNameHash h) = toJSON h + +instance ToJSON MetaId where + toJSON m = object + [ "id" .= toJSON (metaId m) + , "module" .= toJSON (metaModule m) + ] + instance EncodeTCM InteractionId where encodeTCM ii@(InteractionId i) = obj [ "id" @= toJSON i @@ -223,6 +250,10 @@ , "type" #= encPrettyTCM a , "error" #= encodeTCM err ] + DataSort q s -> kind "DataSort" + [ "name" @= encodePretty q + , "sort" #= f s + ] CheckLock t lk -> kind "CheckLock" [ "head" #= f t , "lock" #= f lk @@ -249,6 +280,7 @@ instance EncodeTCM Blocker where encodeTCM (UnblockOnMeta x) = kind "UnblockOnMeta" [ "meta" @= x ] encodeTCM (UnblockOnProblem p) = kind "UnblockOnProblem" [ "id" @= p ] + encodeTCM (UnblockOnDef q) = kind "UnblockOnDef" [ "name" @= encodePretty q ] encodeTCM (UnblockOnAll us) = kind "UnblockOnAll" [ "blockers" @= Set.toList us ] encodeTCM (UnblockOnAny us) = kind "UnblockOnAny" [ "blockers" @= Set.toList us ] @@ -288,7 +320,7 @@ encodeDomType dom = obj [ "dom" #= encodePrettyTCM (unDom dom) , "name" @= fmap encodePretty (bareNameOf dom) - , "finite" @= toJSON (domFinite dom) + , "finite" @= toJSON (domIsFinite dom) , "cohesion" @= encodeShow (modCohesion . argInfoModality $ domInfo dom) , "relevance" @= encodeShow (modRelevance . argInfoModality $ domInfo dom) , "hiding" @= case argInfoHiding $ domInfo dom of @@ -299,11 +331,11 @@ [ "results" #= forM results encodeNamedPretty , "search" @= toJSON search ] - encodeTCM (Info_WhyInScope thing path v xs ms) = kind "WhyInScope" - [ "thing" @= thing + encodeTCM (Info_WhyInScope why@(WhyInScopeData y path _ _ _)) = kind "WhyInScope" + [ "thing" @= prettyShow y , "filepath" @= toJSON path -- use Emacs message first - , "message" #= explainWhyInScope thing path v xs ms + , "message" #= explainWhyInScope why ] encodeTCM (Info_NormalForm commandState computeMode time expr) = kind "NormalForm" [ "commandState" @= commandState @@ -425,7 +457,7 @@ where encodeSolution (i, expr) = object [ "interactionPoint" .= i - , "expression" .= show expr + , "expression" .= P.prettyShow expr ] -- | Convert Response to an JSON value for interactive editor frontends. 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedLists #-} + -- | Library management. -- -- Sample use: @@ -39,16 +41,16 @@ ) where import Control.Arrow ( first , second ) +import qualified Control.Exception as E import Control.Monad ( filterM, forM ) import Control.Monad.Except import Control.Monad.State -import Control.Monad.Writer +import Control.Monad.Writer ( Writer, runWriter, WriterT(WriterT), runWriterT, tell ) import Control.Monad.IO.Class ( MonadIO(..) ) import Data.Char -import Data.Data ( Data ) import Data.Either -import Data.Function +import Data.Function (on) import Data.Map ( Map ) import qualified Data.Map as Map import Data.Maybe ( catMaybes, fromMaybe ) @@ -58,6 +60,7 @@ import System.Directory import System.FilePath import System.Environment +import Text.Printf import Agda.Interaction.Library.Base import Agda.Interaction.Library.Parse @@ -69,11 +72,14 @@ import Agda.Utils.IO ( catchIO ) import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.List -import Agda.Utils.List1 ( List1 ) -import qualified Agda.Utils.List1 as List1 +import Agda.Utils.List1 ( List1, pattern (:|) ) +import Agda.Utils.List2 ( List2 ) +import qualified Agda.Utils.List1 as List1 +import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty +import Agda.Utils.Singleton import Agda.Utils.String ( trim ) import Agda.Version @@ -140,13 +146,13 @@ -- | The @~/.agda/libraries@ file lists the libraries Agda should know about. -- The content of @libraries@ is a list of paths to @.agda-lib@ files. -- --- Agda honors also version specific @libraries@ files, e.g. @libraries-2.6.0@. +-- Agda honors also version-specific @libraries@ files, e.g. @libraries-2.6.0@. -- -- @defaultLibraryFiles@ gives a list of all @libraries@ files Agda should process --- by default. +-- by default. The first file in this list that exists is actually used. -- defaultLibraryFiles :: List1 FilePath -defaultLibraryFiles = List1.fromList ["libraries-" ++ version, "libraries"] +defaultLibraryFiles = ("libraries-" ++ version) :| "libraries" : [] -- | The @defaultsFile@ contains a list of library names relevant for each Agda project. -- @@ -156,13 +162,13 @@ -- | The @~/.agda/executables@ file lists the executables Agda should know about. -- The content of @executables@ is a list of paths to executables. -- --- Agda honors also version specific @executables@ files, e.g. @executables-2.6.0@. +-- Agda honors also version-specific @executables@ files, e.g. @executables-2.6.0@. -- -- @defaultExecutablesFiles@ gives a list of all @executables@ Agda should process --- by default. +-- by default. The first file in this list that exists is actually used. -- defaultExecutableFiles :: List1 FilePath -defaultExecutableFiles = List1.fromList ["executables-" ++ version, "executables"] +defaultExecutableFiles = ("executables-" ++ version) :| "executables" : [] ------------------------------------------------------------------------ -- * Get the libraries for the current project @@ -263,7 +269,7 @@ ls <- liftIO $ map snd . stripCommentLines <$> UTF8.readFile file return $ concatMap splitCommas ls `catchIO` \ e -> do - raiseErrors' [ OtherError $ unlines ["Failed to read defaults file.", show e] ] + raiseErrors' [ ReadError e "Failed to read defaults file." ] return [] ------------------------------------------------------------------------ @@ -274,15 +280,17 @@ -- -- Note: file may not exist. -- +-- If the user specified an alternative @libraries@ file which does not exist, +-- an exception is thrown containing the name of this file. getLibrariesFile - :: (MonadIO m, MonadError String m) + :: (MonadIO m, MonadError FilePath m) => Maybe FilePath -- ^ Override the default @libraries@ file? -> m LibrariesFile getLibrariesFile (Just overrideLibFile) = do -- A user-specified override file must exist. ifM (liftIO $ doesFileExist overrideLibFile) {-then-} (return $ LibrariesFile overrideLibFile True) - {-else-} (throwError $ "Libraries file not found: " ++ overrideLibFile) + {-else-} (throwError overrideLibFile) getLibrariesFile Nothing = do agdaDir <- liftIO $ getAgdaAppDir let defaults = List1.map (agdaDir ) defaultLibraryFiles -- NB: very short list @@ -301,14 +309,16 @@ getInstalledLibraries overrideLibFile = mkLibM [] $ do filem <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile case filem of - Left err -> raiseErrors' [OtherError err] >> return [] + Left theOverrideLibFile -> do + raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ] + return [] Right file -> do if not (lfExists file) then return [] else do ls <- liftIO $ stripCommentLines <$> UTF8.readFile (lfPath file) files <- liftIO $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- ls ] parseLibFiles (Just file) $ nubOn snd files `catchIO` \ e -> do - raiseErrors' [ OtherError $ unlines ["Failed to read installed libraries.", show e] ] + raiseErrors' [ ReadError e "Failed to read installed libraries." ] return [] -- | Parse the given library files. @@ -336,9 +346,9 @@ let (xs, warns) = unzip anns (errs, als) = partitionEithers xs - unless (null warns) $ warnings $ concat warns - unless (null errs) $ - raiseErrors $ map (\(mc,s) -> LibError mc $ OtherError s) errs + List1.unlessNull (concat warns) warnings + List1.unlessNull errs $ \ errs1 -> + raiseErrors $ fmap (\ (mc, err) -> LibError mc $ LibParseError err) errs1 return $ nubOn _libFile als @@ -378,7 +388,7 @@ tmp <- parseExecutablesFile file $ nubOn snd files return tmp `catchIO` \ e -> do - raiseErrors' [ OtherError $ unlines ["Failed to read trusted executables.", show e] ] + raiseErrors' [ ReadError e "Failed to read trusted executables." ] return Map.empty -- | Parse the @executables@ file. @@ -387,16 +397,29 @@ :: ExecutablesFile -> [(LineNumber, FilePath)] -> LibErrorIO (Map ExeName FilePath) -parseExecutablesFile ef files = - fmap (Map.fromList . catMaybes) . forM files $ \(ln, fp) -> do - +parseExecutablesFile ef files = do + executables <- forM files $ \(ln, fp) -> do -- Compute canonical executable name and absolute filepath. let strExeName = takeFileName fp let strExeName' = fromMaybe strExeName $ stripExtension exeExtension strExeName let txtExeName = T.pack strExeName' exePath <- liftIO $ makeAbsolute fp - return $ Just (txtExeName, exePath) + return (txtExeName, exePath) + -- Create a map from executable names to their location(s). + let exeMap1 :: Map ExeName (List1 FilePath) + exeMap1 = Map.fromListWith (<>) $ map (second singleton) executables + + -- Separate non-ambiguous from ambiguous mappings. + let (exeMap, duplicates) = Map.mapEither List2.fromList1Either exeMap1 + + -- Report ambiguous mappings. + List1.unlessNull (Map.toList duplicates) $ \ duplicates1 -> + raiseErrors' $ fmap (uncurry $ DuplicateExecutable $ efPath ef) duplicates1 + + -- Return non-ambiguous mappings. + return exeMap + ------------------------------------------------------------------------ -- * Resolving library names to include pathes ------------------------------------------------------------------------ @@ -407,11 +430,13 @@ -> [AgdaLibFile] -- ^ Libraries Agda knows about. -> [LibName] -- ^ (Non-empty) library names to be resolved to (lists of) pathes. -> LibM [FilePath] -- ^ Resolved pathes (no duplicates). Contains "." if @[LibName]@ does. -libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ WriterT $ do +libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ do efile <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile case efile of - Left err -> return ([], [Left $ LibError Nothing $ OtherError err]) - Right file -> return $ runWriter $ (dot ++) . incs <$> find file [] xs + Left theOverrideLibFile -> do + raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ] + return [] + Right file -> embedWriter $ (dot ++) . incs <$> find file [] xs where (dots, xs) = List.partition (== libNameForCurrentDir) $ map trim xs0 incs = nubOn id . concatMap _libIncludes @@ -422,7 +447,7 @@ :: LibrariesFile -- Only for error reporting. -> [LibName] -- Already resolved libraries. -> [LibName] -- Work list: libraries left to be resolved. - -> Writer [Either LibError LibWarning] [AgdaLibFile] + -> Writer LibErrWarns [AgdaLibFile] find _ _ [] = pure [] find file visited (x : xs) | x `elem` visited = find file visited xs 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 @@ -2,21 +2,24 @@ module Agda.Interaction.Library.Base where -import Control.Arrow ( first , second ) +import Prelude hiding (null) + import Control.DeepSeq +import qualified Control.Exception as E + import Control.Monad.Except import Control.Monad.State -import Control.Monad.Writer -import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Writer ( WriterT, MonadWriter, tell ) +import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Char ( isDigit ) -import Data.Data ( Data ) -import qualified Data.List as List -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Text ( Text ) +import Data.Bifunctor ( first , second ) +import Data.Char ( isDigit ) +import qualified Data.List as List +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Text ( Text, unpack ) -import GHC.Generics (Generic) +import GHC.Generics ( Generic ) import System.Directory import System.FilePath @@ -25,6 +28,9 @@ import Agda.Utils.FileName import Agda.Utils.Lens +import Agda.Utils.List1 ( List1, toList ) +import Agda.Utils.List2 ( List2, toList ) +import Agda.Utils.Null import Agda.Utils.Pretty -- | A symbolic library name. @@ -49,7 +55,7 @@ , efExists :: Bool -- ^ The executables file might not exist, -- but we may print its assumed location in error messages. - } deriving (Show, Data, Generic) + } deriving (Show, Generic) -- | The special name @\".\"@ is used to indicated that the current directory -- should count as a project root. @@ -110,70 +116,123 @@ -- * Library warnings and errors ------------------------------------------------------------------------ +-- ** Position information + type LineNumber = Int +-- | Information about which @.agda-lib@ file we are reading +-- and from where in the @libraries@ file it came from. + data LibPositionInfo = LibPositionInfo - { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file + { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file. , lineNumPos :: LineNumber -- ^ Line number in @libraries@ file. - , filePos :: FilePath -- ^ Library file + , filePos :: FilePath -- ^ Library file. } - deriving (Show, Data, Generic) + deriving (Show, Generic) +-- ** Warnings + data LibWarning = LibWarning (Maybe LibPositionInfo) LibWarning' - deriving (Show, Data, Generic) + deriving (Show, Generic) -- | Library Warnings. data LibWarning' = UnknownField String - deriving (Show, Data, Generic) - -data LibError = LibError (Maybe LibPositionInfo) LibError' + deriving (Show, Generic) libraryWarningName :: LibWarning -> WarningName libraryWarningName (LibWarning c (UnknownField{})) = LibUnknownField_ +-- * Errors + +data LibError = LibError (Maybe LibPositionInfo) LibError' + -- | Collected errors while processing library files. -- data LibError' - = LibNotFound LibrariesFile LibName + = LibrariesFileNotFound FilePath + -- ^ The user specified replacement for the default @libraries@ file does not exist. + | LibNotFound LibrariesFile LibName -- ^ Raised when a library name could not successfully be resolved -- to an @.agda-lib@ file. -- | AmbiguousLib LibName [AgdaLibFile] -- ^ Raised when a library name is defined in several @.agda-lib files@. - | OtherError String - -- ^ Generic error. - deriving (Show) + | LibParseError LibParseError + -- ^ The @.agda-lib@ file could not be parsed. + | ReadError + -- ^ An I/O Error occurred when reading a file. + E.IOException + -- ^ The caught exception + String + -- ^ Explanation when this error occurred. + | DuplicateExecutable + -- ^ The @executables@ file contains duplicate entries. + FilePath + -- ^ Name of the @executables@ file. + Text + -- ^ Name of the executable that is defined twice. + (List2 FilePath) + -- ^ The resolutions of the executable. + -- deriving (Show) --- | Cache locations of project configurations and parsed .agda-lib files -type LibState = - ( Map FilePath ProjectConfig - , Map FilePath AgdaLibFile - ) +-- | Exceptions thrown by the @.agda-lib@ parser. +-- +data LibParseError + = BadLibraryName String + -- ^ An invalid library name, e.g., containing spaces. + | ReadFailure FilePath E.IOException + -- ^ I/O error while reading file. + | MissingFields (List1 String) + -- ^ Missing these mandatory fields. + | DuplicateFields (List1 String) + -- ^ These fields occur each more than once. + | MissingFieldName LineNumber + -- ^ At the given line number, a field name is missing before the @:@. + | BadFieldName LineNumber String + -- ^ At the given line number, an invalid field name is encountered before the @:@. + -- (E.g., containing spaces.) + | MissingColonForField LineNumber String + -- ^ At the given line number, the given field is not followed by @:@. + | ContentWithoutField LineNumber + -- ^ At the given line number, indented text (content) is not preceded by a field. --- | Collects 'LibError's and 'LibWarning's. +-- ** Raising warnings and errors + +-- | Collection of 'LibError's and 'LibWarning's. -- -type LibErrorIO = WriterT [Either LibError LibWarning] (StateT LibState IO) +type LibErrWarns = [Either LibError LibWarning] --- | Throws 'Doc' exceptions, still collects 'LibWarning's. -type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO)) +warnings :: MonadWriter LibErrWarns m => List1 LibWarning -> m () +warnings = tell . map Right . toList -warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m () -warnings = tell . map Right +warnings' :: MonadWriter LibErrWarns m => List1 LibWarning' -> m () +warnings' = tell . map (Right . LibWarning Nothing) . toList -warnings' :: MonadWriter [Either LibError LibWarning] m => [LibWarning'] -> m () -warnings' = tell . map (Right . LibWarning Nothing) +raiseErrors' :: MonadWriter LibErrWarns m => List1 LibError' -> m () +raiseErrors' = tell . map (Left . (LibError Nothing)) . toList --- UNUSED Liang-Ting Chen 2019-07-16 ---warning :: MonadWriter [Either LibError LibWarning] m => LibWarning -> m () ---warning = warnings . pure +raiseErrors :: MonadWriter LibErrWarns m => List1 LibError -> m () +raiseErrors = tell . map Left . toList -raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m () -raiseErrors' = tell . map (Left . (LibError Nothing)) -raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m () -raiseErrors = tell . map Left +------------------------------------------------------------------------ +-- * Library Monad +------------------------------------------------------------------------ +-- | Collects 'LibError's and 'LibWarning's. +-- +type LibErrorIO = WriterT LibErrWarns (StateT LibState IO) + +-- | Throws 'Doc' exceptions, still collects 'LibWarning's. +type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO)) + +-- | Cache locations of project configurations and parsed @.agda-lib@ files. +type LibState = + ( Map FilePath ProjectConfig + , Map FilePath AgdaLibFile + ) + getCachedProjectConfig :: (MonadState LibState m, MonadIO m) => FilePath -> m (Maybe ProjectConfig) @@ -207,35 +266,89 @@ -- * Prettyprinting errors and warnings ------------------------------------------------------------------------ -formatLibPositionInfo :: LibPositionInfo -> String -> Doc -formatLibPositionInfo (LibPositionInfo libFile lineNum file) err = text $ - let loc | Just lf <- libFile = lf ++ ":" ++ show lineNum ++ ": " - | otherwise = "" - in if "Failed to read" `List.isPrefixOf` err - then loc - else file ++ ":" ++ (if all isDigit (take 1 err) then "" else " ") - -- | Pretty-print 'LibError'. formatLibError :: [AgdaLibFile] -> LibError -> Doc -formatLibError installed (LibError mc e) = prefix <+> body where - prefix = case mc of - Nothing -> "" - Just c | OtherError err <- e -> formatLibPositionInfo c err - _ -> "" +formatLibError installed (LibError mc e) = + case (mc, e) of + (Just c, LibParseError err) -> sep [ formatLibPositionInfo c err, pretty e ] + (_ , LibNotFound{} ) -> vcat [ pretty e, prettyInstalledLibraries installed ] + _ -> pretty e - body = case e of +-- | Does a parse error contain a line number? +hasLineNumber :: LibParseError -> Maybe LineNumber +hasLineNumber = \case + BadLibraryName _ -> Nothing + ReadFailure _ _ -> Nothing + MissingFields _ -> Nothing + DuplicateFields _ -> Nothing + MissingFieldName l -> Just l + BadFieldName l _ -> Just l + MissingColonForField l _ -> Just l + ContentWithoutField l -> Just l + +-- UNUSED: +-- -- | Does a parse error contain the name of the parsed file? +-- hasFilePath :: LibParseError -> Maybe FilePath +-- hasFilePath = \case +-- BadLibraryName _ -> Nothing +-- ReadFailure f _ -> Just f +-- MissingFields _ -> Nothing +-- DuplicateFields _ -> Nothing +-- MissingFieldName _ -> Nothing +-- BadFieldName _ _ -> Nothing +-- MissingColonForField _ _ -> Nothing +-- ContentWithoutField _ -> Nothing + +-- | Compute a position position prefix. +-- +-- Depending on the error to be printed, it will +-- +-- - either give the name of the @libraries@ file and a line inside it, +-- +-- - or give the name of the @.agda-lib@ file. +-- +formatLibPositionInfo :: LibPositionInfo -> LibParseError -> Doc +formatLibPositionInfo (LibPositionInfo libFile lineNum file) = \case + + -- If we couldn't even read the @.agda-lib@ file, report error in the @libraries@ file. + ReadFailure _ _ + | Just lf <- libFile + -> hcat [ text lf, ":", pretty lineNum, ":" ] + | otherwise + -> empty + + -- If the parse error comes with a line number, print it here. + e | Just l <- hasLineNumber e + -> hcat [ text file, ":", pretty l, ":" ] + | otherwise + -> hcat [ text file, ":" ] + +prettyInstalledLibraries :: [AgdaLibFile] -> Doc +prettyInstalledLibraries installed = + vcat $ ("Installed libraries:" :) $ + map (nest 2) $ + if null installed then ["(none)"] + else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ] + | l <- installed + ] + +-- | Pretty-print library management error without position info. + +instance Pretty LibError' where + pretty = \case + + LibrariesFileNotFound path -> sep + [ text "Libraries file not found:" + , text path + ] + LibNotFound file lib -> vcat $ [ text $ "Library '" ++ lib ++ "' not found." , sep [ "Add the path to its .agda-lib file to" , nest 2 $ text $ "'" ++ lfPath file ++ "'" , "to install." ] - , "Installed libraries:" - ] ++ - map (nest 2) - (if null installed then ["(none)"] - else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ] - | l <- installed ]) + ] AmbiguousLib lib tgts -> vcat $ sep [ text $ "Ambiguous library '" ++ lib ++ "'." @@ -243,16 +356,51 @@ ] : [ nest 2 $ text (_libName l) <+> parens (text $ _libFile l) | l <- tgts ] + LibParseError err -> pretty err - OtherError err -> text err + ReadError e msg -> vcat + [ text $ msg + , text $ E.displayException e + ] -instance Pretty LibWarning where - pretty (LibWarning mc w) = prefix <+> pretty w + DuplicateExecutable exeFile exe paths -> vcat $ + hcat [ "Duplicate entries for executable '", (text . unpack) exe, "' in ", text exeFile, ":" ] : + map (nest 2 . ("-" <+>) . text) (toList paths) + +-- | Print library file parse error without position info. +-- +instance Pretty LibParseError where + pretty = \case + + BadLibraryName s -> sep + [ "Bad library name:", quotes (text s) ] + ReadFailure file e -> vcat + [ hsep [ "Failed to read library file", text file <> "." ] + , "Reason:" <+> text (E.displayException e) + ] + + MissingFields xs -> "Missing" <+> listFields xs + DuplicateFields xs -> "Duplicate" <+> listFields xs + + MissingFieldName l -> atLine l $ "Missing field name" + BadFieldName l s -> atLine l $ "Bad field name" <+> text (show s) + MissingColonForField l s -> atLine l $ "Missing ':' for field " <+> text (show s) + ContentWithoutField l -> atLine l $ "Missing field" + where - prefix = case mc of - Nothing -> "" - Just c -> formatLibPositionInfo c "" + listFields xs = hsep $ fieldS xs : list xs + fieldS xs = singPlural xs "field:" "fields:" + list = punctuate comma . map (quotes . text) . toList + atLine l = id + -- The line number will be printed by 'formatLibPositionInfo'! + -- atLine l doc = hsep [ text (show l) <> ":", doc ] + +instance Pretty LibWarning where + pretty (LibWarning mc w) = + case mc of + Nothing -> pretty w + Just (LibPositionInfo _ _ file) -> hcat [ text file, ":"] <+> pretty w instance Pretty LibWarning' where pretty (UnknownField s) = text $ "Unknown field '" ++ s ++ "'" diff --git a/src/full/Agda/Interaction/Library/Parse.hs b/src/full/Agda/Interaction/Library/Parse.hs --- a/src/full/Agda/Interaction/Library/Parse.hs +++ b/src/full/Agda/Interaction/Library/Parse.hs @@ -29,28 +29,30 @@ , runP ) where +import qualified Control.Exception as E import Control.Monad import Control.Monad.Except import Control.Monad.Writer import Data.Char -import Data.Data import qualified Data.List as List import System.FilePath import Agda.Interaction.Library.Base import Agda.Utils.Applicative -import Agda.Utils.IO ( catchIO ) +import Agda.Utils.IO ( catchIO ) import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Lens -import Agda.Utils.List ( duplicates ) -import Agda.Utils.String ( ltrim ) +import Agda.Utils.List ( duplicates ) +import Agda.Utils.List1 ( List1, toList ) +import qualified Agda.Utils.List1 as List1 +import Agda.Utils.String ( ltrim ) --- | Parser monad: Can throw @String@ error messages, and collects +-- | Parser monad: Can throw @LibParseError@s, and collects -- @LibWarning'@s library warnings. -type P = ExceptT String (Writer [LibWarning']) +type P = ExceptT LibParseError (Writer [LibWarning']) -runP :: P a -> (Either String a, [LibWarning']) +runP :: P a -> (Either LibParseError a, [LibWarning']) runP = runWriter . runExceptT warningP :: LibWarning' -> P () @@ -89,7 +91,7 @@ where parseName :: [String] -> P LibName parseName [s] | [name] <- words s = pure name - parseName ls = throwError $ "Bad library name: '" ++ unwords ls ++ "'" + parseName ls = throwError $ BadLibraryName $ unwords ls parsePaths :: String -> [FilePath] parsePaths = go id where @@ -111,10 +113,7 @@ parseLibFile :: FilePath -> IO (P AgdaLibFile) parseLibFile file = (fmap setPath . parseLib <$> UTF8.readFile file) `catchIO` \e -> - return $ throwError $ unlines - [ "Failed to read library file " ++ file ++ "." - , "Reason: " ++ show e - ] + return $ throwError $ ReadFailure file e where setPath lib = unrelativise (takeDirectory file) (set libFile file lib) unrelativise dir = over libIncludes (map (dir )) @@ -150,16 +149,15 @@ -- | Ensure that there are no duplicate fields and no mandatory fields are missing. checkFields :: [Field] -> [String] -> P () checkFields fields fs = do - let mandatory = [ fName f | f <- fields, not $ fOptional f ] - -- Missing fields. - missing = mandatory List.\\ fs - -- Duplicate fields. - dup = duplicates fs - -- Plural s for error message. - s xs = if length xs > 1 then "s" else "" - list xs = List.intercalate ", " [ "'" ++ f ++ "'" | f <- xs ] - unless (null missing) $ throwError $ "Missing field" ++ s missing ++ " " ++ list missing - unless (null dup) $ throwError $ "Duplicate field" ++ s dup ++ " " ++ list dup + -- Report missing mandatory fields. + () <- List1.unlessNull missing $ throwError . MissingFields + -- Report duplicate fields. + List1.unlessNull (duplicates fs) $ throwError . DuplicateFields + where + mandatory :: [String] + mandatory = [ fName f | f <- fields, not $ fOptional f ] + missing :: [String] + missing = mandatory List.\\ fs -- | Find 'Field' with given 'fName', throw error if unknown. findField :: String -> [Field] -> P (Maybe Field) @@ -227,17 +225,17 @@ (h, ':' : r) -> case words h of [h] -> pure $ Header l h : [Content l r' | let r' = ltrim r, not (null r')] - [] -> throwError $ show l ++ ": Missing field name" - hs -> throwError $ show l ++ ": Bad field name " ++ show h - _ -> throwError $ show l ++ ": Missing ':' for field " ++ show (ltrim s) + [] -> throwError $ MissingFieldName l + hs -> throwError $ BadFieldName l h + _ -> throwError $ MissingColonForField l (ltrim s) -- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'. -- --- Tailing 'Content's? That's an error. +-- Leading 'Content's? That's an error. -- groupLines :: [GenericLine] -> P GenericFile groupLines [] = pure [] -groupLines (Content l c : _) = throwError $ show l ++ ": Missing field" +groupLines (Content l c : _) = throwError $ ContentWithoutField l groupLines (Header _ h : ls) = (GenericEntry h [ c | Content _ c <- cs ] :) <$> groupLines ls1 where (cs, ls1) = span isContent ls @@ -250,7 +248,7 @@ -- | Break a comma-separated string. Result strings are @trim@med. splitCommas :: String -> [String] -splitCommas s = words $ map (\c -> if c == ',' then ' ' else c) s +splitCommas = words . map (\c -> if c == ',' then ' ' else c) -- | ...and trailing, but not leading, whitespace. stripComments :: String -> String 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 @@ -2,12 +2,12 @@ module Agda.Interaction.MakeCase where -import Prelude hiding (null) +import Prelude hiding ((!!), null) import Control.Monad import Data.Either -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Monoid @@ -76,7 +76,7 @@ -- Get into the context of the meta. mId <- lookupInteractionId ii updateMetaVarRange mId rng - mi <- getMetaInfo <$> lookupMeta mId + mi <- getMetaInfo <$> lookupLocalMeta mId enterClosure mi $ \ r -> do reportSDoc "interaction.case" 20 $ do @@ -223,18 +223,19 @@ recheckAbstractClause :: Type -> Maybe Substitution -> A.SpineClause -> TCM (Clause, Context, [AsBinding]) recheckAbstractClause t sub acl = checkClauseLHS t sub acl $ \ lhs -> do - let cl = Clause{ clauseLHSRange = getRange acl - , clauseFullRange = getRange acl - , clauseTel = lhsVarTele lhs - , namedClausePats = lhsPatterns lhs - , clauseBody = Nothing -- We don't need the body for make case - , clauseType = Just (lhsBodyType lhs) - , clauseCatchall = False - , clauseExact = Nothing - , clauseRecursive = Nothing - , clauseUnreachable = Nothing - , clauseEllipsis = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl - } + let cl = Clause { clauseLHSRange = getRange acl + , clauseFullRange = getRange acl + , clauseTel = lhsVarTele lhs + , namedClausePats = lhsPatterns lhs + , clauseBody = Nothing -- We don't need the body for make case + , clauseType = Just (lhsBodyType lhs) + , clauseCatchall = False + , clauseExact = Nothing + , clauseRecursive = Nothing + , clauseUnreachable = Nothing + , clauseEllipsis = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl + , clauseWhereModule = A.whereModule $ A.clauseWhereDecls acl + } cxt <- getContext let asb = lhsAsBindings lhs return (cl, cxt, asb) @@ -501,15 +502,25 @@ , "ell =" <+> text (show ell) ] ] - withCurrentModule (qnameModule f) $ do + withCurrentModule (qnameModule f) $ -- Andreas, 2015-05-29 Issue 635 -- Contract implicit record patterns before printing. -- c <- translateRecordPatterns $ Clause noRange tel perm ps NoBody t False -- Jesper, 2015-09-19 Don't contract, since we do on-demand splitting - let c = Clause noRange noRange tel ps Nothing (argFromDom <$> t) False Nothing Nothing Nothing ell - let ps = namedClausePats c - inTopContext $ reify $ QNamed f $ c { namedClausePats = ps } - + inTopContext $ reify $ QNamed f $ Clause + { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = tel + , namedClausePats = ps + , clauseBody = Nothing + , clauseType = argFromDom <$> t + , clauseCatchall = False + , clauseExact = Nothing + , clauseRecursive = Nothing + , clauseUnreachable = Nothing + , clauseEllipsis = ell + , clauseWhereModule = Nothing + } -- | Make a clause with a question mark as rhs. 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 @@ -5,6 +5,7 @@ ( CommandLineOptions(..) , PragmaOptions(..) , OptionsPragma + , OptionWarning(..), optionWarningName , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..) , Verbosity, VerboseKey, VerboseLevel , WarningMode(..) @@ -13,17 +14,18 @@ , checkOpts , parsePragmaOptions , parsePluginOptions + , parseVerboseKey , stripRTS , defaultOptions , defaultInteractionOptions - , defaultVerbosity , defaultCutOff , defaultPragmaOptions , standardOptions_ , unsafePragmaOptions - , restartOptions - , infectiveOptions - , coinfectiveOptions + , recheckBecausePragmaOptionsChanged + , InfectiveCoinfective(..) + , InfectiveCoinfectiveOption(..) + , infectiveCoinfectiveOptions , safeFlag , mapFlag , usage @@ -33,9 +35,12 @@ , getOptSimple ) where +import Prelude hiding ( null ) + import Control.DeepSeq import Control.Monad ( when, void ) -import Control.Monad.Except ( Except, MonadError(throwError), runExcept ) +import Control.Monad.Except ( ExceptT, MonadError(throwError), runExceptT ) +import Control.Monad.Writer ( Writer, runWriter, MonadWriter(..) ) import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO) import Data.Maybe @@ -64,24 +69,41 @@ import Agda.Interaction.Options.Warnings import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) ) import Agda.Syntax.Common (Cubical(..)) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.FileName ( AbsolutePath ) import Agda.Utils.Functor ( (<&>) ) import Agda.Utils.Lens ( Lens', over ) -import Agda.Utils.List ( groupOn, initLast1, wordsBy ) -import Agda.Utils.Pretty ( singPlural ) +import Agda.Utils.List ( groupOn, initLast1 ) +import Agda.Utils.List1 ( String1, toList ) +import qualified Agda.Utils.List1 as List1 +import qualified Agda.Utils.Maybe.Strict as Strict +import Agda.Utils.Monad ( tell1 ) +import Agda.Utils.Null +import Agda.Utils.Pretty +import Agda.Utils.ProfileOptions import Agda.Utils.Trie ( Trie ) import qualified Agda.Utils.Trie as Trie import Agda.Utils.WithDefault +import Agda.Utils.Impossible + import Agda.Version -- OptDescr is a Functor -------------------------------------------------- -type VerboseKey = String -type VerboseLevel = Int -type Verbosity = Trie VerboseKey VerboseLevel +type VerboseKey = String +type VerboseKeyItem = String1 +type VerboseLevel = Int +-- | 'Strict.Nothing' is used if no verbosity options have been given, +-- thus making it possible to handle the default case relatively +-- quickly. Note that 'Strict.Nothing' corresponds to a trie with +-- verbosity level 1 for the empty path. +type Verbosity = Strict.Maybe (Trie VerboseKeyItem VerboseLevel) +parseVerboseKey :: VerboseKey -> [VerboseKeyItem] +parseVerboseKey = List1.wordsBy (`elem` ['.', ':']) + -- Don't forget to update -- doc/user-manual/tools/command-line-options.rst -- if you make changes to the command-line options! @@ -99,7 +121,7 @@ -- ^ Use ~/.agda/defaults , optUseLibs :: Bool -- ^ look for .agda-lib files - , optTrustedExecutables :: Map ExeName FilePath + , optTrustedExecutables :: Map ExeName FilePath -- ^ Map names of trusted executables to absolute paths , optPrintAgdaDir :: Bool , optPrintVersion :: Bool @@ -108,7 +130,8 @@ -- ^ Agda REPL (-I). , optGHCiInteraction :: Bool , optJSONInteraction :: Bool - , optOptimSmashing :: Bool + , optExitOnError :: !Bool + -- ^ Exit if an interactive command fails. , optCompileDir :: Maybe FilePath -- ^ In the absence of a path the project root is used. , optGenerateVimFile :: Bool @@ -119,6 +142,8 @@ , optOnlyScopeChecking :: Bool -- ^ Should the top-level module only be scope-checked, and not -- type-checked? + , optTransliterate :: Bool + -- ^ Should code points that are not supported by the locale be transliterated? } deriving (Show, Generic) @@ -130,7 +155,8 @@ { optShowImplicit :: Bool , optShowIrrelevant :: Bool , optUseUnicode :: UnicodeOrAscii - , optVerbose :: Verbosity + , optVerbose :: !Verbosity + , optProfiling :: ProfileOptions , optProp :: Bool , optTwoLevel :: WithDefault 'False , optAllowUnsolved :: Bool @@ -139,10 +165,8 @@ , optTerminationCheck :: Bool , optTerminationDepth :: CutOff -- ^ Cut off structural order comparison at some depth in termination checker? - , optCompletenessCheck :: Bool , optUniverseCheck :: Bool , optOmegaInOmega :: Bool - , optSubtyping :: WithDefault 'False , optCumulativity :: Bool , optSizedTypes :: WithDefault 'False , optGuardedness :: WithDefault 'False @@ -151,12 +175,14 @@ , optIrrelevantProjections :: Bool , optExperimentalIrrelevance :: Bool -- ^ irrelevant levels, irrelevant data matching , optWithoutK :: WithDefault 'False + , optCubicalCompatible :: WithDefault 'False , optCopatterns :: Bool -- ^ Allow definitions by copattern matching? , optPatternMatching :: Bool -- ^ Is pattern matching allowed in the current file? , optExactSplit :: Bool , optEta :: Bool , optForcing :: Bool -- ^ Perform the forcing analysis on data constructors? , optProjectionLike :: Bool -- ^ Perform the projection-likeness analysis on functions? + , optEraseRecordParameters :: Bool -- ^ Mark parameters of record modules as erased? , optRewriting :: Bool -- ^ Can rewrite rules be added and used? , optCubical :: Maybe Cubical , optGuarded :: Bool @@ -173,7 +199,14 @@ , optInversionMaxDepth :: Int , optSafe :: Bool , optDoubleCheck :: Bool - , optSyntacticEquality :: Bool -- ^ Should conversion checker use syntactic equality shortcut? + , optSyntacticEquality :: !(Strict.Maybe Int) + -- ^ Should the conversion checker use the syntactic equality + -- shortcut? 'Nothing' means that it should. @'Just' n@, for a + -- non-negative number @n@, means that syntactic equality checking + -- gets @n@ units of fuel. If the fuel becomes zero, then + -- syntactic equality checking is turned off. The fuel counter is + -- decreased in the failure continuation of + -- 'Agda.TypeChecking.SyntacticEquality.checkSyntacticEquality'. , optWarningMode :: WarningMode , optCompileNoMain :: Bool , optCaching :: Bool @@ -190,15 +223,25 @@ -- ^ Use call-by-name instead of call-by-need , optConfluenceCheck :: Maybe ConfluenceCheck -- ^ Check confluence of rewrite rules? - , optFlatSplit :: Bool + , optCohesion :: Bool + -- ^ Are the cohesion modalities available? + , optFlatSplit :: WithDefault 'False -- ^ Can we split on a (@flat x : A) argument? , optImportSorts :: Bool -- ^ Should every top-level module start with an implicit statement -- @open import Agda.Primitive using (Set; Prop)@? + , optLoadPrimitives :: Bool + -- ^ Should we load the primitive modules at all? This is a stronger + -- form of 'optImportSorts'. , optAllowExec :: Bool + , optSaveMetas :: WithDefault 'False + -- ^ Save meta-variables. , optShowIdentitySubstitutions :: Bool -- ^ Show identity substitutions when pretty-printing terms -- (i.e. always show all arguments of a metavariable) + , optKeepCoveringClauses :: Bool + -- ^ Do not discard clauses constructed by the coverage checker + -- (needed for some external backends) } deriving (Show, Eq, Generic) @@ -223,9 +266,6 @@ mapFlag :: (String -> String) -> OptDescr a -> OptDescr a mapFlag f (Option _ long arg descr) = Option [] (map f long) arg descr -defaultVerbosity :: Verbosity -defaultVerbosity = Trie.singleton [] 1 - defaultInteractionOptions :: PragmaOptions defaultInteractionOptions = defaultPragmaOptions @@ -246,7 +286,7 @@ , optInteractive = False , optGHCiInteraction = False , optJSONInteraction = False - , optOptimSmashing = True + , optExitOnError = False , optCompileDir = Nothing , optGenerateVimFile = False , optIgnoreInterfaces = False @@ -254,6 +294,7 @@ , optLocalInterfaces = False , optPragmaOptions = defaultPragmaOptions , optOnlyScopeChecking = False + , optTransliterate = False } defaultPragmaOptions :: PragmaOptions @@ -261,7 +302,8 @@ { optShowImplicit = False , optShowIrrelevant = False , optUseUnicode = UnicodeOk - , optVerbose = defaultVerbosity + , optVerbose = Strict.Nothing + , optProfiling = noProfileOptions , optProp = False , optTwoLevel = Default , optExperimentalIrrelevance = False @@ -271,22 +313,22 @@ , optDisablePositivity = False , optTerminationCheck = True , optTerminationDepth = defaultCutOff - , optCompletenessCheck = True , optUniverseCheck = True , optOmegaInOmega = False - , optSubtyping = Default , optCumulativity = False , optSizedTypes = Default , optGuardedness = Default , optInjectiveTypeConstructors = False , optUniversePolymorphism = True , optWithoutK = Default + , optCubicalCompatible = Default , optCopatterns = True , optPatternMatching = True , optExactSplit = False , optEta = True , optForcing = True , optProjectionLike = True + , optEraseRecordParameters = False , optRewriting = False , optCubical = Nothing , optGuarded = False @@ -299,7 +341,7 @@ , optInversionMaxDepth = 50 , optSafe = False , optDoubleCheck = False - , optSyntacticEquality = True + , optSyntacticEquality = Strict.Nothing , optWarningMode = defaultWarningMode , optCompileNoMain = False , optCaching = True @@ -309,26 +351,55 @@ , optFastReduce = True , optCallByName = False , optConfluenceCheck = Nothing - , optFlatSplit = True + , optCohesion = False + , optFlatSplit = Default , optImportSorts = True , optAllowExec = False + , optSaveMetas = Default , optShowIdentitySubstitutions = False + , optLoadPrimitives = True + , optKeepCoveringClauses = False } -type OptM = Except String +-- | The options parse monad 'OptM' collects warnings that are not discarded +-- when a fatal error occurrs +newtype OptM a = OptM { unOptM :: ExceptT OptionError (Writer OptionWarnings) a } + deriving (Functor, Applicative, Monad, MonadError OptionError, MonadWriter OptionWarnings) -runOptM :: Monad m => OptM opts -> m (Either String opts) -runOptM = pure . runExcept +type OptionError = String +type OptionWarnings = [OptionWarning] +runOptM :: OptM opts -> (Either OptionError opts, OptionWarnings) +runOptM = runWriter . runExceptT . unOptM + {- | @f :: Flag opts@ is an action on the option record that results from parsing an option. @f opts@ produces either an error message or an updated options record -} type Flag opts = opts -> OptM opts +-- | Warnings when parsing options. + +data OptionWarning + = OptionRenamed { oldOptionName :: String, newOptionName :: String } + deriving (Show, Generic) + +instance NFData OptionWarning + +instance Pretty OptionWarning where + pretty = \case + OptionRenamed old new -> hsep + [ "Option", name old, "is deprecated, please use", name new, "instead" ] + where + name = text . ("--" ++) + +optionWarningName :: OptionWarning -> WarningName +optionWarningName = \case + OptionRenamed{} -> OptionRenamed_ + -- | Checks that the given options are consistent. -checkOpts :: Flag CommandLineOptions +checkOpts :: MonadError OptionError m => CommandLineOptions -> m () checkOpts opts = do -- NOTE: This is a temporary hold-out until --vim can be converted into a backend or plugin, -- whose options compatibility currently is checked in `Agda.Compiler.Backend`. @@ -344,12 +415,11 @@ -- to the rest of the type-checking system. when (optGenerateVimFile opts && optOnlyScopeChecking opts) $ throwError $ "The --only-scope-checking flag cannot be combined with --vim." - return opts -- | Check for unsafe pragmas. Gives a list of used unsafe flags. -unsafePragmaOptions :: CommandLineOptions -> PragmaOptions -> [String] -unsafePragmaOptions clo opts = +unsafePragmaOptions :: PragmaOptions -> [String] +unsafePragmaOptions opts = [ "--allow-unsolved-metas" | optAllowUnsolved opts ] ++ [ "--allow-incomplete-matches" | optAllowIncompleteMatch opts ] ++ [ "--no-positivity-check" | optDisablePositivity opts ] ++ @@ -361,96 +431,155 @@ [ "--irrelevant-projections" | optIrrelevantProjections opts ] ++ [ "--experimental-irrelevance" | optExperimentalIrrelevance opts ] ++ [ "--rewriting" | optRewriting opts ] ++ - [ "--cubical and --with-K" | optCubical opts == Just CFull - , not (collapseDefault $ optWithoutK opts) ] ++ - [ "--erased-cubical and --with-K" | optCubical opts == Just CErased + [ "--cubical-compatible and --with-K" | collapseDefault (optCubicalCompatible opts) , not (collapseDefault $ optWithoutK opts) ] ++ + [ "--without-K and --flat-split" | collapseDefault (optWithoutK opts) + , collapseDefault (optFlatSplit opts) ] ++ [ "--cumulativity" | optCumulativity opts ] ++ [ "--allow-exec" | optAllowExec opts ] ++ + [ "--no-load-primitives" | not $ optLoadPrimitives opts ] ++ [] --- | If any these options have changed, then the file will be --- rechecked. Boolean options are negated to mention non-default --- options, where possible. +-- | This function returns 'True' if the file should be rechecked. -restartOptions :: [(PragmaOptions -> RestartCodomain, String)] -restartOptions = - [ (C . optTerminationDepth, "--termination-depth") - , (B . (/= UnicodeOk) . optUseUnicode, "--no-unicode") - , (B . optAllowUnsolved, "--allow-unsolved-metas") - , (B . optAllowIncompleteMatch, "--allow-incomplete-matches") - , (B . optDisablePositivity, "--no-positivity-check") - , (B . optTerminationCheck, "--no-termination-check") - , (B . not . optUniverseCheck, "--type-in-type") - , (B . optOmegaInOmega, "--omega-in-omega") - , (B . collapseDefault . optSubtyping, "--subtyping") - , (B . optCumulativity, "--cumulativity") - , (B . collapseDefault . optSizedTypes, "--no-sized-types") - , (B . collapseDefault . optGuardedness, "--no-guardedness") - , (B . optInjectiveTypeConstructors, "--injective-type-constructors") - , (B . optProp, "--prop") - , (B . collapseDefault . optTwoLevel, "--two-level") - , (B . not . optUniversePolymorphism, "--no-universe-polymorphism") - , (B . optIrrelevantProjections, "--irrelevant-projections") - , (B . optExperimentalIrrelevance, "--experimental-irrelevance") - , (B . collapseDefault . optWithoutK, "--without-K") - , (B . optExactSplit, "--exact-split") - , (B . not . optEta, "--no-eta-equality") - , (B . optRewriting, "--rewriting") - , (B . (== Just CFull) . optCubical, "--cubical") - , (B . (== Just CErased) . optCubical, "--erased-cubical") - , (B . optGuarded, "--guarded") - , (B . optOverlappingInstances, "--overlapping-instances") - , (B . optQualifiedInstances, "--qualified-instances") - , (B . not . optQualifiedInstances, "--no-qualified-instances") - , (B . optSafe, "--safe") - , (B . optDoubleCheck, "--double-check") - , (B . not . optSyntacticEquality, "--no-syntactic-equality") - , (B . not . optAutoInline, "--no-auto-inline") - , (B . not . optFastReduce, "--no-fast-reduce") - , (B . optCallByName, "--call-by-name") - , (I . optInstanceSearchDepth, "--instance-search-depth") - , (I . optInversionMaxDepth, "--inversion-max-depth") - , (W . optWarningMode, "--warning") - , (B . (== Just LocalConfluenceCheck) . optConfluenceCheck, "--local-confluence-check") - , (B . (== Just GlobalConfluenceCheck) . optConfluenceCheck, "--confluence-check") - , (B . not . optImportSorts, "--no-import-sorts") - , (B . optAllowExec, "--allow-exec") - ] +recheckBecausePragmaOptionsChanged + :: PragmaOptions + -- ^ The options that were used to check the file. + -> PragmaOptions + -- ^ The options that are currently in effect. + -> Bool +recheckBecausePragmaOptionsChanged used current = + blankOut used /= blankOut current + where + -- "Blank out" irrelevant options. + blankOut opts = opts + { optShowImplicit = False + , optShowIrrelevant = False + , optVerbose = empty + , optProfiling = noProfileOptions + , optPostfixProjections = False + , optCompileNoMain = False + , optCaching = False + , optCountClusters = False + , optPrintPatternSynonyms = False + , optShowIdentitySubstitutions = False + } --- to make all restart options have the same type -data RestartCodomain = C CutOff | B Bool | I Int | W WarningMode - deriving Eq +-- | Infective or coinfective? --- | An infective option is an option that if used in one module, must --- be used in all modules that depend on this module. +data InfectiveCoinfective + = Infective + | Coinfective + deriving (Eq, Show, Generic) + +instance NFData InfectiveCoinfective + +-- | Descriptions of infective and coinfective options. + +data InfectiveCoinfectiveOption = ICOption + { icOptionActive :: PragmaOptions -> Bool + -- ^ Is the option active? + , icOptionDescription :: String + -- ^ A description of the option (typically a flag that activates + -- the option). + , icOptionKind :: InfectiveCoinfective + -- ^ Is the option (roughly speaking) infective or coinfective? + , icOptionOK :: PragmaOptions -> PragmaOptions -> Bool + -- ^ This function returns 'True' exactly when, from the + -- perspective of the option in question, the options in the + -- current module (the first argument) are compatible with the + -- options in a given imported module (the second argument). + , icOptionWarning :: TopLevelModuleName -> Doc + -- ^ A warning message that should be used if this option is not + -- used correctly. The given module name is the name of an + -- imported module for which 'icOptionOK' failed. + } + +-- | A standard infective option: If the option is active in an +-- imported module, then it must be active in the current module. + +infectiveOption + :: (PragmaOptions -> Bool) + -- ^ Is the option active? + -> String + -- ^ A description of the option. + -> InfectiveCoinfectiveOption +infectiveOption opt s = ICOption + { icOptionActive = opt + , icOptionDescription = s + , icOptionKind = Infective + , icOptionOK = \current imported -> + opt imported <= opt current + , icOptionWarning = \m -> fsep $ + pwords "Importing module" ++ [pretty m] ++ pwords "using the" ++ + [text s] ++ pwords "flag from a module which does not." + } + +-- | A standard coinfective option: If the option is active in the +-- current module, then it must be active in all imported modules. + +coinfectiveOption + :: (PragmaOptions -> Bool) + -- ^ Is the option active? + -> String + -- ^ A description of the option. + -> InfectiveCoinfectiveOption +coinfectiveOption opt s = ICOption + { icOptionActive = opt + , icOptionDescription = s + , icOptionKind = Coinfective + , icOptionOK = \current imported -> + opt current <= opt imported + , icOptionWarning = \m -> fsep $ + pwords "Importing module" ++ [pretty m] ++ + pwords "not using the" ++ [text s] ++ + pwords "flag from a module which does." + } + +-- | Infective and coinfective options. -- -- Note that @--cubical@ and @--erased-cubical@ are \"jointly -- infective\": if one of them is used in one module, then one or the -- other must be used in all modules that depend on this module. -infectiveOptions :: [(PragmaOptions -> Bool, String)] -infectiveOptions = - [ (isJust . optCubical, "--cubical/--erased-cubical") - , (optGuarded, "--guarded") - , (optProp, "--prop") - , (collapseDefault . optTwoLevel, "--two-level") - , (optRewriting, "--rewriting") - , (collapseDefault . optSizedTypes, "--sized-types") - , (collapseDefault . optGuardedness, "--guardedness") - ] - --- | A coinfective option is an option that if used in one module, must --- be used in all modules that this module depends on. - -coinfectiveOptions :: [(PragmaOptions -> Bool, String)] -coinfectiveOptions = - [ (optSafe, "--safe") - , (collapseDefault . optWithoutK, "--without-K") - , (not . optUniversePolymorphism, "--no-universe-polymorphism") - , (not . collapseDefault . optSubtyping, "--no-subtyping") - , (not . optCumulativity, "--no-cumulativity") +infectiveCoinfectiveOptions :: [InfectiveCoinfectiveOption] +infectiveCoinfectiveOptions = + [ coinfectiveOption optSafe "--safe" + , coinfectiveOption (collapseDefault . optWithoutK) "--without-K" + , cubicalCompatible + , coinfectiveOption (not . optUniversePolymorphism) + "--no-universe-polymorphism" + , coinfectiveOption (not . optCumulativity) "--no-cumulativity" + , infectiveOption (isJust . optCubical) "--cubical/--erased-cubical" + , infectiveOption optGuarded "--guarded" + , infectiveOption optProp "--prop" + , infectiveOption (collapseDefault . optTwoLevel) "--two-level" + , infectiveOption optRewriting "--rewriting" + , infectiveOption (collapseDefault . optSizedTypes) "--sized-types" + , infectiveOption (collapseDefault . optGuardedness) "--guardedness" + , infectiveOption (collapseDefault . optFlatSplit) "--flat-split" + , infectiveOption optCohesion "--cohesion" ] + where + cubicalCompatible = + (coinfectiveOption + (collapseDefault . optCubicalCompatible) + "--cubical-compatible") + { icOptionOK = \current imported -> + -- One must use --cubical-compatible in the imported module if + -- it is used in the current module, except if the current + -- module also uses --with-K and not --safe, and the imported + -- module uses --with-K. + if collapseDefault (optCubicalCompatible current) + then collapseDefault (optCubicalCompatible imported) + || + not (collapseDefault (optWithoutK imported)) + && + not (collapseDefault (optWithoutK current)) + && + not (optSafe current) + else True + } inputFlag :: FilePath -> Flag CommandLineOptions inputFlag f o = @@ -478,24 +607,29 @@ , optSizedTypes = setDefault False sizedTypes } -flatSplitFlag :: Flag PragmaOptions -flatSplitFlag o = return $ o { optFlatSplit = True } +cohesionFlag :: Flag PragmaOptions +cohesionFlag o = return $ o { optCohesion = True } -noFlatSplitFlag :: Flag PragmaOptions -noFlatSplitFlag o = return $ o { optFlatSplit = False } +flatSplitFlag :: Flag PragmaOptions +flatSplitFlag o = return $ o + { optFlatSplit = Value True + , optCohesion = True + } doubleCheckFlag :: Bool -> Flag PragmaOptions doubleCheckFlag b o = return $ o { optDoubleCheck = b } -noSyntacticEqualityFlag :: Flag PragmaOptions -noSyntacticEqualityFlag o = return $ o { optSyntacticEquality = False } - -noSortComparisonFlag :: Flag PragmaOptions -noSortComparisonFlag o = return o - -sharingFlag :: Bool -> Flag CommandLineOptions -sharingFlag _ _ = throwError $ - "Feature --sharing has been removed (in favor of the Agda abstract machine)." +syntacticEqualityFlag :: Maybe String -> Flag PragmaOptions +syntacticEqualityFlag s o = + case fuel of + Left err -> throwError err + Right fuel -> return $ o { optSyntacticEquality = fuel } + where + fuel = case s of + Nothing -> Right Strict.Nothing + Just s -> case readMaybe s of + Just n | n >= 0 -> Right (Strict.Just n) + _ -> Left $ "Not a natural number: " ++ s cachingFlag :: Bool -> Flag PragmaOptions cachingFlag b o = return $ o { optCaching = b } @@ -527,6 +661,12 @@ localInterfacesFlag :: Flag CommandLineOptions localInterfacesFlag o = return $ o { optLocalInterfaces = True } +noLoadPrimitivesFlag :: Flag PragmaOptions +noLoadPrimitivesFlag o = return $ o + { optLoadPrimitives = False + , optImportSorts = False + } + allowUnsolvedFlag :: Flag PragmaOptions allowUnsolvedFlag o = do let upd = over warningSet (Set.\\ unsolvedWarnings) @@ -561,12 +701,18 @@ jsonInteractionFlag :: Flag CommandLineOptions jsonInteractionFlag o = return $ o { optJSONInteraction = True } +interactionExitFlag :: Flag CommandLineOptions +interactionExitFlag o = return $ o { optExitOnError = True } + vimFlag :: Flag CommandLineOptions vimFlag o = return $ o { optGenerateVimFile = True } onlyScopeCheckingFlag :: Flag CommandLineOptions onlyScopeCheckingFlag o = return $ o { optOnlyScopeChecking = True } +transliterateFlag :: Flag CommandLineOptions +transliterateFlag o = return $ o { optTransliterate = True } + countClustersFlag :: Flag PragmaOptions countClustersFlag o = #ifdef COUNT_CLUSTERS @@ -605,28 +751,14 @@ , optWarningMode = upd (optWarningMode o) } --- The option was removed. See Issue 1918. -dontCompletenessCheckFlag :: Flag PragmaOptions -dontCompletenessCheckFlag _ = - throwError "The --no-coverage-check option has been removed." - dontUniverseCheckFlag :: Flag PragmaOptions dontUniverseCheckFlag o = return $ o { optUniverseCheck = False } omegaInOmegaFlag :: Flag PragmaOptions omegaInOmegaFlag o = return $ o { optOmegaInOmega = True } -subtypingFlag :: Flag PragmaOptions -subtypingFlag o = return $ o { optSubtyping = Value True } - -noSubtypingFlag :: Flag PragmaOptions -noSubtypingFlag o = return $ o { optSubtyping = Value False } - cumulativityFlag :: Flag PragmaOptions -cumulativityFlag o = - return $ o { optCumulativity = True - , optSubtyping = setDefault True $ optSubtyping o - } +cumulativityFlag o = return $ o { optCumulativity = True } noCumulativityFlag :: Flag PragmaOptions noCumulativityFlag o = return $ o { optCumulativity = False } @@ -639,10 +771,7 @@ noEtaFlag o = return $ o { optEta = False } sizedTypes :: Flag PragmaOptions -sizedTypes o = - return $ o { optSizedTypes = Value True - --, optSubtyping = setDefault True $ optSubtyping o - } +sizedTypes o = return $ o { optSizedTypes = Value True } noSizedTypes :: Flag PragmaOptions noSizedTypes o = return $ o { optSizedTypes = Value False } @@ -656,10 +785,6 @@ injectiveTypeConstructorFlag :: Flag PragmaOptions injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True } -guardingTypeConstructorFlag :: Flag PragmaOptions -guardingTypeConstructorFlag _ = throwError $ - "Experimental feature --guardedness-preserving-type-constructors has been removed." - universePolymorphismFlag :: Flag PragmaOptions universePolymorphismFlag o = return $ o { optUniversePolymorphism = True } @@ -676,7 +801,10 @@ withKFlag o = return $ o { optWithoutK = Value False } withoutKFlag :: Flag PragmaOptions -withoutKFlag o = return $ o { optWithoutK = Value True } +withoutKFlag o = return $ o + { optWithoutK = Value True + , optFlatSplit = setDefault False (optFlatSplit o) + } copatternsFlag :: Flag PragmaOptions copatternsFlag o = return $ o { optCopatterns = True } @@ -707,14 +835,22 @@ firstOrderFlag :: Flag PragmaOptions firstOrderFlag o = return $ o { optFirstOrder = True } +cubicalCompatibleFlag :: Flag PragmaOptions +cubicalCompatibleFlag o = + return $ o { optCubicalCompatible = Value True + , optWithoutK = setDefault True $ optWithoutK o + , optFlatSplit = setDefault False (optFlatSplit o) + } + cubicalFlag :: Cubical -- ^ Which variant of Cubical Agda? -> Flag PragmaOptions -cubicalFlag variant o = do - let withoutK = optWithoutK o +cubicalFlag variant o = return $ o { optCubical = Just variant - , optWithoutK = setDefault True withoutK + , optCubicalCompatible = setDefault True $ optCubicalCompatible o + , optWithoutK = setDefault True $ optWithoutK o , optTwoLevel = setDefault True $ optTwoLevel o + , optFlatSplit = setDefault False (optFlatSplit o) } guardedFlag :: Flag PragmaOptions @@ -780,17 +916,30 @@ verboseFlag :: String -> Flag PragmaOptions verboseFlag s o = do (k,n) <- parseVerbose s - return $ o { optVerbose = Trie.insert k n $ optVerbose o } + return $ + o { optVerbose = + Strict.Just $ Trie.insert k n $ + case optVerbose o of + Strict.Nothing -> Trie.singleton [] 1 + Strict.Just v -> v + } where - parseVerbose :: String -> OptM ([VerboseKey], VerboseLevel) - parseVerbose s = case wordsBy (`elem` (":." :: String)) s of + parseVerbose :: String -> OptM ([VerboseKeyItem], VerboseLevel) + parseVerbose s = case parseVerboseKey s of [] -> usage s0:ss0 -> do let (ss, s) = initLast1 s0 ss0 - n <- maybe usage return $ readMaybe s + -- The last entry must be a number. + n <- maybe usage return $ readMaybe $ toList s return (ss, n) usage = throwError "argument to verbose should be on the form x.y.z:N or N" +profileFlag :: String -> Flag PragmaOptions +profileFlag s o = + case addProfileOption s (optProfiling o) of + Left err -> throwError err + Right prof -> pure o{ optProfiling = prof } + warningModeFlag :: String -> Flag PragmaOptions warningModeFlag s o = case warningModeUpdate s of Right upd -> return $ o { optWarningMode = upd (optWarningMode o) } @@ -815,11 +964,24 @@ allowExec :: Flag PragmaOptions allowExec o = return $ o { optAllowExec = True } +saveMetas :: Bool -> Flag PragmaOptions +saveMetas save o = return $ o { optSaveMetas = Value save } + +eraseRecordParametersFlag :: Flag PragmaOptions +eraseRecordParametersFlag o = return $ o { optEraseRecordParameters = True } + +noEraseRecordParametersFlag :: Flag PragmaOptions +noEraseRecordParametersFlag o = return $ o { optEraseRecordParameters = False } + integerArgument :: String -> String -> OptM Int integerArgument flag s = maybe usage return $ readMaybe s where usage = throwError $ "option '" ++ flag ++ "' requires an integer argument" +keepCoveringClausesFlag :: Flag PragmaOptions +keepCoveringClausesFlag o = return $ o { optKeepCoveringClauses = True } + + standardOptions :: [OptDescr (Flag CommandLineOptions)] standardOptions = [ Option ['V'] ["version"] (NoArg versionFlag) @@ -841,6 +1003,9 @@ "for use with the Emacs mode" , Option [] ["interaction-json"] (NoArg jsonInteractionFlag) "for use with other editors such as Atom" + , Option [] ["interaction-exit-on-error"] + (NoArg interactionExitFlag) + "exit if a type error is encountered" , Option [] ["compile-dir"] (ReqArg compileDirFlag "DIR") ("directory for compiler output (default: the project root)") @@ -863,6 +1028,8 @@ "don't use default libraries" , Option [] ["only-scope-checking"] (NoArg onlyScopeCheckingFlag) "only scope-check the top-level module, do not type-check it" + , Option [] ["transliterate"] (NoArg transliterateFlag) + "transliterate unsupported code points when printing to stdout/stderr" ] ++ map (fmap lensPragmaOptions) pragmaOptions -- | Defined locally here since module ''Agda.Interaction.Options.Lenses'' @@ -874,13 +1041,13 @@ -- Should not be listed in the usage info, put parsed by GetOpt for good error messaging. deadStandardOptions :: [OptDescr (Flag CommandLineOptions)] deadStandardOptions = - [ Option [] ["sharing"] (NoArg $ sharingFlag True) - "DEPRECATED: does nothing" - , Option [] ["no-sharing"] (NoArg $ sharingFlag False) - "DEPRECATED: does nothing" + [ removedOption "sharing" msgSharing + , removedOption "no-sharing" msgSharing , Option [] ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden "ignore all interface files (re-type check everything, including builtin files)" ] ++ map (fmap lensPragmaOptions) deadPragmaOptions + where + msgSharing = "(in favor of the Agda abstract machine)" pragmaOptions :: [OptDescr (Flag PragmaOptions)] pragmaOptions = @@ -894,6 +1061,8 @@ "don't use unicode characters when printing terms" , Option ['v'] ["verbose"] (ReqArg verboseFlag "N") "set verbosity level to N" + , Option [] ["profile"] (ReqArg profileFlag "TYPE") + ("turn on profiling for TYPE (where TYPE=" ++ intercalate "|" validProfileOptionStrings ++ ")") , Option [] ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag) "succeed and create interface file regardless of unsolved meta variables" , Option [] ["allow-incomplete-matches"] (NoArg allowIncompleteMatchFlag) @@ -908,12 +1077,8 @@ "ignore universe levels (this makes Agda inconsistent)" , Option [] ["omega-in-omega"] (NoArg omegaInOmegaFlag) "enable typing rule Setω : Setω (this makes Agda inconsistent)" - , Option [] ["subtyping"] (NoArg subtypingFlag) - "enable subtyping rules in general (e.g. for irrelevance and erasure)" - , Option [] ["no-subtyping"] (NoArg noSubtypingFlag) - "disable subtyping rules in general (e.g. for irrelevance and erasure) (default)" , Option [] ["cumulativity"] (NoArg cumulativityFlag) - "enable subtyping of universes (e.g. Set =< Set₁) (implies --subtyping)" + "enable subtyping of universes (e.g. Set =< Set₁)" , Option [] ["no-cumulativity"] (NoArg noCumulativityFlag) "disable subtyping of universes (default)" , Option [] ["prop"] (NoArg propFlag) @@ -923,17 +1088,17 @@ , Option [] ["two-level"] (NoArg twoLevelFlag) "enable the use of SSet* universes" , Option [] ["sized-types"] (NoArg sizedTypes) - "enable sized types (default, inconsistent with --guardedness, implies --subtyping)" + "enable sized types (inconsistent with --guardedness)" , Option [] ["no-sized-types"] (NoArg noSizedTypes) - "disable sized types" + "disable sized types (default)" + , Option [] ["cohesion"] (NoArg cohesionFlag) + "enable the cohesion modalities (in particular @flat)" , Option [] ["flat-split"] (NoArg flatSplitFlag) - "allow split on (@flat x : A) arguments (default)" - , Option [] ["no-flat-split"] (NoArg noFlatSplitFlag) - "disable split on (@flat x : A) arguments" + "allow split on (@flat x : A) arguments (implies --cohesion)" , Option [] ["guardedness"] (NoArg guardedness) - "enable constructor-based guarded corecursion (default, inconsistent with --sized-types)" + "enable constructor-based guarded corecursion (inconsistent with --sized-types)" , Option [] ["no-guardedness"] (NoArg noGuardedness) - "disable constructor-based guarded corecursion" + "disable constructor-based guarded corecursion (default)" , Option [] ["injective-type-constructors"] (NoArg injectiveTypeConstructorFlag) "enable injective type constructors (makes Agda anti-classical and possibly inconsistent)" , Option [] ["no-universe-polymorphism"] (NoArg noUniversePolymorphismFlag) @@ -948,8 +1113,10 @@ "enable potentially unsound irrelevance features (irrelevant levels, irrelevant data matching)" , Option [] ["with-K"] (NoArg withKFlag) "enable the K rule in pattern matching (default)" + , Option [] ["cubical-compatible"] (NoArg cubicalCompatibleFlag) + "turn on generation of auxiliary code required for --cubical, implies --without-K" , Option [] ["without-K"] (NoArg withoutKFlag) - "disable the K rule in pattern matching" + "turn on checks to make code compatible with HoTT (e.g. disabling the K rule). Implies --no-flat-split." , Option [] ["copatterns"] (NoArg copatternsFlag) "enable definitions by copattern matching (default)" , Option [] ["no-copatterns"] (NoArg noCopatternsFlag) @@ -966,6 +1133,10 @@ "disable the forcing analysis for data constructors (optimisation)" , Option [] ["no-projection-like"] (NoArg noProjectionLikeFlag) "disable the analysis whether function signatures liken those of projections (optimisation)" + , Option [] ["erase-record-parameters"] (NoArg eraseRecordParametersFlag) + "mark all parameters of record modules as erased" + , Option [] ["no-erase-record-parameters"] (NoArg noEraseRecordParametersFlag) + "do mark all parameters of record modules as erased (default)" , Option [] ["rewriting"] (NoArg rewritingFlag) "enable declaration and use of REWRITE rules" , Option [] ["local-confluence-check"] (NoArg $ confluenceCheckFlag LocalConfluenceCheck) @@ -975,13 +1146,12 @@ , Option [] ["no-confluence-check"] (NoArg noConfluenceCheckFlag) "disable confluence checking of REWRITE rules (default)" , Option [] ["cubical"] (NoArg $ cubicalFlag CFull) - "enable cubical features (e.g. overloads lambdas for paths), implies --without-K" + "enable cubical features (e.g. overloads lambdas for paths), implies --cubical-compatible" , Option [] ["erased-cubical"] (NoArg $ cubicalFlag CErased) - "enable cubical features (some only in erased settings), implies --without-K" + "enable cubical features (some only in erased settings), implies --cubical-compatible" , Option [] ["guarded"] (NoArg guardedFlag) "enable @lock/@tick attributes" - , Option [] ["experimental-lossy-unification"] (NoArg firstOrderFlag) - "enable heuristically unifying `f es = f es'` by unifying `es = es'`, even when it could lose solutions." + , lossyUnificationOption , Option [] ["postfix-projections"] (NoArg postfixProjectionsFlag) "make postfix projection notation the default" , Option [] ["keep-pattern-variables"] (NoArg keepPatternVariablesFlag) @@ -1004,8 +1174,10 @@ "enable double-checking of all terms using the internal typechecker" , Option [] ["no-double-check"] (NoArg (doubleCheckFlag False)) "disable double-checking of terms (default)" - , Option [] ["no-syntactic-equality"] (NoArg noSyntacticEqualityFlag) + , Option [] ["no-syntactic-equality"] (NoArg $ syntacticEqualityFlag (Just "0")) "disable the syntactic equality shortcut in the conversion checker" + , Option [] ["syntactic-equality"] (OptArg syntacticEqualityFlag "FUEL") + "give the syntactic equality shortcut FUEL units of fuel (default: unlimited)" , Option ['W'] ["warning"] (ReqArg warningModeFlag "FLAG") ("set warning flags. See --help=warning.") , Option [] ["no-main"] (NoArg compileFlagNoMain) @@ -1036,22 +1208,75 @@ "use call-by-name evaluation instead of call-by-need" , Option [] ["no-import-sorts"] (NoArg noImportSorts) "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module" + , Option [] ["no-load-primitives"] (NoArg noLoadPrimitivesFlag) + "disable loading of primitive modules at all (implies --no-import-sorts)" , Option [] ["allow-exec"] (NoArg allowExec) "allow system calls to trusted executables with primExec" + , Option [] ["save-metas"] (NoArg $ saveMetas True) + "save meta-variables" + , Option [] ["no-save-metas"] (NoArg $ saveMetas False) + "do not save meta-variables (the default)" + , Option [] ["keep-covering-clauses"] (NoArg keepCoveringClausesFlag) + "do not discard covering clauses (required for some external backends)" ] +lossyUnificationOption :: OptDescr (Flag PragmaOptions) +lossyUnificationOption = + Option [] ["lossy-unification"] (NoArg firstOrderFlag) + "enable heuristically unifying `f es = f es'` by unifying `es = es'`, even when it could lose solutions" + -- | Pragma options of previous versions of Agda. -- Should not be listed in the usage info, put parsed by GetOpt for good error messaging. deadPragmaOptions :: [OptDescr (Flag PragmaOptions)] -deadPragmaOptions = - [ Option [] ["guardedness-preserving-type-constructors"] (NoArg guardingTypeConstructorFlag) - "treat type constructors as inductive constructors when checking productivity" - , Option [] ["no-coverage-check"] (NoArg dontCompletenessCheckFlag) - "the option has been removed" - , Option [] ["no-sort-comparison"] (NoArg noSortComparisonFlag) - "disable the comparison of sorts when checking conversion of types" +deadPragmaOptions = concat + [ map (uncurry removedOption) + [ ("guardedness-preserving-type-constructors" + , "") + , ("no-coverage-check" + , inVersion "2.5.1") -- see issue #1918 + , ("no-sort-comparison" + , "") + , ("subtyping" + , inVersion "2.6.3") -- see issue #5427 + , ("no-subtyping" + , inVersion "2.6.3") -- see issue #5427 + , ("no-flat-split", inVersion "2.6.3") -- See issue #6263. ] + , map (uncurry renamedNoArgOption) + [ ( "experimental-lossy-unification" + , lossyUnificationOption + ) + ] + ] + where + inVersion = ("in version " ++) +-- | Generate a dead options that just error out saying this option has been removed. +removedOption :: + String + -- ^ The name of the removed option. + -> String + -- ^ Optional: additional remark, like in which version the option was removed. + -> OptDescr (Flag a) +removedOption name remark = Option [] [name] (NoArg $ const $ throwError msg) msg + where + msg = unwords ["Option", "--" ++ name, "has been removed", remark] + +-- | Generate a deprecated option that resolves to another option. +renamedNoArgOption :: + String + -- ^ The deprecated long option name. + -> OptDescr (Flag a) + -- ^ The new option. + -> OptDescr (Flag a) + -- ^ The old option which additionally emits a 'RenamedOption' warning. +renamedNoArgOption old = \case + Option _ [new] (NoArg flag) description -> + Option [] [old] (NoArg flag') $ concat [description, " (DEPRECATED, use --", new, ")"] + where + flag' o = tell1 (OptionRenamed old new) >> flag o + _ -> __IMPOSSIBLE__ + -- | Used for printing usage info. -- Does not include the dead options. standardOptions_ :: [OptDescr ()] @@ -1105,17 +1330,6 @@ sugs [a] = a sugs as = "any of " ++ unwords as -{- No longer used in favour of parseBackendOptions in Agda.Compiler.Backend --- | Parse the standard options. -parseStandardOptions :: [String] -> OptM CommandLineOptions -parseStandardOptions argv = parseStandardOptions' argv defaultOptions - -parseStandardOptions' :: [String] -> Flag CommandLineOptions -parseStandardOptions' argv opts = do - opts <- getOptSimple (stripRTS argv) (deadStandardOptions ++ standardOptions) inputFlag opts - checkOpts opts --} - -- | Parse options from an options pragma. parsePragmaOptions :: [String] @@ -1127,7 +1341,7 @@ ps <- getOptSimple argv (deadPragmaOptions ++ pragmaOptions) (\s _ -> throwError $ "Bad option in pragma: " ++ s) (optPragmaOptions opts) - _ <- checkOpts (opts { optPragmaOptions = ps }) + () <- checkOpts (opts { optPragmaOptions = ps }) return ps -- | Parse options for a plugin. 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 @@ -30,6 +30,7 @@ import Text.Read ( readMaybe ) import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HMap import Data.List ( stripPrefix, intercalate ) import GHC.Generics (Generic) @@ -166,9 +167,10 @@ -- to existing warnings in the codebase. data WarningName - = + -- Option Warnings + = OptionRenamed_ -- Parser Warnings - OverlappingTokensWarning_ + | OverlappingTokensWarning_ | UnsupportedAttribute_ | MultipleAttributes_ -- Library Warnings @@ -186,6 +188,7 @@ | EmptyPrivate_ | EmptyRewritePragma_ | EmptyWhere_ + | HiddenGeneralize_ | InvalidCatchallPragma_ | InvalidConstructor_ | InvalidConstructorBlock_ @@ -231,6 +234,7 @@ | NoGuardednessFlag_ | NotInScope_ | NotStrictlyPositive_ + | UnsupportedIndexedMatch_ | OldBuiltin_ | PragmaCompileErased_ | RewriteMaybeNonConfluent_ @@ -273,9 +277,9 @@ -- | The flag corresponding to a warning is precisely the name of the constructor -- minus the trailing underscore. --- sorry string2WarningName :: String -> Maybe WarningName -string2WarningName = readMaybe . (++ "_") +string2WarningName = (`HMap.lookup` warnings) where + warnings = HMap.fromList $ map (\x -> (warningName2String x, x)) [minBound..maxBound] warningName2String :: WarningName -> String warningName2String = initWithDefault __IMPOSSIBLE__ . show @@ -321,6 +325,8 @@ warningNameDescription :: WarningName -> String warningNameDescription = \case + -- Option Warnings + OptionRenamed_ -> "Renamed options." -- Parser Warnings OverlappingTokensWarning_ -> "Multi-line comments spanning one or more literate text blocks." UnsupportedAttribute_ -> "Unsupported attributes." @@ -340,6 +346,7 @@ EmptyPrivate_ -> "Empty `private' blocks." EmptyRewritePragma_ -> "Empty `REWRITE' pragmas." EmptyWhere_ -> "Empty `where' blocks." + HiddenGeneralize_ -> "Hidden identifiers in variable blocks." InvalidCatchallPragma_ -> "`CATCHALL' pragmas before a non-function clause." InvalidConstructor_ -> "`constructor' blocks may only contain type signatures for constructors." InvalidConstructorBlock_ -> "No `constructor' blocks outside of `interleaved mutual' blocks." @@ -389,6 +396,7 @@ FixityInRenamingModule_ -> "Found fixity annotation in renaming directive for module." NotInScope_ -> "Out of scope name." NotStrictlyPositive_ -> "Failed strict positivity checks." + UnsupportedIndexedMatch_ -> "Failed to compute full equivalence when splitting on indexed family." OldBuiltin_ -> "Deprecated `BUILTIN' pragmas." PragmaCompileErased_ -> "`COMPILE' pragma targeting an erased symbol." RewriteMaybeNonConfluent_ -> "Failed local confluence check while computing overlap." @@ -413,7 +421,7 @@ UnsolvedMetaVariables_ -> "Unsolved meta variables." UserWarning_ -> "User-defined warning added using one of the 'WARNING_ON_*' pragmas." WithoutKFlagPrimEraseEquality_ -> "`primEraseEquality' usages with the without-K flags." - WrongInstanceDeclaration_ -> "Terms marked as eligible for instance search should end with a name." + WrongInstanceDeclaration_ -> "Instances that do not adhere to the required format." -- Checking consistency of options CoInfectiveImport_ -> "Importing a file not using e.g. `--safe' from one which does." InfectiveImport_ -> "Importing a file using e.g. `--cubical' into one which doesn't." 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 @@ -30,10 +30,10 @@ ) import Agda.Interaction.Highlighting.Precise import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common (InteractionId(..), Arg) -import Agda.Syntax.Concrete (Expr, Name) -import Agda.Syntax.Concrete.Name (NameInScope) -import Agda.Syntax.Scope.Base (AbstractModule, AbstractName, LocalVar) +import Agda.Syntax.Common (InteractionId(..), Arg) +import Agda.Syntax.Concrete (Expr) +import Agda.Syntax.Concrete.Name (Name, QName, NameInScope) +import Agda.Syntax.Scope.Base (AbstractModule, AbstractName, LocalVar, WhyInScopeData) import qualified Agda.Syntax.Internal as I import {-# SOURCE #-} Agda.TypeChecking.Monad.Base (TCM, TCErr, TCWarning, HighlightingMethod, ModuleToSource, NamedMeta, TCWarning, IPBoundary') @@ -108,7 +108,7 @@ -- TODO: split these into separate constructors | Info_ModuleContents [Name] I.Telescope [(Name, I.Type)] | Info_SearchAbout [(Name, I.Type)] String - | Info_WhyInScope String FilePath (Maybe LocalVar) [AbstractName] [AbstractModule] + | Info_WhyInScope WhyInScopeData | Info_NormalForm CommandState ComputeMode (Maybe CPUTime) A.Expr | Info_InferredType CommandState (Maybe CPUTime) A.Expr | Info_Context InteractionId [ResponseContextEntry] 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 @@ -5,6 +5,7 @@ import Prelude hiding (null) +import qualified Control.Exception as E import Control.Monad ( void ) import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) ) @@ -13,7 +14,9 @@ import Data.Maybe import System.Environment +import System.Exit import System.Console.GetOpt +import qualified System.IO as IO import Paths_Agda ( getDataDir ) @@ -51,26 +54,45 @@ -- | The main function without importing built-in backends runAgda' :: [Backend] -> IO () -runAgda' backends = do - progName <- getProgName - argv <- getArgs - conf <- runExceptT $ do - (bs, opts) <- ExceptT $ runOptM $ parseBackendOptions backends argv defaultOptions +runAgda' backends = runTCMPrettyErrors $ do + progName <- liftIO getProgName + argv <- liftIO getArgs + let (z, warns) = runOptM $ parseBackendOptions backends argv defaultOptions + mapM_ (warning . OptionWarning) warns + conf <- liftIO $ runExceptT $ do + (bs, opts) <- ExceptT $ pure z -- The absolute path of the input file, if provided inputFile <- liftIO $ mapM absolute $ optInputFile opts mode <- getMainMode bs inputFile opts return (bs, opts, mode) case conf of - Left err -> optionError err - Right (bs, opts, mode) -> case mode of - MainModePrintHelp hp -> printUsage bs hp - MainModePrintVersion -> printVersion bs - MainModePrintAgdaDir -> printAgdaDir - MainModeRun interactor -> runTCMPrettyErrors $ do - setTCLens stBackends bs - runAgdaWithOptions interactor progName opts + Left err -> liftIO $ optionError err + Right (bs, opts, mode) -> do + when (optTransliterate opts) $ liftIO $ do + -- When --interaction or --interaction-json is used, then we + -- use UTF-8 when writing to stdout (and when reading from + -- stdin). + if optGHCiInteraction opts || optJSONInteraction opts + then optionError $ + "The option --transliterate must not be combined with " ++ + "--interaction or --interaction-json" + else do + -- Transliterate unsupported code points. + enc <- IO.mkTextEncoding + (show IO.localeEncoding ++ "//TRANSLIT") + IO.hSetEncoding IO.stdout enc + IO.hSetEncoding IO.stderr enc + + case mode of + MainModePrintHelp hp -> liftIO $ printUsage bs hp + MainModePrintVersion -> liftIO $ printVersion bs + MainModePrintAgdaDir -> liftIO $ printAgdaDir + MainModeRun interactor -> do + setTCLens stBackends bs + runAgdaWithOptions interactor progName opts + -- | Main execution mode data MainMode = MainModeRun (Interactor ()) @@ -182,7 +204,7 @@ Bench.print -- Print accumulated statistics. - printStatistics 1 Nothing =<< useTC lensAccumStatistics + printStatistics Nothing =<< useTC lensAccumStatistics where -- Options are fleshed out here so that (most) errors like -- "bad library path" are validated within the interactor, @@ -253,17 +275,84 @@ exitAgdaWith OptionError -- | Run a TCM action in IO; catch and pretty print errors. + +-- If some error message cannot be printed due to locale issues, then +-- one may get the "Error when handling error" error message. There is +-- currently no test case for this error, but on some systems one can +-- (at the time of writing) trigger it by running @LC_CTYPE=C agda +-- --no-libraries Bug.agda@, where @Bug.agda@ contains the following +-- code (if there is some other file in the same directory, for +-- instance @Bug.lagda@, then the error message may be different): +-- +-- @ +-- _ : Set +-- _ = Set +-- @ + runTCMPrettyErrors :: TCM () -> IO () runTCMPrettyErrors tcm = do - r <- runTCMTop $ tcm `catchError` \err -> do - s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err - s1 <- prettyError err - let ss = filter (not . null) $ s2s ++ [s1] - unless (null s1) (liftIO $ putStr $ unlines ss) - throwError err - case r of - Right _ -> exitSuccess - Left _ -> exitAgdaWith TCMError - `catchImpossible` \e -> do - putStr $ show e - exitAgdaWith ImpossibleError + r <- runTCMTop + ( ( (Nothing <$ tcm) + `catchError` \err -> do + s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err + s1 <- prettyError err + let ss = filter (not . null) $ s2s ++ [s1] + unless (null s1) (liftIO $ putStr $ unlines ss) + liftIO $ helpForLocaleError err + return (Just TCMError) + ) `catchImpossible` \e -> do + liftIO $ putStr $ E.displayException e + return (Just ImpossibleError) + ) `E.catches` + -- Catch all exceptions except for those of type ExitCode + -- (which are thrown by exitWith) and asynchronous exceptions + -- (which are for instance raised when Ctrl-C is used, or if + -- the program runs out of heap or stack space). + [ E.Handler $ \(e :: ExitCode) -> E.throw e + , E.Handler $ \(e :: E.AsyncException) -> E.throw e + , E.Handler $ \(e :: E.SomeException) -> do + liftIO $ putStr $ E.displayException e + return $ Right (Just UnknownError) + ] + case r of + Right Nothing -> exitSuccess + Right (Just reason) -> exitAgdaWith reason + Left err -> do + liftIO $ do + putStrLn "\n\nError when handling error:" + putStrLn $ tcErrString err + helpForLocaleError err + exitAgdaWith UnknownError + +-- | If the error is an IO error, and the error message suggests that +-- the problem is related to locales or code pages, print out some +-- extra information. + +helpForLocaleError :: TCErr -> IO () +helpForLocaleError e = case e of + (IOException _ _ e) + | "invalid argument" `List.isInfixOf` show e -> msg + _ -> return () + where + msg = putStr $ unlines + [ "" + , "This error may be due to the use of a locale or code page that does not" + , "support some character used in the program being type-checked." + , "" + , "If it is, then one option is to use the option --transliterate, in which" + , "case unsupported characters are (hopefully) replaced with something else," + , "perhaps question marks. However, that could make the output harder to" + , "read." + , "" + , "If you want to fix the problem \"properly\", then you could try one of the" + , "following suggestions:" + , "" + , "* If you are using Windows, try switching to a different code page (for" + , " instance by running the command 'CHCP 65001')." + , "" + , "* If you are using a Unix-like system, try using a different locale. The" + , " installed locales are perhaps printed by the command 'locale -a'. If" + , " you have a UTF-8 locale installed (for instance sv_SE.UTF-8), then you" + , " can perhaps make Agda use this locale by running something like" + , " 'LC_ALL=sv_SE.UTF-8 agda <...>'." + ] 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 @@ -23,7 +23,6 @@ import qualified Data.Set as Set import Data.Set (Set) import Data.Void -import Data.Data (Data) import GHC.Generics (Generic) @@ -56,7 +55,7 @@ -- e.g. in @{_ : A} -> ..@ vs. @{r : A} -> ..@. newtype BindName = BindName { unBind :: Name } - deriving (Show, Data, HasRange, KillRange, SetRange, NFData) + deriving (Show, HasRange, KillRange, SetRange, NFData) mkBindName :: Name -> BindName mkBindName x = BindName x @@ -73,6 +72,10 @@ type Args = [NamedArg Expr] +-- | Types are just expressions. +-- Use this type synonym for hinting that an expression should be a type. +type Type = Expr + -- | Expressions after scope checking (operators parsed, names resolved). data Expr = Var Name -- ^ Bound variable. @@ -98,12 +101,11 @@ | Lam ExprInfo LamBinding Expr -- ^ @λ bs → e@. | AbsurdLam ExprInfo Hiding -- ^ @λ()@ or @λ{}@. | ExtendedLam ExprInfo DefInfo Erased QName (List1 Clause) - | Pi ExprInfo Telescope1 Expr -- ^ Dependent function space @Γ → A@. - | Generalized (Set QName) Expr -- ^ Like a Pi, but the ordering is not known - | Fun ExprInfo (Arg Expr) Expr -- ^ Non-dependent function space. + | Pi ExprInfo Telescope1 Type -- ^ Dependent function space @Γ → A@. + | Generalized (Set QName) Type -- ^ Like a Pi, but the ordering is not known + | Fun ExprInfo (Arg Type) Type -- ^ Non-dependent function space. | Let ExprInfo (List1 LetBinding) Expr -- ^ @let bs in e@. - | ETel Telescope -- ^ Only used when printing telescopes. | Rec ExprInfo RecordAssigns -- ^ Record construction. | RecUpdate ExprInfo Expr Assigns -- ^ Record update. | ScopedExpr ScopeInfo Expr -- ^ Scope annotation. @@ -111,14 +113,14 @@ | QuoteTerm ExprInfo -- ^ Quote a term. | Unquote ExprInfo -- ^ The splicing construct: unquote ... | DontCare Expr -- ^ For printing @DontCare@ from @Syntax.Internal@. - deriving (Data, Show, Generic) + deriving (Show, Generic) --- | Pattern synonym for regular Def +-- | Pattern synonym for regular 'Def'. pattern Def :: QName -> Expr pattern Def x = Def' x NoSuffix --- | Smart constructor for Generalized -generalized :: Set QName -> Expr -> Expr +-- | Smart constructor for 'Generalized'. +generalized :: Set QName -> Type -> Type generalized s e | null s = e | otherwise = Generalized s e @@ -135,7 +137,7 @@ data ScopeCopyInfo = ScopeCopyInfo { renModules :: Ren ModuleName , renNames :: Ren QName } - deriving (Eq, Show, Data, Generic) + deriving (Eq, Show, Generic) initCopyInfo :: ScopeCopyInfo initCopyInfo = ScopeCopyInfo @@ -155,15 +157,15 @@ type RecordDirectives = RecordDirectives' QName data Declaration - = Axiom KindOfName DefInfo ArgInfo (Maybe [Occurrence]) QName Expr + = Axiom KindOfName DefInfo ArgInfo (Maybe [Occurrence]) QName Type -- ^ Type signature (can be irrelevant, but not hidden). -- -- The fourth argument contains an optional assignment of -- polarities to arguments. - | Generalize (Set QName) DefInfo ArgInfo QName Expr + | Generalize (Set QName) DefInfo ArgInfo QName Type -- ^ First argument is set of generalizable variables used in the type. - | Field DefInfo QName (Arg Expr) -- ^ record field - | Primitive DefInfo QName (Arg Expr) -- ^ primitive function + | Field DefInfo QName (Arg Type) -- ^ record field + | Primitive DefInfo QName (Arg Type) -- ^ primitive function | Mutual MutualInfo [Declaration] -- ^ a bunch of mutually recursive definitions | Section Range ModuleName GeneralizeTelescope [Declaration] | Apply ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective @@ -174,19 +176,20 @@ | Open ModuleInfo ModuleName ImportDirective -- ^ only retained for highlighting purposes | FunDef DefInfo QName Delayed [Clause] -- ^ sequence of function clauses - | DataSig DefInfo QName GeneralizeTelescope Expr -- ^ lone data signature + | DataSig DefInfo QName GeneralizeTelescope Type -- ^ lone data signature | DataDef DefInfo QName UniverseCheck DataDefParams [Constructor] - | RecSig DefInfo QName GeneralizeTelescope Expr -- ^ lone record signature - | RecDef DefInfo QName UniverseCheck RecordDirectives DataDefParams Expr [Declaration] - -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@, + | RecSig DefInfo QName GeneralizeTelescope Type -- ^ lone record signature + | RecDef DefInfo QName UniverseCheck RecordDirectives DataDefParams Type [Declaration] + -- ^ The 'Type' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@, -- and the optional name is the constructor's name. -- The optional 'Range' is for the @pattern@ attribute. | PatternSynDef QName [Arg BindName] (Pattern' Void) -- ^ Only for highlighting purposes | UnquoteDecl MutualInfo [DefInfo] [QName] Expr | UnquoteDef [DefInfo] [QName] Expr + | UnquoteData [DefInfo] QName UniverseCheck [DefInfo] [QName] Expr | ScopedDecl ScopeInfo [Declaration] -- ^ scope annotation - deriving (Data, Show, Generic) + deriving (Show, Generic) type DefInfo = DefInfo' Expr @@ -199,7 +202,7 @@ -- ^ @tel. M args@: applies @M@ to @args@ and abstracts @tel@. | RecordModuleInstance ModuleName -- ^ @M {{...}}@ - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) data Pragma = OptionsPragma [String] @@ -218,12 +221,14 @@ -- @eta-equality@ definition (as it is might make Agda loop). | InjectivePragma QName | InlinePragma Bool QName -- INLINE or NOINLINE + | NotProjectionLikePragma QName + -- Mark the definition as not being projection-like | DisplayPragma QName [NamedArg Pattern] Expr - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | Bindings that are valid in a @let@. data LetBinding - = LetBind LetInfo ArgInfo BindName Expr Expr + = LetBind LetInfo ArgInfo BindName Type Expr -- ^ @LetBind info rel name type defn@ | LetPatBind LetInfo Pattern Expr -- ^ Irrefutable pattern binding. @@ -235,8 +240,7 @@ | LetDeclaredVariable BindName -- ^ Only used for highlighting. Refers to the first occurrence of -- @x@ in @let x : A; x = e@. --- | LetGeneralize DefInfo ArgInfo Expr - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | Only 'Axiom's. type TypeSignature = Declaration @@ -249,7 +253,7 @@ data Binder' a = Binder { binderPattern :: Maybe Pattern , binderName :: a - } deriving (Data, Show, Eq, Functor, Foldable, Traversable, Generic) + } deriving (Show, Eq, Functor, Foldable, Traversable, Generic) type Binder = Binder' BindName @@ -268,11 +272,31 @@ -- ^ . @x@ or @{x}@ or @.x@ or @{x = y}@ or @x\@p@ or @(p)@ | DomainFull TypedBinding -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@ - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) mkDomainFree :: NamedArg Binder -> LamBinding mkDomainFree = DomainFree Nothing +-- | 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 + -- ^ Does this binding have a tactic annotation? + , tbFinite :: Bool + -- ^ Does this binding correspond to a Partial binder, rather than + -- to a Pi binder? Must be present here to be reflected into + -- abstract syntax later (and to be printed to the user later). + } + deriving (Show, Eq, Generic) + +defaultTbInfo :: TypedBindingInfo +defaultTbInfo = TypedBindingInfo + { tbTacticAttr = Nothing + , tbFinite = False + } + -- | A typed binding. Appears in dependent function spaces, typed lambdas, and -- telescopes. It might be tempting to simplify this to only bind a single -- name at a time, and translate, say, @(x y : A)@ to @(x : A)(y : A)@ @@ -288,14 +312,14 @@ -- that the metas of the copy are aliases of the metas of the original. data TypedBinding - = TBind Range TacticAttr (List1 (NamedArg Binder)) Expr + = TBind Range TypedBindingInfo (List1 (NamedArg Binder)) Type -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@. | TLet Range (List1 LetBinding) -- ^ E.g. @(let x = e)@ or @(let open M)@. - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -mkTBind :: Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding -mkTBind r = TBind r Nothing +mkTBind :: Range -> List1 (NamedArg Binder) -> Type -> TypedBinding +mkTBind r = TBind r defaultTbInfo mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding mkTLet _ [] = Nothing @@ -304,7 +328,7 @@ type Telescope1 = List1 TypedBinding type Telescope = [TypedBinding] -mkPi :: ExprInfo -> Telescope -> Expr -> Expr +mkPi :: ExprInfo -> Telescope -> Type -> Type mkPi i [] e = e mkPi i (x:xs) e = Pi i (x :| xs) e @@ -313,7 +337,7 @@ -- ^ Maps generalize variables to the corresponding bound variable (to be -- introduced by the generalisation). , generalizeTel :: Telescope } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) data DataDefParams = DataDefParams { dataDefGeneralizedParams :: Set Name @@ -321,7 +345,7 @@ -- sig, so we keep these in a set on the side. , dataDefParams :: [LamBinding] } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) noDataDefParams :: DataDefParams noDataDefParams = DataDefParams Set.empty [] @@ -343,7 +367,7 @@ { problemInPat :: Pattern , problemInst :: I.Term , problemType :: I.Dom I.Type - } deriving (Data, Show, Generic) + } deriving (Show, Generic) -- These are not relevant for caching purposes instance Eq ProblemEq where _ == _ = True @@ -359,18 +383,20 @@ , clauseRHS :: RHS , clauseWhereDecls :: WhereDeclarations , clauseCatchall :: Bool - } deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic) + } deriving (Show, Functor, Foldable, Traversable, Eq, Generic) data WhereDeclarations = WhereDecls { whereModule :: Maybe ModuleName -- #2897: we need to restrict named where modules in refined contexts, -- so remember whether it was named here - , whereDecls :: Maybe Declaration + , whereAnywhere :: Bool + -- ^ is it an ordinary unnamed @where@? + , whereDecls :: Maybe Declaration -- ^ The declaration is a 'Section'. - } deriving (Data, Show, Eq, Generic) + } deriving (Show, Eq, Generic) instance Null WhereDeclarations where - empty = WhereDecls empty empty + empty = WhereDecls empty False empty noWhereDecls :: WhereDeclarations noWhereDecls = empty @@ -405,7 +431,7 @@ -- ^ The where clauses are attached to the @RewriteRHS@ by --- the scope checker (instead of to the clause). } - deriving (Data, Show, Generic) + deriving (Show, Generic) -- | Ignore 'rhsConcrete' when comparing 'RHS's. instance Eq RHS where @@ -423,7 +449,7 @@ , spLhsDefName :: QName -- ^ Name of function we are defining. , spLhsPats :: [NamedArg Pattern] -- ^ Elimination by pattern, projections, with-patterns. } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | Ignore 'Range' when comparing 'LHS's. instance Eq LHS where @@ -435,7 +461,7 @@ { lhsInfo :: LHSInfo -- ^ Range. , lhsCore :: LHSCore -- ^ Copatterns. } - deriving (Data, Show, Generic) + deriving (Show, Generic) -- | The lhs in projection-application and with-pattern view. -- Parameterised over the type @e@ of dot patterns. @@ -463,7 +489,7 @@ , lhsPats :: [NamedArg (Pattern' e)] -- ^ Further applied to patterns. } - deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic) + deriving (Show, Functor, Foldable, Traversable, Eq, Generic) type LHSCore = LHSCore' Expr @@ -494,7 +520,7 @@ | EqualP PatInfo [(e, e)] | WithP PatInfo (Pattern' e) -- ^ @| p@, for with-patterns. | AnnP PatInfo e (Pattern' e) -- ^ Pattern with type annotation - deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic) + deriving (Show, Functor, Foldable, Traversable, Eq, Generic) type NAPs e = [NamedArg (Pattern' e)] type NAPs1 e = List1 (NamedArg (Pattern' e)) @@ -549,7 +575,6 @@ Generalized a1 b1 == Generalized a2 b2 = (a1, b1) == (a2, b2) Fun a1 b1 c1 == Fun a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2) Let a1 b1 c1 == Let a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2) - ETel a1 == ETel a2 = a1 == a2 Rec a1 b1 == Rec a2 b2 = (a1, b1) == (a2, b2) RecUpdate a1 b1 c1 == RecUpdate a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2) Quote a1 == Quote a2 = a1 == a2 @@ -632,7 +657,6 @@ getRange (Let i _ _) = getRange i getRange (Rec i _) = getRange i getRange (RecUpdate i _ _) = getRange i - getRange (ETel tel) = getRange tel getRange (ScopedExpr _ e) = getRange e getRange (Quote i) = getRange i getRange (QuoteTerm i) = getRange i @@ -661,6 +685,7 @@ getRange (PatternSynDef x _ _ ) = getRange x getRange (UnquoteDecl _ i _ _) = getRange i getRange (UnquoteDef i _ _) = getRange i + getRange (UnquoteData i _ _ j _ _) = getRange (i, j) instance HasRange (Pattern' e) where getRange (VarP x) = getRange x @@ -699,7 +724,7 @@ getRange (RewriteRHS xes _ rhs wh) = getRange (xes, rhs, wh) instance HasRange WhereDeclarations where - getRange (WhereDecls _ ds) = getRange ds + getRange (WhereDecls _ _ ds) = getRange ds instance HasRange LetBinding where getRange (LetBind i _ _ _ _ ) = getRange i @@ -738,6 +763,9 @@ instance KillRange DataDefParams where killRange (DataDefParams s tel) = DataDefParams s (killRange tel) +instance KillRange TypedBindingInfo where + killRange (TypedBindingInfo a b) = killRange2 TypedBindingInfo a b + instance KillRange TypedBinding where killRange (TBind r t xs e) = killRange4 TBind r t xs e killRange (TLet r lbs) = killRange2 TLet r lbs @@ -762,7 +790,6 @@ killRange (Let i ds e) = killRange3 Let i ds e killRange (Rec i fs) = killRange2 Rec i fs killRange (RecUpdate i e fs) = killRange3 RecUpdate i e fs - killRange (ETel tel) = killRange1 ETel tel killRange (ScopedExpr s e) = killRange1 (ScopedExpr s) e killRange (Quote i) = killRange1 Quote i killRange (QuoteTerm i) = killRange1 QuoteTerm i @@ -794,6 +821,7 @@ killRange (PatternSynDef x xs p ) = killRange3 PatternSynDef x xs p killRange (UnquoteDecl mi i x e ) = killRange4 UnquoteDecl mi i x e killRange (UnquoteDef i x e ) = killRange3 UnquoteDef i x e + killRange (UnquoteData i xs uc j cs e) = killRange6 UnquoteData i xs uc j cs e instance KillRange ModuleApplication where killRange (SectionApp a b c ) = killRange3 SectionApp a b c @@ -842,7 +870,7 @@ killRange (RewriteRHS xes spats rhs wh) = killRange4 RewriteRHS xes spats rhs wh instance KillRange WhereDeclarations where - killRange (WhereDecls a b) = killRange2 WhereDecls a b + killRange (WhereDecls a b c) = killRange3 WhereDecls a b c instance KillRange LetBinding where killRange (LetBind i info a b c) = killRange5 LetBind i info a b c @@ -860,6 +888,7 @@ instance NFData a => NFData (Binder' a) instance NFData LamBinding instance NFData TypedBinding +instance NFData TypedBindingInfo instance NFData GeneralizeTelescope instance NFData DataDefParams instance NFData ProblemEq @@ -1042,7 +1071,6 @@ Generalized{} -> __IMPOSSIBLE__ Fun{} -> __IMPOSSIBLE__ Let{} -> __IMPOSSIBLE__ - ETel{} -> __IMPOSSIBLE__ RecUpdate{} -> __IMPOSSIBLE__ Quote{} -> __IMPOSSIBLE__ QuoteTerm{} -> __IMPOSSIBLE__ @@ -1076,3 +1104,99 @@ matchArgs r (n:ns) as = do (p, as) <- matchNextArg r n as first ((unArg n, p) :) <$> matchArgs (getRange p) ns as + +------------------------------------------------------------------------ +-- Declaration spines +------------------------------------------------------------------------ + +-- | Declaration spines. Used in debugging to make it easy to see +-- where constructors such as 'ScopedDecl' and 'Mutual' are placed. + +data DeclarationSpine + = AxiomS + | GeneralizeS + | FieldS + | PrimitiveS + | MutualS [DeclarationSpine] + | SectionS [DeclarationSpine] + | ApplyS + | ImportS + | PragmaS + | OpenS + | FunDefS [ClauseSpine] + | DataSigS + | DataDefS + | RecSigS + | RecDefS [DeclarationSpine] + | PatternSynDefS + | UnquoteDeclS + | UnquoteDefS + | UnquoteDataS + | ScopedDeclS [DeclarationSpine] + deriving Show + +-- | Clause spines. + +data ClauseSpine = ClauseS RHSSpine WhereDeclarationsSpine + deriving Show + +-- | Right-hand side spines. + +data RHSSpine + = RHSS + | AbsurdRHSS + | WithRHSS [ClauseSpine] + | RewriteRHSS RHSSpine WhereDeclarationsSpine + deriving Show + +-- | Spines corresponding to 'WhereDeclarations' values. + +data WhereDeclarationsSpine = WhereDeclsS (Maybe DeclarationSpine) + deriving Show + +-- | The declaration spine corresponding to a declaration. + +declarationSpine :: Declaration -> DeclarationSpine +declarationSpine = \case + Axiom _ _ _ _ _ _ -> AxiomS + Generalize _ _ _ _ _ -> GeneralizeS + Field _ _ _ -> FieldS + Primitive _ _ _ -> PrimitiveS + Mutual _ ds -> MutualS (map declarationSpine ds) + Section _ _ _ ds -> SectionS (map declarationSpine ds) + Apply _ _ _ _ _ -> ApplyS + Import _ _ _ -> ImportS + Pragma _ _ -> PragmaS + Open _ _ _ -> OpenS + FunDef _ _ _ cs -> FunDefS (map clauseSpine cs) + DataSig _ _ _ _ -> DataSigS + DataDef _ _ _ _ _ -> DataDefS + RecSig _ _ _ _ -> RecSigS + RecDef _ _ _ _ _ _ ds -> RecDefS (map declarationSpine ds) + PatternSynDef _ _ _ -> PatternSynDefS + UnquoteDecl _ _ _ _ -> UnquoteDeclS + UnquoteDef _ _ _ -> UnquoteDefS + UnquoteData _ _ _ _ _ _ -> UnquoteDataS + ScopedDecl _ ds -> ScopedDeclS (map declarationSpine ds) + +-- | The clause spine corresponding to a clause. + +clauseSpine :: Clause -> ClauseSpine +clauseSpine (Clause _ _ rhs ws _) = + ClauseS (rhsSpine rhs) (whereDeclarationsSpine ws) + +-- | The right-hand side spine corresponding to a right-hand side. + +rhsSpine :: RHS -> RHSSpine +rhsSpine = \case + RHS _ _ -> RHSS + AbsurdRHS -> AbsurdRHSS + WithRHS _ _ cs -> WithRHSS (map clauseSpine cs) + RewriteRHS _ _ rhs ws -> + RewriteRHSS (rhsSpine rhs) (whereDeclarationsSpine ws) + +-- | The spine corresponding to a 'WhereDeclarations' value. + +whereDeclarationsSpine :: WhereDeclarations -> WhereDeclarationsSpine +whereDeclarationsSpine (WhereDecls _ _ md) = + WhereDeclsS (fmap declarationSpine md) diff --git a/src/full/Agda/Syntax/Abstract/Name.hs b/src/full/Agda/Syntax/Abstract/Name.hs --- a/src/full/Agda/Syntax/Abstract/Name.hs +++ b/src/full/Agda/Syntax/Abstract/Name.hs @@ -11,9 +11,8 @@ import Control.DeepSeq -import Data.Data (Data) import Data.Foldable (length) -import Data.Function +import Data.Function (on) import Data.Hashable (Hashable(..)) import qualified Data.List as List import Data.Maybe @@ -46,7 +45,7 @@ , nameIsRecordName :: Bool -- ^ Is this the name of the invisible record variable `self`? -- Should not be printed or displayed in the context, see issue #3584. - } deriving Data + } -- | Useful for debugging scoping problems uglyShowName :: Name -> String @@ -61,7 +60,6 @@ data QName = QName { qnameModule :: ModuleName , qnameName :: Name } - deriving Data -- | Something preceeded by a qualified name. data QNamed a = QNamed @@ -75,14 +73,14 @@ -- The 'SetRange' instance for module names sets all individual ranges -- to the given one. newtype ModuleName = MName { mnameToList :: [Name] } - deriving (Eq, Ord, Data) + deriving (Eq, Ord) -- | Ambiguous qualified names. Used for overloaded constructors. -- -- Invariant: All the names in the list must have the same concrete, -- unqualified name. (This implies that they all have the same 'Range'). newtype AmbiguousQName = AmbQ { unAmbQ :: List1 QName } - deriving (Eq, Ord, Data, NFData) + deriving (Eq, Ord, NFData) -- | A singleton "ambiguous" name. unambiguous :: QName -> AmbiguousQName @@ -105,7 +103,7 @@ data Suffix = NoSuffix | Suffix !Integer - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) instance NFData Suffix where rnf NoSuffix = () @@ -224,16 +222,6 @@ mnameToConcrete (MName (x:xs)) = foldr C.Qual (C.QName $ List1.last cs) $ List1.init cs where cs = fmap nameConcrete (x :| xs) - --- | Computes the 'TopLevelModuleName' corresponding to the given --- module name, which is assumed to represent a top-level module name. --- --- Precondition: The module name must be well-formed. - -toTopLevelModuleName :: ModuleName -> C.TopLevelModuleName -toTopLevelModuleName (MName []) = __IMPOSSIBLE__ -toTopLevelModuleName (MName ms) = List1.ifNull ms __IMPOSSIBLE__ {-else-} $ \ ms1 -> - C.TopLevelModuleName (getRange ms1) $ fmap (C.nameToRawName . nameConcrete) ms1 qualifyM :: ModuleName -> ModuleName -> ModuleName qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2 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 @@ -8,6 +8,7 @@ import Control.Monad.Identity import Data.Foldable (foldMap) +import qualified Data.DList as DL import Data.Semigroup ((<>)) import Data.Void @@ -37,18 +38,20 @@ appView = fmap snd . appView' appView' :: Expr -> AppView' (AppInfo, Expr) -appView' e = - case e of +appView' e = f (DL.toList es) + where + (f, es) = appView'' e + + appView'' e = case e of App i e1 e2 | Dot _ e2' <- unScope $ namedArg e2 , Just f <- maybeProjTurnPostfix e2' , getHiding e2 == NotHidden -- Jesper, 2018-12-13: postfix projections shouldn't be hidden - -> Application f [defaultNamedArg (i, e1)] - App i e1 arg - | Application hd es <- appView' e1 - -> Application hd $ es ++ [(fmap . fmap) (i,) arg] - ScopedExpr _ e -> appView' e - _ -> Application e [] + -> (Application f, singleton (defaultNamedArg (i, e1))) + App i e1 arg | (f, es) <- appView'' e1 -> + (f, es `DL.snoc` (fmap . fmap) (i,) arg) + ScopedExpr _ e -> appView'' e + _ -> (Application e, mempty) maybeProjTurnPostfix :: Expr -> Maybe Expr maybeProjTurnPostfix e = @@ -70,6 +73,18 @@ lamView (ScopedExpr _ e) = lamView e lamView e = LamView [] e +-- | Collect @A.Pi@s. +data PiView = PiView [(ExprInfo, Telescope1)] Type + +piView :: Expr -> PiView +piView = \case + Pi i tel b -> cons $ piView b + where cons (PiView tels t) = PiView ((i,tel) : tels) t + e -> PiView [] e + +unPiView :: PiView -> Expr +unPiView (PiView tels t) = foldr (uncurry Pi) t tels + -- | Gather top-level 'AsP'atterns and 'AnnP'atterns to expose underlying pattern. asView :: A.Pattern -> ([Name], [A.Expr], A.Pattern) asView (A.AsP _ x p) = (\(asb, ann, p) -> (unBind x : asb, ann, p)) $ asView p @@ -157,7 +172,6 @@ Generalized s e -> Generalized s <$> recurse e Fun ei arg e -> Fun ei <$> recurse arg <*> recurse e Let ei bs e -> Let ei <$> recurse bs <*> recurse e - ETel tel -> ETel <$> recurse tel Rec ei bs -> Rec ei <$> recurse bs RecUpdate ei e bs -> RecUpdate ei <$> recurse e <*> recurse bs ScopedExpr sc e -> ScopedExpr sc <$> recurse e @@ -190,7 +204,6 @@ Generalized _ e -> m `mappend` fold e Fun _ e e' -> m `mappend` fold e `mappend` fold e' Let _ bs e -> m `mappend` fold bs `mappend` fold e - ETel tel -> m `mappend` fold tel Rec _ as -> m `mappend` fold as RecUpdate _ e as -> m `mappend` fold e `mappend` fold as ScopedExpr _ e -> m `mappend` fold e @@ -226,7 +239,6 @@ Generalized s e -> f =<< Generalized s <$> trav e Fun ei arg e -> f =<< Fun ei <$> trav arg <*> trav e Let ei bs e -> f =<< Let ei <$> trav bs <*> trav e - ETel tel -> f =<< ETel <$> trav tel Rec ei bs -> f =<< Rec ei <$> trav bs RecUpdate ei e bs -> f =<< RecUpdate ei <$> trav e <*> trav bs ScopedExpr sc e -> f =<< ScopedExpr sc <$> trav e @@ -289,6 +301,11 @@ foldExpr f (DataDefParams s tel) = foldExpr f tel traverseExpr f (DataDefParams s tel) = DataDefParams s <$> traverseExpr f tel +instance ExprLike TypedBindingInfo where + recurseExpr f (TypedBindingInfo s t) = TypedBindingInfo <$> recurseExpr f s <*> pure t + foldExpr f (TypedBindingInfo s t) = foldExpr f s + traverseExpr f (TypedBindingInfo s t) = TypedBindingInfo <$> traverseExpr f s <*> pure t + instance ExprLike TypedBinding where recurseExpr f e = case e of @@ -367,7 +384,7 @@ Invert qn pes -> Invert <$> recurseExpr f qn <*> recurseExpr f pes instance ExprLike WhereDeclarations where - recurseExpr f (WhereDecls a b) = WhereDecls a <$> recurseExpr f b + recurseExpr f (WhereDecls a b c) = WhereDecls a b <$> recurseExpr f c instance ExprLike ModuleApplication where recurseExpr :: forall m. RecurseExprFn m ModuleApplication @@ -392,6 +409,7 @@ InjectivePragma{} -> pure p InlinePragma{} -> pure p EtaPragma{} -> pure p + NotProjectionLikePragma{} -> pure p DisplayPragma f xs e -> DisplayPragma f <$> rec xs <*> rec e where rec :: RecurseExprRecFn m @@ -428,6 +446,7 @@ PatternSynDef f xs p -> PatternSynDef f xs <$> rec p UnquoteDecl i is xs e -> UnquoteDecl i is xs <$> rec e UnquoteDef i xs e -> UnquoteDef i xs <$> rec e + UnquoteData i xs uc j cs e -> UnquoteData i xs uc j cs <$> rec e ScopedDecl s ds -> ScopedDecl s <$> rec ds where rec :: RecurseExprRecFn m @@ -490,6 +509,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 FunDef _ q _ cls -> singleton (WithKind FunName q) <> declaredNames cls ScopedDecl _ decls -> declaredNames decls Section _ _ _ decls -> declaredNames decls @@ -505,21 +525,22 @@ instance DeclaredNames Pragma where declaredNames = \case BuiltinNoDefPragma _b kind x -> singleton $ WithKind kind x - BuiltinPragma{} -> mempty - CompilePragma{} -> mempty - RewritePragma{} -> mempty - StaticPragma{} -> mempty - EtaPragma{} -> mempty - InjectivePragma{} -> mempty - InlinePragma{} -> mempty - DisplayPragma{} -> mempty - OptionsPragma{} -> mempty + BuiltinPragma{} -> mempty + CompilePragma{} -> mempty + RewritePragma{} -> mempty + StaticPragma{} -> mempty + EtaPragma{} -> mempty + InjectivePragma{} -> mempty + InlinePragma{} -> mempty + NotProjectionLikePragma{} -> mempty + DisplayPragma{} -> mempty + OptionsPragma{} -> mempty instance DeclaredNames Clause where declaredNames (Clause _ _ rhs decls _) = declaredNames rhs <> declaredNames decls instance DeclaredNames WhereDeclarations where - declaredNames (WhereDecls _ ds) = declaredNames ds + declaredNames (WhereDecls _ _ ds) = declaredNames ds instance DeclaredNames RHS where declaredNames = \case @@ -575,7 +596,6 @@ -- Set{} -> mempty -- Prop{} -> mempty -- Let _ lbs e -> declaredNames lbs <> declaredNames e --- ETel{} -> __IMPOSSIBLE__ -- Rec _ fields -> declaredNames fields -- RecUpdate _ e fs -> declaredNames e <> declaredNames fs -- ScopedExpr _ e -> declaredNames e 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 @@ -23,7 +23,7 @@ builtinGlue, builtin_glue, builtin_unglue, builtin_glueU, builtin_unglueU, builtinFaceForall, - builtinId, builtinConId, builtinIdElim, + builtinId, builtinReflId, builtinConId, builtinIdElim, builtinSizeUniv, builtinSize, builtinSizeLt, builtinSizeSuc, builtinSizeInf, builtinSizeMax, builtinInf, builtinSharp, builtinFlat, @@ -31,6 +31,7 @@ builtinLevel, builtinLevelZero, builtinLevelSuc, builtinSet, builtinProp, builtinSetOmega, builtinStrictSet, builtinSSetOmega, builtinLockUniv, + builtinIntervalUniv, builtinFromNat, builtinFromNeg, builtinFromString, builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit, builtinAgdaSortProp, builtinAgdaSortPropLit, builtinAgdaSortInf, @@ -48,7 +49,7 @@ builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam, builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi, builtinAgdaTermSort, builtinAgdaTermLit, builtinAgdaTermUnsupported, builtinAgdaTermMeta, - builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName, + builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartPatt, builtinAgdaErrorPartName, builtinAgdaLiteral, builtinAgdaLitNat, builtinAgdaLitWord64, builtinAgdaLitFloat, builtinAgdaLitChar, builtinAgdaLitString, builtinAgdaLitQName, builtinAgdaLitMeta, builtinAgdaClause, builtinAgdaClauseClause, builtinAgdaClauseAbsurd, builtinAgdaPattern, @@ -64,15 +65,17 @@ builtinAgdaTCMCheckType, builtinAgdaTCMNormalise, builtinAgdaTCMReduce, builtinAgdaTCMCatchError, builtinAgdaTCMGetContext, builtinAgdaTCMExtendContext, builtinAgdaTCMInContext, - builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDefineFun, + builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDeclareData, builtinAgdaTCMDefineData, builtinAgdaTCMDefineFun, builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition, builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm, builtinAgdaTCMQuoteOmegaTerm, builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit, builtinAgdaTCMIsMacro, - builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconsParams, builtinAgdaTCMDebugPrint, + builtinAgdaTCMFormatErrorParts, builtinAgdaTCMDebugPrint, + builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconsParams, builtinAgdaTCMOnlyReduceDefs, builtinAgdaTCMDontReduceDefs, builtinAgdaTCMNoConstraints, builtinAgdaTCMRunSpeculative, - builtinAgdaTCMExec + builtinAgdaTCMExec, + builtinAgdaTCMGetInstances :: String builtinNat = "NATURAL" @@ -106,10 +109,12 @@ builtinJust = "JUST" builtinIO = "IO" builtinId = "ID" -builtinConId = "CONID" +builtinReflId = "REFLID" +builtinConId = "primConId" builtinIdElim = "primIdElim" builtinPath = "PATH" builtinPathP = "PATHP" +builtinIntervalUniv = "CUBEINTERVALUNIV" builtinInterval = "INTERVAL" builtinIMin = "primIMin" builtinIMax = "primIMax" @@ -214,6 +219,7 @@ builtinAgdaErrorPart = "AGDAERRORPART" builtinAgdaErrorPartString = "AGDAERRORPARTSTRING" builtinAgdaErrorPartTerm = "AGDAERRORPARTTERM" +builtinAgdaErrorPartPatt = "AGDAERRORPARTPATT" builtinAgdaErrorPartName = "AGDAERRORPARTNAME" builtinAgdaLiteral = "AGDALITERAL" builtinAgdaLitNat = "AGDALITNAT" @@ -257,6 +263,8 @@ builtinAgdaTCMFreshName = "AGDATCMFRESHNAME" builtinAgdaTCMDeclareDef = "AGDATCMDECLAREDEF" builtinAgdaTCMDeclarePostulate = "AGDATCMDECLAREPOSTULATE" +builtinAgdaTCMDeclareData = "AGDATCMDECLAREDATA" +builtinAgdaTCMDefineData = "AGDATCMDEFINEDATA" builtinAgdaTCMDefineFun = "AGDATCMDEFINEFUN" builtinAgdaTCMGetType = "AGDATCMGETTYPE" builtinAgdaTCMGetDefinition = "AGDATCMGETDEFINITION" @@ -268,12 +276,14 @@ builtinAgdaTCMIsMacro = "AGDATCMISMACRO" builtinAgdaTCMWithNormalisation = "AGDATCMWITHNORMALISATION" builtinAgdaTCMWithReconsParams = "AGDATCMWITHRECONSPARAMS" +builtinAgdaTCMFormatErrorParts = "AGDATCMFORMATERRORPARTS" builtinAgdaTCMDebugPrint = "AGDATCMDEBUGPRINT" builtinAgdaTCMOnlyReduceDefs = "AGDATCMONLYREDUCEDEFS" builtinAgdaTCMDontReduceDefs = "AGDATCMDONTREDUCEDEFS" builtinAgdaTCMNoConstraints = "AGDATCMNOCONSTRAINTS" builtinAgdaTCMRunSpeculative = "AGDATCMRUNSPECULATIVE" builtinAgdaTCMExec = "AGDATCMEXEC" +builtinAgdaTCMGetInstances = "AGDATCMGETINSTANCES" -- | Builtins that come without a definition in Agda syntax. -- These are giving names to Agda internal concepts which @@ -293,6 +303,9 @@ builtinsNoDef = sizeBuiltins ++ [ builtinConId + , builtinIntervalUniv + , builtinId + , builtinReflId , builtinInterval , builtinPartial , builtinPartialP 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 @@ -17,10 +17,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString import qualified Data.Foldable as Fold -import Data.Function +import Data.Function (on) import Data.Hashable (Hashable(..)) import qualified Data.Strict.Maybe as Strict -import Data.Data (Data) import Data.Word import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -29,6 +28,7 @@ import Agda.Syntax.Position +import Agda.Utils.BiMap (HasTag(..)) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List1 ( List1, pattern (:|), (<|) ) @@ -50,7 +50,7 @@ -- | Used to specify whether something should be delayed. data Delayed = Delayed | NotDelayed - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) instance KillRange Delayed where killRange = id @@ -62,7 +62,7 @@ --------------------------------------------------------------------------- data FileType = AgdaFileType | MdFileType | RstFileType | TexFileType | OrgFileType - deriving (Data, Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Pretty FileType where pretty = \case @@ -109,7 +109,7 @@ , recHasEta :: Maybe HasEta0 , recPattern :: Maybe Range , recConstructor :: Maybe a - } deriving (Functor, Data, Show, Eq) + } deriving (Functor, Show, Eq) emptyRecordDirectives :: RecordDirectives' a emptyRecordDirectives = RecordDirectives empty empty empty empty @@ -131,7 +131,7 @@ data HasEta' a = YesEta | NoEta a - deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable) instance HasRange a => HasRange (HasEta' a) where getRange = foldMap getRange @@ -158,7 +158,7 @@ -- ^ Can match on the record constructor. | CopatternMatching -- ^ Can copattern match using the projections. (Default.) - deriving (Data, Show, Eq, Ord, Enum, Bounded) + deriving (Show, Eq, Ord, Enum, Bounded) instance NFData PatternOrCopattern where rnf PatternMatching = () @@ -201,7 +201,7 @@ -- | @Inductive < Coinductive@ data Induction = Inductive | CoInductive -- Keep in this order! - deriving (Data, Eq, Ord, Show) + deriving (Eq, Ord, Show) instance Pretty Induction where pretty Inductive = "inductive" @@ -225,10 +225,10 @@ --------------------------------------------------------------------------- data Overlappable = YesOverlap | NoOverlap - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) data Hiding = Hidden | Instance Overlappable | NotHidden - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) instance Pretty Hiding where pretty = \case @@ -280,7 +280,7 @@ { whHiding :: !Hiding , whThing :: a } - deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) instance Decoration WithHiding where traverseF f (WithHiding h a) = WithHiding h <$> f a @@ -416,7 +416,7 @@ -- ^ Cohesion/what was in Agda-flat. -- see "Brouwer's fixed-point theorem in real-cohesive homotopy type theory" (arXiv:1509.07584) -- Currently only the comonad is implemented. - } deriving (Data, Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic) -- | Dominance ordering. instance PartialOrd Modality where @@ -621,21 +621,21 @@ = Q0Inferred -- ^ User wrote nothing. | Q0 Range -- ^ User wrote "@0". | Q0Erased Range -- ^ User wrote "@erased". - deriving (Data, Show, Generic, Eq, Ord) + deriving (Show, Generic, Eq, Ord) -- | Origin of 'Quantity1'. data Q1Origin = Q1Inferred -- ^ User wrote nothing. | Q1 Range -- ^ User wrote "@1". | Q1Linear Range -- ^ User wrote "@linear". - deriving (Data, Show, Generic, Eq, Ord) + deriving (Show, Generic, Eq, Ord) -- | Origin of 'Quantityω'. data QωOrigin = QωInferred -- ^ User wrote nothing. | Qω Range -- ^ User wrote "@ω". | QωPlenty Range -- ^ User wrote "@plenty". - deriving (Data, Show, Generic, Eq, Ord) + deriving (Show, Generic, Eq, Ord) -- *** Instances for 'Q0Origin'. @@ -776,7 +776,7 @@ | Quantity1 Q1Origin -- ^ Linear use @{1}@ (could be updated destructively). -- Mostly TODO (needs postponable constraints between quantities to compute uses). | Quantityω QωOrigin -- ^ Unrestricted use @ℕ@. - deriving (Data, Show, Generic, Eq, Ord) + deriving (Show, Generic, Eq, Ord) -- @Ord@ instance in case @Quantity@ is used in keys for maps etc. -- | Equality ignoring origin. @@ -995,7 +995,7 @@ data Erased = Erased Q0Origin | NotErased QωOrigin - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | The default value of type 'Erased': not erased. @@ -1065,7 +1065,7 @@ -- Therefore, it is irrelevant at run-time. -- It is treated relevantly during equality checking. | Irrelevant -- ^ The argument is irrelevant at compile- and runtime. - deriving (Data, Show, Eq, Enum, Bounded, Generic) + deriving (Show, Eq, Enum, Bounded, Generic) allRelevances :: [Relevance] allRelevances = [minBound..maxBound] @@ -1244,7 +1244,6 @@ nonStrictToIrr NonStrict = Irrelevant nonStrictToIrr rel = rel - --------------------------------------------------------------------------- -- * Annotations --------------------------------------------------------------------------- @@ -1254,7 +1253,7 @@ { annLock :: Lock -- ^ Fitch-style dependent right adjoints. -- See Modal Dependent Type Theory and Dependent Right Adjoints, arXiv:1804.05236. - } deriving (Data, Eq, Ord, Show, Generic) + } deriving (Eq, Ord, Show, Generic) instance HasRange Annotation where getRange _ = noRange @@ -1300,7 +1299,7 @@ data Lock = IsNotLock | IsLock -- ^ In the future there might be different kinds of them. -- For now we assume lock weakening. - deriving (Data, Show, Generic, Eq, Enum, Bounded, Ord) + deriving (Show, Generic, Eq, Enum, Bounded, Ord) defaultLock :: Lock defaultLock = IsNotLock @@ -1326,7 +1325,7 @@ instance LensLock ArgInfo where getLock = annLock . argInfoAnnotation - setLock l info = info { argInfoAnnotation = Annotation l } + setLock l info = info { argInfoAnnotation = (argInfoAnnotation info){ annLock = l } } instance LensLock (Arg t) where getLock = getLock . getArgInfo @@ -1344,7 +1343,7 @@ | Continuous -- ^ identity modality. -- | Sharp -- ^ same points, codiscrete topology, idempotent monad, diamond-like. | Squash -- ^ single point space, artificially added for Flat left-composition. - deriving (Data, Show, Eq, Enum, Bounded, Generic) + deriving (Show, Eq, Enum, Bounded, Generic) allCohesions :: [Cohesion] allCohesions = [minBound..maxBound] @@ -1514,7 +1513,7 @@ | Reflected -- ^ Produced by the reflection machinery. | CaseSplit -- ^ Produced by an interactive case split. | Substitution -- ^ Named application produced to represent a substitution. E.g. "?0 (x = n)" instead of "?0 n" - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) instance HasRange Origin where getRange _ = noRange @@ -1534,7 +1533,7 @@ { woOrigin :: !Origin , woThing :: a } - deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) instance Decoration WithOrigin where traverseF f (WithOrigin h a) = WithOrigin h <$> f a @@ -1587,7 +1586,7 @@ ----------------------------------------------------------------------------- data FreeVariables = UnknownFVs | KnownFVs IntSet - deriving (Data, Eq, Ord, Show) + deriving (Eq, Ord, Show) instance Semigroup FreeVariables where UnknownFVs <> _ = UnknownFVs @@ -1659,7 +1658,7 @@ , argInfoAnnotation :: Annotation -- ^ Sometimes we want a different kind of binder/pi-type, without it -- supporting any of the @Modality@ interface. - } deriving (Data, Eq, Ord, Show) + } deriving (Eq, Ord, Show) instance HasRange ArgInfo where getRange (ArgInfo h m o _fv a) = getRange (h, m, o, a) @@ -1791,7 +1790,7 @@ data Arg e = Arg { argInfo :: ArgInfo , unArg :: e - } deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable) + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) instance Decoration Arg where traverseF f (Arg ai a) = Arg ai <$> f a @@ -1961,7 +1960,7 @@ Named { nameOf :: Maybe name , namedThing :: a } - deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) -- | Standard naming. type Named_ = Named NamedName @@ -2130,7 +2129,7 @@ { rangeOf :: Range , rangedThing :: a } - deriving (Data, Show, Functor, Foldable, Traversable) + deriving (Show, Functor, Foldable, Traversable) -- | Thing with no range info. unranged :: a -> Ranged a @@ -2188,7 +2187,7 @@ | ConOCon -- ^ User wrote a constructor (pattern). | ConORec -- ^ User wrote a record (pattern). | ConOSplit -- ^ Generated by interactive case splitting. - deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic) + deriving (Show, Eq, Ord, Enum, Bounded, Generic) instance NFData ConOrigin @@ -2205,7 +2204,7 @@ = ProjPrefix -- ^ User wrote a prefix projection. | ProjPostfix -- ^ User wrote a postfix projection. | ProjSystem -- ^ Projection was generated by the system. - deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic) + deriving (Show, Eq, Ord, Enum, Bounded, Generic) instance NFData ProjOrigin @@ -2219,7 +2218,7 @@ -- | Functions can be defined in both infix and prefix style. See -- 'Agda.Syntax.Concrete.LHS'. data IsInfix = InfixDef | PrefixDef - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) -- ** private blocks, public imports @@ -2229,7 +2228,7 @@ -- ^ Store the 'Origin' of the private block that lead to this qualifier. -- This is needed for more faithful printing of declarations. | PublicAccess - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) instance Pretty Access where pretty = text . \case @@ -2249,7 +2248,7 @@ -- | Abstract or concrete. data IsAbstract = AbstractDef | ConcreteDef - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | Semigroup computes if any of several is an 'AbstractDef'. instance Semigroup IsAbstract where @@ -2291,7 +2290,7 @@ data IsInstance = InstanceDef Range -- ^ Range of the @instance@ keyword. | NotInstanceDef - deriving (Data, Show, Eq, Ord) + deriving (Show, Eq, Ord) instance KillRange IsInstance where killRange = \case @@ -2311,7 +2310,7 @@ -- | Is this a macro definition? data IsMacro = MacroDef | NotMacroDef - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) instance KillRange IsMacro where killRange = id instance HasRange IsMacro where getRange _ = noRange @@ -2322,16 +2321,26 @@ -- * NameId --------------------------------------------------------------------------- -newtype ModuleNameHash = ModuleNameHash Word64 - deriving (Eq, Ord, Show, Data) +newtype ModuleNameHash = ModuleNameHash { moduleNameHash :: Word64 } + deriving (Eq, Ord, Hashable) +instance HasTag ModuleNameHash where + type Tag ModuleNameHash = ModuleNameHash + tag = Just . id + noModuleNameHash :: ModuleNameHash noModuleNameHash = ModuleNameHash 0 +-- | The record selector is not included in the resulting strings. + +instance Show ModuleNameHash where + showsPrec p (ModuleNameHash h) = showParen (p > 0) $ + showString "ModuleNameHash " . shows h + -- | The unique identifier of a name. Second argument is the top-level module -- identifier. data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash - deriving (Eq, Ord, Data, Generic, Show) + deriving (Eq, Ord, Generic, Show) instance KillRange NameId where killRange = id @@ -2359,23 +2368,41 @@ -- * Meta variables --------------------------------------------------------------------------- --- | A meta variable identifier is just a natural number. --- -newtype MetaId = MetaId { metaId :: Nat } - deriving (Eq, Ord, Num, Real, Enum, Integral, Data, Generic) +-- | Meta-variable identifiers use the same structure as 'NameId's. +data MetaId = MetaId + { metaId :: {-# UNPACK #-} !Word64 + , metaModule :: {-# UNPACK #-} !ModuleNameHash + } + deriving (Eq, Ord, Generic) + instance Pretty MetaId where - pretty (MetaId n) = text $ "_" ++ show n + pretty (MetaId n m) = + text $ "_" ++ show n ++ "@" ++ show (moduleNameHash m) --- | Show non-record version of this newtype. +instance Enum MetaId where + succ MetaId{..} = MetaId { metaId = succ metaId, .. } + pred MetaId{..} = MetaId { metaId = pred metaId, .. } + + -- The following functions should not be used. + toEnum = __IMPOSSIBLE__ + fromEnum = __IMPOSSIBLE__ + +-- | The record selectors are not included in the resulting strings. + instance Show MetaId where - showsPrec p (MetaId n) = showParen (p > 0) $ - showString "MetaId " . shows n + showsPrec p (MetaId n m) = showParen (p > 0) $ + showString "MetaId " . + showsPrec 11 n . + showString " " . + showsPrec 11 m instance NFData MetaId where - rnf (MetaId x) = rnf x + rnf (MetaId x y) = rnf x `seq` rnf y -instance Hashable MetaId +instance Hashable MetaId where + {-# INLINE hashWithSalt #-} + hashWithSalt salt (MetaId n m) = hashWithSalt salt (n, m) newtype Constr a = Constr a @@ -2386,7 +2413,7 @@ -- | A "problem" consists of a set of constraints and the same constraint can be part of multiple -- problems. newtype ProblemId = ProblemId Nat - deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData) + deriving (Eq, Ord, Enum, Real, Integral, Num, NFData) -- This particular Show instance is ok because of the Num instance. instance Show ProblemId where show (ProblemId n) = show n @@ -2407,7 +2434,7 @@ -- @foo_bar@. | End -- ^ The following underscore is at the end of the name: @foo_@. - deriving (Show, Eq, Ord, Data) + deriving (Show, Eq, Ord) -- | Placeholders are used to represent the underscores in a section. @@ -2416,7 +2443,7 @@ | NoPlaceholder !(Strict.Maybe PositionInName) e -- ^ The second argument is used only (but not always) for name -- parts other than underscores. - deriving (Data, Eq, Ord, Functor, Foldable, Traversable, Show) + deriving (Eq, Ord, Functor, Foldable, Traversable, Show) -- | An abbreviation: @noPlaceholder = 'NoPlaceholder' -- 'Strict.Nothing'@. @@ -2448,7 +2475,6 @@ , Integral , Real , Enum - , Data , NFData ) @@ -2470,7 +2496,7 @@ -- ^ No fixity declared. | Related !PrecedenceLevel -- ^ Fixity level declared as the number. - deriving (Eq, Ord, Show, Data) + deriving (Eq, Ord, Show) instance Null FixityLevel where null Unrelated = True @@ -2484,7 +2510,7 @@ -- | Associativity. data Associativity = NonAssoc | LeftAssoc | RightAssoc - deriving (Eq, Ord, Show, Data) + deriving (Eq, Ord, Show) -- | Fixity of operators. @@ -2494,7 +2520,7 @@ , fixityLevel :: !FixityLevel , fixityAssoc :: !Associativity } - deriving (Data, Show) + deriving Show noFixity :: Fixity noFixity = Fixity noRange Unrelated NonAssoc @@ -2534,7 +2560,7 @@ -- ^ Range of the name in the fixity declaration -- (used for correct highlighting, see issue #2140). } - deriving (Data, Show) + deriving Show noFixity' :: Fixity' noFixity' = Fixity' noFixity noNotation noRange @@ -2591,7 +2617,7 @@ , impRenaming :: RenamingDirective' n m , publicOpen :: Maybe Range -- ^ Only for @open@. Exports the opened names from the current module. } - deriving (Data, Eq) + deriving Eq type HidingDirective' n m = [ImportedName' n m] type RenamingDirective' n m = [Renaming' n m] @@ -2629,7 +2655,7 @@ data Using' n m = UseEverything -- ^ No @using@ clause given. | Using [ImportedName' n m] -- ^ @using@ the specified names. - deriving (Data, Eq) + deriving Eq instance Semigroup (Using' n m) where UseEverything <> u = u @@ -2654,7 +2680,7 @@ data ImportedName' n m = ImportedModule m -- ^ Imported module name of type @m@. | ImportedName n -- ^ Imported name of type @n@. - deriving (Data, Eq, Ord, Show) + deriving (Eq, Ord, Show) fromImportedName :: ImportedName' a a -> a fromImportedName = \case @@ -2690,7 +2716,7 @@ , renToRange :: Range -- ^ The range of the \"to\" keyword. Retained for highlighting purposes. } - deriving (Data, Eq) + deriving Eq -- ** HasRange instances @@ -2761,7 +2787,7 @@ -- ^ Treat as terminating (unsafe). Same effect as 'NoTerminationCheck'. | TerminationMeasure Range m -- ^ Skip termination checking but use measure instead. - deriving (Data, Show, Eq, Functor) + deriving (Show, Eq, Functor) instance KillRange m => KillRange (TerminationCheck m) where killRange (TerminationMeasure _ m) = TerminationMeasure noRange (killRange m) @@ -2780,7 +2806,7 @@ -- | Positivity check? (Default = True). data PositivityCheck = YesPositivityCheck | NoPositivityCheck - deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic) + deriving (Eq, Ord, Show, Bounded, Enum, Generic) instance KillRange PositivityCheck where killRange = id @@ -2803,7 +2829,7 @@ -- | Universe check? (Default is yes). data UniverseCheck = YesUniverseCheck | NoUniverseCheck - deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic) + deriving (Eq, Ord, Show, Bounded, Enum, Generic) instance KillRange UniverseCheck where killRange = id @@ -2816,7 +2842,7 @@ -- | Coverage check? (Default is yes). data CoverageCheck = YesCoverageCheck | NoCoverageCheck - deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic) + deriving (Eq, Ord, Show, Bounded, Enum, Generic) instance KillRange CoverageCheck where killRange = id @@ -2847,7 +2873,7 @@ data RewriteEqn' qn nm p e = Rewrite (List1 (qn, e)) -- ^ @rewrite e@ | Invert qn (List1 (Named nm (p, e))) -- ^ @with p <- e in eq@ - deriving (Data, Eq, Show, Functor, Foldable, Traversable) + deriving (Eq, Show, Functor, Foldable, Traversable) instance (NFData qn, NFData nm, NFData p, NFData e) => NFData (RewriteEqn' qn nm p e) where rnf = \case @@ -2888,7 +2914,7 @@ , ellipsisWithArgs :: Int } | NoEllipsis - deriving (Data, Show, Eq) + deriving (Show, Eq) instance Null ExpandedEllipsis where null = (== NoEllipsis) @@ -2912,65 +2938,98 @@ rnf NoEllipsis = () -- | Notation as provided by the @syntax@ declaration. -type Notation = [GenPart] +type Notation = [NotationPart] noNotation :: Notation noNotation = [] --- | Part of a Notation -data GenPart - = BindHole Range (Ranged Int) - -- ^ Argument is the position of the hole (with binding) where the binding should occur. - -- First range is the rhs range and second is the binder. - | NormalHole Range (NamedArg (Ranged Int)) - -- ^ Argument is where the expression should go. - | WildHole (Ranged Int) - -- ^ An underscore in binding position. - | IdPart RString - deriving (Data, Show) +-- | Positions of variables in syntax declarations. -instance Eq GenPart where - BindHole _ i == BindHole _ j = i == j - NormalHole _ x == NormalHole _ y = x == y - WildHole i == WildHole j = i == j - IdPart x == IdPart y = x == y - _ == _ = False +data BoundVariablePosition = BoundVariablePosition + { holeNumber :: !Int + -- ^ The position (in the left-hand side of the syntax + -- declaration) of the hole in which the variable is bound, + -- counting from zero (and excluding parts that are not holes). + -- For instance, for @syntax Σ A (λ x → B) = B , A , x@ the number + -- for @x@ is @1@, corresponding to @B@ (@0@ would correspond to + -- @A@). + , varNumber :: !Int + -- ^ The position in the list of variables for this particular + -- variable, counting from zero, and including wildcards. For + -- instance, for @syntax F (λ x _ y → A) = y ! A ! x@ the number + -- for @x@ is @0@, the number for @_@ is @1@, and the number for + -- @y@ is @2@. + } + deriving (Eq, Ord, Show) -instance Ord GenPart where - BindHole _ i `compare` BindHole _ j = i `compare` j - NormalHole _ x `compare` NormalHole _ y = x `compare` y - WildHole i `compare` WildHole j = i `compare` j - IdPart x `compare` IdPart y = x `compare` y - BindHole{} `compare` _ = LT - _ `compare` BindHole{} = GT - NormalHole{} `compare` _ = LT - _ `compare` NormalHole{} = GT - WildHole{} `compare` _ = LT - _ `compare` WildHole{} = GT +-- | Notation parts. -instance HasRange GenPart where +data NotationPart + = IdPart RString + -- ^ An identifier part. For instance, for @_+_@ the only + -- identifier part is @+@. + | HolePart Range (NamedArg (Ranged Int)) + -- ^ A hole: a place where argument expressions can be written. + -- For instance, for @_+_@ the two underscores are holes, and for + -- @syntax Σ A (λ x → B) = B , A , x@ the variables @A@ and @B@ + -- are holes. The number is the position of the hole, counting + -- from zero. For instance, the number for @A@ is @0@, and the + -- number for @B@ is @1@. + | VarPart Range (Ranged BoundVariablePosition) + -- ^ A bound variable. + -- + -- The first range is the range of the variable in the right-hand + -- side of the syntax declaration, and the second range is the + -- range of the variable in the left-hand side. + | WildPart (Ranged BoundVariablePosition) + -- ^ A wildcard (an underscore in binding position). + deriving Show + +instance Eq NotationPart where + VarPart _ i == VarPart _ j = i == j + HolePart _ x == HolePart _ y = x == y + WildPart i == WildPart j = i == j + IdPart x == IdPart y = x == y + _ == _ = False + +instance Ord NotationPart where + VarPart _ i `compare` VarPart _ j = i `compare` j + HolePart _ x `compare` HolePart _ y = x `compare` y + WildPart i `compare` WildPart j = i `compare` j + IdPart x `compare` IdPart y = x `compare` y + VarPart{} `compare` _ = LT + _ `compare` VarPart{} = GT + HolePart{} `compare` _ = LT + _ `compare` HolePart{} = GT + WildPart{} `compare` _ = LT + _ `compare` WildPart{} = GT + +instance HasRange NotationPart where getRange = \case - IdPart x -> getRange x - BindHole r _ -> r - WildHole i -> getRange i - NormalHole r _ -> r + IdPart x -> getRange x + VarPart r _ -> r + WildPart i -> getRange i + HolePart r _ -> r -instance SetRange GenPart where +instance SetRange NotationPart where setRange r = \case - IdPart x -> IdPart x - BindHole _ i -> BindHole r i - WildHole i -> WildHole i - NormalHole _ i -> NormalHole r i + IdPart x -> IdPart x + VarPart _ i -> VarPart r i + WildPart i -> WildPart i + HolePart _ i -> HolePart r i -instance KillRange GenPart where +instance KillRange NotationPart where killRange = \case - IdPart x -> IdPart $ killRange x - BindHole _ i -> BindHole noRange $ killRange i - WildHole i -> WildHole $ killRange i - NormalHole _ x -> NormalHole noRange $ killRange x + IdPart x -> IdPart $ killRange x + VarPart _ i -> VarPart noRange $ killRange i + WildPart i -> WildPart $ killRange i + HolePart _ x -> HolePart noRange $ killRange x -instance NFData GenPart where - rnf (BindHole _ a) = rnf a - rnf (NormalHole _ a) = rnf a - rnf (WildHole a) = rnf a - rnf (IdPart a) = rnf a +instance NFData BoundVariablePosition where + rnf = (`seq` ()) + +instance NFData NotationPart where + rnf (VarPart _ a) = rnf a + rnf (HolePart _ a) = rnf a + rnf (WildPart a) = rnf a + rnf (IdPart a) = rnf a 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 @@ -61,7 +61,6 @@ , Module(..) , ThingWithFixity(..) , HoleContent, HoleContent'(..) - , topLevelModuleName , spanAllowedBeforeModule ) where @@ -70,7 +69,7 @@ import Control.DeepSeq -import Data.Data ( Data ) +import qualified Data.DList as DL import Data.Functor.Identity import Data.Set ( Set ) import Data.Text ( Text ) @@ -103,14 +102,14 @@ -- ^ An abstraction inside a special syntax declaration -- (see Issue 358 why we introduce this). | Ordinary e - deriving (Data, Functor, Foldable, Traversable, Eq) + deriving (Functor, Foldable, Traversable, Eq) fromOrdinary :: e -> OpApp e -> e fromOrdinary d (Ordinary e) = e fromOrdinary d _ = d data FieldAssignment' a = FieldAssignment { _nameFieldA :: Name, _exprFieldA :: a } - deriving (Data, Functor, Foldable, Traversable, Show, Eq) + deriving (Functor, Foldable, Traversable, Show, Eq) type FieldAssignment = FieldAssignment' Expr @@ -119,7 +118,7 @@ , _exprModA :: [Expr] , _importDirModA :: ImportDirective } - deriving (Data, Eq) + deriving Eq type RecordAssignment = Either FieldAssignment ModuleAssignment type RecordAssignments = [RecordAssignment] @@ -170,7 +169,6 @@ | As Range Name Expr -- ^ ex: @x\@p@, only in patterns | Dot Range Expr -- ^ ex: @.p@, only in patterns | DoubleDot Range Expr -- ^ ex: @..A@, used for parsing @..A -> B@ - | ETel Telescope -- ^ only used for printing telescopes | Quote Range -- ^ ex: @quote@, should be applied to a name | QuoteTerm Range -- ^ ex: @quoteTerm@, should be applied to a term | Tactic Range Expr -- ^ ex: @\@(tactic t)@, used to declare tactic arguments @@ -179,7 +177,7 @@ | Equal Range Expr Expr -- ^ ex: @a = b@, used internally in the parser | Ellipsis Range -- ^ @...@, used internally to parse patterns. | Generalized Expr - deriving (Data, Eq) + deriving Eq type OpAppArgs = OpAppArgs' Expr type OpAppArgs' e = [NamedArg (MaybePlaceholder (OpApp e))] @@ -210,19 +208,19 @@ -- Second arg is @Nothing@ before expansion, and -- @Just p@ after expanding ellipsis to @p@. | WithP Range Pattern -- ^ @| p@, for with-patterns. - deriving (Data, Eq) + deriving Eq data DoStmt = DoBind Range Pattern Expr [LamClause] -- ^ @p ← e where cs@ | DoThen Expr | DoLet Range (List1 Declaration) - deriving (Data, Eq) + deriving Eq -- | A Binder @x\@p@, the pattern is optional data Binder' a = Binder { binderPattern :: Maybe Pattern , binderName :: a - } deriving (Data, Eq, Functor, Foldable, Traversable) + } deriving (Eq, Functor, Foldable, Traversable) type Binder = Binder' BoundName @@ -240,7 +238,7 @@ -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@ or @x\@p@ or @(p)@ | DomainFull a -- ^ . @(xs : e)@ or @{xs : e}@ - deriving (Data, Functor, Foldable, Traversable, Eq) + deriving (Functor, Foldable, Traversable, Eq) -- | Drop type annotations and lets from bindings. dropTypeAndModality :: LamBinding -> [LamBinding] @@ -250,11 +248,12 @@ dropTypeAndModality (DomainFree x) = [DomainFree $ setModality defaultModality x] data BoundName = BName - { boundName :: Name - , bnameFixity :: Fixity' - , bnameTactic :: TacticAttribute -- From @tactic attribute + { boundName :: Name + , bnameFixity :: Fixity' + , bnameTactic :: TacticAttribute -- From @tactic attribute + , bnameIsFinite :: Bool } - deriving (Data, Eq) + deriving Eq type TacticAttribute = Maybe Expr @@ -262,7 +261,7 @@ mkBoundName_ x = mkBoundName x noFixity' mkBoundName :: Name -> Fixity' -> BoundName -mkBoundName x f = BName x f Nothing +mkBoundName x f = BName x f Nothing False -- | A typed binding. @@ -273,7 +272,7 @@ -- ^ Binding @(x1\@p1 ... xn\@pn : A)@. | TLet Range (List1 Declaration) -- ^ Let binding @(let Ds)@ or @(open M args)@. - deriving (Data, Functor, Foldable, Traversable, Eq) + deriving (Functor, Foldable, Traversable, Eq) -- | A telescope is a sequence of typed bindings. Bound variables are in scope -- in later types. @@ -327,7 +326,7 @@ , lhsWithExpr :: [WithExpr] -- ^ @with e1 in eq | {e2} | ...@ (many) } - deriving (Data, Eq) + deriving Eq type RewriteEqn = RewriteEqn' () Name Pattern Expr type WithExpr = Named Name (Arg Expr) @@ -351,13 +350,13 @@ { lhsEllipsisRange :: Range , lhsEllipsisPat :: LHSCore -- ^ Pattern that was expanded from an ellipsis @...@. } - deriving (Data, Eq) + deriving Eq type RHS = RHS' Expr data RHS' e = AbsurdRHS -- ^ No right hand side because of absurd match. | RHS e - deriving (Data, Functor, Foldable, Traversable, Eq) + deriving (Functor, Foldable, Traversable, Eq) -- | @where@ block following a clause. type WhereClause = WhereClause' [Declaration] @@ -375,14 +374,14 @@ -- The 'Access' flag applies to the 'Name' (not the module contents!) -- and is propagated from the parent function. -- List of declarations can be empty. - deriving (Data, Eq, Functor, Foldable, Traversable) + deriving (Eq, Functor, Foldable, Traversable) data LamClause = LamClause { lamLHS :: [Pattern] -- ^ Possibly empty sequence. , lamRHS :: RHS , lamCatchAll :: Bool } - deriving (Data, Eq) + deriving Eq -- | An expression followed by a where clause. -- Currently only used to give better a better error message in interaction. @@ -406,7 +405,7 @@ , asRange :: Range -- ^ The range of the \"as\" keyword. Retained for highlighting purposes. } - deriving (Data, Show, Functor, Foldable, Traversable, Eq) + deriving (Show, Functor, Foldable, Traversable, Eq) -- | From the parser, we get an expression for the @as@-'Name', which -- we have to parse into a 'Name'. @@ -434,7 +433,7 @@ -- ^ Range of @[no-]eta-equality@ keyword. | PatternOrCopattern Range -- ^ If declaration @pattern@ is present, give its range. - deriving (Data,Eq,Show) + deriving (Eq, Show) type RecordDirectives = RecordDirectives' (Name, IsInstance) @@ -479,9 +478,13 @@ | ModuleMacro Range Name ModuleApplication !OpenShortHand ImportDirective | Module Range QName Telescope [Declaration] | UnquoteDecl Range [Name] Expr + -- ^ @unquoteDecl xs = e@ | UnquoteDef Range [Name] Expr + -- ^ @unquoteDef xs = e@ + | UnquoteData Range Name [Name] Expr + -- ^ @unquoteDecl data d constructor xs = e@ | Pragma Pragma - deriving (Data, Eq) + deriving Eq -- | Extract a record directive isRecordDirective :: Declaration -> Maybe RecordDirective @@ -494,10 +497,10 @@ -- ^ @tel. M args@ | RecordModuleInstance Range QName -- ^ @M {{...}}@ - deriving (Data, Eq) + deriving Eq data OpenShortHand = DoOpen | DontOpen - deriving (Data, Eq, Show, Generic) + deriving (Eq, Show, Generic) -- Pragmas ---------------------------------------------------------------- @@ -539,7 +542,9 @@ | PolarityPragma Range Name [Occurrence] | NoUniverseCheckPragma Range -- ^ Applies to the following data/record type. - deriving (Data, Eq) + | NotProjectionLikePragma Range QName + -- ^ Applies to the stated function + deriving Eq --------------------------------------------------------------------------- @@ -550,19 +555,6 @@ , modDecls :: [Declaration] } --- | Computes the top-level module name. --- --- Precondition: The 'Module' has to be well-formed. --- This means that there are only allowed declarations before the --- first module declaration, typically import declarations. --- See 'spanAllowedBeforeModule'. - -topLevelModuleName :: Module -> TopLevelModuleName -topLevelModuleName (Mod _ []) = __IMPOSSIBLE__ -topLevelModuleName (Mod _ ds) = case spanAllowedBeforeModule ds of - (_, Module _ n _ _ : _) -> toTopLevelModuleName n - _ -> __IMPOSSIBLE__ - -- | Splits off allowed (= import) declarations before the first -- non-allowed declaration. -- After successful parsing, the first non-allowed declaration @@ -610,14 +602,18 @@ data AppView = AppView Expr [NamedArg Expr] appView :: Expr -> AppView -appView = \case - App r e1 e2 -> vApp (appView e1) e2 - RawApp _ (List2 e1 e2 es) - -> AppView e1 $ map arg (e2:es) - e -> AppView e [] +appView e = f (DL.toList ess) where - vApp (AppView e es) arg = AppView e (es ++ [arg]) + (f, ess) = appView' e + appView' = \case + App r e1 e2 -> vApp (appView' e1) 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) @@ -823,7 +819,6 @@ InstanceArg r _ -> r Rec r _ -> r RecUpdate r _ _ -> r - ETel tel -> getRange tel Quote r -> r QuoteTerm r -> r Unquote r -> r @@ -903,6 +898,7 @@ getRange (PatternSyn r _ _ _) = r getRange (UnquoteDecl r _ _) = r getRange (UnquoteDef r _ _) = r + getRange (UnquoteData r _ _ _) = r getRange (Pragma p) = getRange p instance HasRange LHS where @@ -946,6 +942,7 @@ getRange (NoPositivityCheckPragma r) = r getRange (PolarityPragma r _ _) = r getRange (NoUniverseCheckPragma r) = r + getRange (NotProjectionLikePragma r _) = r instance HasRange AsName where getRange a = getRange (asRange a, asName a) @@ -1011,7 +1008,7 @@ killRange (Binder a b) = killRange2 Binder a b instance KillRange BoundName where - killRange (BName n f t) = killRange3 BName n f t + killRange (BName n f t b) = killRange4 BName n f t b instance KillRange RecordDirective where killRange (Induction a) = killRange1 Induction a @@ -1050,6 +1047,7 @@ killRange (Module _ q t d) = killRange3 (Module noRange) q t d killRange (UnquoteDecl _ x t) = killRange2 (UnquoteDecl noRange) x t killRange (UnquoteDef _ x t) = killRange2 (UnquoteDef noRange) x t + killRange (UnquoteData _ xs cs t) = killRange3 (UnquoteData noRange) xs cs t killRange (Pragma p) = killRange1 Pragma p instance KillRange Expr where @@ -1078,7 +1076,6 @@ killRange (As _ n e) = killRange2 (As noRange) n e killRange (Dot _ e) = killRange1 (Dot noRange) e killRange (DoubleDot _ e) = killRange1 (DoubleDot noRange) e - killRange (ETel t) = killRange1 ETel t killRange (Quote _) = Quote noRange killRange (QuoteTerm _) = QuoteTerm noRange killRange (Unquote _) = Unquote noRange @@ -1150,6 +1147,7 @@ killRange (NoPositivityCheckPragma _) = NoPositivityCheckPragma noRange killRange (PolarityPragma _ q occs) = killRange1 (\q -> PolarityPragma noRange q occs) q killRange (NoUniverseCheckPragma _) = NoUniverseCheckPragma noRange + killRange (NotProjectionLikePragma _ q) = NotProjectionLikePragma noRange q instance KillRange RHS where killRange AbsurdRHS = AbsurdRHS @@ -1195,7 +1193,6 @@ rnf (As _ a b) = rnf a `seq` rnf b rnf (Dot _ a) = rnf a rnf (DoubleDot _ a) = rnf a - rnf (ETel a) = rnf a rnf (Quote _) = () rnf (QuoteTerm _) = () rnf (Tactic _ a) = rnf a @@ -1265,6 +1262,7 @@ rnf (Module _ a b c) = rnf a `seq` rnf b `seq` rnf c rnf (UnquoteDecl _ a b) = rnf a `seq` rnf b rnf (UnquoteDef _ a b) = rnf a `seq` rnf b + rnf (UnquoteData _ a b c) = rnf a `seq` rnf b `seq` rnf c rnf (Pragma a) = rnf a instance NFData OpenShortHand @@ -1291,6 +1289,7 @@ rnf (NoPositivityCheckPragma _) = () rnf (PolarityPragma _ a b) = rnf a `seq` rnf b rnf (NoUniverseCheckPragma _) = () + rnf (NotProjectionLikePragma _ q) = rnf q -- | Ranges are not forced. @@ -1342,7 +1341,7 @@ rnf (Binder a b) = rnf a `seq` rnf b instance NFData BoundName where - rnf (BName a b c) = rnf a `seq` rnf b `seq` rnf c + rnf (BName a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d instance NFData a => NFData (RHS' a) where rnf AbsurdRHS = () 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 @@ -93,6 +93,18 @@ , ("flat" , Flat) ] +-- | Information about cohesion attributes (printed representations +-- and positions). +-- +-- This information is returned by the parser. Code that calls the +-- parser should, if appropriate, complain if support for cohesion +-- attributes has not been enabled and the returned list is non-empty. +-- This can be taken care of by +-- 'Agda.Syntax.Translation.ConcreteToAbstract.checkCohesionAttributes', +-- which should not be called until after pragma options have been set. + +type CohesionAttributes = [(String, Range)] + -- | Modifiers for 'Quantity'. lockAttributeTable :: [(String, Lock)] 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 @@ -60,7 +60,6 @@ import Control.Monad.Trans ( lift ) import Data.Bifunctor -import Data.Data (Data) import Data.Either (isLeft, isRight) import Data.Function (on) import qualified Data.Map as Map @@ -150,27 +149,28 @@ deriving (Eq, Show) declKind :: NiceDeclaration -> DeclKind -declKind (FunSig r _ _ _ _ _ tc cc x _) = LoneSigDecl r (FunName tc cc) x -declKind (NiceRecSig r _ _ pc uc x pars _) = LoneSigDecl r (RecName pc uc) x -declKind (NiceDataSig r _ _ pc uc x pars _) = LoneSigDecl r (DataName pc uc) x -declKind (FunDef r _ abs ins tc cc x _) = LoneDefs (FunName tc cc) [x] -declKind (NiceDataDef _ _ _ pc uc x pars _) = LoneDefs (DataName pc uc) [x] +declKind (FunSig r _ _ _ _ _ tc cc x _) = LoneSigDecl r (FunName tc cc) x +declKind (NiceRecSig r _ _ pc uc x pars _) = LoneSigDecl r (RecName pc uc) x +declKind (NiceDataSig r _ _ pc uc x pars _) = LoneSigDecl r (DataName pc uc) x +declKind (FunDef r _ abs ins tc cc x _) = LoneDefs (FunName tc cc) [x] +declKind (NiceDataDef _ _ _ pc uc x pars _) = LoneDefs (DataName pc uc) [x] +declKind (NiceUnquoteData _ _ _ pc uc x _ _) = LoneDefs (DataName pc uc) [x] declKind (NiceRecDef _ _ _ pc uc x _ pars _) = LoneDefs (RecName pc uc) [x] -declKind (NiceUnquoteDef _ _ _ tc cc xs _) = LoneDefs (FunName tc cc) xs -declKind Axiom{} = OtherDecl -declKind NiceField{} = OtherDecl -declKind PrimitiveFunction{} = OtherDecl -declKind NiceMutual{} = OtherDecl -declKind NiceModule{} = OtherDecl -declKind NiceModuleMacro{} = OtherDecl -declKind NiceOpen{} = OtherDecl -declKind NiceImport{} = OtherDecl -declKind NicePragma{} = OtherDecl -declKind NiceFunClause{} = OtherDecl -declKind NicePatternSyn{} = OtherDecl -declKind NiceGeneralize{} = OtherDecl -declKind NiceUnquoteDecl{} = OtherDecl -declKind NiceLoneConstructor{} = OtherDecl +declKind (NiceUnquoteDef _ _ _ tc cc xs _) = LoneDefs (FunName tc cc) xs +declKind Axiom{} = OtherDecl +declKind NiceField{} = OtherDecl +declKind PrimitiveFunction{} = OtherDecl +declKind NiceMutual{} = OtherDecl +declKind NiceModule{} = OtherDecl +declKind NiceModuleMacro{} = OtherDecl +declKind NiceOpen{} = OtherDecl +declKind NiceImport{} = OtherDecl +declKind NicePragma{} = OtherDecl +declKind NiceFunClause{} = OtherDecl +declKind NicePatternSyn{} = OtherDecl +declKind NiceGeneralize{} = OtherDecl +declKind NiceUnquoteDecl{} = OtherDecl +declKind NiceLoneConstructor{} = OtherDecl -- | Replace (Data/Rec/Fun)Sigs with Axioms for postulated names -- The first argument is a list of axioms only. @@ -307,6 +307,10 @@ Generalize r sigs -> do gs <- forM sigs $ \case sig@(TypeSig info tac x t) -> do + -- Andreas, 2022-03-25, issue #5850: + -- Warn about @variable {x} : A@ which is equivalent to @variable x : A@. + when (getHiding info == Hidden) $ + declarationWarning $ HiddenGeneralize $ getRange x return $ NiceGeneralize (getRange sig) PublicAccess info tac x t _ -> __IMPOSSIBLE__ return (gs, ds) @@ -488,6 +492,11 @@ mapM_ removeLoneSig xs return ([NiceUnquoteDef r PublicAccess ConcreteDef TerminationCheck YesCoverageCheck xs e] , ds) + UnquoteData r xs cs e -> do + pc <- use positivityCheckPragma + uc <- use universeCheckPragma + return ([NiceUnquoteData r PublicAccess ConcreteDef pc uc xs cs e], ds) + Pragma p -> nicePragma p ds nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration]) @@ -1032,6 +1041,7 @@ NiceGeneralize{} -> top NiceUnquoteDecl{} -> top NiceUnquoteDef{} -> bottom + NiceUnquoteData{} -> top NicePragma r pragma -> case pragma of OptionsPragma{} -> top -- error thrown in the type checker @@ -1051,6 +1061,7 @@ StaticPragma{} -> bottom InlinePragma{} -> bottom + NotProjectionLikePragma{} -> bottom ImpossiblePragma{} -> top -- error thrown in scope checker EtaPragma{} -> bottom -- needs record definition @@ -1135,6 +1146,7 @@ termCheck NicePatternSyn{} = TerminationCheck termCheck NiceGeneralize{} = TerminationCheck termCheck NiceLoneConstructor{} = TerminationCheck + termCheck NiceUnquoteData{} = TerminationCheck covCheck :: NiceDeclaration -> CoverageCheck covCheck (FunSig _ _ _ _ _ _ _ cc _ _) = cc @@ -1159,6 +1171,7 @@ covCheck NicePatternSyn{} = YesCoverageCheck covCheck NiceGeneralize{} = YesCoverageCheck covCheck NiceLoneConstructor{} = YesCoverageCheck + covCheck NiceUnquoteData{} = YesCoverageCheck -- ASR (26 December 2015): Do not positivity check a mutual -- block if any of its inner declarations comes with a @@ -1227,6 +1240,7 @@ d@NiceRecDef{} -> return d d@NicePatternSyn{} -> return d d@NiceGeneralize{} -> return d + d@NiceUnquoteData{} -> return d setInstance :: Range -- Range of @instance@ keyword. @@ -1290,6 +1304,7 @@ -- Need to set updater state to dirty! NiceUnquoteDecl r p _ i tc cc x e -> tellDirty $> NiceUnquoteDecl r p AbstractDef i tc cc x e NiceUnquoteDef r p _ tc cc x e -> tellDirty $> NiceUnquoteDef r p AbstractDef tc cc x e + NiceUnquoteData r p _ tc cc x xs e -> tellDirty $> NiceUnquoteData r p AbstractDef tc cc x xs e d@NiceModule{} -> return d d@NiceModuleMacro{} -> return d d@NicePragma{} -> return d @@ -1363,6 +1378,7 @@ FunDef r ds a i tc cc x cls -> FunDef r ds a i tc cc x <$> mkPrivate 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 @@ -1408,6 +1424,7 @@ NiceGeneralize r _ i tac n e -> [Generalize r [TypeSig i tac n e]] NiceUnquoteDecl r _ _ i _ _ x e -> inst i [UnquoteDecl r x e] NiceUnquoteDef r _ _ _ _ x e -> [UnquoteDef r x e] + NiceUnquoteData r _ _ _ _ x xs e -> [UnquoteData r x xs e] where inst (InstanceDef r) ds = [InstanceB r ds] inst NotInstanceDef ds = ds @@ -1436,3 +1453,4 @@ NiceGeneralize{} -> Nothing NiceUnquoteDecl _ _ a _ _ _ _ _ -> Just a NiceUnquoteDef _ _ a _ _ _ _ -> Just a + NiceUnquoteData _ _ a _ _ _ _ _ -> Just a 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 @@ -2,8 +2,6 @@ import Control.DeepSeq -import Data.Data - import GHC.Generics (Generic) import Agda.Syntax.Position @@ -47,7 +45,7 @@ -- Range is of mutual block. | UnquoteDefRequiresSignature (List1 Name) | BadMacroDef NiceDeclaration - deriving (Data, Show) + deriving Show ------------------------------------------------------------------------ -- Warnings @@ -70,6 +68,10 @@ | EmptyPostulate Range -- ^ Empty @postulate@ block. | EmptyPrivate Range -- ^ Empty @private@ block. | EmptyPrimitive Range -- ^ Empty @primitive@ block. + | HiddenGeneralize Range + -- ^ A 'Hidden' identifier in a @variable@ declaration. + -- Hiding has no effect there as generalized variables are always hidden + -- (or instance variables). | InvalidCatchallPragma Range -- ^ A {-\# CATCHALL \#-} pragma -- that does not precede a function clause. @@ -115,7 +117,7 @@ -- ^ @instance@ block with nothing that can (newly) become an instance. | UselessPrivate Range -- ^ @private@ block with nothing that can (newly) be made private. - deriving (Data, Show, Generic) + deriving (Show, Generic) declarationWarningName :: DeclarationWarning -> WarningName declarationWarningName = declarationWarningName' . dwWarning @@ -133,6 +135,7 @@ EmptyPrivate{} -> EmptyPrivate_ EmptyPostulate{} -> EmptyPostulate_ EmptyPrimitive{} -> EmptyPrimitive_ + HiddenGeneralize{} -> HiddenGeneralize_ InvalidCatchallPragma{} -> InvalidCatchallPragma_ InvalidConstructor{} -> InvalidConstructor_ InvalidConstructorBlock{} -> InvalidConstructorBlock_ @@ -174,6 +177,7 @@ EmptyPrivate{} -> False EmptyPostulate{} -> False EmptyPrimitive{} -> False + HiddenGeneralize{} -> False InvalidCatchallPragma{} -> False InvalidConstructor{} -> False InvalidConstructorBlock{} -> False @@ -243,6 +247,7 @@ getRange (EmptyGeneralize r) = r getRange (EmptyPrimitive r) = r getRange (EmptyField r) = r + getRange (HiddenGeneralize r) = r getRange (InvalidTerminationCheckPragma r) = r getRange (InvalidCoverageCheckPragma r) = r getRange (InvalidNoPositivityCheckPragma r) = r @@ -340,6 +345,7 @@ pretty (EmptyGeneralize _) = fsep $ pwords "Empty variable block." pretty (EmptyPrimitive _) = fsep $ pwords "Empty primitive block." pretty (EmptyField _) = fsep $ pwords "Empty field block." + pretty (HiddenGeneralize _) = fsep $ pwords "Declaring a variable as hidden has no effect in a variable block. Generalization never introduces visible arguments." pretty InvalidRecordDirective{} = fsep $ pwords "Record directives can only be used inside record definitions and before field declarations." pretty (InvalidTerminationCheckPragma _) = fsep $ 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 @@ -113,9 +113,9 @@ addLoneSig :: Range -> Name -> DataRecOrFun -> Nice Name addLoneSig r x k = do -- Andreas, 2020-05-19, issue #4157, make '_' unique. - x' <- if not $ isNoName x then return x else do - i <- nextNameId - return x{ nameId = i } + x' <- case x of + Name{} -> pure x + NoName r _ -> NoName r <$> nextNameId loneSigs %== \ s -> do let (mr, s') = Map.insertLookupWithKey (\ _k new _old -> new) x (LoneSig r x' k) s case mr of 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 @@ -2,7 +2,6 @@ import Control.DeepSeq -import Data.Data import Data.Map (Map) import Data.Semigroup ( Semigroup(..) ) @@ -80,7 +79,8 @@ | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr - deriving (Data, Show, Generic) + | NiceUnquoteData Range Access IsAbstract PositivityCheck UniverseCheck Name [Name] Expr + deriving (Show, Generic) instance NFData NiceDeclaration @@ -100,7 +100,7 @@ -- | One clause in a function definition. There is no guarantee that the 'LHS' -- actually declares the 'Name'. We will have to check that later. data Clause = Clause Name Catchall LHS RHS WhereClause [Clause] - deriving (Data, Show, Generic) + deriving (Show, Generic) instance NFData Clause @@ -174,8 +174,10 @@ interleavedDecl :: Name -> InterleavedDecl -> [(DeclNum, NiceDeclaration)] interleavedDecl k = \case InterleavedData i d@(NiceDataSig _ acc abs pc uc _ pars _) ds -> - let fpars = concatMap dropTypeAndModality pars - ddef = NiceDataDef noRange UserWritten abs pc uc k fpars + let fpars = concatMap dropTypeAndModality pars + r = getRange (k, fpars) + ddef cs = NiceDataDef (getRange (r, cs)) UserWritten + abs pc uc k fpars cs in (i,d) : maybe [] (\ (j, dss) -> [(j, ddef (sconcat (List1.reverse dss)))]) ds InterleavedFun i d@(FunSig r acc abs inst mac info tc cc n e) dcs -> let fdef dcss = let (dss, css) = List1.unzip dcss in @@ -191,7 +193,7 @@ | FieldBlock -- ^ @field@. Ensured by parser. | DataBlock -- ^ @data ... where@. Here we got a bad error message for Agda-2.5 (Issue 1698). | ConstructorBlock -- ^ @constructor@, in @interleaved mutual@. - deriving (Data, Eq, Ord, Show) + deriving (Eq, Ord, Show) instance HasRange NiceDeclaration where @@ -215,7 +217,8 @@ getRange (NiceGeneralize r _ _ _ _ _) = r getRange (NiceFunClause r _ _ _ _ _ _) = r getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r - getRange (NiceUnquoteDef r _ _ _ _ _ _) = r + getRange (NiceUnquoteDef r _ _ _ _ _ _) = r + getRange (NiceUnquoteData r _ _ _ _ _ _ _) = r instance Pretty NiceDeclaration where pretty = \case @@ -240,6 +243,7 @@ NiceGeneralize _ _ _ _ x _ -> text "variable" <+> pretty x NiceUnquoteDecl _ _ _ _ _ _ xs _ -> text "" NiceUnquoteDef _ _ _ _ _ xs _ -> text "" + NiceUnquoteData _ _ _ _ _ x xs _ -> text "" declName :: NiceDeclaration -> String declName Axiom{} = "Postulates" @@ -255,6 +259,7 @@ declName NiceGeneralize{} = "Generalized variables" declName NiceUnquoteDecl{} = "Unquoted declarations" declName NiceUnquoteDef{} = "Unquoted definitions" +declName NiceUnquoteData{} = "Unquoted data types" declName NiceRecSig{} = "Records" declName NiceDataSig{} = "Data types" declName NiceFunClause{} = "Functions without a type signature" @@ -285,7 +290,7 @@ -- ^ Name of a record type | FunName TerminationCheck CoverageCheck -- ^ Name of a function. - deriving (Data, Show) + deriving Show -- Ignore pragmas when checking equality instance Eq DataRecOrFun where 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 @@ -91,10 +91,12 @@ return (f, p) where mergePolarities p1 p2 - | Set.null i = return (Map.union p1 p2) - | otherwise = throwMultiplePolarityPragmas (Set.toList i) + | Map.null i = return (Map.union p1 p2) + | otherwise = throwMultiplePolarityPragmas $ + map fst $ Map.toList i where - i = Set.intersection (Map.keysSet p1) (Map.keysSet p2) + -- Only the keys are used. + i = Map.intersection p1 p2 instance MonadFixityError m => Monoid (MonadicFixPol m) where mempty = MonadicFixPol $ return (Map.empty, Map.empty) @@ -180,6 +182,7 @@ Module {} -> mempty UnquoteDecl {} -> mempty UnquoteDef {} -> mempty + UnquoteData {} -> mempty Pragma {} -> mempty data DeclaredNames = DeclaredNames { _allNames, _postulates, _privateNames :: Set Name } @@ -208,39 +211,40 @@ -- i.e., do not go into modules. declaredNames :: Declaration -> DeclaredNames declaredNames = \case - TypeSig _ _ x _ -> declaresName x - FieldSig _ _ x _ -> declaresName x - Field _ fs -> foldMap declaredNames fs + TypeSig _ _ x _ -> declaresName x + FieldSig _ _ x _ -> declaresName x + Field _ fs -> foldMap declaredNames fs FunClause (LHS p [] []) _ _ _ | IdentP (QName x) <- removeParenP p - -> declaresName x - FunClause{} -> mempty - DataSig _ x _ _ -> declaresName x - DataDef _ _ _ cs -> foldMap declaredNames cs - Data _ x _ _ cs -> declaresName x <> foldMap declaredNames cs - RecordSig _ x _ _ -> declaresName x - RecordDef _ x d _ _ -> declaresNames $ foldMap (:[]) (fst <$> recConstructor d) - Record _ x d _ _ _ -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d) - RecordDirective _ -> mempty - Infix _ _ -> mempty - Syntax _ _ -> mempty - PatternSyn _ x _ _ -> declaresName x - Mutual _ ds -> foldMap declaredNames ds + -> declaresName x + FunClause{} -> mempty + DataSig _ x _ _ -> declaresName x + DataDef _ _ _ cs -> foldMap declaredNames cs + Data _ x _ _ cs -> declaresName x <> foldMap declaredNames cs + RecordSig _ x _ _ -> declaresName x + RecordDef _ x d _ _ -> declaresNames $ foldMap (:[]) (fst <$> recConstructor d) + Record _ x d _ _ _ -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d) + RecordDirective _ -> mempty + Infix _ _ -> mempty + Syntax _ _ -> mempty + PatternSyn _ x _ _ -> declaresName x + Mutual _ ds -> foldMap declaredNames ds InterleavedMutual _ ds -> foldMap declaredNames ds - LoneConstructor _ ds -> foldMap declaredNames ds - Abstract _ ds -> foldMap declaredNames ds - Private _ _ ds -> allPrivateNames $ foldMap declaredNames ds - InstanceB _ ds -> foldMap declaredNames ds - Macro _ ds -> foldMap declaredNames ds - Postulate _ ds -> allPostulates $ foldMap declaredNames ds - Primitive _ ds -> foldMap declaredNames ds - Generalize _ ds -> foldMap declaredNames ds - Open{} -> mempty - Import{} -> mempty - ModuleMacro{} -> mempty - Module{} -> mempty - UnquoteDecl _ xs _ -> declaresNames xs - UnquoteDef{} -> mempty + LoneConstructor _ ds -> foldMap declaredNames ds + Abstract _ ds -> foldMap declaredNames ds + Private _ _ ds -> allPrivateNames $ foldMap declaredNames ds + InstanceB _ ds -> foldMap declaredNames ds + Macro _ ds -> foldMap declaredNames ds + Postulate _ ds -> allPostulates $ foldMap declaredNames ds + Primitive _ ds -> foldMap declaredNames ds + Generalize _ ds -> foldMap declaredNames ds + Open{} -> mempty + Import{} -> mempty + ModuleMacro{} -> mempty + Module{} -> mempty + UnquoteDecl _ xs _ -> declaresNames xs + UnquoteDef{} -> mempty + UnquoteData _ x cs _ -> declaresNames (x:cs) -- BUILTIN pragmas which do not require an accompanying definition declare -- the (unqualified) name they mention. Pragma (BuiltinPragma _ b (QName x)) 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 @@ -131,7 +131,6 @@ As r x e -> f $ As r x $ mapE e Dot r e -> f $ Dot r $ mapE e DoubleDot r e -> f $ DoubleDot r $ mapE e - ETel tel -> f $ ETel $ mapE tel Tactic r e -> f $ Tactic r (mapE e) Quote{} -> f $ e0 QuoteTerm{} -> f $ e0 @@ -246,6 +245,7 @@ Module r n tel ds -> Module r n (mapE tel) $ mapE ds UnquoteDecl r x e -> UnquoteDecl r x (mapE e) UnquoteDef r x e -> UnquoteDef r x (mapE e) + UnquoteData r x xs e -> UnquoteData r x xs (mapE e) e@Pragma{} -> e where mapE :: ExprLike e => e -> e diff --git a/src/full/Agda/Syntax/Concrete/Name.hs b/src/full/Agda/Syntax/Concrete/Name.hs --- a/src/full/Agda/Syntax/Concrete/Name.hs +++ b/src/full/Agda/Syntax/Concrete/Name.hs @@ -3,30 +3,26 @@ -} module Agda.Syntax.Concrete.Name where +import Prelude hiding ((!!)) + import Control.DeepSeq import Data.ByteString.Char8 (ByteString) -import Data.Function +import Data.Function (on) import qualified Data.Foldable as Fold -import qualified Data.List as List -import Data.Data (Data) import GHC.Generics (Generic) -import System.FilePath - import Agda.Syntax.Common import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Position -import Agda.Utils.FileName import Agda.Utils.Lens -import Agda.Utils.List (last1) +import Agda.Utils.List ((!!), last1) import Agda.Utils.List1 (List1, pattern (:|), (<|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Pretty import Agda.Utils.Singleton -import Agda.Utils.Size import Agda.Utils.Suffix import Agda.Utils.Impossible @@ -49,7 +45,6 @@ { nameRange :: Range , nameId :: NameId } - deriving Data type NameParts = List1 NamePart @@ -72,7 +67,7 @@ data NamePart = Hole -- ^ @_@ part. | Id RawName -- ^ Identifier part. - deriving (Data, Generic) + deriving Generic -- | Define equality on @Name@ to ignore range so same names in different -- locations are equal. @@ -115,27 +110,13 @@ data QName = Qual Name QName -- ^ @A.rest@. | QName Name -- ^ @x@. - deriving (Data, Eq, Ord) + deriving (Eq, Ord) instance Underscore QName where underscore = QName underscore isUnderscore (QName x) = isUnderscore x isUnderscore Qual{} = False --- | Top-level module names. Used in connection with the file system. --- --- Invariant: The list must not be empty. - -data TopLevelModuleName = TopLevelModuleName - { moduleNameRange :: Range - , moduleNameParts :: List1 String - } - deriving (Show, Data, Generic) - -instance Eq TopLevelModuleName where (==) = (==) `on` moduleNameParts -instance Ord TopLevelModuleName where compare = compare `on` moduleNameParts -instance Sized TopLevelModuleName where size = size . moduleNameParts - ------------------------------------------------------------------------ -- * Constructing simple 'Name's. ------------------------------------------------------------------------ @@ -179,7 +160,7 @@ stringNameParts :: String -> NameParts stringNameParts "" = singleton $ Id "_" -- NoName stringNameParts "_" = singleton $ Id "_" -- NoName -stringNameParts s = List1.fromList $ loop s +stringNameParts s = List1.fromListSafe __IMPOSSIBLE__ $ loop s where loop "" = [] loop ('_':s) = Hole : loop s @@ -223,7 +204,7 @@ ------------------------------------------------------------------------ data NameInScope = InScope | NotInScope - deriving (Eq, Show, Data) + deriving (Eq, Show) class LensInScope a where lensInScope :: Lens' NameInScope a @@ -377,37 +358,6 @@ isUnqualified (QName n) = Just n ------------------------------------------------------------------------ --- * Operations on 'TopLevelModuleName' ------------------------------------------------------------------------- - --- | Turns a qualified name into a 'TopLevelModuleName'. The qualified --- name is assumed to represent a top-level module name. - -toTopLevelModuleName :: QName -> TopLevelModuleName -toTopLevelModuleName q = TopLevelModuleName (getRange q) $ - fmap nameToRawName $ qnameParts q - --- | Turns a top-level module name into a file name with the given --- suffix. - -moduleNameToFileName :: TopLevelModuleName -> String -> FilePath -moduleNameToFileName (TopLevelModuleName _ ms) ext = - joinPath (List1.init ms) List1.last ms <.> ext - --- | Finds the current project's \"root\" directory, given a project --- file and the corresponding top-level module name. --- --- Example: If the module \"A.B.C\" is located in the file --- \"/foo/A/B/C.agda\", then the root is \"/foo/\". --- --- Precondition: The module name must be well-formed. - -projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath -projectRoot file (TopLevelModuleName _ m) = - mkAbsolute $ - iterate takeDirectory (filePath file) !! length m - ------------------------------------------------------------------------- -- * No name stuff ------------------------------------------------------------------------ @@ -445,8 +395,6 @@ instance IsNoName a => IsNoName (Ranged a) where instance IsNoName a => IsNoName (WithOrigin a) where --- no instance for TopLevelModuleName - ------------------------------------------------------------------------ -- * Showing names ------------------------------------------------------------------------ @@ -473,9 +421,6 @@ | otherwise = pretty m <> "." <> pretty x pretty (QName x) = pretty x -instance Pretty TopLevelModuleName where - pretty (TopLevelModuleName _ ms) = text $ List.intercalate "." $ List1.toList ms - ------------------------------------------------------------------------ -- * Range instances ------------------------------------------------------------------------ @@ -488,9 +433,6 @@ getRange (QName x) = getRange x getRange (Qual n x) = fuseRange n x -instance HasRange TopLevelModuleName where - getRange = moduleNameRange - instance SetRange Name where setRange r (Name _ nis ps) = Name r nis ps setRange r (NoName _ i) = NoName r i @@ -499,9 +441,6 @@ setRange r (QName x) = QName (setRange r x) setRange r (Qual n x) = Qual (setRange r n) (setRange r x) -instance SetRange TopLevelModuleName where - setRange r (TopLevelModuleName _ x) = TopLevelModuleName r x - instance KillRange QName where killRange (QName x) = QName $ killRange x killRange (Qual n x) = killRange n `Qual` killRange x @@ -510,9 +449,6 @@ killRange (Name r nis ps) = Name (killRange r) nis ps killRange (NoName r i) = NoName (killRange r) i -instance KillRange TopLevelModuleName where - killRange (TopLevelModuleName _ x) = TopLevelModuleName noRange x - ------------------------------------------------------------------------ -- * NFData instances ------------------------------------------------------------------------ @@ -534,5 +470,3 @@ instance NFData QName where rnf (Qual a b) = rnf a `seq` rnf b rnf (QName a) = rnf a - -instance NFData TopLevelModuleName 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 @@ -19,12 +19,12 @@ ) where import Control.Applicative ( Alternative((<|>))) -import Control.Arrow (second) import Control.Monad.Except (throwError) import Data.Either (partitionEithers) import qualified Data.Foldable as Fold -import Data.Function +import Data.Function (on) +import qualified Data.Function import qualified Data.List as List import Data.Maybe import Data.Map (Map) @@ -42,6 +42,7 @@ import Agda.Syntax.Position import Agda.Syntax.Notation import Agda.Syntax.Scope.Base +import Agda.Syntax.Scope.Flat import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad.Base (typeError, TypeError(..), LHSOrPatSyn(..)) @@ -81,45 +82,6 @@ -- * Building the parser --------------------------------------------------------------------------- -type FlatScope = Map QName [AbstractName] - --- | Compute all defined names in scope and their fixities/notations. --- Note that overloaded names (constructors) can have several --- fixities/notations. Then we 'mergeNotations'. (See issue 1194.) -getDefinedNames :: KindsOfNames -> FlatScope -> [[NewNotation]] -getDefinedNames kinds names = - [ mergeNotations $ map (namesToNotation x . A.qnameName . anameName) ds - | (x, ds) <- Map.toList names - , any ((`elemKindsOfNames` kinds) . anameKind) ds - , not (null ds) - ] - -- Andreas, 2013-03-21 see Issue 822 - -- Names can have different kinds, i.e., 'defined' and 'constructor'. - -- We need to consider all names that have *any* matching kind, - -- not only those whose first appearing kind is matching. - --- | Compute all names (first component) and operators/notations --- (second component) in scope. -localNames :: FlatScope -> ScopeM ([QName], [NewNotation]) -localNames flat = do - let defs = getDefinedNames allKindsOfNames flat - locals <- nubOn fst . notShadowedLocals <$> getLocalVars - -- Note: Debug printout aligned with the one in buildParsers. - reportS "scope.operators" 50 - [ "flat = " ++ prettyShow flat - , "defs = " ++ prettyShow defs - , "locals= " ++ prettyShow locals - ] - let localNots = map localOp locals - notLocal = not . hasElem (map notaName localNots) . notaName - otherNots = concatMap (filter notLocal) defs - return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots - where - localOp (x, y) = namesToNotation (QName x) y - split = partitionEithers . concatMap opOrNot - opOrNot n = Left (notaName n) : - [Right n | not (null (notation n))] - -- | A data structure used internally by 'buildParsers'. data InternalParsers e = InternalParsers { pTop :: Parser e e @@ -181,7 +143,9 @@ buildParsers kind exprNames = do flat <- flattenScope (qualifierModules exprNames) <$> getScope - (names, ops) <- localNames flat + (names, ops0) <- localNames flat + let ops | kind == IsPattern = filter (not . isLambdaNotation) ops0 + | otherwise = ops0 let -- All names. namesInExpr :: Set QName @@ -224,9 +188,9 @@ Trie.member (addHole withHole p) partListsInExpr where p = case n of - NormalHole{} : IdPart p : _ -> rangedThing p - IdPart p : _ -> rangedThing p - _ -> __IMPOSSIBLE__ + HolePart{} : IdPart p : _ -> rangedThing p + IdPart p : _ -> rangedThing p + _ -> __IMPOSSIBLE__ -- Is the last identifier part present in n present in the -- expression, without any succeeding name parts, except for a @@ -235,9 +199,9 @@ Trie.member (addHole withHole p) reversedPartListsInExpr where p = case reverse n of - NormalHole{} : IdPart p : _ -> rangedThing p - IdPart p : _ -> rangedThing p - _ -> __IMPOSSIBLE__ + HolePart{} : IdPart p : _ -> rangedThing p + IdPart p : _ -> rangedThing p + _ -> __IMPOSSIBLE__ -- Are the initial and final identifier parts present with -- the right mix of leading and trailing underscores? 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 @@ -7,7 +7,9 @@ import Control.Monad ((<=<)) import Data.Either +import Data.Function (on) import Data.Kind ( Type ) +import qualified Data.List as List import Data.Maybe import qualified Data.Strict.Maybe as Strict import Data.Set (Set) @@ -277,39 +279,39 @@ where - (leadingHoles, syn1) = span isNormalHole syn - (withoutExternalHoles, trailingHoles) = spanEnd isNormalHole syn1 + (leadingHoles, syn1) = span isAHole syn + (withoutExternalHoles, trailingHoles) = spanEnd isAHole syn1 leadingHole = case leadingHoles of - [NormalHole _ h] -> h - _ -> __IMPOSSIBLE__ + [HolePart _ h] -> h + _ -> __IMPOSSIBLE__ trailingHole = case trailingHoles of - [NormalHole _ h] -> h - _ -> __IMPOSSIBLE__ + [HolePart _ h] -> h + _ -> __IMPOSSIBLE__ worker :: [Name] -> Notation -> Parser e (Range, [Either (MaybePlaceholder e, NamedArg (Ranged Int)) - (LamBinding, Ranged Int)]) + (LamBinding, Ranged BoundVariablePosition)]) worker ms [] = pure (noRange, []) worker ms (IdPart x : xs) = (\r1 (r2, es) -> (fuseRanges r1 r2, es)) <$> partP ms (rangedThing x) <*> worker [] xs -- Only the first part is qualified. - worker ms (NormalHole _ h : xs) = + worker ms (HolePart _ h : xs) = (\e (r, es) -> (r, Left (e, h) : es)) <$> maybePlaceholder (if isOp && parseSections == ParseSections then Just Middle else Nothing) p <*> worker ms xs - worker ms (WildHole h : xs) = + worker ms (WildPart h : xs) = (\(r, es) -> let anon = mkBinder_ simpleHole in (r, Right (mkBinding h anon) : es)) <$> worker ms xs - worker ms (BindHole _ h : xs) = do + worker ms (VarPart _ h : xs) = do (\ b (r, es) -> (r, Right (mkBinding h b) : es)) -- Andreas, 2011-04-07 put just 'Relevant' here, is this -- correct? @@ -322,13 +324,19 @@ findExprFor :: [(MaybePlaceholder e, NamedArg (Ranged Int))] -> - [(LamBinding, Ranged Int)] -> Int -> + [(LamBinding, Ranged BoundVariablePosition)] -> Int -> NamedArg (MaybePlaceholder (OpApp e)) findExprFor normalHoles binders n = case [ h | h@(_, m) <- normalHoles, rangedThing (namedArg m) == n ] of [(Placeholder p, arg)] -> set (Placeholder p) arg [(NoPlaceholder _ e, arg)] -> - List1.ifNull [ b | (b, m) <- binders, rangedThing m == n ] + List1.ifNull + (map snd $ + List.sortBy (compare `on` fst) + [ (varNumber (rangedThing m), b) + | (b, m) <- binders + , holeNumber (rangedThing m) == n + ]) {-then-} (set (noPlaceholder (Ordinary e)) arg) -- no variable to bind {-else-} $ \ bs -> set (noPlaceholder (SyntaxBindingLambda (fuseRange bs e) bs e)) arg _ -> __IMPOSSIBLE__ diff --git a/src/full/Agda/Syntax/Concrete/Pattern.hs b/src/full/Agda/Syntax/Concrete/Pattern.hs --- a/src/full/Agda/Syntax/Concrete/Pattern.hs +++ b/src/full/Agda/Syntax/Concrete/Pattern.hs @@ -101,6 +101,7 @@ -- | Add applicative patterns (non-projection / non-with patterns) to the right. lhsCoreApp :: LHSCore -> [NamedArg Pattern] -> LHSCore +lhsCoreApp (LHSEllipsis r core) ps = LHSEllipsis r $ lhsCoreApp core ps lhsCoreApp core ps = core { lhsPats = lhsPats core ++ ps } -- | Add with-patterns to the right. 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 @@ -80,23 +80,25 @@ NotHidden -> parens prettyRelevance :: LensRelevance a => a -> Doc -> Doc -prettyRelevance a d = - if render d == "_" then d else pretty (getRelevance a) <> d +prettyRelevance a = (pretty (getRelevance a) <>) prettyQuantity :: LensQuantity a => a -> Doc -> Doc -prettyQuantity a d = - if render d == "_" then d else pretty (getQuantity a) <+> d +prettyQuantity a = (pretty (getQuantity a) <+>) prettyErased :: Erased -> Doc -> Doc prettyErased = prettyQuantity . asQuantity prettyCohesion :: LensCohesion a => a -> Doc -> Doc -prettyCohesion a d = - if render d == "_" then d else pretty (getCohesion a) <+> d +prettyCohesion a = (pretty (getCohesion a) <+>) prettyTactic :: BoundName -> Doc -> Doc prettyTactic = prettyTactic' . bnameTactic +prettyFiniteness :: BoundName -> Doc -> Doc +prettyFiniteness name + | bnameIsFinite name = ("@finite" <+>) + | otherwise = id + prettyTactic' :: TacticAttribute -> Doc -> Doc prettyTactic' Nothing d = d prettyTactic' (Just t) d = "@" <> (parens ("tactic" <+> pretty t) <+> d) @@ -151,6 +153,28 @@ , pretty (getCohesion mod) ] +-- | Show the attributes necessary to recover a modality, in long-form +-- (e.g. using at-syntax rather than dots). For the default modality, +-- the result is at-ω (rather than the empty document). Suitable for +-- showing modalities outside of binders. +attributesForModality :: Modality -> Doc +attributesForModality mod + | mod == defaultModality = text "@ω" + | otherwise = fsep $ catMaybes [relevance, quantity, cohesion] + where + relevance = case getRelevance mod of + Relevant -> Nothing + Irrelevant -> Just "@irrelevant" + NonStrict -> Just "@shape-irrelevant" + quantity = case getQuantity mod of + Quantity0{} -> Just "@0" + Quantity1{} -> Just "@1" + Quantityω{} -> Nothing + cohesion = case getCohesion mod of + Flat{} -> Just "@♭" + Continuous{} -> Nothing + Squash{} -> Just "@⊤" + instance Pretty (OpApp Expr) where pretty (Ordinary e) = pretty e pretty (SyntaxBindingLambda r bs e) = pretty (Lam r bs e) @@ -216,8 +240,6 @@ Rec _ xs -> sep ["record", bracesAndSemicolons (map pretty xs)] RecUpdate _ e xs -> sep ["record" <+> pretty e, bracesAndSemicolons (map pretty xs)] - ETel [] -> "()" - ETel tel -> fsep $ map pretty tel Quote _ -> "quote" QuoteTerm _ -> "quoteTerm" Unquote _ -> "unquote" @@ -300,6 +322,7 @@ pretty (TBind _ xs e) = fsep [ prettyRelevance y $ prettyHiding y parens + $ prettyFiniteness (binderName $ namedArg y) $ prettyCohesion y $ prettyQuantity y $ prettyTactic (binderName $ namedArg y) $ @@ -386,128 +409,125 @@ pretty (DoLet _ ds) = "let" <+> vcat (fmap pretty ds) instance Pretty Declaration where - prettyList = vcat . map pretty - pretty d = - case d of - TypeSig i tac x e -> - sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ pretty x <+> ":" - , nest 2 $ pretty e - ] - - FieldSig inst tac x (Arg i e) -> - mkInst inst $ mkOverlap i $ - prettyRelevance i $ prettyHiding i id $ prettyCohesion i $ prettyQuantity i $ - pretty $ TypeSig (setRelevance Relevant i) tac x e - - where - - mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ] - mkInst NotInstanceDef d = d - - mkOverlap i d | isOverlappable i = "overlap" <+> d - | otherwise = d + prettyList = vcat . map pretty + pretty = \case + TypeSig i tac x e -> + sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ pretty x <+> ":" + , nest 2 $ pretty e + ] + FieldSig inst tac x (Arg i e) -> + mkInst inst $ mkOverlap i $ + prettyRelevance i $ prettyHiding i id $ prettyCohesion i $ prettyQuantity i $ + pretty $ TypeSig (setRelevance Relevant i) tac x e + where + mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ] + mkInst NotInstanceDef d = d - Field _ fs -> - sep [ "field" - , nest 2 $ vcat (map pretty fs) + mkOverlap i d | isOverlappable i = "overlap" <+> d + | otherwise = d + Field _ fs -> + sep [ "field" + , nest 2 $ vcat (map pretty fs) + ] + FunClause lhs rhs wh _ -> + sep [ pretty lhs + , nest 2 $ pretty rhs + ] $$ nest 2 (pretty wh) + DataSig _ x tel e -> + sep [ hsep [ "data" + , pretty x + , fcat (map pretty tel) ] - FunClause lhs rhs wh _ -> - sep [ pretty lhs - , nest 2 $ pretty rhs - ] $$ nest 2 (pretty wh) - DataSig _ x tel e -> - sep [ hsep [ "data" - , pretty x - , fcat (map pretty tel) - ] - , nest 2 $ hsep - [ ":" - , pretty e - ] - ] - Data _ x tel e cs -> - sep [ hsep [ "data" - , pretty x - , fcat (map pretty tel) - ] - , nest 2 $ hsep - [ ":" - , pretty e - , "where" - ] - ] $$ nest 2 (vcat $ map pretty cs) - DataDef _ x tel cs -> - sep [ hsep [ "data" - , pretty x - , fcat (map pretty tel) - ] - , nest 2 $ "where" - ] $$ nest 2 (vcat $ map pretty cs) - RecordSig _ x tel e -> - sep [ hsep [ "record" - , pretty x - , fcat (map pretty tel) - ] - , nest 2 $ hsep - [ ":" - , pretty e - ] - ] - Record _ x dir tel e cs -> - pRecord x dir tel (Just e) cs - RecordDef _ x dir tel cs -> - pRecord x dir tel Nothing cs - RecordDirective r -> pRecordDirective r - Infix f xs -> - pretty f <+> fsep (punctuate comma $ fmap pretty xs) - Syntax n xs -> "syntax" <+> pretty n <+> "..." - PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as) - <+> "=" <+> pretty p - Mutual _ ds -> namedBlock "mutual" ds - InterleavedMutual _ ds -> namedBlock "interleaved mutual" ds - LoneConstructor _ ds -> namedBlock "constructor" ds - Abstract _ ds -> namedBlock "abstract" ds - Private _ _ ds -> namedBlock "private" ds - InstanceB _ ds -> namedBlock "instance" ds - Macro _ ds -> namedBlock "macro" ds - Postulate _ ds -> namedBlock "postulate" ds - Primitive _ ds -> namedBlock "primitive" ds - Generalize _ ds -> namedBlock "variable" ds - Module _ x tel ds -> - hsep [ "module" - , pretty x - , fcat (map pretty tel) - , "where" - ] $$ nest 2 (vcat $ map pretty ds) - ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x -> - sep [ pretty DoOpen - , nest 2 $ pretty e - , nest 4 $ pretty i - ] - ModuleMacro _ x (SectionApp _ tel e) open i -> - sep [ pretty open <+> "module" <+> pretty x <+> fcat (map pretty tel) - , nest 2 $ "=" <+> pretty e <+> pretty i - ] - ModuleMacro _ x (RecordModuleInstance _ rec) open i -> - sep [ pretty open <+> "module" <+> pretty x - , nest 2 $ "=" <+> pretty rec <+> "{{...}}" - ] - Open _ x i -> hsep [ "open", pretty x, pretty i ] - Import _ x rn open i -> - hsep [ pretty open, "import", pretty x, as rn, pretty i ] - where - as Nothing = empty - as (Just x) = "as" <+> pretty (asName x) - UnquoteDecl _ xs t -> - sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ] - UnquoteDef _ xs t -> - sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ] - Pragma pr -> sep [ "{-#" <+> pretty pr, "#-}" ] - where - namedBlock s ds = - sep [ text s - , nest 2 $ vcat $ map pretty ds - ] + , nest 2 $ hsep + [ ":" + , pretty e + ] + ] + Data _ x tel e cs -> + sep [ hsep [ "data" + , pretty x + , fcat (map pretty tel) + ] + , nest 2 $ hsep + [ ":" + , pretty e + , "where" + ] + ] $$ nest 2 (vcat $ map pretty cs) + DataDef _ x tel cs -> + sep [ hsep [ "data" + , pretty x + , fcat (map pretty tel) + ] + , nest 2 $ "where" + ] $$ nest 2 (vcat $ map pretty cs) + RecordSig _ x tel e -> + sep [ hsep [ "record" + , pretty x + , fcat (map pretty tel) + ] + , nest 2 $ hsep + [ ":" + , pretty e + ] + ] + Record _ x dir tel e cs -> + pRecord x dir tel (Just e) cs + RecordDef _ x dir tel cs -> + pRecord x dir tel Nothing cs + RecordDirective r -> pRecordDirective r + Infix f xs -> + pretty f <+> fsep (punctuate comma $ fmap pretty xs) + Syntax n xs -> "syntax" <+> pretty n <+> "..." + PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as) + <+> "=" <+> pretty p + Mutual _ ds -> namedBlock "mutual" ds + InterleavedMutual _ ds -> namedBlock "interleaved mutual" ds + LoneConstructor _ ds -> namedBlock "constructor" ds + Abstract _ ds -> namedBlock "abstract" ds + Private _ _ ds -> namedBlock "private" ds + InstanceB _ ds -> namedBlock "instance" ds + Macro _ ds -> namedBlock "macro" ds + Postulate _ ds -> namedBlock "postulate" ds + Primitive _ ds -> namedBlock "primitive" ds + Generalize _ ds -> namedBlock "variable" ds + Module _ x tel ds -> + hsep [ "module" + , pretty x + , fcat (map pretty tel) + , "where" + ] $$ nest 2 (vcat $ map pretty ds) + ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x -> + sep [ pretty DoOpen + , nest 2 $ pretty e + , nest 4 $ pretty i + ] + ModuleMacro _ x (SectionApp _ tel e) open i -> + sep [ pretty open <+> "module" <+> pretty x <+> fcat (map pretty tel) + , nest 2 $ "=" <+> pretty e <+> pretty i + ] + ModuleMacro _ x (RecordModuleInstance _ rec) open i -> + sep [ pretty open <+> "module" <+> pretty x + , nest 2 $ "=" <+> pretty rec <+> "{{...}}" + ] + Open _ x i -> hsep [ "open", pretty x, pretty i ] + Import _ x rn open i -> + hsep [ pretty open, "import", pretty x, as rn, pretty i ] + where + as Nothing = empty + as (Just x) = "as" <+> pretty (asName x) + UnquoteDecl _ xs t -> + sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ] + UnquoteDef _ xs t -> + sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ] + UnquoteData _ x xs t -> + sep [ "unquoteData" <+> pretty x <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ] + Pragma pr -> sep [ "{-#" <+> pretty pr, "#-}" ] + where + namedBlock s ds = + sep [ text s + , nest 2 $ vcat $ map pretty ds + ] pHasEta0 :: HasEta0 -> Doc pHasEta0 = \case @@ -584,6 +604,8 @@ hsep $ ["INJECTIVE", pretty i] pretty (InlinePragma _ True i) = hsep $ ["INLINE", pretty i] + pretty (NotProjectionLikePragma _ i) = + hsep $ ["NOT_PROJECTION_LIKE", pretty i] pretty (InlinePragma _ False i) = hsep $ ["NOINLINE", pretty i] pretty (ImpossiblePragma _ strs) = @@ -623,11 +645,11 @@ Unrelated -> empty Related{} -> pretty ass <+> pretty level -instance Pretty GenPart where - pretty (IdPart x) = text $ rangedThing x - pretty BindHole{} = underscore - pretty NormalHole{} = underscore - pretty WildHole{} = underscore +instance Pretty NotationPart where + pretty (IdPart x) = text $ rangedThing x + pretty HolePart{} = underscore + pretty VarPart{} = underscore + pretty WildPart{} = underscore prettyList = hcat . map pretty diff --git a/src/full/Agda/Syntax/Fixity.hs b/src/full/Agda/Syntax/Fixity.hs --- a/src/full/Agda/Syntax/Fixity.hs +++ b/src/full/Agda/Syntax/Fixity.hs @@ -5,8 +5,6 @@ import Control.DeepSeq -import Data.Data (Data) - import GHC.Generics (Generic) import Agda.Syntax.Position @@ -21,7 +19,7 @@ -- | Decorating something with @Fixity'@. data ThingWithFixity x = ThingWithFixity x Fixity' - deriving (Functor, Foldable, Traversable, Data, Show) + deriving (Functor, Foldable, Traversable, Show) instance LensFixity' (ThingWithFixity a) where lensFixity' f (ThingWithFixity a fix') = ThingWithFixity a <$> f fix' @@ -32,7 +30,7 @@ -- | Do we prefer parens around arguments like @λ x → x@ or not? -- See 'lamBrackets'. data ParenPreference = PreferParen | PreferParenless - deriving (Eq, Ord, Show, Data, Generic) + deriving (Eq, Ord, Show, Generic) instance NFData ParenPreference @@ -49,7 +47,7 @@ | LeftOperandCtx Fixity | RightOperandCtx Fixity ParenPreference | FunctionCtx | ArgumentCtx ParenPreference | InsideOperandCtx | WithFunCtx | WithArgCtx | DotPatternCtx - deriving (Show, Data, Eq, Generic) + deriving (Show, Eq, Generic) instance NFData Precedence 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 @@ -11,7 +11,6 @@ import Control.DeepSeq -import Data.Data (Data) import Data.Semigroup (Semigroup) import GHC.Generics (Generic) @@ -36,7 +35,7 @@ , metaNumber :: Maybe MetaId , metaNameSuggestion :: String } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) emptyMetaInfo :: MetaInfo emptyMetaInfo = MetaInfo @@ -59,7 +58,7 @@ --------------------------------------------------------------------------} newtype ExprInfo = ExprRange Range - deriving (Data, Show, Eq, Null, NFData) + deriving (Show, Eq, Null, NFData) exprNoRange :: ExprInfo exprNoRange = ExprRange noRange @@ -80,7 +79,7 @@ , appOrigin :: Origin , appParens :: ParenPreference -- ^ Do we prefer a lambda argument with or without parens? } - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | Default is system inserted and prefer parens. defaultAppInfo :: Range -> AppInfo @@ -117,7 +116,7 @@ , minfoDirective :: Maybe ImportDirective -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'. } - deriving (Data, Eq, Show, Generic) + deriving (Eq, Show, Generic) instance HasRange ModuleInfo where getRange = minfoRange @@ -135,7 +134,7 @@ --------------------------------------------------------------------------- newtype LetInfo = LetRange Range - deriving (Data, Show, Eq, Null, NFData) + deriving (Show, Eq, Null, NFData) instance HasRange LetInfo where getRange (LetRange r) = r @@ -156,7 +155,7 @@ , defInfo :: DeclInfo , defTactic :: Maybe t } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) mkDefInfo :: Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t mkDefInfo x f a ab r = mkDefInfoInstance x f a ab NotInstanceDef NotMacroDef r @@ -191,7 +190,7 @@ { declName :: Name , declRange :: Range } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) instance HasRange DeclInfo where getRange = declRange @@ -214,7 +213,7 @@ , mutualPositivityCheck :: PositivityCheck , mutualRange :: Range } - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | Default value for 'MutualInfo'. instance Null MutualInfo where @@ -235,7 +234,7 @@ data LHSInfo = LHSInfo { lhsRange :: Range , lhsEllipsis :: ExpandedEllipsis - } deriving (Data, Show, Eq, Generic) + } deriving (Show, Eq, Generic) instance HasRange LHSInfo where getRange (LHSInfo r _) = r @@ -256,7 +255,7 @@ -- | For a general pattern we remember the source code position. newtype PatInfo = PatRange Range - deriving (Data, Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange, + deriving (Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange, KillRange, NFData) -- | Empty range for patterns. @@ -271,7 +270,7 @@ , conPatInfo :: PatInfo , conPatLazy :: ConPatLazy } - deriving (Data, Eq, Show, Generic) + deriving (Eq, Show, Generic) instance HasRange ConPatInfo where getRange = getRange . conPatInfo @@ -288,6 +287,6 @@ data ConPatLazy = ConPatLazy -- ^ Dotted constructor. | ConPatEager -- ^ Ordinary constructor. - deriving (Data, Eq, Ord, Show, Bounded, Enum, Generic) + deriving (Eq, Ord, Show, Bounded, Enum, Generic) instance NFData ConPatLazy 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} module Agda.Syntax.Internal @@ -13,7 +14,7 @@ import Control.Monad.Identity import Control.DeepSeq -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Semigroup ( Semigroup, (<>), Sum(..) ) @@ -21,7 +22,6 @@ import Data.Set (Set) import Data.Traversable -import Data.Data (Data) import GHC.Generics (Generic) @@ -65,34 +65,35 @@ -- 'Arg' is used for actual arguments ('Var', 'Con', 'Def' etc.) -- and in 'Abstract' syntax and other situations. -- --- [ cubical ] When @domFinite = True@ for the domain of a 'Pi' --- type, the elements should be compared by tabulating the domain type. --- Only supported in case the domain type is primIsOne, to obtain --- the correct equality for partial elements. +-- [ cubical ] When @annFinite (argInfoAnnotation domInfo) = True@ for +-- the domain of a 'Pi' type, the elements should be compared by +-- tabulating the domain type. Only supported in case the domain type +-- is primIsOne, to obtain the correct equality for partial elements. -- data Dom' t e = Dom { domInfo :: ArgInfo - , domFinite :: !Bool , domName :: Maybe NamedName -- ^ e.g. @x@ in @{x = y : A} -> B@. + , domIsFinite :: Bool + -- ^ Is this a Π-type (False), or a partial type (True)? , domTactic :: Maybe t -- ^ "@tactic e". , unDom :: e - } deriving (Data, Show, Functor, Foldable, Traversable) + } deriving (Show, Functor, Foldable, Traversable) type Dom = Dom' Term instance Decoration (Dom' t) where - traverseF f (Dom ai b x t a) = Dom ai b x t <$> f a + traverseF f (Dom ai x t b a) = Dom ai x t b <$> f a instance HasRange a => HasRange (Dom' t a) where getRange = getRange . unDom instance (KillRange t, KillRange a) => KillRange (Dom' t a) where - killRange (Dom info b x t a) = killRange5 Dom info b x t a + killRange (Dom info x t b a) = killRange4 Dom info x t b a -- | Ignores 'Origin' and 'FreeVariables' and tactic. instance Eq a => Eq (Dom' t a) where - Dom (ArgInfo h1 m1 _ _ a1) b1 s1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) b2 s2 _ x2 = - (h1, m1, a1, b1, s1, x1) == (h2, m2, a2, b2, s2, x2) + Dom (ArgInfo h1 m1 _ _ a1) s1 f1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) s2 f2 _ x2 = + (h1, m1, a1, s1, f1, x1) == (h2, m2, a2, s2, f2, x2) instance LensNamed (Dom' t e) where type NameOf (Dom' t e) = NamedName @@ -129,10 +130,10 @@ -- often for class AddContext. domFromArg :: Arg a -> Dom a -domFromArg (Arg i a) = Dom i False Nothing Nothing a +domFromArg (Arg i a) = Dom i Nothing False Nothing a domFromNamedArg :: NamedArg a -> Dom a -domFromNamedArg (Arg i a) = Dom i False (nameOf a) Nothing (namedThing a) +domFromNamedArg (Arg i a) = Dom i (nameOf a) False Nothing (namedThing a) defaultDom :: a -> Dom a defaultDom = defaultArgDom defaultArgInfo @@ -151,7 +152,7 @@ data DataOrRecord = IsData | IsRecord PatternOrCopattern - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | Store the names of the record fields in the constructor. -- This allows reduction of projection redexes outside of TCM. @@ -163,7 +164,7 @@ , conFields :: [Arg QName] -- ^ The name of the record fields. -- 'Arg' is stored since the info in the constructor args -- might not be accurate because of subtyping (issue #2170). - } deriving (Data, Show, Generic) + } deriving (Show, Generic) instance Eq ConHead where (==) = (==) `on` conName @@ -225,7 +226,7 @@ -- where they can affect type checking, so syntactic checks are free to ignore the -- eliminators, which are only there to ease debugging when a dummy term incorrectly -- leaks into a relevant position. - deriving (Data, Show) + deriving Show type ConInfo = ConOrigin @@ -242,7 +243,7 @@ -- ^ The body has (at least) one free variable. -- Danger: 'unAbs' doesn't shift variables properly | NoAbs { absName :: ArgName, unAbs :: a } - deriving (Data, Functor, Foldable, Traversable, Generic) + deriving (Functor, Foldable, Traversable, Generic) instance Decoration Abs where traverseF f (Abs x a) = Abs x <$> f a @@ -251,7 +252,7 @@ -- | Types are terms with a sort annotation. -- data Type'' t a = El { _getSort :: Sort' t, unEl :: a } - deriving (Data, Show, Functor, Foldable, Traversable) + deriving (Show, Functor, Foldable, Traversable) type Type' a = Type'' Term a @@ -284,22 +285,23 @@ -- and so on. data Tele a = EmptyTel | ExtendTel a (Abs (Tele a)) -- ^ 'Abs' is never 'NoAbs'. - deriving (Data, Show, Functor, Foldable, Traversable, Generic) + deriving (Show, Functor, Foldable, Traversable, Generic) type Telescope = Tele (Dom Type) data IsFibrant = IsFibrant | IsStrict - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | Sorts. -- data Sort' t = Type (Level' t) -- ^ @Set ℓ@. | Prop (Level' t) -- ^ @Prop ℓ@. - | Inf IsFibrant Integer -- ^ @Setωᵢ@. + | Inf IsFibrant !Integer -- ^ @Setωᵢ@. | SSet (Level' t) -- ^ @SSet ℓ@. | SizeUniv -- ^ @SizeUniv@, a sort inhabited by type @Size@. | LockUniv -- ^ @LockUniv@, a sort for locks. + | IntervalUniv -- ^ @IntervalUniv@, a sort inhabited by the cubical interval. | PiSort (Dom' t t) (Sort' t) (Abs (Sort' t)) -- ^ Sort of the pi type. | FunSort (Sort' t) (Sort' t) -- ^ Sort of a (non-dependent) function type. | UnivSort (Sort' t) -- ^ Sort of another sort. @@ -310,19 +312,19 @@ -- Replaces the abuse of @Prop@ for a dummy sort. -- The @String@ typically describes the location where we create this dummy, -- but can contain other information as well. - deriving (Data, Show) + deriving Show type Sort = Sort' Term -- | A level is a maximum expression of a closed level and 0..n -- 'PlusLevel' expressions each of which is an atom plus a number. -data Level' t = Max Integer [PlusLevel' t] - deriving (Show, Data, Functor, Foldable, Traversable) +data Level' t = Max !Integer [PlusLevel' t] + deriving (Show, Functor, Foldable, Traversable) type Level = Level' Term -data PlusLevel' t = Plus Integer t - deriving (Show, Data, Functor, Foldable, Traversable) +data PlusLevel' t = Plus !Integer t + deriving (Show, Functor, Foldable, Traversable) type PlusLevel = PlusLevel' Term type LevelAtom = Term @@ -333,7 +335,7 @@ -- | Newtypes for terms that produce a dummy, rather than crash, when -- applied to incompatible eliminations. -newtype BraveTerm = BraveTerm { unBrave :: Term } deriving (Data, Show) +newtype BraveTerm = BraveTerm { unBrave :: Term } deriving Show --------------------------------------------------------------------------- -- * Blocked Terms @@ -366,21 +368,21 @@ -- For the purpose of the permutation and the body dot patterns count -- as variables. TODO: Change this! data Clause = Clause - { clauseLHSRange :: Range - , clauseFullRange :: Range - , clauseTel :: Telescope + { clauseLHSRange :: Range + , clauseFullRange :: Range + , clauseTel :: Telescope -- ^ @Δ@: The types of the pattern variables in dependency order. - , namedClausePats :: NAPs + , namedClausePats :: NAPs -- ^ @Δ ⊢ ps@. The de Bruijn indices refer to @Δ@. - , clauseBody :: Maybe Term + , clauseBody :: Maybe Term -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an -- absurd one. - , clauseType :: Maybe (Arg Type) + , clauseType :: Maybe (Arg Type) -- ^ @Δ ⊢ t@. The type of the rhs under @clauseTel@. -- Used, e.g., by @TermCheck@. -- Can be 'Irrelevant' if we encountered an irrelevant projection -- pattern on the lhs. - , clauseCatchall :: Bool + , clauseCatchall :: Bool -- ^ Clause has been labelled as CATCHALL. , clauseExact :: Maybe Bool -- ^ Pattern matching of this clause is exact, no catch-all case. @@ -400,10 +402,12 @@ -- @Nothing@ means coverage checker has not run yet (clause may be unreachable). -- @Just False@ means clause is not unreachable. -- @Just True@ means clause is unreachable. - , clauseEllipsis :: ExpandedEllipsis + , clauseEllipsis :: ExpandedEllipsis -- ^ Was this clause created by expansion of an ellipsis? + , clauseWhereModule :: Maybe ModuleName + -- ^ Keeps track of the module name associate with the clause's where clause. } - deriving (Data, Show, Generic) + deriving (Show, Generic) clausePats :: Clause -> [Arg DeBruijnPattern] clausePats = map (fmap namedThing) . namedClausePats @@ -423,7 +427,7 @@ data PatternInfo = PatternInfo { patOrigin :: PatOrigin , patAsNames :: [Name] - } deriving (Data, Show, Eq, Generic) + } deriving (Show, Eq, Generic) defaultPatternInfo :: PatternInfo defaultPatternInfo = PatternInfo PatOSystem [] @@ -439,7 +443,7 @@ | PatORec -- ^ User wrote a record pattern | PatOLit -- ^ User wrote a literal pattern | PatOAbsurd -- ^ User wrote an absurd pattern - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) -- | Patterns are variables, constructors, or wildcards. -- @QName@ is used in @ConP@ rather than @Name@ since @@ -463,7 +467,7 @@ -- ^ Path elimination pattern, like @VarP@ but keeps track of endpoints. | DefP PatternInfo QName [NamedArg (Pattern' x)] -- ^ Used for HITs, the QName should be the one from primHComp. - deriving (Data, Show, Functor, Foldable, Traversable, Generic) + deriving (Show, Functor, Foldable, Traversable, Generic) type Pattern = Pattern' PatVarName -- ^ The @PatVarName@ is a name suggestion. @@ -480,8 +484,8 @@ -- | Type used when numbering pattern variables. data DBPatVar = DBPatVar { dbPatVarName :: PatVarName - , dbPatVarIndex :: Int - } deriving (Data, Show, Eq, Generic) + , dbPatVarIndex :: !Int + } deriving (Show, Eq, Generic) type DeBruijnPattern = Pattern' DBPatVar @@ -528,7 +532,7 @@ -- variables they bind are unused. The GHC backend compiles lazy matches -- to lazy patterns in Haskell (TODO: not yet). } - deriving (Data, Show, Generic) + deriving (Show, Generic) noConPatternInfo :: ConPatternInfo noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False @@ -648,14 +652,16 @@ -- Γ ⊢ u :# ρ : Δ, A -- @ - | Strengthen Impossible (Substitution' a) + | Strengthen Impossible !Int (Substitution' a) -- ^ Strengthening substitution. First argument is @__IMPOSSIBLE__@. - -- Apply this to a term which does not contain variable 0 - -- to lower all de Bruijn indices by one. - -- @ - -- Γ ⊢ ρ : Δ + -- In @'Strengthen err n ρ@ the number @n@ must be non-negative. + -- This substitution should only be applied to values @t@ for + -- which none of the variables @0@ up to @n - 1@ are free in + -- @t[ρ]@, and in that case @n@ is subtracted from all free de + -- Bruijn indices in @t[ρ]@. + -- Γ ⊢ ρ : Δ |Θ| = n -- --------------------------- - -- Γ ⊢ Strengthen ρ : Δ, A + -- Γ ⊢ Strengthen n ρ : Δ, Θ -- @ | Wk !Int (Substitution' a) @@ -701,17 +707,35 @@ -- | View type as equality type. data EqualityView - = EqualityType - { eqtSort :: Sort -- ^ Sort of this type. - , eqtName :: QName -- ^ Builtin EQUALITY. - , eqtParams :: [Arg Term] -- ^ Hidden. Empty or @Level@. - , eqtType :: Arg Term -- ^ Hidden - , eqtLhs :: Arg Term -- ^ NotHidden - , eqtRhs :: Arg Term -- ^ NotHidden - } + = EqualityViewType EqualityTypeData | OtherType Type -- ^ reduced | IdiomType Type -- ^ reduced +data EqualityTypeData = EqualityTypeData + { _eqtSort :: Sort -- ^ Sort of this type. + , _eqtName :: QName -- ^ Builtin EQUALITY. + , _eqtParams :: Args -- ^ Hidden. Empty or @Level@. + , _eqtType :: Arg Term -- ^ Hidden. + , _eqtLhs :: Arg Term -- ^ NotHidden. + , _eqtRhs :: Arg Term -- ^ NotHidden. + } + +pattern EqualityType + :: Sort + -> QName + -> Args + -> Arg Term + -> Arg Term + -> Arg Term + -> EqualityView +pattern EqualityType{ eqtSort, eqtName, eqtParams, eqtType, eqtLhs, eqtRhs } = + EqualityViewType (EqualityTypeData eqtSort eqtName eqtParams eqtType eqtLhs eqtRhs) + +-- The COMPLETE pragma is new in GHC 8.2 +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE EqualityType, OtherType, IdiomType #-} +#endif + isEqualityType :: EqualityView -> Bool isEqualityType EqualityType{} = True isEqualityType OtherType{} = False @@ -1022,10 +1046,6 @@ MetaV x es -> Just (MetaV x, es) Con{} -> Nothing Lit{} -> Nothing - -- Andreas, 2016-04-13, Issue 1932: We convert λ x → x .f into f - Lam h (Abs _ v) | visible h -> case v of - Var 0 [Proj _o f] -> Just (Def f, []) - _ -> Nothing Lam{} -> Nothing Pi{} -> Nothing Sort{} -> Nothing @@ -1045,11 +1065,12 @@ -- | A 'null' clause is one with no patterns and no rhs. -- Should not exist in practice. instance Null Clause where - empty = Clause empty empty empty empty empty empty False Nothing Nothing Nothing empty - null (Clause _ _ tel pats body _ _ _ _ _ _) + empty = Clause empty empty empty empty empty empty False Nothing Nothing Nothing empty empty + null (Clause _ _ tel pats body _ _ _ _ _ _ wm) = null tel && null pats && null body + && null wm --------------------------------------------------------------------------- @@ -1120,6 +1141,7 @@ SSet l -> 1 + tsize l SizeUniv -> 1 LockUniv -> 1 + IntervalUniv -> 1 PiSort a s1 s2 -> 1 + tsize a + tsize s1 + tsize s2 FunSort s1 s2 -> 1 + tsize s1 + tsize s2 UnivSort s -> 1 + tsize s @@ -1134,12 +1156,12 @@ tsize (Plus _ a) = tsize a instance TermSize a => TermSize (Substitution' a) where - tsize IdS = 1 - tsize (EmptyS _) = 1 - tsize (Wk _ rho) = 1 + tsize rho - tsize (t :# rho) = 1 + tsize t + tsize rho - tsize (Strengthen _ rho) = 1 + tsize rho - tsize (Lift _ rho) = 1 + tsize rho + tsize IdS = 1 + tsize (EmptyS _) = 1 + tsize (Wk _ rho) = 1 + tsize rho + tsize (t :# rho) = 1 + tsize t + tsize rho + tsize (Strengthen _ _ rho) = 1 + tsize rho + tsize (Lift _ rho) = 1 + tsize rho --------------------------------------------------------------------------- -- * KillRange instances. @@ -1179,6 +1201,7 @@ Inf f n -> Inf f n SizeUniv -> SizeUniv LockUniv -> LockUniv + IntervalUniv -> IntervalUniv Type a -> killRange1 Type a Prop a -> killRange1 Prop a SSet a -> killRange1 SSet a @@ -1190,12 +1213,12 @@ s@DummyS{} -> s instance KillRange Substitution where - killRange IdS = IdS - killRange (EmptyS err) = EmptyS err - killRange (Wk n rho) = killRange1 (Wk n) rho - killRange (t :# rho) = killRange2 (:#) t rho - killRange (Strengthen err rho) = killRange1 (Strengthen err) rho - killRange (Lift n rho) = killRange1 (Lift n) rho + killRange IdS = IdS + killRange (EmptyS err) = EmptyS err + killRange (Wk n rho) = killRange1 (Wk n) rho + killRange (t :# rho) = killRange2 (:#) t rho + killRange (Strengthen err n rho) = killRange1 (Strengthen err n) rho + killRange (Lift n rho) = killRange1 (Lift n) rho instance KillRange PatOrigin where killRange = id @@ -1221,8 +1244,8 @@ DefP o q ps -> killRange2 (DefP o) q ps instance KillRange Clause where - killRange (Clause rl rf tel ps body t catchall exact recursive unreachable ell) = - killRange10 Clause rl rf tel ps body t catchall exact recursive unreachable ell + killRange (Clause rl rf tel ps body t catchall exact recursive unreachable ell wm) = + killRange11 Clause rl rf tel ps body t catchall exact recursive unreachable ell wm instance KillRange a => KillRange (Tele a) where killRange = fmap killRange @@ -1241,12 +1264,16 @@ prettyPrec = pr where pr p rho = case rho of - IdS -> "idS" - EmptyS err -> "emptyS" - t :# rho -> mparens (p > 2) $ sep [ pr 2 rho <> ",", prettyPrec 3 t ] - Strengthen _ rho -> mparens (p > 9) $ "strS" <+> pr 10 rho - Wk n rho -> mparens (p > 9) $ text ("wkS " ++ show n) <+> pr 10 rho - Lift n rho -> mparens (p > 9) $ text ("liftS " ++ show n) <+> pr 10 rho + IdS -> "idS" + EmptyS err -> "emptyS" + t :# rho -> mparens (p > 2) $ + sep [ pr 2 rho <> ",", prettyPrec 3 t ] + Strengthen _ n rho -> mparens (p > 9) $ + text ("strS " ++ show n) <+> pr 10 rho + Wk n rho -> mparens (p > 9) $ + text ("wkS " ++ show n) <+> pr 10 rho + Lift n rho -> mparens (p > 9) $ + text ("liftS " ++ show n) <+> pr 10 rho instance Pretty Term where prettyPrec p v = @@ -1338,10 +1365,10 @@ SSet l -> mparens (p > 9) $ "SSet" <+> prettyPrec 10 l SizeUniv -> "SizeUniv" LockUniv -> "LockUniv" + IntervalUniv -> "IntervalUniv" PiSort a s1 s2 -> mparens (p > 9) $ - "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a)) - <+> parens (sep [ text ("λ " ++ absName s2 ++ " ->") - , nest 2 $ pretty (unAbs s2) ]) + "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a) <+> ":" <+> pretty s1) + <+> parens (pretty (unAbs s2)) FunSort a b -> mparens (p > 9) $ "funSort" <+> prettyPrec 10 a <+> prettyPrec 10 b UnivSort s -> mparens (p > 9) $ "univSort" <+> prettyPrec 10 s @@ -1380,6 +1407,10 @@ prettyPrec n (IApplyP _o _ _ x) = prettyPrec n x -- prettyPrec n (IApplyP _o u0 u1 x) = text "@[" <> prettyPrec 0 u0 <> text ", " <> prettyPrec 0 u1 <> text "]" <> prettyPrec n x +instance Pretty a => Pretty (Blocked a) where + pretty (Blocked x a) = ("[" <+> pretty a <+> "]") <> pretty x + pretty (NotBlocked _ x) = pretty x + ----------------------------------------------------------------------------- -- * NFData instances ----------------------------------------------------------------------------- @@ -1411,6 +1442,7 @@ SSet l -> rnf l SizeUniv -> () LockUniv -> () + IntervalUniv -> () PiSort a b c -> rnf (a, b, unAbs c) FunSort a b -> rnf (a, b) UnivSort a -> rnf a @@ -1425,7 +1457,7 @@ rnf (Plus n l) = rnf (n, l) instance NFData e => NFData (Dom e) where - rnf (Dom a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e + rnf (Dom a c d e f) = rnf a `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f instance NFData DataOrRecord instance NFData ConHead diff --git a/src/full/Agda/Syntax/Internal/Blockers.hs b/src/full/Agda/Syntax/Internal/Blockers.hs --- a/src/full/Agda/Syntax/Internal/Blockers.hs +++ b/src/full/Agda/Syntax/Internal/Blockers.hs @@ -3,7 +3,6 @@ import Control.DeepSeq -import Data.Data (Data) import Data.Set (Set) import qualified Data.Set as Set import Data.Semigroup @@ -11,6 +10,7 @@ import GHC.Generics (Generic) import Agda.Syntax.Common +import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Internal.Elim import Agda.Utils.Pretty hiding ((<>)) @@ -30,8 +30,8 @@ -- ^ Not enough arguments were supplied to complete the matching. | AbsurdMatch -- ^ We matched an absurd clause, results in a neutral 'Def'. - | MissingClauses - -- ^ We ran out of clauses, all considered clauses + | MissingClauses QName + -- ^ We ran out of clauses for 'QName', all considered clauses -- produced an actual mismatch. -- This can happen when try to reduce a function application -- but we are still missing some function clauses. @@ -39,7 +39,7 @@ | ReallyNotBlocked -- ^ Reduction was not blocked, we reached a whnf -- which can be anything but a stuck @'Def'@. - deriving (Show, Data, Generic) + deriving (Show, Generic) -- | 'ReallyNotBlocked' is the unit. -- 'MissingClauses' is dominant. @@ -47,8 +47,8 @@ instance Semigroup (NotBlocked' t) where ReallyNotBlocked <> b = b -- MissingClauses is dominant (absorptive) - b@MissingClauses <> _ = b - _ <> b@MissingClauses = b + b@MissingClauses{} <> _ = b + _ <> b@MissingClauses{} = b -- StuckOn is second strongest b@StuckOn{} <> _ = b _ <> b@StuckOn{} = b @@ -67,7 +67,8 @@ | UnblockOnAny (Set Blocker) | UnblockOnMeta MetaId -- ^ Unblock if meta is instantiated | UnblockOnProblem ProblemId - deriving (Data, Show, Eq, Ord, Generic) + | UnblockOnDef QName -- ^ Unblock when function is defined + deriving (Show, Eq, Ord, Generic) instance NFData Blocker @@ -101,12 +102,18 @@ unblockOnEither :: Blocker -> Blocker -> Blocker unblockOnEither a b = unblockOnAny $ Set.fromList [a, b] +unblockOnBoth :: Blocker -> Blocker -> Blocker +unblockOnBoth a b = unblockOnAll $ Set.fromList [a, b] + unblockOnMeta :: MetaId -> Blocker unblockOnMeta = UnblockOnMeta unblockOnProblem :: ProblemId -> Blocker unblockOnProblem = UnblockOnProblem +unblockOnDef :: QName -> Blocker +unblockOnDef = UnblockOnDef + unblockOnAllMetas :: Set MetaId -> Blocker unblockOnAllMetas = unblockOnAll . Set.mapMonotonic unblockOnMeta @@ -118,39 +125,52 @@ onBlockingMetasM f (UnblockOnAny bs) = unblockOnAny . Set.fromList <$> mapM (onBlockingMetasM f) (Set.toList bs) onBlockingMetasM f (UnblockOnMeta x) = f x onBlockingMetasM f b@UnblockOnProblem{} = pure b +onBlockingMetasM f b@UnblockOnDef{} = pure b allBlockingMetas :: Blocker -> Set MetaId allBlockingMetas (UnblockOnAll us) = Set.unions $ map allBlockingMetas $ Set.toList us allBlockingMetas (UnblockOnAny us) = Set.unions $ map allBlockingMetas $ Set.toList us allBlockingMetas (UnblockOnMeta x) = Set.singleton x allBlockingMetas UnblockOnProblem{} = Set.empty +allBlockingMetas UnblockOnDef{} = Set.empty allBlockingProblems :: Blocker -> Set ProblemId allBlockingProblems (UnblockOnAll us) = Set.unions $ map allBlockingProblems $ Set.toList us allBlockingProblems (UnblockOnAny us) = Set.unions $ map allBlockingProblems $ Set.toList us allBlockingProblems UnblockOnMeta{} = Set.empty allBlockingProblems (UnblockOnProblem p) = Set.singleton p +allBlockingProblems UnblockOnDef{} = Set.empty --- Note: We pick the All rather than the Any as the semigroup instance. +allBlockingDefs :: Blocker -> Set QName +allBlockingDefs (UnblockOnAll us) = Set.unions $ map allBlockingDefs $ Set.toList us +allBlockingDefs (UnblockOnAny us) = Set.unions $ map allBlockingDefs $ Set.toList us +allBlockingDefs UnblockOnMeta{} = Set.empty +allBlockingDefs UnblockOnProblem{} = Set.empty +allBlockingDefs (UnblockOnDef q) = Set.singleton q + +{- There are two possible instances of Semigroup, so we don't commit + to either one. instance Semigroup Blocker where x <> y = unblockOnAll $ Set.fromList [x, y] instance Monoid Blocker where mempty = alwaysUnblock mappend = (<>) +-} instance Pretty Blocker where pretty (UnblockOnAll us) = "all" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us) pretty (UnblockOnAny us) = "any" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us) pretty (UnblockOnMeta m) = pretty m pretty (UnblockOnProblem pid) = "problem" <+> pretty pid + pretty (UnblockOnDef q) = "definition" <+> pretty q -- | Something where a meta variable may block reduction. Notably a top-level meta is considered -- blocking. This did not use to be the case (pre Aug 2020). data Blocked' t a = Blocked { theBlocker :: Blocker, ignoreBlocking :: a } | NotBlocked { blockingStatus :: NotBlocked' t, ignoreBlocking :: a } - deriving (Data, Show, Functor, Foldable, Traversable, Generic) + deriving (Show, Functor, Foldable, Traversable, Generic) instance Decoration (Blocked' t) where traverseF f (Blocked b x) = Blocked b <$> f x @@ -162,7 +182,7 @@ f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e) instance Semigroup a => Semigroup (Blocked' t a) where - Blocked x a <> Blocked y b = Blocked (x <> y) (a <> b) + Blocked x a <> Blocked y b = Blocked (unblockOnBoth x y) (a <> b) b@Blocked{} <> NotBlocked{} = b NotBlocked{} <> b@Blocked{} = b NotBlocked x a <> NotBlocked y b = NotBlocked (x <> y) (a <> b) @@ -198,10 +218,9 @@ -- (Missing ordinary pattern would mean the @e@ is of function type, -- but we cannot match against something of function type.) stuckOn :: Elim' t -> NotBlocked' t -> NotBlocked' t -stuckOn e r = - case r of - MissingClauses -> r - StuckOn{} -> r +stuckOn e = \case + r@MissingClauses{} -> r + r@StuckOn{} -> r Underapplied -> r' AbsurdMatch -> r' ReallyNotBlocked -> r' @@ -227,6 +246,10 @@ notBlocked_ :: Blocked' t () notBlocked_ = notBlocked () +getBlocker :: Blocked' t a -> Blocker +getBlocker (Blocked b _) = b +getBlocker NotBlocked{} = neverUnblock + ----------------------------------------------------------------------------- -- * Waking up logic ----------------------------------------------------------------------------- @@ -256,10 +279,18 @@ where u' = unblockMeta x u +wakeIfBlockedOnDef :: QName -> Blocker -> WakeUp +wakeIfBlockedOnDef q u + | u' == alwaysUnblock = WakeUp + | otherwise = DontWakeUp (Just u') + where + u' = unblockDef q u + unblockMeta :: MetaId -> Blocker -> Blocker unblockMeta x u@(UnblockOnMeta y) | x == y = alwaysUnblock | otherwise = u unblockMeta _ u@UnblockOnProblem{} = u +unblockMeta _ u@UnblockOnDef{} = u unblockMeta x (UnblockOnAll us) = unblockOnAll $ Set.map (unblockMeta x) us unblockMeta x (UnblockOnAny us) = unblockOnAny $ Set.map (unblockMeta x) us @@ -267,5 +298,14 @@ unblockProblem p u@(UnblockOnProblem q) | p == q = alwaysUnblock | otherwise = u unblockProblem _ u@UnblockOnMeta{} = u +unblockProblem _ u@UnblockOnDef{} = u unblockProblem p (UnblockOnAll us) = unblockOnAll $ Set.map (unblockProblem p) us unblockProblem p (UnblockOnAny us) = unblockOnAny $ Set.map (unblockProblem p) us + +unblockDef :: QName -> Blocker -> Blocker +unblockDef q u@(UnblockOnDef q') | q == q' = alwaysUnblock + | otherwise = u +unblockDef q u@UnblockOnMeta{} = u +unblockDef q u@UnblockOnProblem{} = u +unblockDef q (UnblockOnAll us) = unblockOnAll $ Set.map (unblockDef q) us +unblockDef q (UnblockOnAny us) = unblockOnAny $ Set.map (unblockDef q) us diff --git a/src/full/Agda/Syntax/Internal/Defs.hs b/src/full/Agda/Syntax/Internal/Defs.hs --- a/src/full/Agda/Syntax/Internal/Defs.hs +++ b/src/full/Agda/Syntax/Internal/Defs.hs @@ -81,6 +81,7 @@ SSet l -> getDefs l SizeUniv -> return () LockUniv -> return () + IntervalUniv -> return () PiSort a s1 s2 -> getDefs a >> getDefs s1 >> getDefs s2 FunSort s1 s2 -> getDefs s1 >> getDefs s2 UnivSort s -> getDefs s @@ -105,3 +106,11 @@ instance (GetDefs a, GetDefs b) => GetDefs (a,b) where getDefs (a,b) = getDefs a >> getDefs b + +instance GetDefs Telescope where + getDefs = getDefs . telToList + +-- no defs here + +instance {-# OVERLAPPING #-} GetDefs String where + getDefs _ = return () diff --git a/src/full/Agda/Syntax/Internal/Elim.hs b/src/full/Agda/Syntax/Internal/Elim.hs --- a/src/full/Agda/Syntax/Internal/Elim.hs +++ b/src/full/Agda/Syntax/Internal/Elim.hs @@ -2,7 +2,6 @@ module Agda.Syntax.Internal.Elim where import Control.DeepSeq -import Data.Data (Data) import Agda.Syntax.Common import Agda.Syntax.Concrete.Pretty () -- Pretty Arg instance @@ -20,7 +19,7 @@ = Apply (Arg a) -- ^ Application. | Proj ProjOrigin QName -- ^ Projection. 'QName' is name of a record projection. | IApply a a a -- ^ IApply x y r, x and y are the endpoints - deriving (Data, Show, Functor, Foldable, Traversable) + deriving (Show, Functor, Foldable, Traversable) -- | This instance cheats on 'Proj', use with care. -- 'Proj's are always assumed to be 'UserWritten', since they have no 'ArgInfo'. @@ -42,6 +41,13 @@ isApplyElim' :: Empty -> Elim' a -> Arg a isApplyElim' e = fromMaybe (absurd e) . isApplyElim +-- | Only 'Apply' variant. +isProperApplyElim :: Elim' a -> Bool +isProperApplyElim = \case + Apply _ -> True + IApply{} -> False + Proj{} -> False + -- | Drop 'Apply' constructors. (Safe) allApplyElims :: [Elim' a] -> Maybe [Arg a] allApplyElims = mapM isApplyElim @@ -80,4 +86,3 @@ rnf (Apply x) = rnf x rnf Proj{} = () rnf (IApply x y r) = rnf x `seq` rnf y `seq` rnf r - diff --git a/src/full/Agda/Syntax/Internal/Generic.hs b/src/full/Agda/Syntax/Internal/Generic.hs --- a/src/full/Agda/Syntax/Internal/Generic.hs +++ b/src/full/Agda/Syntax/Internal/Generic.hs @@ -96,7 +96,7 @@ t@Lit{} -> f t Sort s -> f =<< Sort <$> traverseTermM f s DontCare mv -> f =<< DontCare <$> traverseTermM f mv - t@Dummy{} -> f t + Dummy s xs -> f =<< Dummy s <$> traverseTermM f xs foldTerm f t = f t `mappend` case t of Var i xs -> foldTerm f xs @@ -109,7 +109,7 @@ Lit _ -> mempty Sort s -> foldTerm f s DontCare mv -> foldTerm f mv - Dummy{} -> mempty + Dummy _ xs -> foldTerm f xs instance TermLike Level where traverseTermM f (Max n as) = Max n <$> traverseTermM f as @@ -131,12 +131,13 @@ SSet l -> SSet <$> traverseTermM f l s@SizeUniv -> pure s s@LockUniv -> pure s + s@IntervalUniv -> pure s PiSort a b c -> PiSort <$> traverseTermM f a <*> traverseTermM f b <*> traverseTermM f c FunSort a b -> FunSort <$> traverseTermM f a <*> traverseTermM f b UnivSort a -> UnivSort <$> traverseTermM f a MetaS x es -> MetaS x <$> traverseTermM f es DefS q es -> DefS q <$> traverseTermM f es - s@DummyS{} -> pure s + s@(DummyS _) -> pure s foldTerm f = \case Type l -> foldTerm f l @@ -145,12 +146,13 @@ SSet l -> foldTerm f l SizeUniv -> mempty LockUniv -> mempty + IntervalUniv -> mempty PiSort a b c -> foldTerm f a <> foldTerm f b <> foldTerm f c FunSort a b -> foldTerm f a <> foldTerm f b UnivSort a -> foldTerm f a MetaS _ es -> foldTerm f es DefS _ es -> foldTerm f es - DummyS{} -> mempty + DummyS _ -> mempty instance TermLike EqualityView where diff --git a/src/full/Agda/Syntax/Internal/MetaVars.hs b/src/full/Agda/Syntax/Internal/MetaVars.hs --- a/src/full/Agda/Syntax/Internal/MetaVars.hs +++ b/src/full/Agda/Syntax/Internal/MetaVars.hs @@ -23,13 +23,18 @@ instance AllMetas Type instance TermLike a => AllMetas (Elim' a) instance TermLike a => AllMetas (Tele a) -instance TermLike a => AllMetas (Dom a) +instance (AllMetas a, AllMetas b) => AllMetas (Dom' a b) where + allMetas f (Dom _ _ _ t e) = allMetas f t <> allMetas f e + -- These types need to be packed up as a Term to get the metas. instance AllMetas Sort where allMetas f = allMetas f . Sort instance AllMetas Level where allMetas f = allMetas f . Level instance AllMetas PlusLevel where allMetas f l = allMetas f (Max 0 [l]) +instance {-# OVERLAPPING #-} AllMetas String where + allMetas f _ = mempty + -- Generic instances instance (AllMetas a, AllMetas b) => AllMetas (a, b) where allMetas f (x, y) = allMetas f x <> allMetas f y @@ -57,6 +62,7 @@ sortMetas Inf{} = mempty sortMetas SizeUniv{} = mempty sortMetas LockUniv{} = mempty + sortMetas IntervalUniv{} = mempty sortMetas (PiSort _ s1 s2) = sortMetas s1 <> sortMetas (unAbs s2) -- the domain is a term so is covered by the fold sortMetas (FunSort a b) = sortMetas a <> sortMetas b sortMetas (UnivSort s) = sortMetas s 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 @@ -1,9 +1,9 @@ - --- | Extract all names from things. +-- | Extract all names and meta-variables from things. module Agda.Syntax.Internal.Names where -import Data.List.NonEmpty (NonEmpty(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMap import Data.Map (Map) import Data.Set (Set) @@ -12,206 +12,376 @@ import Agda.Syntax.Internal import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Treeless import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.CompiledClause +import Agda.Utils.List1 (List1) +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Singleton import Agda.Utils.Impossible +-- | Some or all of the 'QName's that can be found in the given thing. + namesIn :: (NamesIn a, Collection QName m) => a -> m namesIn = namesIn' singleton +-- | Some or all of the 'QName's that can be found in the given thing. + +namesIn' :: (NamesIn a, Monoid m) => (QName -> m) -> a -> m +namesIn' f = namesAndMetasIn' (either f mempty) + +-- | Some or all of the meta-variables that can be found in the given +-- thing. + +metasIn :: (NamesIn a, Collection MetaId m) => a -> m +metasIn = metasIn' singleton + +-- | Some or all of the meta-variables that can be found in the given +-- thing. + +-- TODO: Does this function make +-- Agda.Syntax.Internal.MetaVars.allMetas superfluous? Maybe not, +-- allMetas ignores the first argument of PiSort. + +metasIn' :: (NamesIn a, Monoid m) => (MetaId -> m) -> a -> m +metasIn' f = namesAndMetasIn' (either mempty f) + +-- | Some or all of the names and meta-variables that can be found in +-- the given thing. + +namesAndMetasIn :: + (NamesIn a, Collection QName m1, Collection MetaId m2) => + a -> (m1, m2) +namesAndMetasIn = + namesAndMetasIn' + (either (\x -> (singleton x, mempty)) + (\m -> (mempty, singleton m))) + class NamesIn a where - namesIn' :: Monoid m => (QName -> m) -> a -> m + -- | Some or all of the names and meta-variables that can be found + -- in the given thing. + namesAndMetasIn' :: Monoid m => (Either QName MetaId -> m) -> a -> m - default namesIn' :: (Monoid m, Foldable f, NamesIn b, f b ~ a) => (QName -> m) -> a -> m - namesIn' = foldMap . namesIn' + default namesAndMetasIn' :: + (Monoid m, Foldable f, NamesIn b, f b ~ a) => + (Either QName MetaId -> m) -> a -> m + namesAndMetasIn' = foldMap . namesAndMetasIn' -- Generic collections instance NamesIn a => NamesIn (Maybe a) +instance NamesIn a => NamesIn (Strict.Maybe a) instance NamesIn a => NamesIn [a] -instance NamesIn a => NamesIn (NonEmpty a) +instance NamesIn a => NamesIn (List1 a) instance NamesIn a => NamesIn (Set a) instance NamesIn a => NamesIn (Map k a) -- Decorations instance NamesIn a => NamesIn (Arg a) -instance NamesIn a => NamesIn (Dom a) instance NamesIn a => NamesIn (Named n a) instance NamesIn a => NamesIn (Abs a) instance NamesIn a => NamesIn (WithArity a) instance NamesIn a => NamesIn (Open a) instance NamesIn a => NamesIn (C.FieldAssignment' a) +instance (NamesIn a, NamesIn b) => NamesIn (Dom' a b) where + namesAndMetasIn' sg (Dom _ _ _ t e) = + mappend (namesAndMetasIn' sg t) (namesAndMetasIn' sg e) + + -- Specific collections instance NamesIn a => NamesIn (Tele a) -- Tuples instance (NamesIn a, NamesIn b) => NamesIn (a, b) where - namesIn' sg (x, y) = mappend (namesIn' sg x) (namesIn' sg y) + namesAndMetasIn' sg (x, y) = + mappend (namesAndMetasIn' sg x) (namesAndMetasIn' sg y) instance (NamesIn a, NamesIn b, NamesIn c) => NamesIn (a, b, c) where - namesIn' sg (x, y, z) = namesIn' sg (x, (y, z)) + namesAndMetasIn' sg (x, y, z) = namesAndMetasIn' sg (x, (y, z)) instance (NamesIn a, NamesIn b, NamesIn c, NamesIn d) => NamesIn (a, b, c, d) where - namesIn' sg (x, y, z, u) = namesIn' sg ((x, y), (z, u)) + namesAndMetasIn' sg (x, y, z, u) = + namesAndMetasIn' sg ((x, y), (z, u)) +instance + (NamesIn a, NamesIn b, NamesIn c, NamesIn d, NamesIn e) => + NamesIn (a, b, c, d, e) where + namesAndMetasIn' sg (x, y, z, u, v) = + namesAndMetasIn' sg ((x, y), (z, (u, v))) + +instance + (NamesIn a, NamesIn b, NamesIn c, NamesIn d, NamesIn e, NamesIn f) => + NamesIn (a, b, c, d, e, f) where + namesAndMetasIn' sg (x, y, z, u, v, w) = + namesAndMetasIn' sg ((x, (y, z)), (u, (v, w))) + instance NamesIn CompKit where - namesIn' sg (CompKit a b) = namesIn' sg (a,b) + namesAndMetasIn' sg (CompKit a b) = namesAndMetasIn' sg (a,b) --- Base case +-- Base cases instance NamesIn QName where - namesIn' sg x = sg x -- interesting case! + namesAndMetasIn' sg x = sg (Left x) -- interesting case! +instance NamesIn MetaId where + namesAndMetasIn' sg x = sg (Right x) + instance NamesIn ConHead where - namesIn' sg h = namesIn' sg (conName h) + namesAndMetasIn' sg h = namesAndMetasIn' sg (conName h) +instance NamesIn Bool where + namesAndMetasIn' _ _ = mempty + -- Andreas, 2017-07-27 -- In the following clauses, the choice of fields is not obvious -- to the reader. Please comment on the choices. --- --- Also, this would be more robust if these were constructor-style --- matches instead of record-style matches. --- If someone adds a field containing names, this would go unnoticed. instance NamesIn Definition where - namesIn' sg def = namesIn' sg (defType def, theDef def, defDisplay def) + namesAndMetasIn' sg + (Defn _ _ t _ _ _ _ disp _ _ _ _ _ _ _ _ _ _ def) = + namesAndMetasIn' sg (t, def, disp) instance NamesIn Defn where - namesIn' sg = \case + namesAndMetasIn' sg = \case Axiom _ -> mempty - DataOrRecSig{} -> mempty - GeneralizableVar{} -> mempty - PrimitiveSort{} -> mempty + DataOrRecSig _ -> mempty + GeneralizableVar -> mempty + PrimitiveSort _ s -> namesAndMetasIn' sg s AbstractDefn{} -> __IMPOSSIBLE__ -- Andreas 2017-07-27, Q: which names can be in @cc@ which are not already in @cl@? - Function { funClauses = cl, funCompiled = cc } - -> namesIn' sg (cl, cc) - Datatype { dataClause = cl, dataCons = cs, dataSort = s } - -> namesIn' sg (cl, cs, s) - Record { recClause = cl, recConHead = c, recFields = fs, recComp = comp } - -> namesIn' sg (cl, c, fs, comp) - -- Don't need recTel since those will be reachable from the constructor - Constructor { conSrcCon = c, conData = d, conComp = kit, conProj = fs } - -> namesIn' sg (c, d, kit, fs) - Primitive { primClauses = cl, primCompiled = cc } - -> namesIn' sg (cl, cc) + Function cl cc _ _ _ _ _ _ _ _ _ _ el _ _ + -> namesAndMetasIn' sg (cl, cc, el) + Datatype _ _ cl cs s _ _ _ trX trD + -> namesAndMetasIn' sg (cl, cs, s, trX, trD) + Record _ cl c _ fs recTel _ _ _ _ _ _ comp + -> namesAndMetasIn' sg (cl, c, fs, recTel, comp) + Constructor _ _ c d _ _ kit fs _ _ + -> namesAndMetasIn' sg (c, d, kit, fs) + Primitive _ _ cl _ cc + -> namesAndMetasIn' sg (cl, cc) instance NamesIn Clause where - namesIn' sg Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } = - namesIn' sg (tel, ps, b, t) + namesAndMetasIn' sg (Clause _ _ tel ps b t _ _ _ _ _ _) = + namesAndMetasIn' sg (tel, ps, b, t) instance NamesIn CompiledClauses where - namesIn' sg (Case _ c) = namesIn' sg c - namesIn' sg (Done _ v) = namesIn' sg v - namesIn' sg Fail{} = mempty + namesAndMetasIn' sg (Case _ c) = namesAndMetasIn' sg c + namesAndMetasIn' sg (Done _ v) = namesAndMetasIn' sg v + namesAndMetasIn' sg (Fail _) = mempty -- Andreas, 2017-07-27 -- Why ignoring the litBranches? instance NamesIn a => NamesIn (Case a) where - namesIn' sg Branches{ conBranches = bs, catchAllBranch = c } = - namesIn' sg (bs, c) + namesAndMetasIn' sg (Branches _ bs _ _ c _ _) = + namesAndMetasIn' sg (bs, c) instance NamesIn (Pattern' a) where - namesIn' sg = \case - VarP{} -> mempty - LitP _ l -> namesIn' sg l - DotP _ v -> namesIn' sg v - ConP c _ args -> namesIn' sg (c, args) - DefP o q args -> namesIn' sg (q, args) - ProjP _ f -> namesIn' sg f - IApplyP _ t u _ -> namesIn' sg (t, u) + namesAndMetasIn' sg = \case + VarP _ _ -> mempty + LitP _ l -> namesAndMetasIn' sg l + DotP _ v -> namesAndMetasIn' sg v + ConP c _ args -> namesAndMetasIn' sg (c, args) + DefP o q args -> namesAndMetasIn' sg (q, args) + ProjP _ f -> namesAndMetasIn' sg f + IApplyP _ t u _ -> namesAndMetasIn' sg (t, u) instance NamesIn a => NamesIn (Type' a) where - namesIn' sg (El s t) = namesIn' sg (s, t) + namesAndMetasIn' sg (El s t) = namesAndMetasIn' sg (s, t) instance NamesIn Sort where - namesIn' sg = \case - Type l -> namesIn' sg l - Prop l -> namesIn' sg l + namesAndMetasIn' sg = \case + Type l -> namesAndMetasIn' sg l + Prop l -> namesAndMetasIn' sg l Inf _ _ -> mempty - SSet l -> namesIn' sg l + SSet l -> namesAndMetasIn' sg l SizeUniv -> mempty LockUniv -> mempty - PiSort a b c -> namesIn' sg (a, b, c) - FunSort a b -> namesIn' sg (a, b) - UnivSort a -> namesIn' sg a - MetaS _ es -> namesIn' sg es - DefS d es -> namesIn' sg (d, es) - DummyS{} -> mempty + IntervalUniv -> mempty + PiSort a b c -> namesAndMetasIn' sg (a, b, c) + FunSort a b -> namesAndMetasIn' sg (a, b) + UnivSort a -> namesAndMetasIn' sg a + MetaS x es -> namesAndMetasIn' sg (x, es) + DefS d es -> namesAndMetasIn' sg (d, es) + DummyS _ -> mempty instance NamesIn Term where - namesIn' sg = \case - Var _ args -> namesIn' sg args - Lam _ b -> namesIn' sg b - Lit l -> namesIn' sg l - Def f args -> namesIn' sg (f, args) - Con c _ args -> namesIn' sg (c, args) - Pi a b -> namesIn' sg (a, b) - Sort s -> namesIn' sg s - Level l -> namesIn' sg l - MetaV _ args -> namesIn' sg args - DontCare v -> namesIn' sg v - Dummy{} -> mempty + namesAndMetasIn' sg = \case + Var _ args -> namesAndMetasIn' sg args + Lam _ b -> namesAndMetasIn' sg b + Lit l -> namesAndMetasIn' sg l + Def f args -> namesAndMetasIn' sg (f, args) + Con c _ args -> namesAndMetasIn' sg (c, args) + Pi a b -> namesAndMetasIn' sg (a, b) + Sort s -> namesAndMetasIn' sg s + Level l -> namesAndMetasIn' sg l + MetaV x args -> namesAndMetasIn' sg (x, args) + DontCare v -> namesAndMetasIn' sg v + Dummy _ args -> namesAndMetasIn' sg args instance NamesIn Level where - namesIn' sg (Max _ ls) = namesIn' sg ls + namesAndMetasIn' sg (Max _ ls) = namesAndMetasIn' sg ls instance NamesIn PlusLevel where - namesIn' sg (Plus _ l) = namesIn' sg l + namesAndMetasIn' sg (Plus _ l) = namesAndMetasIn' sg l --- For QName literals! +-- For QName and Meta literals! instance NamesIn Literal where - namesIn' sg = \case - LitNat{} -> mempty - LitWord64{} -> mempty - LitString{} -> mempty - LitChar{} -> mempty - LitFloat{} -> mempty - LitQName x -> namesIn' sg x - LitMeta{} -> mempty + namesAndMetasIn' sg = \case + LitNat _ -> mempty + LitWord64 _ -> mempty + LitString _ -> mempty + LitChar _ -> mempty + LitFloat _ -> mempty + LitQName x -> namesAndMetasIn' sg x + LitMeta _ m -> namesAndMetasIn' sg m instance NamesIn a => NamesIn (Elim' a) where - namesIn' sg (Apply arg) = namesIn' sg arg - namesIn' sg (Proj _ f) = namesIn' sg f - namesIn' sg (IApply x y arg) = namesIn' sg (x, y, arg) + namesAndMetasIn' sg (Apply arg) = namesAndMetasIn' sg arg + namesAndMetasIn' sg (Proj _ f) = namesAndMetasIn' sg f + namesAndMetasIn' sg (IApply x y arg) = namesAndMetasIn' sg (x, y, arg) +instance NamesIn a => NamesIn (Substitution' a) where + namesAndMetasIn' sg = \case + IdS -> mempty + EmptyS _ -> mempty + t :# s -> namesAndMetasIn' sg (t, s) + Strengthen _ _ s -> namesAndMetasIn' sg s + Wk _ s -> namesAndMetasIn' sg s + Lift _ s -> namesAndMetasIn' sg s + instance NamesIn DisplayForm where - namesIn' sg (Display _ ps v) = namesIn' sg (ps, v) + namesAndMetasIn' sg (Display _ ps v) = namesAndMetasIn' sg (ps, v) instance NamesIn DisplayTerm where - namesIn' sg = \case - DWithApp v us es -> namesIn' sg (v, us, es) - DCon c _ vs -> namesIn' sg (c, vs) - DDef f es -> namesIn' sg (f, es) - DDot v -> namesIn' sg v - DTerm v -> namesIn' sg v + namesAndMetasIn' sg = \case + DWithApp v us es -> namesAndMetasIn' sg (v, us, es) + DCon c _ vs -> namesAndMetasIn' sg (c, vs) + DDef f es -> namesAndMetasIn' sg (f, es) + DDot v -> namesAndMetasIn' sg v + DTerm v -> namesAndMetasIn' sg v +instance NamesIn a => NamesIn (Builtin a) where + namesAndMetasIn' sg = \case + Builtin t -> namesAndMetasIn' sg t + Prim x -> namesAndMetasIn' sg x + BuiltinRewriteRelations xs -> namesAndMetasIn' sg xs + +-- | Note that the 'primFunImplementation' is skipped. +instance NamesIn PrimFun where + namesAndMetasIn' sg = \case + PrimFun x _ _ -> namesAndMetasIn' sg x + +instance NamesIn Section where + namesAndMetasIn' sg = \case + Section tel -> namesAndMetasIn' sg tel + +instance NamesIn NLPat where + namesAndMetasIn' sg = \case + PVar _ _ -> mempty + PDef a b -> namesAndMetasIn' sg (a, b) + PLam _ a -> namesAndMetasIn' sg a + PPi a b -> namesAndMetasIn' sg (a, b) + PSort a -> namesAndMetasIn' sg a + PBoundVar _ a -> namesAndMetasIn' sg a + PTerm a -> namesAndMetasIn' sg a + +instance NamesIn NLPType where + namesAndMetasIn' sg = \case + NLPType a b -> namesAndMetasIn' sg (a, b) + +instance NamesIn NLPSort where + namesAndMetasIn' sg = \case + PType a -> namesAndMetasIn' sg a + PProp a -> namesAndMetasIn' sg a + PSSet a -> namesAndMetasIn' sg a + PInf _ _ -> mempty + PSizeUniv -> mempty + PLockUniv -> mempty + PIntervalUniv -> mempty + +instance NamesIn RewriteRule where + namesAndMetasIn' sg = \case + RewriteRule a b c d e f _ -> + namesAndMetasIn' sg (a, b, c, d, e, f) + +instance (NamesIn a, NamesIn b) => NamesIn (HashMap a b) where + namesAndMetasIn' sg = namesAndMetasIn' sg . HMap.toList + +instance NamesIn System where + namesAndMetasIn' sg (System tel cs) = namesAndMetasIn' sg (tel, cs) + +instance NamesIn ExtLamInfo where + namesAndMetasIn' sg (ExtLamInfo _ _ s) = namesAndMetasIn' sg s + +instance NamesIn a => NamesIn (FunctionInverse' a) where + namesAndMetasIn' sg = \case + NotInjective -> mempty + Inverse m -> namesAndMetasIn' sg m + +instance NamesIn TTerm where + namesAndMetasIn' sg = \case + TVar _ -> mempty + TPrim _ -> mempty + TDef x -> namesAndMetasIn' sg x + TApp t xs -> namesAndMetasIn' sg (t, xs) + TLam t -> namesAndMetasIn' sg t + TLit l -> namesAndMetasIn' sg l + TCon x -> namesAndMetasIn' sg x + TLet t1 t2 -> namesAndMetasIn' sg (t1, t2) + TCase _ c t ts -> namesAndMetasIn' sg (c, t, ts) + TUnit -> mempty + TSort -> mempty + TErased -> mempty + TCoerce t -> namesAndMetasIn' sg t + TError _ -> mempty + +instance NamesIn TAlt where + namesAndMetasIn' sg = \case + TACon x _ t -> namesAndMetasIn' sg (x, t) + TAGuard t1 t2 -> namesAndMetasIn' sg (t1, t2) + TALit l t -> namesAndMetasIn' sg (l, t) + +instance NamesIn CaseType where + namesAndMetasIn' sg = \case + CTData _ x -> namesAndMetasIn' sg x + CTNat -> mempty + CTInt -> mempty + CTChar -> mempty + CTString -> mempty + CTFloat -> mempty + CTQName -> mempty + +instance NamesIn CaseInfo where + namesAndMetasIn' sg (CaseInfo _ t) = namesAndMetasIn' sg t + +instance NamesIn Compiled where + namesAndMetasIn' sg (Compiled t _) = namesAndMetasIn' sg t + -- Pattern synonym stuff -- newtype PSyn = PSyn A.PatternSynDefn instance NamesIn PSyn where - namesIn' sg (PSyn (_args, p)) = namesIn' sg p + namesAndMetasIn' sg (PSyn (_args, p)) = namesAndMetasIn' sg p instance NamesIn (A.Pattern' a) where - namesIn' sg = \case - A.VarP{} -> mempty - A.ConP _ c args -> namesIn' sg (c, args) - A.ProjP _ _ d -> namesIn' sg d - A.DefP _ f args -> namesIn' sg (f, args) - A.WildP{} -> mempty - A.AsP _ _ p -> namesIn' sg p - A.AbsurdP{} -> mempty - A.LitP _ l -> namesIn' sg l - A.PatternSynP _ c args -> namesIn' sg (c, args) - A.RecP _ fs -> namesIn' sg fs + namesAndMetasIn' sg = \case + A.VarP _ -> mempty + A.ConP _ c args -> namesAndMetasIn' sg (c, args) + A.ProjP _ _ d -> namesAndMetasIn' sg d + A.DefP _ f args -> namesAndMetasIn' sg (f, args) + A.WildP _ -> mempty + A.AsP _ _ p -> namesAndMetasIn' sg p + A.AbsurdP _ -> mempty + A.LitP _ l -> namesAndMetasIn' sg l + A.PatternSynP _ c args -> namesAndMetasIn' sg (c, args) + A.RecP _ fs -> namesAndMetasIn' sg fs A.DotP{} -> __IMPOSSIBLE__ -- Dot patterns are not allowed in pattern synonyms A.EqualP{} -> __IMPOSSIBLE__ -- Andrea: should we allow these in pattern synonyms? - A.WithP _ p -> namesIn' sg p + A.WithP _ p -> namesAndMetasIn' sg p A.AnnP _ a p -> __IMPOSSIBLE__ -- Type annotations are not (yet) allowed in pattern synonyms instance NamesIn AmbiguousQName where - namesIn' sg (AmbQ cs) = namesIn' sg cs + namesAndMetasIn' sg (AmbQ cs) = namesAndMetasIn' sg cs diff --git a/src/full/Agda/Syntax/Internal/Pattern.hs b/src/full/Agda/Syntax/Internal/Pattern.hs --- a/src/full/Agda/Syntax/Internal/Pattern.hs +++ b/src/full/Agda/Syntax/Internal/Pattern.hs @@ -355,3 +355,10 @@ LitP{} -> [] ProjP{} -> [] IApplyP _ _ _ x -> [(x, defaultModality)] + + +hasDefP :: [NamedArg DeBruijnPattern] -> Bool +hasDefP ps = getAny $ flip foldPattern ps $ \ (x :: DeBruijnPattern) -> + case x of + DefP{} -> Any True + _ -> Any False diff --git a/src/full/Agda/Syntax/Internal/SanityCheck.hs b/src/full/Agda/Syntax/Internal/SanityCheck.hs --- a/src/full/Agda/Syntax/Internal/SanityCheck.hs +++ b/src/full/Agda/Syntax/Internal/SanityCheck.hs @@ -40,9 +40,9 @@ unless (size delta > 0) $ err $ "consS: empty target" sanityCheckVars gamma v sanityCheckSubst gamma rho (dropLast delta) - Strengthen _ rho -> do - unless (size delta > 0) $ err $ "strS: empty target" - sanityCheckSubst gamma rho (dropLast delta) + Strengthen _ n rho -> do + unless (size delta >= n) $ err $ "strS: empty target" + sanityCheckSubst gamma rho (dropLastN n delta) Wk n rho -> do unless (size gamma >= n) $ err $ "wkS:" <+> sep [ "|" <> pretty gamma <> "|" , text $ "< " ++ show n ] diff --git a/src/full/Agda/Syntax/Literal.hs b/src/full/Agda/Syntax/Literal.hs --- a/src/full/Agda/Syntax/Literal.hs +++ b/src/full/Agda/Syntax/Literal.hs @@ -5,13 +5,14 @@ import Data.Char import Data.Word -import Data.Data (Data) import Data.Text (Text) import qualified Data.Text as T import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Abstract.Name +import {-# SOURCE #-} Agda.Syntax.TopLevelModuleName + (TopLevelModuleName) import Agda.Utils.FileName import Agda.Utils.Float ( doubleDenotEq, doubleDenotOrd ) import Agda.Utils.Pretty @@ -24,8 +25,8 @@ | LitString !Text | LitChar !Char | LitQName !QName - | LitMeta AbsolutePath MetaId - deriving (Data, Show) + | LitMeta !TopLevelModuleName !MetaId + deriving Show instance Pretty Literal where pretty (LitNat n) = pretty n @@ -92,7 +93,7 @@ killRange (LitString x) = LitString x killRange (LitChar x) = LitChar x killRange (LitQName x) = killRange1 LitQName x - killRange (LitMeta f x) = LitMeta f x + killRange (LitMeta m x) = LitMeta (killRange m) x -- | Ranges are not forced. @@ -103,4 +104,4 @@ rnf (LitString _ ) = () rnf (LitChar _ ) = () rnf (LitQName a ) = rnf a - rnf (LitMeta _ x ) = rnf x + rnf (LitMeta m _ ) = rnf m diff --git a/src/full/Agda/Syntax/Notation.hs b/src/full/Agda/Syntax/Notation.hs --- a/src/full/Agda/Syntax/Notation.hs +++ b/src/full/Agda/Syntax/Notation.hs @@ -34,18 +34,20 @@ import Agda.Utils.Lens import Agda.Utils.List +import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null import Agda.Utils.Pretty import Agda.Utils.Impossible --- | Data type constructed in the Happy parser; converted to 'GenPart' --- before it leaves the Happy code. +-- | Data type constructed in the Happy parser; converted to +-- 'NotationPart' before it leaves the Happy code. data HoleName - = LambdaHole { _bindHoleName :: RString - , holeName :: RString } - -- ^ @\ x -> y@; 1st argument is the bound name (unused for now). + = LambdaHole { _bindHoleNames :: List1 RString + , holeName :: RString + } + -- ^ @λ x₁ … xₙ → y@: The first argument contains the bound names. | ExprHole { holeName :: RString } -- ^ Simple named hole with hiding. @@ -59,32 +61,25 @@ stringParts gs = [ rangedThing x | IdPart x <- gs ] -- | Target argument position of a part (Nothing if it is not a hole). -holeTarget :: GenPart -> Maybe Int -holeTarget (BindHole _ n) = Just $ rangedThing n -holeTarget (WildHole n) = Just $ rangedThing n -holeTarget (NormalHole _ n) = Just $ rangedThing $ namedArg n -holeTarget IdPart{} = Nothing - --- | Is the part a hole? WildHoles don't count since they don't correspond to --- anything the user writes. -isAHole :: GenPart -> Bool -isAHole BindHole{} = True -isAHole NormalHole{} = True -isAHole WildHole{} = False -isAHole IdPart{} = False +holeTarget :: NotationPart -> Maybe Int +holeTarget (VarPart _ n) = Just $ holeNumber $ rangedThing n +holeTarget (WildPart n) = Just $ holeNumber $ rangedThing n +holeTarget (HolePart _ n) = Just $ rangedThing $ namedArg n +holeTarget IdPart{} = Nothing --- | Is the part a normal hole? -isNormalHole :: GenPart -> Bool -isNormalHole NormalHole{} = True -isNormalHole BindHole{} = False -isNormalHole WildHole{} = False -isNormalHole IdPart{} = False +-- | Is the part a hole? +isAHole :: NotationPart -> Bool +isAHole HolePart{} = True +isAHole VarPart{} = False +isAHole WildPart{} = False +isAHole IdPart{} = False -- | Is the part a binder? -isBindingHole :: GenPart -> Bool -isBindingHole BindHole{} = True -isBindingHole WildHole{} = True -isBindingHole _ = False +isBinder :: NotationPart -> Bool +isBinder HolePart{} = False +isBinder VarPart{} = True +isBinder WildPart{} = True +isBinder IdPart{} = False -- | Classification of notations. @@ -101,7 +96,7 @@ notationKind :: Notation -> NotationKind notationKind [] = NoNotation notationKind (h:syn) = - case (isNormalHole h, isNormalHole $ last1 h syn) of + case (isAHole h, isAHole $ last1 h syn) of (True , True ) -> InfixNotation (True , False) -> PostfixNotation (False, True ) -> PrefixNotation @@ -109,16 +104,16 @@ -- | From notation with names to notation with indices. -- --- Example: --- @ --- ids = ["for", "x", "∈", "xs", "return", "e"] --- holes = [ LambdaHole "x" "e", ExprHole "xs" ] --- @ --- creates the notation +-- An example (with some parts of the code omitted): +-- The lists +-- @["for", "x", "∈", "xs", "return", "e"]@ +-- and +-- @['LambdaHole' ("x" :| []) "e", 'ExprHole' "xs"]@ +-- are mapped to the following notation: -- @ --- [ IdPart "for" , BindHole 0 --- , IdPart "∈" , NormalHole 1 --- , IdPart "return" , NormalHole 0 +-- [ 'IdPart' "for" , 'VarPart' ('BoundVariablePosition' 0 0) +-- , 'IdPart' "∈" , 'HolePart' 1 +-- , 'IdPart' "return" , 'HolePart' 0 -- ] -- @ mkNotation :: [NamedArg HoleName] -> [RString] -> Either String Notation @@ -136,11 +131,11 @@ -- Andreas, 2018-10-18, issue #3285: -- syntax that is just a single hole is ill-formed and crashes the operator parser when (isSingleHole xs) $ throwError "syntax cannot be a single hole" - return $ insertWildHoles xs + return $ insertWildParts xs where holeNames :: [RString] holeNames = map namedArg holes >>= \case - LambdaHole x y -> [x, y] + LambdaHole _ y -> [y] ExprHole y -> [y] prettyHoles :: String @@ -153,55 +148,86 @@ numberedHoles :: [(Int, NamedArg HoleName)] numberedHoles = zip holeNumbers holes - -- The WildHoles don't correspond to anything in the right-hand side so + -- The WildParts don't correspond to anything in the right-hand side so -- we add them next to their corresponding body. Slightly subtle: due to -- the way the operator parsing works they can't be added first or last. - insertWildHoles :: [GenPart] -> [GenPart] - insertWildHoles xs = foldr ins xs wilds + insertWildParts :: [NotationPart] -> [NotationPart] + insertWildParts xs = foldr ins xs wilds where - wilds = [ i | (_, WildHole i) <- holeMap ] - ins w (NormalHole r h : hs) - | namedArg h == w = NormalHole r h : WildHole w : hs + wilds = [ i | (_, WildPart i) <- holeMap ] + + ins w (HolePart r h : hs) + | namedArg h == fmap holeNumber w = + HolePart r h : WildPart w : hs ins w (h : hs) = h : insBefore w hs ins _ [] = __IMPOSSIBLE__ - insBefore w (NormalHole r h : hs) - | namedArg h == w = WildHole w : NormalHole r h : hs + insBefore w (HolePart r h : hs) + | namedArg h == fmap holeNumber w = + WildPart w : HolePart r h : hs insBefore w (h : hs) = h : insBefore w hs insBefore _ [] = __IMPOSSIBLE__ - -- Create a map (association list) from hole names to holes. - -- A @LambdaHole@ contributes two entries: - -- both names are mapped to the same number, - -- but distinguished by BindHole vs. NormalHole. - holeMap :: [(RString, GenPart)] + -- A map (association list) from hole names to notation parts. A + -- @LambdaHole@ contributes one or more entries, one @HolePart@ + -- and zero or more @VarPart@s or @WildParts@, all mapped to the + -- same number. + holeMap :: [(RString, NotationPart)] holeMap = do - (i, h) <- numberedHoles -- v This range is filled in by mkPart - let ri x = Ranged (getRange x) i - normalHole y = NormalHole noRange $ fmap (ri y <$) h + (i, h) <- numberedHoles + let ri x = Ranged (getRange x) i + rp x n = Ranged (getRange x) $ + BoundVariablePosition + { holeNumber = i + , varNumber = n + } + hole y = HolePart noRange $ fmap (ri y <$) h + -- This range is filled in by mkPart. case namedArg h of - ExprHole y -> [(y, normalHole y)] - LambdaHole x y - | "_" <- rangedThing x -> [(x, WildHole (ri x)), (y, normalHole y)] - | otherwise -> [(x, BindHole noRange (ri x)), (y, normalHole y)] - -- Filled in by mkPart + ExprHole y -> [(y, hole y)] + LambdaHole xs y -> [(y, hole y)] ++ + zipWith + (\ n x -> case rangedThing x of + "_" -> (x, WildPart (rp x n)) + _ -> (x, VarPart noRange (rp x n))) + -- Filled in by mkPart. + [0..] + (List1.toList xs) -- Check whether all hole names are distinct. -- The hole names are the keys of the @holeMap@. uniqueHoleNames = distinct [ x | (x, _) <- holeMap, rangedThing x /= "_" ] - isExprLinear xs = List.sort [ i | x <- xs, isNormalHole x, let Just i = holeTarget x ] == holeNumbers - isLambdaLinear xs = List.sort [ rangedThing x | BindHole _ x <- xs ] == - [ i | (i, h) <- numberedHoles, - LambdaHole x _ <- [namedArg h], rangedThing x /= "_" ] + isExprLinear xs = + List.sort [ i | x <- xs, isAHole x, let Just i = holeTarget x ] + == + holeNumbers - noAdjacentHoles :: [GenPart] -> Bool - noAdjacentHoles [] = __IMPOSSIBLE__ - noAdjacentHoles [x] = True - noAdjacentHoles (x:y:xs) = - not (isAHole x && isAHole y) && noAdjacentHoles (y:xs) + isLambdaLinear xs = + List.sort [ rangedThing x | VarPart _ x <- xs ] + == + [ BoundVariablePosition { holeNumber = i, varNumber = v } + | (i, h) <- numberedHoles + , LambdaHole vs _ <- [namedArg h] + , (v, x) <- zip [0..] $ map rangedThing $ List1.toList vs + , x /= "_" + ] - isSingleHole :: [GenPart] -> Bool + noAdjacentHoles :: [NotationPart] -> Bool + noAdjacentHoles = + noAdj . + filter (\h -> case h of + HolePart{} -> True + IdPart{} -> True + _ -> False) + where + noAdj [] = __IMPOSSIBLE__ + noAdj [x] = True + noAdj (x:y:xs) = + not (isAHole x && isAHole y) && + noAdj (y:xs) + + isSingleHole :: [NotationPart] -> Bool isSingleHole = \case [ IdPart{} ] -> False [ _hole ] -> True @@ -260,7 +286,7 @@ -- | Create a 'Notation' (without binders) from a concrete 'Name'. -- Does the obvious thing: --- 'Hole's become 'NormalHole's, 'Id's become 'IdParts'. +-- 'Hole's become 'HolePart's, 'Id's become 'IdParts'. -- If 'Name' has no 'Hole's, it returns 'noNotation'. syntaxOf :: Name -> Notation syntaxOf y @@ -272,7 +298,7 @@ -- Result will have no 'BindingHole's. mkSyn :: Int -> [NamePart] -> Notation mkSyn n [] = [] - mkSyn n (Hole : xs) = NormalHole noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs + mkSyn n (Hole : xs) = HolePart noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs mkSyn n (Id x : xs) = IdPart (unranged x) : mkSyn n xs -- | Merges 'NewNotation's that have the same precedence level and @@ -336,6 +362,15 @@ merge :: [NewNotation] -> NewNotation merge [] = __IMPOSSIBLE__ merge ns@(n : _) = n { notaNames = Set.unions $ map notaNames ns } + +-- | Check if a notation contains any lambdas (in which case it cannot be used in a pattern). +isLambdaNotation :: NewNotation -> Bool +isLambdaNotation n = any isBinder (notation n) + where + isBinder VarPart{} = True + isBinder WildPart{} = True + isBinder IdPart{} = False + isBinder HolePart{} = False -- | Lens for 'Fixity' in 'NewNotation'. 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 @@ -41,6 +41,7 @@ import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Literate import Agda.Syntax.Concrete +import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Parser.Tokens import Agda.Utils.FileName @@ -71,19 +72,21 @@ -- | Embed a 'ParseResult' as 'PM' computation. -wrap :: ParseResult a -> PM a +wrap :: ParseResult a -> PM (a, CohesionAttributes) wrap (ParseFailed err) = throwError err wrap (ParseOk s x) = do modify' (parseWarnings s ++) - return x + return (x, parseCohesion s) -wrapM :: IO (ParseResult a) -> PM a +wrapM :: IO (ParseResult a) -> PM (a, CohesionAttributes) wrapM m = liftIO m >>= wrap -- | Returns the contents of the given file. -readFilePM :: AbsolutePath -> PM Text -readFilePM path = wrapIOM (ReadFileError path) (readTextFile $ filePath path) +readFilePM :: RangeFile -> PM Text +readFilePM file = + wrapIOM (ReadFileError file) $ + readTextFile (filePath $ rangeFilePath file) wrapIOM :: (MonadError e m, MonadIO m) => (IOError -> e) -> IO a -> m a wrapIOM f m = do @@ -103,7 +106,8 @@ , parseLiterate :: LiterateParser a } -type LiterateParser a = Parser a -> [Layer] -> PM a +type LiterateParser a = + Parser a -> [Layer] -> PM (a, CohesionAttributes) -- | Initial state for lexing. @@ -117,7 +121,7 @@ -- | Parse without top-level layout. -parse :: Parser a -> String -> PM a +parse :: Parser a -> String -> PM (a, CohesionAttributes) parse p = wrapM . return . M.parse (parseFlags p) normalLexState (parser p) -- | Parse with top-level layout. @@ -126,7 +130,7 @@ :: SrcFile -- ^ Name of source file. -> Parser a -- ^ Parser to use. -> String -- ^ Contents of source file. - -> PM a + -> PM (a, CohesionAttributes) parseFileFromString src p = wrapM . return . M.parseFromSrc (parseFlags p) layoutLexState (parser p) src -- | Parse with top-level layout. @@ -138,32 +142,33 @@ parseLiterateWithComments :: LiterateParser [Token] parseLiterateWithComments p layers = do - code <- parseLiterateWithoutComments p layers + (code, coh) <- parseLiterateWithoutComments p layers let literate = filter (not . isCodeLayer) layers let (terms, overlaps) = interleaveRanges (map Left code) (map Right literate) forM_ (map fst overlaps) $ \c -> warning $ OverlappingTokensWarning { warnRange = getRange c } - return $ forMaybe terms $ \case + (, 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 + Right (Layer Code _ _) -> Nothing) parseLiterateFile :: Processor -> Parser a - -> AbsolutePath - -- ^ The path to the file. + -> RangeFile + -- ^ The file. -> String -- ^ The file contents. Note that the file is /not/ read from -- disk. - -> PM a + -> PM (a, CohesionAttributes) parseLiterateFile po p path = parseLiterate p p . po (startPos (Just path)) -parsePosString :: Parser a -> Position -> String -> PM a +parsePosString :: + Parser a -> Position -> String -> PM (a, CohesionAttributes) parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) normalLexState (parser p) -- | Extensions supported by `parseFile`. @@ -174,24 +179,26 @@ parseFile :: Show a => Parser a - -> AbsolutePath - -- ^ The path to the file. + -> RangeFile + -- ^ The file. -> String -- ^ The file contents. Note that the file is /not/ read from -- disk. - -> PM (a, FileType) + -> PM ((a, CohesionAttributes), FileType) parseFile p file input = - if ".agda" `List.isSuffixOf` filePath file then + if ".agda" `List.isSuffixOf` path then (, AgdaFileType) <$> parseFileFromString (Strict.Just file) p input else go literateProcessors where + path = filePath (rangeFilePath file) + go [] = throwError InvalidExtensionError { errPath = file , errValidExts = acceptableFileExts } go ((ext, (po, ft)) : pos) - | ext `List.isSuffixOf` filePath file = + | ext `List.isSuffixOf` path = (, ft) <$> parseLiterateFile po p file input | otherwise = go pos diff --git a/src/full/Agda/Syntax/Parser/Layout.hs b/src/full/Agda/Syntax/Parser/Layout.hs --- a/src/full/Agda/Syntax/Parser/Layout.hs +++ b/src/full/Agda/Syntax/Parser/Layout.hs @@ -13,7 +13,7 @@ > [Layout 12, Layout 4, Layout 0] The closest layout block is the one following @do@ which is - started by token @foo@ at column 12. The second closest block is the + started by token @y@ at column 12. The second closest block is the @where@ clause started by the @x'@ token which has indentation 4. Finally, there is a top-level layout block with indentation 0. 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,4 +1,3 @@ - {-| This module contains the building blocks used to construct the lexer. -} module Agda.Syntax.Parser.LexActions @@ -35,6 +34,8 @@ import Agda.Syntax.Literal import Agda.Utils.List +import Agda.Utils.List1 (String1, toList) +import qualified Agda.Utils.List1 as List1 import Agda.Utils.Impossible @@ -251,15 +252,15 @@ -- | Parse an identifier. Identifiers can be qualified (see 'Name'). -- Example: @Foo.Bar.f@ identifier :: LexAction Token -identifier = qualified (either TokId TokQId) +identifier = qualified $ either (TokId . second toList) (TokQId . map (second toList)) -- | Parse a possibly qualified name. -qualified :: (Either (Interval, String) [(Interval, String)] -> a) -> LexAction a +qualified :: (Either (Interval, String1) [(Interval, String1)] -> a) -> LexAction a qualified tok = token $ \s -> do i <- getParseInterval - case mkName i $ wordsBy (=='.') s of + case mkName i $ List1.wordsBy (== '.') s of [] -> lexError "lex error on .." [x] -> return $ tok $ Left x xs -> return $ tok $ Right xs @@ -267,7 +268,7 @@ -- Compute the ranges for the substrings (separated by '.') of -- a name. Dots are included: the intervals generated for -- "A.B.x" correspond to "A.", "B." and "x". - mkName :: Interval -> [String] -> [(Interval, String)] + mkName :: Interval -> [String1] -> [(Interval, String1)] mkName _ [] = [] mkName i [x] = [(i, x)] mkName i (x:xs) = (i0, x) : mkName i1 xs 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 @@ -90,6 +90,7 @@ "INJECTIVE" { keyword KwINJECTIVE } "INLINE" { keyword KwINLINE } "NOINLINE" { keyword KwNOINLINE } + "NOT_PROJECTION_LIKE" { keyword KwNOT_PROJECTION_LIKE } "LINE" { keyword KwLINE } "MEASURE" { keyword KwMEASURE } "NO_POSITIVITY_CHECK" { keyword KwNO_POSITIVITY_CHECK } 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 @@ -37,11 +37,11 @@ import Control.Monad.State import Data.Int -import Data.Data ( Data ) import Data.Maybe ( listToMaybe ) import Agda.Interaction.Options.Warnings +import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Position import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ) ) @@ -76,6 +76,8 @@ -- (states can be nested so we need a stack) , parseFlags :: ParseFlags -- ^ parametrization of the parser , parseWarnings :: ![ParseWarning] -- ^ In reverse order. + , parseCohesion :: !CohesionAttributes + -- ^ Every encountered occurrence of a cohesion attribute. } deriving Show @@ -151,12 +153,12 @@ -- | Parse errors that concern a whole file. | InvalidExtensionError - { errPath :: !AbsolutePath + { errPath :: !RangeFile -- ^ The file which the error concerns. , errValidExts :: [String] } | ReadFileError - { errPath :: !AbsolutePath + { errPath :: !RangeFile , errIOError :: IOError } deriving Show @@ -172,7 +174,7 @@ -- ^ Unsupported attribute. | MultipleAttributes Range !(Maybe String) -- ^ Multiple attributes. - deriving (Data, Show) + deriving Show instance NFData ParseWarning where rnf (OverlappingTokensWarning _) = () @@ -293,6 +295,7 @@ -- Just for better errors on stray @constructor@ decls. , parseFlags = flags , parseWarnings = [] + , parseCohesion = [] } where pos' = pos { srcFile = () } @@ -300,8 +303,8 @@ -- | Constructs the initial state of the parser. The string argument -- is the input string, the file path is only there because it's part -- of a position. -initState :: Maybe AbsolutePath -> ParseFlags -> String -> [LexState] - -> ParseState +initState :: + Maybe RangeFile -> ParseFlags -> String -> [LexState] -> ParseState initState file = initStatePos (startPos file) -- | The default flags. 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 @@ -31,9 +31,12 @@ import Control.Applicative ( (<|>) ) import Control.Monad +import Control.Monad.State import Data.Bifunctor (first, second) import Data.Char +import Data.DList (DList) +import qualified Data.DList as DL import qualified Data.List as List import Data.Maybe import Data.Semigroup ((<>), sconcat) @@ -166,6 +169,7 @@ 'NO_UNIVERSE_CHECK' { TokKeyword KwNO_UNIVERSE_CHECK $$ } 'NON_TERMINATING' { TokKeyword KwNON_TERMINATING $$ } 'NON_COVERING' { TokKeyword KwNON_COVERING $$ } + 'NOT_PROJECTION_LIKE' { TokKeyword KwNOT_PROJECTION_LIKE $$ } 'OPTIONS' { TokKeyword KwOPTIONS $$ } 'POLARITY' { TokKeyword KwPOLARITY $$ } 'WARNING_ON_USAGE' { TokKeyword KwWARNING_ON_USAGE $$ } @@ -294,6 +298,7 @@ | 'NO_UNIVERSE_CHECK' { TokKeyword KwNO_UNIVERSE_CHECK $1 } | 'NON_TERMINATING' { TokKeyword KwNON_TERMINATING $1 } | 'NON_COVERING' { TokKeyword KwNON_COVERING $1 } + | 'NOT_PROJECTION_LIKE' { TokKeyword KwNOT_PROJECTION_LIKE $1 } | 'OPTIONS' { TokKeyword KwOPTIONS $1 } | 'POLARITY' { TokKeyword KwPOLARITY $1 } | 'REWRITE' { TokKeyword KwREWRITE $1 } @@ -572,11 +577,12 @@ Strings : {- empty -} { [] } | string Strings { $1 : $2 } -ForeignCode :: { [(Interval, String)] } +ForeignCode :: { DList (Interval, String) } ForeignCode - : {- empty -} { [] } - | string ForeignCode { $1 : $2 } - | '{-#' ForeignCode '#-}' ForeignCode { [($1, "{-#")] ++ $2 ++ [($3, "#-}")] ++ $4 } + : {- empty -} { mempty } + | string ForeignCode { $1 `DL.cons` $2 } + | '{-#' ForeignCode '#-}' ForeignCode + { (($1, "{-#") `DL.cons` $2) <> (($3, "#-}") `DL.cons` $4) } PragmaName :: { Name } PragmaName : string {% mkName $1 } @@ -851,7 +857,7 @@ : LamBinds '->' {% case absurdBinding $1 of Just{} -> parseError "Absurd lambda cannot have a body." - Nothing -> return $ List1.fromList $ lamBindings $1 + Nothing -> return $ List1.fromListSafe __IMPOSSIBLE__ $ lamBindings $1 } AbsurdLamBindings :: { Either ([LamBinding], Hiding) (List1 Expr) } @@ -1307,6 +1313,8 @@ UnquoteDecl :: { Declaration } UnquoteDecl : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 } + | 'unquoteDecl' 'data' Id '=' Expr { UnquoteData (getRange($1, $2, $5)) $3 [] $5 } + | 'unquoteDecl' 'data' Id 'constructor' SpaceIds '=' Expr { UnquoteData (getRange($1, $2, $4, $7)) $3 (List1.toList $5) $7 } | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) (List1.toList $2) $4 } | 'unquoteDef' SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) (List1.toList $2) $4 } @@ -1314,7 +1322,7 @@ Syntax :: { Declaration } Syntax : 'syntax' Id HoleNames '=' SimpleIds {% case $2 of - Name _ _ (_ :| []) -> case mkNotation $3 $5 of + Name _ _ (_ :| []) -> case mkNotation (DL.toList $3) (reverse $5) of Left err -> parseError $ "Malformed syntax declaration: " ++ err Right n -> return $ Syntax $2 n _ -> parseError "Syntax declarations are allowed only for simple names (without holes)" @@ -1330,14 +1338,23 @@ PatternSynArgs :: { [Arg Name] } PatternSynArgs : DomainFreeBindings {% patternSynArgs $1 } +-- The list should be reversed. + SimpleIds :: { [RString] } -SimpleIds : SimpleId { [$1] } - | SimpleIds SimpleId {$1 ++ [$2]} +SimpleIds : SimpleId { [$1] } + | SimpleIds SimpleId { $2 : $1 } -HoleNames :: { [NamedArg HoleName] } -HoleNames : { [] } - | HoleNames HoleName {$1 ++ [$2]} +-- The list should be reversed. +SimpleIdsOrWildcards :: { List1 RString } +SimpleIdsOrWildcards + : SimpleIdOrWildcard { List1.singleton $1 } + | SimpleIdsOrWildcards SimpleIdOrWildcard { $2 <| $1 } + +HoleNames :: { DList (NamedArg HoleName) } +HoleNames : { mempty } + | HoleNames HoleName { $1 `DL.snoc` $2 } + HoleName :: { NamedArg HoleName } HoleName : SimpleTopHole { defaultNamedArg $1 } @@ -1349,20 +1366,24 @@ SimpleTopHole :: { HoleName } SimpleTopHole : SimpleId { ExprHole $1 } - | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole $3 $5 } - | '(' '\\' '_' '->' SimpleId ')' { LambdaHole (Ranged (getRange $3) "_") $5 } + | '(' '\\' SimpleIdsOrWildcards '->' SimpleId ')' + { LambdaHole (List1.reverse $3) $5 } SimpleHole :: { HoleName } SimpleHole : SimpleId { ExprHole $1 } - | '\\' SimpleId '->' SimpleId { LambdaHole $2 $4 } - | '\\' '_' '->' SimpleId { LambdaHole (Ranged (getRange $3) "_") $4 } --- Variable name hole to be implemented later. + | '\\' SimpleIdsOrWildcards '->' SimpleId + { LambdaHole (List1.reverse $2) $4 } -- Discard the interval. SimpleId :: { RString } SimpleId : id { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) } +SimpleIdOrWildcard :: { RString } +SimpleIdOrWildcard + : SimpleId { $1 } + | '_' { Ranged (getRange $1) "_" } + MaybeOpen :: { Maybe Range } MaybeOpen : 'open' { Just (getRange $1) } | {- empty -} { Nothing } @@ -1500,6 +1521,7 @@ | NonTerminatingPragma { $1 } | NoTerminationCheckPragma { $1 } | NonCoveringPragma { $1 } + | NotProjectionLikePragma { $1 } | WarningOnUsagePragma { $1 } | WarningOnImportPragma { $1 } | MeasurePragma { $1 } @@ -1532,7 +1554,9 @@ ForeignPragma :: { Pragma } ForeignPragma - : '{-#' 'FOREIGN' string ForeignCode '#-}' { ForeignPragma (getRange ($1, $2, fst $3, $5)) (mkRString $3) (recoverLayout $4) } + : '{-#' 'FOREIGN' string ForeignCode '#-}' + { ForeignPragma (getRange ($1, $2, fst $3, $5)) + (mkRString $3) (recoverLayout (DL.toList $4)) } CompilePragma :: { Pragma } CompilePragma @@ -1554,6 +1578,11 @@ : '{-#' 'NOINLINE' PragmaQName '#-}' { InlinePragma (getRange ($1,$2,$3,$4)) False $3 } +NotProjectionLikePragma :: { Pragma } +NotProjectionLikePragma + : '{-#' 'NOT_PROJECTION_LIKE' PragmaQName '#-}' + { NotProjectionLikePragma (getRange ($1,$2,$3,$4)) $3 } + InjectivePragma :: { Pragma } InjectivePragma : '{-#' 'INJECTIVE' PragmaQName '#-}' @@ -2375,8 +2404,15 @@ -- | Parse an attribute. toAttribute :: Expr -> Parser Attr -toAttribute x = maybe failure (return . Attr (getRange x) y) $ exprToAttribute x +toAttribute x = do + attr <- maybe failure (return . Attr r y) $ exprToAttribute x + case theAttr attr of + CohesionAttribute{} -> + modify' (\s -> s { parseCohesion = (y, r) : parseCohesion s }) + _ -> return () + return attr where + r = getRange x y = prettyShow x failure = parseErrorRange x $ "Unknown attribute: " ++ y 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,6 +24,7 @@ | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINLINE | KwNOINLINE | KwETA | KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING + | KwNOT_PROJECTION_LIKE | KwNON_COVERING | KwWARNING_ON_USAGE | KwWARNING_ON_IMPORT | KwMEASURE | KwDISPLAY diff --git a/src/full/Agda/Syntax/Position.hs b/src/full/Agda/Syntax/Position.hs --- a/src/full/Agda/Syntax/Position.hs +++ b/src/full/Agda/Syntax/Position.hs @@ -7,6 +7,8 @@ , PositionWithoutFile , Position'(..) , SrcFile + , RangeFile(..) + , mkRangeFile , positionInvariant , startPos , movePos @@ -34,6 +36,8 @@ , intervalToRange , rangeIntervals , rangeFile + , rangeModule' + , rangeModule , rightMargin , noRange , posToRange, posToRange' @@ -63,17 +67,17 @@ import Prelude hiding ( null ) import Control.DeepSeq +import Control.Monad import Control.Monad.Writer (runWriter, tell) import qualified Data.Foldable as Fold -import Data.Function +import Data.Function (on) import Data.Int -import Data.List hiding (null) +import Data.List (sort) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import Data.Data (Data) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Semigroup (Semigroup(..)) @@ -81,6 +85,9 @@ import GHC.Generics (Generic) +import {-# SOURCE #-} Agda.Syntax.TopLevelModuleName + (TopLevelModuleName) + import Agda.Utils.FileName import Agda.Utils.List import Agda.Utils.List1 (List1) @@ -115,7 +122,7 @@ , posCol :: !Int32 -- ^ Column number, counting from 1. } - deriving (Show, Data, Functor, Foldable, Traversable, Generic) + deriving (Show, Functor, Foldable, Traversable, Generic) positionInvariant :: Position' a -> Bool positionInvariant p = @@ -130,8 +137,50 @@ instance Ord a => Ord (Position' a) where compare = compare `on` importantPart -type SrcFile = Strict.Maybe AbsolutePath +type SrcFile = Strict.Maybe RangeFile +-- | File information used in the 'Position', 'Interval' and 'Range' +-- types. +data RangeFile = RangeFile + { rangeFilePath :: !AbsolutePath + -- ^ The file's path. + , rangeFileName :: !(Maybe TopLevelModuleName) + -- ^ The file's top-level module name. + -- + -- This field is optional, but some things may break if the field + -- is not instantiated with an actual top-level module name. For + -- instance, the 'Eq' and 'Ord' instances only make use of this + -- field. + -- + -- The field uses 'Maybe' rather than 'Strict.Maybe' because it + -- should be possible to instantiate it with something that is not + -- yet defined (see 'Agda.Interaction.Imports.parseSource'). + -- + -- This 'TopLevelModuleName' should not contain a range. + } + deriving (Show, Generic) + +-- | A smart constructor for 'RangeFile'. + +mkRangeFile :: AbsolutePath -> Maybe TopLevelModuleName -> RangeFile +mkRangeFile f top = RangeFile + { rangeFilePath = f + , rangeFileName = killRange top + } + +-- | Only the 'rangeFileName' component is compared. + +instance Eq RangeFile where + (==) = (==) `on` rangeFileName + +-- | Only the 'rangeFileName' component is compared. + +instance Ord RangeFile where + compare = compare `on` rangeFileName + +instance NFData RangeFile where + rnf (RangeFile _ n) = rnf n + type Position = Position' SrcFile type PositionWithoutFile = Position' () @@ -145,7 +194,7 @@ -- -- Note the invariant which intervals have to satisfy: 'intervalInvariant'. data Interval' a = Interval { iStart, iEnd :: !(Position' a) } - deriving (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) type Interval = Interval' SrcFile type IntervalWithoutFile = Interval' () @@ -196,7 +245,7 @@ = NoRange | Range !a (Seq IntervalWithoutFile) deriving - (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic) + (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) type Range = Range' SrcFile @@ -208,19 +257,17 @@ empty = NoRange -instance Semigroup a => Semigroup (Range' a) where +instance Eq a => Semigroup (Range' a) where NoRange <> r = r r <> NoRange = r - Range f is <> Range f' is' = Range (f <> f') (is <> is') + Range f is <> Range f' is' + | f /= f' = __IMPOSSIBLE__ + | otherwise = Range f (is <> is') -instance Semigroup a => Monoid (Range' a) where +instance Eq a => Monoid (Range' a) where mempty = empty mappend = (<>) --- | To get @'Semigroup' 'Range'@, we need a semigroup instance for 'AbsolutePath'. -instance Semigroup AbsolutePath where - f <> f' = if f == f' then f else __IMPOSSIBLE__ - -- | The intervals that make up the range. The intervals are -- consecutive and separated ('consecutiveAndSeparated'). rangeIntervals :: Range' a -> [IntervalWithoutFile] @@ -261,6 +308,20 @@ rangeFile NoRange = Strict.Nothing rangeFile (Range f _) = f +-- | The range's top-level module name, if any. +-- +-- If there is no range, then 'Nothing' is returned. If there is a +-- range without a module name, then @'Just' 'Nothing'@ is returned. +rangeModule' :: Range -> Maybe (Maybe TopLevelModuleName) +rangeModule' NoRange = Nothing +rangeModule' (Range f _) = Just $ case f of + Strict.Nothing -> Nothing + Strict.Just f -> rangeFileName f + +-- | The range's top-level module name, if any. +rangeModule :: Range -> Maybe TopLevelModuleName +rangeModule = join . rangeModule' + -- | Conflate a range to its right margin. rightMargin :: Range -> Range rightMargin r@NoRange = r @@ -543,6 +604,9 @@ -- Printing ------------------------------------------------------------------------ +instance Pretty RangeFile where + pretty = pretty . rangeFilePath + instance Pretty a => Pretty (Position' (Strict.Maybe a)) where pretty (Pn Strict.Nothing _ l c) = pretty l <> "," <> pretty c pretty (Pn (Strict.Just f) _ l c) = @@ -594,7 +658,7 @@ } -- | The first position in a file: position 1, line 1, column 1. -startPos :: Maybe AbsolutePath -> Position +startPos :: Maybe RangeFile -> Position startPos = startPos' . Strict.toStrict -- | Ranges between two unknown positions @@ -612,8 +676,8 @@ -- | Advance the position by a string. -- -- > movePosByString = foldl' movePos -movePosByString :: Position' a -> String -> Position' a -movePosByString = foldl' movePos +movePosByString :: Foldable t => Position' a -> t Char -> Position' a +movePosByString = Fold.foldl' movePos -- | Backup the position by one character. -- diff --git a/src/full/Agda/Syntax/Position.hs-boot b/src/full/Agda/Syntax/Position.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/Position.hs-boot @@ -0,0 +1,3 @@ +module Agda.Syntax.Position where + +class KillRange a 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 @@ -12,7 +12,7 @@ import Data.Either (partitionEithers) import Data.Foldable ( length, toList ) -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -21,8 +21,6 @@ import Data.Maybe import Data.Semigroup ( Semigroup(..) ) -import Data.Data (Data) - import GHC.Generics (Generic) import Agda.Benchmarking @@ -41,7 +39,9 @@ import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 ( List1, pattern (:|) ) +import Agda.Utils.List2 ( List2 ) import qualified Agda.Utils.List1 as List1 +import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe (filterMaybe) import Agda.Utils.Null import Agda.Utils.Pretty hiding ((<>)) @@ -62,19 +62,19 @@ , scopeImports :: Map C.QName A.ModuleName , scopeDatatypeModule :: Maybe DataOrRecordModule } - deriving (Data, Eq, Show, Generic) + deriving (Eq, Show, Generic) data DataOrRecordModule = IsDataModule | IsRecordModule - deriving (Data, Show, Eq, Enum, Bounded, Generic) + deriving (Show, Eq, Enum, Bounded, Generic) -- | See 'Agda.Syntax.Common.Access'. data NameSpaceId = PrivateNS -- ^ Things not exported by this module. | PublicNS -- ^ Things defined and exported by this module. | ImportedNS -- ^ Things from open public, exported by this module. - deriving (Data, Eq, Bounded, Enum, Show, Generic) + deriving (Eq, Bounded, Enum, Show, Generic) allNameSpaces :: [NameSpaceId] allNameSpaces = [minBound..maxBound] @@ -121,7 +121,7 @@ , _scopeFixities :: C.Fixities -- ^ Maps concrete names C.Name to fixities , _scopePolarities :: C.Polarities -- ^ Maps concrete names C.Name to polarities } - deriving (Data, Show, Generic) + deriving (Show, Generic) -- | For the sake of highlighting, the '_scopeInverseName' map also stores -- the 'KindOfName' of an @A.QName@. @@ -129,7 +129,7 @@ { qnameKind :: KindOfName -- ^ The 'anameKind'. , qnameConcrete :: List1 C.QName -- ^ Possible renderings of the abstract name. } - deriving (Data, Show, Generic) + deriving (Show, Generic) -- | Invariant: the 'KindOfName' components should be equal -- whenever we have to concrete renderings of an abstract name. @@ -154,7 +154,7 @@ | PatternBound -- ^ @f ... =@ | LetBound -- ^ @let ... in@ | WithBound -- ^ @| ... in q@ - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) instance Pretty BindingSource where pretty = \case @@ -175,7 +175,7 @@ -- ^ If this list is not empty, the local variable is -- shadowed by one or more imports. } - deriving (Data, Show, Generic) + deriving (Show, Generic) instance Eq LocalVar where (==) = (==) `on` localVar @@ -310,7 +310,7 @@ -- ^ All abstract names targeted by a concrete name in scope. -- Computed by 'recomputeInScopeSets'. } - deriving (Data, Eq, Show, Generic) + deriving (Eq, Show, Generic) type ThingsInScope a = Map C.Name [a] type NamesInScope = ThingsInScope AbstractName @@ -344,7 +344,7 @@ -- | Non-dependent tag for name or module. data NameOrModule = NameNotModule | ModuleNotName - deriving (Data, Eq, Ord, Show, Enum, Bounded, Generic) + deriving (Eq, Ord, Show, Enum, Bounded, Generic) ------------------------------------------------------------------------ -- * Decorated names @@ -375,7 +375,7 @@ | PrimName -- ^ Name of a @primitive@. | OtherDefName -- ^ A @DefName@, but either other kind or don't know which kind. -- End @DefName@. Keep these together in sequence, for sake of @isDefName@! - deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic) + deriving (Eq, Ord, Show, Enum, Bounded, Generic) isDefName :: KindOfName -> Bool isDefName = (>= DataName) @@ -437,7 +437,7 @@ data WithKind a = WithKind { theKind :: KindOfName , kindedThing :: a - } deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable) + } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) -- | Where does a name come from? -- @@ -450,7 +450,7 @@ -- ^ Imported from another module. | Applied C.QName WhyInScope -- ^ Imported by a module application. - deriving (Data, Show, Generic) + deriving (Show, Generic) -- | A decoration of 'Agda.Syntax.Abstract.Name.QName'. data AbstractName = AbsName @@ -464,11 +464,11 @@ -- ^ Additional information needed during scope checking. Currently used -- for generalized data/record params. } - deriving (Data, Show, Generic) + deriving (Show, Generic) data NameMetadata = NoMetadata | GeneralizedVarsMetadata (Map A.QName A.Name) - deriving (Data, Show, Generic) + deriving (Show, Generic) -- | A decoration of abstract syntax module names. data AbstractModule = AbsModule @@ -477,7 +477,7 @@ , amodLineage :: WhyInScope -- ^ Explanation where this name came from. } - deriving (Data, Show, Generic) + deriving (Show, Generic) instance Eq AbstractName where (==) = (==) `on` anameName @@ -524,7 +524,7 @@ | -- | Unbound name. UnknownName - deriving (Data, Show, Eq, Generic) + deriving (Show, Eq, Generic) instance Pretty ResolvedName where pretty = \case @@ -539,6 +539,40 @@ pretty NoSuffix = mempty pretty (Suffix i) = text (show i) +-- | Why is a resolved name ambiguous? What did it resolve to? +-- +-- Invariant (statically enforced): At least two resolvents in total. +data AmbiguousNameReason + = AmbiguousLocalVar LocalVar (List1 AbstractName) + -- ^ The name resolves both to a local variable and some declared names. + | AmbiguousDeclName (List2 AbstractName) + -- ^ The name resolves to at least 2 declared names. + deriving (Show, Generic) + +-- | The flat list of ambiguous names in 'AmbiguousNameReason'. +ambiguousNamesInReason :: AmbiguousNameReason -> List2 (A.QName) +ambiguousNamesInReason = \case + AmbiguousLocalVar (LocalVar y _ _) xs -> List2.cons (A.qualify_ y) $ fmap anameName xs + AmbiguousDeclName xs -> fmap anameName xs + +data WhyInScopeData + = WhyInScopeData + C.QName + -- ^ The name @x@ this explanation is about. + FilePath + -- ^ The directory in which the current module resides. + (Maybe LocalVar) + -- ^ The local variable that @x@ could denote, if any. + [AbstractName] + -- ^ The defined names that @x@ could denote. + [AbstractModule] + -- ^ The modules that @x@ could denote. + +whyInScopeDataFromAmbiguousNameReason :: C.QName -> AmbiguousNameReason -> WhyInScopeData +whyInScopeDataFromAmbiguousNameReason q = \case + AmbiguousLocalVar x ys -> WhyInScopeData q empty (Just x) (toList ys) empty + AmbiguousDeclName ys -> WhyInScopeData q empty Nothing (toList ys) empty + -- * Operations on name and module maps. mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a @@ -725,6 +759,16 @@ mergeNamesMany [ map (, nameSpaceAccess nsId) <$> inNameSpace ns | (nsId, ns) <- scopeNameSpaces s ] +-- | Look up a single name in the current scope. +-- +-- This is equivalent to @Map.lookup n . allNamesInScope'@, but more efficient +-- when only a single name needs to be looked up. +findNameInScope :: InScope a => C.Name -> Scope -> [(a, Access)] +findNameInScope n s = + [ (name, nameSpaceAccess nsId) + | (nsId, ns) <- scopeNameSpaces s + , name <- Map.findWithDefault [] n $ inNameSpace ns ] + -- | Returns the scope's non-private names. exportedNamesInScope :: InScope a => Scope -> ThingsInScope a exportedNamesInScope = namesInScope [PublicNS, ImportedNS] @@ -1031,41 +1075,6 @@ imports = map lookP $ Map.elems $ scopeImports s submods = map (lookP . amodName) $ concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s --- | Compute a flattened scope. Only include unqualified names or names --- qualified by modules in the first argument. -flattenScope :: [[C.Name]] -> ScopeInfo -> Map C.QName [AbstractName] -flattenScope ms scope = - Map.unionWith (++) - (build ms allNamesInScope root) - imported - where - current = moduleScope $ scope ^. scopeCurrent - root = mergeScopes $ current : map moduleScope (scopeParents current) - - imported = Map.unionsWith (++) - [ qual c (build ms' exportedNamesInScope $ moduleScope a) - | (c, a) <- Map.toList $ scopeImports root - , let -- get the suffixes of c in ms - ms' = mapMaybe (List.stripPrefix $ List1.toList $ C.qnameParts c) ms - , not $ null ms' ] - qual c = Map.mapKeys (q c) - where - q (C.QName x) = C.Qual x - q (C.Qual m x) = C.Qual m . q x - - build :: [[C.Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map C.QName [AbstractName] - build ms getNames s = Map.unionsWith (++) $ - Map.mapKeysMonotonic C.QName (getNames s) : - [ Map.mapKeysMonotonic (\ y -> C.Qual x y) $ - build ms' exportedNamesInScope $ moduleScope m - | (x, mods) <- Map.toList (getNames s) - , let ms' = [ tl | hd:tl <- ms, hd == x ] - , not $ null ms' - , AbsModule m _ <- mods ] - - moduleScope :: A.ModuleName -> Scope - moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules - -- | Get all concrete names in scope. Includes bound variables. concreteNamesInScope :: ScopeInfo -> Set C.QName concreteNamesInScope scope = @@ -1086,7 +1095,9 @@ build :: (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName build getNames s = Set.unions $ - Set.fromList (map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) : + Set.fromAscList + (map C.QName $ + Map.keys (getNames s :: ThingsInScope AbstractName)) : [ Set.mapMonotonic (\ y -> C.Qual x y) $ build exportedNamesInScope $ moduleScope m | (x, mods) <- Map.toList (getNames s) @@ -1120,16 +1131,16 @@ -- Find a concrete, possibly qualified name in scope @s@. findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)] findName q0 s = case q0 of - C.QName x -> lookupName x s + C.QName x -> findNameInScope x s C.Qual x q -> do let -- Get the modules named @x@ in scope @s@. mods :: [A.ModuleName] - mods = amodName . fst <$> lookupName x s + mods = amodName . fst <$> findNameInScope x s -- Get the definitions named @x@ in scope @s@ and interpret them as modules. -- Andreas, 2013-05-01: Issue 836 debates this feature: -- Qualified constructors are qualified by their datatype rather than a module defs :: [A.ModuleName] -- NB:: Defined but not used - defs = qnameToMName . anameName . fst <$> lookupName x s + defs = qnameToMName . anameName . fst <$> findNameInScope x s -- Andreas, 2013-05-01: Issue 836 complains about the feature -- that constructors can also be qualified by their datatype -- and projections by their record type. This feature is off @@ -1145,9 +1156,6 @@ -- trace ("ss' = " ++ show ss') $ do s' <- maybeToList ss' findName q s' - where - lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)] - lookupName x s = fromMaybe [] $ Map.lookup x $ allNamesInScope' s -- 2. Finding a name in the top imports. @@ -1438,3 +1446,4 @@ instance NFData NameMetadata instance NFData AbstractModule instance NFData ResolvedName +instance NFData AmbiguousNameReason diff --git a/src/full/Agda/Syntax/Scope/Flat.hs b/src/full/Agda/Syntax/Scope/Flat.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/Scope/Flat.hs @@ -0,0 +1,106 @@ +-- | Flattened scopes. +module Agda.Syntax.Scope.Flat + ( FlatScope + , flattenScope + , getDefinedNames + , localNames + ) where + +import Data.Bifunctor +import Data.Either (partitionEithers) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map + +import qualified Agda.Syntax.Abstract.Name as A +import Agda.Syntax.Concrete +import Agda.Syntax.Notation +import Agda.Syntax.Scope.Base +import Agda.Syntax.Scope.Monad + +import Agda.TypeChecking.Monad.Debug + +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.Pretty + +-- | Flattened scopes. +newtype FlatScope = Flat (Map QName [AbstractName]) + deriving Pretty + +-- | Compute a flattened scope. Only include unqualified names or names +-- qualified by modules in the first argument. +flattenScope :: [[Name]] -> ScopeInfo -> FlatScope +flattenScope ms scope = + Flat $ + Map.unionWith (++) + (build ms allNamesInScope root) + imported + where + current = moduleScope $ scope ^. scopeCurrent + root = mergeScopes $ current : map moduleScope (scopeParents current) + + imported = Map.unionsWith (++) + [ qual c (build ms' exportedNamesInScope $ moduleScope a) + | (c, a) <- Map.toList $ scopeImports root + , let -- get the suffixes of c in ms + ms' = mapMaybe (List.stripPrefix $ List1.toList $ qnameParts c) ms + , not $ null ms' ] + qual c = Map.mapKeysMonotonic (q c) + where + q (QName x) = Qual x + q (Qual m x) = Qual m . q x + + build :: [[Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map QName [AbstractName] + build ms getNames s = Map.unionsWith (++) $ + Map.mapKeysMonotonic QName (getNames s) : + [ Map.mapKeysMonotonic (\ y -> Qual x y) $ + build ms' exportedNamesInScope $ moduleScope m + | (x, mods) <- Map.toList (getNames s) + , let ms' = [ tl | hd:tl <- ms, hd == x ] + , not $ null ms' + , AbsModule m _ <- mods ] + + moduleScope :: A.ModuleName -> Scope + moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules + +-- | Compute all defined names in scope and their fixities/notations. +-- Note that overloaded names (constructors) can have several +-- fixities/notations. Then we 'mergeNotations'. (See issue 1194.) +getDefinedNames :: KindsOfNames -> FlatScope -> [[NewNotation]] +getDefinedNames kinds (Flat names) = + [ mergeNotations $ map (namesToNotation x . A.qnameName . anameName) ds + | (x, ds) <- Map.toList names + , any ((`elemKindsOfNames` kinds) . anameKind) ds + , not (null ds) + ] + -- Andreas, 2013-03-21 see Issue 822 + -- Names can have different kinds, i.e., 'defined' and 'constructor'. + -- We need to consider all names that have *any* matching kind, + -- not only those whose first appearing kind is matching. + +-- | Compute all names (first component) and operators/notations +-- (second component) in scope. +localNames :: FlatScope -> ScopeM ([QName], [NewNotation]) +localNames flat = do + let defs = getDefinedNames allKindsOfNames flat + locals <- nubOn fst . notShadowedLocals <$> getLocalVars + -- Note: Debug printout aligned with the one in + -- Agda.Syntax.Concrete.Operators.buildParsers. + reportS "scope.operators" 50 + [ "flat = " ++ prettyShow flat + , "defs = " ++ prettyShow defs + , "locals= " ++ prettyShow locals + ] + let localNots = map localOp locals + notLocal = not . hasElem (map notaName localNots) . notaName + otherNots = concatMap (filter notLocal) defs + return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots + where + localOp (x, y) = namesToNotation (QName x) y + split = partitionEithers . concatMap opOrNot + opOrNot n = Left (notaName n) : + [Right n | not (null (notation n))] diff --git a/src/full/Agda/Syntax/Scope/Monad.hs b/src/full/Agda/Syntax/Scope/Monad.hs --- a/src/full/Agda/Syntax/Scope/Monad.hs +++ b/src/full/Agda/Syntax/Scope/Monad.hs @@ -51,8 +51,8 @@ import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List -import Agda.Utils.List1 (List1, pattern (:|), nonEmpty) -import Agda.Utils.List2 (List2(List2)) +import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, toList) +import Agda.Utils.List2 (List2(List2), toList) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe @@ -328,11 +328,15 @@ resolveName' :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName resolveName' kinds names x = runExceptT (tryResolveName kinds names x) >>= \case - Left ys -> traceCall (SetRange $ getRange x) $ typeError $ AmbiguousName x ys + Left reason -> do + reportS "scope.resolve" 60 $ unlines $ + "resolveName': ambiguous name" : + map (show . qnameName) (toList $ ambiguousNamesInReason reason) + setCurrentRange x $ typeError $ AmbiguousName x reason Right x' -> return x' tryResolveName - :: (ReadTCState m, HasBuiltins m, MonadError (List1 A.QName) m) + :: forall m. (ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m) => KindsOfNames -- ^ Restrict search to these kinds of names. -> Maybe (Set A.Name) -- ^ Unless 'Nothing', restrict search to match any of these names. -> C.QName -- ^ Name to be resolved @@ -341,13 +345,14 @@ scope <- getScope let vars = AssocList.mapKeysMonotonic C.QName $ scope ^. scopeLocals case lookup x vars of + -- Case: we have a local variable x, but is (perhaps) shadowed by some imports ys. - Just (LocalVar y b ys) -> + Just var@(LocalVar y b ys) -> -- We may ignore the imports filtered out by the @names@ filter. - ifNull (filterNames id ys) - {-then-} (return $ VarName y{ nameConcrete = unqualify x } b) - {-else-} $ \ ys' -> - throwError $ A.qualify_ y :| map anameName ys' + case nonEmpty $ filterNames id ys of + Nothing -> return $ VarName y{ nameConcrete = unqualify x } b + Just ys' -> throwError $ AmbiguousLocalVar var ys' + -- Case: we do not have a local variable x. Nothing -> do -- Consider only names that are in the given set of names and @@ -372,15 +377,19 @@ Just ds | all ((PatternSynName ==) . anameKind . fst) ds , isNothing suffixedNames -> return $ PatternSynResName $ fmap (upd . fst) ds - Just ((d, a) :| []) | isNothing suffixedNames -> - return $ DefinedName a (upd d) A.NoSuffix - - Just ds -> throwError $ fmap (anameName . fst) $ caseMaybe suffixedNames id ((<>) . snd) ds + Just ((d, a) :| ds) -> case (suffixedNames, ds) of + (Nothing, []) -> + return $ DefinedName a (upd d) A.NoSuffix + (Nothing, (d',_) : ds') -> + throwError $ AmbiguousDeclName $ List2 d d' $ map fst ds' + (Just (_, ss), _) -> + throwError $ AmbiguousDeclName $ List2.append (d :| map fst ds) (fmap fst ss) Nothing -> case suffixedNames of Nothing -> return UnknownName Just (suffix , (d, a) :| []) -> return $ DefinedName a (upd d) suffix - Just (suffix , sds) -> throwError $ fmap (anameName . fst) sds + Just (suffix , (d1,_) :| (d2,_) : sds) -> + throwError $ AmbiguousDeclName $ List2 d1 d2 $ map fst sds where -- @names@ intended semantics: a filter on names. @@ -529,7 +538,13 @@ -- later on. rebindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM () rebindName acc kind x y = do - modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x + if kind == ConName + then modifyCurrentScope $ + mapScopeNS (localNameSpace acc) + (Map.update (toList <.> nonEmpty . (filter ((==) ConName . anameKind))) x) + id + id + else modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x bindName acc kind x y -- | Bind a module name. @@ -1004,11 +1019,15 @@ modClashes = filter (\ (_c, as) -> length as >= 2) $ Map.toList $ nsModules exported -- No ambiguity if concrete identifier is only mapped to - -- constructor names or only to projection names. - defClash (_, qs) = not $ all (isJust . isConName) ks || all (==FldName) ks + -- constructor names or only to projection names or only to pattern synonyms. + defClash (_, qs) = not $ or + [ all (isJust . isConName) ks + , all (== FldName) ks + , all (== PatternSynName) ks + ] where ks = map anameKind qs -- We report the first clashing exported identifier. - unlessNull (filter (\ x -> defClash x) defClashes) $ + unlessNull (filter defClash defClashes) $ \ ((x, q:_) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing unlessNull modClashes $ \ ((_, ms) : _) -> do diff --git a/src/full/Agda/Syntax/TopLevelModuleName.hs b/src/full/Agda/Syntax/TopLevelModuleName.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/TopLevelModuleName.hs @@ -0,0 +1,237 @@ +------------------------------------------------------------------------ +-- Top-level module names +------------------------------------------------------------------------ + +module Agda.Syntax.TopLevelModuleName where + +import Control.DeepSeq + +import Data.Function (on) +import Data.Hashable +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text as T + +import GHC.Generics (Generic) + +import System.FilePath + +import qualified Agda.Syntax.Abstract.Name as A +import Agda.Syntax.Common +import qualified Agda.Syntax.Concrete as C +import Agda.Syntax.Position + +import Agda.Utils.BiMap (HasTag(..)) +import Agda.Utils.FileName +import Agda.Utils.Hash +import Agda.Utils.Impossible +import Agda.Utils.Lens +import Agda.Utils.List1 (List1) +import qualified Agda.Utils.List1 as List1 +import Agda.Utils.Pretty +import Agda.Utils.Singleton +import Agda.Utils.Size + +------------------------------------------------------------------------ +-- Raw top-level module names + +-- | A top-level module name has one or more name parts. + +type TopLevelModuleNameParts = List1 Text + +-- | Raw top-level module names (with linear-time comparisons). + +data RawTopLevelModuleName = RawTopLevelModuleName + { rawModuleNameRange :: Range + , rawModuleNameParts :: TopLevelModuleNameParts + } + deriving (Show, Generic) + +instance Eq RawTopLevelModuleName where + (==) = (==) `on` rawModuleNameParts + +instance Ord RawTopLevelModuleName where + compare = compare `on` rawModuleNameParts + +instance Sized RawTopLevelModuleName where + size = size . rawModuleNameParts + +instance Pretty RawTopLevelModuleName where + pretty = text . rawTopLevelModuleNameToString + +instance HasRange RawTopLevelModuleName where + getRange = rawModuleNameRange + +instance SetRange RawTopLevelModuleName where + setRange r (RawTopLevelModuleName _ x) = RawTopLevelModuleName r x + +instance KillRange RawTopLevelModuleName where + killRange (RawTopLevelModuleName _ x) = + RawTopLevelModuleName noRange x + +instance C.IsNoName RawTopLevelModuleName where + isNoName m = rawModuleNameParts m == singleton "_" + +-- | The 'Range' is not forced. + +instance NFData RawTopLevelModuleName where + rnf (RawTopLevelModuleName _ x) = rnf x + +-- | Turns a raw top-level module name into a string. + +rawTopLevelModuleNameToString :: RawTopLevelModuleName -> String +rawTopLevelModuleNameToString = + List.intercalate "." . + map T.unpack . List1.toList . rawModuleNameParts + +-- | Hashes a raw top-level module name. + +hashRawTopLevelModuleName :: RawTopLevelModuleName -> ModuleNameHash +hashRawTopLevelModuleName = + ModuleNameHash . hashString . rawTopLevelModuleNameToString + +-- | Turns a qualified name into a 'RawTopLevelModuleName'. The +-- qualified name is assumed to represent a top-level module name. + +rawTopLevelModuleNameForQName :: C.QName -> RawTopLevelModuleName +rawTopLevelModuleNameForQName q = RawTopLevelModuleName + { rawModuleNameRange = getRange q + , rawModuleNameParts = + fmap (T.pack . C.nameToRawName) $ C.qnameParts q + } + +-- | Computes the 'RawTopLevelModuleName' corresponding to the given +-- module name, which is assumed to represent a top-level module name. +-- +-- Precondition: The module name must be well-formed. + +rawTopLevelModuleNameForModuleName :: + A.ModuleName -> RawTopLevelModuleName +rawTopLevelModuleNameForModuleName (A.MName []) = __IMPOSSIBLE__ +rawTopLevelModuleNameForModuleName (A.MName ms) = + List1.ifNull ms __IMPOSSIBLE__ $ \ms -> + RawTopLevelModuleName + { rawModuleNameRange = getRange ms + , rawModuleNameParts = + fmap (T.pack . C.nameToRawName . A.nameConcrete) ms + } + +-- | Computes the top-level module name. +-- +-- Precondition: The 'C.Module' has to be well-formed. +-- This means that there are only allowed declarations before the +-- first module declaration, typically import declarations. +-- See 'spanAllowedBeforeModule'. + +rawTopLevelModuleNameForModule :: C.Module -> RawTopLevelModuleName +rawTopLevelModuleNameForModule (C.Mod _ []) = __IMPOSSIBLE__ +rawTopLevelModuleNameForModule (C.Mod _ ds) = + case C.spanAllowedBeforeModule ds of + (_, C.Module _ n _ _ : _) -> rawTopLevelModuleNameForQName n + _ -> __IMPOSSIBLE__ + +------------------------------------------------------------------------ +-- Top-level module names + +-- | Top-level module names (with constant-time comparisons). + +data TopLevelModuleName = TopLevelModuleName + { moduleNameRange :: Range + , moduleNameId :: {-# UNPACK #-} !ModuleNameHash + , moduleNameParts :: TopLevelModuleNameParts + } + deriving (Show, Generic) + +instance HasTag TopLevelModuleName where + type Tag TopLevelModuleName = ModuleNameHash + tag = Just . moduleNameId + +instance Eq TopLevelModuleName where + (==) = (==) `on` moduleNameId + +instance Ord TopLevelModuleName where + compare = compare `on` moduleNameId + +instance Hashable TopLevelModuleName where + hashWithSalt salt = hashWithSalt salt . moduleNameId + +instance Sized TopLevelModuleName where + size = size . rawTopLevelModuleName + +instance Pretty TopLevelModuleName where + pretty = pretty . rawTopLevelModuleName + +instance HasRange TopLevelModuleName where + getRange = moduleNameRange + +instance SetRange TopLevelModuleName where + setRange r (TopLevelModuleName _ h x) = TopLevelModuleName r h x + +instance KillRange TopLevelModuleName where + killRange (TopLevelModuleName _ h x) = TopLevelModuleName noRange h x + +-- | The 'Range' is not forced. + +instance NFData TopLevelModuleName where + rnf (TopLevelModuleName _ x y) = rnf (x, y) + +-- | A lens focusing on the 'moduleNameParts'. + +lensTopLevelModuleNameParts :: + Lens' TopLevelModuleNameParts TopLevelModuleName +lensTopLevelModuleNameParts f m = + f (moduleNameParts m) <&> \ xs -> m{ moduleNameParts = xs } + +-- | Converts a top-level module name to a raw top-level module name. + +rawTopLevelModuleName :: TopLevelModuleName -> RawTopLevelModuleName +rawTopLevelModuleName m = RawTopLevelModuleName + { rawModuleNameRange = moduleNameRange m + , rawModuleNameParts = moduleNameParts m + } + +-- | Converts a raw top-level module name and a hash to a top-level +-- module name. +-- +-- This function does not ensure that there are no hash collisions, +-- that is taken care of by +-- 'Agda.TypeChecking.Monad.State.topLevelModuleName'. + +unsafeTopLevelModuleName :: + RawTopLevelModuleName -> ModuleNameHash -> TopLevelModuleName +unsafeTopLevelModuleName m h = TopLevelModuleName + { moduleNameRange = rawModuleNameRange m + , moduleNameParts = rawModuleNameParts m + , moduleNameId = h + } + +-- | A corresponding 'C.QName'. The range of each 'Name' part is the +-- whole range of the 'TopLevelModuleName'. + +topLevelModuleNameToQName :: TopLevelModuleName -> C.QName +topLevelModuleNameToQName m = + List1.foldr C.Qual C.QName $ + fmap (C.Name (getRange m) C.NotInScope . + C.stringNameParts . T.unpack) $ + moduleNameParts m + +-- | Turns a top-level module name into a file name with the given +-- suffix. + +moduleNameToFileName :: TopLevelModuleName -> String -> FilePath +moduleNameToFileName TopLevelModuleName{ moduleNameParts = ms } ext = + joinPath (map T.unpack $ List1.init ms) + T.unpack (List1.last ms) <.> ext + +-- | Finds the current project's \"root\" directory, given a project +-- file and the corresponding top-level module name. +-- +-- Example: If the module \"A.B.C\" is located in the file +-- \"/foo/A/B/C.agda\", then the root is \"/foo/\". +-- +-- Precondition: The module name must be well-formed. + +projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath +projectRoot file TopLevelModuleName{ moduleNameParts = m } = + mkAbsolute $ + iterate takeDirectory (filePath file) !! length m diff --git a/src/full/Agda/Syntax/TopLevelModuleName.hs-boot b/src/full/Agda/Syntax/TopLevelModuleName.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/TopLevelModuleName.hs-boot @@ -0,0 +1,13 @@ +module Agda.Syntax.TopLevelModuleName where + +import Control.DeepSeq + +import {-# SOURCE #-} Agda.Syntax.Position (KillRange) + +data TopLevelModuleName + +instance Eq TopLevelModuleName +instance Ord TopLevelModuleName +instance Show TopLevelModuleName +instance NFData TopLevelModuleName +instance KillRange TopLevelModuleName 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 @@ -36,15 +36,15 @@ import qualified Data.Map as Map import Data.Maybe -import Data.Monoid +import Data.Monoid hiding ((<>)) import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Foldable as Fold import Data.Void import Data.List (sortBy) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty +import Data.Semigroup (Semigroup, (<>)) +import Data.String import Agda.Syntax.Common import Agda.Syntax.Position @@ -64,8 +64,13 @@ import Agda.TypeChecking.Monad.State (getScope, getAllPatternSyns) import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Builtin +import Agda.TypeChecking.Monad.MetaVars +import Agda.TypeChecking.Monad.Pure +import Agda.TypeChecking.Monad.Signature +import {-# SOURCE #-} Agda.TypeChecking.Pretty (prettyTCM) import Agda.Interaction.Options import qualified Agda.Utils.AssocList as AssocList @@ -79,7 +84,7 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null -import Agda.Utils.Pretty +import Agda.Utils.Pretty hiding ((<>)) import Agda.Utils.Singleton import Agda.Utils.Suffix @@ -91,7 +96,7 @@ -- ^ Abstract names currently in scope. Unlike the -- ScopeInfo, this includes names for hidden -- arguments inserted by the system. - , takenDefNames :: Set C.Name + , takenDefNames :: Set C.NameParts -- ^ Concrete names of all definitions in scope , currentScope :: ScopeInfo , builtins :: Map String A.QName @@ -132,15 +137,21 @@ , foldPatternSynonyms = foldPatSyns } where + defs = Set.map nameParts . Map.keysSet $ + Map.filterWithKey usefulDef $ + nsNames $ everythingInScope scope + -- Jesper, 2018-12-10: It's fine to shadow generalizable names as -- they will never show up directly in printed terms. notGeneralizeName AbsName{ anameKind = k } = not (k == GeneralizeName || k == DisallowedGeneralizeName) - defs = Map.keysSet $ - Map.filter (all notGeneralizeName) $ - nsNames $ everythingInScope scope + usefulDef C.NoName{} _ = False + usefulDef C.Name{} names = all notGeneralizeName names + nameParts (C.NoName {}) = __IMPOSSIBLE__ + nameParts (C.Name { nameNameParts }) = nameNameParts + currentPrecedence :: AbsToCon PrecedenceStack currentPrecedence = asks $ (^. scopePrecedence) . currentScope @@ -179,7 +190,7 @@ where is m q b = Just q == Map.lookup b m -- | Resolve a concrete name. If illegally ambiguous fail with the ambiguous names. -resolveName :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> AbsToCon (Either (NonEmpty A.QName) ResolvedName) +resolveName :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> AbsToCon (Either AmbiguousNameReason ResolvedName) resolveName kinds candidates q = runExceptT $ tryResolveName kinds candidates q -- | Treat illegally ambiguous names as UnknownNames. @@ -188,20 +199,17 @@ -- The Monad -------------------------------------------------------------- --- | We need: --- - Read access to the AbsToCon environment --- - Read access to the TC environment --- - Read access to the TC state --- - Read and write access to the stConcreteNames part of the TC state --- - Read access to the options --- - Permission to print debug messages +-- | The function 'runAbsToCon' can target any monad that satisfies +-- the constraints of 'MonadAbsToCon'. type MonadAbsToCon m = - ( MonadTCEnv m - , ReadTCState m + ( MonadFresh NameId m + , MonadInteractionPoints m , MonadStConcreteNames m , HasOptions m - , HasBuiltins m - , MonadDebug m + , PureTCM m + , IsString (m Doc) + , Null (m Doc) + , Semigroup (m Doc) ) newtype AbsToCon a = AbsToCon @@ -261,10 +269,48 @@ traceDebugMessage k n s cont = AbsToCon $ traceDebugMessage k n s $ unAbsToCon cont -- can't eta-reduce! verboseBracket k n s cont = AbsToCon $ verboseBracket k n s $ unAbsToCon cont -- because of GHC-9.0 - getVerbosity = defaultGetVerbosity - isDebugPrinting = defaultIsDebugPrinting - nowDebugPrinting = defaultNowDebugPrinting + getVerbosity = defaultGetVerbosity + getProfileOptions = defaultGetProfileOptions + isDebugPrinting = defaultIsDebugPrinting + nowDebugPrinting = defaultNowDebugPrinting +instance HasConstInfo AbsToCon where + getConstInfo' a = AbsToCon (getConstInfo' a) + getRewriteRulesFor a = AbsToCon (getRewriteRulesFor a) + +instance MonadAddContext AbsToCon where + addCtx a b c = AbsToCon (addCtx a b (unAbsToCon c)) + + addLetBinding' a b c d = + AbsToCon (addLetBinding' a b c (unAbsToCon d)) + + updateContext a b c = AbsToCon (updateContext a b (unAbsToCon c)) + + withFreshName a b c = + AbsToCon (withFreshName a b (\x -> unAbsToCon (c x))) + +instance MonadReduce AbsToCon where + liftReduce a = AbsToCon (liftReduce a) + +instance PureTCM AbsToCon where + +instance MonadFresh NameId AbsToCon where + fresh = AbsToCon fresh + +instance MonadInteractionPoints AbsToCon where + freshInteractionId = AbsToCon freshInteractionId + modifyInteractionPoints a = AbsToCon (modifyInteractionPoints a) + +instance IsString (AbsToCon Doc) where + fromString a = AbsToCon (fromString a) + +instance Null (AbsToCon Doc) where + empty = AbsToCon empty + null = __IMPOSSIBLE__ + +instance Semigroup (AbsToCon Doc) where + a <> b = AbsToCon (unAbsToCon a <> unAbsToCon b) + runAbsToCon :: MonadAbsToCon m => AbsToCon c -> m c runAbsToCon m = do scope <- getScope @@ -362,7 +408,9 @@ -- | For the given abstract name, return the names that could shadow it. shadowingNames :: (ReadTCState m, MonadStConcreteNames m) => A.Name -> m (Set RawName) -shadowingNames x = Set.fromList . Map.findWithDefault [] x <$> useR stShadowingNames +shadowingNames x = + Set.fromList . Fold.toList . Map.findWithDefault mempty x <$> + useR stShadowingNames toConcreteName :: A.Name -> AbsToCon C.Name toConcreteName x | y <- nameConcrete x , isNoName y = return y @@ -399,13 +447,21 @@ return $ nameConcrete x -- Otherwise we pick a name that does not shadow other names _ -> do + takenDefs <- asks takenDefNames taken <- takenNames toAvoid <- shadowingNames x glyphMode <- optUseUnicode <$> pragmaOptions let freshNameMode = case glyphMode of UnicodeOk -> A.UnicodeSubscript AsciiOnly -> A.AsciiCounter - let shouldAvoid = (`Set.member` (taken `Set.union` toAvoid)) . C.nameToRawName + + shouldAvoid C.NoName {} = False + shouldAvoid name@C.Name { nameNameParts } = + let raw = C.nameToRawName name in + nameNameParts `Set.member` takenDefs || + raw `Set.member` taken || + raw `Set.member` toAvoid + y = firstNonTakenName freshNameMode shouldAvoid $ nameConcrete x reportSLn "toConcrete.bindName" 80 $ render $ vcat [ "picking concrete name for:" <+> text (C.nameToRawName $ nameConcrete x) @@ -418,11 +474,10 @@ where takenNames :: AbsToCon (Set RawName) takenNames = do - xs <- asks takenDefNames ys0 <- asks takenVarNames reportSLn "toConcrete.bindName" 90 $ render $ "abstract names of local vars: " <+> prettyList_ (map (C.nameToRawName . nameConcrete) $ Set.toList ys0) ys <- Set.fromList . concat <$> mapM hasConcreteNames (Set.toList ys0) - return $ Set.map C.nameToRawName $ xs `Set.union` ys + return $ Set.map C.nameToRawName ys -- | Add a abstract name to the scope and produce an available concrete version of it. @@ -680,9 +735,9 @@ toConcrete = \case VarName x _ -> C.QName <$> toConcrete x DefinedName _ x s -> addSuffixConcrete s $ toConcrete x - FieldName xs -> toConcrete (NonEmpty.head xs) - ConstructorName _ xs -> toConcrete (NonEmpty.head xs) - PatternSynResName xs -> toConcrete (NonEmpty.head xs) + FieldName xs -> toConcrete (List1.head xs) + ConstructorName _ xs -> toConcrete (List1.head xs) + PatternSynResName xs -> toConcrete (List1.head xs) UnknownName -> __IMPOSSIBLE__ addSuffixConcrete :: HasOptions m => A.Suffix -> m C.QName -> m C.QName @@ -727,9 +782,10 @@ return $ C.QuestionMark (getRange i) $ interactionId ii <$ guard (preserve || isJust (metaNumber i)) - toConcrete (A.Underscore i) = return $ - C.Underscore (getRange i) $ - prettyShow . NamedMeta (metaNameSuggestion i) . MetaId . metaId <$> metaNumber i + toConcrete (A.Underscore i) = + C.Underscore (getRange i) <$> + traverse (render <.> prettyTCM) + (NamedMeta (metaNameSuggestion i) <$> metaNumber i) toConcrete (A.Dot i e) = C.Dot (getRange i) <$> toConcrete e @@ -826,7 +882,7 @@ reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps return $ LamClause ps rhs ca decl2clause _ = __IMPOSSIBLE__ - C.ExtendedLam (getRange i) erased . List1.fromList <$> + C.ExtendedLam (getRange i) erased . List1.fromListSafe __IMPOSSIBLE__ <$> mapM decl2clause decls -- TODO List1: can we demonstrate non-emptiness? @@ -875,8 +931,6 @@ bracket appBrackets $ do C.RecUpdate (getRange i) <$> toConcrete e <*> toConcreteTop fs - toConcrete (A.ETel tel) = C.ETel . catMaybes <$> toConcrete tel - toConcrete (A.ScopedExpr _ e) = toConcrete e toConcrete (A.Quote i) = return $ C.Quote (getRange i) toConcrete (A.QuoteTerm i) = return $ C.QuoteTerm (getRange i) @@ -892,7 +946,7 @@ makeDomainFree b@(A.DomainFull (A.TBind _ tac (x :| []) t)) = case unScope t of A.Underscore A.MetaInfo{metaNumber = Nothing} -> - A.DomainFree tac x + A.DomainFree (tbTacticAttr tac) x _ -> b makeDomainFree b = b @@ -946,10 +1000,10 @@ type ConOfAbs A.TypedBinding = Maybe C.TypedBinding bindToConcrete (A.TBind r t xs e) ret = do - t <- traverse toConcrete t + tac <- traverse toConcrete (tbTacticAttr t) bindToConcrete (fmap forceNameIfHidden xs) $ \ xs -> do e <- toConcreteTop e - let setTac x = x { bnameTactic = t } + let setTac x = x { bnameTactic = tac , C.bnameIsFinite = tbFinite t } ret $ Just $ C.TBind r (fmap (updateNamedArg (fmap setTac)) xs) e bindToConcrete (A.TLet r lbs) ret = bindToConcrete lbs $ \ ds -> do @@ -992,15 +1046,15 @@ instance ToConcrete A.WhereDeclarations where type ConOfAbs A.WhereDeclarations = WhereClause - bindToConcrete (A.WhereDecls _ Nothing) ret = ret C.NoWhere - bindToConcrete (A.WhereDecls (Just am) (Just (A.Section _ _ _ ds))) ret = do + bindToConcrete (A.WhereDecls _ _ Nothing) ret = ret C.NoWhere + bindToConcrete (A.WhereDecls (Just am) False (Just (A.Section _ _ _ ds))) ret = do ds' <- declsToConcrete ds cm <- unqualify <$> lookupModule am -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere -- Should not really matter for printing... let wh' = (if isNoName cm then AnyWhere noRange else SomeWhere noRange cm PublicAccess) $ ds' local (openModule' am defaultImportDir id) $ ret wh' - bindToConcrete (A.WhereDecls _ (Just d)) ret = + bindToConcrete (A.WhereDecls _ _ (Just d)) ret = ret . AnyWhere noRange =<< toConcrete d mergeSigAndDef :: [C.Declaration] -> [C.Declaration] @@ -1223,7 +1277,9 @@ xs <- mapM (unqual <=< toConcrete) xs (:[]) . C.UnquoteDef (getRange i) xs <$> toConcrete e + toConcrete (A.UnquoteData i xs uc j cs e) = __IMPOSSIBLE__ + data RangeAndPragma = RangeAndPragma Range A.Pragma instance ToConcrete RangeAndPragma where @@ -1240,6 +1296,7 @@ A.StaticPragma x -> C.StaticPragma r <$> toConcrete x A.InjectivePragma x -> C.InjectivePragma r <$> toConcrete x A.InlinePragma b x -> C.InlinePragma r b <$> toConcrete x + A.NotProjectionLikePragma q -> C.NotProjectionLikePragma r <$> toConcrete q 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 @@ -1776,5 +1833,5 @@ instance ToConcrete NamedMeta where type ConOfAbs NamedMeta = C.Expr - toConcrete i = do - return $ C.Underscore noRange (Just $ prettyShow i) + toConcrete i = + C.Underscore noRange . Just . render <$> prettyTCM i 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 @@ -15,6 +15,7 @@ , NewName, OldQName , PatName, APatName , importPrimitives + , checkCohesionAttributes ) where import Prelude hiding ( null ) @@ -29,15 +30,14 @@ import Data.Map (Map) import Data.Functor (void) import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import qualified Data.Map as Map import Data.Maybe import Data.Monoid (First(..)) import Data.Void -import Agda.Syntax.Concrete as C hiding (topLevelModuleName) +import Agda.Syntax.Concrete as C +import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Concrete.Generic import Agda.Syntax.Concrete.Operators import Agda.Syntax.Concrete.Pattern @@ -58,11 +58,13 @@ import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs) import Agda.Syntax.DoNotation import Agda.Syntax.IdiomBrackets +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo) import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange) -import Agda.TypeChecking.Monad.State +import Agda.TypeChecking.Monad.State hiding (topLevelModuleName) +import qualified Agda.TypeChecking.Monad.State as S import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint) import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath) @@ -174,7 +176,11 @@ buildType :: [C.NiceDeclaration] -> ScopeM A.Expr -- TODO: Telescope instead of Expr in abstract RecDef buildType ds = do - dummy <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet + -- The constructor target type is computed in the type checker. + -- For now, we put a dummy expression there. + -- Andreas, 2022-10-06, issue #6165: + -- The dummy was builtinSet, but this might not be defined yet. + let dummy = A.Lit empty $ LitString "TYPE" tel <- catMaybes <$> mapM makeBinding ds return $ A.mkPi (ExprRange (getRange ds)) tel dummy @@ -183,7 +189,7 @@ let failure = typeError $ NotValidBeforeField d r = getRange d mkLet d = Just . A.TLet r <$> toAbstract (LetDef d) - traceCall (SetRange r) $ case d of + setCurrentRange r $ case d of C.NiceField r pr ab inst tac x a -> do fx <- getConcreteFixity x @@ -225,6 +231,7 @@ C.NiceGeneralize{} -> failure C.NiceUnquoteDecl{} -> failure C.NiceUnquoteDef{} -> failure + C.NiceUnquoteData{} -> failure checkModuleApplication :: C.ModuleApplication @@ -608,8 +615,8 @@ q -> return q data APatName = VarPatName A.Name - | ConPatName (NonEmpty AbstractName) - | PatternSynPatName (NonEmpty AbstractName) + | ConPatName (List1 AbstractName) + | PatternSynPatName (List1 AbstractName) instance ToAbstract PatName where type AbsOfCon PatName = APatName @@ -667,9 +674,9 @@ DefinedName _ d NoSuffix -> return $ anameName d DefinedName _ d Suffix{} -> notInScopeError (toQName x) -- We can get the cases below for DISPLAY pragmas - ConstructorName _ ds -> return $ anameName (NonEmpty.head ds) -- We'll throw out this one, so it doesn't matter which one we pick - FieldName ds -> return $ anameName (NonEmpty.head ds) - PatternSynResName ds -> return $ anameName (NonEmpty.head ds) + ConstructorName _ ds -> return $ anameName (List1.head ds) -- We'll throw out this one, so it doesn't matter which one we pick + FieldName ds -> return $ anameName (List1.head ds) + PatternSynResName ds -> return $ anameName (List1.head ds) VarName x _ -> genericError $ "Not a defined name: " ++ prettyShow x UnknownName -> notInScopeError (toQName x) @@ -835,7 +842,7 @@ setScope si -- This turns into an A.ScopedExpr si $ A.ExtendedLam... return $ A.ExtendedLam (ExprRange r) di erased qname' $ - List1.fromList cs + List1.fromListSafe __IMPOSSIBLE__ cs _ -> __IMPOSSIBLE__ -- | Raise an error if argument is a C.Dot with Hiding info. @@ -1013,7 +1020,6 @@ C.Absurd _ -> notAnExpression e -- Impossible things - C.ETel _ -> __IMPOSSIBLE__ C.Equal{} -> genericError "Parse error: unexpected '='" C.Ellipsis _ -> genericError "Parse error: unexpected '...'" C.DoubleDot _ _ -> genericError "Parse error: unexpected '..'" @@ -1091,13 +1097,16 @@ toAbstract (C.TBind r xs t) = do t' <- toAbstractCtx TopCtx t tac <- traverse toAbstract $ - case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of - [] -> Nothing - tac : _ -> Just tac - -- Invariant: all tactics are the same - -- (distributed in the parser, TODO: don't) + -- Invariant: all tactics are the same + -- (distributed in the parser, TODO: don't) + case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of + [] -> Nothing + tac : _ -> Just tac + + let fin = all (bnameIsFinite . C.binderName . namedArg) xs xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs - return $ Just $ A.TBind r tac xs' t' + + return $ Just $ A.TBind r (TypedBindingInfo tac fin) xs' t' toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ds) -- | Scope check a module (top level function). @@ -1246,7 +1255,7 @@ data TopLevel a = TopLevel { topLevelPath :: AbsolutePath -- ^ The file path from which we loaded this module. - , topLevelExpectedName :: C.TopLevelModuleName + , topLevelExpectedName :: TopLevelModuleName -- ^ The expected module name -- (coming from the import statement that triggered scope checking this file). , topLevelTheThing :: a @@ -1278,13 +1287,13 @@ -- If there are declarations after the top-level module -- we have to report a parse error here. - (_, C.Module{} : d : _) -> traceCall (SetRange $ getRange d) $ + (_, C.Module{} : d : _) -> setCurrentRange d $ genericError $ "No declarations allowed after top-level module." -- Otherwise, proceed. (outsideDecls, [ C.Module r m0 tel insideDecls ]) -> do -- If the module name is _ compute the name from the file path - m <- if isNoName m0 + (m, top) <- if isNoName m0 then do -- Andreas, 2017-07-28, issue #1077 -- Check if the insideDecls end in a single module which has the same @@ -1296,7 +1305,8 @@ -- report an error. case flip span insideDecls $ \case { C.Module{} -> False; _ -> True } of (ds0, (C.Module _ m1 _ _ : _)) - | C.toTopLevelModuleName m1 == expectedMName + | rawTopLevelModuleNameForQName m1 == + rawTopLevelModuleName expectedMName -- If the anonymous module comes from the user, -- the range cannot be the beginningOfFile. -- That is the range if the parser inserted the anon. module. @@ -1309,12 +1319,17 @@ void $ toAbstract (Declarations outsideDecls) void $ toAbstract (Declarations ds0) -- Fail with a crude error otherwise - traceCall (SetRange $ getRange ds0) $ genericError + setCurrentRange ds0 $ genericError "Illegal declaration(s) before top-level module" -- Otherwise, reconstruct the top-level module name - _ -> return $ C.QName $ setRange (getRange m0) $ - C.simpleName $ stringToRawName $ rootNameModule file + _ -> do + let m = C.QName $ setRange (getRange m0) $ + C.simpleName $ stringToRawName $ + rootNameModule file + top <- S.topLevelModuleName + (rawTopLevelModuleNameForQName m) + return (m, top) -- Andreas, 2017-05-17, issue #2574, keep name as jump target! -- Andreas, 2016-07-12, ALTERNATIVE: -- -- We assign an anonymous file module the name expected from @@ -1329,9 +1344,11 @@ -- We need to check the module name against the file name here. -- Otherwise one could sneak in a lie and confuse the scope -- checker. - checkModuleName (C.toTopLevelModuleName m0) (SourceFile file) $ Just expectedMName - return m0 - setTopLevelModule m + top <- S.topLevelModuleName + (rawTopLevelModuleNameForQName m0) + checkModuleName top (SourceFile file) (Just expectedMName) + return (m0, top) + setTopLevelModule top am <- toAbstract (NewModuleQName m) primitiveImport <- importPrimitives -- Scope check the declarations outside @@ -1472,6 +1489,7 @@ C.RewritePragma{} -> Nothing -- @CompilePragma@ already handled in the nicifier C.CompilePragma{} -> Nothing + C.NotProjectionLikePragma{} -> Nothing newtype LetDefs = LetDefs (List1 C.Declaration) @@ -1719,7 +1737,9 @@ -- Definitions (possibly mutual) NiceMutual r 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' ] @@ -1925,7 +1945,7 @@ dir <- notPublicWithoutOpen open dir -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name. - let illformedAs s = traceCall (SetRange $ getRange as) $ do + let illformedAs s = setCurrentRange as $ do -- If @as@ is followed by something that is not a simple name, -- throw a warning and discard the as-clause. Nothing <$ warning (IllformedAsClause s) @@ -1938,16 +1958,18 @@ Just (AsName (Left (C.Ident C.Qual{})) r) -> illformedAs "; a qualified name is not allowed here" Just (AsName (Left e) r) -> illformedAs "" + top <- S.topLevelModuleName (rawTopLevelModuleNameForQName x) -- First scope check the imported module and return its name and -- interface. This is done with that module as the top-level module. -- This is quite subtle. We rely on the fact that when setting the -- top-level module and generating a fresh module name, the generated -- name will be exactly the same as the name generated when checking -- the imported module. - (m, i) <- withCurrentModule noModuleName $ withTopLevelModule x $ do + (m, i) <- withCurrentModule noModuleName $ + withTopLevelModule top $ do m <- toAbstract $ NewModuleQName x -- (No longer erases the contents of @m@.) printScope "import" 10 "before import:" - (m, i) <- scopeCheckImport m + (m, i) <- scopeCheckImport top m printScope "import" 10 $ "scope checked import: " ++ prettyShow i -- We don't want the top scope of the imported module (things happening -- before the module declaration) @@ -2039,6 +2061,34 @@ zipWithM_ (rebindName p OtherDefName) xs ys return [ A.UnquoteDef [ mkDefInfo x fx PublicAccess a r | (fx, x) <- zip fxs xs ] ys e ] + NiceUnquoteData r p a pc uc x cs e -> do + fx <- getConcreteFixity x + x' <- freshAbstractQName fx x + bindName p QuotableName x x' + + -- Create the module for the qualified constructors + checkForModuleClash x + let m = qnameToMName x' + createModule (Just IsDataModule) m + bindModule p x m -- make it a proper module + + cs' <- mapM (bindUnquoteConstructorName m p) cs + + e <- withCurrentModule m $ toAbstract e + + rebindName p DataName x x' + zipWithM_ (rebindName p ConName) cs cs' + withCurrentModule m $ zipWithM_ (rebindName p ConName) cs cs' + + fcs <- mapM getConcreteFixity cs + let mi = MutualInfo TerminationCheck YesCoverageCheck pc r + return + [ A.Mutual + mi [A.UnquoteData + [ mkDefInfo x fx p a r ] x' uc + [ mkDefInfo c fc p a r | (fc, c) <- zip fcs cs] cs' e ] + ] + NicePatternSyn r a n as p -> do reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ prettyShow n (as, p) <- withLocalVars $ do @@ -2237,6 +2287,25 @@ AbstractDef -> PrivateAccess Inserted _ -> p +bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> TCM A.QName +bindUnquoteConstructorName m p c = do + + r <- resolveName (C.QName c) + fc <- getConcreteFixity c + c' <- withCurrentModule m $ freshAbstractQName fc c + let aname qn = AbsName qn QuotableName Defined NoMetadata + addName = modifyCurrentScope $ addNameToScope (localNameSpace p) c $ aname c' + success = addName >> (withCurrentModule m $ addName) + 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" + return c' + instance ToAbstract DataConstrDecl where type AbsOfCon DataConstrDecl = A.Declaration @@ -2326,6 +2395,15 @@ sINLINE ++ " used on ambiguous name " ++ prettyShow x _ -> genericError $ "Target of " ++ sINLINE ++ " pragma should be a function" return [ A.InlinePragma b y ] + toAbstract (C.NotProjectionLikePragma _ x) = do + e <- toAbstract $ OldQName x Nothing + y <- case e of + A.Def x -> return x + A.Proj _ p | Just x <- getUnambiguous p -> return x + A.Proj _ x -> genericError $ + "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.BuiltinPragma _ rb qx) | isUntypedBuiltin b = do q <- toAbstract $ ResolveQName qx @@ -2524,7 +2602,7 @@ void $ -- We can ignore the returned default A.ImportDirective. openModule TopOpenModule (Just am) (C.QName m) $ defaultImportDir { publicOpen = Just noRange } - return (x, A.WhereDecls (am <$ whname) $ singleton d) + return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d) data TerminationOrPositivity = Termination | Positivity deriving (Show) @@ -2963,9 +3041,9 @@ -- Get the notation for the operator. nota <- getNotation op ns let parts = notation nota - -- We can throw away the @BindingHoles@, since binders + -- We can throw away the @VarPart@s, since binders -- have been preprocessed into @OpApp C.Expr@. - let nonBindingParts = filter (not . isBindingHole) parts + let nonBindingParts = filter (not . isBinder) parts -- We should be left with as many holes as we have been given args @es@. -- If not, crash. unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__ @@ -3042,6 +3120,20 @@ set :: a -> NamedArg b -> NamedArg a set x arg = fmap (fmap (const x)) arg +-- | Raises an error if the list of cohesion attributes is non-empty +-- and cohesion modalities are not supported. + +checkCohesionAttributes :: CohesionAttributes -> ScopeM () +checkCohesionAttributes attrs = + unlessM (optCohesion <$> pragmaOptions) $ + case attrs of + [] -> return () + (s, r) : _ -> + setCurrentRange r $ + typeError $ GenericDocError $ P.fsep $ + P.pwords "Cohesion modalities have not been enabled" ++ + P.pwords "(use --cohesion to enable them):" ++ + [P.text s] {-------------------------------------------------------------------------- Things we parse but are not part of the Agda file syntax 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 @@ -177,9 +177,9 @@ type ReifiesTo MetaId = Expr reifyWhen = reifyWhenE - reify x@(MetaId n) = do + reify x = do b <- asksTC envPrintMetasBare - mi <- mvInfo <$> lookupMeta x + mi <- mvInfo <$> lookupLocalMeta x let mi' = Info.MetaInfo { metaRange = getRange $ miClosRange mi , metaScope = clScope $ miClosRange mi @@ -435,9 +435,11 @@ reifyTerm expandAnonDefs0 v0 = do -- Jesper 2018-11-02: If 'PrintMetasBare', drop all meta eliminations. metasBare <- asksTC envPrintMetasBare + reportSDoc "reify.term" 80 $ pure $ "reifyTerm v0 = " <+> pretty v0 v <- instantiate v0 >>= \case I.MetaV x _ | metasBare -> return $ I.MetaV x [] v -> return v + reportSDoc "reify.term" 80 $ pure $ "reifyTerm v = " <+> pretty v -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled -- (i.e. when we don't care about nice printing) expandAnonDefs <- return expandAnonDefs0 `and2M` displayFormsEnabled @@ -445,6 +447,7 @@ -- 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 -- Hack to print generalized field projections with nicer names. Should -- only show up in errors. Check the spined form! @@ -528,11 +531,15 @@ I.Level l -> reify l I.Pi a b -> case b of NoAbs _ b' - | visible a -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b') + | visible a, not (domIsFinite a) -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b') -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi -- since (a) the syntax {A} -> B or {{A}} -> B is not legal -- and (b) the name of the binder might matter. -- See issue 951 (a) and 952 (b). + -- + -- Amy, 2022-09-05: Can't be finite either, since otherwise + -- we say ".(IsOne φ) → A ≠ .(IsOne φ) → A" with no + -- indication of which is finite and which isn't | otherwise -> mkPi b =<< reify a b -> mkPi b =<< do ifM (domainFree a (absBody b)) @@ -543,7 +550,9 @@ tac <- traverse reify $ domTactic a (x, b) <- reify b let xs = singleton $ Arg info $ Named (domName a) $ mkBinder_ x - return $ A.Pi noExprInfo (singleton $ TBind noRange tac xs a') b + return $ A.Pi noExprInfo + (singleton $ TBind noRange (TypedBindingInfo tac (domIsFinite a)) xs a') + b -- We can omit the domain type if it doesn't have any free variables -- and it's mentioned in the target type. domainFree a b = do @@ -556,7 +565,7 @@ es' <- reify es - mv <- lookupMeta x + mv <- lookupLocalMeta x (msub1,meta_tel,msub2) <- do local_chkpt <- viewTC eCurrentCheckpoint (chkpt, tel, msub2) <- enterClosure mv $ \ _ -> @@ -689,7 +698,7 @@ alreadyPrinting <- viewTC ePrintingPatternLambdas extLam <- case def of - Function{ funExtLam = Just{}, funProjection = Just{} } -> __IMPOSSIBLE__ + Function{ funExtLam = Just{}, funProjection = Right{} } -> __IMPOSSIBLE__ Function{ funExtLam = Just (ExtLamInfo m b sys) } -> Just . (,Strict.toLazy sys) . size <$> lookupSection m _ -> return Nothing @@ -703,7 +712,7 @@ _ -> do (pad, nes :: [Elim' (Named_ Term)]) <- case def of - Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do + Function{ funProjection = Right Projection{ projIndex = np } } | np > 0 -> do reportSLn "reify.def" 70 $ " def. is a projection with projIndex = " ++ show np -- This is tricky: @@ -795,7 +804,7 @@ :: MonadReify m => QName -> ArgInfo -> Int -> Maybe System -> [I.Clause] -> I.Elims -> m Expr - reifyExtLam x i npars msys cls es = do + reifyExtLam x ai npars msys cls es = do reportSLn "reify.def" 10 $ "reifying extended lambda " ++ prettyShow x reportSLn "reify.def" 50 $ render $ nest 2 $ vcat [ "npars =" <+> pretty npars @@ -815,13 +824,14 @@ let cx = nameConcrete $ qnameName x dInfo = mkDefInfo cx noFixity' PublicAccess ConcreteDef (getRange x) - erased = case getQuantity i of + erased = case getQuantity ai of Quantity0 o -> Erased o Quantityω o -> NotErased o Quantity1 o -> __IMPOSSIBLE__ - elims (A.ExtendedLam exprNoRange dInfo erased x $ - List1.fromList cls) - =<< reify rest + lam = case cls of + [] -> A.AbsurdLam exprNoRange NotHidden + (cl:cls) -> A.ExtendedLam exprNoRange dInfo erased x (cl :| cls) + elims lam =<< reify rest -- | @nameFirstIfHidden (x:a) ({e} es) = {x = e} es@ nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)] @@ -1047,7 +1057,6 @@ A.Let _ _ _ -> __IMPOSSIBLE__ A.Rec i es -> A.Rec i $ blank bound es A.RecUpdate i e es -> uncurry (A.RecUpdate i) $ blank bound (e, es) - A.ETel _ -> __IMPOSSIBLE__ A.Quote {} -> __IMPOSSIBLE__ A.QuoteTerm {} -> __IMPOSSIBLE__ A.Unquote {} -> __IMPOSSIBLE__ @@ -1347,8 +1356,8 @@ result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls False return result -instance Reify Type where - type ReifiesTo Type = Expr +instance Reify I.Type where + type ReifiesTo I.Type = A.Type reifyWhen = reifyWhenE reify (I.El _ t) = reify t @@ -1359,7 +1368,7 @@ reifyWhen = reifyWhenE reify s = do s <- instantiateFull s - SortKit{..} <- sortKit + SortKit{..} <- infallibleSortKit case s of I.Type (I.ClosedLevel 0) -> return $ A.Def' nameOfSet A.NoSuffix I.Type (I.ClosedLevel n) -> return $ A.Def' nameOfSet (A.Suffix n) @@ -1383,6 +1392,9 @@ I.LockUniv -> do lockU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLockUniv return $ A.Def lockU + I.IntervalUniv -> do + intervalU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinIntervalUniv + return $ A.Def intervalU I.PiSort a s1 s2 -> do pis <- freshName_ ("piSort" :: String) -- TODO: hack (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2) @@ -1438,7 +1450,7 @@ name = domName arg tac <- traverse reify $ domTactic arg let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x - return $ TBind r tac xs e : bs + return $ TBind r (TypedBindingInfo tac (domIsFinite arg)) xs e : bs instance Reify i => Reify (Dom i) where type ReifiesTo (Dom i) = Arg (ReifiesTo i) 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 @@ -17,7 +17,11 @@ import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Common -import Agda.Syntax.Abstract as A hiding (Apply) +import Agda.Syntax.Abstract + ( Name, QName, QNamed(QNamed) + , isNoName, nameConcrete, nextName, qualify, unambiguous + ) +import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Reflected as R import Agda.Syntax.Internal (Dom,Dom'(..)) @@ -133,37 +137,42 @@ instance ToAbstract r => ToAbstract [Arg r] where type AbsOfRef [Arg r] = [NamedArg (AbsOfRef r)] --- instance ToAbstract r Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where -instance (ToAbstract r, AbsOfRef r ~ Expr) => ToAbstract (Dom r, Name) where +-- instance ToAbstract r A.Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where +instance (ToAbstract r, AbsOfRef r ~ A.Expr) => ToAbstract (Dom r, Name) where type AbsOfRef (Dom r, Name) = A.TypedBinding - toAbstract (Dom{domInfo = i,unDom = x, domTactic = tac}, name) = do + toAbstract (Dom{domInfo = i, domIsFinite = isfin, unDom = x, domTactic = tac}, name) = do dom <- toAbstract x - return $ mkTBind noRange (singleton $ unnamedArg i $ mkBinder_ name) dom + -- TODO(Amy): Anyone know why this discards the tactic? It was like + -- that when I got here! + return $ A.TBind noRange + (A.TypedBindingInfo Nothing isfin) + (singleton $ unnamedArg i $ A.mkBinder_ name) + dom -instance ToAbstract (Expr, Elim) where - type AbsOfRef (Expr, Elim) = Expr +instance ToAbstract (A.Expr, Elim) where + type AbsOfRef (A.Expr, Elim) = A.Expr toAbstract (f, Apply arg) = do arg <- toAbstract arg showImp <- showImplicitArguments return $ if showImp || visible arg - then App (setOrigin Reflected defaultAppInfo_) f arg + then A.App (setOrigin Reflected defaultAppInfo_) f arg else f -instance ToAbstract (Expr, Elims) where - type AbsOfRef (Expr, Elims) = Expr +instance ToAbstract (A.Expr, Elims) where + type AbsOfRef (A.Expr, Elims) = A.Expr toAbstract (f, elims) = foldM (curry toAbstract) f elims instance ToAbstract r => ToAbstract (R.Abs r) where type AbsOfRef (R.Abs r) = (AbsOfRef r, Name) - toAbstract (Abs s x) = withName s' $ \name -> (,) <$> toAbstract x <*> return name + toAbstract (Abs s x) = withName s' $ \name -> (,name) <$> toAbstract x where s' = if (isNoName s) then "z" else s -- TODO: only do this when var is free instance ToAbstract Literal where - type AbsOfRef Literal = Expr + type AbsOfRef Literal = A.Expr toAbstract l = return $ A.Lit empty l instance ToAbstract Term where - type AbsOfRef Term = Expr + type AbsOfRef Term = A.Expr toAbstract = \case R.Var i es -> do name <- mkVarName i @@ -175,7 +184,7 @@ R.Lam h t -> do (e, name) <- toAbstract t let info = setHiding h $ setOrigin Reflected defaultArgInfo - return $ A.Lam exprNoRange (mkDomainFree $ unnamedArg info $ mkBinder_ name) e + return $ A.Lam exprNoRange (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ name) e R.ExtLam cs es -> do name <- freshName_ extendedLambdaName m <- getCurrentModule @@ -195,7 +204,7 @@ info <- mkMetaInfo let info' = info{ metaNumber = Just x } toAbstract (A.Underscore info', es) - R.Unknown -> Underscore <$> mkMetaInfo + R.Unknown -> A.Underscore <$> mkMetaInfo mkMetaInfo :: ReadTCState m => m MetaInfo mkMetaInfo = do @@ -203,15 +212,23 @@ return $ emptyMetaInfo { metaScope = scope } mkDef :: HasConstInfo m => QName -> m A.Expr -mkDef f = - ifM (isMacro . theDef <$> getConstInfo f) - (return $ A.Macro f) - (return $ A.Def f) +mkDef f = getConstInfo f <&> theDef <&> \case -mkApp :: Expr -> Expr -> Expr -mkApp e1 e2 = App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2 + Constructor{} + -> A.Con $ unambiguous f + Function{ funProjection = Right Projection{ projProper = Just{} } } + -> A.Proj ProjSystem $ unambiguous f + d@Function{} | isMacro d + -> A.Macro f + + _ -> A.Def f + +mkApp :: A.Expr -> A.Expr -> A.Expr +mkApp e1 e2 = A.App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2 + + mkVar :: MonadReflectedToAbstract m => Int -> m (Name, R.Type) mkVar i = ifJustM (askVar i) return $ do cxt <- getContextTelescope @@ -228,7 +245,7 @@ return $ A.AnnP patNoRange t p instance ToAbstract Sort where - type AbsOfRef Sort = Expr + type AbsOfRef Sort = A.Expr toAbstract s = do setName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet propName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinProp @@ -239,7 +256,7 @@ PropS x -> mkApp (A.Def propName) <$> toAbstract x PropLitS x -> return $ A.Def' propName $ A.Suffix x InfS x -> return $ A.Def' infName $ A.Suffix x - UnknownS -> mkApp (A.Def setName) . Underscore <$> mkMetaInfo + UnknownS -> mkApp (A.Def setName) . A.Underscore <$> mkMetaInfo instance ToAbstract R.Pattern where type AbsOfRef R.Pattern = A.Pattern @@ -250,7 +267,7 @@ R.DotP t -> A.DotP patNoRange <$> toAbstract t R.VarP i -> do (x, t) <- mkVar i - annotatePattern i t $ A.VarP $ mkBindName x + annotatePattern i t $ A.VarP $ A.mkBindName x R.LitP l -> return $ A.LitP patNoRange l R.AbsurdP i -> do (_, t) <- mkVar i @@ -264,13 +281,13 @@ checkClauseTelescopeBindings tel pats pats <- toAbstract pats rhs <- toAbstract rhs - let lhs = spineToLhs $ SpineLHS empty name pats - return $ A.Clause lhs [] (RHS rhs Nothing) noWhereDecls False + let lhs = spineToLhs $ A.SpineLHS empty name pats + return $ A.Clause lhs [] (A.RHS rhs Nothing) A.noWhereDecls False toAbstract (QNamed name (R.AbsurdClause tel pats)) = withVars (map (Text.unpack *** unArg) tel) $ \_ -> do checkClauseTelescopeBindings tel pats pats <- toAbstract pats - let lhs = spineToLhs $ SpineLHS empty name pats - return $ A.Clause lhs [] AbsurdRHS noWhereDecls False + let lhs = spineToLhs $ A.SpineLHS empty name pats + return $ A.Clause lhs [] A.AbsurdRHS A.noWhereDecls False instance ToAbstract [QNamed R.Clause] where type AbsOfRef [QNamed R.Clause] = [A.Clause] diff --git a/src/full/Agda/Syntax/Treeless.hs b/src/full/Agda/Syntax/Treeless.hs --- a/src/full/Agda/Syntax/Treeless.hs +++ b/src/full/Agda/Syntax/Treeless.hs @@ -14,7 +14,6 @@ import Control.Arrow (first, second) import Control.DeepSeq -import Data.Data (Data) import Data.Word import GHC.Generics (Generic) @@ -29,13 +28,13 @@ , cArgUsage :: Maybe [ArgUsage] -- ^ 'Nothing' if treeless usage analysis has not run yet. } - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | Usage status of function arguments in treeless code. data ArgUsage = ArgUsed | ArgUnused - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | The treeless compiler can behave differently depending on the target -- language evaluation strategy. For instance, more aggressive erasure for @@ -72,7 +71,7 @@ | TCoerce TTerm -- ^ Used by the GHC backend | TError TError -- ^ A runtime error, something bad has happened. - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | Compiler-related primitives. This are NOT the same thing as primitives -- in Agda's surface or internal syntax! @@ -100,7 +99,7 @@ | PIf | PSeq | PITo64 | P64ToI - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) isPrimEq :: TPrim -> Bool isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ, PEq64] @@ -204,12 +203,12 @@ | CTString | CTFloat | CTQName - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) data CaseInfo = CaseInfo { caseLazy :: Bool , caseType :: CaseType } - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) data TAlt = TACon { aCon :: QName, aArity :: Int, aBody :: TTerm } @@ -219,7 +218,7 @@ | TAGuard { aGuard :: TTerm, aBody :: TTerm } -- ^ Binds no variables | TALit { aLit :: Literal, aBody:: TTerm } - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) data TError = TUnreachable @@ -231,7 +230,7 @@ -- ^ Code which could not be obtained because of a hole in the program. -- This should throw a runtime error. -- The string gives some information about the meta variable that got compiled. - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) class Unreachable a where 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 @@ -18,7 +18,10 @@ import Control.Monad.Except import Control.Monad.Reader +import Data.DList (DList) +import qualified Data.DList as DL import Data.Semigroup ( Semigroup(..) ) +import Data.Set (Set) import qualified Data.Set as Set import Agda.Interaction.Options (optTerminationDepth) @@ -31,7 +34,7 @@ import Agda.Termination.CutOff import Agda.Termination.Order (Order,le,unknown) -import Agda.Termination.RecCheck (anyDefs) +import Agda.Termination.RecCheck (MutualNames, anyDefs) import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Benchmark @@ -56,16 +59,16 @@ import Agda.Utils.Impossible --- | The mutual block we are checking. --- --- The functions are numbered according to their order of appearance --- in this list. - -type MutualNames = [QName] - -- | The target of the function we are checking. -type Target = QName +data Target + = TargetDef QName + -- ^ The target of recursion is a @record@, @data@, or unreducible @Def@. + | TargetRecord + -- ^ We are termination-checking a record. + | TargetOther + -- ^ None of the above two or unknown. + deriving (Eq, Show) -- | The current guardedness level. @@ -94,13 +97,13 @@ -- ^ The names of the functions in the mutual block we are checking. -- This includes the internally generated functions -- (with, extendedlambda, coinduction). - , terUserNames :: [QName] + , terUserNames :: Set QName -- ^ The list of name actually appearing in the file (abstract syntax). -- Excludes the internally generated functions. , terHaveInlinedWith :: Bool -- ^ Does the actual clause result from with-inlining? -- (If yes, it may be ill-typed.) - , terTarget :: Maybe Target + , terTarget :: Target -- ^ Target type of the function we are currently termination checking. -- Only the constructors of 'Target' are considered guarding. , terDelayed :: Delayed @@ -153,7 +156,7 @@ , terMutual = __IMPOSSIBLE__ -- needs to be set! , terCurrent = __IMPOSSIBLE__ -- needs to be set! , terHaveInlinedWith = False - , terTarget = Nothing + , terTarget = TargetOther , terDelayed = NotDelayed , terMaskArgs = repeat False -- use all arguments (mask none) , terMaskResult = False -- use result (do not mask) @@ -279,13 +282,13 @@ terGetMutual :: TerM MutualNames terGetMutual = terAsks terMutual -terGetUserNames :: TerM [QName] +terGetUserNames :: TerM (Set QName) terGetUserNames = terAsks terUserNames -terGetTarget :: TerM (Maybe Target) +terGetTarget :: TerM Target terGetTarget = terAsks terTarget -terSetTarget :: Maybe Target -> TerM a -> TerM a +terSetTarget :: Target -> TerM a -> TerM a terSetTarget t = terLocal $ \ e -> e { terTarget = t } terGetHaveInlinedWith :: TerM Bool @@ -575,7 +578,11 @@ -- * Call pathes --- | The call information is stored as free monoid +-- | Call paths. + +-- An old comment: +-- +-- The call information is stored as free monoid -- over 'CallInfo'. As long as we never look at it, -- only accumulate it, it does not matter whether we use -- 'Set', (nub) list, or 'Tree'. @@ -584,16 +591,24 @@ -- Since we define no order on 'CallInfo' (expensive), -- we cannot use a 'Set' or nub list. -- Performance-wise, I could not see a difference between Set and list. +-- +-- If the binary tree is balanced "incorrectly", then forcing it could +-- be expensive, so a switch was made to difference lists. -newtype CallPath = CallPath { callInfos :: [CallInfo] } +newtype CallPath = CallPath (DList CallInfo) deriving (Show, Semigroup, Monoid) +-- | The calls making up the call path. + +callInfos :: CallPath -> [CallInfo] +callInfos (CallPath cs) = DL.toList cs + -- | Only show intermediate nodes. (Drop last 'CallInfo'). instance Pretty CallPath where - pretty (CallPath cis0) = if null cis then empty else + pretty cis0 = if null cis then empty else P.hsep (map (\ ci -> arrow P.<+> P.pretty ci) cis) P.<+> arrow where - cis = init cis0 + cis = init (callInfos cis0) arrow = "-->" -- * Size depth estimation @@ -601,16 +616,23 @@ -- | A very crude way of estimating the @SIZELT@ chains -- @i > j > k@ in context. Returns 3 in this case. -- Overapproximates. +class TerSetSizeDepth b where + terSetSizeDepth :: b -> TerM a -> TerM a +instance TerSetSizeDepth Telescope where + terSetSizeDepth = terSetSizeDepth . telToList + -- TODO: more precise analysis, constructing a tree -- of relations between size variables. -terSetSizeDepth :: Telescope -> TerM a -> TerM a -terSetSizeDepth tel cont = do - n <- liftTCM $ sum <$> do - forM (telToList tel) $ \ dom -> do - a <- reduce $ snd $ unDom dom - ifM (isJust <$> isSizeType a) (return 1) {- else -} $ - case unEl a of - MetaV{} -> return 1 - _ -> return 0 - terLocal (set terSizeDepth n) cont +instance TerSetSizeDepth ListTel where + terSetSizeDepth doms cont = do + n <- liftTCM $ sum <$> do + forM doms $ \ dom -> do + -- Andreas, 2022-03-12, TODO: + -- use ifBlocked? Shouldn't blocked types be treated like metas? + a <- reduce $ snd $ unDom dom + ifM (isJust <$> isSizeType a) (return 1) {- else -} $ + case unEl a of + MetaV{} -> return 1 + _ -> return 0 + terLocal (set terSizeDepth n) cont 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 @@ -13,16 +13,19 @@ module Agda.Termination.RecCheck - ( recursive + ( MutualNames + , recursive , anyDefs ) where import Control.Monad (forM, forM_) +import Data.Foldable import Data.Graph import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.Map as Map +import qualified Data.Map.Strict as MapS import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set @@ -37,6 +40,13 @@ import Agda.Utils.Impossible +-- | The mutual block we are checking. +-- +-- The functions are numbered according to their order of appearance +-- in this set. + +type MutualNames = Set QName + -- | We compute for each clause the set of potentially recursive names. type NamesPerClause = IntMap (Set QName) @@ -46,16 +56,21 @@ -- -- As a side effect, update the 'clauseRecursive' field in the -- clauses belonging to the given functions. -recursive :: [QName] -> TCM [[QName]] +recursive :: Set QName -> TCM [MutualNames] recursive names = do + let names' = toList names -- For each function, get names per clause and total. - (perClauses, nss) <- unzip <$> mapM (recDef (names `hasElem`)) names + (perClauses, nss) <- unzip <$> mapM (recDef (`Set.member` names)) names' -- Create graph suitable for stronglyConnComp. -- Nodes are identical to node keys. - let graph = zipWith (\ x ns -> (x, x, Set.toList ns)) names nss + let graph = zipWith (\ x ns -> (x, x, Set.toList ns)) names' nss let sccs = stronglyConnComp graph - let nonRec = mapMaybe (\case{ AcyclicSCC x -> Just x ; _ -> Nothing}) sccs - let recs = mapMaybe (\case{ CyclicSCC xs -> Just xs; _ -> Nothing}) sccs + let nonRec = mapMaybe (\case AcyclicSCC x -> Just x + _ -> Nothing) + sccs + let recs = mapMaybe (\case CyclicSCC xs -> Just (Set.fromList xs) + _ -> Nothing) + sccs reportSLn "rec.graph" 60 $ show graph @@ -65,7 +80,7 @@ -- Mark individual clauses of recursive functions: -------------------------------------------------- -- Map names to clause numbers to sets of mentioned names. - let clMap = Map.fromListWith __IMPOSSIBLE__ $ zip names perClauses + let clMap = Map.fromListWith __IMPOSSIBLE__ $ zip names' perClauses -- Walk through SCCs. forM_ recs $ \ scc -> do -- Does a set of names have an overlap with the current scc? @@ -88,6 +103,9 @@ { funTerminates = Just True , funClauses = map (\ cl -> cl { clauseRecursive = Just False }) $ funClauses def } + def@Record{} -> def + { recTerminates = Just True + } def -> def -- | Mark all clauses of a function as recursive or non-recursive. @@ -112,11 +130,17 @@ -- Get names in body (perClause, ns2) <- case theDef def of + Function{ funClauses = cls } -> do perClause <- do forM (zip [0..] cls) $ \ (i, cl) -> (i,) <$> anyDefs include cl return (IntMap.fromList perClause, mconcat $ map snd perClause) + + Record{ recTel } -> do + ns <- anyDefs include recTel + return (IntMap.singleton 0 ns, ns) + _ -> return (mempty, mempty) reportS "rec.graph" 20 @@ -131,14 +155,16 @@ anyDefs :: GetDefs a => (QName -> Bool) -> a -> TCM (Set QName) anyDefs include a = do -- Prepare function to lookup metas outside of TCM - st <- getMetaStore - let lookup (MetaId x) = (mvInstantiation <$> IntMap.lookup x st) >>= \case - InstV _ v -> Just v -- TODO: ignoring the lambdas might be bad? - Open -> Nothing - OpenInstance -> Nothing - BlockedConst{} -> Nothing - PostponedTypeCheckingProblem{} -> Nothing + st <- useR stSolvedMetaStore + let lookup x = inst . mvInstantiation <$> MapS.lookup x st -- we collect only those used definitions that are in @names@ emb d = if include d then Set.singleton d else Set.empty -- get all the Defs that are in names return $ getDefs' lookup emb a + where + -- TODO: Is it bad to ignore the lambdas? + inst (InstV i) = instBody i + inst Open = __IMPOSSIBLE__ + inst OpenInstance = __IMPOSSIBLE__ + inst BlockedConst{} = __IMPOSSIBLE__ + inst PostponedTypeCheckingProblem{} = __IMPOSSIBLE__ diff --git a/src/full/Agda/Termination/SparseMatrix.hs b/src/full/Agda/Termination/SparseMatrix.hs --- a/src/full/Agda/Termination/SparseMatrix.hs +++ b/src/full/Agda/Termination/SparseMatrix.hs @@ -48,7 +48,7 @@ ) where import Data.Array -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Maybe 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 @@ -24,6 +24,7 @@ import Data.Foldable (toList) import qualified Data.List as List import Data.Monoid hiding ((<>)) +import Data.Set (Set) import qualified Data.Set as Set import qualified Agda.Syntax.Abstract as A @@ -115,13 +116,17 @@ A.ScopedDecl scope ds -> {- withScope_ scope $ -} termDecls ds -- scope is irrelevant as we are termination checking Syntax.Internal A.RecSig{} -> return mempty - A.RecDef _ r _ _ _ _ ds -> termDecls ds - -- These should all be wrapped in mutual blocks + A.RecDef _ x _ _ _ _ ds -> termMutual [x] <> termDecls ds + -- Andreas, 2022-10-23, issue #5823 + -- Also check record types for termination. + -- They are unfolded during construction of unique inhabitants of eta-records. + -- These should all be wrapped in mutual blocks: A.FunDef{} -> __IMPOSSIBLE__ A.DataSig{} -> __IMPOSSIBLE__ A.DataDef{} -> __IMPOSSIBLE__ A.UnquoteDecl{} -> __IMPOSSIBLE__ A.UnquoteDef{} -> __IMPOSSIBLE__ + A.UnquoteData{} -> __IMPOSSIBLE__ where termDecls ds = concat <$> mapM termDecl' ds @@ -129,7 +134,7 @@ -- for symbols that need to be termination-checked. getNames = concatMap getName getName (A.FunDef i x delayed cs) = [x] - getName (A.RecDef _ _ _ _ _ _ ds) = getNames ds + getName (A.RecDef _ x _ _ _ _ ds) = x : getNames ds getName (A.Mutual _ ds) = getNames ds getName (A.Section _ _ _ ds) = getNames ds getName (A.ScopedDecl _ ds) = getNames ds @@ -153,8 +158,9 @@ -- during type-checking. mid <- fromMaybe __IMPOSSIBLE__ <$> asksTC envMutualBlock mutualBlock <- lookupMutualBlock mid - let allNames = filter (not . isAbsurdLambdaName) $ Set.elems $ mutualNames mutualBlock - names = if null names0 then allNames else names0 + let allNames = Set.filter (not . isAbsurdLambdaName) $ + mutualNames mutualBlock + names = if null names0 then allNames else Set.fromList names0 i = mutualInfo mutualBlock -- We set the range to avoid panics when printing error messages. @@ -196,7 +202,7 @@ forM sccs $ \ allNames -> do -- Set the mutual names in the termination environment. - let namesSCC = filter (allNames `hasElem`) names + let namesSCC = Set.filter (`Set.member` allNames) names let setNames e = e { terMutual = allNames , terUserNames = namesSCC @@ -207,23 +213,15 @@ " with cutoff=" ++ show cutoff ++ "..." terLocal setNames cont - -- New check currently only makes a difference for copatterns. + -- New check currently only makes a difference for copatterns and record types. -- Since it is slow, only invoke it if - -- any of the definitions uses copatterns. - res <- ifM (orM $ map usesCopatterns allNames) + -- any of the definitions uses copatterns or is a record type. + ifM (anyM allNames $ \ q -> usesCopatterns q `or2M` (isJust <$> isRecord q)) -- Then: New check, one after another. (runTerm $ forM' allNames $ termFunction) -- Else: Old check, all at once. (runTerm $ termMutual') - -- Record result of termination check in signature. - -- If there are some termination errors, we collect them in - -- the state and mark the definition as non-terminating so - -- that it does not get unfolded - let terminates = null res - forM_ allNames $ \ q -> setTerminates q terminates - return res - -- | @termMutual'@ checks all names of the current mutual block, -- henceforth called @allNames@, for termination. -- @@ -268,19 +266,25 @@ -- the names the user has declared. This is for error reporting. names <- terGetUserNames case r of - Left calls -> return $ singleton $ terminationError names $ callInfos calls + + Left calls -> do + mapM_ (`setTerminates` False) allNames + return $ singleton $ terminationError names calls + Right{} -> do liftTCM $ reportSLn "term.warn.yes" 2 $ prettyShow (names) ++ " does termination check" + mapM_ (`setTerminates` True) allNames return mempty -- | Smart constructor for 'TerminationError'. -- Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'. -terminationError :: [QName] -> [CallInfo] -> TerminationError -terminationError names calls = TerminationError names' calls +terminationError :: Set QName -> CallPath -> TerminationError +terminationError names calls = TerminationError names' calls' where - names' = filter (hasElem mentioned) names - mentioned = map callInfoTarget calls + calls' = callInfos calls + mentioned = map callInfoTarget calls' + names' = filter (hasElem mentioned) $ toList names billToTerGraph :: a -> TerM a billToTerGraph a = liftTCM $ billPureTo [Benchmark.Termination, Benchmark.Graph] a @@ -343,20 +347,27 @@ return () -- | @termFunction name@ checks @name@ for termination. +-- If it passes the termination check it is marked as "terminates" in the signature. termFunction :: QName -> TerM Result -termFunction name = do +termFunction name = inConcreteOrAbstractMode name $ \ def -> do -- Function @name@ is henceforth referred to by its @index@ -- in the list of @allNames@ of the mutual block. allNames <- terGetMutual - let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames + let index = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex name allNames -- Retrieve the target type of the function to check. -- #4256: Don't use typeOfConst (which instantiates type with module params), since termination -- checking is running in the empty context, but with the current module unchanged. - target <- liftTCM $ do typeEndsInDef . defType =<< getConstInfo name + target <- case theDef def of + -- We are termination-checking a record (calls to record will not be guarding): + Record{} -> return TargetRecord + -- We are termination-checking a definition: + _ -> typeEndsInDef (defType def) <&> \case + Just d -> TargetDef d + Nothing -> TargetOther reportTarget target terSetTarget target $ do @@ -368,7 +379,10 @@ if null todo then return $ Left calls else do -- Extract calls originating from indices in @todo@. new <- forM' todo $ \ i -> - termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i + termDef $ + if i < 0 || i >= Set.size allNames + then __IMPOSSIBLE__ + else Set.elemAt i allNames -- Mark those functions as processed and add the calls to the result. let done' = done `mappend` todo calls' = new `mappend` calls @@ -385,26 +399,61 @@ cutoff <- terGetCutOff let ?cutoff = cutoff r <- billToTerGraph $ Term.terminatesFilter (== index) calls1 - case r of + + -- Andrea: 22/04/2020. + -- With cubical we will always have a clause where the dot + -- patterns are instead replaced with a variable, so they + -- cannot be relied on for termination. + -- See issue #4606 for a counterexample involving HITs. + -- + -- Without the presence of HITs I conjecture that dot patterns + -- could be turned into actual splits, because no-confusion + -- would make the other cases impossible, so I do not disable + -- this for --without-K entirely. + -- + -- Andreas, 2022-03-21: The check for --cubical was missing here. + ifM (isJust . optCubical <$> pragmaOptions) (return r) {- else -} $ case r of Right () -> return $ Right () - Left{} -> do + Left{} -> do -- Try again, but include the dot patterns this time. calls2 <- terSetUseDotPatterns True $ collect reportCalls "" calls2 - billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2 + billToTerGraph $ Term.terminatesFilter (== index) calls2 names <- terGetUserNames - case r of - Left calls -> return $ singleton $ terminationError ([name] `List.intersect` names) calls + case mapLeft callInfos r of + + Left calls -> do + -- Mark as non-terminating. + setTerminates name False + + -- Functions must be terminating, records types need not... + case theDef def of + + -- Records need not terminate, so we just put the error on the debug log. + Record{} -> do + reportSDoc "term.warn.no" 10 $ vcat $ + hsep [ "Record type", prettyTCM name, "does not termination check.", "Problematic calls:" ] : + (map (nest 2 . prettyTCM) $ List.sortOn getRange calls) + mempty + + -- Functions must terminate, so we report the error. + _ -> do + let err = TerminationError [name | name `elem` names] calls + return $ singleton err + Right () -> do - liftTCM $ reportSLn "term.warn.yes" 2 $ + reportSLn "term.warn.yes" 2 $ prettyShow name ++ " does termination check" + setTerminates name True return mempty where - reportTarget r = liftTCM $ - reportSLn "term.target" 20 $ " target type " ++ - caseMaybe r "not recognized" (\ q -> - "ends in " ++ prettyShow q) + reportTarget :: MonadDebug m => Target -> m () + reportTarget tgt = reportSLn "term.target" 20 $ (" " ++) $ + case tgt of + TargetRecord -> "termination checking a record type" + TargetDef q -> unwords [ "target type ends in", prettyShow q ] + TargetOther -> "target type not recognized" -- | To process the target type. typeEndsInDef :: MonadTCM tcm => Type -> tcm (Maybe QName) @@ -427,6 +476,13 @@ termDef :: QName -> TerM Calls termDef name = terSetCurrent name $ inConcreteOrAbstractMode name $ \ def -> do + -- Skip calls to record types unless we are checking a record type in the first place. + let isRecord_ = case theDef def of { Record{} -> True; _ -> False } + let notTargetRecord = terGetTarget <&> \case + TargetRecord -> False + _ -> True + ifM (pure isRecord_ `and2M` notTargetRecord) mempty {-else-} $ do + -- Retrieve definition let t = defType def @@ -459,14 +515,28 @@ then return empty else termClause cl + -- @record R pars : Set where field tel@ + -- is treated like function @R pars = tel@. + Record{ recPars, recTel } -> termRecTel recPars recTel + _ -> return empty - where - hasDefP :: [NamedArg DeBruijnPattern] -> Bool - hasDefP ps = getAny $ flip foldPattern ps $ \ (x :: DeBruijnPattern) -> - case x of - DefP{} -> Any True - _ -> Any False +-- | Extract "calls" to the field types from a record constructor telescope. +-- Does not extract from the parameters, but treats these as the "pattern variables" +-- (the lhs of the "function"). +termRecTel :: Nat -> Telescope -> TerM Calls +termRecTel npars tel = do + -- Set up the record parameters like function parameters. + let (pars, fields) = splitAt npars $ telToList tel + addContext pars $ do + ps <- mkPats npars + terSetPatterns ps $ terSetSizeDepth pars $ do + -- Treat the record fields like the body of a function. + extract $ telFromList fields + where + -- create n variable patterns + mkPats n = zipWith mkPat (downFrom n) <$> getContextNames + mkPat i x = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i -- | Collect calls in type signature @f : (x1:A1)...(xn:An) -> B@. -- It is treated as if there were the additional function clauses. @@ -505,50 +575,43 @@ (ds, d) <- liftTCM $ do TelV tel core <- telViewPath t -- Check argument types - ds <- forM (telToList tel) $ \ t -> do - TelV _ t <- telViewPath $ snd $ unDom t - d <- (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t) - when d $ - reportSDoc "term.mask" 20 $ do - "argument type " - <+> prettyTCM t - <+> " is not data or record type, ignoring structural descent for --without-K" - return d + ds <- checkArgumentTypes tel -- Check result types - d <- isNothing <.> isDataOrRecord . unEl $ core + d <- addContext tel $ isNothing <.> isDataOrRecord . unEl $ core when d $ reportSLn "term.mask" 20 $ "result type is not data or record type, ignoring guardedness for --without-K" return (ds, d) terSetMaskArgs (ds ++ repeat True) $ terSetMaskResult d $ cont + where + checkArgumentTypes :: Telescope -> TCM [Bool] + checkArgumentTypes EmptyTel = return [] + checkArgumentTypes (ExtendTel dom atel) = do + TelV tel2 t <- telViewPath $ unDom dom + d <- addContext tel2 $ + (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t) + when d $ + reportSDoc "term.mask" 20 $ do + "argument type " + <+> prettyTCM t + <+> " is not data or record type, ignoring structural descent for --without-K" + underAbstraction dom atel $ \tel -> (d:) <$> checkArgumentTypes tel -- | Is the current target type among the given ones? -targetElem :: [Target] -> TerM Bool -targetElem ds = maybe False (`elem` ds) <$> terGetTarget +targetElem :: [QName] -> TerM Bool +targetElem ds = terGetTarget <&> \case + TargetDef d -> d `elem` ds + TargetRecord -> False + TargetOther -> False -{- --- | The target type of the considered recursive definition. -data Target - = Set -- ^ Constructing a Set (only meaningful with 'guardingTypeConstructors'). - | Data QName -- ^ Constructing a coinductive or mixed type (could be data or record). - deriving (Eq, Show) --- | Check wether a 'Target" corresponds to the current one. -matchingTarget :: DBPConf -> Target -> TCM Bool -matchingTarget conf t = maybe (return True) (match t) (currentTarget conf) - where - match Set Set = return True - match (Data d) (Data d') = mutuallyRecursive d d' - match _ _ = return False --} - -- | Convert a term (from a dot pattern) to a DeBruijn pattern. -- -- The term is first normalized and stripped of all non-coinductive projections. termToDBP :: Term -> TerM DeBruijnPattern -termToDBP t = ifNotM terGetUseDotPatterns (return unusedVar) $ {- else -} do +termToDBP t = termToPattern =<< do liftTCM $ stripAllProjections =<< normalise t -- | Convert a term (from a dot pattern) to a pattern for the purposes of the termination checker. @@ -572,18 +635,25 @@ instance TermToPattern Term DeBruijnPattern where termToPattern t = liftTCM (constructorForm t) >>= \case -- Constructors. - Con c _ args -> ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args) - Def s [Apply arg] -> do + Con c _ args -> ifDotPatsOrRecord c $ + ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args) + Def s [Apply arg] -> ifDotPats $ do suc <- terGetSizeSuc if Just s == suc then ConP (ConHead s IsData Inductive []) noConPatternInfo . map (fmap unnamed) <$> termToPattern [arg] - else return $ dotP t + else fallback DontCare t -> termToPattern t -- OR: __IMPOSSIBLE__ -- removed by stripAllProjections -- Leaves. Var i [] -> varP . (`DBPatVar` i) . prettyShow <$> nameOfBV i Lit l -> return $ litP l Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s - t -> return $ dotP t - + t -> fallback + where + -- Andreas, 2022-06-14, issues #5953 and #4725 + -- Recognize variable and record patterns in dot patterns regardless + -- of whether dot-pattern termination is on. + ifDotPats = ifNotM terGetUseDotPatterns fallback + ifDotPatsOrRecord c = ifM (pure (IsData == conDataRecord c) `and2M` do not <$> terGetUseDotPatterns) fallback + fallback = return $ dotP t -- | Masks all non-data/record type patterns if --without-K. -- See issue #1023. @@ -686,6 +756,7 @@ Inf f n -> return empty SizeUniv -> return empty LockUniv -> return empty + IntervalUniv -> return empty Type t -> terUnguarded $ extract t -- no guarded levels Prop t -> terUnguarded $ extract t SSet t -> terUnguarded $ extract t @@ -701,6 +772,11 @@ instance ExtractCalls Type where extract (El s t) = extract (s, t) +instance ExtractCalls a => ExtractCalls (Tele a) where + extract = \case + EmptyTel -> mempty + ExtendTel a tel -> extract a <> extract tel + -- | Extract recursive calls from a constructor application. constructor @@ -756,13 +832,16 @@ ] -- insert this call into the call list - case List.elemIndex g names of + case Set.lookupIndex g names of -- call leads outside the mutual block and can be ignored Nothing -> return calls - -- call is to one of the mutally recursive functions + -- call is to one of the mutally recursive functions/record Just gInd -> do + cutoff <- terGetCutOff + let ?cutoff = cutoff + delayed <- terGetDelayed -- Andreas, 2017-02-14, issue #2458: -- If we have inlined with-functions, we could be illtyped, @@ -798,15 +877,30 @@ -- spent on call matrix generation (nrows, ncols, matrix) <- billTo [Benchmark.Termination, Benchmark.Compare] $ compareArgs es - -- only a delayed definition can be guarded - let ifDelayed o | Order.decreasing o && delayed == NotDelayed = Order.le - | otherwise = o + + -- Andreas, 2022-03-21, #5823: + -- If we are "calling" a record type we are guarded unless the origin + -- of the termination analysis is itself a record. + -- This is because we usually do not "unfold" record types into their + -- field telescope. We only do so when trying to construct the + -- unique inhabitant of record type (singleton analysis). + -- In the latter case, a call to a record type is not guarding. + guarded' <- isRecord g >>= \case + Just{} -> terGetTarget >>= \case + TargetRecord + -> return guarded + _ -> return (guarded .*. Order.lt) + -- guarding when we call a record and not termination checking a record + Nothing + -- only a delayed definition can be guarded + | Order.decreasing guarded && delayed == NotDelayed + -> return Order.le + | otherwise + -> return guarded liftTCM $ reportSLn "term.guardedness" 20 $ "composing with guardedness " ++ prettyShow guarded ++ - " counting as " ++ prettyShow (ifDelayed guarded) - cutoff <- terGetCutOff - let ?cutoff = cutoff - let matrix' = composeGuardedness (ifDelayed guarded) matrix + " counting as " ++ prettyShow guarded' + let matrix' = composeGuardedness guarded' matrix -- Andreas, 2013-04-26 FORBIDDINGLY expensive! -- This PrettyTCM QName cost 50% of the termination time for std-lib!! @@ -830,14 +924,14 @@ -- Andreas, 2017-01-05, issue #2376 -- Remove arguments inserted by etaExpandClause. - let src = fromMaybe __IMPOSSIBLE__ $ List.elemIndex f names + let src = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex f names tgt = gInd cm = makeCM ncols nrows matrix' - info = CallPath [CallInfo + info = CallPath $ singleton $ + CallInfo { callInfoTarget = g - , callInfoRange = getRange g , callInfoCall = doc - }] + } verboseS "term.kept.call" 5 $ do pats <- terGetPatterns reportSDoc "term.kept.call" 5 $ vcat @@ -887,7 +981,7 @@ -- Finally, try to reduce with the non-recursive clauses (and no rewrite rules). r <- liftTCM $ modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $ - runReduceM $ appDefE' v0 cls [] (map notReduced es) + runReduceM $ appDefE' g v0 cls [] (map notReduced es) case r of NoReduction{} -> fallback YesReduction _ v -> do @@ -909,29 +1003,36 @@ instance ExtractCalls Term where extract t = do - liftTCM $ reportSDoc "term.check.term" 50 $ do + reportSDoc "term.check.term" 50 $ do "looking for calls in" <+> prettyTCM t -- Instantiate top-level MetaVar. - t <- liftTCM $ instantiate t - case t of + instantiate t >>= \case -- Constructed value. Con ConHead{conName = c, conDataRecord = dataOrRec} _ es -> do let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es -- A constructor preserves the guardedness of all its arguments. - let argsg = zip args $ repeat True + -- Andreas, 2022-09-19, issue #6108: + -- A higher constructor does not. So check if there is an @IApply@ amoung @es@. + let argsg = zip args $ repeat $ all isProperApplyElim es -- If we encounter a coinductive record constructor -- in a type mutual with the current target -- then we count it as guarding. - let inductive = return Inductive - coinductive = return CoInductive + let inductive = return Inductive -- not guarding, but preserving + coinductive = return CoInductive -- guarding + -- ♯ is guarding ind <- ifM ((Just c ==) <$> terGetSharp) coinductive $ {-else-} do + -- data constructors are not guarding if dataOrRec == IsData then inductive else do - caseMaybeM (liftTCM $ isRecordConstructor c) inductive $ \ (q, def) -> do + -- abstract constructors are not guarding + caseMaybeM (isRecordConstructor c) inductive $ \ (q, def) -> do reportSLn "term.check.term" 50 $ "constructor " ++ prettyShow c ++ " has record type " ++ prettyShow q + -- inductive record constructors are not guarding if recInduction def /= Just CoInductive then inductive else do + -- coinductive constructors unrelated to the mutually + -- constructed inhabitants of coinductive types are not guarding ifM (targetElem . fromMaybe __IMPOSSIBLE__ $ recMutual def) {-then-} coinductive {-else-} inductive @@ -946,17 +1047,16 @@ -- Neutral term. Destroys guardedness. Var i es -> terUnguarded $ extract es - -- Dependent function space. Destroys guardedness. + -- Dependent function space. Pi a (Abs x b) -> - terUnguarded $ CallGraph.union <$> extract a <*> do a <- maskSizeLt a -- OR: just do not add a to the context! addContext (x, a) $ terRaise $ extract b - -- Non-dependent function space. Destroys guardedness. + -- Non-dependent function space. Pi a (NoAbs _ b) -> - terUnguarded $ CallGraph.union <$> extract a <*> extract b + CallGraph.union <$> extract a <*> extract b -- Literal. Lit l -> return empty @@ -1035,7 +1135,7 @@ let guardedness = if useGuardedness then decr True $ projsCaller - projsCallee - else Order.Unknown + else Order.le liftTCM $ reportSDoc "term.guardedness" 30 $ sep [ "compareArgs:" , nest 2 $ text $ "projsCaller = " ++ prettyShow projsCaller @@ -1328,14 +1428,17 @@ compareConArgs ts ps = do cutoff <- terGetCutOff let ?cutoff = cutoff - -- we may assume |ps| >= |ts|, otherwise c ps would be of functional type - -- which is impossible - case (length ts, length ps) of - (0,0) -> return Order.le -- c <= c - (0,1) -> return Order.unknown -- c not<= c x - (1,0) -> __IMPOSSIBLE__ - (1,1) -> compareTerm' (unArg (head ts)) (notMasked $ namedArg $ head ps) - (_,_) -> foldl (Order..*.) Order.le <$> + case compare (length ts) (length ps) of + + -- We may assume |ps| >= |ts|, otherwise c ps would be of functional type + -- which is impossible. + GT -> __IMPOSSIBLE__ + + -- Andreas, 2022-08-31, issue #6059: doing anything smarter than + -- @unknown@ here can lead to non-termination. + LT -> return Order.unknown + + EQ -> List.foldl' (Order..*.) Order.le <$> zipWithM compareTerm' (map unArg ts) (map (notMasked . namedArg) ps) -- corresponds to taking the size, not the height -- allows examples like (x, y) < (Succ x, y) 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 @@ -5,7 +5,7 @@ import Control.Monad import Control.Monad.Except -import Data.Function +import Data.Function (on) import qualified Data.HashMap.Strict as HMap import Agda.Syntax.Common @@ -81,9 +81,10 @@ pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a)) $ mkPi (setHiding NotHidden $ defaultDom ("eq", eq)) $ b -piAbstract (Arg info (prf, eqt@(EqualityType _ _ _ (Arg _ a) v _))) b = do +piAbstract (Arg info (prf, EqualityViewType eqt@(EqualityTypeData _ _ _ (Arg _ a) v _))) b = do s <- sortOf a - let prfTy = equalityUnview eqt + let prfTy :: Type + prfTy = equalityUnview eqt vTy = El s a b <- abstractType prfTy prf b b <- addContext ("w" :: String, defaultDom prfTy) $ @@ -92,8 +93,10 @@ where funType str a = mkPi $ setArgInfo info $ defaultDom (str, a) -- Abstract the lhs (@a@) of the equality only. + eqt1 :: EqualityTypeData eqt1 = raise 1 eqt - eqTy' = equalityUnview $ eqt1 { eqtLhs = eqtLhs eqt1 $> var 0 } + eqTy' :: Type + eqTy' = equalityUnview $ eqt1{ _eqtLhs = _eqtLhs eqt1 $> var 0 } -- | @isPrefixOf u v = Just es@ if @v == u `applyE` es@. @@ -208,6 +211,7 @@ SSet n -> SSet $ absS n SizeUniv -> SizeUniv LockUniv -> LockUniv + IntervalUniv -> LockUniv PiSort a s1 s2 -> PiSort (absS a) (absS s1) (absS s2) FunSort s1 s2 -> FunSort (absS s1) (absS s2) UnivSort s -> UnivSort $ absS s @@ -329,9 +333,9 @@ -- | Ignore the tactic. instance EqualSy a => EqualSy (Dom a) where - equalSy d@(Dom ai b x _tac a) d'@(Dom ai' b' x' _tac' a') = and + equalSy d@(Dom ai x f _tac a) d'@(Dom ai' x' f' _tac' a') = and [ x == x' - , b == b' + , f == f' , equalSy ai ai' , equalSy a a' ] diff --git a/src/full/Agda/TypeChecking/CheckInternal.hs b/src/full/Agda/TypeChecking/CheckInternal.hs --- a/src/full/Agda/TypeChecking/CheckInternal.hs +++ b/src/full/Agda/TypeChecking/CheckInternal.hs @@ -41,6 +41,7 @@ import Agda.Utils.Functor (($>)) +import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size import Agda.Utils.Impossible @@ -162,12 +163,12 @@ [ "checking internal " , nest 2 $ sep [ prettyTCM v <+> ":" , nest 2 $ prettyTCM t ] ] - reportSDoc "tc.check.internal" 30 $ sep + reportSDoc "tc.check.internal" 60 $ sep [ "checking internal with DB indices" , nest 2 $ sep [ pretty v <+> ":" , nest 2 $ pretty t ] ] ctx <- getContextTelescope - reportSDoc "tc.check.internal" 30 $ sep + unless (null ctx) $ reportSDoc "tc.check.internal" 30 $ sep [ "In context" , nest 2 $ sep [ prettyTCM ctx ] ] -- Bring projection-like funs in post-fix form, @@ -215,7 +216,7 @@ NoAbs{} -> id a <- mkDom <$> checkInternal' action (unEl $ unDom a) CmpLeq (sort sa) v' <- goInside $ Pi a . mkRng <$> checkInternal' action (unEl $ unAbs b) CmpLeq (sort sb) - s' <- sortOf v' + s' <- sortOf v -- Issue #6205: do not use v' since it might not be valid syntax compareSort cmp s' s return v' Sort s -> do @@ -227,7 +228,7 @@ return $ Sort s Level l -> do l <- checkLevel action l - lt <- levelType + lt <- levelType' compareType cmp lt t return $ Level l DontCare v -> DontCare <$> checkInternal' action v cmp t @@ -322,8 +323,7 @@ -- | Infer type of a neutral term. infer :: (MonadCheckInternal m) => Term -> m Type -infer v = do - case v of +infer = \case Var i es -> do a <- typeOfBV i snd <$> inferSpine a (Var i []) es @@ -332,7 +332,10 @@ MetaV x es -> do -- we assume meta instantiations to be well-typed a <- metaType x snd <$> inferSpine a (MetaV x []) es - _ -> __IMPOSSIBLE__ + v -> __IMPOSSIBLE_VERBOSE__ $ unlines + [ "CheckInternal.infer: non-inferable term:" + , " " ++ prettyShow v + ] -- | Infer ordinary function application. inferDef :: (MonadCheckInternal m) => QName -> Elims -> m Type @@ -370,7 +373,7 @@ , "type t = " <+> pretty t , "self = " <+> pretty self , "self' = " <+> pretty self' - , "eliminated by e = " <+> text (show e) + , "eliminated by e = " <+> pretty e ] case e of IApply x y r -> do @@ -426,6 +429,7 @@ SSet l -> SSet <$> checkLevel action l SizeUniv -> return SizeUniv LockUniv -> return LockUniv + IntervalUniv -> return IntervalUniv PiSort dom s1 s2 -> do let a = unDom dom s1' <- checkSort action s1 @@ -465,7 +469,7 @@ checkPlusLevel (Plus k l) = Plus k <$> checkLevelAtom l checkLevelAtom l = do - lvl <- levelType + lvl <- levelType' checkInternal' action l CmpLeq lvl -- | Universe subsumption and type equality (subtyping for sizes, resp.). diff --git a/src/full/Agda/TypeChecking/CompiledClause.hs b/src/full/Agda/TypeChecking/CompiledClause.hs --- a/src/full/Agda/TypeChecking/CompiledClause.hs +++ b/src/full/Agda/TypeChecking/CompiledClause.hs @@ -14,11 +14,6 @@ import Data.Map (Map) import Data.Semigroup hiding (Arg(..)) - - - -import Data.Data (Data) - import GHC.Generics (Generic) import Agda.Syntax.Common @@ -33,7 +28,7 @@ import Agda.Utils.Impossible data WithArity c = WithArity { arity :: Int, content :: c } - deriving (Data, Functor, Foldable, Traversable, Show, Generic) + deriving (Functor, Foldable, Traversable, Show, Generic) -- | Branches in a case tree. @@ -57,7 +52,7 @@ -- ^ Lazy pattern match. Requires single (non-copattern) branch with no lit -- branches and no catch-all. } - deriving (Data, Functor, Foldable, Traversable, Show, Generic) + deriving (Functor, Foldable, Traversable, Show, Generic) -- | Case tree with bodies. @@ -75,7 +70,7 @@ | Fail [Arg ArgName] -- ^ Absurd case. Add the free variables here as well so we can build correct -- number of lambdas for strict backends. (#4280) - deriving (Data, Functor, Traversable, Foldable, Show, Generic) + deriving (Functor, Traversable, Foldable, Show, Generic) type CompiledClauses = CompiledClauses' Term 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 @@ -198,7 +198,7 @@ caseMaybeM (asksTC envAppDef) __IMPOSSIBLE__ $ \ f -> do pds <- getPartialDefs if f `elem` pds - then return (NoReduction $ NotBlocked MissingClauses []) + then return (NoReduction $ NotBlocked (MissingClauses f) []) else do ifM (optRewriting <$> pragmaOptions) {-then-} (return (NoReduction $ NotBlocked ReallyNotBlocked [])) -- See #5396 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 @@ -26,6 +26,7 @@ import Agda.TypeChecking.Irrelevance import {-# SOURCE #-} Agda.TypeChecking.Rules.Application +import {-# SOURCE #-} Agda.TypeChecking.Rules.Data ( checkDataSort ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Def import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Conversion @@ -40,6 +41,7 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty (prettyShow) +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Impossible @@ -58,7 +60,14 @@ pids <- asksTC envActiveProblems reportSDoc "tc.constr.add" 20 $ hsep [ "adding constraint" - , prettyTCM . PConstr pids unblock =<< buildClosure c ] + , prettyTCM . PConstr pids unblock =<< buildClosure c + , "unblocker: " , prettyTCM unblock + ] + -- Jesper, 2022-10-22: We should never block on a meta that is + -- already solved. However, currently this is not always + -- strictly adhered to. TODO: pull off the band-aid and + -- uncomment the following line. + -- whenM (anyM (Set.toList $ allBlockingMetas unblock) isInstantiatedMeta) __IMPOSSIBLE__ -- Need to reduce to reveal possibly blocking metas c <- reduce =<< instantiateFull c caseMaybeM (simpl c) {-no-} (addConstraint' unblock c) $ {-yes-} \ cs -> do @@ -192,16 +201,8 @@ stealConstraints pid handler --- | Wake constraints matching the given predicate (and aren't instance --- constraints if 'shouldPostponeInstanceSearch'). -wakeConstraints' :: (ProblemConstraint -> WakeUp) -> TCM () -wakeConstraints' p = do - skipInstance <- shouldPostponeInstanceSearch - let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c) - wakeConstraints $ wakeUpWhen (not . skip) p - -- | Wake up the constraints depending on the given meta. -wakeupConstraints :: MetaId -> TCM () +wakeupConstraints :: MonadMetaSolver m => MetaId -> m () wakeupConstraints x = do wakeConstraints' (wakeIfBlockedOnMeta x . constraintUnblocker) solveAwakeConstraints @@ -215,17 +216,11 @@ wakeup u | Set.null $ allBlockingProblems u = WakeUp | otherwise = DontWakeUp Nothing -solveAwakeConstraints :: (MonadConstraint m) => m () -solveAwakeConstraints = solveAwakeConstraints' False - -solveAwakeConstraints' :: (MonadConstraint m) => Bool -> m () -solveAwakeConstraints' = solveSomeAwakeConstraints (const True) - -- | Solve awake constraints matching the predicate. If the second argument is -- True solve constraints even if already 'isSolvingConstraints'. solveSomeAwakeConstraintsTCM :: (ProblemConstraint -> Bool) -> Bool -> TCM () solveSomeAwakeConstraintsTCM solveThis force = do - verboseS "profile.constraints" 10 $ liftTCM $ tickMax "max-open-constraints" . List.genericLength =<< getAllConstraints + whenProfile Profile.Constraints $ liftTCM $ tickMax "max-open-constraints" . List.genericLength =<< getAllConstraints whenM ((force ||) . not <$> isSolvingConstraints) $ nowSolvingConstraints $ do -- solveSizeConstraints -- Andreas, 2012-09-27 attacks size constrs too early -- Ulf, 2016-12-06: Don't inherit problems here! Stored constraints @@ -242,7 +237,7 @@ solveConstraintTCM :: Constraint -> TCM () solveConstraintTCM c = do - verboseS "profile.constraints" 10 $ liftTCM $ tick "attempted-constraints" + whenProfile Profile.Constraints $ liftTCM $ tick "attempted-constraints" verboseBracket "tc.constr.solve" 20 "solving constraint" $ do pids <- asksTC envActiveProblems reportSDoc "tc.constr.solve.constr" 20 $ text (show $ Set.toList pids) <+> prettyTCM c @@ -262,8 +257,8 @@ reportSDoc "tc.constr.unblock" 15 $ hsep ["not unblocking", prettyTCM m, "because", ifM (isFrozen m) "it's frozen" "meta assignments are turned off"] addConstraint alwaysUnblock $ UnBlock m) $ do - inst <- mvInstantiation <$> lookupMeta m - reportSDoc "tc.constr.unblock" 65 $ text ("unblocking a metavar yields the constraint: " ++ show inst) + inst <- lookupMetaInstantiation m + reportSDoc "tc.constr.unblock" 65 $ "unblocking a metavar yields the constraint:" <+> pretty inst case inst of BlockedConst t -> do reportSDoc "tc.constr.blocked" 15 $ @@ -296,9 +291,10 @@ solveConstraint_ (CheckLockedVars a b c d) = checkLockedVars a b c d solveConstraint_ (HasBiggerSort a) = hasBiggerSort a solveConstraint_ (HasPTSRule a b) = hasPTSRule a b +solveConstraint_ (CheckDataSort q s) = checkDataSort q s solveConstraint_ (CheckMetaInst m) = checkMetaInst m solveConstraint_ (CheckType t) = checkType t -solveConstraint_ (UsableAtModality mod t) = usableAtModality mod t +solveConstraint_ (UsableAtModality cc ms mod t) = usableAtModality' ms cc mod t checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term checkTypeCheckingProblem = \case diff --git a/src/full/Agda/TypeChecking/Constraints.hs-boot b/src/full/Agda/TypeChecking/Constraints.hs-boot --- a/src/full/Agda/TypeChecking/Constraints.hs-boot +++ b/src/full/Agda/TypeChecking/Constraints.hs-boot @@ -10,7 +10,6 @@ instance MonadConstraint TCM where -solveAwakeConstraints' :: MonadConstraint m => Bool -> m () noConstraints :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m) => m a -> m a ifNoConstraints_ :: TCM () -> TCM a -> (ProblemId -> TCM a) -> TCM a 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 @@ -8,12 +8,14 @@ -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) -import Data.Function +import Data.Function (on) import Data.Semigroup ((<>)) -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set +import Data.IntMap (IntMap) + +import qualified Data.List as List +import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet +import qualified Data.Set as Set import Agda.Syntax.Common import Agda.Syntax.Internal @@ -29,7 +31,7 @@ import qualified Agda.TypeChecking.SyntacticEquality as SynEq import Agda.TypeChecking.Telescope import Agda.TypeChecking.Constraints -import Agda.TypeChecking.Conversion.Pure (pureCompareAs) +import Agda.TypeChecking.Conversion.Pure (pureCompareAs, runPureConversion) import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (infer) import Agda.TypeChecking.Forcing (isForced, nextIsForced) import Agda.TypeChecking.Free @@ -53,6 +55,9 @@ import Agda.Utils.Maybe import Agda.Utils.Permutation import Agda.Utils.Pretty (prettyShow) +import qualified Agda.Utils.ProfileOptions as Profile +import Agda.Utils.BoolSet (BoolSet) +import qualified Agda.Utils.BoolSet as BoolSet import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.WithDefault @@ -152,14 +157,17 @@ , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v , nest 2 $ prettyTCM a ] - -- Check syntactic equality. This actually saves us quite a bit of work. - ((u, v), equal) <- SynEq.checkSyntacticEquality u v + whenProfile Profile.Conversion $ tick "compare" + -- OLD CODE, traverses the *full* terms u v at each step, even if they -- are different somewhere. Leads to infeasibility in issue 854. -- (u, v) <- instantiateFull (u, v) -- let equal = u == v - if equal then verboseS "profile.sharing" 20 $ tick "equal terms" else do - verboseS "profile.sharing" 20 $ tick "unequal terms" + + -- Check syntactic equality. This actually saves us quite a bit of work. + SynEq.checkSyntacticEquality u v + (\_ _ -> whenProfile Profile.Conversion $ tick "compare equal") $ + \u v -> do reportSDoc "tc.conv.term" 15 $ sep $ [ "compareTerm (not syntactically equal)" , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v @@ -198,6 +206,7 @@ -- but irrelevant projections since they are applied to their parameters. if isJust $ isRelevantProjection_ def then fallback else do pol <- getPolarity' cmp f + whenProfile Profile.Conversion $ tick "compare first-order shortcut" compareElims pol [] (defType def) (Def f []) es es' `orelse` fallback _ -> fallback where @@ -209,9 +218,11 @@ , nest 2 $ prettyTCM (MetaV x es) <+> ":=" <+> prettyTCM v ] whenM (isInstantiatedMeta x) (patternViolation alwaysUnblock) -- Already instantiated, retry right away + whenProfile Profile.Conversion $ tick "compare meta shortcut" assignE dir x es v a $ compareAsDir dir a reportSDoc "tc.conv.term.shortcut" 50 $ "shortcut successful" $$ nest 2 ("result:" <+> (pretty =<< instantiate (MetaV x es))) + whenProfile Profile.Conversion $ tick "compare meta shortcut successful" -- Should be ok with catchError_ but catchError is much safer since we don't -- rethrow errors. orelse :: m () -> m () -> m () @@ -221,7 +232,8 @@ -- and run conversion check again. assignE :: (MonadConversion m) => CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> m ()) -> m () -assignE dir x es v a comp = assignWrapper dir x es v $ do +assignE dir x es v a comp = do + whenProfile Profile.Conversion $ tick "compare meta" case allApplyElims es of Just vs -> assignV dir x vs v a Nothing -> do @@ -241,7 +253,7 @@ comp w v Nothing -> do reportSLn "tc.conv.assign" 30 "eta expansion did not instantiate meta" - patternViolation (unblockOnAnyMetaIn (MetaV x es)) -- nothing happened, give up + patternViolation $ unblockOnMeta x -- nothing happened, give up compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m () compareAsDir dir a = dirToCmp (`compareAs'` a) dir @@ -263,6 +275,9 @@ isSize <- isJust <$> isSizeType a' (bs, s) <- reduceWithBlocker $ getSort a' mlvl <- getBuiltin' builtinLevel + reportSDoc "tc.conv.term" 40 $ fsep + [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' + , "at sort", prettyTCM s] reportSDoc "tc.conv.level" 60 $ nest 2 $ sep [ "a' =" <+> pretty a' , "mlvl =" <+> pretty mlvl @@ -277,11 +292,17 @@ b <- levelView n equalLevel a b a@Pi{} -> equalFun s a m n - Lam _ _ -> __IMPOSSIBLE__ + Lam _ _ -> do + reportSDoc "tc.conv.term.sort" 10 $ fsep + [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' + , "at sort", prettyTCM s + ] + __IMPOSSIBLE__ Def r es -> do isrec <- isEtaRecord r if isrec then do + whenProfile Profile.Conversion $ tick "compare at eta record" sig <- getSignature let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem @@ -303,24 +324,26 @@ mNeutral <- isNeutral m n <- reduceB n nNeutral <- isNeutral n - case (m, n) of - _ | isMeta m || isMeta n -> - compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n) - - _ | mNeutral && nNeutral -> do - -- Andreas 2011-03-23: (fixing issue 396) - -- if we are dealing with a singleton record, - -- we can succeed immediately - ifM (isSingletonRecordModuloRelevance r ps) (return ()) $ - -- do not eta-expand if comparing two neutrals - compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n) - _ -> do - (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m - (_ , n') <- etaExpandRecord r ps $ ignoreBlocking n - -- No subtyping on record terms - c <- getRecordConstructor r - -- Record constructors are covariant (see test/succeed/CovariantConstructors). - compareArgs (repeat $ polFromCmp cmp) [] (telePi_ tel __DUMMY_TYPE__) (Con c ConOSystem []) m' n' + 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 + whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral" + -- Andreas 2011-03-23: (fixing issue 396) + -- if we are dealing with a singleton record, + -- we can succeed immediately + let profUnitEta = whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral at unit" + ifM (isSingletonRecordModuloRelevance r ps) (profUnitEta) $ do + -- do not eta-expand if comparing two neutrals + compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n) + | otherwise -> do + whenProfile Profile.Conversion $ tick "compare at eta-record: eta-expanding" + (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m + (_ , n') <- etaExpandRecord r ps $ ignoreBlocking n + -- No subtyping on record terms + c <- getRecordConstructor r + -- Record constructors are covariant (see test/succeed/CovariantConstructors). + compareArgs (repeat $ polFromCmp cmp) [] (telePi_ tel __DUMMY_TYPE__) (Con c ConOSystem []) m' n' else (do pathview <- pathView a' equalPath pathview a' m n) @@ -328,21 +351,26 @@ where -- equality at function type (accounts for eta) equalFun :: (MonadConversion m) => Sort -> Term -> Term -> Term -> m () - equalFun s a@(Pi dom b) m n | domFinite dom = do + equalFun s a@(Pi dom b) m n | domIsFinite dom = do mp <- fmap getPrimName <$> getBuiltin' builtinIsOne + let asFn = El s (Pi (dom { domIsFinite = False }) b) case unEl $ unDom dom of Def q [Apply phi] - | Just q == mp -> compareTermOnFace cmp (unArg phi) (El s (Pi (dom {domFinite = False}) b)) m n - _ -> equalFun s (Pi (dom{domFinite = False}) b) m n - equalFun _ (Pi dom@Dom{domInfo = info} b) m n | not $ domFinite dom = do + | Just q == mp -> compareTermOnFace cmp (unArg phi) asFn m n + _ -> equalFun s (unEl asFn) m n + + equalFun _ (Pi dom@Dom{domInfo = info} b) m n = do + whenProfile Profile.Conversion $ tick "compare at function type" let name = suggests [ Suggestion b , Suggestion m , Suggestion n ] addContext (name, dom) $ compareTerm cmp (absBody b) m' n' where (m',n') = raise 1 (m,n) `apply` [Arg info $ var 0] + equalFun _ _ _ _ = __IMPOSSIBLE__ equalPath :: (MonadConversion m) => PathView -> Type -> Term -> Term -> m () equalPath (PathType s _ l a x y) _ m n = do + whenProfile Profile.Conversion $ tick "compare at path type" let name = "i" :: String interval <- el primInterval let (m',n') = raise 1 (m, n) `applyE` [IApply (raise 1 $ unArg x) (raise 1 $ unArg y) (var 0)] @@ -364,7 +392,23 @@ unglue <- prim_unglue let mkUnglue m = apply unglue $ map (setHiding Hidden) args ++ [argN m] reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n) - compareTermOnFace cmp (unArg phi) a' m n + + -- When φ is an interval expression which can be + -- decomposed into substitutions σ, then we also compare + -- the terms m[σ] = n[σ] at the type (Glue a φ _)[σ]. This + -- is because, under decomposing φ, the Glue type might + -- reduce. + phi' <- decomposeInterval' (unArg phi) + -- However if φ is *not* decomposable (e.g. because it is + -- a function application φ i, see Issue #5955), then we + -- do not recur, otherwise we'd just end up right back + -- here. + unless (IntMap.null (foldMap fst phi')) $ + compareTermOnFace cmp (unArg phi) a' m n + + -- And in the general case, we compare the glued things by + -- "eta": m and n are the same if they unglue to the same + -- thing. compareTerm cmp aty (mkUnglue m) (mkUnglue n) Def q es | Just q == mHComp, Just (sl:s:args@[phi,u,u0]) <- allApplyElims es , Sort (Type lvl) <- unArg s @@ -414,6 +458,7 @@ targ <- abortIfBlocked targ fromMaybeM __IMPOSSIBLE__ $ getDefType f targ + -- | Syntax directed equality on atomic values -- compareAtom :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m () @@ -427,15 +472,17 @@ , prettyTCM n , prettyTCM t ] + whenProfile Profile.Conversion $ tick "compare by reduction" + -- Are we currently defining mutual functions? Which? + currentMutuals <- maybe (pure Set.empty) (mutualNames <.> lookupMutualBlock) =<< asksTC envMutualBlock + -- Andreas: what happens if I cut out the eta expansion here? -- Answer: Triggers issue 245, does not resolve 348 (mb',nb') <- do mb' <- etaExpandBlocked =<< reduceB m nb' <- etaExpandBlocked =<< reduceB n return (mb', nb') - let getBlocker (Blocked b _) = b - getBlocker NotBlocked{} = neverUnblock - blocker = unblockOnEither (getBlocker mb') (getBlocker nb') + let blocker = unblockOnEither (getBlocker mb') (getBlocker nb') reportSLn "tc.conv.atom.size" 50 $ "term size after reduce: " ++ show (termSize $ ignoreBlocking mb', termSize $ ignoreBlocking nb') -- constructorForm changes literal to constructors @@ -468,48 +515,15 @@ , prettyTCM t ] reportSDoc "tc.conv.atom" 80 $ - "compareAtom" <+> fsep [ (text . show) mb <+> prettyTCM cmp - , (text . show) nb - , ":" <+> (text . show) t ] + "compareAtom" <+> fsep [ pretty mb <+> prettyTCM cmp + , pretty nb + , ":" <+> pretty t ] case (mb, nb) of -- equate two metas x and y. if y is the younger meta, -- try first y := x and then x := y _ | MetaV x xArgs <- ignoreBlocking mb, -- Can be either Blocked or NotBlocked depending on MetaV y yArgs <- ignoreBlocking nb -> -- envCompareBlocked check above. - if | x == y, cmpBlocked -> do - a <- metaType x - blockOnError (unblockOnMeta x) $ - compareElims [] [] a (MetaV x []) xArgs yArgs - | x == y -> blockOnError (unblockOnMeta x) $ - case intersectVars xArgs yArgs of - -- all relevant arguments are variables - Just kills -> do - -- kills is a list with 'True' for each different var - killResult <- killArgs kills x - case killResult of - NothingToPrune -> return () - PrunedEverything -> return () - PrunedNothing -> checkDefinitionalEquality - PrunedSomething -> checkDefinitionalEquality - -- not all relevant arguments are variables - Nothing -> checkDefinitionalEquality -- Check definitional equality on meta-variables - -- (same as for blocked terms) - | otherwise -> do - [p1, p2] <- mapM getMetaPriority [x,y] - -- First try the one with the highest priority. If that doesn't - -- work, try the low priority one. - let (solve1, solve2) - | (p1, x) > (p2, y) = (l1, r2) - | otherwise = (r1, l2) - where l1 = assign dir x xArgs n - r1 = assign rid y yArgs m - -- Careful: the first attempt might prune the low - -- priority meta! (Issue #2978) - l2 = ifM (isInstantiatedMeta x) (compareAsDir dir t m n) l1 - r2 = ifM (isInstantiatedMeta y) (compareAsDir rid t n m) r1 - - -- Unblock on both unblockers of solve1 and solve2 - catchPatternErr (`addOrUnblocker` solve2) solve1 + compareMetas cmp t x xArgs y yArgs -- one side a meta _ | MetaV x es <- ignoreBlocking mb -> assign dir x es n @@ -517,7 +531,8 @@ (Blocked{}, Blocked{}) | not cmpBlocked -> checkDefinitionalEquality (Blocked b _, _) | not cmpBlocked -> useInjectivity (fromCmp cmp) b t m n -- The blocked term goes first (_, Blocked b _) | not cmpBlocked -> useInjectivity (flipCmp $ fromCmp cmp) b t n m - _ -> blockOnError blocker $ do + bs -> do + blockOnError blocker $ do -- -- Andreas, 2013-10-20 put projection-like function -- -- into the spine, to make compareElims work. -- -- 'False' means: leave (Def f []) unchanged even for @@ -665,15 +680,63 @@ [ "t1 =" <+> prettyTCM t1 , "t2 =" <+> prettyTCM t2 ] - compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC $ + compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC errF $ compareType cmp (absBody b1) (absBody b2) where errH = typeError $ UnequalHiding t1 t2 errR = typeError $ UnequalRelevance cmp t1 t2 errQ = typeError $ UnequalQuantity cmp t1 t2 errC = typeError $ UnequalCohesion cmp t1 t2 + errF = typeError $ UnequalFiniteness cmp t1 t2 _ -> __IMPOSSIBLE__ +-- | Check whether @x xArgs `cmp` y yArgs@ +compareMetas :: MonadConversion m => Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> m () +compareMetas cmp t x xArgs y yArgs | x == y = blockOnError (unblockOnMeta x) $ do + cmpBlocked <- viewTC eCompareBlocked + let ok = return () + notOk = patternViolation neverUnblock + fallback = do + -- Fallback: check definitional equality + a <- metaType x + runPureConversion (compareElims [] [] a (MetaV x []) xArgs yArgs) >>= \case + Just{} -> ok + Nothing -> notOk + if | cmpBlocked -> do + a <- metaType x + compareElims [] [] a (MetaV x []) xArgs yArgs + | otherwise -> case intersectVars xArgs yArgs of + -- all relevant arguments are variables + Just kills -> do + -- kills is a list with 'True' for each different var + killResult <- killArgs kills x + case killResult of + NothingToPrune -> ok + PrunedEverything -> ok + PrunedNothing -> fallback + PrunedSomething -> fallback + -- not all relevant arguments are variables + Nothing -> fallback +compareMetas cmp t x xArgs y yArgs = do + [p1, p2] <- mapM getMetaPriority [x,y] + let dir = fromCmp cmp + rid = flipCmp dir -- The reverse direction. Bad name, I know. + retry = patternViolation alwaysUnblock + -- First try the one with the highest priority. If that doesn't + -- work, try the low priority one. + let (solve1, solve2) + | (p1, x) > (p2, y) = (l1, r2) + | otherwise = (r1, l2) + where l1 = assignE dir x xArgs (MetaV y yArgs) t $ \ _ _ -> retry + r1 = assignE rid y yArgs (MetaV x xArgs) t $ \ _ _ -> retry + -- Careful: the first attempt might prune the low + -- priority meta! (Issue #2978) + l2 = ifM (isInstantiatedMeta x) retry l1 + r2 = ifM (isInstantiatedMeta y) retry r1 + + -- Unblock on both unblockers of solve1 and solve2 + catchPatternErr (`addOrUnblocker` solve2) solve1 + -- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@. compareDom :: (MonadConversion m , Free c) => Comparison -- ^ @cmp@ The comparison direction @@ -685,18 +748,18 @@ -> m () -- ^ Continuation if mismatch in 'Relevance'. -> m () -- ^ Continuation if mismatch in 'Quantity'. -> m () -- ^ Continuation if mismatch in 'Cohesion'. + -> m () -- ^ Continuation if mismatch in 'annFinite'. -> m () -- ^ Continuation if comparison is successful. -> m () compareDom cmp0 dom1@(Dom{domInfo = i1, unDom = a1}) dom2@(Dom{domInfo = i2, unDom = a2}) - b1 b2 errH errR errQ errC cont = do - hasSubtyping <- collapseDefault . optSubtyping <$> pragmaOptions - let cmp = if hasSubtyping then cmp0 else CmpEq + b1 b2 errH errR errQ errC errF cont = do if | not $ sameHiding dom1 dom2 -> errH - | not $ compareRelevance cmp (getRelevance dom1) (getRelevance dom2) -> errR - | not $ compareQuantity cmp (getQuantity dom1) (getQuantity dom2) -> errQ - | not $ compareCohesion cmp (getCohesion dom1) (getCohesion dom2) -> errC + | not $ (==) (getRelevance dom1) (getRelevance dom2) -> errR + | not $ sameQuantity (getQuantity dom1) (getQuantity dom2) -> errQ + | not $ sameCohesion (getCohesion dom1) (getCohesion dom2) -> errC + | not $ domIsFinite dom1 == domIsFinite dom2 -> errF | otherwise -> do let r = max (getRelevance dom1) (getRelevance dom2) -- take "most irrelevant" @@ -715,18 +778,6 @@ -- Only the domain type in context will be blocked. -- But see issue #1258. -compareRelevance :: Comparison -> Relevance -> Relevance -> Bool -compareRelevance CmpEq = (==) -compareRelevance CmpLeq = (<=) - -compareQuantity :: Comparison -> Quantity -> Quantity -> Bool -compareQuantity CmpEq = sameQuantity -compareQuantity CmpLeq = moreQuantity - -compareCohesion :: Comparison -> Cohesion -> Cohesion -> Bool -compareCohesion CmpEq = sameCohesion -compareCohesion CmpLeq = moreCohesion - -- | When comparing argument spines (in compareElims) where the first arguments -- don't match, we keep going, substituting the anti-unification of the two -- terms in the telescope. More precisely: @@ -746,8 +797,7 @@ -- #2384. antiUnify :: MonadConversion m => ProblemId -> Type -> Term -> Term -> m Term antiUnify pid a u v = do - ((u, v), eq) <- SynEq.checkSyntacticEquality u v - if eq then return u else do + SynEq.checkSyntacticEquality u v (\u _ -> return u) $ \u v -> do (u, v) <- reduce (u, v) reportSDoc "tc.conv.antiUnify" 30 $ vcat [ "antiUnify" @@ -1000,12 +1050,14 @@ [ nest 2 $ "v =" <+> pretty v , nest 2 $ "w =" <+> pretty w ] + whenProfile Profile.Conversion $ tick "compare irrelevant" try v w $ try w v $ return () where try (MetaV x es) w fallback = do - mv <- lookupMeta x - let rel = getMetaRelevance mv - inst = case mvInstantiation mv of + mi <- lookupMetaInstantiation x + mm <- lookupMetaModality x + let rel = getRelevance mm + inst = case mi of InstV{} -> True _ -> False reportSDoc "tc.conv.irr" 20 $ vcat @@ -1171,28 +1223,51 @@ -- unrelated to the other universes. -- leqSort :: forall m. MonadConversion m => Sort -> Sort -> m () -leqSort s1 s2 = (catchConstraint (SortCmp CmpLeq s1 s2) :: m () -> m ()) $ do - (s1,s2) <- reduce (s1,s2) - let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) (SortCmp CmpLeq s1 s2) - no = typeError $ NotLeqSort s1 s2 - yes = return () - synEq = ifNotM (optSyntacticEquality <$> pragmaOptions) postpone $ do - ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2 - if | equal -> yes - | otherwise -> postpone +leqSort s1 s2 = do reportSDoc "tc.conv.sort" 30 $ sep [ "leqSort" , nest 2 $ fsep [ prettyTCM s1 <+> "=<" , prettyTCM s2 ] ] - propEnabled <- isPropEnabled - typeInTypeEnabled <- typeInType - omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions + reportSDoc "tc.conv.sort" 60 $ + sep [ "leqSort" + , nest 2 $ fsep [ pretty s1 <+> "=<" + , pretty s2 ] + ] + whenProfile Profile.Conversion $ tick "compare sorts" - let fvsRHS = (`IntSet.member` allFreeVars s2) - badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS + SynEq.checkSyntacticEquality s1 s2 (\_ _ -> return ()) $ \s1 s2 -> do - case (s1, s2) of + s1b <- reduceB s1 + s2b <- reduceB s2 + + let (s1,s2) = (ignoreBlocking s1b , ignoreBlocking s2b) + blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b) + postpone = patternViolation blocker + + let postponeIfBlocked = catchPatternErr $ \blocker -> do + if | blocker == neverUnblock -> typeError $ NotLeqSort s1 s2 + | otherwise -> do + reportSDoc "tc.conv.sort" 30 $ vcat + [ "Postponing constraint" + , nest 2 $ fsep [ prettyTCM s1 <+> "=<" + , prettyTCM s2 ] + ] + reportSDoc "tc.conv.sort" 60 $ vcat + [ "Postponing constraint" + , nest 2 $ fsep [ pretty s1 <+> "=<" + , pretty s2 ] + ] + addConstraint blocker $ SortCmp CmpLeq s1 s2 + + propEnabled <- isPropEnabled + typeInTypeEnabled <- typeInType + omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions + + let fvsRHS = (`IntSet.member` allFreeVars s2) + badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS + + postponeIfBlocked $ case (s1, s2) of -- Andreas, 2018-09-03: crash on dummy sort (DummyS s, _) -> impossibleSort s (_, DummyS s) -> impossibleSort s @@ -1232,15 +1307,16 @@ (SSet{} , Inf IsStrict _) -> yes (SSet{} , Inf IsFibrant _) -> no - -- @SizeUniv@ and @Prop0@ are bottom sorts. + -- @LockUniv@, @IntervalUniv@, @SizeUniv@, and @Prop0@ are bottom sorts. -- So is @Set0@ if @Prop@ is not enabled. (_ , LockUniv) -> equalSort s1 s2 + (_ , IntervalUniv) -> equalSort s1 s2 (_ , SizeUniv) -> equalSort s1 s2 (_ , Prop (Max 0 [])) -> equalSort s1 s2 (_ , Type (Max 0 [])) | not propEnabled -> equalSort s1 s2 - -- SizeUniv is unrelated to any @Set l@ or @Prop l@ + -- @SizeUniv@ and @LockUniv@ are unrelated to any @Set l@ or @Prop l@ (SizeUniv, Type{} ) -> no (SizeUniv, Prop{} ) -> no (SizeUniv , Inf{} ) -> no @@ -1250,27 +1326,37 @@ (LockUniv , Inf{} ) -> no (LockUniv, SSet{} ) -> no + -- @IntervalUniv@ is below @SSet l@, but not @Set l@ or @Prop l@ + (IntervalUniv, Type{}) -> no + (IntervalUniv, Prop{}) -> no + (IntervalUniv , Inf IsStrict _) -> yes + (IntervalUniv , Inf IsFibrant _) -> no + (IntervalUniv , SSet b) -> leqLevel (ClosedLevel 0) b + -- If the first sort is a small sort that rigidly depends on a -- variable and the second sort does not mention this variable, -- the second sort must be at least @Setω@. - (_ , _ ) | Just (True,f) <- isSmallSort s1 , badRigid -> leqSort (Inf f 0) s2 + (_ , _ ) | Right (SmallSort f) <- sizeOfSort s1 , badRigid -> leqSort (Inf f 0) s2 -- PiSort, FunSort, UnivSort and MetaS might reduce once we instantiate -- more metas, so we postpone. - (PiSort{}, _ ) -> synEq - (_ , PiSort{}) -> synEq - (FunSort{}, _ ) -> synEq - (_ , FunSort{}) -> synEq - (UnivSort{}, _ ) -> synEq - (_ , UnivSort{}) -> synEq - (MetaS{} , _ ) -> synEq - (_ , MetaS{} ) -> synEq + (PiSort{}, _ ) -> postpone + (_ , PiSort{}) -> postpone + (FunSort{}, _ ) -> postpone + (_ , FunSort{}) -> postpone + (UnivSort{}, _ ) -> postpone + (_ , UnivSort{}) -> postpone + (MetaS{} , _ ) -> postpone + (_ , MetaS{} ) -> postpone -- DefS are postulated sorts, so they do not reduce. - (DefS{} , _ ) -> synEq - (_ , DefS{}) -> synEq + (DefS{} , _ ) -> no + (_ , DefS{}) -> no where + no = patternViolation neverUnblock + yes = return () + leqFib IsFibrant _ = True leqFib IsStrict IsStrict = True leqFib _ _ = False @@ -1287,9 +1373,15 @@ "compareLevel" <+> sep [ prettyTCM a <+> "=<" , prettyTCM b ] + whenProfile Profile.Conversion $ tick "compare levels" - (a, b) <- reduce (a, b) - ((a, b), equal) <- SynEq.checkSyntacticEquality a b + (a, b) <- normalise (a, b) + SynEq.checkSyntacticEquality' a b + (\_ _ -> + reportSDoc "tc.conv.level" 60 + "checkSyntacticEquality returns True") $ \a b -> do + reportSDoc "tc.conv.level" 60 + "checkSyntacticEquality returns False" let notok = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b) postpone = patternViolation (unblockOnAnyMetaIn (a, b)) @@ -1298,10 +1390,6 @@ TypeError{} -> notok err -> throwError err - reportSDoc "tc.conv.level" 60 $ - "checkSyntacticEquality returns" <+> prettyTCM equal - unless equal $ do - cumulativity <- optCumulativity <$> pragmaOptions areWeComputingOverlap <- viewTC eConflComputingOverlap reportSDoc "tc.conv.level" 40 $ @@ -1369,7 +1457,7 @@ , not areWeComputingOverlap , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map . fmap) ignoreBlocking (List1.toList bs) , null bs' || noMetas (Level a , unSingleLevels bs') -> do - mv <- lookupMeta x + mv <- lookupLocalMeta x -- Jesper, 2019-10-13: abort if this is an interaction -- meta or a generalizable meta abort <- (isJust <$> isInteractionMeta x) `or2M` @@ -1420,6 +1508,7 @@ equalLevel :: forall m. MonadConversion m => Level -> Level -> m () equalLevel a b = do reportSDoc "tc.conv.level" 50 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ] + whenProfile Profile.Conversion $ tick "compare levels" -- Andreas, 2013-10-31 remove common terms (that don't contain metas!) -- THAT's actually UNSOUND when metas are instantiated, because -- max a b == max a c does not imply b == c @@ -1436,22 +1525,27 @@ ] ] ] + reportSDoc "tc.conv.level" 80 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ] - (a, b) <- reduce (a, b) - ((a, b), equal) <- SynEq.checkSyntacticEquality a b - reportSDoc "tc.conv.level" 60 $ - "checkSyntacticEquality returns" <+> prettyTCM equal - unless equal $ do + (a, b) <- normalise (a, b) -- Jesper, 2014-02-02 remove terms that certainly do not contribute -- to the maximum let (a', b') = removeSubsumed a b + SynEq.checkSyntacticEquality' a' b' + (\_ _ -> + reportSDoc "tc.conv.level" 60 + "checkSyntacticEquality returns True") $ \a b -> do + + reportSDoc "tc.conv.level" 60 "checkSyntacticEquality returns False" + let notok = unlessM typeInType notOk notOk = typeError $ UnequalLevel CmpEq a' b' postpone = do reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a' <+> "==") 0 (pretty b') - patternViolation (unblockOnAnyMetaIn (a', b')) + blocker <- unblockOnAnyMetaIn <$> instantiateFull (a', b') + patternViolation blocker reportSDoc "tc.conv.level" 50 $ sep [ "equalLevel (w/o subsumed)" @@ -1465,18 +1559,18 @@ bs = levelMaxView b' reportSDoc "tc.conv.level" 50 $ sep [ text "equalLevel" - , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as + , vcat [ nest 2 $ sep [ prettyList_ $ fmap (prettyTCM . unSingleLevel) as , "==" - , prettyList_ $ fmap (pretty . unSingleLevel) bs + , prettyList_ $ fmap (prettyTCM . unSingleLevel) bs ] ] ] reportSDoc "tc.conv.level" 80 $ sep [ text "equalLevel" - , vcat [ nest 2 $ sep [ prettyList_ $ fmap (text . show . unSingleLevel) as + , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as , "==" - , prettyList_ $ fmap (text . show . unSingleLevel) bs + , prettyList_ $ fmap (pretty . unSingleLevel) bs ] ] ] @@ -1512,8 +1606,8 @@ | MetaV x as' <- ignoreBlocking a , MetaV y bs' <- ignoreBlocking b , k == l -> do - lvl <- levelType - equalAtom (AsTermsOf lvl) (MetaV x as') (MetaV y bs') + lvl <- levelType' + compareMetas CmpEq (AsTermsOf lvl) x as' y bs' (SinglePlus (Plus k a) :| [] , _) | MetaV x as' <- ignoreBlocking a , Just b' <- subLevel k b -> meta x as' b' @@ -1540,19 +1634,19 @@ List1.zipWithM_ ((===) `on` levelTm . unSingleLevel . fmap ignoreBlocking) as bs -- more cases? - _ | noMetas (Level a , Level b) -> notok - | otherwise -> postpone + _ | noMetas (a , b) -> notok + | otherwise -> postpone where a === b = unlessM typeInType $ do - lvl <- levelType + lvl <- levelType' equalAtom (AsTermsOf lvl) a b -- perform assignment (MetaV x as) := b meta x as b = do reportSLn "tc.meta.level" 30 $ "Assigning meta level" reportSDoc "tc.meta.level" 50 $ "meta" <+> sep [prettyList $ map pretty as, pretty b] - lvl <- levelType + lvl <- levelType' assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms isNeutral (SinglePlus (Plus _ NotBlocked{})) = True @@ -1584,26 +1678,44 @@ -- | Check that the first sort equal to the second. equalSort :: forall m. MonadConversion m => Sort -> Sort -> m () equalSort s1 s2 = do - catchConstraint (SortCmp CmpEq s1 s2) $ do - (s1,s2) <- reduce (s1,s2) - let yes = return () - no = typeError $ UnequalSorts s1 s2 + reportSDoc "tc.conv.sort" 30 $ sep + [ "equalSort" + , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> "==" + , prettyTCM s2 ] + ] + ] + reportSDoc "tc.conv.sort" 60 $ sep + [ "equalSort" + , vcat [ nest 2 $ fsep [ pretty s1 <+> "==" + , pretty s2 ] + ] + ] + whenProfile Profile.Conversion $ tick "compare sorts" - reportSDoc "tc.conv.sort" 30 $ sep - [ "equalSort" - , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> "==" - , prettyTCM s2 ] - , nest 2 $ fsep [ pretty s1 <+> "==" - , pretty s2 ] - ] - ] + SynEq.checkSyntacticEquality s1 s2 (\_ _ -> return ()) $ \s1 s2 -> do - propEnabled <- isPropEnabled - typeInTypeEnabled <- typeInType - omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions + s1b <- reduceB s1 + s2b <- reduceB s2 - case (s1, s2) of + let (s1,s2) = (ignoreBlocking s1b, ignoreBlocking s2b) + blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b) + let postponeIfBlocked = catchPatternErr $ \blocker -> + if | blocker == neverUnblock -> typeError $ UnequalSorts s1 s2 + | otherwise -> do + reportSDoc "tc.conv.sort" 30 $ vcat + [ "Postponing constraint" + , nest 2 $ fsep [ prettyTCM s1 <+> "==" + , prettyTCM s2 ] + ] + addConstraint blocker $ SortCmp CmpEq s1 s2 + + propEnabled <- isPropEnabled + typeInTypeEnabled <- typeInType + omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions + + postponeIfBlocked $ case (s1, s2) of + -- Andreas, 2018-09-03: crash on dummy sort (DummyS s, _) -> impossibleSort s (_, DummyS s) -> impossibleSort s @@ -1611,10 +1723,7 @@ -- one side is a meta sort: try to instantiate -- In case both sides are meta sorts, instantiate the -- bigger (i.e. more recent) one. - (MetaS x es , MetaS y es') - | x == y -> synEq s1 s2 - | x < y -> meta y es' s1 - | otherwise -> meta x es s2 + (MetaS x es , MetaS y es') -> compareMetas CmpEq AsTypes x es y es' (MetaS x es , _ ) -> meta x es s2 (_ , MetaS x es ) -> meta x es s1 @@ -1622,6 +1731,7 @@ (Type a , Type b ) -> equalLevel a b `catchInequalLevel` no (SizeUniv , SizeUniv ) -> yes (LockUniv , LockUniv ) -> yes + (IntervalUniv , IntervalUniv) -> yes (Prop a , Prop b ) -> equalLevel a b `catchInequalLevel` no (Inf f m , Inf f' n ) -> if f == f' && (m == n || typeInTypeEnabled || omegaInOmegaEnabled) then yes else no @@ -1634,26 +1744,32 @@ | typeInTypeEnabled -> yes -- equating @PiSort a b@ to another sort - (s1 , PiSort a b c) -> piSortEquals s1 a b c - (PiSort a b c , s2) -> piSortEquals s2 a b c + (s1 , PiSort a b c) -> piSortEquals s1 a b c blocker + (PiSort a b c , s2) -> piSortEquals s2 a b c blocker -- equating @FunSort a b@ to another sort - (s1 , FunSort a b) -> funSortEquals s1 a b - (FunSort a b , s2) -> funSortEquals s2 a b + (s1 , FunSort a b) -> funSortEquals s1 a b blocker + (FunSort a b , s2) -> funSortEquals s2 a b blocker -- equating @UnivSort s@ to another sort - (s1 , UnivSort s2) -> univSortEquals s1 s2 - (UnivSort s1 , s2 ) -> univSortEquals s2 s1 + (s1 , UnivSort s2) -> univSortEquals s1 s2 blocker + (UnivSort s1 , s2 ) -> univSortEquals s2 s1 blocker -- postulated sorts can only be equal if they have the same head (DefS d es , DefS d' es') - | d == d' -> synEq s1 s2 + | d == d' -> do + pol <- getPolarity' CmpEq d + a <- computeElimHeadType d es es' + compareElims pol [] a (Def d []) es es' | otherwise -> no -- any other combinations of sorts are not equal (_ , _ ) -> no where + yes = return () + no = patternViolation neverUnblock + -- perform assignment (MetaS x es) := s meta :: MetaId -> [Elim' Term] -> Sort -> m () meta x es s = do @@ -1661,27 +1777,16 @@ reportSDoc "tc.meta.sort" 50 $ "meta" <+> sep [pretty x, prettyList $ map pretty es, pretty s] assignE DirEq x es (Sort s) AsTypes __IMPOSSIBLE__ - -- fall back to syntactic equality check, postpone if it fails - synEq :: Sort -> Sort -> m () - synEq s1 s2 = do - let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) $ SortCmp CmpEq s1 s2 - doSynEq <- optSyntacticEquality <$> pragmaOptions - if | doSynEq -> do - ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2 - if | equal -> return () - | otherwise -> postpone - | otherwise -> postpone - -- Equate a sort @s1@ to @univSort s2@ -- Precondition: @s1@ and @univSort s2@ are already reduced. - univSortEquals :: Sort -> Sort -> m () - univSortEquals s1 s2 = do + univSortEquals :: Sort -> Sort -> Blocker -> m () + univSortEquals s1 s2 blocker = do reportSDoc "tc.conv.sort" 35 $ vcat [ "univSortEquals" , " s1 =" <+> prettyTCM s1 , " s2 =" <+> prettyTCM s2 ] - let no = typeError $ UnequalSorts s1 (UnivSort s2) + let postpone = patternViolation blocker case s1 of -- @Set l1@ is the successor sort of either @Set l2@ or -- @Prop l2@ where @l1 == lsuc l2@. @@ -1701,7 +1806,7 @@ return l2 equalSort (Type l2) s2 -- Otherwise we postpone - | otherwise -> synEq (Type l1) (UnivSort s2) + | otherwise -> postpone -- @Setωᵢ@ is a successor sort if n > 0, or if -- --type-in-type or --omega-in-omega is enabled. Inf f n | n > 0 -> equalSort (Inf f $ n - 1) s2 @@ -1713,14 +1818,14 @@ Prop{} -> no SizeUniv{} -> no -- Anything else: postpone - _ -> synEq s1 (UnivSort s2) + _ -> postpone -- Equate a sort @s@ to @piSort a s1 s2@ -- Precondition: @s@ and @piSort a s1 s2@ are already reduced. - piSortEquals :: Sort -> Dom Term -> Sort -> Abs Sort -> m () - piSortEquals s a s1 NoAbs{} = __IMPOSSIBLE__ - piSortEquals s a s1 s2Abs@(Abs x s2) = do + piSortEquals :: Sort -> Dom Term -> Sort -> Abs Sort -> Blocker -> m () + piSortEquals s a s1 NoAbs{} blocker = __IMPOSSIBLE__ + piSortEquals s a s1 s2Abs@(Abs x s2) blocker = do let adom = El s1 <$> a reportSDoc "tc.conv.sort" 35 $ vcat [ "piSortEquals" @@ -1730,22 +1835,23 @@ , " s2 =" <+> addContext (x,adom) (prettyTCM s2) ] propEnabled <- isPropEnabled + let postpone = patternViolation blocker -- If @s2@ is dependent, then @piSort a s1 s2@ computes to -- @Setωi@. Hence, if @s@ is small, then @s2@ -- cannot be dependent. - if | Just (True,_) <- isSmallSort s -> do + if | isSmallSort s -> do -- We force @s2@ to be non-dependent by unifying it with -- a fresh meta that does not depend on @x : a@ s2' <- newSortMeta addContext (x , adom) $ equalSort s2 (raise 1 s2') - funSortEquals s s1 s2' + funSortEquals s s1 s2' blocker -- Otherwise: postpone - | otherwise -> synEq (PiSort a s1 s2Abs) s + | otherwise -> postpone -- Equate a sort @s@ to @funSort s1 s2@ -- Precondition: @s@ and @funSort s1 s2@ are already reduced - funSortEquals :: Sort -> Sort -> Sort -> m () - funSortEquals s0 s1 s2 = do + funSortEquals :: Sort -> Sort -> Sort -> Blocker -> m () + funSortEquals s0 s1 s2 blocker = do reportSDoc "tc.conv.sort" 35 $ vcat [ "funSortEquals" , " s0 =" <+> prettyTCM s0 @@ -1754,30 +1860,40 @@ ] propEnabled <- isPropEnabled sizedTypesEnabled <- sizedTypesOption + cubicalEnabled <- isJust . optCubical <$> pragmaOptions + let postpone = patternViolation blocker case s0 of -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must -- be @Setωᵢ@. - Inf f n | Just (True,_) <- isSmallSort s1, Just (True,_) <- isSmallSort s2 -> do + Inf f n | isSmallSort s1, isSmallSort s2 -> do typeError $ UnequalSorts s0 (FunSort s1 s2) - | Just (True, IsFibrant) <- isSmallSort s1 -> equalSort (Inf f n) s2 - | Just (True, IsFibrant) <- isSmallSort s2 -> equalSort (Inf f n) s1 + | Right (SmallSort IsFibrant) <- sizeOfSort s1 -> equalSort (Inf f n) s2 + | Right (SmallSort IsFibrant) <- sizeOfSort s2 -> equalSort (Inf f n) s1 -- TODO 2ltt: handle IsStrict cases. - | otherwise -> synEq s0 (FunSort s1 s2) + | otherwise -> postpone -- If @Set l == funSort s1 s2@, then @s2@ must be of the - -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@, or - -- @SizeUniv@. + -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@, + -- @SizeUniv@, or @IUniv@. Type l -> do l2 <- forceType s2 -- We must have @l2 =< l@, this might help us to solve -- more constraints (in particular when @l == 0@). leqLevel l2 l + -- Jesper, 2022-10-22, #6211: the operations `forceType` + -- and `leqLevel` above might have instantiated some + -- metas, so we need to reduce s1 again to get an + -- up-to-date Blocker. + s1b <- reduceB s1 + let s1 = ignoreBlocking s1b + blocker = getBlocker s1b -- Jesper, 2019-12-27: SizeUniv is disabled at the moment. - if | {- sizedTypesEnabled || -} propEnabled -> case funSort' s1 (Type l2) of + if | {- sizedTypesEnabled || -} propEnabled || cubicalEnabled -> + case funSort' s1 (Type l2) of -- If the work we did makes the @funSort@ compute, -- continue working. - Just s -> equalSort (Type l) s + Right s -> equalSort (Type l) s -- Otherwise: postpone - Nothing -> synEq (Type l) (FunSort s1 $ Type l2) + Left{} -> patternViolation blocker -- If both Prop and sized types are disabled, only the -- case @s1 == Set l1@ remains. | otherwise -> do @@ -1789,16 +1905,19 @@ Prop l -> do l2 <- forceProp s2 leqLevel l2 l + s1b <- reduceB s1 + let s1 = ignoreBlocking s1b + blocker = getBlocker s1b case funSort' s1 (Prop l2) of -- If the work we did makes the @funSort@ compute, -- continue working. - Just s -> equalSort (Prop l) s + Right s -> equalSort (Prop l) s -- Otherwise: postpone - Nothing -> synEq (Prop l) (FunSort s1 $ Prop l2) + Left _ -> patternViolation blocker -- We have @SizeUniv == funSort s1 s2@ iff @s2 == SizeUniv@ SizeUniv -> equalSort SizeUniv s2 -- Anything else: postpone - _ -> synEq s0 (FunSort s1 s2) + _ -> postpone -- check if the given sort @s0@ is a (closed) bottom sort -- i.e. @piSort a b == s0@ implies @b == s0@. @@ -1854,7 +1973,12 @@ -- xs <- mapM (mapM (\ (i,b) -> (,) i <$> intervalUnview (if b then IOne else IZero))) as -- return xs -forallFaceMaps :: MonadConversion m => Term -> (Map.Map Int Bool -> Blocker -> Term -> m a) -> (Substitution -> m a) -> m [a] +forallFaceMaps + :: MonadConversion m + => Term + -> (IntMap Bool -> Blocker -> Term -> m a) + -> (IntMap Bool -> Substitution -> m a) + -> m [a] forallFaceMaps t kb k = do reportSDoc "conv.forall" 20 $ fsep ["forallFaceMaps" @@ -1867,7 +1991,7 @@ return (\b -> if b then io else iz) forM as $ \ (ms,ts) -> do ifBlockeds ts (kb ms) $ \ _ _ -> do - let xs = map (second boolToI) $ Map.toAscList ms + let xs = map (second boolToI) $ IntMap.toAscList ms cxt <- getContext reportSDoc "conv.forall" 20 $ fsep ["substContextN" @@ -1882,16 +2006,16 @@ tel <- getContextTelescope m <- currentModule sub <- getModuleParameterSub m - reportS "conv.forall" 10 - [ replicate 10 '-' - , show (envCurrentModule $ clEnv cl) - , show (envLetBindings $ clEnv cl) - , show tel -- (toTelescope $ envContext $ clEnv cl) - , show sigma - , show m - , show sub + reportSDoc "conv.forall" 30 $ vcat + [ text (replicate 10 '-') + , prettyTCM (envCurrentModule $ clEnv cl) + -- , prettyTCM (envLetBindings $ clEnv cl) + , prettyTCM tel -- (toTelescope $ envContext $ clEnv cl) + , prettyTCM sigma + , prettyTCM m + , prettyTCM sub ] - k sigma + k ms sigma where -- TODO Andrea: inefficient because we try to reduce the ts which we know are in whnf ifBlockeds ts blocked unblocked = do @@ -1931,6 +2055,7 @@ compareInterval cmp i t u = do reportSDoc "tc.conv.interval" 15 $ sep [ "{ compareInterval" <+> prettyTCM t <+> "=" <+> prettyTCM u ] + whenProfile Profile.Conversion $ tick "compare at interval type" tb <- reduceB t ub <- reduceB u let t = ignoreBlocking tb @@ -1960,7 +2085,7 @@ isBlocked NotBlocked{} = False -type Conj = (Map.Map Int (Set.Set Bool),[Term]) +type Conj = (IntMap BoolSet, [Term]) isCanonical :: [Conj] -> Bool isCanonical = all (null . snd) @@ -1979,10 +2104,10 @@ -- ' {q_j | j} ⊆ {r_i | i} leqConj :: MonadConversion m => Conj -> Conj -> m Bool leqConj (rs, rst) (qs, qst) = do - if toSet qs `Set.isSubsetOf` toSet rs + if IntMap.isSubmapOfBy BoolSet.isSubsetOf qs rs then do interval <- - elSSet $ fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval + El IntervalUniv . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval -- we don't want to generate new constraints here because -- 1. in some situations the same constraint would get generated twice. -- 2. unless things are completely accepted we are going to @@ -1993,24 +2118,26 @@ listSubset qst rst else return False - where - toSet m = Set.fromList [(i, b) | (i, bs) <- Map.toList m, b <- Set.toList bs] -- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m () equalTermOnFace = compareTermOnFace CmpEq compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m () -compareTermOnFace = compareTermOnFace' compareTerm +compareTermOnFace = compareTermOnFace' (const compareTerm) -compareTermOnFace' :: MonadConversion m => (Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m () +compareTermOnFace' + :: MonadConversion m + => (Substitution -> Comparison -> Type -> Term -> Term -> m ()) + -> Comparison -> Term -> Type -> Term -> Term -> m () compareTermOnFace' k cmp phi ty u v = do reportSDoc "tc.conv.face" 40 $ text "compareTermOnFace:" <+> pretty phi <+> "|-" <+> pretty u <+> "==" <+> pretty v <+> ":" <+> pretty ty + whenProfile Profile.Conversion $ tick "compare at face type" phi <- reduce phi - _ <- forallFaceMaps phi postponed - $ \ alpha -> k cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v) + _ <- forallFaceMaps phi postponed $ \ faces alpha -> + k alpha cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v) return () where postponed ms blocker psi = do @@ -2019,7 +2146,7 @@ ineg <- cl $ getPrimitiveTerm "primINeg" psi <- open psi let phi = foldr (\ (i,b) r -> do i <- open (var i); pure imin <@> (if b then i else pure ineg <@> i) <@> r) - psi (Map.toList ms) -- TODO Andrea: make a view? + psi (IntMap.toList ms) -- TODO Andrea: make a view? phi addConstraint blocker (ValueCmpOnFace cmp phi ty u v) diff --git a/src/full/Agda/TypeChecking/Conversion/Pure.hs b/src/full/Agda/TypeChecking/Conversion/Pure.hs --- a/src/full/Agda/TypeChecking/Conversion/Pure.hs +++ b/src/full/Agda/TypeChecking/Conversion/Pure.hs @@ -56,21 +56,31 @@ runPureConversion :: (MonadBlock m, PureTCM m, Show a) => PureConversionT m a -> m (Maybe a) -runPureConversion (PureConversionT m) = locallyTC eCompareBlocked (const True) $ do +runPureConversion (PureConversionT m) = locallyTC eCompareBlocked (const True) $ + verboseBracket "tc.conv.pure" 40 "runPureConversion" $ do i <- useR stFreshInt pid <- useR stFreshProblemId nid <- useR stFreshNameId let frsh = FreshThings i pid nid result <- fst <$> runStateT (runExceptT m) frsh - reportSLn "tc.conv.pure" 40 $ "runPureConversion result: " ++ show result case result of Left (PatternErr block) - | block == neverUnblock -> return Nothing - | otherwise -> patternViolation block - Left TypeError{} -> return Nothing + | block == neverUnblock -> do + debugResult "stuck" + return Nothing + | otherwise -> do + debugResult $ "blocked on" <+> prettyTCM block + patternViolation block + Left TypeError{} -> do + debugResult "type error" + return Nothing Left Exception{} -> __IMPOSSIBLE__ Left IOException{} -> __IMPOSSIBLE__ - Right x -> return $ Just x + Right x -> do + debugResult "success" + return $ Just x + where + debugResult msg = reportSDoc "tc.conv.pure" 40 $ "runPureConversion result: " <+> msg instance MonadTrans PureConversionT where lift = PureConversionT . lift . lift 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 @@ -1,4 +1,5 @@ {-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeApplications #-} {-| Coverage checking, case splitting, and splitting for refine tactics. @@ -46,7 +47,10 @@ import Agda.TypeChecking.Coverage.Match import Agda.TypeChecking.Coverage.SplitTree +import Agda.TypeChecking.Coverage.SplitClause +import Agda.TypeChecking.Coverage.Cubical + import Agda.TypeChecking.Conversion (tryConversion, equalType) import Agda.TypeChecking.Datatypes (getConForm) import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType ) @@ -72,60 +76,15 @@ import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size +import Agda.Utils.Tuple import Agda.Utils.WithDefault import Agda.Utils.Impossible +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Control.Monad.State -data SplitClause = SClause - { scTel :: Telescope - -- ^ Type of variables in @scPats@. - , scPats :: [NamedArg SplitPattern] - -- ^ The patterns leading to the currently considered branch of - -- the split tree. - , scSubst :: Substitution' SplitPattern - -- ^ Substitution from 'scTel' to old context. - -- Only needed directly after split on variable: - -- * To update 'scTarget' - -- * To rename other split variables when splitting on - -- multiple variables. - -- @scSubst@ is not ``transitive'', i.e., does not record - -- the substitution from the original context to 'scTel' - -- over a series of splits. It is freshly computed - -- after each split by 'computeNeighborhood'; also - -- 'splitResult', which does not split on a variable, - -- should reset it to the identity 'idS', lest it be - -- applied to 'scTarget' again, leading to Issue 1294. - , scCheckpoints :: Map CheckpointId Substitution - -- ^ We need to keep track of the module parameter checkpoints for the - -- clause for the purpose of inferring missing instance clauses. - , scTarget :: Maybe (Dom Type) - -- ^ The type of the rhs, living in context 'scTel'. - -- 'fixTargetType' computes the new 'scTarget' by applying - -- substitution 'scSubst'. - } --- | A @Covering@ is the result of splitting a 'SplitClause'. -data Covering = Covering - { covSplitArg :: Arg Nat - -- ^ De Bruijn level (counting dot patterns) of argument we split on. - , covSplitClauses :: [(SplitTag, SplitClause)] - -- ^ Covering clauses, indexed by constructor/literal these clauses share. - } - --- | Project the split clauses out of a covering. -splitClauses :: Covering -> [SplitClause] -splitClauses (Covering _ qcs) = map snd qcs - --- | Create a split clause from a clause in internal syntax. Used by make-case. -clauseToSplitClause :: Clause -> SplitClause -clauseToSplitClause cl = SClause - { scTel = clauseTel cl - , scPats = toSplitPatterns $ namedClausePats cl - , scSubst = idS -- Andreas, 2014-07-15 TODO: Is this ok? - , scCheckpoints = Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing - , scTarget = domFromArg <$> clauseType cl - } - type CoverM = ExceptT SplitError TCM -- | Top-level function for checking pattern coverage. @@ -202,7 +161,9 @@ -- Storing the covering clauses so that checkIApplyConfluence_ can -- find them later. -- Andreas, 2019-03-27, only needed when --cubical - whenM (isJust . optCubical <$> pragmaOptions) $ do + -- Jesper, 2022-10-18, also needed for some backends, so keep when flag says so + opts <- pragmaOptions + when (isJust (optCubical opts) || optKeepCoveringClauses opts) $ modifySignature $ updateDefinition f $ updateTheDef $ updateCovering $ const qss @@ -219,17 +180,18 @@ -- ifNotM (isEmptyTel tel) (return True) $ do -- Jesper, 2018-11-28, Issue #3407: if the clause is absurd, -- add the appropriate absurd clause to the definition. - let cl = Clause { clauseLHSRange = noRange - , clauseFullRange = noRange - , clauseTel = tel - , namedClausePats = applySubst sub ps - , clauseBody = Nothing - , clauseType = Nothing + let cl = Clause { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = tel + , namedClausePats = applySubst sub ps + , clauseBody = Nothing + , clauseType = Nothing , clauseCatchall = True -- absurd clauses are safe as catch-all , clauseExact = Just False , clauseRecursive = Just False , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } reportSDoc "tc.cover.missing" 20 $ inTopContext $ do sep [ "adding missing absurd clause" @@ -305,15 +267,6 @@ -- to the user. Rather, assume the clause is not already covered. `catchError` \ _ -> return False -data CoverResult = CoverResult - { coverSplitTree :: SplitTree - , coverUsedClauses :: IntSet -- Set Nat - , coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])] - , coverPatterns :: [Clause] - -- ^ The set of patterns used as cover. - , coverNoExactClauses :: IntSet -- Set Nat - } - -- | @cover f cs (SClause _ _ ps _) = return (splitTree, used, pss)@. -- checks that the list of clauses @cs@ covers the given split clause. -- Returns the @splitTree@, the @used@ clauses, and missing cases @pss@. @@ -329,6 +282,14 @@ , nest 2 $ "target sort =" <+> do addContext tel $ maybe (text "") (prettyTCM . getSort . unDom) target ] reportSLn "tc.cover.cover" 80 $ "raw target =\n" ++ show target + verboseS "tc.cover.matching" 20 $ do + reportSLn "tc.cover.matching" 20 $ "clauses when matching:" + forM_ cs $ \ c -> do + let gamma = clauseTel c + ps = namedClausePats c + reportSDoc "tc.cover.matching" 20 $ addContext gamma $ + "ps :" <+> prettyTCM (fmap namedArg ps) + match cs ps >>= \case Yes (i,mps) -> do reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i @@ -397,11 +358,63 @@ Block{} -> Just c No{} -> Nothing + -- Rename the variables in a telescope in accordance with their + -- first appearance in the given NAPs. This is done to preserve + -- variable names in IApplyConfluence error messages. Specifically, + -- consider e.g. + -- + -- data T : Set where + -- x : T + -- p : Path (Path T x x) refl refl + -- f (p i j) = ... + -- + -- When generating the covering clause corresponding to f's clause, + -- the names we have in scope are i and i₁, since those are the + -- names of both PathP binder arguments. (recall Path A x y = PathP (λ i → A) x y) + -- So if we tried to print (Var 0 []) in the context of + -- IApplyConfluence for that clause, what we see isn't j, it's i₁. + -- + -- This function takes "name suggestions" from both variable + -- patterns and IApply co/patterns, and replaces any existing names + -- in the telescope by the name in that pattern. + renTeleFromNap :: Telescope -> NAPs -> Telescope + renTeleFromNap tel ps = telFromList $ evalState (traverse upd (telToList tel)) (size - 1) + where + -- Fold a single pattern into a map of name suggestions: + -- In the running example above, we have + -- f (p i@1 j@0) + -- so the map that nameSuggest (p ...) returns is {0 → j, 1 → j} + nameSuggest :: DeBruijnPattern -> IntMap ArgName + nameSuggest ps = flip foldPattern ps $ \case + VarP _ i | dbPatVarName i /= "_" -> + IntMap.singleton (dbPatVarIndex i) (dbPatVarName i) + IApplyP _ _ _ i | dbPatVarName i /= "_" -> + IntMap.singleton (dbPatVarIndex i) (dbPatVarName i) + _ -> mempty + + -- Suggestions from all patterns.. + suggestions = foldMap (nameSuggest . namedThing . unArg) ps + + -- The state will start counting from (length Γ - 1), which is + -- the *highest* variable index, i.e. the index of the variable + -- with level 0. Instead of doing a lot of de Bruijn arithmetic + -- + recursion, traverse handles iteration and the State handles + -- counting down. + size = length (telToList tel) + upd :: Dom (ArgName , Type) -> State Int (Dom (ArgName , Type)) + upd dom = state $ \s -> do + case IntMap.lookup s suggestions of + Just nm' -> ( dom{ domName = Just (WithOrigin CaseSplit (unranged nm')) + , unDom = (nm' , snd (unDom dom)) + } , s - 1) + Nothing -> (dom , s - 1) + applyCl :: SplitClause -> Clause -> [(Nat, SplitPattern)] -> TCM Clause - applyCl SClause{scTel = tel, scPats = sps} cl mps = addContext tel $ do + applyCl SClause{scTel = pretel, scPats = sps} cl mps + | tel <- renTeleFromNap pretel (namedClausePats cl) = addContext tel $ do let ps = namedClausePats cl reportSDoc "tc.cover.applyCl" 40 $ "applyCl" - reportSDoc "tc.cover.applyCl" 40 $ "tel =" <+> prettyTCM tel + reportSDoc "tc.cover.applyCl" 40 $ "tel =" <+> pretty tel reportSDoc "tc.cover.applyCl" 40 $ "ps =" <+> pretty ps reportSDoc "tc.cover.applyCl" 40 $ "mps =" <+> pretty mps reportSDoc "tc.cover.applyCl" 40 $ "s =" <+> pretty s @@ -437,16 +450,21 @@ , namedClausePats = (s `applySubst` ps) ++ extra , clauseBody = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl , clauseType = ty - , clauseCatchall = clauseCatchall cl - , clauseExact = clauseExact cl - , clauseRecursive = clauseRecursive cl + , clauseCatchall = clauseCatchall cl + , clauseExact = clauseExact cl + , clauseRecursive = clauseRecursive cl , clauseUnreachable = clauseUnreachable cl - , clauseEllipsis = clauseEllipsis cl + , clauseEllipsis = clauseEllipsis cl + , clauseWhereModule = clauseWhereModule cl } where - (vs,qs) = unzip mps - mps' = zip vs $ map namedArg $ fromSplitPatterns $ map defaultNamedArg qs - s = parallelS (for [0..maximum (-1:vs)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i mps'))) + mps' = + Map.fromList $ + map (mapSnd (namedArg . fromSplitPattern . defaultNamedArg)) mps + s = parallelS (for (case Map.lookupMax mps' of + Nothing -> [] + Just (i, _) -> [0..i]) $ \ i -> + fromMaybe (deBruijnVar i) (Map.lookup i mps')) updateRelevance :: TCM a -> TCM a updateRelevance cont = @@ -472,16 +490,24 @@ -- TODO Andrea: I guess an empty pattern is not part of the cover? let qs = [] return $ CoverResult (SplittingDone (size tel)) empty [] qs empty - Right (Covering n scs, x) -> do - cs <- do - let fallback = return cs + Right (Covering n scs', x) -> do + let scs = map (\(t,(sc,i)) -> (t,sc)) scs' + + (results_trX, cs) <- createMissingIndexedClauses f n x sc scs' cs + (scs, cs, results_hc) <- do + let fallback = return (scs, cs, []) caseMaybeM (getPrimitiveName' builtinHComp) fallback $ \ comp -> do let isComp = \case SplitCon c -> comp == c _ -> False - caseMaybe (List.find (isComp . fst) scs) fallback $ \ (_, newSc) -> do - snoc cs <$> createMissingHCompClause f n x sc newSc - results <- mapM ((cover f cs) . snd) scs + caseMaybe (List.find (isComp . fst) scs) fallback $ \ (sp, newSc) -> do + (res,cs') <- createMissingHCompClause f n x sc newSc cs + let scs2 = filter (not . isComp . fst) scs + return (scs2,cs',res) + let results_extra = results_hc ++ results_trX + trees_extra = map (\(sp,cr) -> (sp, coverSplitTree cr)) results_extra + + results <- (++ map snd (results_extra)) <$> mapM ((cover f cs) . snd) scs let trees = map coverSplitTree results useds = map coverUsedClauses results psss = map coverMissingClauses results @@ -498,9 +524,8 @@ , "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps) ] ] - -- TODO Andrea: do something with etaRecordSplits and qsss? let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees - tree = SplitAt n StrictSplit trees' -- TODO: Lazy? + tree = SplitAt n StrictSplit (trees' ++ trees_extra) -- TODO: Lazy? return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex) -- Try to split result @@ -554,7 +579,7 @@ Right (Covering n scs) -> do -- If result splitting was successful, continue coverage checking. (projs, results) <- unzip <$> do - mapM (traverseF $ cover f cs <=< (snd <.> insertTrailingArgs False)) scs + mapM (traverseF $ cover f cs <=< (snd <.> insertTrailingArgs False)) (map (\(t,(sc,i)) -> (t,sc)) scs) -- OR: -- forM scs $ \ (proj, sc') -> (proj,) <$> do -- cover f cs =<< do @@ -611,241 +636,6 @@ (q , addEtaSplits 0 (gatherEtaSplits n sc ps) t) - - --- | Append an hcomp clause to the clauses of a function. -createMissingHCompClause - :: QName - -- ^ Function name. - -> Arg Nat -- ^ index of hcomp pattern - -> BlockingVar -- ^ Blocking var that lead to hcomp split. - -> SplitClause -- ^ Clause before the hcomp split - -> SplitClause - -- ^ Clause to add. - -> TCM Clause -createMissingHCompClause f n x old_sc (SClause tel ps _sigma' cps (Just t)) = setCurrentRange f $ do - reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "Trying to create right-hand side of type" <+> prettyTCM t - reportSDoc "tc.cover.hcomp" 30 $ addContext tel $ text "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps) - reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel - - io <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne - iz <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero - let - cannotCreate :: forall m a. (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> Closure (Abs Type) -> m a - cannotCreate doc t = do - typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t - let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc - old_t = fromJust $ scTarget old_sc - old_tel = scTel old_sc - -- old_tel = Γ(x:H)Δ - -- Γ(x:H)Δ ⊢ old_t - -- vs = iApplyVars old_ps - -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs] - - -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] - -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ] - -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0) - - -- Extra assumption: - -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ' - -- ps = old_ps[x = hcomp φ u u0],ps' - -- with Δ' and ps' introduced by fixTarget. - -- So final clause will be: - -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps' - getLevel t = do - s <- reduce $ getSort t - case s of - Type l -> pure (Level l) - s -> do - reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s - typeError . GenericDocError =<< - (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"") - - -- Γ ⊢ hdelta = (x : H)(δ : Δ) - (gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel - - -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ - (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel - - -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ) - {- rhoS = liftS (size hdelta) $ raiseS 3 -} - vs = iApplyVars (scPats old_sc) - - -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs] - alphab <- forM vs $ \ i -> do - let - -- Γ(x:H)(δ : Δ) ⊢ - tm = Def f old_ps - -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems - (l,r) <- reduce (inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm) - return $ (var i, (l, r)) - - - - cl <- do - (ty,rhs) <- addContext working_tel $ do - -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ] - -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] - -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i] - -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i] - -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]] - -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i]) - -- (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]] - -- α ↦ b[x = hfill φ u u0 i,δ_fill[i]] - -- ]) - -- (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ] - - runNamesT [] $ do - tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr - tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax - tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin - tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg - tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp - tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans - extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps - let - ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - trFillTel' a b c d = do - m <- trFillTel <$> a <*> b <*> c <*> d - x <- lift $ runExceptT m - case x of - Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t - Right args -> return args - comp <- do - let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r)) - <@> lam "i" (\ i -> bA <@> (i `imax` r)) - <@> r - <@> u - return $ \ la bA phi u u0 -> - pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi - <@> lam "i" (\ i -> ilam "o" $ \ o -> - forward la bA i (u <@> i <..> o)) - <@> forward la bA (pure iz) u0 - let - hcomp la bA phi u u0 = pure tHComp <#> la <#> bA - <#> phi - <@> u - <@> u0 - - hfill la bA phi u u0 i = hcomp la bA - (pure tIMax <@> phi <@> (pure tINeg <@> i)) - (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA) - <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o) - <@> ilam "o" (\ _ -> u0) - ) - u0 - -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ) - hcompS <- lift $ do - hdom <- pure $ raise 3 hdom - let - [phi,u,u0] = map (pure . var) [2,1,0] - htype = pure $ unEl . unDom $ hdom - lvl = getLevel $ unDom hdom - hc <- pure tHComp <#> lvl <#> htype - <#> phi - <@> u - <@> u0 - return $ liftS (size delta) $ hc `consS` raiseS 3 - -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom - hdom <- pure $ raise (3+size delta) hdom - htype <- open $ unEl . unDom $ hdom - lvl <- open =<< (lift . getLevel $ unDom hdom) - - -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ - [phi,u,u0] <- mapM (open . raise (size delta) . var) [2,1,0] - -- Γ,x,Δ ⊢ f old_ps - -- Γ ⊢ abstract hdelta (f old_ps) - g <- open $ raise (3+size delta) $ abstract hdelta (Def f old_ps) - old_t <- open $ raise (3+size delta) $ abstract hdelta (unDom old_t) - let bapp a x = lazyAbsApp <$> a <*> x - (delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do - -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ - delta <- open $ raise (3+size delta) delta - -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i)) - deltaf <- open =<< bind "i" (\ i -> - (delta `bapp` hfill lvl htype phi u u0 (ineg i))) - -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0] - args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz) - bind "i" $ \ i -> addContext ("i" :: String) $ do -- for error messages. - -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i) - trFillTel' deltaf (pure iz) args (ineg i) - let - apply_delta_fill i f = apply <$> f <*> (delta_fill `bapp` i) - call v i = apply_delta_fill i $ g <@> v - ty <- do - return $ \ i -> do - v <- hfill lvl htype phi u u0 i - hd <- old_t - args <- delta_fill `bapp` i - lift $ piApplyM hd $ Arg (domInfo hdom) v : args - ty_level <- do - t <- bind "i" ty - s <- reduce $ getSort (absBody t) - reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s - case s of - Type l -> open =<< lam "i" (\ _ -> pure $ Level l) - _ -> cannotCreate "Cannot compose with type family:" =<< liftTCM (buildClosure t) - - let - pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i) - <@> phi <@> psi - <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1 - alpha <- do - vars <- mapM (open . applySubst hcompS . fst) alphab - return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars - - -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]] - b <- do - sides <- forM alphab $ \ (psi,(side0,side1)) -> do - psi <- open $ hcompS `applySubst` psi - - [side0,side1] <- mapM (open . raise (3+size delta) . abstract hdelta) [side0,side1] - return $ (ineg psi `imax` psi, \ i -> pOr_ty i (ineg psi) psi (ilam "o" $ \ _ -> apply_delta_fill i $ side0 <@> hfill lvl htype phi u u0 i) - (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i)) - let recurse [] i = __IMPOSSIBLE__ - recurse [(psi,u)] i = u i - recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i) - return $ recurse sides - - ((,) <$> ty (pure io) <*>) $ do - comp ty_level - (lam "i" $ fmap unEl . ty) - (phi `imax` alpha) - (lam "i" $ \ i -> - let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i) - in if null alphab then rhs else - pOr_ty i phi alpha rhs (b i) - ) - (call u0 (pure iz)) - reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel - let n = size tel - (size gamma + 3 + size delta) - reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n) - (TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty - rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs - - cxt <- getContextTelescope - reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt - reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel - reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t - reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs - - return $ Clause { clauseLHSRange = noRange - , clauseFullRange = noRange - , clauseTel = tel - , namedClausePats = fromSplitPatterns ps - , clauseBody = Just $ rhs - , clauseType = Just $ defaultArg t - , clauseCatchall = False - , clauseExact = Just True - , clauseRecursive = Nothing -- TODO: can it be recursive? - , clauseUnreachable = Just False -- missing, thus, not unreachable - , clauseEllipsis = NoEllipsis - } - addClauses f [cl] -- Important: add at the end. - return cl -createMissingHCompClause _ _ _ _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__ - -- | Append a instance clause to the clauses of a function. inferMissingClause :: QName @@ -875,11 +665,12 @@ , namedClausePats = fromSplitPatterns ps , clauseBody = Just rhs , clauseType = Just (argFromDom t) - , clauseCatchall = False + , clauseCatchall = False , clauseExact = Just True , clauseRecursive = Nothing -- could be recursive , clauseUnreachable = Just False -- missing, thus, not unreachable - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } addClauses f [cl] -- Important: add at the end. return cl @@ -986,7 +777,7 @@ let fallback = return (empty, sc) caseMaybe target fallback $ \ a -> do if isJust (domTactic a) && not force then fallback else do - (TelV tel b) <- telViewUpTo (-1) $ unDom a + (TelV tel b) <- addContext sctel $ telViewUpTo (-1) $ unDom a reportSDoc "tc.cover.target" 15 $ sep [ "target type telescope: " <+> do addContext sctel $ prettyTCM tel @@ -1038,6 +829,15 @@ | visible ai = setOrigin UserWritten ai | otherwise = setOrigin Inserted ai + +-- | Checks if a type in this sort supports hcomp. +-- currently all such types will have a Level. +-- precondition: Sort in whnf and not blocked. +hasHComp :: Sort -> Maybe Level +hasHComp (Type l) = Just l +hasHComp _ = Nothing + + computeHCompSplit :: Telescope -- ^ Telescope before split point. -> PatVarName -- ^ Name of pattern variable at split point. -> Telescope -- ^ Telescope after split point. @@ -1051,13 +851,18 @@ -- -> QName -- ^ Constructor to fit into hole. -> CoverM (Maybe (SplitTag,SplitClause)) -- ^ New split clause if successful. computeHCompSplit delta1 n delta2 d pars ixs hix tel ps cps = do + withK <- not . collapseDefault . optCubicalCompatible <$> pragmaOptions + if withK then return Nothing else do -- Get the type of the datatype -- Δ1 ⊢ dtype dsort <- liftTCM $ (parallelS (reverse $ map unArg pars) `applySubst`) . dataSort . theDef <$> getConstInfo d hCompName <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp theHCompT <- defType <$> getConstInfo hCompName + + -- TODO can dsort be blocked or not in whnf? + caseMaybe (hasHComp dsort) (return Nothing) $ \ dlvl' -> do let - dlvl = Level . (\ (Type s) -> s) $ dsort + dlvl = Level dlvl' dterm = Def d [] `apply` (pars ++ ixs) -- Δ1 ⊢ gamma TelV gamma _ <- lift $ telView (theHCompT `piApply` [setHiding Hidden $ defaultArg $ dlvl , defaultArg $ dterm]) @@ -1068,7 +873,7 @@ -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ let (rho1,rho2) = splitS (size gamma) $ toSplitPSubst rho0 - let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $ + let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $ -- should there be a different Origin here? map (fmap unnamed) [setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dlvl ,setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dterm] ++ applySubst rho2 (teleNamedArgs gamma) -- rho0? @@ -1091,7 +896,6 @@ return $ Just . (SplitCon hCompName,) $ SClause delta' ps' rho cps' Nothing -- target fixed later - -- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps con@ -- -- @ @@ -1120,7 +924,7 @@ -> [NamedArg SplitPattern] -- ^ Patterns before doing the split. -> Map CheckpointId Substitution -- ^ Current checkpoints -> QName -- ^ Constructor to fit into hole. - -> CoverM (Maybe SplitClause) -- ^ New split clause if successful. + -> CoverM (Maybe (SplitClause, IInfo)) -- ^ New split clause if successful. computeNeighbourhood delta1 n delta2 d pars ixs hix tel ps cps c = do -- Get the type of the datatype @@ -1136,7 +940,8 @@ -- Lookup the type of the constructor at the given parameters (gamma0, cixs, boundary) <- do - (TelV gamma0 (El _ d), boundary) <- liftTCM $ telViewPathBoundaryP (ctype `piApply` pars) + (TelV gamma0 (El _ d), boundary) <- liftTCM $ addContext delta1 $ + telViewPathBoundaryP (ctype `piApply` pars) let Def _ es = d Just cixs = allApplyElims es return (gamma0, cixs, boundary) @@ -1166,22 +971,34 @@ -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope -- TODO: should we propagate the modality in general? -- See also LHS checking. - dtype <- do + dtype <- addContext delta1 $ do let updCoh = composeCohesion (getCohesion info) TelV dtel dt <- telView dtype return $ abstract (mapCohesion updCoh <$> dtel) dt + dsort <- addContext delta1 $ reduce (getSort dtype) - withKIfStrict <- addContext delta1 $ reduce (getSort dtype) >>= \case + withKIfStrict <- case dsort of SSet{} -> return $ locallyTC eSplitOnStrict $ const True _ -> return id - r <- withKIfStrict $ unifyIndices + -- Should we attempt to compute a left inverse for this clause? When + -- --cubical-compatible --flat-split is given, we don't generate a + -- left inverse (at all). This means that, when the coverage checker + -- gets to the clause this was in, it won't generate a (malformed!) + -- transpX clause for @♭ matching. + -- TODO(Amy): properly support transpX when @♭ stuff is in the + -- context. + let flatSplit = boolToMaybe (getCohesion info == Flat) SplitOnFlat + + r <- withKIfStrict $ lift $ unifyIndices' flatSplit delta1Gamma flex (raise (size gamma) dtype) conIxs givenIxs + TelV eqTel _ <- telView $ (raise (size gamma) dtype) + let stuck b errs = do debugCantSplit throwError $ UnificationStuck b (conName con) (delta1 `abstract` gamma) conIxs givenIxs errs @@ -1194,7 +1011,25 @@ UnifyStuck errs -> stuck Nothing errs - Unifies (delta1',rho0,_) -> do + Unifies (delta1',rho0,eqs,tauInv) -> do + + let unifyInfo | Type _ <- dsort -- only types of sort Type l have trX constructors: + -- re #3733: update if we add transp for other sorts. + , not $ null $ conIxs -- no point propagating this info if trivial? + , Right (tau,leftInv) <- tauInv + = TheInfo $ UE delta1Gamma delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv + | otherwise + = NoInfo + + case tauInv of + Right{} -> return () + Left SplitOnStrict -> return () + Left x -> do + whenM (collapseDefault . optCubicalCompatible <$> + pragmaOptions) $ do + -- re #3733: TODO better error msg. + lift $ warning . UnsupportedIndexedMatch =<< prettyTCM x + debugSubst "rho0" rho0 let rho0' = toSplitPSubst rho0 @@ -1227,7 +1062,7 @@ let cps' = applySplitPSubst rho cps - return $ Just $ SClause delta' ps' rho cps' Nothing -- target fixed later + return $ Just . (,unifyInfo) $ SClause delta' ps' rho cps' Nothing -- target fixed later where debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix = liftTCM $ do @@ -1243,7 +1078,7 @@ , "ixs =" <+> do addContext delta1 $ prettyList $ map prettyTCM ixs , "cixs =" <+> do addContext gamma $ prettyList $ map prettyTCM cixs , "delta1 =" <+> do inTopContext $ prettyTCM delta1 - , "delta2 =" <+> do inTopContext $ addContext delta1 $ addContext gamma $ prettyTCM delta2 + , "delta2 =" <+> do inTopContext $ addContext delta1 $ addContext n $ prettyTCM delta2 , "gamma =" <+> do inTopContext $ addContext delta1 $ prettyTCM gamma , "tel =" <+> do inTopContext $ prettyTCM tel , "hix =" <+> text (show hix) @@ -1412,17 +1247,20 @@ -- Andreas, 2010-09-21, isDatatype now directly throws an exception if it fails -- cons = constructors of this datatype (dr, d, pars, ixs, cons', isHIT) <- inContextOfT $ isDatatype ind t + isFib <- lift $ isFibrant t cons <- case checkEmpty of CheckEmpty -> ifM (liftTCM $ inContextOfT $ isEmptyType $ unDom t) (pure []) (pure cons') NoCheckEmpty -> pure cons' mns <- forM cons $ \ con -> fmap (SplitCon con,) <$> computeNeighbourhood delta1 n delta2 d pars ixs x tel ps cps con - hcompsc <- if isHIT && inserttrailing == DoInsertTrailing + hcompsc <- if isFib && (isHIT || (size ixs > 0)) && not (null mns) && inserttrailing == DoInsertTrailing then computeHCompSplit delta1 n delta2 d pars ixs x tel ps cps else return Nothing + let ns = catMaybes mns return ( dr , not (null ixs) -- Is "d" indexed? - , catMaybes (mns ++ [hcompsc]) + , length $ ns + , ns ++ catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns]) ) computeLitNeighborhoods = do @@ -1452,21 +1290,24 @@ -- to an inductive family (with at least one index), then the -- following code should be changed (the constructor False -- stands for "not indexed"). - return (IsData, False, ns ++ [ ca ]) + let ns' = map ((fmap (,NoInfo))) $ ns ++ [ ca ] + return (IsData, False, length ns', ns') - (dr, isIndexed, ns) <- if null pcons' && not (null plits) + -- numMatching is the number of proper constructors matching, excluding hcomp. + -- for literals this considers the catchall clause as 1 extra constructor. + (dr, isIndexed, numMatching, ns) <- if null pcons' && not (null plits) then computeLitNeighborhoods else computeNeighborhoods ns <- case target of - Just a -> forM ns $ \ (con, sc) -> lift $ (con,) <$> + Just a -> forM ns $ \ (con,(sc,info)) -> lift $ (con,) . (,info) <$> fixTargetType (getQuantity t) con sc a Nothing -> return ns ns <- case inserttrailing of DontInsertTrailing -> return ns - DoInsertTrailing -> lift $ forM ns $ \(con,sc) -> - (con,) . snd <$> insertTrailingArgs False sc + DoInsertTrailing -> lift $ forM ns $ \(con,(sc,info)) -> + (con,) . (,info) . snd <$> insertTrailingArgs False sc mHCompName <- getPrimitiveName' builtinHComp withoutK <- collapseDefault . optWithoutK <$> pragmaOptions @@ -1477,8 +1318,8 @@ throwError . ErasedDatatype causedByWithoutK =<< do liftTCM $ inContextOfT $ buildClosure (unDom t) - case ns of - [] -> do + case numMatching of + 0 -> do let absurdp = VarP (PatternInfo PatOAbsurd []) $ SplitPatVar underscore 0 [] rho = liftS x $ consS absurdp $ raiseS 1 ps' = applySubst rho ps @@ -1491,13 +1332,13 @@ } -- Andreas, 2018-10-17: If more than one constructor matches, we cannot erase. - _ : _ : _ | not erased && not (usableQuantity t) -> + n | n > 1 && not erased && not (usableQuantity t) -> erasedError False -- If exactly one constructor matches and the K rule is turned -- off, then we only allow erasure for non-indexed data types -- (#4172). - [_] | not erased && not (usableQuantity t) && + 1 | not erased && not (usableQuantity t) && withoutK && isIndexed -> erasedError True @@ -1512,7 +1353,7 @@ let all_tags = Set.fromList ptags `Set.union` inferred_tags when (allowPartialCover == NoAllowPartialCover && not overlap) $ - for_ ns $ \(tag, sc) -> do + for_ ns $ \(tag, (sc, _)) -> do unless (tag `Set.member` all_tags) $ do isImpossibleClause <- liftTCM $ isEmptyTel $ scTel sc unless isImpossibleClause $ do @@ -1522,7 +1363,7 @@ ] throwError (GenericSplitError "precomputed set of constructors does not cover all cases") - liftTCM $ checkSortOfSplitVar dr (unDom t) delta2 target + liftTCM $ inContextOfT $ checkSortOfSplitVar dr (unDom t) delta2 target return $ Right $ Covering (lookupPatternVar sc x) ns where @@ -1645,7 +1486,7 @@ reportSDoc "tc.cover.copattern" 40 $ vcat [ "fieldSub for" <+> prettyTCM (unDom proj) , nest 2 $ pretty fieldSub ] - return (SplitCon (unDom proj), sc') + 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! diff --git a/src/full/Agda/TypeChecking/Coverage/Cubical.hs b/src/full/Agda/TypeChecking/Coverage/Cubical.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Coverage/Cubical.hs @@ -0,0 +1,1391 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +module Agda.TypeChecking.Coverage.Cubical where + +import Prelude hiding (null, (!!)) -- do not use partial functions like !! + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Trans ( lift ) + +import Data.Foldable (for_) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Agda.Syntax.Common +import Agda.Syntax.Position +import Agda.Syntax.Internal hiding (DataOrRecord(..)) +import Agda.Syntax.Internal.Pattern +import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..)) + +import Agda.TypeChecking.Names +import Agda.TypeChecking.Primitive hiding (Nat) +import Agda.TypeChecking.Monad + +import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar) +import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars) +import Agda.TypeChecking.Rules.LHS.Unify +import Agda.TypeChecking.Rules.Term (unquoteTactic) + +import Agda.TypeChecking.Coverage.Match +import Agda.TypeChecking.Coverage.SplitTree +import Agda.TypeChecking.Coverage.SplitClause + + +import Agda.TypeChecking.Conversion (tryConversion, equalType) +import Agda.TypeChecking.Datatypes (getConForm, getDatatypeArgs) +import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType ) +import Agda.TypeChecking.Irrelevance +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Records +import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Telescope.Path +import Agda.TypeChecking.MetaVars +import Agda.TypeChecking.Warnings + +import Agda.Interaction.Options + +import Agda.Utils.Either +import Agda.Utils.Functor +import Agda.Utils.List +import Agda.Utils.Maybe +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.Permutation +import Agda.Utils.Pretty (prettyShow) +import Agda.Utils.Singleton +import Agda.Utils.Size +import Agda.Utils.WithDefault + +import Agda.Utils.Impossible + + +createMissingIndexedClauses :: QName + -> Arg Nat + -> BlockingVar + -> SplitClause + -> [(SplitTag,(SplitClause,IInfo))] + -> [Clause] + -> TCM ([(SplitTag,CoverResult)],[Clause]) +createMissingIndexedClauses f n x old_sc scs cs = do + reflId <- getName' builtinReflId + let infos = [(c,i) | (SplitCon c, (_,TheInfo i)) <- scs ] + case scs of + [(SplitCon c,(_newSc,i@TheInfo{}))] | Just c == reflId -> do + mc <- createMissingConIdClause f n x old_sc i + caseMaybe mc (return ([],cs)) $ \ ((sp,tree),cl) -> do + let res = CoverResult tree (IntSet.singleton (length cs)) [] [cl] IntSet.empty + return ([(sp,res)],snoc cs cl) + xs | not $ null infos -> do + reportSDoc "tc.cover.indexed" 20 $ text "size (xs,infos):" <+> pretty (size xs,size infos) + reportSDoc "tc.cover.indexed" 20 $ text "xs :" <+> pretty (map fst xs) + + unless (size xs == size infos + 1) $ + reportSDoc "tc.cover.indexed" 20 $ text "missing some infos" + -- Andrea: what to do when we only managed to build a unification proof for some of the constructors? + Constructor{conData} <- theDef <$> getConstInfo (fst (head infos)) + Datatype{dataPars = pars, dataIxs = nixs, dataTranspIx} <- theDef <$> getConstInfo conData + hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp + trX <- fromMaybe __IMPOSSIBLE__ <$> pure dataTranspIx + trX_cl <- createMissingTrXTrXClause trX f n x old_sc + hcomp_cl <- createMissingTrXHCompClause trX f n x old_sc + (trees,cls) <- fmap unzip . forM infos $ \ (c,i) -> do + cl <- createMissingTrXConClause trX f n x old_sc c i + return $ ((SplitCon c , SplittingDone (size $ clauseTel cl)) , cl) + let extra = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl) + , (SplitCon hcomp, SplittingDone $ size $ clauseTel hcomp_cl) + ] + -- = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl) ] + extraCl = [trX_cl, hcomp_cl] + -- = [trX_cl] + let clauses = cls ++ extraCl + let tree = SplitAt ((+(pars+nixs+1)) <$> n) StrictSplit $ + trees + ++ extra + res = CoverResult + { coverSplitTree = tree + , coverUsedClauses = IntSet.fromList (map (length cs +) [0..length clauses-1]) + , coverMissingClauses = [] + , coverPatterns = clauses + , coverNoExactClauses = IntSet.empty + } + reportSDoc "tc.cover.indexed" 20 $ + "tree:" <+> pretty tree + addClauses f clauses + return $ ([(SplitCon trX,res)],cs++clauses) +-- return $ ([],[]) + xs | otherwise -> return ([],cs) + +covFillTele :: QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term] +covFillTele func tel face d j = do + ed_f <- liftTCM $ runExceptT $ trFillTel tel face d j + case ed_f of + Right d_f -> pure $ map unArg d_f + Left failed_t -> enterClosure failed_t $ \failed_t -> addContext ("i" :: String, __DUMMY_DOM__) $ do + typeError . GenericDocError =<< vcat + [ "Could not generate a transport clause for" <+> prettyTCM func + , "because a term of type" <+> prettyTCM (unAbs failed_t) + , "lives in the sort" <+> prettyTCM (getSort (unAbs failed_t)) <+> "and thus can not be transported" + ] + +createMissingTrXTrXClause :: QName -- ^ trX + -> QName -- ^ f defined + -> Arg Nat + -> BlockingVar + -> SplitClause + -> TCM Clause +createMissingTrXTrXClause q_trX f n x old_sc = do + let + old_tel = scTel old_sc + old_ps = fromSplitPatterns $ scPats old_sc + old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + + reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f + reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $ + [ "old_tel:" <+> prettyTCM old_tel + , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps) + , "old_t :" <+> addContext old_tel (prettyTCM old_t) + ] + + -- TODO: redo comments, the strategy changed. + -- old_tel = Γ1, (x : D η v), Δ + -- α = boundary(old_ps) + -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ] + + -- α' = boundary(old_ps[x = pat]) + -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v + + -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat] + + -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized. + + -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α'] + -- , φ ↦ w1[φ = i1, p = refl] + -- , ψ ↦ w1[ψ = i1, q = refl] + -- ] + -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1) + -- Ξ ⊢ pat_rec[0] = pat : D η v + -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v + -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t) + + -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ + -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]] + -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides. + + interval <- elInf primInterval + iz <- primIZero + io <- primIOne + tHComp <- primHComp + tNeg <- primINeg + let neg i = pure tNeg <@> i + let min i j = cl primIMin <@> i <@> j + let max i j = cl primIMax <@> i <@> j + let + old_tel = scTel old_sc + old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc + old_ps = pure $ old_ps' + old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + -- old_tel = Γ(x: D η v)Δ + -- Γ1, (x : D η v) ⊢ delta = (δ : Δ) + (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel + delta = pure $ AbsN (teleNames gamma1x) $ delta' + gamma1_size = (size gamma1x - 1) + (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x + + old_sides <- forM old_ps' $ \ ps -> do + let vs = iApplyVars ps + let tm = Def f $ patternsToElims ps + xs <- forM vs $ \ v -> + -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?) + fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm) + return $ concatMap (\(v,(l,r)) -> [(tNeg `apply` [argN v],l),(v,r)]) xs + let + gamma1ArgNames = teleArgNames gamma1 + deltaArgNames = teleArgNames delta' + (params,xTel,dT) <- addContext gamma1 $ do + Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType' + def <- getConstInfo d + let dTy = defType def + let Datatype{dataSort = s} = theDef def + TelV tel _ <- telView dTy + let params = AbsN (teleNames gamma1) ps + xTel = AbsN (teleNames gamma1) (tel `apply` ps) + + dT <- runNamesT [] $ do + s <- open $ AbsN (teleNames tel) s + bindNArg (teleArgNames gamma1) $ \ g1 -> do + bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do + params <- pure params `applyN` (fmap unArg <$> g1) + x <- sequence x + s <- s `applyN` (map (pure . unArg) $ params ++ x) + pure $ El s $ Def d [] `apply` (params ++ x) + return $ (params, xTel,dT) + + let + xTelI = pure $ expTelescope interval <$> xTel + xTelIArgNames = teleArgNames (unAbsN xTel) -- same names + + -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0) + let trX' = bindNArg gamma1ArgNames $ \ g1 -> do + bindNArg ([defaultArg "phi"] ++ xTelIArgNames) $ \ phi_p -> do + bindNArg [defaultArg "x0"] $ \ x0 -> do + param_args <- fmap (map (setHiding Hidden . fmap (unnamed . dotP))) $ + pure params `applyN` (fmap unArg <$> g1) + (phi:p) <- sequence phi_p + x0 <- sequence x0 + pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0 + trX = (fmap . fmap . fmap) patternToTerm <$> trX' + let pat' = + bindN (map unArg gamma1ArgNames) $ \ g1 -> do + bindN (map unArg $ ([defaultArg "phi"] ++ xTelIArgNames)) $ \ phi_p -> do + bindN (map unArg $ ([defaultArg "psi"] ++ xTelIArgNames)) $ \ psi_q -> do + bindN (map unArg $ [defaultArg "x0"]) $ \ x0 -> do + -- (phi:p) <- sequence phi_p + -- (psi:q) <- sequence psi_q + -- x0 <- sequence x0 + let trX = trX' `applyN` g1 + trX `applyN` phi_p `applyN` [trX `applyN` psi_q `applyN` x0] + -- pure $ trX $ p ++ [phi, defaultArg $ unnamed $ trX $ q ++ [psi] ++ x0] + pat = (fmap . fmap . fmap . fmap) patternToTerm <$> pat' + let deltaPat g1 phi p psi q x0 = + delta `applyN` (g1 ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]]) + -- Ξ + cTel <- runNamesT [] $ + abstractN (pure gamma1) $ \ g1 -> do + abstractT "φ" (pure interval) $ \ phi -> do + abstractN (xTelI `applyN` g1) $ \ p -> do + abstractT "ψ" (pure interval) $ \ psi -> do + abstractN (xTelI `applyN` g1) $ \ q -> do + abstractT "x0" (pure dT `applyN` g1 `applyN` (flip map q $ \ f -> f <@> pure iz)) $ \ x0 -> do + deltaPat g1 phi p psi q x0 + + ps_ty_rhs <- runNamesT [] $ do + bindN (map unArg gamma1ArgNames) $ \ g1 -> do + bind "φ" $ \ phi -> do + bindN (map unArg xTelIArgNames) $ \ p -> do + bind "ψ" $ \ psi -> do + bindN (map unArg xTelIArgNames) $ \ q -> do + bind "x0" $ \ x0 -> do + bindN (map unArg deltaArgNames) $ \ d -> do + let + ps :: NamesT TCM NAPs + ps = old_ps `applyN` (g1 + ++ [pat' `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]] + ++ d) + + rhsTy = old_ty `applyN` (g1 + ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]] + ++ d) + + xTel <- (open =<<) $ pure xTel `applyN` g1 + q4_f <- (open =<<) $ bind "i" $ \ i -> lamTel $ bind "j" $ \ j -> do + ty <- bind "i" $ \ _ -> xTel + face <- max phi $ max (neg j) (neg i) + base <- map defaultArg <$> appTel (sequence q) j + u <- liftM2 (,) (max j psi) $ bind "h" $ \ h -> do + appTel (sequence p) (min j (min h i)) + Right xs <- lift $ runExceptT $ transpSysTel' False ty [u] face base + pure $ map unArg xs + -- Ξ ⊢ pat_rec[0] = pat : D η v + -- Ξ ⊢ pat_rec[1] = trX q4 (φ ∧ ψ) x0 : D η v + -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q4_f i) (ψ ∧ (φ ∨ ~ i)) t) + pat_rec <- (open =<<) $ bind "i" $ \ i -> do + p_conn <- (mapM open =<<) $ lamTel $ bind "i" $ \ j -> sequence p `appTel` max i j + q4_f' <- (mapM open =<<) $ absApp <$> q4_f <*> i + trX `applyN` g1 `applyN` (max i phi:p_conn) + `applyN` [trX `applyN` g1 `applyN` (min psi (max phi (neg i)):q4_f') `applyN` [x0]] + + let mkBndry args = do + args1 <- (mapM open =<<) $ (absApp <$> args <*> pure io) + -- faces ought to be constant on "j" + faces <- pure (fmap (map fst) old_sides) `applyN` args1 + us <- forM (mapM (map snd) old_sides) $ \ u -> do + lam "j" $ \ j -> ilam "o" $ \ _ -> do + args <- (mapM open =<<) $ (absApp <$> args <*> j) + pure u `applyN` args + forM (zip faces us) $ \ (phi,u) -> liftM2 (,) (open phi) (open u) + let mkComp pr = bind "i" $ \ i -> do + d_f <- (open =<<) $ bind "j" $ \ j -> do + tel <- bind "j" $ \ j -> delta `applyN` (g1 ++ [pr `applyN` [i,j]]) + face <- min phi psi `max` (min i (max phi psi)) + j <- j + d <- map defaultArg <$> sequence d + lift $ covFillTele f tel face d j + let args = bind "j" $ \ j -> do + g1 <- sequence g1 + x <- pr `applyN` [i,neg j] + ys <- absApp <$> d_f <*> neg j + pure $ g1 ++ x:ys + ty <- (open =<<) $ bind "j" $ \ j -> do + args <- (mapM open =<<) $ absApp <$> args <*> j + fmap unDom $ old_ty `applyN` args + let face = max i (min phi psi) + base <- (open =<<) $ do + args' <- (mapM open =<<) $ absApp <$> args <*> pure iz + fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args' + sys <- mkBndry args + transpSys ty sys face base + + -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ + -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]] + -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides. + syspsi <- (open =<<) $ lam "i" $ \ i -> ilam "o" $ \ _ -> do + c <- mkComp $ bindN ["i","j"] $ \ [i,j] -> do + Abs n (data_ty,lines) <- bind "k" $ \ k -> do + let phi_k = max phi (neg k) + let p_k = flip map p $ \ p -> lam "h" $ \ h -> p <@> (min k h) + data_ty <- pure dT `applyN` g1 `applyN` (flip map p $ \ p -> p <@> k) + line1 <- trX `applyN` g1 `applyN` (phi_k:p_k) `applyN` [x0] + + line2 <- trX `applyN` g1 + `applyN` (max phi_k j : (flip map p_k $ \ p -> lam "h" $ \ h -> p <@> (max h j))) + `applyN` + [trX `applyN` g1 + `applyN` (max phi_k (neg j): (flip map p_k $ \ p -> lam "h" $ \ h -> p <@> (min h j))) + `applyN` [x0]] + pure (data_ty,[line1,line2]) + data_ty <- open $ Abs n data_ty + [line1,line2] <- mapM (open . Abs n) lines + let sys = [(neg i, lam "k" $ \ k -> ilam "o" $ \ _ -> absApp <$> line2 <*> k) + ,(neg j `max` j `max` i `max` phi, lam "k" $ \ k -> ilam "o" $ \ _ -> absApp <$> line1 <*> k) + ] + transpSys data_ty sys (pure iz) x0 + absApp <$> pure c <*> i + sysphi <- (open =<<) $ lam "i" $ \ i -> ilam "o" $ \ o -> do + c <- mkComp $ bindN ["i","j"] $ \ _ij -> do + trX `applyN` g1 `applyN` (psi:q) `applyN` [x0] + absApp <$> pure c <*> i + syse <- mkBndry $ bind "j" $ \ _ -> sequence $ g1 ++ [absApp <$> pat_rec <*> pure iz] ++ d + let sys = syse ++ [(phi,sysphi)] ++ [(psi,syspsi)] + w0 <- (open =<<) $ do + let w = mkComp (bindN ["i","j"] $ \ [_i, j] -> absApp <$> pat_rec <*> j) + absApp <$> w <*> pure iz + let rhs = hcomp (unDom <$> rhsTy) sys w0 + (,,) <$> ps <*> rhsTy <*> rhs + let (ps,ty,rhs) = unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs + reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f + let c = Clause { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = cTel + , namedClausePats = ps + , clauseBody = Just rhs + , clauseType = Just $ Arg (getArgInfo ty) (unDom ty) + , clauseCatchall = False + , clauseExact = Nothing + , clauseRecursive = Just True + , clauseUnreachable = Just False + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing + } + debugClause "tc.cover.trx.trx" c + return $ c +createMissingTrXHCompClause :: QName + -> QName + -> Arg Nat + -> BlockingVar + -> SplitClause + -> TCM Clause +createMissingTrXHCompClause q_trX f n x old_sc = do + let + old_tel = scTel old_sc + old_ps = fromSplitPatterns $ scPats old_sc + old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + + reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f + reportSDoc "tc.cover.trx.hcomp" 20 $ nest 2 $ vcat $ + [ "old_tel:" <+> prettyTCM old_tel + , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps) + , "old_t :" <+> addContext old_tel (prettyTCM old_t) + ] + + -- old_tel = Γ1, (x : D η v), Δ + -- α = boundary(old_ps) + -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ] + + -- α' = boundary(old_ps[x = pat]) + -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : I -> [ψ] → D η (p i0), u0 : D η (p i0) ⊢ pat := trX p φ (hcomp ψ u u0) : D η v + + -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : ..., u0 : D η (p i0), Δ[x = pat] + + -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized. + + -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α'] + -- , φ ↦ w1[φ = i1, p = refl] = f old_ps[γ1,x = hcomp ψ u u0 ,δ] + -- , ψ ↦ w1[ψ = i1] = f old_ps[γ1,x = trX p φ (u i1 _),δ] + -- ] + + -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1) + -- Ξ ⊢ pat_rec[0] = pat : D η v + -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v + -- Ξ ⊢ pat-rec[i] := trX (\ j → q (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t) + + -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ : Δ[γ1,x = pat_rec[1]] + -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]] + -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides. + + q_hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp + let + old_tel = scTel old_sc + old_ps = fromSplitPatterns $ scPats old_sc + old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + + reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f + reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $ + [ "old_tel:" <+> prettyTCM old_tel + , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps) + , "old_t :" <+> addContext old_tel (prettyTCM old_t) + ] + + -- TODO: redo comments, the strategy changed. + -- old_tel = Γ1, (x : D η v), Δ + -- α = boundary(old_ps) + -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ] + + -- α' = boundary(old_ps[x = pat]) + -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v + + -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat] + + -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized. + + -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α'] + -- , φ ↦ w1[φ = i1, p = refl] + -- , ψ ↦ w1[ψ = i1, q = refl] + -- ] + -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1) + -- Ξ ⊢ pat_rec[0] = pat : D η v + -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v + -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t) + + -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ + -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]] + -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides. + + interval <- elInf primInterval + iz <- primIZero + io <- primIOne + tHComp <- primHComp + tNeg <- primINeg + let neg i = pure tNeg <@> i + let min i j = cl primIMin <@> i <@> j + let max i j = cl primIMax <@> i <@> j + let + old_tel = scTel old_sc + old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc + old_ps = pure $ old_ps' + old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + -- old_tel = Γ(x: D η v)Δ + -- Γ1, (x : D η v) ⊢ delta = (δ : Δ) + (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel + delta = pure $ AbsN (teleNames gamma1x) $ delta' + gamma1_size = (size gamma1x - 1) + (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x + + old_sides <- forM old_ps' $ \ ps -> do + let vs = iApplyVars ps + let tm = Def f $ patternsToElims ps + xs <- forM vs $ \ v -> + -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?) + fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm) + return $ concatMap (\(v,(l,r)) -> [(tNeg `apply` [argN v],l),(v,r)]) xs + let + gamma1ArgNames = teleArgNames gamma1 + deltaArgNames = teleArgNames delta' + (params,xTel,dT) <- addContext gamma1 $ do + Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType' + def <- getConstInfo d + let dTy = defType def + let Datatype{dataSort = s} = theDef def + TelV tel _ <- telView dTy + let params = AbsN (teleNames gamma1) ps + xTel = AbsN (teleNames gamma1) (tel `apply` ps) + + dT <- runNamesT [] $ do + s <- open $ AbsN (teleNames tel) s + bindNArg (teleArgNames gamma1) $ \ g1 -> do + bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do + params <- pure params `applyN` (fmap unArg <$> g1) + x <- sequence x + s <- s `applyN` (map (pure . unArg) $ params ++ x) + pure $ El s $ Def d [] `apply` (params ++ x) + return $ (params, xTel,dT) + + let + xTelI = pure $ expTelescope interval <$> xTel + xTelIArgNames = teleArgNames (unAbsN xTel) -- same names + + -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0) + let trX' = bindNArg gamma1ArgNames $ \ g1 -> do + bindNArg ([defaultArg "phi"] ++ xTelIArgNames) $ \ phi_p -> do + bindNArg [defaultArg "x0"] $ \ x0 -> do + param_args <- fmap (map (setHiding Hidden . fmap (unnamed . dotP))) $ + pure params `applyN` (fmap unArg <$> g1) + (phi:p) <- sequence phi_p + x0 <- sequence x0 + pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0 + trX = (fmap . fmap . fmap) patternToTerm <$> trX' + let + hcompD' g1 v = + bindNArg [argH "psi",argN "u", argN "u0"] $ \ x0 -> do + x0 <- sequence x0 + Just (LEl l t) <- (toLType =<<) $ pure dT `applyN` g1 `applyN` v + let ty = map (fmap (unnamed . dotP) . argH) [Level l,t] + pure $ DefP defaultPatternInfo q_hcomp $ ty ++ x0 + hcompD <- runNamesT [] $ + bindN (map unArg $ gamma1ArgNames) $ \ g1 -> do + bindN (teleNames $ unAbsN $ xTel) $ \ v -> do + fmap patternToTerm <$> hcompD' g1 v + let pat' = + bindN (map unArg gamma1ArgNames) $ \ g1 -> do + bindN (map unArg $ ([defaultArg "phi"] ++ xTelIArgNames)) $ \ phi_p -> do + bindN ["psi","u","u0"] $ \ x0 -> do + let trX = trX' `applyN` g1 + let p0 = flip map (tail phi_p) $ \ p -> p <@> pure iz + trX `applyN` phi_p `applyN` [hcompD' g1 p0 `applyN` x0] + pat = (fmap . fmap . fmap) patternToTerm <$> pat' + let deltaPat g1 phi p x0 = + delta `applyN` (g1 ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` x0]) + -- Ξ + cTel <- runNamesT [] $ + abstractN (pure gamma1) $ \ g1 -> do + abstractT "φ" (pure interval) $ \ phi -> do + abstractN (xTelI `applyN` g1) $ \ p -> do + let p0 = flip map p $ \ p -> p <@> pure iz + let ty = pure dT `applyN` g1 `applyN` p0 + abstractT "ψ" (pure interval) $ \ psi -> do + abstractT "u" (pure interval --> pPi' "o" psi (\ _ -> ty)) $ \ u -> do + abstractT "u0" ty $ \ u0 -> do + deltaPat g1 phi p [psi,u,u0] + + ps_ty_rhs <- runNamesT [] $ do + bindN (map unArg gamma1ArgNames) $ \ g1 -> do + bind "φ" $ \ phi -> do + bindN (map unArg xTelIArgNames) $ \ p -> do + bind "ψ" $ \ psi -> do + bind "u" $ \ u -> do + bind "u0" $ \ u0 -> do + bindN (map unArg deltaArgNames) $ \ d -> do + let + x0 :: Vars TCM + x0 = [psi,u,u0] + ps :: NamesT TCM NAPs + ps = old_ps `applyN` (g1 + ++ [pat' `applyN` g1 `applyN` (phi:p) `applyN` x0] + ++ d) + + rhsTy = old_ty `applyN` (g1 + ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` x0] + ++ d) + + xTel <- (open =<<) $ pure xTel `applyN` g1 + -- Ξ ⊢ pat-rec[i] := trX .. (hfill ... (~ i)) + pat_rec <- (open =<<) $ bind "i" $ \ i -> do + let tr x = trX `applyN` g1 `applyN` (phi:p) `applyN` [x] + let p0 = flip map p $ \ p -> p <@> pure iz + tr (hcomp (pure dT `applyN` g1 `applyN` p0) + [(psi,lam "j" $ \ j -> u <@> (min j (neg i))) + ,(i ,lam "j" $ \ _ -> ilam "o" $ \ _ -> u0)] + u0) + -- args : (i.old_tel) -> ... + let mkBndry args = do + args1 <- (mapM open =<<) $ (absApp <$> args <*> pure io) + -- faces ought to be constant on "j" + faces <- pure (fmap (map fst) old_sides) `applyN` args1 + us <- forM (mapM (map snd) old_sides) $ \ u -> do + lam "j" $ \ j -> ilam "o" $ \ _ -> do + args <- (mapM open =<<) $ (absApp <$> args <*> j) + pure u `applyN` args + forM (zip faces us) $ \ (phi,u) -> liftM2 (,) (open phi) (open u) + rhs <- do + d_f <- (open =<<) $ bind "j" $ \ j -> do + tel <- bind "j" $ \ j -> delta `applyN` (g1 ++ [absApp <$> pat_rec <*> j]) + let face = iz + j <- j + d <- map defaultArg <$> sequence d + lift $ covFillTele f tel face d j + let args = bind "j" $ \ j -> do + g1 <- sequence g1 + x <- absApp <$> pat_rec <*> neg j + ys <- absApp <$> d_f <*> neg j + pure $ g1 ++ x:ys + ty <- (open =<<) $ bind "j" $ \ j -> do + args <- (mapM open =<<) $ absApp <$> args <*> j + fmap unDom $ old_ty `applyN` args + let face = pure iz + othersys <- (open =<<) $ lam "j" $ \ j -> ilam "o" $ \ _ -> do + args' <- (mapM open =<<) $ absApp <$> args <*> j + fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args' + sys <- mkBndry args + let + -- we could specialize all of sysphi/syspsi/base to compute + -- away trX or the hcomp respectively, should lead to + -- smaller/more efficient terms. + -- + -- we could also ditch sysphi completely, + -- as the computation rule for hcomp would achieve the same. + sysphi = othersys + syspsi = othersys + base <- (open =<<) $ do + args' <- (mapM open =<<) $ absApp <$> args <*> pure iz + fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args' + transpSys ty ((phi,sysphi):(psi,syspsi):sys) face base + (,,) <$> ps <*> rhsTy <*> pure rhs + let (ps,ty,rhs) = unAbsN $ unAbs $ unAbs $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs + reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f + let c = Clause { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = cTel + , namedClausePats = ps + , clauseBody = Just rhs + , clauseType = Just $ Arg (getArgInfo ty) (unDom ty) + , clauseCatchall = False + , clauseExact = Nothing + , clauseRecursive = Just True + , clauseUnreachable = Just False + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing + } + debugClause "tc.cover.trx.hcomp" c + return c +createMissingTrXConClause :: QName -- trX + -> QName -- f defined + -> Arg Nat + -> BlockingVar + -> SplitClause + -> QName -- constructor name + -> UnifyEquiv + -> TCM Clause +createMissingTrXConClause q_trX f n x old_sc c (UE gamma gamma' xTel u v rho tau leftInv) = do + reportSDoc "tc.cover.trxcon" 20 $ "trX-con clause for" <+> prettyTCM f <+> "with con" <+> prettyTCM c + reportSDoc "tc.cover.trxcon" 20 $ nest 2 $ vcat $ + [ "gamma" <+> prettyTCM gamma + , "gamma'" <+> prettyTCM gamma' + , "xTel" <+> addContext gamma (prettyTCM xTel) + , "u" <+> addContext gamma (prettyTCM u) + , "v" <+> addContext gamma (prettyTCM v) + , "rho" <+> addContext gamma' (prettyTCM rho) + ] + + Constructor{conSrcCon = chead} <- theDef <$> getConstInfo c + + -- = TheInfo $ UE delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv + + -- η : Params_D ⊢ c : (a : Args(η)) → D η (ξ(η,a)) + + -- scTel old_sc = Γ1, (x : D η v), Δ + -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)] + + -- Γ = Γ1, a : Args(η) + -- Γ ⊢ u = ξ(η,a) + -- Γ ⊢ c a : D η u + + -- Γ' ⊢ ρ : Γ + + -- Γ' ⊢ u[ρ] = v[ρ] : X(η)[ρ] + + -- Γ' ⊢ c a[ρ] : (D η v)[ρ] + + -- Γ' ⊢ ρx := ρ,x = c a[ρ] : Γ,(x : D η v) + + -- Γ',Δ[ρx] ⊢ old_t[ρx] + -- Γ',Δ[ρx] ⊢ f old_ps[ρx] : old_t[ρx] [α[ρx] ↦ e[γ1,x,δ][ρx]] + + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ τ : Γ' + + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ [ρx][τ] = [ρ[τ], x = c a[ρ[τ]]] : Γ,(x : D η v) + + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path X(η) u v) + + -- Γ,(φ : I),(p : Path X(η) u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path X(η) u v) + + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path X(η) u v) + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i1 = γ ,φ ,p : Γ,(φ : I),(p : Path X(η) u v) + -- leftInv[φ = i1][i] = idS + + -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢ τ' = liftS |Δ[ρx]| τ : Γ',Δ[ρx] + + -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢ + -- w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ] + + -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ], α(γ1,x,δ)[ρx][τ'] ⊢ w = e(γ1,x,δ)[ρx][τ'] + + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v + + + -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat]) + + -- Ξ ⊢ δ_f[1] = trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]] + + -- Ξ ⊢ w[δ_f[1]] : old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ_f[1]] + -- Ξ, α(γ1,x,δ)[ρx][τ'][δ = δ_f[1]] ⊢ w[δ_f[1]] = e(γ1,x,δ)[ρx][τ'][δ_f[1]] + + -- Ξ, α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1]) ⊢ w[δ_f[1]] = e(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1]) + + -- Recap: + -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)] + -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat]) + -- Ξ ⊢ δ_f[1] := trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]] + -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢ + -- w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ] + -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v + + + -- Ξ ⊢ ?rhs : old_t[γ1,x = pat,δ] [α(γ1,pat,δ) ↦ e(γ1,pat,δ) + -- ,φ ↦ w + -- ] + + -- ?rhs := transp (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]]) φ (w[δ_f[1]]) + + -- we shall consider α(γ1,pat,δ) = α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1]) + -- also rather than (p : Path X(η) u v) we'll have (p : I -> X(η)), same as the type of trX. + + iz <- primIZero + interval <- elInf primInterval + let + old_tel = scTel old_sc + old_ps = pure $ AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc + old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + -- old_tel = Γ(x: D η v)Δ + -- Γ1, (x : D η v) ⊢ delta = (δ : Δ) + (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel + let + gammaArgNames = teleArgNames gamma + deltaArgNames = teleArgNames delta' + let + xTelI = pure $ AbsN (teleNames gamma) $ expTelescope interval xTel + delta = pure $ AbsN (teleNames gamma1x) $ delta' + gamma1_size = (size gamma1x - 1) + (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x + params <- addContext gamma1 $ do + Just (_d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType' + return $ AbsN (teleNames gamma1) ps + -- Γ, φ , p ⊢ pat := trX p φ (c a) + let pat' = + bindNArg gammaArgNames $ \ g1_args -> do + bindNArg ([defaultArg "phi"] ++ teleArgNames xTel) $ \ phi_p -> do + let (g1,args) = splitAt gamma1_size g1_args + (phi:p) <- sequence phi_p + args <- sequence args + let cargs = defaultArg $ unnamed $ ConP chead noConPatternInfo args + -- Amy (2022-11-06): Set the parameters to quantity-0. + param_args <- fmap (map (setQuantity (Quantity0 Q0Inferred) . setHiding Hidden . fmap (unnamed . dotP))) $ + pure params `applyN` take gamma1_size (fmap unArg <$> g1_args) + pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi,cargs] + pat = (fmap . fmap) patternToTerm <$> pat' + pat_left' = (fmap . fmap) (Abs "i" . (applySubst leftInv)) <$> pat + g1_left' = bindN (map unArg gammaArgNames) $ \ g1_args -> do + bindN (map unArg $ [defaultArg "phi"] ++ teleArgNames xTel) $ \ phi_p -> do + g1 <- sequence $ take gamma1_size g1_args :: NamesT TCM [Term] + pure $ Abs "i" (applySubst leftInv g1) + + gamma <- return $ pure gamma + let deltaPat g1_args phi p = + delta `applyN` (take gamma1_size g1_args ++ [pat `applyN` g1_args `applyN` (phi:p)]) + let neg i = cl primINeg <@> i + -- Ξ + cTel <- runNamesT [] $ + abstractN gamma $ \ g1_args -> do + abstractT "φ" (pure interval) $ \ phi -> do + abstractN (xTelI `applyN` g1_args) $ \ p -> do + deltaPat g1_args phi p + ps_ty_rhs <- runNamesT [] $ do + bindN (map unArg gammaArgNames) $ \ g1_args -> do + bind "phi" $ \ phi -> do + bindN (teleNames xTel) $ \ p -> do + bindN (map unArg $ deltaArgNames) $ \ d -> do + let + g1_left = g1_left' `applyN` g1_args `applyN` (phi:p) + pat_left = pat_left' `applyN` g1_args `applyN` (phi:p) + g1 :: Vars TCM + g1 = take gamma1_size g1_args + + args :: Vars TCM + args = drop gamma1_size g1_args + + ps :: NamesT TCM NAPs + ps = old_ps `applyN` (g1 ++ [pat' `applyN` g1_args `applyN` (phi:p)] ++ d) + + rhsTy = old_ty `applyN` (g1 ++ [pat `applyN` g1_args `applyN` (phi:p)] ++ d) + + -- (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) + delta_f <- (open =<<) $ bind "i" $ \ i -> do + let ni = neg i + dargs <- (mapM open =<<) $ do + xs <- absApp <$> g1_left <*> ni + y <- absApp <$> pat_left <*> ni + return $ xs ++ [y] + delta `applyN` dargs + + -- trFillTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ + d_f <- (open =<<) $ bind "i" $ \ i -> do + delta_f <- delta_f + phi <- phi + d <- map defaultArg <$> sequence d + i <- i + lift $ covFillTele f delta_f phi d i + + -- w = Def f (old_ps[g1_left[i],pat_left[i],d_f[~ i]]) + w <- (open =<<) $ bind "i" $ \ i -> do + psargs <- (mapM open =<<) $ do + xs <- absApp <$> g1_left <*> i + y <- absApp <$> pat_left <*> i + zs <- absApp <$> d_f <*> neg i + return $ xs ++ [y] ++ zs + ps <- (fmap patternsToElims <$> old_ps) `applyN` psargs + pure $ Def f ps + + + -- (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]]) + ty <- (open =<<) $ bind "i" $ \ i -> do + tyargs <- (mapM open =<<) $ do + xs <- absApp <$> g1_left <*> i + y <- absApp <$> pat_left <*> i + zs <- absApp <$> d_f <*> neg i + return $ xs ++ [y] ++ zs + fmap unDom $ old_ty `applyN` tyargs + + sys <- do + sides <- do + neg <- primINeg + io <- primIOne + vs <- iApplyVars <$> ps + tm <- w + xs <- forM vs $ \ v -> + -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?) + fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm) + return $ concatMap (\(v,(l,r)) -> [(neg `apply` [argN v],l),(v,r)]) xs + forM sides $ \ (psi,u') -> do + u' <- open u' + u <- lam "i" $ \ i -> ilam "o" $ \ o -> absApp <$> u' <*> i + (,) <$> open psi <*> open u + + let rhs = transpSys ty sys phi (absApp <$> w <*> pure iz) + + (,,) <$> ps <*> rhsTy <*> rhs + + let (ps,ty,rhs) = unAbsN $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs + qs <- mapM (fmap (fromMaybe __IMPOSSIBLE__) . getName') [builtinINeg, builtinIMax, builtinIMin] + rhs <- addContext cTel $ + locallyReduceDefs (OnlyReduceDefs (Set.fromList $ q_trX : qs)) $ normalise rhs + let cl = Clause { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = cTel + , namedClausePats = ps + , clauseBody = Just rhs + , clauseType = Just $ Arg (getArgInfo ty) (unDom ty) + , clauseCatchall = False + , clauseExact = Nothing + , clauseRecursive = Just True + , clauseUnreachable = Just False + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing + } + + + debugClause "tc.cover.trxcon" cl + + reportSDoc "tc.cover.trxcon" 20 $ vcat $ + [ "clause:" + , nest 2 $ prettyTCM . QNamed f $ cl + ] + + let mod = + setRelevance Irrelevant $ -- See #5611. + getModality $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc + -- we follow what `cover` does when updating the modality from the target. + applyModalityToContext mod $ do + unlessM (asksTC hasQuantity0) $ do + reportSDoc "tc.cover.trxcon" 20 $ text "testing usable at mod: " <+> pretty mod + addContext cTel $ usableAtModality IndexedClause mod rhs + + return cl + +-- | If given @TheInfo{}@ then assumes "x : Id u v" and +-- returns both a @SplittingDone@ for conId, and the @Clause@ that covers it. +createMissingConIdClause :: QName -- ^ function being defined + -> Arg Nat -- ^ @covSplitArg@ index + -> BlockingVar -- ^ @x@ variable being split on. + -> SplitClause -- ^ clause before split + -> IInfo -- ^ info from unification + -> TCM (Maybe ((SplitTag,SplitTree),Clause)) +createMissingConIdClause f _n x old_sc (TheInfo info) = setCurrentRange f $ do + let + -- iΓ' + itel = infoTel + -- with 3 params, reflId : Id A u u -- no arguments. + -- iΓ' ⊢ iρ : Γ + -- + -- Δ = Γ,φ,(p : u ≡ v) ⊢ iτ : iΓ' + -- ρ = iρ + -- τ = iτ + irho = infoRho info + itau = infoTau info + ileftInv = infoLeftInv info + interval <- elInf primInterval + tTrans <- primTrans + tComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp + conId <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinConId + let bindSplit (tel1,tel2) = (tel1,AbsN (teleNames tel1) tel2) + let + old_tel = scTel old_sc + + -- old_tel = Γ(x: Id A u v)Δ + -- Γ(x: Id A u v)Δ ⊢ old_t + -- Γ ⊢ hdelta = (x : Id A u v)(δ : Δ) + pair@(_gamma,_hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel + (gamma,hdelta) = bindSplit pair + old_t = AbsN (teleNames old_tel) $ fromJust $ scTarget old_sc + old_ps = AbsN (teleNames old_tel) $ patternsToElims $ fromSplitPatterns $ scPats old_sc + old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc + + params <- runNamesT [] $ do + hdelta <- open hdelta + bindN (teleNames gamma) $ \ args -> do + hdelta@(ExtendTel hdom _) <- applyN hdelta args + Def _Id es@[_,_,_,_] <- reduce $ unEl $ unDom hdom + return $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es + + working_tel <- runNamesT [] $ do + 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)) + abstractN (pure (telFromList [defaultDom ("phi",interval)] :: Telescope)) $ \ [phi] -> + abstractN pTel $ \ [p] -> do + [l,bA,x,y] <- mapM open =<< applyN params args + apply1 <$> applyN hdelta args <*> (cl primConId <#> l <#> bA <#> x <#> y <@> phi <@> p) + -- working_tel ⊢ i. γ[leftInv i] + (gamma_args_left :: Abs [Term], con_phi_p_left :: Abs Term) <- fmap (raise (size delta) . unAbsN) . runNamesT [] $ do + params <- open params + bindN (teleNames gamma ++ ["phi","p"]) $ \ args' -> do + let (args,[phi,p]) = splitAt (size gamma) args' + [l,bA,x,y] <- mapM open =<< applyN params args + gargs <- Abs "i" . applySubst ileftInv <$> sequence args + con_phi_p <- Abs "i" . applySubst ileftInv <$> do + (cl primConId <#> l <#> bA <#> x <#> y <@> phi <@> p) + return (gargs,con_phi_p) + ps <- fmap unAbsN . runNamesT [] $ do + old_ps' <- open $ old_ps' + params <- open params + bindN (teleNames working_tel) $ \ (wargs :: [NamesT TCM Term]) -> do + let (g,phi:p:d) = splitAt (size gamma) $ telePatterns working_tel [] + params <- map (argH . unnamed . dotP) <$> applyN params (take (size gamma) wargs) + let x = DefP defaultPatternInfo conId $ params ++ [phi,p] + args <- open $ map namedArg g ++ [x] ++ map namedArg d + applyN' old_ps' args + -- tel = Γ',Δ[ρ,x = refl] + -- Γ' ⊢ ρ : Γ + -- Γ' ⊢ u[ρ] = v[ρ] : A[ρ] + + -- Γ' ⊢ ρ,x=refl : Γ,(x : Id A u v) + + -- Γ',Δ[ρ,x = refl] ⊢ old_t[ρ,x=refl] = Δ₂ -> t + -- Γ',Δ[ρ,x = refl] ⊢ f old_ps[ρ,x = refl] : old_t[ρ,x = refl] + -- Γ,(φ : I),(p : Path A u v) ⊢ τ : Γ' + + -- Γ' ⊢ [ρ,x = refl u[ρ]] : Γ,(x : Id A u v) + + -- Γ,(φ : I),(p : Path A u v) ⊢ [ρ,x = refl u[ρ]][τ] = [ρ[τ], x = refl u[ρ[τ]]] : Γ,(x : Id A u v) + + -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path A u v) + + -- Γ,(φ : I),(p : Path A u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path A u v) + + -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path A u v) + -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = γ ,φ ,p : Γ,(φ : I),(p : Path A u v) + -- leftInv[φ = i1][i] = idS + + -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl] + + -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ + -- w = f old_ps[ρ[τ],x = refl u[ρ[τ]],δ] : old_t[ρ,x = refl][τ'] = old_t[ρ[τ],x = refl u[ρ[τ]],δ] + + -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨φ,p⟩[leftInv (~i)] : (Id A u v)[γ[leftInv (~ i)]] + -- μ[0] = ⟨ φ , p ⟩ + -- μ[1] = ⟨ 1 , refl ⟩ + + -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ + -- δ_f[1] = vecTransp (i. Δ[γ[leftInv (~ i)], ⟨φ,p⟩[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]] + + -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ w[δ_f[1]] : old_t[ρ[τ],x = refl u[ρ[τ]],δ_f[1]] + -- Γ,(φ : I),(p : Path A u v),Δ[x = ⟨ φ , p ⟩] ⊢ rhs = transp (i. old_t[γ[leftInv i],x = ⟨φ,p⟩[leftInv i], δ_f[~i]]) φ (w[δ_f[1]]) : old_t[γ,x = ⟨ φ , p ⟩,δ] + let + getLevel t = do + s <- reduce $ getSort t + case s of + Type l -> pure (Level l) + s -> do + reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s + typeError . GenericDocError =<< + (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"") + (ty,rhs) <- addContext working_tel $ runNamesT [] $ do + let + raiseFrom :: Subst a => Telescope -> a -> a + raiseFrom tel x = raise (size working_tel - size tel) x + all_args = teleArgs working_tel :: Args + (gamma_args,phi:p:delta_args) = splitAt (size gamma) all_args + old_t <- open $ raiseFrom EmptyTel old_t + old_ps <- open $ raiseFrom EmptyTel old_ps + delta_args <- open delta_args + gamma_args_left <- open gamma_args_left + con_phi_p_left <- open con_phi_p_left + hdelta <- open $ raiseFrom gamma hdelta + delta_f <- bind "i" $ \ i -> do + apply1 <$> applyN' hdelta (lazyAbsApp <$> gamma_args_left <*> (cl primINeg <@> i)) <*> (lazyAbsApp <$> con_phi_p_left <*> (cl primINeg <@> i)) + delta_f <- open delta_f + [phi,p] <- mapM (open . unArg) [phi,p] + delta_args_f <- bind "i" $ \ i -> do + + m <- trFillTel' True <$> delta_f <*> phi <*> delta_args <*> i + 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 + x <- lazyAbsApp <$> con_phi_p_left <*> i + d <- lazyAbsApp <$> delta_args_f <*> (cl primINeg <@> i) + args <- open $ g ++ [x] ++ map unArg d + applyN' old_t args + w <- (open =<<) $ bind "i" $ \ i -> do + g <- lazyAbsApp <$> gamma_args_left <*> i + x <- lazyAbsApp <$> con_phi_p_left <*> i + d <- lazyAbsApp <$> delta_args_f <*> (cl primINeg <@> i) + args <- open $ g ++ [x] ++ map unArg d + Def f <$> applyN' old_ps args + + ps <- open ps + max <- primIMax + iz <- primIZero + alphas <- (open =<<) $ do + vs <- iApplyVars <$> ps + neg <- primINeg + zero <- primIZero + return $ foldr (\ x r -> max `apply` [argN $ max `apply` [argN x, argN (neg `apply` [argN x])], argN r]) zero $ map var vs + sides <- (open =<<) $ do + neg <- primINeg + io <- primIOne + bind "i" $ \ i -> do + vs <- iApplyVars <$> ps + tm <- lazyAbsApp <$> w <*> i + xs <- forM vs $ \ v -> + -- have to reduce these under the appropriate substitutions, otherwise non-normalizing + fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm) + phiv <- fromMaybe __IMPOSSIBLE__ . deBruijnView <$> phi + -- extra assumption: phi |- w i = w 0, otherwise we need [ phi -> w 0 ] specifically + tm_phi <- reduce $ inplaceS phiv io `applySubst` tm + phi <- phi + return $ (phi,tm_phi) : concatMap (\(v,(l,r)) -> [(neg `apply` [argN v],l),(v,r)]) xs + + let imax i j = apply max $ map argN [i,j] + tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr + let + pOr l ty phi psi u0 u1 = do + [phi,psi] <- mapM open [phi,psi] + pure tPOr <#> l + <@> phi <@> psi + <#> (ilam "o" $ \ _ -> ty) <@> noilam u0 <@> u1 + + noilam u = do + u <- open u + ilam "o" $ \ _ -> u + + combine l ty [] = __IMPOSSIBLE__ + combine l ty [(psi,u)] = noilam u + combine l ty ((psi,u):xs) = pOr l ty psi (foldr imax iz (map fst xs)) u (combine l ty xs) + + let ty i = lazyAbsApp <$> old_t_f <*> i + l <- (open =<<) $ lam "i" $ \ i -> do + t <- unDom <$> ty i + lift $ getLevel t + ((,) <$> ty (cl primIOne) <*>) $ do + 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) + <@> (cl primIMax <@> phi <@> alphas) + <@> (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) + <@> phi + <@> (lazyAbsApp <$> w <*> primIZero) + + reportSDoc "tc.cover.conid" 20 $ text "conid case for" <+> text (show f) + reportSDoc "tc.cover.conid" 20 $ text "tel =" <+> prettyTCM working_tel + reportSDoc "tc.cover.conid" 25 $ addContext working_tel $ prettyTCM rhs + + let cl = Clause { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = working_tel + , namedClausePats = ps + , clauseBody = Just $ rhs + , clauseType = Just $ Arg (domInfo ty) (unDom ty) + , clauseCatchall = False + , clauseUnreachable = Just False -- missing, thus, not unreachable + , clauseRecursive = Just False + , clauseEllipsis = NoEllipsis + , clauseExact = Nothing + , clauseWhereModule = Nothing + } + addClauses f [cl] + return $ Just ((SplitCon conId,SplittingDone (size working_tel)),cl) +createMissingConIdClause f n x old_sc NoInfo = return Nothing + + +{- + OLD leftInv case + -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ] ≡ wkS 2 : Γ + -- Γ,(φ : I),(p : Path A u v)(i : I) ⊢ leftInv i : Γ + -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ] : Γ + -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = wkS 2 : Γ + -- leftInv[φ = i1][i] = wkS 2 + + -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl] + + -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ w = f old_ps[ρ,x = refl][τ'] : old_t[ρ,x = refl][τ'] + + -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨ (φ ∨ ~ i) , (\ j → p (i ∧ j)) ⟩ : Id A u (p i) =?= (Id A u v)[leftInv (~ i)] + μ[0] = ⟨ 1 , (\ _ → u[ρ[τ]]) ⟩ + μ[1] = ⟨ φ , p ⟩ + -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ vecTransp (i. Δ[leftInv (~ i),μ[i]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]] +-} + +-- | Append an hcomp clause to the clauses of a function. +createMissingHCompClause + :: QName + -- ^ Function name. + -> Arg Nat -- ^ index of hcomp pattern + -> BlockingVar -- ^ Blocking var that lead to hcomp split. + -> SplitClause -- ^ Clause before the hcomp split + -> SplitClause + -- ^ Clause to add. + -> [Clause] + -> TCM ([(SplitTag,CoverResult)], [Clause]) +createMissingHCompClause f n x old_sc (SClause tel ps _sigma' _cps (Just t)) cs = setCurrentRange f $ do + reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "Trying to create right-hand side of type" <+> prettyTCM t + reportSDoc "tc.cover.hcomp" 30 $ addContext tel $ text "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps) + reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel + + io <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne + iz <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero + let + cannotCreate :: MonadTCError m => Doc -> Closure (Abs Type) -> m a + cannotCreate doc t = do + typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t + let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc + old_t = fromJust $ scTarget old_sc + old_tel = scTel old_sc + -- old_tel = Γ(x:H)Δ + -- Γ(x:H)Δ ⊢ old_t + -- vs = iApplyVars old_ps + -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs] + + -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] + -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ] + -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0) + + -- Extra assumption: + -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ' + -- ps = old_ps[x = hcomp φ u u0],ps' + -- with Δ' and ps' introduced by fixTarget. + -- So final clause will be: + -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps' + getLevel t = do + s <- reduce $ getSort t + case s of + Type l -> pure (Level l) + s -> do + reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s + typeError . GenericDocError =<< + (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"") + + -- Γ ⊢ hdelta = (x : H)(δ : Δ) + (gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel + + -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ + (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel + + -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ) + {- rhoS = liftS (size hdelta) $ raiseS 3 -} + vs = iApplyVars (scPats old_sc) + + -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs] + alphab <- forM vs $ \ i -> do + let + -- Γ(x:H)(δ : Δ) ⊢ + tm = Def f old_ps + -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems + (l,r) <- reduce (inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm) + return $ (var i, (l, r)) + + + + cl <- do + (ty,rhs) <- addContext working_tel $ do + -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ] + -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] + -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i] + -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i] + -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]] + -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i]) + -- (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]] + -- α ↦ b[x = hfill φ u u0 i,δ_fill[i]] + -- ]) + -- (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ] + + runNamesT [] $ do + tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr + tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax + tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin + tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg + tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp + tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans + extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps + let + ineg j = pure tINeg <@> j + imax i j = pure tIMax <@> i <@> j + trFillTel' a b c d = do + m <- trFillTel <$> a <*> b <*> c <*> d + x <- lift $ runExceptT m + case x of + Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t + Right args -> return args + comp <- mkCompLazy "hcompClause" + let + hcomp la bA phi u u0 = pure tHComp <#> la <#> bA + <#> phi + <@> u + <@> u0 + + hfill la bA phi u u0 i = hcomp la bA + (pure tIMax <@> phi <@> (pure tINeg <@> i)) + (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA) + <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o) + <@> ilam "o" (\ _ -> u0) + ) + u0 + -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ) + hcompS <- lift $ do + hdom <- pure $ raise 3 hdom + let + [phi,u,u0] = map (pure . var) [2,1,0] + htype = pure $ unEl . unDom $ hdom + lvl = getLevel $ unDom hdom + hc <- pure tHComp <#> lvl <#> htype + <#> phi + <@> u + <@> u0 + return $ liftS (size delta) $ hc `consS` raiseS 3 + -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom + hdom <- pure $ raise (3+size delta) hdom + htype <- open $ unEl . unDom $ hdom + lvl <- open =<< (lift . getLevel $ unDom hdom) + + -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ + [phi,u,u0] <- mapM (open . raise (size delta) . var) [2,1,0] + -- Γ,x,Δ ⊢ f old_ps + -- Γ ⊢ abstract hdelta (f old_ps) + g <- open $ raise (3+size delta) $ abstract hdelta (Def f old_ps) + old_t <- open $ raise (3+size delta) $ abstract hdelta (unDom old_t) + let bapp a x = lazyAbsApp <$> a <*> x + (delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do + -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ + delta <- open $ raise (3+size delta) delta + -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i)) + deltaf <- open =<< bind "i" (\ i -> + (delta `bapp` hfill lvl htype phi u u0 (ineg i))) + -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0] + args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz) + bind "i" $ \ i -> addContext ("i" :: String) $ do -- for error messages. + -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i) + trFillTel' deltaf (pure iz) args (ineg i) + let + apply_delta_fill i f = apply <$> f <*> (delta_fill `bapp` i) + call v i = apply_delta_fill i $ g <@> v + ty <- do + return $ \ i -> do + v <- hfill lvl htype phi u u0 i + hd <- old_t + args <- delta_fill `bapp` i + lift $ piApplyM hd $ Arg (domInfo hdom) v : args + ty_level <- do + t <- bind "i" $ \ x -> ty x + s <- reduce $ getSort (absBody t) + reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s + case s of + Type l -> open =<< lam "i" (\ _ -> pure $ Level l) + _ -> do cl <- liftTCM (buildClosure t) + liftTCM (cannotCreate "Cannot compose with type family:" cl) + + let + pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i) + <@> phi <@> psi + <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1 + alpha <- do + vars <- mapM (open . applySubst hcompS . fst) alphab + return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars + + -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]] + b <- do + sides <- forM alphab $ \ (psi,(side0,side1)) -> do + psi <- open $ hcompS `applySubst` psi + + [side0,side1] <- mapM (open . raise (3+size delta) . abstract hdelta) [side0,side1] + return $ (ineg psi `imax` psi, \ i -> pOr_ty i (ineg psi) psi (ilam "o" $ \ _ -> apply_delta_fill i $ side0 <@> hfill lvl htype phi u u0 i) + (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i)) + let recurse [] i = __IMPOSSIBLE__ + recurse [(psi,u)] i = u i + recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i) + return $ recurse sides + + ((,) <$> ty (pure io) <*>) $ do + comp ty_level + (lam "i" $ fmap unEl . ty) + (phi `imax` alpha) + (lam "i" $ \ i -> + let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i) + in if null alphab then rhs else + pOr_ty i phi alpha rhs (b i) + ) + (call u0 (pure iz)) + reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel + let n = size tel - (size gamma + 3 + size delta) + reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n) + (TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty + rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs + + cxt <- getContextTelescope + reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt + reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel + reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t + reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs + + return $ Clause { clauseLHSRange = noRange + , clauseFullRange = noRange + , clauseTel = tel + , namedClausePats = fromSplitPatterns ps + , clauseBody = Just $ rhs + , clauseType = Just $ defaultArg t + , clauseCatchall = False + , clauseExact = Just True + , clauseRecursive = Nothing -- TODO: can it be recursive? + , clauseUnreachable = Just False -- missing, thus, not unreachable + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing + } + addClauses f [cl] -- Important: add at the end. + let result = CoverResult + { coverSplitTree = SplittingDone (size (clauseTel cl)) + , coverUsedClauses = IntSet.singleton (length cs) + , coverMissingClauses = [] + , coverPatterns = [cl] + , coverNoExactClauses = IntSet.empty + } + hcompName <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp + return ([(SplitCon hcompName,result)],cs++[cl]) +createMissingHCompClause _ _ _ _ (SClause _ _ _ _ Nothing) _ = __IMPOSSIBLE__ diff --git a/src/full/Agda/TypeChecking/Coverage/Match.hs b/src/full/Agda/TypeChecking/Coverage/Match.hs --- a/src/full/Agda/TypeChecking/Coverage/Match.hs +++ b/src/full/Agda/TypeChecking/Coverage/Match.hs @@ -13,7 +13,8 @@ module Agda.TypeChecking.Coverage.Match ( Match(..), match, matchClause - , SplitPattern, SplitPatVar(..), fromSplitPatterns, toSplitPatterns + , SplitPattern, SplitPatVar(..) + , fromSplitPattern, fromSplitPatterns, toSplitPatterns , toSplitPSubst, applySplitPSubst , isTrivialPattern , BlockingVar(..), BlockingVars, BlockedOnResult(..) @@ -25,6 +26,8 @@ import Prelude hiding ( null ) +import Data.DList (DList) +import Data.Foldable (toList) import qualified Data.List as List import Data.Maybe (mapMaybe, fromMaybe) import Data.Semigroup ( Semigroup, (<>)) @@ -43,6 +46,7 @@ import Agda.Utils.Null import Agda.Utils.Pretty ( Pretty(..), text, (<+>), cat , prettyList_ ) import Agda.Utils.Monad +import Agda.Utils.Singleton import Agda.Utils.Impossible @@ -110,7 +114,7 @@ => Nat -- Clause number. -> Clause -> m (Match (Nat, SplitInstantiation)) - matchIt i c = fmap (i,) <$> matchClause ps c + matchIt i c = fmap (\s -> (i, toList s)) <$> matchClause ps c -- | For each variable in the patterns of a split clause, we remember the -- de Bruijn-index and the literals excluded by previous matches. @@ -147,8 +151,11 @@ toSplitPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern] toSplitPatterns = (fmap . fmap . fmap . fmap) toSplitVar +fromSplitPattern :: NamedArg SplitPattern -> NamedArg DeBruijnPattern +fromSplitPattern = (fmap . fmap . fmap) fromSplitVar + fromSplitPatterns :: [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern] -fromSplitPatterns = (fmap . fmap . fmap . fmap) fromSplitVar +fromSplitPatterns = fmap fromSplitPattern type SplitPSubstitution = Substitution' SplitPattern @@ -219,7 +226,7 @@ -- | If matching succeeds, we return the instantiation of the clause pattern vector -- to obtain the split clause pattern vector. -type MatchResult = Match SplitInstantiation +type MatchResult = Match (DList (Nat, SplitPattern)) instance Pretty BlockingVar where pretty (BlockingVar i cs ls o l) = cat @@ -342,7 +349,7 @@ -> m MatchResult -- ^ Result. -- If 'Yes' the instantiation @rs@ such that @ps[rs] == qs@. -matchPats [] [] = yes [] +matchPats [] [] = yes mempty matchPats (p:ps) (q:qs) = matchPat (namedArg p) (namedArg q) `combine` matchPats ps qs @@ -352,8 +359,8 @@ -- Thus, if the split clause has copatterns left, -- the current (shorter) clause is not considered covering. matchPats [] qs@(_:_) = case mapMaybe isProjP qs of - [] -> yes [] -- no proj. patterns left - _ -> no -- proj. patterns left + [] -> yes mempty -- no proj. patterns left + _ -> no -- proj. patterns left -- Patterns left in candidate clause: -- If the current clause has additional copatterns in @@ -408,9 +415,10 @@ -- to produce the split clause pattern, @p[rs] = q@. matchPat p q = case p of - VarP _ x -> yes [(fromMaybe __IMPOSSIBLE__ (deBruijnView x),q)] + VarP _ x -> + yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q) - DotP{} -> yes [] + DotP{} -> yes mempty -- Jesper, 2014-11-04: putting 'Yes [q]' here triggers issue 1333. -- Not checking for trivial patterns should be safe here, as dot patterns are -- guaranteed to match if the rest of the pattern does, so some extra splitting @@ -421,16 +429,17 @@ then no else blockedOnLiteral (splitPatVarIndex x) l _ -> isLitP q >>= \case - Just l' -> if l == l' then yes [] else no + Just l' -> if l == l' then yes mempty else no Nothing -> no ProjP _ d -> case q of ProjP _ d' -> do d <- getOriginalProjection d - if d == d' then yes [] else no + if d == d' then yes mempty else no _ -> __IMPOSSIBLE__ - IApplyP _ _ _ x -> yes [(fromMaybe __IMPOSSIBLE__ (deBruijnView x),q)] + IApplyP _ _ _ x -> + yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q) -- Issue #4179: If the inferred pattern is a literal -- v we need to turn it into a constructor pattern. @@ -446,7 +455,7 @@ IApplyP _ _ _ x -> blockedOnConstructor (splitPatVarIndex x) c ci DefP o c ps -> unDotP q >>= \case - VarP _ x -> __IMPOSSIBLE__ -- blockedOnConstructor (splitPatVarIndex x) c + VarP _ x -> no ConP c' i qs -> no DotP o t -> no LitP{} -> no diff --git a/src/full/Agda/TypeChecking/Coverage/SplitClause.hs b/src/full/Agda/TypeChecking/Coverage/SplitClause.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Coverage/SplitClause.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE NondecreasingIndentation #-} + +{-| SplitClause and CoverResult types. + + -} + +module Agda.TypeChecking.Coverage.SplitClause where + +import Prelude hiding (null, (!!)) -- do not use partial functions like !! + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Trans ( lift ) + +import Data.Foldable (for_) +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Agda.Syntax.Common +import Agda.Syntax.Position +import Agda.Syntax.Internal hiding (DataOrRecord(..)) +import Agda.Syntax.Internal.Pattern +import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..)) + +import Agda.TypeChecking.Names +import Agda.TypeChecking.Primitive hiding (Nat) +import Agda.TypeChecking.Monad + +import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar) +import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars) +import Agda.TypeChecking.Rules.LHS.Unify +import Agda.TypeChecking.Rules.Term (unquoteTactic) + +import Agda.TypeChecking.Coverage.Match +import Agda.TypeChecking.Coverage.SplitTree + +import Agda.TypeChecking.Conversion (tryConversion, equalType) +import Agda.TypeChecking.Datatypes (getConForm) +import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType ) +import Agda.TypeChecking.Irrelevance +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Records +import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Telescope.Path +import Agda.TypeChecking.MetaVars +import Agda.TypeChecking.Warnings + +import Agda.Interaction.Options + +import Agda.Utils.Either +import Agda.Utils.Functor +import Agda.Utils.List +import Agda.Utils.Maybe +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.Permutation +import Agda.Utils.Pretty (prettyShow) +import Agda.Utils.Singleton +import Agda.Utils.Size +import Agda.Utils.WithDefault + +import Agda.Utils.Impossible + + +data SplitClause = SClause + { scTel :: Telescope + -- ^ Type of variables in @scPats@. + , scPats :: [NamedArg SplitPattern] + -- ^ The patterns leading to the currently considered branch of + -- the split tree. + , scSubst :: Substitution' SplitPattern + -- ^ Substitution from 'scTel' to old context. + -- Only needed directly after split on variable: + -- * To update 'scTarget' + -- * To rename other split variables when splitting on + -- multiple variables. + -- @scSubst@ is not ``transitive'', i.e., does not record + -- the substitution from the original context to 'scTel' + -- over a series of splits. It is freshly computed + -- after each split by 'computeNeighborhood'; also + -- 'splitResult', which does not split on a variable, + -- should reset it to the identity 'idS', lest it be + -- applied to 'scTarget' again, leading to Issue 1294. + , scCheckpoints :: Map CheckpointId Substitution + -- ^ We need to keep track of the module parameter checkpoints for the + -- clause for the purpose of inferring missing instance clauses. + , scTarget :: Maybe (Dom Type) + -- ^ The type of the rhs, living in context 'scTel'. + -- 'fixTargetType' computes the new 'scTarget' by applying + -- substitution 'scSubst'. + } + +data UnifyEquiv = UE { infoTel0 :: Telescope -- Γ0 + , infoTel :: Telescope -- Γ' + , infoEqTel :: Telescope -- Γ0 ⊢ Δ + , infoEqLHS :: [Term] -- Γ0 ⊢ us : Δ + , infoEqRHS :: [Term] -- Γ0 ⊢ vs : Δ + , infoRho :: PatternSubstitution -- Γ' ⊢ ρ : Γ0 + -- Γ = Γ0,(φ : I),(eqs : Paths Δ us vs) + -- Γ' ⊢ ρ,i1,refls : Γ + , infoTau :: Substitution -- Γ ⊢ τ : Γ' + , infoLeftInv :: Substitution -- Γ | (i : I) ⊢ leftInv : Γ + -- leftInv[i=0] = ρ[τ],i1s,refls + -- leftInv[i=1] = idS + } + deriving Show + +data IInfo = TheInfo UnifyEquiv | NoInfo deriving Show + +-- | A @Covering@ is the result of splitting a 'SplitClause'. +data Covering = Covering + { covSplitArg :: Arg Nat + -- ^ De Bruijn level (counting dot patterns) of argument we split on. + , covSplitClauses :: [(SplitTag, (SplitClause, IInfo))] + -- ^ Covering clauses, indexed by constructor/literal these clauses share. + } + +-- | Project the split clauses out of a covering. +splitClauses :: Covering -> [SplitClause] +splitClauses (Covering _ qcs) = map (fst . snd) qcs + +-- | Create a split clause from a clause in internal syntax. Used by make-case. +clauseToSplitClause :: Clause -> SplitClause +clauseToSplitClause cl = SClause + { scTel = clauseTel cl + , scPats = toSplitPatterns $ namedClausePats cl + , scSubst = idS -- Andreas, 2014-07-15 TODO: Is this ok? + , scCheckpoints = Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing + , scTarget = domFromArg <$> clauseType cl + } + + +--------------------------------------------- +-- Record type for the results of @cover@ +--------------------------------------------- + +data CoverResult = CoverResult + { coverSplitTree :: SplitTree + , coverUsedClauses :: IntSet -- Set Nat + , coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])] + , coverPatterns :: [Clause] + -- ^ The set of patterns used as cover. + , coverNoExactClauses :: IntSet -- Set Nat + } diff --git a/src/full/Agda/TypeChecking/Coverage/SplitTree.hs b/src/full/Agda/TypeChecking/Coverage/SplitTree.hs --- a/src/full/Agda/TypeChecking/Coverage/SplitTree.hs +++ b/src/full/Agda/TypeChecking/Coverage/SplitTree.hs @@ -15,7 +15,6 @@ import Control.DeepSeq import Data.Tree -import Data.Data (Data) import GHC.Generics (Generic) @@ -46,10 +45,10 @@ , splitLazy :: LazySplit , splitTrees :: SplitTrees' a -- ^ Sub split trees. } - deriving (Data, Show, Generic) + deriving (Show, Generic) data LazySplit = LazySplit | StrictSplit - deriving (Data, Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic) -- | Split tree branching. A finite map from constructor names to splittrees -- A list representation seems appropriate, since we are expecting not @@ -64,7 +63,7 @@ = SplitCon QName | SplitLit Literal | SplitCatchall - deriving (Show, Eq, Ord, Data, Generic) + deriving (Show, Eq, Ord, Generic) instance Pretty SplitTag where pretty (SplitCon c) = pretty c 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 @@ -33,6 +33,9 @@ Record { recConHead = c' } -> return c' _ -> throwError $ SigUnknown $ prettyShow c ++ " is not a constructor" +isConstructor :: (HasConstInfo m) => QName -> m Bool +isConstructor q = isRight <$> getConHead q + -- | Get true constructor with fields, expanding literals to constructors -- if possible. getConForm :: QName -> TCM (Either SigError ConHead) @@ -66,6 +69,15 @@ Record{} -> return False _ -> __IMPOSSIBLE__ +isPathCons :: HasConstInfo m => QName -> m Bool +isPathCons c = do + d <- getConstructorData c + def <- theDef <$> getConstInfo d + case def of + Datatype {dataPathCons = xs} -> return $ c `elem` xs + Record{} -> return False + _ -> __IMPOSSIBLE__ + -- | @getConType c t@ computes the constructor parameters from type @t@ -- and returns them plus the instantiated type of constructor @c@. -- This works also if @t@ is a function type ending in a data/record type; @@ -165,16 +177,19 @@ -- For getting just the arity of constructor @c@, -- use @either id size <$> getConstructorArity c@. getConstructorInfo :: HasConstInfo m => QName -> m ConstructorInfo -getConstructorInfo c = do +getConstructorInfo c = fromMaybe __IMPOSSIBLE__ <$> getConstructorInfo' c + +getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo) +getConstructorInfo' c = do (theDef <$> getConstInfo c) >>= \case - Constructor{ conData = d, conArity = n } -> do + Constructor{ conData = d, conArity = n } -> Just <$> do (theDef <$> getConstInfo d) >>= \case r@Record{ recFields = fs } -> return $ RecordCon (recPatternMatching r) (recEtaEquality r) fs Datatype{} -> return $ DataCon n _ -> __IMPOSSIBLE__ - _ -> __IMPOSSIBLE__ + _ -> return Nothing --------------------------------------------------------------------------- -- * Data types @@ -211,6 +226,23 @@ Record{ recPars = n } -> return $ Just n Constructor{ conPars = n } -> return $ Just n _ -> return Nothing + +-- | This is a simplified version of @isDatatype@ from @Coverage@, +-- useful when we do not want to import the module. +getDatatypeArgs :: HasConstInfo m => Type -> m (Maybe (QName, Args, Args)) +getDatatypeArgs t = do + case unEl t of + Def d es -> do + let ~(Just args) = allApplyElims es + def <- theDef <$> getConstInfo d + case def of + Datatype{dataPars = np} -> do + let !(ps, is) = splitAt np args + return $ Just (d, ps, is) + Record{} -> do + return $ Just (d, args, []) + _ -> return Nothing + _ -> return Nothing getNotErasedConstructors :: QName -> TCM [QName] getNotErasedConstructors d = do 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 @@ -1,14 +1,22 @@ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where +import qualified Control.Exception as E +import Control.Monad.Trans + +import Data.Maybe import Data.Monoid (All(..)) -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.Internal +import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Internal.Names import Agda.Syntax.Scope.Base @@ -18,34 +26,122 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce +import Agda.Utils.Impossible import Agda.Utils.Lens +import Agda.Utils.WithDefault --- | Run before serialisation to remove any definitions that are not reachable --- from the public interface to the module. -eliminateDeadCode :: DisplayForms -> Signature -> TCM (DisplayForms, Signature) -eliminateDeadCode disp sig = Bench.billTo [Bench.DeadCode] $ do +-- | 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 :: + BuiltinThings PrimFun -> DisplayForms -> Signature -> + LocalMetaStore -> + TCM (DisplayForms, Signature, RemoteMetaStore) +eliminateDeadCode bs disp sig ms = Bench.billTo [Bench.DeadCode] $ do patsyn <- getPatternSyns public <- Set.mapMonotonic anameName . publicNames <$> getScope - defs <- traverse instantiateFull $ sig ^. sigDefinitions + save <- collapseDefault . optSaveMetas <$> pragmaOptions + defs <- (if save then return else traverse instantiateFull) + (sig ^. sigDefinitions) -- #2921: Eliminating definitions with attached COMPILE pragmas results in -- the pragmas not being checked. Simple solution: don't eliminate these. - let hasCompilePragma = Set.fromList . HMap.keys . HMap.filter (not . Map.null . defCompiledRep) $ defs - let r = reachableFrom (Set.union public hasCompilePragma) patsyn defs - dead = Set.fromList (HMap.keys defs) `Set.difference` r + -- #6022 (Andreas, 2022-09-30): Eliminating cubical primitives can lead to crashes. + -- Simple solution: retain all primitives (shouldn't be many). + let hasCompilePragma = not . MapS.null . defCompiledRep + isPrimitive = \case + Primitive{} -> True + PrimitiveSort{} -> True + _ -> False + extraRootsFilter (name, def) + | hasCompilePragma def || isPrimitive (theDef def) = Just name + | otherwise = Nothing + extraRoots = + Set.fromList $ mapMaybe extraRootsFilter $ HMap.toList defs + + 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) = + reachableFrom (rootNames, rootMetas) patsyn disp defs ms + 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 r) defs + $ HMap.filterWithKey (\ x _ -> Set.member x rns) defs disp' = HMap.filter (not . null) $ HMap.map (filter valid) disp - reportSLn "tc.dead" 10 $ "Removed " ++ show (HMap.size defs - HMap.size defs') ++ " unused definitions." - return (disp', set sigDefinitions defs' sig) + ms' = HMap.fromList $ + mapMaybe + (\(m, mv) -> + if not (Set.member m rms) + then Nothing + else Just (m, remoteMetaVariable mv)) $ + MapS.toList ms + -- The hashmaps are forced to WHNF to ensure that the computations + -- are billed to the right account. + disp' <- liftIO $ E.evaluate disp' + defs' <- liftIO $ E.evaluate defs' + ms' <- liftIO $ E.evaluate ms' + 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." + return (disp', set sigDefinitions defs' sig, ms') -reachableFrom :: Set QName -> A.PatternSynDefns -> Definitions -> Set QName -reachableFrom names psyns defs = follow names (Set.toList names) +reachableFrom + :: (Set QName, Set MetaId) -- ^ Roots. + -> A.PatternSynDefns -> DisplayForms -> Definitions -> LocalMetaStore + -> (Set QName, Set MetaId) +reachableFrom (ids, ms) psyns disp defs insts = + follow (ids, ms) + (map Left (Set.toList ids) ++ map Right (Set.toList ms)) where - follow visited [] = visited - follow visited (x : xs) = follow (Set.union visited new) (Set.toList new ++ xs) - where - new = names `Set.difference` visited - names = case HMap.lookup x defs of - Nothing -> namesIn (PSyn <$> Map.lookup x psyns) - Just d -> namesIn d + follow seen [] = seen + follow (!ids, !ms) (x : xs) = + follow (Set.union ids'' ids, Set.union ms'' ms) + (map Left (Set.toList ids'') ++ + map Right (Set.toList ms'') ++ + xs) + where + ids'' = ids' `Set.difference` ids + ms'' = ms' `Set.difference` ms + + (ids', ms') = case x of + Left x -> + namesAndMetasIn + ( HMap.lookup x defs + , PSyn <$> MapS.lookup x psyns + , HMap.lookup x disp + ) + Right m -> case MapS.lookup m insts of + Nothing -> (Set.empty, Set.empty) + Just mv -> namesAndMetasIn (instBody (theInstantiation mv)) + +-- | 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__ + BlockedConst{} -> __IMPOSSIBLE__ + PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__ + +-- | Converts from 'MetaVariable' to 'RemoteMetaVariable'. +-- +-- Precondition: The instantiation must be of the form @'InstV' inst@. + +remoteMetaVariable :: MetaVariable -> RemoteMetaVariable +remoteMetaVariable mv = RemoteMetaVariable + { rmvInstantiation = theInstantiation mv + , rmvModality = getModality mv + , rmvJudgement = mvJudgement mv + } diff --git a/src/full/Agda/TypeChecking/DisplayForm.hs b/src/full/Agda/TypeChecking/DisplayForm.hs --- a/src/full/Agda/TypeChecking/DisplayForm.hs +++ b/src/full/Agda/TypeChecking/DisplayForm.hs @@ -137,7 +137,7 @@ unionMatch :: Monad m => MatchResult -> MatchResult -> MaybeT m MatchResult unionMatch m1 m2 - | Set.disjoint (Map.keysSet m1) (Map.keysSet m2) = return $ Map.union m1 m2 + | null (Map.intersection m1 m2) = return $ Map.union m1 m2 | otherwise = mzero -- Non-linear pattern, fail for now. unionsMatch :: Monad m => [MatchResult] -> MaybeT m MatchResult 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 @@ -21,6 +21,7 @@ import Agda.TypeChecking.Coverage import Agda.TypeChecking.Coverage.Match ( fromSplitPatterns ) import Agda.TypeChecking.Records +import Agda.TypeChecking.Reduce ( instantiateFull ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope @@ -36,7 +37,7 @@ | DontKnow Blocker -- ^ Emptyness check blocked instance Semigroup ErrorNonEmpty where - DontKnow u1 <> DontKnow u2 = DontKnow $ u1 <> u2 -- Both must unblock for this to proceed + DontKnow u1 <> DontKnow u2 = DontKnow $ unblockOnBoth u1 u2 -- Both must unblock for this to proceed e@DontKnow{} <> _ = e _ <> e@DontKnow{} = e FailBecause err <> _ = FailBecause err @@ -88,7 +89,9 @@ dontAssignMetas $ do r <- splitLast Inductive tel ps case r of - Left UnificationStuck{} -> return $ Left $ DontKnow $ unblockOnAnyMetaIn tel + Left UnificationStuck{} -> do + blocker <- unblockOnAnyMetaIn <$> instantiateFull tel -- TODO Jesper: get proper blocking information from unification + return $ Left $ DontKnow blocker Left _ -> return $ Left Fail Right cov -> do let ps = map (namedArg . lastWithDefault __IMPOSSIBLE__ . fromSplitPatterns . scPats) $ splitClauses cov 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 @@ -17,17 +17,19 @@ , dropTopLevelModule , topLevelModuleDropper , stringTCErr + , explainWhyInScope + , Verbalize(verbalize) ) where import Prelude hiding ( null, foldl ) +import qualified Control.Exception as E import Control.Monad.Except import qualified Data.CaseInsensitive as CaseInsens import Data.Foldable (foldl) -import Data.Function +import Data.Function (on) import Data.List (sortBy, dropWhileEnd, intercalate) -import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import qualified Data.Set as Set import qualified Text.PrettyPrint.Boxes as Boxes @@ -48,6 +50,7 @@ import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug +import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.SizedTypes ( sizeType ) import Agda.TypeChecking.Monad.State @@ -107,7 +110,7 @@ tcErrString err = prettyShow (getRange err) ++ " " ++ case err of TypeError _ _ cl -> errorString $ clValue cl Exception r s -> prettyShow r ++ " " ++ show s - IOException _ r e -> prettyShow r ++ " " ++ show e + IOException _ r e -> prettyShow r ++ " " ++ E.displayException e PatternErr{} -> "PatternErr" stringTCErr :: String -> TCErr @@ -232,6 +235,7 @@ UnequalRelevance{} -> "UnequalRelevance" UnequalQuantity{} -> "UnequalQuantity" UnequalCohesion{} -> "UnequalCohesion" + UnequalFiniteness{} -> "UnequalFiniteness" UnequalHiding{} -> "UnequalHiding" UnequalLevel{} -> "UnequalLevel" UnequalSorts{} -> "UnequalSorts" @@ -291,14 +295,10 @@ -- | Produces a function which drops the filename component of the qualified name. topLevelModuleDropper :: (MonadDebug m, MonadTCEnv m, ReadTCState m) => m (QName -> QName) -topLevelModuleDropper = do - caseMaybeM (asksTC envCurrentPath) (return id) $ \ f -> do - reportSDoc "err.dropTopLevel" 60 $ vcat - [ "current path =" <+> (text . filePath) f - , "moduleToSource =" <+> do text . show =<< useR stModuleToSource - ] - m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f - return $ dropTopLevelModule' $ size m +topLevelModuleDropper = + caseMaybeM currentTopLevelModule + (return id) + (return . dropTopLevelModule' . size) instance PrettyTCM TypeError where prettyTCM err = case err of @@ -597,6 +597,11 @@ pwords "because one is a non-flat function type and the other is a flat function type" -- FUTURE Cohesion: update message if/when introducing sharp. + UnequalFiniteness cmp a b -> fsep $ + [prettyTCM a, notCmp cmp, prettyTCM b] ++ + pwords "because one is a type of partial elements and the other is a function type" + -- FUTURE Cohesion: update message if/when introducing sharp. + UnequalHiding a b -> fsep $ [prettyTCM a, "!=", prettyTCM b] ++ pwords "because one is an implicit function type and the other is an explicit function type" @@ -804,11 +809,11 @@ NoSuchModule x -> fsep $ pwords "No module" ++ [pretty x] ++ pwords "in scope" - AmbiguousName x ys -> vcat + AmbiguousName x reason -> vcat [ fsep $ pwords "Ambiguous name" ++ [pretty x <> "."] ++ pwords "It could refer to any one of" - , nest 2 $ vcat $ fmap nameWithBinding ys - , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)" + , nest 2 $ vcat $ fmap nameWithBinding $ ambiguousNamesInReason reason + , explainWhyInScope $ whyInScopeDataFromAmbiguousNameReason x reason ] AmbiguousModule x ys -> vcat @@ -937,7 +942,7 @@ , fsep $ pwords "(hint: overloaded pattern synonyms must be equal up to variable and constructor names)" ] where - (x, _) = NonEmpty.head defs + (x, _) = List1.head defs prDef (x, (xs, p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) ("at" <+> pretty r) where r = nameBindingSite $ qnameName x @@ -1005,14 +1010,14 @@ sortBy (compare `on` prettyShow . notaName . sectNotation) $ filter (not . closedWithoutHoles) sects)) where - trimLeft = dropWhile isNormalHole - trimRight = dropWhileEnd isNormalHole + trimLeft = dropWhile isAHole + trimRight = dropWhileEnd isAHole closedWithoutHoles sect = sectKind sect == NonfixNotation && - null [ () | NormalHole {} <- trimLeft $ trimRight $ - notation (sectNotation sect) ] + null [ () | HolePart{} <- trimLeft $ trimRight $ + notation (sectNotation sect) ] prettyName n = Boxes.text $ P.render (P.pretty n) ++ @@ -1261,7 +1266,7 @@ (d1, d2, d) <- prettyInEqual t1 t2 fsep $ return d1 : ncmp : return d2 : return d : [] -instance PrettyUnequal Type where +instance PrettyUnequal I.Type where prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2) instance PrettyTCM SplitError where @@ -1328,7 +1333,7 @@ pwords "Case to handle:") $$ nest 2 (vcat $ [display cl]) $$ ((pure msg <+> enterClosure t displayAbs) <> ".") where - displayAbs :: Abs Type -> m Doc + displayAbs :: Abs I.Type -> m Doc displayAbs (Abs x t) = addContext x $ prettyTCM t displayAbs (NoAbs x t) = prettyTCM t display (tel, ps) = prettyTCM $ NamedClause f True $ @@ -1379,6 +1384,84 @@ pwords "modality" + +explainWhyInScope :: forall m. MonadPretty m => WhyInScopeData -> m Doc +explainWhyInScope (WhyInScopeData y _ Nothing [] []) = text (prettyShow y ++ " is not in scope.") +explainWhyInScope (WhyInScopeData y _ v xs ms) = vcat + [ text (prettyShow y ++ " is in scope as") + , nest 2 $ vcat [variable v xs, modules ms] + ] + where + -- variable :: Maybe _ -> [_] -> m Doc + variable Nothing vs = names vs + variable (Just x) vs + | null vs = asVar + | otherwise = vcat + [ sep [ asVar, nest 2 $ shadowing x] + , nest 2 $ names vs + ] + where + asVar :: m Doc + asVar = do + "* a variable bound at" <+> prettyTCM (nameBindingSite $ localVar x) + shadowing :: LocalVar -> m Doc + shadowing (LocalVar _ _ []) = "shadowing" + shadowing _ = "in conflict with" + names = vcat . map pName + modules = vcat . map pMod + + pKind = \case + ConName -> "constructor" + CoConName -> "coinductive constructor" + FldName -> "record field" + PatternSynName -> "pattern synonym" + GeneralizeName -> "generalizable variable" + DisallowedGeneralizeName -> "generalizable variable from let open" + MacroName -> "macro name" + QuotableName -> "quotable name" + -- previously DefName: + DataName -> "data type" + RecName -> "record type" + AxiomName -> "postulate" + PrimName -> "primitive function" + FunName -> "defined name" + OtherDefName -> "defined name" + + pName :: AbstractName -> m Doc + pName a = sep + [ "* a" + <+> pKind (anameKind a) + <+> text (prettyShow $ anameName a) + , nest 2 $ "brought into scope by" + ] $$ + nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a)) + pMod :: AbstractModule -> m Doc + pMod a = sep + [ "* a module" <+> text (prettyShow $ amodName a) + , nest 2 $ "brought into scope by" + ] $$ + nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a)) + + pWhy :: Range -> WhyInScope -> m Doc + pWhy r Defined = "- its definition at" <+> prettyTCM r + pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w + pWhy r (Opened m w) = + "- the opening of" + <+> prettyTCM m + <+> "at" + <+> prettyTCM (getRange m) + $$ + pWhy r w + pWhy r (Applied m w) = + "- the application of" + <+> prettyTCM m + <+> "at" + <+> prettyTCM (getRange m) + $$ + pWhy r w + + + --------------------------------------------------------------------------- -- * Natural language --------------------------------------------------------------------------- @@ -1412,6 +1495,13 @@ Flat -> "flat" Continuous -> "continuous" Squash -> "squashed" + +instance Verbalize Modality where + verbalize mod | mod == defaultModality = "default" + verbalize (Modality rel qnt coh) = intercalate "," $ + [ verbalize rel | rel /= defaultRelevance ] ++ + [ verbalize qnt | qnt /= defaultQuantity ] ++ + [ verbalize coh | coh /= defaultCohesion ] -- | Indefinite article. data Indefinite a = Indefinite a 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 @@ -1,6 +1,7 @@ module Agda.TypeChecking.Errors where import Agda.Syntax.Abstract.Name +import Agda.Syntax.Common import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug) 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,6 +63,11 @@ isForced, nextIsForced ) where +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.Monoid -- for (<>) in GHC 8.0.2 import Agda.Interaction.Options @@ -104,7 +109,10 @@ _ -> __IMPOSSIBLE__ n = size tel xs :: [(Modality, Nat)] - xs = forcedVariables vs + 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 @@ -114,8 +122,9 @@ isForced m i = (hasQuantity0 m || noUserQuantity m) && (getRelevance m /= Irrelevant) - && any (\(m', j) -> i == j - && m' `moreUsableModality` m) xs + && 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) @@ -129,9 +138,11 @@ -- | Compute the pattern variables of a term or term-like thing. class ForcedVariables a where - forcedVariables :: a -> [(Modality, Nat)] + forcedVariables :: a -> DList (Modality, Nat) - default forcedVariables :: (ForcedVariables b, Foldable t, a ~ t b) => a -> [(Modality, Nat)] + default forcedVariables :: + (ForcedVariables b, Foldable t, a ~ t b) => + a -> DList (Modality, Nat) forcedVariables = foldMap forcedVariables instance ForcedVariables a => ForcedVariables [a] where @@ -139,19 +150,20 @@ -- Note that the 'a' does not include the 'Arg' in 'Apply'. instance ForcedVariables a => ForcedVariables (Elim' a) where forcedVariables (Apply x) = forcedVariables x - forcedVariables IApply{} = [] -- No forced variables in path applications - forcedVariables Proj{} = [] + forcedVariables IApply{} = mempty -- No forced variables in path applications + forcedVariables Proj{} = mempty instance ForcedVariables a => ForcedVariables (Arg a) where - forcedVariables x = [ (composeModality m m', i) | (m', i) <- forcedVariables (unArg x) ] + forcedVariables x = + fmap (first (composeModality m)) (forcedVariables (unArg x)) where m = getModality x -- | Assumes that the term is in normal form. instance ForcedVariables Term where forcedVariables = \case - Var i [] -> [(unitModality, i)] + Var i [] -> DL.singleton (unitModality, i) Con _ _ vs -> forcedVariables vs - _ -> [] + _ -> mempty isForced :: IsForced -> Bool isForced Forced = True diff --git a/src/full/Agda/TypeChecking/Free.hs b/src/full/Agda/TypeChecking/Free.hs --- a/src/full/Agda/TypeChecking/Free.hs +++ b/src/full/Agda/TypeChecking/Free.hs @@ -57,7 +57,7 @@ , flexRigOccurrenceIn , closed , MetaSet - , insertMetaSet, foldrMetaSet + , insertMetaSet, foldrMetaSet, metaSetToBlocker ) where import Prelude hiding (null) @@ -178,17 +178,17 @@ -- ** Flexible /rigid occurrence info for a single variable. -- | Get the full occurrence information of a free variable. -flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe (FlexRig' ()) +flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig flexRigOccurrenceIn = flexRigOccurrenceIn' IgnoreNot -flexRigOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe (FlexRig' ()) +flexRigOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe FlexRig flexRigOccurrenceIn' ig x t = theSingleFlexRig $ runFree sg ig t where sg y = if x == y then oneSingleFlexRig else mempty -- | "Collection" just keeping track of the occurrence of a single variable. -- 'Nothing' means variable does not occur freely. -newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe (FlexRig' ()) } +newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe FlexRig } oneSingleFlexRig :: SingleFlexRig oneSingleFlexRig = SingleFlexRig $ Just $ oneFlexRig @@ -204,8 +204,8 @@ mempty = SingleFlexRig Nothing mappend = (<>) -instance IsVarSet () SingleFlexRig where - withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ () <$ varFlexRig o) . theSingleFlexRig +instance IsVarSet MetaSet SingleFlexRig where + withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ varFlexRig o) . theSingleFlexRig -- ** Plain free occurrence. diff --git a/src/full/Agda/TypeChecking/Free/Lazy.hs b/src/full/Agda/TypeChecking/Free/Lazy.hs --- a/src/full/Agda/TypeChecking/Free/Lazy.hs +++ b/src/full/Agda/TypeChecking/Free/Lazy.hs @@ -65,10 +65,11 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet import Data.Semigroup ( Semigroup, (<>) ) - +import qualified Data.Set as Set +import Data.Set (Set) import Agda.Syntax.Common @@ -87,18 +88,21 @@ -- | A set of meta variables. Forms a monoid under union. -newtype MetaSet = MetaSet { theMetaSet :: IntSet } +newtype MetaSet = MetaSet { theMetaSet :: HashSet MetaId } deriving (Eq, Show, Null, Semigroup, Monoid) instance Singleton MetaId MetaSet where - singleton = MetaSet . singleton . metaId + singleton = MetaSet . singleton insertMetaSet :: MetaId -> MetaSet -> MetaSet -insertMetaSet (MetaId m) (MetaSet ms) = MetaSet $ IntSet.insert m ms +insertMetaSet m (MetaSet ms) = MetaSet $ HashSet.insert m ms foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a -foldrMetaSet f e ms = IntSet.foldr (f . MetaId) e $ theMetaSet ms +foldrMetaSet f e ms = HashSet.foldr f e $ theMetaSet ms +metaSetToBlocker :: MetaSet -> Blocker +metaSetToBlocker ms = unblockOnAny $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms + --------------------------------------------------------------------------- -- * Flexible and rigid occurrences (semigroup) @@ -548,6 +552,7 @@ SSet a -> freeVars' a SizeUniv -> mempty LockUniv -> mempty + IntervalUniv -> mempty PiSort a s1 s2 -> underFlexRig (Flexible mempty) (freeVars' $ unDom a) `mappend` underFlexRig WeaklyRigid (freeVars' (s1, s2)) FunSort s1 s2 -> freeVars' s1 `mappend` freeVars' s2 diff --git a/src/full/Agda/TypeChecking/Free/Precompute.hs b/src/full/Agda/TypeChecking/Free/Precompute.hs --- a/src/full/Agda/TypeChecking/Free/Precompute.hs +++ b/src/full/Agda/TypeChecking/Free/Precompute.hs @@ -80,6 +80,7 @@ SSet a -> SSet <$> precomputeFreeVars a SizeUniv -> pure s LockUniv -> pure s + IntervalUniv -> pure s PiSort a s1 s2 -> PiSort <$> precomputeFreeVars a <*> precomputeFreeVars s1 <*> precomputeFreeVars s2 FunSort s1 s2 -> uncurry FunSort <$> precomputeFreeVars (s1, s2) UnivSort s -> UnivSort <$> precomputeFreeVars s diff --git a/src/full/Agda/TypeChecking/Free/Reduce.hs b/src/full/Agda/TypeChecking/Free/Reduce.hs --- a/src/full/Agda/TypeChecking/Free/Reduce.hs +++ b/src/full/Agda/TypeChecking/Free/Reduce.hs @@ -4,9 +4,12 @@ module Agda.TypeChecking.Free.Reduce ( ForceNotFree , forceNotFree + , reallyFree , IsFree(..) ) where +import Prelude hiding (null) + import Control.Monad.Reader import Control.Monad.State @@ -22,7 +25,9 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free import Agda.TypeChecking.Free.Precompute + import Agda.Utils.Monad +import Agda.Utils.Null -- | A variable can either not occur (`NotFree`) or it does occur -- (`MaybeFree`). In the latter case, the occurrence may disappear @@ -45,6 +50,35 @@ (a, mxs) <- runStateT (runReaderT (forceNotFreeR $ precomputeFreeVars_ a) mempty) mxs return (mxs, a) +-- | Checks if the given term contains any free variables that are in +-- the given set of variables, possibly reducing the term in the +-- process. Returns `Right Nothing` if there are such variables, +-- `Right (Just v')` if there are none (where v' is the possibly +-- reduced version of the given term) or `Left b` if the problem is +-- blocked on a meta. +reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a) + => IntSet -> a -> m (Either Blocked_ (Maybe a)) +reallyFree xs v = do + (mxs , v') <- forceNotFree xs v + case IntMap.foldr pickFree NotFree mxs of + MaybeFree ms + | null ms -> return $ Right Nothing + | otherwise -> return $ Left $ Blocked blocker () + where blocker = metaSetToBlocker ms + NotFree -> return $ Right (Just v') + + where + -- Check if any of the variables occur freely. + -- Prefer occurrences that do not depend on any metas. + pickFree :: IsFree -> IsFree -> IsFree + pickFree f1@(MaybeFree ms1) f2 + | null ms1 = f1 + pickFree f1@(MaybeFree ms1) f2@(MaybeFree ms2) + | null ms2 = f2 + | otherwise = f1 + pickFree f1@(MaybeFree ms1) NotFree = f1 + pickFree NotFree f2 = f2 + type MonadFreeRed m = ( MonadReader MetaSet m , MonadState (IntMap IsFree) m @@ -151,4 +185,5 @@ s@(Inf _ _)-> return s s@SizeUniv -> return s s@LockUniv -> return s + s@IntervalUniv -> return s s@DummyS{} -> return s diff --git a/src/full/Agda/TypeChecking/Functions.hs b/src/full/Agda/TypeChecking/Functions.hs --- a/src/full/Agda/TypeChecking/Functions.hs +++ b/src/full/Agda/TypeChecking/Functions.hs @@ -38,9 +38,9 @@ etaExpandClause :: MonadTCM tcm => Clause -> tcm Clause etaExpandClause clause = liftTCM $ do case clause of - Clause _ _ ctel ps _ Nothing _ _ _ _ _ -> return clause - Clause _ _ ctel ps Nothing (Just t) _ _ _ _ _ -> return clause - Clause rl rf ctel ps (Just body) (Just t) catchall exact recursive unreachable ell -> do + Clause _ _ ctel ps _ Nothing _ _ _ _ _ _ -> return clause + Clause _ _ ctel ps Nothing (Just t) _ _ _ _ _ _ -> return clause + Clause rl rf ctel ps (Just body) (Just t) catchall exact recursive unreachable ell wm -> do -- Get the telescope to expand the clause with. TelV tel0 t' <- addContext ctel $ telView $ unArg t @@ -62,7 +62,7 @@ , " xs = " <+> text (prettyShow xs) , " new tel = " <+> prettyTCM ctel' ] - return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall exact recursive unreachable ell + return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall exact recursive unreachable ell wm where -- Get all initial lambdas of the body. peekLambdas :: Term -> [Arg ArgName] 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 @@ -10,12 +10,12 @@ import Control.Monad import Control.Monad.Except -import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map +import qualified Data.Map.Strict as MapS import Data.List (partition, sortBy) import Data.Monoid import Data.Function (on) @@ -46,14 +46,15 @@ import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor import Agda.Utils.Impossible -import Agda.Utils.List (hasElem) +import Agda.Utils.Lens +import Agda.Utils.List (downFrom, hasElem) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Permutation import Agda.Utils.Pretty (prettyShow) - +import Agda.Utils.Tuple -- | Generalize a telescope over a set of generalizable variables. generalizeTelescope :: Map QName Name -> (forall a. (Telescope -> TCM a) -> TCM a) -> ([Maybe Name] -> Telescope -> TCM a) -> TCM a @@ -128,7 +129,7 @@ -- | Create metas for the generalizable variables and run the type check action. createMetasAndTypeCheck :: - Set QName -> TCM a -> TCM (a, Map MetaId QName, MetaStore) + Set QName -> TCM a -> TCM (a, Map MetaId QName, LocalMetaStores) createMetasAndTypeCheck s typecheckAction = do ((namedMetas, x), allmetas) <- metasCreatedBy $ do (metamap, genvals) <- createGenValues s @@ -147,26 +148,42 @@ genRecMeta <- newTypeMeta (mkType 0) addContext (defaultDom ("genTel" :: String, genRecMeta)) $ ret genRecMeta --- | Compute the generalized telescope from metas created when checking the type/telescope to be +-- | Compute the generalized telescope from metas created when checking the *thing* (type or telescope) to be -- generalized. Called in the context extended with the telescope record variable (whose type is -- the first argument). Returns the telescope of generalized variables and a substitution from -- this telescope to the current context. -computeGeneralization :: - Type -> Map MetaId name -> MetaStore -> - TCM (Telescope, [Maybe name], Substitution) +computeGeneralization + :: Type + -- ^ The metavariable to be instantiated with record type containing + -- as fields the variables generalized in the *thing*. + -> Map MetaId name + -- ^ Metas created from an occurrence of a @variable@. (The original free variables.) + -- E.g. if you have + -- @ + -- variable l : Level; A : Set l + -- postulate f : A → A + -- @ + -- then @A@ would be in this @Map@, but not @l@. + -> LocalMetaStores + -- ^ The metas created when type-checking the *thing*. + -> TCM (Telescope, [Maybe name], Substitution) + -- ^ The telescope together with binder name (left-to-right order), + -- and substitution from this telescope to the current context. computeGeneralization genRecMeta nameMap allmetas = postponeInstanceConstraints $ do reportSDoc "tc.generalize" 10 $ "computing generalization for type" <+> prettyTCM genRecMeta -- Pair metas with their metaInfo - mvs <- mapM ((\ x -> (x,) <$> lookupMeta x) . MetaId) $ IntMap.keys allmetas + let mvs = MapS.assocs (openMetas allmetas) ++ + MapS.assocs (solvedMetas allmetas) -- Issue 4727: filter out metavariables that were created before the -- current checkpoint, since they are too old to be generalized. -- TODO: make metasCreatedBy smarter so it doesn't see pruned -- versions of old metas as new metas. cp <- viewTC eCurrentCheckpoint - let isFreshMeta (x,mv) = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp + let isFreshMeta :: MonadReduce m => (MetaId, MetaVariable) -> m Bool + isFreshMeta (x,mv) = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp mvs <- filterM isFreshMeta mvs cs <- (++) <$> useTC stAwakeConstraints <*> useTC stSleepingConstraints @@ -208,7 +225,7 @@ cp <- viewTC eCurrentCheckpoint let canGeneralize x | isConstrained x = return False canGeneralize x = do - mv <- lookupMeta x + mv <- lookupLocalMeta x msub <- enterClosure mv $ \ _ -> checkpointSubstitution' cp let sameContext = @@ -223,10 +240,10 @@ (Just IdS, Perm m xs) -> xs == [0 .. m - 1] (Just (Wk n IdS), Perm m xs) -> xs == [0 .. m - n - 1] _ -> False - unless sameContext $ do + unless sameContext $ reportSDoc "tc.generalize" 20 $ do ty <- getMetaType x let Perm m xs = mvPermutation mv - reportSDoc "tc.generalize" 20 $ vcat + vcat [ text "Don't know how to generalize over" , nest 2 $ prettyTCM x <+> text ":" <+> prettyTCM ty , text "in context" @@ -236,15 +253,18 @@ return sameContext inherited <- fmap Set.unions $ forM generalizableClosed $ \ (x, mv) -> case mvInstantiation mv of - InstV _ v -> do + InstV inst -> do parentName <- getMetaNameSuggestion x - metas <- filterM canGeneralize . Set.toList . allMetas Set.singleton =<< instantiateFull v + metas <- filterM canGeneralize . Set.toList . + allMetas Set.singleton =<< + instantiateFull (instBody inst) let suggestNames i [] = return () suggestNames i (m : ms) = do -- #4291: Override existing meta name suggestion. If we solved the parent with a new -- meta use the parent name for that, otherwise suffix with a number. - let suf | null ms && i == 1, MetaV{} <- v = "" - | otherwise = "." ++ show i + let suf | null ms && i == 1, + MetaV{} <- instBody inst = "" + | otherwise = "." ++ show i setMetaNameSuggestion m (parentName ++ suf) suggestNames (i + 1) ms unless (null metas) $ @@ -304,7 +324,7 @@ teleTypes <- do args <- getContextArgs fmap concat $ forM sortedMetas $ \ m -> do - mv <- lookupMeta m + mv <- lookupLocalMeta m let info = hideOrKeepInstance $ getArgInfo $ miGeneralizable $ mvInfo mv @@ -320,7 +340,9 @@ -- Now we need to prune the unsolved metas to make sure they respect the new -- dependencies (#3672). Also update interaction points to point to pruned metas. let inscope (ii, InteractionPoint{ipMeta = Just x}) - | IntMap.member (metaId x) allmetas = Just (x, ii) + | MapS.member x (openMetas allmetas) || + MapS.member x (solvedMetas allmetas) = + Just (x, ii) inscope _ = Nothing ips <- Map.fromDistinctAscList . mapMaybe inscope . fst . BiMap.toDistinctAscendingLists <$> useTC stInteractionPoints pruneUnsolvedMetas genRecName genRecCon genTel genRecFields ips shouldGeneralize allSortedMetas @@ -332,6 +354,15 @@ -- value packing up the generalized variables for the genTel variable. let sub = unpackSub genRecCon (map (argInfo . fst) teleTypes) (length teleTypes) + -- Instantiate all fresh meta-variables to get rid of + -- __DUMMY_TERM__. + genTel <- flip instantiateWhen genTel $ \m -> do + mv <- lookupMeta m + case mv of + Nothing -> __IMPOSSIBLE__ + Just Left{} -> return False + Just (Right mv) -> isFreshMeta (m, mv) + return (genTel, telNames, sub) -- | Prune unsolved metas (#3672). The input includes also the generalized metas and is sorted in @@ -380,7 +411,7 @@ -- on any variables introduced after the genRec. See test/Fail/Issue3672b.agda for a test case. prePrune x = do cp <- viewTC eCurrentCheckpoint - mv <- lookupMeta x + mv <- lookupLocalMeta x (i, _A) <- enterClosure mv $ \ _ -> do δ <- checkpointSubstitution cp _A <- case mvJudgement mv of @@ -432,7 +463,7 @@ pruneMeta _Θ x = do cp <- viewTC eCurrentCheckpoint - mv <- lookupMeta x + mv <- lookupLocalMeta x -- The reason we are doing all this inside the closure of x is so that if x is an interaction -- meta we get the right context for the pruned interaction meta. enterClosure mv $ \ _ -> @@ -555,10 +586,15 @@ findGenRec :: MetaVariable -> TCM (Maybe Int) findGenRec mv = do cxt <- instantiateFull =<< getContext - let notPruned = permute (takeP (length cxt) $ mvPermutation mv) $ - reverse $ zipWith const [0..] cxt - case [ i | (i, Dom{unDom = (_, El _ (Def q _))}) <- zip [0..] cxt, - q == genRecName, i `elem` notPruned ] of + let n = length cxt + notPruned = IntSet.fromList $ + permute (takeP n $ mvPermutation mv) $ + downFrom n + case [ i + | (i, Dom{unDom = (_, El _ (Def q _))}) <- zip [0..] cxt + , q == genRecName + , i `IntSet.member` notPruned + ] of [] -> return Nothing _:_:_ -> __IMPOSSIBLE__ [i] -> return (Just i) @@ -782,12 +818,13 @@ , funMutual = Just [] , funAbstr = ConcreteDef , funDelayed = NotDelayed - , funProjection = Just proj + , funProjection = Right proj , funFlags = Set.empty , funTerminates = Just True , funExtLam = Nothing , funWith = Nothing , funCovering = [] + , funIsKanOp = Nothing } addConstant' (conName genRecCon) defaultArgInfo (conName genRecCon) __DUMMY_TYPE__ $ -- Filled in later Constructor { conPars = 0 @@ -814,6 +851,7 @@ , recEtaEquality' = Inferred YesEta , recPatternMatching = CopatternMatching , recInduction = Nothing + , recTerminates = Just True -- not recursive , recAbstr = ConcreteDef , recComp = emptyCompKit } @@ -849,7 +887,6 @@ reportSDoc "tc.generalize" 40 $ text "Final genRecCon type:" <+> inTopContext (prettyTCM conType) setType (conName con) conType -- Record telescope: Includes both parameters and fields. - modifyGlobalDefinition name $ \ r -> - r { theDef = (theDef r) { recTel = fullTel } } + modifyGlobalDefinition name $ set (lensTheDef . lensRecord . lensRecTel) fullTel 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 @@ -4,10 +4,15 @@ import Prelude hiding (null, (!!)) -- do not use partial functions like !! import Control.Monad -import Control.Arrow (first,second) +import Control.Monad.Except -import qualified Data.List as List -import qualified Data.Map as Map +import Data.Bifunctor (first, second) +import Data.DList (DList) +import Data.Foldable (toList) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet import Agda.Syntax.Common import Agda.Syntax.Position @@ -31,9 +36,11 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Maybe +import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Impossible import Agda.Utils.Functor +import Control.Monad.Reader checkIApplyConfluence_ :: QName -> TCM () @@ -49,10 +56,11 @@ case theDef d of Function{funClauses = cls', funCovering = cls} -> do reportSDoc "tc.cover.iapply" 10 $ text "length cls =" <+> pretty (length cls) - when (null cls && not (null $ concatMap (iApplyVars . namedClausePats) cls')) $ + when (null cls && any (not . null . iApplyVars . namedClausePats) cls') $ __IMPOSSIBLE__ - modifySignature $ updateDefinition f $ updateTheDef - $ updateCovering (const []) + unlessM (optKeepCoveringClauses <$> pragmaOptions) $ + modifySignature $ updateDefinition f $ updateTheDef + $ updateCovering (const []) traceCall (CheckFunDefCall (getRange f) f [] False) $ forM_ cls $ checkIApplyConfluence f @@ -68,9 +76,10 @@ , namedClausePats = ps , clauseType = Just t , clauseBody = Just body - } -> setCurrentRange (getRange f) $ do + } -> setCurrentRange (clauseLHSRange cl) $ do let trhs = unArg t + oldCall <- asksTC envCall reportSDoc "tc.cover.iapply" 40 $ "tel =" <+> prettyTCM clTel reportSDoc "tc.cover.iapply" 40 $ "ps =" <+> pretty ps ps <- normaliseProjP ps @@ -83,14 +92,53 @@ reportSDoc "tc.iapply" 40 $ text "clause:" <+> pretty ps <+> "->" <+> pretty body reportSDoc "tc.iapply" 20 $ "body =" <+> prettyTCM body - addContext clTel $ equalTermOnFace phi trhs lhs body + let + k :: Substitution -> Comparison -> Type -> Term -> Term -> TCM () + k phi cmp ty u v = do + u_e <- simplify u + ty_e <- simplify ty + let + -- Make note of the context (literally): we're + -- checking that this specific clause in f is + -- confluent with IApply reductions. That way if we + -- can tell the user what the endpoints are. + why = CheckIApplyConfluence + (getRange cl) f + (applySubst phi lhs) + u_e v ty + -- But if the conversion checking failed really early, we drop the extra + -- information. In that case, it's just noise. + maybeDropCall e@(TypeError x y err) + | UnequalTerms _ u' v' _ <- clValue err = do + u <- prettyTCM u_e + v <- prettyTCM =<< simplify v + enterClosure err $ \e' -> do + u' <- prettyTCM =<< simplify u' + v' <- prettyTCM =<< simplify v' + -- Specifically, we compare how the things are pretty-printed, to avoid + -- double-printing, rather than a more refined heuristic, since the + -- “failure case” here is *at worst* accidentally reminding the user of how + -- IApplyConfluence works. + if (u == u' && v == v') + then localTC (\e -> e { envCall = oldCall }) $ typeError e' + else throwError e + maybeDropCall x = throwError x + + -- Note: Any postponed constraint with this call *will* have the extra + -- information. This is a feature: if the constraint is woken up later, + -- then it's probably a good idea to remind the user of what's going on, + -- instead of presenting a mysterious error. + traceCall why (compareTerm cmp ty u v `catchError` maybeDropCall) + + addContext clTel $ compareTermOnFace' k CmpEq phi trhs lhs body + case body of MetaV m es_m' | Just es_m <- allApplyElims es_m' -> caseMaybeM (isInteractionMeta m) (return ()) $ \ ii -> do cs' <- do reportSDoc "tc.iapply.ip" 20 $ "clTel =" <+> prettyTCM clTel - mv <- lookupMeta m + mv <- lookupLocalMeta m enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢ ty <- getMetaType m mTel <- getContextTelescope @@ -110,7 +158,7 @@ addContext clTel $ do -- mTel.clTel ⊢ () <- reportSDoc "tc.iapply.ip" 40 $ "mTel.clTel =" <+> (prettyTCM =<< getContextTelescope) - forallFaceMaps phi __IMPOSSIBLE__ $ \ alpha -> do + forallFaceMaps phi __IMPOSSIBLE__ $ \_ alpha -> do -- mTel.clTel' ⊢ -- mTel.clTel ⊢ alpha : mTel.clTel' reportSDoc "tc.iapply.ip" 40 $ "mTel.clTel' =" <+> (prettyTCM =<< getContextTelescope) @@ -164,7 +212,6 @@ modifyInteractionPoints (BiMap.adjust f ii) _ -> return () - -- | current context is of the form Γ.Δ unifyElims :: Args -- ^ variables to keep Γ ⊢ x_n .. x_0 : Γ @@ -177,39 +224,54 @@ -- Γ.Δ', [(x = u)] ⊢ id_g = ts[σ] : Γ -> TCM a unifyElims vs ts k = do - dom <- getContext - let (binds' , eqs' ) = candidate (map unArg vs) (map unArg ts) - (binds'', eqss') = - unzip $ map (\ (j,t:ts) -> ((j,t),map (,var j) ts)) $ Map.toList $ Map.fromListWith (++) (map (second (:[])) binds') - cod = codomain s (map fst binds) dom - binds = map (second (raise (size cod - size vs))) binds'' - eqs = map (first (raise $ size dom - size vs)) $ eqs' ++ concat eqss' - s = bindS binds - updateContext s (codomain s (map fst binds)) $ do - k s (s `applySubst` eqs) + dom <- getContext + let (binds' , eqs' ) = candidate (map unArg vs) (map unArg ts) + (binds'', eqss') = + unzip $ + map (\(j, tts) -> case toList tts of + t : ts -> ((j, t), map (, var j) ts) + [] -> __IMPOSSIBLE__) $ + IntMap.toList $ IntMap.fromListWith (<>) binds' + cod' = codomain s (IntSet.fromList $ map fst binds'') + cod = cod' dom + svs = size vs + binds = IntMap.fromList $ + map (second (raise (size cod - svs))) binds'' + eqs = map (first (raise (size dom - svs))) $ + eqs' ++ concat eqss' + s = bindS binds + updateContext s cod' $ k s (s `applySubst` eqs) where - candidate :: [Term] -> [Term] -> ([(Nat,Term)],[(Term,Term)]) - candidate (i:is) (Var j []:ts) = first ((j,i):) (candidate is ts) - candidate (i:is) (t:ts) = second ((i,t):) (candidate is ts) - candidate [] [] = ([],[]) - candidate _ _ = __IMPOSSIBLE__ - - - bindS binds = parallelS (for [0..maximum (-1:map fst binds)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i binds))) + candidate :: [Term] -> [Term] -> ([(Nat, DList Term)], [(Term, Term)]) + candidate is ts = case (is, ts) of + (i : is, Var j [] : ts) -> first ((j, singleton i) :) $ + candidate is ts + (i : is, t : ts) -> second ((i, t) :) $ + candidate is ts + ([], []) -> ([], []) + _ -> __IMPOSSIBLE__ - codomain :: Substitution - -> [Nat] -- support - -> Context -> Context - codomain s vs cxt = map snd $ filter (\ (i,c) -> i `List.notElem` vs) $ zip [0..] cxt' - where - cxt' = zipWith (\ n d -> dropS n s `applySubst` d) [1..] cxt + bindS binds = parallelS $ + case IntMap.lookupMax binds of + Nothing -> [] + Just (max, _) -> for [0 .. max] $ \i -> + fromMaybe (deBruijnVar i) (IntMap.lookup i binds) + codomain + :: Substitution + -> IntSet -- Support. + -> Context -> Context + codomain s vs = + mapMaybe (\(i, c) -> if i `IntSet.member` vs + then Nothing + else Just c) . + zipWith (\i c -> (i, dropS (i + 1) s `applySubst` c)) [0..] -- | Like @unifyElims@ but @Γ@ is from the the meta's @MetaInfo@ and -- the context extension @Δ@ is taken from the @Closure@. unifyElimsMeta :: MetaId -> Args -> Closure Constraint -> ([(Term,Term)] -> Constraint -> TCM a) -> TCM a unifyElimsMeta m es_m cl k = ifM (isNothing . optCubical <$> pragmaOptions) (enterClosure cl $ k []) $ do - mv <- lookupMeta m + mv <- lookupLocalMeta m enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢ ty <- metaType m mTel0 <- getContextTelescope 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 @@ -41,6 +41,7 @@ module Agda.TypeChecking.Injectivity where import Control.Applicative +import Control.Monad import Control.Monad.Except import Control.Monad.Fail import Control.Monad.State @@ -52,15 +53,20 @@ import Data.Maybe import Data.Traversable hiding (for) import Data.Semigroup ((<>)) +import Data.Foldable (fold) import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern +import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Irrelevance (isIrrelevantOrPropM) import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Telescope.Path +import Agda.TypeChecking.Primitive.Base +import Agda.TypeChecking.Primitive.Cubical import Agda.TypeChecking.Reduce import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Conversion @@ -68,6 +74,8 @@ import Agda.TypeChecking.Polarity import Agda.TypeChecking.Warnings +import Agda.Interaction.Options + import Agda.Utils.Either import Agda.Utils.Functor import Agda.Utils.List @@ -75,6 +83,7 @@ import Agda.Utils.Monad import Agda.Utils.Permutation import Agda.Utils.Pretty ( prettyShow ) +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Impossible @@ -110,7 +119,10 @@ Constructor{} -> __IMPOSSIBLE__ AbstractDefn{}-> __IMPOSSIBLE__ -- Andreas, 2019-07-10, issue #3900: canonicalName needs ignoreAbstractMode - Con c _ _ -> ignoreAbstractMode $ Just . ConsHead <$> canonicalName (conName c) + Con c _ _ -> ignoreAbstractMode $ do + q <- canonicalName (conName c) + ifM (isPathCons q) (return Nothing) $ + {- else -} return $ Just $ ConsHead q Sort _ -> return (Just SortHead) Pi _ _ -> return (Just PiHead) Var i [] -> return (Just $ VarHead i) -- Only naked variables. Otherwise substituting a neutral term is not guaranteed to stay neutral. @@ -122,8 +134,28 @@ DontCare{} -> return Nothing Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s +-- | Is this a matchable definition, or constructor, which reduces based +-- on interval substitutions? +isUnstableDef :: PureTCM m => QName -> m Bool +isUnstableDef qn = do + defn <- getConstInfo qn + prims <- traverse getPrimitiveName' + [ builtinHComp + , builtinComp + , builtinTrans + , builtinGlue + , builtin_glue + , builtin_glueU ] + case theDef defn of + _ | any (Just qn ==) prims -> pure True + Function{funIsKanOp = Just _} -> pure True + _ -> pure False + + -- | Do a full whnf and treat neutral terms as rigid. Used on the arguments to --- an injective functions and to the right-hand side. +-- an injective functions and to the right-hand side. Only returns +-- heads which are stable under interval substitution, i.e. NOT path +-- constructors or generated hcomp/transp! headSymbol' :: (PureTCM m, MonadError TCErr m) => Term -> m (Maybe TermHead) @@ -132,8 +164,15 @@ case v of Blocked{} -> return Nothing NotBlocked _ v -> case v of - Def g _ -> return $ Just $ ConsHead g - Con c _ _ -> return $ Just $ ConsHead $ conName c + Def g _ -> + ifM (isUnstableDef g) + (pure Nothing) + (pure . Just $ ConsHead g) + Con c _ _ -> do + q <- canonicalName (conName c) + ifM (isPathCons q) + (pure Nothing) + (return $ Just $ ConsHead q) Var i _ -> return $ Just (VarHead i) Sort _ -> return $ Just SortHead Pi _ _ -> return $ Just PiHead @@ -188,13 +227,23 @@ varToArg _ h = return h -- We don't need to consider absurd clauses - let computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = do + let computeHead c | hasDefP (namedClausePats c) = return [] + -- hasDefP clauses are skipped, these matter only for --cubical, in which case the function will behave as NotInjective. + computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = addContext (clauseTel c) $ do maybeIrr <- fromRight (const True) <.> runBlocked $ isIrrelevantOrPropM tbody + -- We treat ordinary clauses with IApply copatterns as *immediately* + -- failing the injectivity check. Consider e.g. + -- foo x = T + -- foo (y i) = Glue U λ { (i = i0) → T , _ ; (i = i1) → T , _ } + -- seeing foo α = Glue ... and inverting it to α = y β loses solutions. E.g. if we + -- later had some other α = x, now we're screwed, x ≠ y β. But if we had postponed + -- originally we'd just compare T = Glue ... which has a chance of going through. + let ivars = iApplyVars (namedClausePats c) + guard (null ivars) h <- if maybeIrr then return UnknownHead else varToArg c =<< do lift $ fromMaybe UnknownHead <$> do - addContext (clauseTel c) $ - headSymbol body + headSymbol body return [Map.singleton h [c]] computeHead _ = return [] @@ -211,7 +260,6 @@ case uc of [c] -> prettyTCM $ map namedArg $ namedClausePats c _ -> "(multiple clauses)" - return $ Inverse hdMap -- | If a clause is over-applied we can't trust the head (Issue 2944). For @@ -272,9 +320,10 @@ functionInverse = \case Def f es -> do inv <- defInverse <$> getConstInfo f + cubical <- optCubical <$> pragmaOptions case inv of NotInjective -> return NoInv - Inverse m -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m) + Inverse m -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m) -- NB: Invertible functions are never classified as -- projection-like, so this is fine, we are not -- missing parameters. (Andreas, 2013-11-01) @@ -302,6 +351,7 @@ reportSDoc "tc.inj.use" 30 $ fsep $ pwords "useInjectivity on" ++ [ prettyTCM blk, prettyTCM cmp, prettyTCM neu, prettyTCM ty] + whenProfile Profile.Conversion $ tick "compare by reduction: injectivity" let canReduceToSelf = Map.member (ConsHead f) hdMap || Map.member UnknownHead hdMap case neu of -- f us == f vs <=> us == vs @@ -319,6 +369,7 @@ fs <- getForcedArgs f pol <- getPolarity' cmp f reportSDoc "tc.inj.invert.success" 20 $ hsep ["Successful spine comparison of", prettyTCM f] + whenProfile Profile.Conversion $ tick "compare by reduction: injectivity successful" app (compareElims pol fs fTy (Def f [])) blkArgs neuArgs -- f us == c vs 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 @@ -5,6 +5,7 @@ , isInstanceConstraint , shouldPostponeInstanceSearch , postponeInstanceConstraints + , getInstanceCandidates ) where import Control.Monad ( forM ) @@ -13,6 +14,7 @@ import qualified Data.IntMap as IntMap import qualified Data.Map as Map +import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.List as List import Data.Bifunctor @@ -169,7 +171,7 @@ rel = getRelevance $ defArgInfo def let v = case theDef def of -- drop parameters if it's a projection function... - Function{ funProjection = Just p } -> projDropParsApply p ProjSystem rel args + 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. @@ -207,7 +209,7 @@ findInstance m Nothing = do -- Andreas, 2015-02-07: New metas should be created with range of the -- current instance meta, thus, we set the range. - mv <- lookupMeta m + mv <- lookupLocalMeta m setCurrentRange mv $ do reportSLn "tc.instance" 20 $ "The type of the FindInstance constraint isn't known, trying to find it again." t <- instantiate =<< getMetaTypeInContext m @@ -227,6 +229,19 @@ findInstance m (Just cands) = -- Note: if no blocking meta variable this will not unblock until the end of the mutual block whenJustM (findInstance' m cands) $ (\ (cands, b) -> addConstraint b $ FindInstance m $ Just cands) +-- | Entry point for `tcGetInstances` primitive +getInstanceCandidates :: MetaId -> TCM (Either Blocker [Candidate]) +getInstanceCandidates m = do + mv <- lookupLocalMeta m + setCurrentRange mv $ do + t <- instantiate =<< getMetaTypeInContext m + TelV tel t' <- telViewUpTo' (-1) notVisible t + addContext tel $ initialInstanceCandidates t' >>= \case + Left b -> return $ Left b + Right cands -> checkCandidates m t' cands >>= \case + Nothing -> return $ Right cands + Just (_ , cands') -> return $ Right cands' + -- | Result says whether we need to add constraint, and if so, the set of -- remaining candidates and an eventual blocking metavariable. findInstance' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Blocker)) @@ -238,7 +253,7 @@ return $ Just (cands, neverUnblock)) $ billTo [Benchmark.Typing, Benchmark.InstanceSearch] $ do -- Andreas, 2015-02-07: New metas should be created with range of the -- current instance meta, thus, we set the range. - mv <- lookupMeta m + mv <- lookupLocalMeta m setCurrentRange mv $ do reportSLn "tc.instance" 15 $ "findInstance 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands) @@ -357,9 +372,12 @@ -- This is sufficient to reduce the list to a singleton should all be equal. dropSameCandidates :: MetaId -> [(Candidate, Term, a)] -> TCM [(Candidate, Term, a)] dropSameCandidates m cands0 = verboseBracket "tc.instance" 30 "dropSameCandidates" $ do - metas <- getMetaStore - -- Does `it` have any metas in the initial meta variable store? - let freshMetas = getAny . allMetas (Any . (`IntMap.notMember` metas) . metaId) + !nextMeta <- nextLocalMeta + isRemoteMeta <- isRemoteMeta + -- Does "it" contain any fresh meta-variables? + let freshMetas = + getAny . + allMetas (\m -> Any (not (isRemoteMeta m || m < nextMeta))) -- Take overlappable candidates into account let cands = @@ -372,7 +390,7 @@ , nest 2 $ vcat [ if freshMetas v then "(redacted)" else sep [ prettyTCM v ] | (_, v, _) <- cands ] ] - rel <- getMetaRelevance <$> lookupMeta m + rel <- getRelevance <$> lookupMetaModality m case cands of [] -> return cands cvd : _ | isIrrelevant rel -> do @@ -450,7 +468,7 @@ checkCandidateForMeta m t (Candidate q term t' _) = checkDepth term t' $ do -- Andreas, 2015-02-07: New metas should be created with range of the -- current instance meta, thus, we set the range. - mv <- lookupMeta m + mv <- lookupLocalMeta m setCurrentRange mv $ do debugConstraints verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $ @@ -540,16 +558,6 @@ handle err | hardFailure err = return $ HellNo err | otherwise = No <$ debugTypeFail err - -isInstanceConstraint :: Constraint -> Bool -isInstanceConstraint FindInstance{} = True -isInstanceConstraint _ = False - -shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool -shouldPostponeInstanceSearch = - and2M ((^. stConsideringInstance) <$> getTCState) - (not . optOverlappingInstances <$> pragmaOptions) - `or2M` ((^. stPostponeInstanceSearch) <$> getTCState) nowConsideringInstance :: (ReadTCState m) => m a -> m a nowConsideringInstance = locallyTCState stConsideringInstance $ const True 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 @@ -83,6 +83,7 @@ import Agda.Syntax.Common import Agda.Syntax.Internal +import Agda.Syntax.Concrete.Pretty import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty @@ -93,6 +94,9 @@ import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.WithDefault +import qualified Agda.Utils.Null as Null +import Agda.Utils.WithDefault (collapseDefault) -- | data 'Relevance' -- see "Agda.Syntax.Common". @@ -198,7 +202,7 @@ splittableCohesion :: (HasOptions m, LensCohesion a) => a -> m Bool splittableCohesion a = do let c = getCohesion a - pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do optFlatSplit <$> pragmaOptions) + pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do collapseDefault . optFlatSplit <$> pragmaOptions) -- | (Conditionally) wake up irrelevant variables and make them relevant. -- For instance, @@ -305,7 +309,7 @@ Sort s -> usableRel rel s Level l -> return True MetaV m vs -> do - mrel <- getMetaRelevance <$> lookupMeta m + mrel <- getRelevance <$> lookupMetaModality m return (mrel `moreRelevant` rel) `and2M` usableRel rel vs DontCare v -> usableRel rel v -- TODO: allow irrelevant things to be used in DontCare position? Dummy{} -> return True @@ -321,6 +325,7 @@ SSet l -> usableRel rel l SizeUniv -> return True LockUniv -> return True + IntervalUniv -> return True PiSort a s1 s2 -> usableRel rel (a,s1,s2) FunSort s1 s2 -> usableRel rel (s1,s2) UnivSort s -> usableRel rel s @@ -348,7 +353,7 @@ usableRel rel (Proj _ p) = do prel <- relOfConst p return $ prel `moreRelevant` rel - usableRel rel (IApply x y v) = allM [x,y,v] $ usableRel rel + usableRel rel (IApply x y v) = usableRel rel v instance UsableRelevance a => UsableRelevance (Arg a) where usableRel rel (Arg info u) = @@ -398,7 +403,15 @@ text ("has modality " ++ show fmod ++ ", which is a " ++ (if ok then "" else "NOT ") ++ "more usable modality than " ++ show mod) return ok `and2M` usableMod mod vs - Con c _ vs -> usableMod mod vs + Con c o vs -> do + cmod <- modalityOfConst (conName c) + let ok = cmod `moreUsableModality` mod + reportSDoc "tc.irr" 50 $ + "The constructor" <+> prettyTCM (Con c o []) <+> + text ("has the modality " ++ show cmod ++ ", which is " ++ + (if ok then "" else "NOT ") ++ + "more usable than the modality " ++ show mod ++ ".") + return ok `and2M` usableMod mod vs Lit l -> return True Lam info v -> usableModAbs info mod v -- Even if Pi contains Type, here we check it as a constructor for terms in the universe. @@ -411,7 +424,7 @@ Sort s -> usableMod mod s Level l -> return True MetaV m vs -> do - mmod <- getMetaModality <$> lookupMeta m + mmod <- lookupMetaModality m let ok = mmod `moreUsableModality` mod reportSDoc "tc.irr" 50 $ "Metavariable" <+> prettyTCM (MetaV m []) <+> @@ -461,7 +474,7 @@ usableMod mod (Proj _ p) = do pmod <- modalityOfConst p return $ pmod `moreUsableModality` mod - usableMod mod (IApply x y v) = allM [x,y,v] $ usableMod mod + usableMod mod (IApply x y v) = usableMod mod v instance UsableModality a => UsableModality (Arg a) where usableMod mod (Arg info u) = @@ -471,16 +484,76 @@ instance UsableModality a => UsableModality (Dom a) where usableMod mod Dom{unDom = u} = usableMod mod u -usableAtModality :: MonadConstraint TCM => Modality -> Term -> TCM () -usableAtModality mod t = catchConstraint (UsableAtModality mod t) $ do - res <- runExceptT $ usableMod mod t - case res of - Right b -> do - unless b $ - typeError . GenericDocError =<< (prettyTCM t <+> "is not usable at the required modality" <+> prettyTCM mod) - Left blocker -> patternViolation blocker +usableAtModality' + :: MonadConstraint TCM + -- Note: This weird-looking constraint is to trick GHC into accepting + -- that an instance of MonadConstraint TCM will exist, even if we + -- can't import the module in which it is defined. + => Maybe Sort -> WhyCheckModality -> Modality -> Term -> TCM () +usableAtModality' ms why mod t = + catchConstraint (UsableAtModality why ms mod t) $ do + whenM (maybe (pure True) isFibrant ms) $ do + res <- runExceptT $ usableMod mod t + case res of + Right b -> unless b $ + typeError . GenericDocError =<< formatWhy + Left blocker -> patternViolation blocker + where + formatWhy = do + compatible <- collapseDefault . 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 + + -- * Propositions -- | Is a type a proposition? (Needs reduction.) @@ -513,6 +586,7 @@ SSet{} -> False SizeUniv{} -> False LockUniv{} -> False + IntervalUniv{} -> False PiSort{} -> False FunSort{} -> False UnivSort{} -> False @@ -531,6 +605,7 @@ SSet{} -> False SizeUniv{} -> False LockUniv{} -> True + IntervalUniv{} -> True PiSort{} -> False FunSort{} -> False UnivSort{} -> False diff --git a/src/full/Agda/TypeChecking/Level.hs b/src/full/Agda/TypeChecking/Level.hs --- a/src/full/Agda/TypeChecking/Level.hs +++ b/src/full/Agda/TypeChecking/Level.hs @@ -3,7 +3,6 @@ import Data.Maybe import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable (Traversable) import Agda.Syntax.Common @@ -14,6 +13,7 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce +import Agda.Utils.List1 ( List1, pattern (:|) ) import Agda.Utils.Maybe ( caseMaybeM, allJustM ) import Agda.Utils.Monad ( tryMaybe ) import Agda.Utils.Singleton @@ -31,10 +31,21 @@ , zeroName :: QName } --- | Get the 'primLevel' as a 'Type'. -levelType :: (HasBuiltins m) => m Type -levelType = El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel +{-# SPECIALIZE levelType :: TCM Type #-} +-- | Get the 'primLevel' as a 'Type'. Aborts if any of the level BUILTINs is undefined. +levelType :: (HasBuiltins m, MonadTCError m) => m Type +levelType = El (mkType 0) . lvlType <$> requireLevels + -- Andreas, 2022-10-11, issue #6168 + -- It seems superfluous to require all level builtins here, + -- but since we are in MonadTCError here, this is our chance to make sure + -- that all level builtins are defined. + -- Otherwise, we might run into an __IMPOSSIBLE__ later, + -- e.g. if only BUILTIN LEVEL was defined by reallyUnLevelView requires all builtins. +-- | Get the 'primLevel' as a 'Type'. Unsafe, crashes if the BUILTIN LEVEL is undefined. +levelType' :: (HasBuiltins m) => m Type +levelType' = El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel + isLevelType :: PureTCM m => Type -> m Bool isLevelType a = reduce (unEl a) >>= \case Def f [] -> do @@ -42,9 +53,6 @@ return $ f == lvl _ -> return False -levelSucFunction :: TCM (Term -> Term) -levelSucFunction = apply1 <$> primLevelSuc - {-# SPECIALIZE builtinLevelKit :: TCM LevelKit #-} {-# SPECIALIZE builtinLevelKit :: ReduceM LevelKit #-} builtinLevelKit :: (HasBuiltins m) => m LevelKit @@ -64,9 +72,24 @@ , zeroName = z } +{-# SPECIALIZE requireLevels :: TCM LevelKit #-} -- | Raises an error if no level kit is available. -requireLevels :: HasBuiltins m => m LevelKit -requireLevels = builtinLevelKit +requireLevels :: (HasBuiltins m, MonadTCError m) => m LevelKit +requireLevels = do + level@(Def l []) <- getBuiltin builtinLevel + zero@(Def z []) <- getBuiltin builtinLevelZero + suc@(Def s []) <- getBuiltin builtinLevelSuc + max@(Def m []) <- getBuiltin builtinLevelMax + return $ LevelKit + { lvlType = level + , lvlSuc = \ a -> suc `apply1` a + , lvlMax = \ a b -> max `applys` [a, b] + , lvlZero = zero + , typeName = l + , sucName = s + , maxName = m + , zeroName = z + } -- | Checks whether level kit is fully available. haveLevels :: HasBuiltins m => m Bool @@ -90,13 +113,7 @@ {-# SPECIALIZE reallyUnLevelView :: Level -> TCM Term #-} {-# SPECIALIZE reallyUnLevelView :: Level -> ReduceM Term #-} reallyUnLevelView :: (HasBuiltins m) => Level -> m Term -reallyUnLevelView nv = do - suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc - zer <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero - case nv of - Max n [] -> return $ unConstV zer (apply1 suc) n - Max 0 [a] -> return $ unPlusV (apply1 suc) a - _ -> (`unlevelWithKit` nv) <$> builtinLevelKit +reallyUnLevelView nv = (`unlevelWithKit` nv) <$> builtinLevelKit unlevelWithKit :: LevelKit -> Level -> Term unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax = max } = \case @@ -223,7 +240,7 @@ n = maximum $ 0 : [m | SingleClosed m <- ls] as = [a | SinglePlus a <- ls] -levelMaxView :: Level' t -> NonEmpty (SingleLevel' t) +levelMaxView :: Level' t -> List1 (SingleLevel' t) levelMaxView (Max n []) = singleton $ SingleClosed n levelMaxView (Max 0 (a:as)) = SinglePlus a :| map SinglePlus as levelMaxView (Max n as) = SingleClosed n :| map SinglePlus as diff --git a/src/full/Agda/TypeChecking/Level/Solve.hs b/src/full/Agda/TypeChecking/Level/Solve.hs --- a/src/full/Agda/TypeChecking/Level/Solve.hs +++ b/src/full/Agda/TypeChecking/Level/Solve.hs @@ -5,7 +5,7 @@ import Control.Monad import Control.Monad.Except -import qualified Data.IntMap as IntMap +import qualified Data.Map.Strict as MapS import Data.Maybe import Agda.Interaction.Options @@ -27,16 +27,17 @@ -- level, and instantiate them to the lowest level. defaultOpenLevelsToZero :: (PureTCM m, MonadMetaSolver m) => m a -> m a defaultOpenLevelsToZero f = ifNotM (optCumulativity <$> pragmaOptions) f $ do - (result , newMetas) <- metasCreatedBy f - defaultLevelsToZero newMetas + (result, newMetas) <- metasCreatedBy f + defaultLevelsToZero (openMetas newMetas) return result -defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => MetaStore -> m () -defaultLevelsToZero xs = loop =<< openLevelMetas (map MetaId $ IntMap.keys xs) +defaultLevelsToZero :: + forall m. (PureTCM m, MonadMetaSolver m) => LocalMetaStore -> m () +defaultLevelsToZero xs = loop =<< openLevelMetas (MapS.keys xs) where loop :: [MetaId] -> m () loop xs = do - let isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x + let isOpen x = isOpenMeta <$> lookupMetaInstantiation x xs <- filterM isOpen xs allMetaTypes <- getOpenMetas >>= traverse metaType let notInTypeOfMeta x = not $ mentionsMeta x allMetaTypes diff --git a/src/full/Agda/TypeChecking/LevelConstraints.hs b/src/full/Agda/TypeChecking/LevelConstraints.hs --- a/src/full/Agda/TypeChecking/LevelConstraints.hs +++ b/src/full/Agda/TypeChecking/LevelConstraints.hs @@ -58,7 +58,7 @@ go _ [] = IdS go y ren0@((y', x) : ren) | y == y' = Var x [] :# go (y + 1) ren - | otherwise = Strengthen impossible $ go (y + 1) ren0 + | otherwise = strengthenS' impossible 1 $ go (y + 1) ren0 -- | Turn a level constraint into a list of inequalities between -- single levels, if possible. 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 @@ -9,10 +9,10 @@ import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT ) import Control.Monad.Trans ( lift ) -import Data.Function -import qualified Data.IntMap as IntMap +import Data.Function (on) import qualified Data.IntSet as IntSet import qualified Data.List as List +import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav @@ -58,7 +58,8 @@ import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.Permutation -import Agda.Utils.Pretty ( Pretty, prettyShow ) +import Agda.Utils.Pretty (Pretty, prettyShow, render) +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import qualified Agda.Utils.Graph.TopSort as Graph import Agda.Utils.VarSet (VarSet) @@ -90,16 +91,18 @@ findIdx :: Eq a => [a] -> a -> Maybe Int findIdx vs v = List.elemIndex v (reverse vs) +-- | Does the given local meta-variable have a twin meta-variable? + hasTwinMeta :: MetaId -> TCM Bool hasTwinMeta x = do - m <- lookupMeta x + m <- lookupLocalMeta x return $ isJust $ mvTwin m -- | Check whether a meta variable is a place holder for a blocked term. isBlockedTerm :: MetaId -> TCM Bool isBlockedTerm x = do reportSLn "tc.meta.blocked" 12 $ "is " ++ prettyShow x ++ " a blocked term? " - i <- mvInstantiation <$> lookupMeta x + i <- lookupMetaInstantiation x let r = case i of BlockedConst{} -> True PostponedTypeCheckingProblem{} -> True @@ -107,12 +110,12 @@ Open{} -> False OpenInstance{} -> False reportSLn "tc.meta.blocked" 12 $ - if r then " yes, because " ++ show i else " no" + if r then " yes, because " ++ prettyShow i else " no" return r isEtaExpandable :: [MetaKind] -> MetaId -> TCM Bool isEtaExpandable kinds x = do - i <- mvInstantiation <$> lookupMeta x + i <- lookupMetaInstantiation x return $ case i of Open{} -> True OpenInstance{} -> Records `notElem` kinds @@ -143,13 +146,21 @@ -- verify (new) invariants whenM (not <$> asksTC envAssignMetas) __IMPOSSIBLE__ - verboseS "profile.metas" 10 $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-} - modifyMetaStore $ ins x $ InstV tel $ killRange v + whenProfile Profile.Metas $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-} + updateMetaVarTCM x $ \ mv -> + mv { mvInstantiation = InstV $ Instantiation + { instTel = tel + , instBody = v + -- Andreas, 2022-04-28, issue #5875: + -- Can't killRange the meta-solution, since this will destroy + -- ranges of termination errors (and potentially other passes + -- that run on internal syntax)! + -- , instBody = killRange v + } + } etaExpandListeners x wakeupConstraints x reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x - where - ins x i = IntMap.adjust (\ mv -> mv { mvInstantiation = i }) $ metaId x -- * Creating meta variables. @@ -394,7 +405,7 @@ MetaVar { mvInfo = MetaInfo{ miClosRange = Closure{ clEnv = TCEnv{ envContext = gamma }}} , mvPermutation = p - } <- fromMaybe __IMPOSSIBLE__ <$> lookupMeta' x + } <- fromMaybe __IMPOSSIBLE__ <$> lookupLocalMeta' x -- Get the current context Δ. delta <- getContext -- A bit hazardous: @@ -617,28 +628,8 @@ problemType (CheckLambda _ _ _ t ) = t problemType (DoQuoteTerm _ _ t) = t --- | Eta expand metavariables listening on the current meta. -etaExpandListeners :: MetaId -> TCM () -etaExpandListeners m = do - ls <- getMetaListeners m - clearMetaListeners m -- we don't really have to do this - mapM_ wakeupListener ls - --- | Wake up a meta listener and let it do its thing -wakeupListener :: Listener -> TCM () - -- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevance -wakeupListener (EtaExpand x) = etaExpandMetaSafe x -wakeupListener (CheckConstraint _ c) = do - reportSDoc "tc.meta.blocked" 20 $ "waking boxed constraint" <+> prettyTCM c - modifyAwakeConstraints (c:) - solveAwakeConstraints - --- | Do safe eta-expansions for meta (@SingletonRecords,Levels@). -etaExpandMetaSafe :: (MonadMetaSolver m) => MetaId -> m () -etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels] - --- | Eta expand a metavariable, if it is of the specified kind. --- Don't do anything if the metavariable is a blocked term. +-- | 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 kinds m = whenM ((not <$> isFrozen m) `and2M` asksTC envAssignMetas `and2M` isEtaExpandable kinds m) $ do verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do @@ -652,7 +643,7 @@ reportSDoc "tc.meta.eta" 20 $ do "we do not expand meta variable" <+> prettyTCM m <+> text ("(requested was expansion of " ++ show kinds ++ ")") - meta <- lookupMeta m + meta <- lookupLocalMeta m case mvJudgement meta of IsSort{} -> dontExpand HasType _ cmp a -> do @@ -676,7 +667,7 @@ -- they go unsolved: conversion will compare them at the -- different cases for the domain, so it will not find the -- solution for the whole meta. - if any domFinite (flattenTel tel) then dontExpand else do + if any domIsFinite (flattenTel tel) then dontExpand else do -- Issue #3774: continue with the right context for b addContext tel $ do @@ -742,7 +733,7 @@ assignWrapper dir x es v doAssign = do ifNotM (asksTC envAssignMetas) dontAssign $ {- else -} do reportSDoc "tc.meta.assign" 10 $ do - "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ show dir) <+> prettyTCM v + "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ prettyShow dir) <+> prettyTCM v nowSolvingConstraints doAssign `finally` solveAwakeConstraints where dontAssign = do @@ -768,7 +759,7 @@ assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM () assign dir x args v target = addOrUnblocker (unblockOnMeta x) $ do - mvar <- lookupMeta x -- information associated with meta x + mvar <- lookupLocalMeta x -- information associated with meta x let t = jMetaType $ mvJudgement mvar -- Andreas, 2011-05-20 TODO! @@ -1057,7 +1048,7 @@ -- @ -- we need to check that @A <: A'@ (due to contravariance). let sigma = parallelS $ reverse $ map unArg args - hasSubtyping <- collapseDefault . optSubtyping <$> pragmaOptions + hasSubtyping <- optCumulativity <$> pragmaOptions when hasSubtyping $ forM_ ids $ \(i , u) -> do -- @u@ is a (projected) variable, so we can infer its type a <- applySubst sigma <$> addContext tel' (infer u) @@ -1083,10 +1074,12 @@ let success = killResult `elem` [PrunedSomething,PrunedEverything] reportSDoc "tc.meta.assign" 10 $ "pruning" <+> prettyTCM x <+> do text $ if success then "succeeded" else "failed" - patternViolation (if success then alwaysUnblock -- If pruning succeeded we want to retry right away - else unblockOnAnyMetaIn $ MetaV x $ map Apply args) - -- TODO: could be more precise: only unblock on metas - -- applied to offending variables + blocker <- if + | success -> return alwaysUnblock -- If pruning succeeded we want to retry right away + | otherwise -> unblockOnAnyMetaIn . MetaV x . map Apply <$> instantiateFull args + -- TODO: could be more precise: only unblock on metas + -- applied to offending variables + patternViolation blocker {- UNUSED -- | When faced with @_X us == D vs@ for an inert D we can solve this by @@ -1254,7 +1247,7 @@ -- Andreas, 2013-10-25 double check solution before assigning whenM (optDoubleCheck <$> pragmaOptions) $ do - m <- lookupMeta x + m <- lookupLocalMeta x reportSDoc "tc.meta.check" 30 $ "double checking solution" catchConstraint (CheckMetaInst x) $ addContext tel' $ checkSolutionForMeta x m v' a @@ -1281,18 +1274,19 @@ -- instantiated, add a constraint to check the instantiation later. checkMetaInst :: MetaId -> TCM () checkMetaInst x = do - m <- lookupMeta x + m <- lookupLocalMeta x let postpone = addConstraint (unblockOnMeta x) $ CheckMetaInst x case mvInstantiation m of BlockedConst{} -> postpone PostponedTypeCheckingProblem{} -> postpone Open{} -> postpone OpenInstance{} -> postpone - InstV xs v -> do - let n = size xs + InstV inst -> do + let n = size (instTel inst) t = jMetaType $ mvJudgement m (telv@(TelV tel a),bs) <- telViewUpToPathBoundary n t - catchConstraint (CheckMetaInst x) $ addContext tel $ checkSolutionForMeta x m v a + catchConstraint (CheckMetaInst x) $ addContext tel $ + checkSolutionForMeta x m (instBody inst) a -- | Check that the instantiation of the metavariable with the given -- term is well-typed. @@ -1321,8 +1315,7 @@ reportSDoc "tc.meta.subtype" 30 $ "checking that subtype" <+> prettyTCM a <+> "of" <+> prettyTCM b <+> "is actually equal." - ((a, b), equal) <- SynEq.checkSyntacticEquality a b - unless equal $ do + SynEq.checkSyntacticEquality a b (\_ _ -> return ()) $ \a b -> do cumulativity <- optCumulativity <$> pragmaOptions abortIfBlocked (unEl b) >>= \case Sort sb -> abortIfBlocked (unEl a) >>= \case @@ -1353,8 +1346,8 @@ -- @_Y args <= u@. subtypingForSizeLt :: CompareDirection -- ^ @dir@ - -> MetaId -- ^ The meta variable @x@. - -> MetaVariable -- ^ Its associated information @mvar <- lookupMeta x@. + -> MetaId -- ^ The local meta-variable @x@. + -> MetaVariable -- ^ Its associated information @mvar <- lookupLocalMeta x@. -> Type -- ^ Its type @t = jMetaType $ mvJudgement mvar@ -> Args -- ^ Its arguments. -> Term -- ^ Its to-be-assigned value @v@, such that @x args `dir` v@. @@ -1571,86 +1564,88 @@ inverseSubst :: Args -> ExceptT InvertExcept TCM SubstCand inverseSubst args = map (mapFst unArg) <$> loop (zip args terms) where - loop = foldM isVarOrIrrelevant [] - terms = map var (downFrom (size args)) - failure = do - lift $ reportSDoc "tc.meta.assign" 15 $ vcat - [ "not all arguments are variables: " <+> prettyTCM args - , " aborting assignment" ] - throwError CantInvert - neutralArg = throwError NeutralArg + loop = foldM isVarOrIrrelevant [] + terms = map var (downFrom (size args)) + failure = do + lift $ reportSDoc "tc.meta.assign" 15 $ vcat + [ "not all arguments are variables: " <+> prettyTCM args + , " aborting assignment" ] + throwError CantInvert + neutralArg = throwError NeutralArg - isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res - isVarOrIrrelevant vars (Arg info v, t) = do - let irr | isIrrelevant info = True - | DontCare{} <- v = True - | otherwise = False - case stripDontCare v of - -- i := x - Var i [] -> return $ (Arg info i, t) `cons` vars + isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res + isVarOrIrrelevant vars (Arg info v, t) = do + let irr | isIrrelevant info = True + | DontCare{} <- v = True + | otherwise = False + case stripDontCare v of + -- i := x + Var i [] -> return $ (Arg info i, t) `cons` vars - -- π i := x try to eta-expand projection π away! - Var i es | Just qs <- mapM isProjElim es -> - throwError $ ProjVar $ ProjectedVar i qs + -- π i := x try to eta-expand projection π away! + Var i es | Just qs <- mapM isProjElim es -> + throwError $ ProjVar $ ProjectedVar i qs - -- (i, j) := x becomes [i := fst x, j := snd x] - -- Andreas, 2013-09-17 but only if constructor is fully applied - Con c ci es -> do - let fallback - | isIrrelevant info = return vars - | otherwise = failure - irrProj <- optIrrelevantProjections <$> pragmaOptions - lift (isRecordConstructor $ conName c) >>= \case - Just (_, r@Record{ recFields = fs }) - | YesEta <- recEtaEquality r -- Andreas, 2019-11-10, issue #4185: only for eta-records - , length fs == length es - , hasQuantity0 info || all usableQuantity fs -- Andreas, 2019-11-12/17, issue #4168b - , irrProj || all isRelevant fs -> do - let aux (Arg _ v) Dom{domInfo = info', unDom = f} = (Arg ai v,) $ t `applyE` [Proj ProjSystem f] where - ai = ArgInfo - { argInfoHiding = min (getHiding info) (getHiding info') - , argInfoModality = Modality - { modRelevance = max (getRelevance info) (getRelevance info') - , modQuantity = max (getQuantity info) (getQuantity info') - , modCohesion = max (getCohesion info) (getCohesion info') - } - , argInfoOrigin = min (getOrigin info) (getOrigin info') - , argInfoFreeVariables = unknownFreeVariables - , argInfoAnnotation = argInfoAnnotation info' - } - vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - res <- loop $ zipWith aux vs fs - return $ res `append` vars - | otherwise -> fallback - _ -> fallback + -- (i, j) := x becomes [i := fst x, j := snd x] + -- Andreas, 2013-09-17 but only if constructor is fully applied + Con c ci es -> do + let fallback + | isIrrelevant info = return vars + | otherwise = failure + irrProj <- optIrrelevantProjections <$> pragmaOptions + lift (isRecordConstructor $ conName c) >>= \case + Just (_, r@Record{ recFields = fs }) + | YesEta <- recEtaEquality r -- Andreas, 2019-11-10, issue #4185: only for eta-records + , length fs == length es + , hasQuantity0 info || all usableQuantity fs -- Andreas, 2019-11-12/17, issue #4168b + , irrProj || all isRelevant fs -> do + let aux (Arg _ v) Dom{domInfo = info', unDom = f} = + (Arg ai v,) $ t `applyE` [Proj ProjSystem f] + where + ai = ArgInfo + { argInfoHiding = min (getHiding info) (getHiding info') + , argInfoModality = Modality + { modRelevance = max (getRelevance info) (getRelevance info') + , modQuantity = max (getQuantity info) (getQuantity info') + , modCohesion = max (getCohesion info) (getCohesion info') + } + , argInfoOrigin = min (getOrigin info) (getOrigin info') + , argInfoFreeVariables = unknownFreeVariables + , argInfoAnnotation = argInfoAnnotation info' + } + vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es + res <- loop $ zipWith aux vs fs + return $ res `append` vars + | otherwise -> fallback + _ -> fallback - -- An irrelevant argument which is not an irrefutable pattern is dropped - _ | irr -> return vars + -- An irrelevant argument which is not an irrefutable pattern is dropped + _ | irr -> return vars - -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure - -- from those that can only put somewhere as a whole ==> neutralArg - Var{} -> neutralArg - Def{} -> neutralArg -- Note that this Def{} is in normal form and might be prunable. - Lam{} -> failure - Lit{} -> failure - MetaV{} -> failure - Pi{} -> neutralArg - Sort{} -> neutralArg - Level{} -> neutralArg - DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare - Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s + -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure + -- from those that can only put somewhere as a whole ==> neutralArg + Var{} -> neutralArg + Def{} -> neutralArg -- Note that this Def{} is in normal form and might be prunable. + Lam{} -> failure + Lit{} -> failure + MetaV{} -> failure + Pi{} -> neutralArg + Sort{} -> neutralArg + Level{} -> neutralArg + DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare + Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s - -- managing an assoc list where duplicate indizes cannot be irrelevant vars - append :: Res -> Res -> Res - append res vars = foldr cons vars res + -- managing an assoc list where duplicate indizes cannot be irrelevant vars + append :: Res -> Res -> Res + append res vars = foldr cons vars res - -- adding an irrelevant entry only if not present - cons :: (Arg Nat, Term) -> Res -> Res - cons a@(Arg ai i, t) vars - | isIrrelevant ai = applyUnless (any ((i==) . unArg . fst) vars) (a :) vars - | otherwise = a : -- adding a relevant entry - -- filter out duplicate irrelevants - filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars + -- adding an irrelevant entry only if not present + cons :: (Arg Nat, Term) -> Res -> Res + cons a@(Arg ai i, t) vars + | isIrrelevant ai = applyUnless (any ((i==) . unArg . fst) vars) (a :) vars + | otherwise = a : -- adding a relevant entry + -- filter out duplicate irrelevants + filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars -- | Turn open metas into postulates. @@ -1666,35 +1661,35 @@ m <- asksTC envCurrentModule -- Go through all open metas. - ms <- IntMap.assocs <$> useTC stMetaStore + ms <- MapS.assocs <$> useTC stOpenMetaStore forM_ ms $ \ (x, mv) -> do - when (isOpenMeta $ mvInstantiation mv) $ do - let t = dummyTypeToOmega $ jMetaType $ mvJudgement mv + let t = dummyTypeToOmega $ jMetaType $ mvJudgement mv - -- Create a name for the new postulate. - let r = clValue $ miClosRange $ mvInfo mv - -- s <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op - let s = "unsolved#meta." ++ prettyShow x - n <- freshName r s - let q = A.QName m n + -- Create a name for the new postulate. + let r = clValue $ miClosRange $ mvInfo mv + s' <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op + let s = "unsolved#meta." ++ filter (/= '_') s' + n <- freshName r s + let q = A.QName m n - -- Debug. - reportSDoc "meta.postulate" 20 $ vcat - [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ") - <+> prettyTCM (MetaId x) <+> " into postulate." - , nest 2 $ vcat - [ "Name: " <+> prettyTCM q - , "Type: " <+> prettyTCM t - ] + -- Debug. + reportSDoc "meta.postulate" 20 $ vcat + [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ") + <+> prettyTCM x <+> " into postulate." + , nest 2 $ vcat + [ "Name: " <+> prettyTCM q + , "Type: " <+> prettyTCM t ] + ] - -- Add the new postulate to the signature. - addConstant' q defaultArgInfo q t defaultAxiom + -- Add the new postulate to the signature. + addConstant' q defaultArgInfo q t defaultAxiom - -- Solve the meta. - let inst = InstV [] $ Def q [] - updateMetaVar (MetaId x) $ \ mv0 -> mv0 { mvInstantiation = inst } - return () + -- Solve the meta. + let inst = InstV $ Instantiation + { instTel = [], instBody = Def q [] } + updateMetaVar x $ \ mv0 -> mv0 { mvInstantiation = inst } + return () where -- Unsolved sort metas can have a type ending in a Dummy if they are allowed to be instantiated -- to Setω. This will crash the serializer (issue #3730). To avoid this we replace dummy type @@ -1709,15 +1704,20 @@ dependencySortMetas metas = do metaGraph <- concat <$> do forM metas $ \ m -> do - deps <- allMetas (\ m' -> if m' `elem` metas then singleton m' else mempty) <$> getType m + deps <- allMetas (\m' -> if m' `Set.member` metas' + then singleton m' + else mempty) <$> + getType m return [ (m, m') | m' <- Set.toList deps ] - return $ Graph.topSort metas metaGraph + return $ Graph.topSort metas' metaGraph where + metas' = Set.fromList metas + -- Sort metas don't have types, but we still want to sort them. getType m = do - mv <- lookupMeta m - case mvJudgement mv of + j <- lookupMetaJudgement m + case j of IsSort{} -> return Nothing HasType{ jMetaType = t } -> Just <$> instantiateFull t diff --git a/src/full/Agda/TypeChecking/MetaVars.hs-boot b/src/full/Agda/TypeChecking/MetaVars.hs-boot --- a/src/full/Agda/TypeChecking/MetaVars.hs-boot +++ b/src/full/Agda/TypeChecking/MetaVars.hs-boot @@ -11,7 +11,6 @@ newArgsMeta' :: MonadMetaSolver m => Condition -> Type -> m Args newArgsMeta :: MonadMetaSolver m => Type -> m Args assignTerm :: MonadMetaSolver m => MetaId -> [Arg String] -> Term -> m () -etaExpandMetaSafe :: MonadMetaSolver m => MetaId -> m () assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM () newInstanceMeta :: MonadMetaSolver m => String -> Type -> m (MetaId, Term) newValueMeta :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term) 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 @@ -43,6 +43,7 @@ mentionsMetas xs (UnblockOnAny bs) = mentionsMetas xs $ Set.toList bs mentionsMetas xs (UnblockOnMeta x) = HashSet.member x xs mentionsMetas xs UnblockOnProblem{} = False + mentionsMetas xs UnblockOnDef{} = False instance MentionsMeta Type where mentionsMetas xs (El s t) = mentionsMetas xs (s, t) @@ -55,6 +56,7 @@ SSet l -> mentionsMetas xs l SizeUniv -> False LockUniv -> False + IntervalUniv -> False PiSort a s1 s2 -> mentionsMetas xs (a, s1, s2) FunSort s1 s2 -> mentionsMetas xs (s1, s2) UnivSort s -> mentionsMetas xs s @@ -117,10 +119,11 @@ HasBiggerSort a -> mm a HasPTSRule a b -> mm (a, b) UnquoteTactic tac hole goal -> False + CheckDataSort q s -> mm s CheckMetaInst m -> True -- TODO CheckType t -> mm t CheckLockedVars a b c d -> mm ((a, b), (c, d)) - UsableAtModality mod t -> mm t + UsableAtModality _ ms mod t -> mm (ms, t) where mm :: forall t. MentionsMeta t => t -> Bool mm = mentionsMetas xs diff --git a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs --- a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs +++ b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs @@ -32,7 +32,7 @@ import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars -import Agda.TypeChecking.Constraints () -- instances +import Agda.TypeChecking.Constraints ( wakeupConstraints ) import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Reduce @@ -190,7 +190,7 @@ [ "occursCheck: definition" , prettyTCM d , "has relevance" - , prettyTCM (getRelevance dmod) + , text . show $ getRelevance dmod ] abort neverUnblock $ MetaIrrelevantSolution m $ Def d [] unless (er || usableQuantity dmod) $ do @@ -198,7 +198,7 @@ [ "occursCheck: definition" , prettyTCM d , "has quantity" - , prettyTCM (getQuantity dmod) + , text . show $ getQuantity dmod ] abort neverUnblock $ MetaErasedSolution m $ Def d [] @@ -225,17 +225,17 @@ -- abort ctx $ MetaOccursInItself m' when (m == m0) $ patternViolation' neverUnblock 50 $ "occursCheck failed: Found " ++ prettyShow m - mv <- lookupMeta m - let mmod = getMetaModality mv + mv <- lookupLocalMeta m + let mmod = getModality mv mmod' = setRelevance rel $ setQuantity qnt $ mmod if (mmod `moreUsableModality` mmod') then return m else do reportSDoc "tc.meta.occurs" 35 $ hsep [ "occursCheck: meta variable" , prettyTCM m , "has relevance" - , prettyTCM (getRelevance mmod) + , text . show $ getRelevance mmod , "and quantity" - , prettyTCM (getQuantity mmod) + , text . show $ getQuantity mmod ] allowAssign <- asksTC envAssignMetas -- Jesper, 2020-11-10: if we encounter a metavariable that is @@ -260,15 +260,10 @@ when (isUnguarded cxt) $ fail "occurrence is unguarded" reportSDoc "tc.meta.occurs" 20 $ "Promoting meta" <+> prettyTCM m <+> "to modality" <+> prettyTCM mmod' - let info' = setModality mmod' $ mvInfo mv - m' <- liftTCM $ newMeta Instantiable info' (mvPriority mv) (mvPermutation mv) (mvJudgement mv) - reportSDoc "tc.meta.occurs.qnt" 20 $ hsep - [ "occursCheck: new meta variable" - , prettyTCM m' - ] - liftTCM $ assignTerm m [] $ MetaV m' [] - reportSDoc "tc.meta.occurs" 35 $ "New name for" <+> prettyTCM m <+> "is" <+> prettyTCM m' - return m' + updateMetaVar m $ \ mv -> mv { mvInfo = setModality mmod' $ mvInfo mv } + etaExpandListeners m + wakeupConstraints m + return m -- | Construct a test whether a de Bruijn index is allowed -- or needs to be pruned. @@ -276,9 +271,9 @@ allowedVars = do -- @n@ is the number of binders we have stepped under. n <- liftM2 (-) getContextSize (asks (occCxtSize . feExtra)) - xs <- asks ((IntMap.keysSet . theVarMap) . (occVars . feExtra)) + xs <- asks (theVarMap . occVars . feExtra) -- Bound variables are allowed, and those mentioned in occVars. - return $ \ i -> i < n || (i - n) `IntSet.member` xs + return $ \ i -> i < n || (i - n) `IntMap.member` xs -- ** Unfolding during occurs check. @@ -367,7 +362,7 @@ :: (Occurs a, InstantiateFull a, PrettyTCM a) => MetaId -> VarMap -> a -> TCM a occursCheck m xs v = Bench.billTo [ Bench.Typing, Bench.OccursCheck ] $ do - mv <- lookupMeta m + mv <- lookupLocalMeta m n <- getContextSize reportSLn "tc.meta.occurs" 35 $ "occursCheck " ++ show m ++ " " ++ show xs let initEnv unf = FreeEnv @@ -378,7 +373,7 @@ , occCxtSize = n } , feFlexRig = StronglyRigid -- ? Unguarded - , feModality = getMetaModality mv + , feModality = getModality mv , feSingleton = variableCheck xs } initOccursCheck mv @@ -389,7 +384,7 @@ -- (unless metavariable is irrelevant, in which case the -- constraint will anyway be dropped) case err of - PatternErr{} | not (isIrrelevant $ getMetaModality mv) -> do + PatternErr{} | not (isIrrelevant $ getModality mv) -> do initOccursCheck mv occurs v `runReaderT` initEnv YesUnfold _ -> throwError err @@ -401,19 +396,25 @@ TypeError _ _ cl -> case clValue cl of MetaOccursInItself{} -> typeError . GenericDocError =<< - fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to") + fsep [ text "Refuse to construct infinite term by instantiating" + , prettyTCM m + , "to" , prettyTCM =<< instantiateFull v ] MetaCannotDependOn _ i -> ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism)) ( typeError . GenericDocError =<< - fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to") + fsep [ text "Cannot instantiate the metavariable" + , prettyTCM m + , "to" , prettyTCM v , "since universe polymorphism is disabled" ] ) {- else -} ( typeError . GenericDocError =<< - fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution") + fsep [ text "Cannot instantiate the metavariable" + , prettyTCM m + , "to solution" , prettyTCM v , "since it contains the variable" , enterClosure cl $ \_ -> prettyTCM (Var i []) @@ -422,13 +423,17 @@ ) MetaIrrelevantSolution _ _ -> typeError . GenericDocError =<< - fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution") + fsep [ text "Cannot instantiate the metavariable" + , prettyTCM m + , "to solution" , prettyTCM v , "since (part of) the solution was created in an irrelevant context" ] MetaErasedSolution _ _ -> typeError . GenericDocError =<< - fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution") + fsep [ text "Cannot instantiate the metavariable" + , prettyTCM m + , "to solution" , prettyTCM v , "since (part of) the solution was created in an erased context" ] @@ -613,6 +618,7 @@ SSet a -> SSet <$> occurs a s@SizeUniv -> return s s@LockUniv -> return s + s@IntervalUniv -> return s UnivSort s -> UnivSort <$> do flexibly $ occurs s MetaS x es -> do MetaV x es <- occurs (MetaV x es) @@ -633,6 +639,7 @@ SSet a -> metaOccurs m a SizeUniv -> return () LockUniv -> return () + IntervalUniv -> return () UnivSort s -> metaOccurs m s MetaS x es -> metaOccurs m $ MetaV x es DefS d es -> metaOccurs m $ Def d es @@ -822,7 +829,7 @@ -- If the definition is incomplete, arguments might disappear -- by reductions that come with more clauses, thus, these -- arguments are not rigid. - NotBlocked MissingClauses _ -> return False + NotBlocked (MissingClauses _) _ -> return False -- _ -> mempty -- breaks: ImproveInertRHS, Issue442, PruneRecord, PruningNonMillerPattern _ -> anyRigid f es Con _ _ ts -> anyRigid f ts @@ -845,6 +852,7 @@ SSet l -> anyRigid f l SizeUniv -> return False LockUniv -> return False + IntervalUniv -> return False PiSort a s1 s2 -> return False FunSort s1 s2 -> return False UnivSort s -> anyRigid f s @@ -898,7 +906,7 @@ killArgs kills _ | not (or kills) = return NothingToPrune -- nothing to kill killArgs kills m = do - mv <- lookupMeta m + mv <- lookupLocalMeta m allowAssign <- asksTC envAssignMetas if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS @@ -940,9 +948,12 @@ killedType :: (MonadReduce m) => [(Dom (ArgName, Type), Bool)] -> Type -> m ([Arg Bool], Type) killedType args b = do + let n = length args + let iargs = zip (downFrom n) args + -- Turn list of bools into an IntSet containing the variables we want to kill -- (indices relative to b). - let tokill = IntSet.fromList [ i | ((_, True), i) <- zip (reverse args) [0..] ] + let tokill = IntSet.fromList [ i | (i, (_, True)) <- iargs ] -- First, check the free variables of b to see if they prevent any kills. (tokill, b) <- reallyNotFreeIn tokill b @@ -952,7 +963,7 @@ -- Turn the IntSet of killed variables into the list of Arg Bool's to return. let kills = [ Arg (getArgInfo dom) (IntSet.member i killed) - | (i, (dom, _)) <- reverse $ zip [0..] $ reverse args ] + | (i, (dom, _)) <- iargs ] return (kills, b) where down = IntSet.map pred @@ -990,7 +1001,7 @@ (ys, a) <- reallyNotFreeIn xs' a -- Recurse on Δ, ys, and (x : A') → B, where A reduces to A' and ys ⊆ xs' -- not free in A'. We already know ys not free in B. - (zs, b) <- go args ys (mkPi ((name, a) <$ arg) b) + (zs, b) <- go args ys $ mkPi ((name, a) <$ arg) b -- Shift back up to make it relative to Δ (x : A) again. return (up zs, b) @@ -1024,7 +1035,7 @@ -> Type -- ^ The pruned type of the new meta var. -> m () performKill kills m a = do - mv <- lookupMeta m + mv <- lookupLocalMeta m when (mvFrozen mv == Frozen) __IMPOSSIBLE__ -- Arity of the old meta. let n = size kills 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 @@ -1,4739 +1,5381 @@ {-# LANGUAGE CPP #-} --- {-# LANGUAGE UndecidableInstances #-} -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT - -module Agda.TypeChecking.Monad.Base - ( module Agda.TypeChecking.Monad.Base - , HasOptions (..) - ) where - -import Prelude hiding (null) - -import Control.Applicative hiding (empty) -import qualified Control.Concurrent as C -import Control.DeepSeq -import qualified Control.Exception as E - -import qualified Control.Monad.Fail as Fail - -import Control.Monad ( void ) -import Control.Monad.Except -import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.State ( MonadState(..), modify, StateT(..), runStateT ) -import Control.Monad.Reader ( MonadReader(..), ReaderT(..), runReaderT ) -import Control.Monad.Writer ( WriterT ) -import Control.Monad.Trans ( MonadTrans(..), lift ) -import Control.Monad.Trans.Control ( MonadTransControl(..), liftThrough ) -import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT ) -import Control.Monad.Trans.Maybe ( MaybeT(..) ) - -import Control.Parallel ( pseq ) - -import Data.Array (Ix) -import Data.Function -import Data.Int -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import qualified Data.List as List -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -- hiding (singleton, null, empty) -import Data.Sequence (Seq) -import Data.Set (Set) -import qualified Data.Set as Set -- hiding (singleton, null, empty) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HMap -import Data.Semigroup ( Semigroup, (<>)) --, Any(..) ) -import Data.Data (Data) -import Data.String -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import Data.IORef - -import GHC.Generics (Generic) - -import Agda.Benchmarking (Benchmark, Phase) - -import Agda.Syntax.Concrete (TopLevelModuleName) -import Agda.Syntax.Common -import qualified Agda.Syntax.Concrete as C -import Agda.Syntax.Concrete.Definitions - (NiceDeclaration, DeclarationWarning, dwWarning, declarationWarningName) -import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Internal as I -import Agda.Syntax.Internal.MetaVars -import Agda.Syntax.Internal.Generic (TermLike(..)) -import Agda.Syntax.Parser (ParseWarning) -import Agda.Syntax.Parser.Monad (parseWarningName) -import Agda.Syntax.Treeless (Compiled) -import Agda.Syntax.Notation -import Agda.Syntax.Position -import Agda.Syntax.Scope.Base -import qualified Agda.Syntax.Info as Info - -import Agda.TypeChecking.CompiledClause -import Agda.TypeChecking.Coverage.SplitTree -import Agda.TypeChecking.Positivity.Occurrence -import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder) - --- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend --- conflicts with Args, defined in Agda.Syntax.Internal and also imported here. --- This only matters when interpreted in ghci, which sees all of the module's --- exported symbols, not just the ones defined in the `.hs-boot`. See the --- comment in ../../Compiler/Backend.hs-boot -import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args) - -import Agda.Interaction.Options -import Agda.Interaction.Options.Warnings -import {-# SOURCE #-} Agda.Interaction.Response - (InteractionOutputCallback, defaultInteractionOutputCallback) -import Agda.Interaction.Highlighting.Precise - (HighlightingInfo, NameKind) -import Agda.Interaction.Library - -import Agda.Utils.Benchmark (MonadBench(..)) -import Agda.Utils.BiMap (BiMap, HasTag(..)) -import qualified Agda.Utils.BiMap as BiMap -import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) -import Agda.Utils.FileName -import Agda.Utils.Functor -import Agda.Utils.Hash -import Agda.Utils.Lens -import Agda.Utils.List -import Agda.Utils.ListT -import Agda.Utils.List1 (List1, pattern (:|)) -import Agda.Utils.List2 (List2, pattern List2) -import qualified Agda.Utils.List1 as List1 -import qualified Agda.Utils.Maybe.Strict as Strict -import Agda.Utils.Monad -import Agda.Utils.Null -import Agda.Utils.Permutation -import Agda.Utils.Pretty -import Agda.Utils.Singleton -import Agda.Utils.SmallSet (SmallSet) -import qualified Agda.Utils.SmallSet as SmallSet -import Agda.Utils.Update -import Agda.Utils.WithDefault ( collapseDefault ) - -import Agda.Utils.Impossible - ---------------------------------------------------------------------------- --- * Type checking state ---------------------------------------------------------------------------- - -data TCState = TCSt - { stPreScopeState :: !PreScopeState - -- ^ The state which is frozen after scope checking. - , stPostScopeState :: !PostScopeState - -- ^ The state which is modified after scope checking. - , stPersistentState :: !PersistentTCState - -- ^ State which is forever, like a diamond. - } - deriving Generic - -class Monad m => ReadTCState m where - getTCState :: m TCState - locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b - - withTCState :: (TCState -> TCState) -> m a -> m a - withTCState = locallyTCState id - - default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState - getTCState = lift getTCState - - default locallyTCState - :: (MonadTransControl t, ReadTCState n, t n ~ m) - => Lens' a TCState -> (a -> a) -> m b -> m b - locallyTCState l = liftThrough . locallyTCState l - -instance ReadTCState m => ReadTCState (ListT m) where - locallyTCState l = mapListT . locallyTCState l - -instance ReadTCState m => ReadTCState (ChangeT m) -instance ReadTCState m => ReadTCState (ExceptT err m) -instance ReadTCState m => ReadTCState (IdentityT m) -instance ReadTCState m => ReadTCState (MaybeT m) -instance ReadTCState m => ReadTCState (ReaderT r m) -instance ReadTCState m => ReadTCState (StateT s m) -instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m) - - -instance Show TCState where - show _ = "TCSt{}" - -data PreScopeState = PreScopeState - { stPreTokens :: !HighlightingInfo - -- ^ Highlighting info for tokens and Happy parser warnings (but - -- not for those tokens/warnings for which highlighting exists in - -- 'stPostSyntaxInfo'). - , stPreImports :: !Signature -- XX populated by scope checker - -- ^ Imported declared identifiers. - -- Those most not be serialized! - , stPreImportedModules :: !(Set ModuleName) -- imports logic - , stPreModuleToSource :: !ModuleToSource -- imports - , stPreVisitedModules :: !VisitedModules -- imports - , stPreScope :: !ScopeInfo - -- generated by scope checker, current file: - -- which modules you have, public definitions, current file, maps concrete names to abstract names. - , stPrePatternSyns :: !A.PatternSynDefns - -- ^ Pattern synonyms of the current file. Serialized. - , stPrePatternSynImports :: !A.PatternSynDefns - -- ^ Imported pattern synonyms. Must not be serialized! - , stPreGeneralizedVars :: !(Strict.Maybe (Set QName)) - -- ^ Collected generalizable variables; used during scope checking of terms - , stPrePragmaOptions :: !PragmaOptions - -- ^ Options applying to the current file. @OPTIONS@ - -- pragmas only affect this field. - , stPreImportedBuiltins :: !(BuiltinThings PrimFun) - , stPreImportedDisplayForms :: !DisplayForms - -- ^ Display forms added by someone else to imported identifiers - , stPreImportedInstanceDefs :: !InstanceTable - , stPreForeignCode :: !(Map BackendName [ForeignCode]) - -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output. - -- Does not include code for imported modules. - , stPreFreshInteractionId :: !InteractionId - , stPreImportedUserWarnings :: !(Map A.QName Text) - -- ^ Imported @UserWarning@s, not to be stored in the @Interface@ - , stPreLocalUserWarnings :: !(Map A.QName Text) - -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@ - , stPreWarningOnImport :: !(Strict.Maybe Text) - -- ^ Whether the current module should raise a warning when opened - , stPreImportedPartialDefs :: !(Set QName) - -- ^ Imported partial definitions, not to be stored in the @Interface@ - , stPreProjectConfigs :: !(Map FilePath ProjectConfig) - -- ^ Map from directories to paths of closest enclosing .agda-lib - -- files (or @Nothing@ if there are none). - , stPreAgdaLibFiles :: !(Map FilePath AgdaLibFile) - -- ^ Contents of .agda-lib files that have already been parsed. - } - deriving Generic - --- | Name disambiguation for the sake of highlighting. -data DisambiguatedName = DisambiguatedName NameKind A.QName - deriving Generic -type DisambiguatedNames = IntMap DisambiguatedName - -type ConcreteNames = Map Name [C.Name] - -data PostScopeState = PostScopeState - { stPostSyntaxInfo :: !HighlightingInfo - -- ^ Highlighting info. - , stPostDisambiguatedNames :: !DisambiguatedNames - -- ^ Disambiguation carried out by the type checker. - -- Maps position of first name character to disambiguated @'A.QName'@ - -- for each @'A.AmbiguousQName'@ already passed by the type checker. - , stPostMetaStore :: !MetaStore - , stPostInteractionPoints :: !InteractionPoints -- scope checker first - , stPostAwakeConstraints :: !Constraints - , stPostSleepingConstraints :: !Constraints - , stPostDirty :: !Bool -- local - -- ^ Dirty when a constraint is added, used to prevent pointer update. - -- Currently unused. - , stPostOccursCheckDefs :: !(Set QName) -- local - -- ^ Definitions to be considered during occurs check. - -- Initialized to the current mutual block before the check. - -- During occurs check, we remove definitions from this set - -- as soon we have checked them. - , stPostSignature :: !Signature - -- ^ Declared identifiers of the current file. - -- These will be serialized after successful type checking. - , stPostModuleCheckpoints :: !(Map ModuleName CheckpointId) - -- ^ For each module remember the checkpoint corresponding to the orignal - -- context of the module parameters. - , stPostImportsDisplayForms :: !DisplayForms - -- ^ Display forms we add for imported identifiers - , stPostCurrentModule :: !(Strict.Maybe ModuleName) - -- ^ The current module is available after it has been type - -- checked. - , stPostInstanceDefs :: !TempInstanceTable - , stPostConcreteNames :: !ConcreteNames - -- ^ Map keeping track of concrete names assigned to each abstract name - -- (can be more than one name in case the first one is shadowed) - , stPostUsedNames :: !(Map RawName [RawName]) - -- ^ Map keeping track for each name root (= name w/o numeric - -- suffixes) what names with the same root have been used during a - -- TC computation. This information is used to build the - -- @ShadowingNames@ map. - , stPostShadowingNames :: !(Map Name [RawName]) - -- ^ Map keeping track for each (abstract) name the list of all - -- (raw) names that it could maybe be shadowed by. - , stPostStatistics :: !Statistics - -- ^ Counters to collect various statistics about meta variables etc. - -- Only for current file. - , stPostTCWarnings :: ![TCWarning] - , stPostMutualBlocks :: !(Map MutualId MutualBlock) - , stPostLocalBuiltins :: !(BuiltinThings PrimFun) - , stPostFreshMetaId :: !MetaId - , stPostFreshMutualId :: !MutualId - , stPostFreshProblemId :: !ProblemId - , stPostFreshCheckpointId :: !CheckpointId - , stPostFreshInt :: !Int - , stPostFreshNameId :: !NameId - , stPostAreWeCaching :: !Bool - , stPostPostponeInstanceSearch :: !Bool - , stPostConsideringInstance :: !Bool - , stPostInstantiateBlocking :: !Bool - -- ^ Should we instantiate away blocking metas? - -- This can produce ill-typed terms but they are often more readable. See issue #3606. - -- Best set to True only for calls to pretty*/reify to limit unwanted reductions. - , stPostLocalPartialDefs :: !(Set QName) - -- ^ Local partial definitions, to be stored in the @Interface@ - } - deriving (Generic) - --- | A mutual block of names in the signature. -data MutualBlock = MutualBlock - { mutualInfo :: Info.MutualInfo - -- ^ The original info of the mutual block. - , mutualNames :: Set QName - } deriving (Show, Eq, Generic) - -instance Null MutualBlock where - empty = MutualBlock empty empty - --- | A part of the state which is not reverted when an error is thrown --- or the state is reset. -data PersistentTCState = PersistentTCSt - { stDecodedModules :: !DecodedModules - , stPersistentOptions :: CommandLineOptions - , stInteractionOutputCallback :: InteractionOutputCallback - -- ^ Callback function to call when there is a response - -- to give to the interactive frontend. - -- See the documentation of 'InteractionOutputCallback'. - , stBenchmark :: !Benchmark - -- ^ Structure to track how much CPU time was spent on which Agda phase. - -- Needs to be a strict field to avoid space leaks! - , stAccumStatistics :: !Statistics - -- ^ Should be strict field. - , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache) - -- ^ Cached typechecking state from the last loaded file. - -- Should be @Nothing@ when checking imports. - , stPersistBackends :: [Backend] - -- ^ Current backends with their options - } - deriving Generic - -data LoadedFileCache = LoadedFileCache - { lfcCached :: !CachedTypeCheckLog - , lfcCurrent :: !CurrentTypeCheckLog - } - deriving Generic - --- | A log of what the type checker does and states after the action is --- completed. The cached version is stored first executed action first. -type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)] - --- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type --- checking of a module. Stored in reverse order (last performed action --- first). -type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)] - --- | A complete log for a module will look like this: --- --- * 'Pragmas' --- --- * 'EnterSection', entering the main module. --- --- * 'Decl'/'EnterSection'/'LeaveSection', for declarations and nested --- modules --- --- * 'LeaveSection', leaving the main module. -data TypeCheckAction - = EnterSection !ModuleName !A.Telescope - | LeaveSection !ModuleName - | Decl !A.Declaration - -- ^ Never a Section or ScopeDecl - | Pragmas !PragmaOptions - deriving (Generic) - --- | Empty persistent state. - -initPersistentState :: PersistentTCState -initPersistentState = PersistentTCSt - { stPersistentOptions = defaultOptions - , stDecodedModules = Map.empty - , stInteractionOutputCallback = defaultInteractionOutputCallback - , stBenchmark = empty - , stAccumStatistics = Map.empty - , stPersistLoadedFileCache = empty - , stPersistBackends = [] - } - --- | Empty state of type checker. - -initPreScopeState :: PreScopeState -initPreScopeState = PreScopeState - { stPreTokens = mempty - , stPreImports = emptySignature - , stPreImportedModules = Set.empty - , stPreModuleToSource = Map.empty - , stPreVisitedModules = Map.empty - , stPreScope = emptyScopeInfo - , stPrePatternSyns = Map.empty - , stPrePatternSynImports = Map.empty - , stPreGeneralizedVars = mempty - , stPrePragmaOptions = defaultInteractionOptions - , stPreImportedBuiltins = Map.empty - , stPreImportedDisplayForms = HMap.empty - , stPreImportedInstanceDefs = Map.empty - , stPreForeignCode = Map.empty - , stPreFreshInteractionId = 0 - , stPreImportedUserWarnings = Map.empty - , stPreLocalUserWarnings = Map.empty - , stPreWarningOnImport = empty - , stPreImportedPartialDefs = Set.empty - , stPreProjectConfigs = Map.empty - , stPreAgdaLibFiles = Map.empty - } - -initPostScopeState :: PostScopeState -initPostScopeState = PostScopeState - { stPostSyntaxInfo = mempty - , stPostDisambiguatedNames = IntMap.empty - , stPostMetaStore = IntMap.empty - , stPostInteractionPoints = empty - , stPostAwakeConstraints = [] - , stPostSleepingConstraints = [] - , stPostDirty = False - , stPostOccursCheckDefs = Set.empty - , stPostSignature = emptySignature - , stPostModuleCheckpoints = Map.empty - , stPostImportsDisplayForms = HMap.empty - , stPostCurrentModule = empty - , stPostInstanceDefs = (Map.empty , Set.empty) - , stPostConcreteNames = Map.empty - , stPostUsedNames = Map.empty - , stPostShadowingNames = Map.empty - , stPostStatistics = Map.empty - , stPostTCWarnings = [] - , stPostMutualBlocks = Map.empty - , stPostLocalBuiltins = Map.empty - , stPostFreshMetaId = 0 - , stPostFreshMutualId = 0 - , stPostFreshProblemId = 1 - , stPostFreshCheckpointId = 1 - , stPostFreshInt = 0 - , stPostFreshNameId = NameId 0 noModuleNameHash - , stPostAreWeCaching = False - , stPostPostponeInstanceSearch = False - , stPostConsideringInstance = False - , stPostInstantiateBlocking = False - , stPostLocalPartialDefs = Set.empty - } - -initState :: TCState -initState = TCSt - { stPreScopeState = initPreScopeState - , stPostScopeState = initPostScopeState - , stPersistentState = initPersistentState - } - --- * st-prefixed lenses ------------------------------------------------------------------------- - -stTokens :: Lens' HighlightingInfo TCState -stTokens f s = - f (stPreTokens (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}} - -stImports :: Lens' Signature TCState -stImports f s = - f (stPreImports (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}} - -stImportedModules :: Lens' (Set ModuleName) TCState -stImportedModules f s = - f (stPreImportedModules (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}} - -stModuleToSource :: Lens' ModuleToSource TCState -stModuleToSource f s = - f (stPreModuleToSource (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}} - -stVisitedModules :: Lens' VisitedModules TCState -stVisitedModules f s = - f (stPreVisitedModules (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}} - -stScope :: Lens' ScopeInfo TCState -stScope f s = - f (stPreScope (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}} - -stPatternSyns :: Lens' A.PatternSynDefns TCState -stPatternSyns f s = - f (stPrePatternSyns (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}} - -stPatternSynImports :: Lens' A.PatternSynDefns TCState -stPatternSynImports f s = - f (stPrePatternSynImports (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}} - -stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState -stGeneralizedVars f s = - f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}} - -stPragmaOptions :: Lens' PragmaOptions TCState -stPragmaOptions f s = - f (stPrePragmaOptions (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}} - -stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState -stImportedBuiltins f s = - f (stPreImportedBuiltins (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}} - -stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState -stForeignCode f s = - f (stPreForeignCode (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}} - -stFreshInteractionId :: Lens' InteractionId TCState -stFreshInteractionId f s = - f (stPreFreshInteractionId (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}} - -stImportedUserWarnings :: Lens' (Map A.QName Text) TCState -stImportedUserWarnings f s = - f (stPreImportedUserWarnings (stPreScopeState s)) <&> - \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}} - -stLocalUserWarnings :: Lens' (Map A.QName Text) TCState -stLocalUserWarnings f s = - f (stPreLocalUserWarnings (stPreScopeState s)) <&> - \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}} - -getUserWarnings :: ReadTCState m => m (Map A.QName Text) -getUserWarnings = do - iuw <- useR stImportedUserWarnings - luw <- useR stLocalUserWarnings - return $ iuw `Map.union` luw - -stWarningOnImport :: Lens' (Maybe Text) TCState -stWarningOnImport f s = - f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&> - \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}} - -stImportedPartialDefs :: Lens' (Set QName) TCState -stImportedPartialDefs f s = - f (stPreImportedPartialDefs (stPreScopeState s)) <&> - \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}} - -stLocalPartialDefs :: Lens' (Set QName) TCState -stLocalPartialDefs f s = - f (stPostLocalPartialDefs (stPostScopeState s)) <&> - \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}} - -getPartialDefs :: ReadTCState m => m (Set QName) -getPartialDefs = do - ipd <- useR stImportedPartialDefs - lpd <- useR stLocalPartialDefs - return $ ipd `Set.union` lpd - -stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState -stLoadedFileCache f s = - f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&> - \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}} - -stBackends :: Lens' [Backend] TCState -stBackends f s = - f (stPersistBackends (stPersistentState s)) <&> - \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}} - -stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState -stProjectConfigs f s = - f (stPreProjectConfigs (stPreScopeState s)) <&> - \ x -> s {stPreScopeState = (stPreScopeState s) {stPreProjectConfigs = x}} - -stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState -stAgdaLibFiles f s = - f (stPreAgdaLibFiles (stPreScopeState s)) <&> - \ x -> s {stPreScopeState = (stPreScopeState s) {stPreAgdaLibFiles = x}} - -stFreshNameId :: Lens' NameId TCState -stFreshNameId f s = - f (stPostFreshNameId (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}} - -stSyntaxInfo :: Lens' HighlightingInfo TCState -stSyntaxInfo f s = - f (stPostSyntaxInfo (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}} - -stDisambiguatedNames :: Lens' DisambiguatedNames TCState -stDisambiguatedNames f s = - f (stPostDisambiguatedNames (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}} - -stMetaStore :: Lens' MetaStore TCState -stMetaStore f s = - f (stPostMetaStore (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostMetaStore = x}} - -stInteractionPoints :: Lens' InteractionPoints TCState -stInteractionPoints f s = - f (stPostInteractionPoints (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}} - -stAwakeConstraints :: Lens' Constraints TCState -stAwakeConstraints f s = - f (stPostAwakeConstraints (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}} - -stSleepingConstraints :: Lens' Constraints TCState -stSleepingConstraints f s = - f (stPostSleepingConstraints (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}} - -stDirty :: Lens' Bool TCState -stDirty f s = - f (stPostDirty (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}} - -stOccursCheckDefs :: Lens' (Set QName) TCState -stOccursCheckDefs f s = - f (stPostOccursCheckDefs (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}} - -stSignature :: Lens' Signature TCState -stSignature f s = - f (stPostSignature (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}} - -stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState -stModuleCheckpoints f s = - f (stPostModuleCheckpoints (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}} - -stImportsDisplayForms :: Lens' DisplayForms TCState -stImportsDisplayForms f s = - f (stPostImportsDisplayForms (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}} - -stImportedDisplayForms :: Lens' DisplayForms TCState -stImportedDisplayForms f s = - f (stPreImportedDisplayForms (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}} - -stCurrentModule :: Lens' (Maybe ModuleName) TCState -stCurrentModule f s = - f (Strict.toLazy $ stPostCurrentModule (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = Strict.toStrict x}} - -stImportedInstanceDefs :: Lens' InstanceTable TCState -stImportedInstanceDefs f s = - f (stPreImportedInstanceDefs (stPreScopeState s)) <&> - \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}} - -stInstanceDefs :: Lens' TempInstanceTable TCState -stInstanceDefs f s = - f (stPostInstanceDefs (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}} - -stConcreteNames :: Lens' ConcreteNames TCState -stConcreteNames f s = - f (stPostConcreteNames (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}} - -stUsedNames :: Lens' (Map RawName [RawName]) TCState -stUsedNames f s = - f (stPostUsedNames (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}} - -stShadowingNames :: Lens' (Map Name [RawName]) TCState -stShadowingNames f s = - f (stPostShadowingNames (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}} - -stStatistics :: Lens' Statistics TCState -stStatistics f s = - f (stPostStatistics (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}} - -stTCWarnings :: Lens' [TCWarning] TCState -stTCWarnings f s = - f (stPostTCWarnings (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}} - -stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState -stMutualBlocks f s = - f (stPostMutualBlocks (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}} - -stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState -stLocalBuiltins f s = - f (stPostLocalBuiltins (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}} - -stFreshMetaId :: Lens' MetaId TCState -stFreshMetaId f s = - f (stPostFreshMetaId (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}} - -stFreshMutualId :: Lens' MutualId TCState -stFreshMutualId f s = - f (stPostFreshMutualId (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}} - -stFreshProblemId :: Lens' ProblemId TCState -stFreshProblemId f s = - f (stPostFreshProblemId (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}} - -stFreshCheckpointId :: Lens' CheckpointId TCState -stFreshCheckpointId f s = - f (stPostFreshCheckpointId (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}} - -stFreshInt :: Lens' Int TCState -stFreshInt f s = - f (stPostFreshInt (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}} - --- use @areWeCaching@ from the Caching module instead. -stAreWeCaching :: Lens' Bool TCState -stAreWeCaching f s = - f (stPostAreWeCaching (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}} - -stPostponeInstanceSearch :: Lens' Bool TCState -stPostponeInstanceSearch f s = - f (stPostPostponeInstanceSearch (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}} - -stConsideringInstance :: Lens' Bool TCState -stConsideringInstance f s = - f (stPostConsideringInstance (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}} - -stInstantiateBlocking :: Lens' Bool TCState -stInstantiateBlocking f s = - f (stPostInstantiateBlocking (stPostScopeState s)) <&> - \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}} - -stBuiltinThings :: TCState -> BuiltinThings PrimFun -stBuiltinThings s = (s^.stLocalBuiltins) `Map.union` (s^.stImportedBuiltins) - - --- * Fresh things ------------------------------------------------------------------------- - -class Enum i => HasFresh i where - freshLens :: Lens' i TCState - nextFresh' :: i -> i - nextFresh' = succ - -nextFresh :: HasFresh i => TCState -> (i, TCState) -nextFresh s = - let !c = s^.freshLens - in (c, set freshLens (nextFresh' c) s) - -class Monad m => MonadFresh i m where - fresh :: m i - - default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i - fresh = lift fresh - -instance MonadFresh i m => MonadFresh i (ReaderT r m) -instance MonadFresh i m => MonadFresh i (StateT s m) -instance MonadFresh i m => MonadFresh i (ListT m) -instance MonadFresh i m => MonadFresh i (IdentityT m) - -instance HasFresh i => MonadFresh i TCM where - fresh = do - !s <- getTC - let (!c , !s') = nextFresh s - putTC s' - return c - -instance HasFresh MetaId where - freshLens = stFreshMetaId - -instance HasFresh MutualId where - freshLens = stFreshMutualId - -instance HasFresh InteractionId where - freshLens = stFreshInteractionId - -instance HasFresh NameId where - freshLens = stFreshNameId - -- nextFresh increments the current fresh name by 2 so @NameId@s used - -- before caching starts do not overlap with the ones used after. - nextFresh' = succ . succ - -instance HasFresh Int where - freshLens = stFreshInt - -instance HasFresh ProblemId where - freshLens = stFreshProblemId - -newtype CheckpointId = CheckpointId Int - deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData) - -instance Show CheckpointId where - show (CheckpointId n) = show n - -instance Pretty CheckpointId where - pretty (CheckpointId n) = pretty n - -instance HasFresh CheckpointId where - freshLens = stFreshCheckpointId - -freshName :: MonadFresh NameId m => Range -> String -> m Name -freshName r s = do - i <- fresh - return $ mkName r i s - -freshNoName :: MonadFresh NameId m => Range -> m Name -freshNoName r = - do i <- fresh - return $ makeName i (C.NoName noRange i) r noFixity' False - -freshNoName_ :: MonadFresh NameId m => m Name -freshNoName_ = freshNoName noRange - -freshRecordName :: MonadFresh NameId m => m Name -freshRecordName = do - i <- fresh - return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True - --- | Create a fresh name from @a@. -class FreshName a where - freshName_ :: MonadFresh NameId m => a -> m Name - -instance FreshName (Range, String) where - freshName_ = uncurry freshName - -instance FreshName String where - freshName_ = freshName noRange - -instance FreshName Range where - freshName_ = freshNoName - -instance FreshName () where - freshName_ () = freshNoName_ - ---------------------------------------------------------------------------- --- ** Managing file names ---------------------------------------------------------------------------- - --- | Maps top-level module names to the corresponding source file --- names. - -type ModuleToSource = Map TopLevelModuleName AbsolutePath - --- | Maps source file names to the corresponding top-level module --- names. - -type SourceToModule = Map AbsolutePath TopLevelModuleName - --- | Creates a 'SourceToModule' map based on 'stModuleToSource'. --- --- O(n log n). --- --- For a single reverse lookup in 'stModuleToSource', --- rather use 'lookupModuleFromSourse'. - -sourceToModule :: TCM SourceToModule -sourceToModule = - Map.fromListWith __IMPOSSIBLE__ - . List.map (\(m, f) -> (f, m)) - . Map.toList - <$> useTC stModuleToSource - --- | Lookup an 'AbsolutePath' in 'sourceToModule'. --- --- O(n). - -lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName) -lookupModuleFromSource f = - fmap fst . List.find ((f ==) . snd) . Map.toList <$> useR stModuleToSource - - ---------------------------------------------------------------------------- --- ** Associating concrete names to an abstract name ---------------------------------------------------------------------------- - --- | A monad that has read and write access to the stConcreteNames --- part of the TCState. Basically, this is a synonym for `MonadState --- ConcreteNames m` (which cannot be used directly because of the --- limitations of Haskell's typeclass system). -class Monad m => MonadStConcreteNames m where - runStConcreteNames :: StateT ConcreteNames m a -> m a - - useConcreteNames :: m ConcreteNames - useConcreteNames = runStConcreteNames get - - modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m () - modifyConcreteNames = runStConcreteNames . modify - -instance MonadStConcreteNames TCM where - runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m - -instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where - runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m - -instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where - runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m) - -instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where - runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do - ((x,ns'),s') <- runStateT (runStateT m ns) s - return ((x,s'),ns') - ---------------------------------------------------------------------------- --- ** Interface ---------------------------------------------------------------------------- - - --- | Distinguishes between type-checked and scope-checked interfaces --- when stored in the map of `VisitedModules`. -data ModuleCheckMode - = ModuleScopeChecked - | ModuleTypeChecked - deriving (Eq, Ord, Bounded, Enum, Show, Generic) - - -data ModuleInfo = ModuleInfo - { miInterface :: Interface - , miWarnings :: [TCWarning] - -- ^ Warnings were encountered when the module was type checked. - -- These might include warnings not stored in the interface itself, - -- specifically unsolved interaction metas. - -- See "Agda.Interaction.Imports" - , miPrimitive :: Bool - -- ^ 'True' if the module is a primitive module, which should always - -- be importable. - , miMode :: ModuleCheckMode - -- ^ The `ModuleCheckMode` used to create the `Interface` - } - deriving Generic - --- Note that the use of 'C.TopLevelModuleName' here is a potential --- performance problem, because these names do not contain unique --- identifiers. - -type VisitedModules = Map C.TopLevelModuleName ModuleInfo -type DecodedModules = Map C.TopLevelModuleName ModuleInfo - -data ForeignCode = ForeignCode Range String - deriving (Show, Generic) - -data Interface = Interface - { iSourceHash :: Hash - -- ^ Hash of the source code. - , iSource :: TL.Text - -- ^ The source code. The source code is stored so that the HTML - -- and LaTeX backends can generate their output without having to - -- re-read the (possibly out of date) source code. - , iFileType :: FileType - -- ^ Source file type, determined from the file extension - , iImportedModules :: [(ModuleName, Hash)] - -- ^ Imported modules and their hashes. - , iModuleName :: ModuleName - -- ^ Module name of this interface. - , iScope :: Map ModuleName Scope - -- ^ Scope defined by this module. - -- - -- Andreas, AIM XX: Too avoid duplicate serialization, this field is - -- not serialized, so if you deserialize an interface, @iScope@ - -- will be empty. - -- But 'constructIScope' constructs 'iScope' from 'iInsideScope'. - , iInsideScope :: ScopeInfo - -- ^ Scope after we loaded this interface. - -- Used in 'Agda.Interaction.BasicOps.AtTopLevel' - -- and 'Agda.Interaction.CommandLine.interactionLoop'. - , iSignature :: Signature - , iDisplayForms :: DisplayForms - -- ^ Display forms added for imported identifiers. - , iUserWarnings :: Map A.QName Text - -- ^ User warnings for imported identifiers - , iImportWarning :: Maybe Text - -- ^ Whether this module should raise a warning when imported - , iBuiltin :: BuiltinThings (String, QName) - , iForeignCode :: Map BackendName [ForeignCode] - , iHighlighting :: HighlightingInfo - , iDefaultPragmaOptions :: [OptionsPragma] - -- ^ Pragma options set in library files. - , iFilePragmaOptions :: [OptionsPragma] - -- ^ Pragma options set in the file. - , iOptionsUsed :: PragmaOptions - -- ^ Options/features used when checking the file (can be different - -- from options set directly in the file). - , iPatternSyns :: A.PatternSynDefns - , iWarnings :: [TCWarning] - , iPartialDefs :: Set QName - } - deriving (Show, Generic) - -instance Pretty Interface where - pretty (Interface - sourceH source fileT importedM moduleN scope insideS signature - display userwarn importwarn builtin foreignCode highlighting - libPragmaO filePragmaO - oUsed patternS warnings partialdefs) = - - hang "Interface" 2 $ vcat - [ "source hash:" <+> (pretty . show) sourceH - , "source:" $$ nest 2 (text $ TL.unpack source) - , "file type:" <+> (pretty . show) fileT - , "imported modules:" <+> (pretty . show) importedM - , "module name:" <+> pretty moduleN - , "scope:" <+> (pretty . show) scope - , "inside scope:" <+> (pretty . show) insideS - , "signature:" <+> (pretty . show) signature - , "display:" <+> (pretty . show) display - , "user warnings:" <+> (pretty . show) userwarn - , "import warning:" <+> (pretty . show) importwarn - , "builtin:" <+> (pretty . show) builtin - , "Foreign code:" <+> (pretty . show) foreignCode - , "highlighting:" <+> (pretty . show) highlighting - , "library pragma options:" <+> (pretty . show) libPragmaO - , "file pragma options:" <+> (pretty . show) filePragmaO - , "options used:" <+> (pretty . show) oUsed - , "pattern syns:" <+> (pretty . show) patternS - , "warnings:" <+> (pretty . show) warnings - , "partial definitions:" <+> (pretty . show) partialdefs - ] - --- | Combines the source hash and the (full) hashes of the imported modules. -iFullHash :: Interface -> Hash -iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i) - --- | A lens for the 'iSignature' field of the 'Interface' type. - -intSignature :: Lens' Signature Interface -intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s } - ---------------------------------------------------------------------------- --- ** Closure ---------------------------------------------------------------------------- - -data Closure a = Closure - { clSignature :: Signature - , clEnv :: TCEnv - , clScope :: ScopeInfo - , clModuleCheckpoints :: Map ModuleName CheckpointId - , clValue :: a - } - deriving (Functor, Foldable, Generic) - -instance Show a => Show (Closure a) where - show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }" - -instance HasRange a => HasRange (Closure a) where - getRange = getRange . clValue - -class LensClosure a b | b -> a where - lensClosure :: Lens' (Closure a) b - -instance LensClosure a (Closure a) where - lensClosure = id - -instance LensTCEnv (Closure a) where - lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env } - -buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a) -buildClosure x = do - env <- askTC - sig <- useR stSignature - scope <- useR stScope - cps <- useR stModuleCheckpoints - return $ Closure sig env scope cps x - ---------------------------------------------------------------------------- --- ** Constraints ---------------------------------------------------------------------------- - -type Constraints = [ProblemConstraint] - -data ProblemConstraint = PConstr - { constraintProblems :: Set ProblemId - , constraintUnblocker :: Blocker - , theConstraint :: Closure Constraint - } - deriving (Show, Generic) - -instance HasRange ProblemConstraint where - getRange = getRange . theConstraint - -data Constraint - = ValueCmp Comparison CompareAs Term Term - | ValueCmpOnFace Comparison Term Type Term Term - | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim] - | SortCmp Comparison Sort Sort - | LevelCmp Comparison Level Level --- | ShortCut MetaId Term Type --- -- ^ A delayed instantiation. Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'. - | HasBiggerSort Sort - | HasPTSRule (Dom Type) (Abs Sort) - | CheckMetaInst MetaId - | CheckType Type - | UnBlock MetaId - -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved - -- constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst' - -- or 'PostponedTypeCheckingProblem'. - | IsEmpty Range Type - -- ^ The range is the one of the absurd pattern. - | CheckSizeLtSat Term - -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT. - | FindInstance MetaId (Maybe [Candidate]) - -- ^ the first argument is the instance argument and the second one is the list of candidates - -- (or Nothing if we haven’t determined the list of candidates yet) - | CheckFunDef Delayed A.DefInfo QName [A.Clause] TCErr - -- ^ Last argument is the error causing us to postpone. - | UnquoteTactic Term Term Type -- ^ First argument is computation and the others are hole and goal type - | CheckLockedVars Term Type (Arg Term) Type -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed. - | UsableAtModality Modality Term -- ^ is the term usable at the given modality? - deriving (Show, Generic) - -instance HasRange Constraint where - getRange (IsEmpty r t) = r - getRange _ = noRange -{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId - getRange (ValueCmp cmp a u v) = getRange (a,u,v) - getRange (ElimCmp pol a v es es') = getRange (a,v,es,es') - getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel') - getRange (SortCmp cmp s s') = getRange (s,s') - getRange (LevelCmp cmp l l') = getRange (l,l') - getRange (UnBlock x) = getRange x - getRange (FindInstance x cands) = getRange x --} - -instance Free Constraint where - freeVars' c = - case c of - ValueCmp _ t u v -> freeVars' (t, (u, v)) - ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v))) - ElimCmp _ _ t u es es' -> freeVars' ((t, u), (es, es')) - SortCmp _ s s' -> freeVars' (s, s') - LevelCmp _ l l' -> freeVars' (l, l') - UnBlock _ -> mempty - IsEmpty _ t -> freeVars' t - CheckSizeLtSat u -> freeVars' u - FindInstance _ cs -> freeVars' cs - CheckFunDef{} -> mempty - HasBiggerSort s -> freeVars' s - HasPTSRule a s -> freeVars' (a , s) - CheckLockedVars a b c d -> freeVars' ((a,b),(c,d)) - UnquoteTactic t h g -> freeVars' (t, (h, g)) - CheckMetaInst m -> mempty - CheckType t -> freeVars' t - UsableAtModality mod t -> freeVars' t - -instance TermLike Constraint where - foldTerm f = \case - ValueCmp _ t u v -> foldTerm f (t, u, v) - ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v) - ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es') - LevelCmp _ l l' -> foldTerm f (Level l, Level l') -- Note wrapping as term, to ensure f gets to act on l and l' - IsEmpty _ t -> foldTerm f t - CheckSizeLtSat u -> foldTerm f u - UnquoteTactic t h g -> foldTerm f (t, h, g) - SortCmp _ s1 s2 -> foldTerm f (Sort s1, Sort s2) -- Same as LevelCmp case - UnBlock _ -> mempty - CheckLockedVars a b c d -> foldTerm f (a, b, c, d) - FindInstance _ _ -> mempty - CheckFunDef{} -> mempty - HasBiggerSort s -> foldTerm f s - HasPTSRule a s -> foldTerm f (a, Sort <$> s) - CheckMetaInst m -> mempty - CheckType t -> foldTerm f t - UsableAtModality m t -> foldTerm f t - - traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented - -instance AllMetas Constraint - -data Comparison = CmpEq | CmpLeq - deriving (Eq, Data, Show, Generic) - -instance Pretty Comparison where - pretty CmpEq = "=" - pretty CmpLeq = "=<" - --- | An extension of 'Comparison' to @>=@. -data CompareDirection = DirEq | DirLeq | DirGeq - deriving (Eq, Show) - -instance Pretty CompareDirection where - pretty = text . \case - DirEq -> "=" - DirLeq -> "=<" - DirGeq -> ">=" - --- | Embed 'Comparison' into 'CompareDirection'. -fromCmp :: Comparison -> CompareDirection -fromCmp CmpEq = DirEq -fromCmp CmpLeq = DirLeq - --- | Flip the direction of comparison. -flipCmp :: CompareDirection -> CompareDirection -flipCmp DirEq = DirEq -flipCmp DirLeq = DirGeq -flipCmp DirGeq = DirLeq - --- | Turn a 'Comparison' function into a 'CompareDirection' function. --- --- Property: @dirToCmp f (fromCmp cmp) = f cmp@ -dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c -dirToCmp cont DirEq = cont CmpEq -dirToCmp cont DirLeq = cont CmpLeq -dirToCmp cont DirGeq = flip $ cont CmpLeq - --- | We can either compare two terms at a given type, or compare two --- types without knowing (or caring about) their sorts. -data CompareAs - = AsTermsOf Type -- ^ @Type@ should not be @Size@. - -- But currently, we do not rely on this invariant. - | AsSizes -- ^ Replaces @AsTermsOf Size@. - | AsTypes - deriving (Data, Show, Generic) - -instance Free CompareAs where - freeVars' (AsTermsOf a) = freeVars' a - freeVars' AsSizes = mempty - freeVars' AsTypes = mempty - -instance TermLike CompareAs where - foldTerm f (AsTermsOf a) = foldTerm f a - foldTerm f AsSizes = mempty - foldTerm f AsTypes = mempty - - traverseTermM f = \case - AsTermsOf a -> AsTermsOf <$> traverseTermM f a - AsSizes -> return AsSizes - AsTypes -> return AsTypes - -instance AllMetas CompareAs - ---------------------------------------------------------------------------- --- * Open things ---------------------------------------------------------------------------- - --- | A thing tagged with the context it came from. Also keeps the substitution from previous --- checkpoints. This lets us handle the case when an open thing was created in a context that we --- have since exited. Remember which module it's from to make sure we don't get confused by --- checkpoints from other files. -data Open a = OpenThing { openThingCheckpoint :: CheckpointId - , openThingCheckpointMap :: Map CheckpointId Substitution - , openThingModule :: ModuleNameHash - , openThing :: a } - deriving (Show, Functor, Foldable, Traversable, Generic) - -instance Decoration Open where - traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x - -instance Pretty a => Pretty (Open a) where - prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $ - "OpenThing" <+> pretty cp <+> pretty (Map.toList env) prettyPrec 10 x - ---------------------------------------------------------------------------- --- * Judgements --- --- Used exclusively for typing of meta variables. ---------------------------------------------------------------------------- - --- | Parametrized since it is used without MetaId when creating a new meta. -data Judgement a - = HasType - { jMetaId :: a - , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type? - , jMetaType :: Type - } - | IsSort - { jMetaId :: a - , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas - } - deriving Generic - -instance Pretty a => Pretty (Judgement a) where - pretty (HasType a cmp t) = hsep [ pretty a, ":" , pretty t ] - pretty (IsSort a t) = hsep [ pretty a, ":sort", pretty t ] - ------------------------------------------------------------------------------ --- ** Generalizable variables ------------------------------------------------------------------------------ - -data DoGeneralize - = YesGeneralizeVar -- ^ Generalize because it is a generalizable variable. - | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and - -- we're currently checking the type of a generalizable variable - -- (this should get the default modality). - | NoGeneralize -- ^ Don't generalize. - deriving (Eq, Ord, Show, Data, Generic) - --- | The value of a generalizable variable. This is created to be a --- generalizable meta before checking the type to be generalized. -data GeneralizedValue = GeneralizedValue - { genvalCheckpoint :: CheckpointId - , genvalTerm :: Term - , genvalType :: Type - } deriving (Show, Data, Generic) - ---------------------------------------------------------------------------- --- ** Meta variables ---------------------------------------------------------------------------- - -data MetaVariable = - MetaVar { mvInfo :: MetaInfo - , mvPriority :: MetaPriority -- ^ some metavariables are more eager to be instantiated - , mvPermutation :: Permutation - -- ^ a metavariable doesn't have to depend on all variables - -- in the context, this "permutation" will throw away the - -- ones it does not depend on - , mvJudgement :: Judgement MetaId - , mvInstantiation :: MetaInstantiation - , mvListeners :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one - , mvFrozen :: Frozen -- ^ are we past the point where we can instantiate this meta variable? - , mvTwin :: Maybe MetaId - -- ^ @Just m@ means that this meta-variable will be - -- equated to @m@ when the latter is unblocked. See - -- 'Agda.TypeChecking.MetaVars.blockTermOnProblem'. - } - deriving Generic - -data Listener = EtaExpand MetaId - | CheckConstraint Nat ProblemConstraint - deriving Generic - -instance Eq Listener where - EtaExpand x == EtaExpand y = x == y - CheckConstraint x _ == CheckConstraint y _ = x == y - _ == _ = False - -instance Ord Listener where - EtaExpand x `compare` EtaExpand y = x `compare` y - CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y - EtaExpand{} `compare` CheckConstraint{} = LT - CheckConstraint{} `compare` EtaExpand{} = GT - --- | Frozen meta variable cannot be instantiated by unification. --- This serves to prevent the completion of a definition by its use --- outside of the current block. --- (See issues 118, 288, 399). -data Frozen - = Frozen -- ^ Do not instantiate. - | Instantiable - deriving (Eq, Show, Generic) - -data MetaInstantiation - = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables) - | Open -- ^ unsolved - | OpenInstance -- ^ open, to be instantiated by instance search - | BlockedConst Term -- ^ solution blocked by unsolved constraints - | PostponedTypeCheckingProblem (Closure TypeCheckingProblem) - deriving Generic - --- | Solving a 'CheckArgs' constraint may or may not check the target type. If --- it did, it returns a handle to any unsolved constraints. -data CheckedTarget = CheckedTarget (Maybe ProblemId) - | NotCheckedTarget - -data PrincipalArgTypeMetas = PrincipalArgTypeMetas - { patmMetas :: Args -- ^ metas created for hidden and instance arguments - -- in the principal argument's type - , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and - -- instance arguments - } - deriving Generic - -data TypeCheckingProblem - = CheckExpr Comparison A.Expr Type - | CheckArgs Comparison ExpandHidden Range [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term) - | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Args Type Int Term Type PrincipalArgTypeMetas - | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type - -- ^ @(λ (xs : t₀) → e) : t@ - -- This is not an instance of 'CheckExpr' as the domain type - -- has already been checked. - -- For example, when checking - -- @(λ (x y : Fin _) → e) : (x : Fin n) → ?@ - -- we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@ - -- is a 'Type' rather than an 'A.Expr'. - | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term` - deriving Generic - -instance Show MetaInstantiation where - show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")" - show Open = "Open" - show OpenInstance = "OpenInstance" - show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")" - show (PostponedTypeCheckingProblem{}) = "PostponedTypeCheckingProblem (...)" - --- | Meta variable priority: --- When we have an equation between meta-variables, which one --- should be instantiated? --- --- Higher value means higher priority to be instantiated. -newtype MetaPriority = MetaPriority Int - deriving (Eq, Ord, Show, NFData) - -data RunMetaOccursCheck - = RunMetaOccursCheck - | DontRunMetaOccursCheck - deriving (Eq, Ord, Show, Generic) - --- | @MetaInfo@ is cloned from one meta to the next during pruning. -data MetaInfo = MetaInfo - { miClosRange :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range. - , miModality :: Modality -- ^ Instantiable with irrelevant/erased solution? - , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions? - , miNameSuggestion :: MetaNameSuggestion - -- ^ Used for printing. - -- @Just x@ if meta-variable comes from omitted argument with name @x@. - , miGeneralizable :: Arg DoGeneralize - -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo? - } - deriving Generic - -instance LensModality MetaInfo where - getModality = miModality - setModality mod mi = mi { miModality = mod } - mapModality f mi = mi { miModality = f $ miModality mi } - -instance LensQuantity MetaInfo where - getQuantity = getQuantity . getModality - mapQuantity f = mapModality (mapQuantity f) - --- | Name suggestion for meta variable. Empty string means no suggestion. -type MetaNameSuggestion = String - --- | For printing, we couple a meta with its name suggestion. -data NamedMeta = NamedMeta - { nmSuggestion :: MetaNameSuggestion - , nmid :: MetaId - } - -instance Pretty NamedMeta where - pretty (NamedMeta "" x) = pretty x - pretty (NamedMeta "_" x) = pretty x - pretty (NamedMeta s x) = text $ "_" ++ s ++ prettyShow x - -type MetaStore = IntMap MetaVariable - -instance HasRange MetaInfo where - getRange = clValue . miClosRange - -instance HasRange MetaVariable where - getRange m = getRange $ getMetaInfo m - -instance SetRange MetaInfo where - setRange r m = m { miClosRange = (miClosRange m) { clValue = r }} - -instance SetRange MetaVariable where - setRange r m = m { mvInfo = setRange r (mvInfo m) } - -instance LensModality MetaVariable where - getModality = getModality . mvInfo - setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv } - mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv } - -instance LensQuantity MetaVariable where - getQuantity = getQuantity . getModality - mapQuantity f = mapModality (mapQuantity f) - -normalMetaPriority :: MetaPriority -normalMetaPriority = MetaPriority 0 - -lowMetaPriority :: MetaPriority -lowMetaPriority = MetaPriority (-10) - -highMetaPriority :: MetaPriority -highMetaPriority = MetaPriority 10 - -getMetaInfo :: MetaVariable -> Closure Range -getMetaInfo = miClosRange . mvInfo - -getMetaScope :: MetaVariable -> ScopeInfo -getMetaScope m = clScope $ getMetaInfo m - -getMetaEnv :: MetaVariable -> TCEnv -getMetaEnv m = clEnv $ getMetaInfo m - -getMetaSig :: MetaVariable -> Signature -getMetaSig m = clSignature $ getMetaInfo m - -getMetaRelevance :: MetaVariable -> Relevance -getMetaRelevance = getRelevance . getModality - -getMetaModality :: MetaVariable -> Modality -getMetaModality = getModality - --- Lenses - -metaFrozen :: Lens' Frozen MetaVariable -metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x } - -_mvInfo :: Lens' MetaInfo MetaVariable -_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi } - --- Lenses onto Closure Range - -instance LensClosure Range MetaInfo where - lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl } - -instance LensClosure Range MetaVariable where - lensClosure = _mvInfo . lensClosure - --- Lenses onto IsAbstract - -instance LensIsAbstract TCEnv where - lensIsAbstract f env = - -- Andreas, 2019-08-19 - -- Using $! to prevent space leaks like #1829. - -- This can crash when trying to get IsAbstract from IgnoreAbstractMode. - (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env)) - <&> \ a -> env { envAbstractMode = aDefToMode a } - -instance LensIsAbstract (Closure a) where - lensIsAbstract = lensTCEnv . lensIsAbstract - -instance LensIsAbstract MetaInfo where - lensIsAbstract = lensClosure . lensIsAbstract - ---------------------------------------------------------------------------- --- ** Interaction meta variables ---------------------------------------------------------------------------- - --- | Interaction points are created by the scope checker who sets the range. --- The meta variable is created by the type checker and then hooked up to the --- interaction point. -data InteractionPoint = InteractionPoint - { ipRange :: Range -- ^ The position of the interaction point. - , ipMeta :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc. - , ipSolved:: Bool -- ^ Has this interaction point already been solved? - , ipClause:: IPClause - -- ^ The clause of the interaction point (if any). - -- Used for case splitting. - } - deriving Generic - -instance Eq InteractionPoint where (==) = (==) `on` ipMeta - -instance HasTag InteractionPoint where - type Tag InteractionPoint = MetaId - tag = ipMeta - --- | Data structure managing the interaction points. --- --- We never remove interaction points from this map, only set their --- 'ipSolved' to @True@. (Issue #2368) -type InteractionPoints = BiMap InteractionId InteractionPoint - --- | Flag to indicate whether the meta is overapplied in the --- constraint. A meta is overapplied if it has more arguments than --- the size of the telescope in its creation environment --- (as stored in MetaInfo). -data Overapplied = Overapplied | NotOverapplied - deriving (Eq, Show, Data, Generic) - --- | Datatype representing a single boundary condition: --- x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es -data IPBoundary' t = IPBoundary - { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n] - , ipbValue :: t -- ^ @t@ - , ipbMetaApp :: t -- ^ @?n es@ - , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ? - } - deriving (Show, Data, Functor, Foldable, Traversable, Generic) - -type IPBoundary = IPBoundary' Term - --- | Which clause is an interaction point located in? -data IPClause = IPClause - { ipcQName :: QName -- ^ The name of the function. - , ipcClauseNo :: Int -- ^ The number of the clause of this function. - , ipcType :: Type -- ^ The type of the function - , ipcWithSub :: Maybe Substitution -- ^ Module parameter substitution - , ipcClause :: A.SpineClause -- ^ The original AST clause. - , ipcClosure :: Closure () -- ^ Environment for rechecking the clause. - , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS. - } - | IPNoClause -- ^ The interaction point is not in the rhs of a clause. - deriving (Generic) - -instance Eq IPClause where - IPNoClause == IPNoClause = True - IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i' - _ == _ = False - ---------------------------------------------------------------------------- --- ** Signature ---------------------------------------------------------------------------- - -data Signature = Sig - { _sigSections :: Sections - , _sigDefinitions :: Definitions - , _sigRewriteRules:: RewriteRuleMap -- ^ The rewrite rules defined in this file. - } - deriving (Show, Generic) - -sigSections :: Lens' Sections Signature -sigSections f s = - f (_sigSections s) <&> - \x -> s {_sigSections = x} - -sigDefinitions :: Lens' Definitions Signature -sigDefinitions f s = - f (_sigDefinitions s) <&> - \x -> s {_sigDefinitions = x} - -sigRewriteRules :: Lens' RewriteRuleMap Signature -sigRewriteRules f s = - f (_sigRewriteRules s) <&> - \x -> s {_sigRewriteRules = x} - -type Sections = Map ModuleName Section -type Definitions = HashMap QName Definition -type RewriteRuleMap = HashMap QName RewriteRules -type DisplayForms = HashMap QName [LocalDisplayForm] - -newtype Section = Section { _secTelescope :: Telescope } - deriving (Data, Show, NFData) - -instance Pretty Section where - pretty = pretty . _secTelescope - -secTelescope :: Lens' Telescope Section -secTelescope f s = - f (_secTelescope s) <&> - \x -> s {_secTelescope = x} - -emptySignature :: Signature -emptySignature = Sig Map.empty HMap.empty HMap.empty - --- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a --- constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a --- more readable 'Abstract.Syntax'. --- --- The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables --- that matches any term. -data DisplayForm = Display - { dfPatternVars :: Nat - -- ^ Number @n@ of pattern variables in 'dfPats'. - , dfPats :: Elims - -- ^ Left hand side patterns, the @n@ first free variables are pattern variables, - -- any variables above @n@ are fixed and only match that particular variable. This - -- happens when you have display forms inside parameterised modules that match on the module - -- parameters. The 'ArgInfo' is ignored in these patterns. - , dfRHS :: DisplayTerm - -- ^ Right hand side. - } - deriving (Data, Show, Generic) - -type LocalDisplayForm = Open DisplayForm - --- | A structured presentation of a 'Term' for reification into --- 'Abstract.Syntax'. -data DisplayTerm - = DWithApp DisplayTerm [DisplayTerm] Elims - -- ^ @(f vs | ws) es@. - -- The first 'DisplayTerm' is the parent function @f@ with its args @vs@. - -- The list of 'DisplayTerm's are the with expressions @ws@. - -- The 'Elims' are additional arguments @es@ - -- (possible in case the with-application is of function type) - -- or projections (if it is of record type). - | DCon ConHead ConInfo [Arg DisplayTerm] - -- ^ @c vs@. - | DDef QName [Elim' DisplayTerm] - -- ^ @d vs@. - | DDot Term - -- ^ @.v@. - | DTerm Term - -- ^ @v@. - deriving (Data, Show, Generic) - -instance Free DisplayForm where - freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t) - -instance Free DisplayTerm where - freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es)) - freeVars' (DCon _ _ vs) = freeVars' vs - freeVars' (DDef _ es) = freeVars' es - freeVars' (DDot v) = freeVars' v - freeVars' (DTerm v) = freeVars' v - -instance Pretty DisplayTerm where - prettyPrec p v = - case v of - DTerm v -> prettyPrec p v - DDot v -> "." <> prettyPrec 10 v - DDef f es -> pretty f `pApp` es - DCon c _ vs -> pretty (conName c) `pApp` map Apply vs - DWithApp h ws es -> - mparens (p > 0) - (sep [ pretty h - , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ]) - `pApp` es - where - pApp :: Pretty el => Doc -> [el] -> Doc - pApp d els = mparens (not (null els) && p > 9) $ - sep [d, nest 2 $ fsep (map (prettyPrec 10) els)] - -instance Pretty DisplayForm where - prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $ - "Display" fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ] - --- | By default, we have no display form. -defaultDisplayForm :: QName -> [LocalDisplayForm] -defaultDisplayForm c = [] - --- | Non-linear (non-constructor) first-order pattern. -data NLPat - = PVar !Int [Arg Int] - -- ^ Matches anything (modulo non-linearity) that only contains bound - -- variables that occur in the given arguments. - | PDef QName PElims - -- ^ Matches @f es@ - | PLam ArgInfo (Abs NLPat) - -- ^ Matches @λ x → t@ - | PPi (Dom NLPType) (Abs NLPType) - -- ^ Matches @(x : A) → B@ - | PSort NLPSort - -- ^ Matches a sort of the given shape. - | PBoundVar {-# UNPACK #-} !Int PElims - -- ^ Matches @x es@ where x is a lambda-bound variable - | PTerm Term - -- ^ Matches the term modulo β (ideally βη). - deriving (Data, Show, Generic) -type PElims = [Elim' NLPat] - -data NLPType = NLPType - { nlpTypeSort :: NLPSort - , nlpTypeUnEl :: NLPat - } deriving (Data, Show, Generic) - -data NLPSort - = PType NLPat - | PProp NLPat - | PInf IsFibrant Integer - | PSizeUniv - | PLockUniv - deriving (Data, Show, Generic) - -type RewriteRules = [RewriteRule] - --- | Rewrite rules can be added independently from function clauses. -data RewriteRule = RewriteRule - { rewName :: QName -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@ - -- where @≡@ is the rewrite relation. - , rewContext :: Telescope -- ^ @Γ@. - , rewHead :: QName -- ^ @f@. - , rewPats :: PElims -- ^ @Γ ⊢ f ps : t@. - , rewRHS :: Term -- ^ @Γ ⊢ rhs : t@. - , rewType :: Type -- ^ @Γ ⊢ t@. - , rewFromClause :: Bool -- ^ Was this rewrite rule created from a clause in the definition of the function? - } - deriving (Data, Show, Generic) - -data Definition = Defn - { defArgInfo :: ArgInfo -- ^ Hiding should not be used. - , defName :: QName -- ^ The canonical name, used e.g. in compilation. - , defType :: Type -- ^ Type of the lifted definition. - , defPolarity :: [Polarity] - -- ^ Variance information on arguments of the definition. - -- Does not include info for dropped parameters to - -- projection(-like) functions and constructors. - , defArgOccurrences :: [Occurrence] - -- ^ Positivity information on arguments of the definition. - -- Does not include info for dropped parameters to - -- projection(-like) functions and constructors. - - -- Sometimes Agda looks up 'Occurrence's in these lists based on - -- their position, so one might consider replacing the list - -- with, say, an 'IntMap'. However, presumably these lists tend - -- to be short, in which case 'IntMap's could be slower than - -- lists. For instance, at one point the longest list - -- encountered for the standard library (in serialised - -- interfaces) had length 27. Distribution: - -- - -- Length, number of lists - -- ----------------------- - -- - -- 0, 2444 - -- 1, 721 - -- 2, 433 - -- 3, 668 - -- 4, 602 - -- 5, 624 - -- 6, 626 - -- 7, 484 - -- 8, 375 - -- 9, 264 - -- 10, 305 - -- 11, 188 - -- 12, 171 - -- 13, 108 - -- 14, 84 - -- 15, 80 - -- 16, 38 - -- 17, 23 - -- 18, 16 - -- 19, 8 - -- 20, 7 - -- 21, 5 - -- 22, 2 - -- 23, 3 - -- 27, 1 - - , defArgGeneralizable :: NumGeneralizableArgs - -- ^ How many arguments should be generalised. - , defGeneralizedParams :: [Maybe Name] - -- ^ Gives the name of the (bound variable) parameter for named generalized - -- parameters. This is needed to bring it into scope when type checking - -- the data/record definition corresponding to a type with generalized - -- parameters. - , defDisplay :: [LocalDisplayForm] - , defMutual :: MutualId - , defCompiledRep :: CompiledRepresentation - , defInstance :: Maybe QName - -- ^ @Just q@ when this definition is an instance of class q - , defCopy :: Bool - -- ^ Has this function been created by a module - -- instantiation? - , defMatchable :: Set QName - -- ^ The set of symbols with rewrite rules that match against this symbol - , defNoCompilation :: Bool - -- ^ should compilers skip this? Used for e.g. cubical's comp - , defInjective :: Bool - -- ^ Should the def be treated as injective by the pattern matching unifier? - , defCopatternLHS :: Bool - -- ^ Is this a function defined by copatterns? - , defBlocked :: Blocked_ - -- ^ What blocking tag to use when we cannot reduce this def? - -- Used when checking a function definition is blocked on a meta - -- in the type. - , defLanguage :: !Language - -- ^ The language used for the definition. - , theDef :: Defn - } - deriving (Show, Generic) - -instance LensArgInfo Definition where - getArgInfo = defArgInfo - mapArgInfo f def = def { defArgInfo = f $ defArgInfo def } - -instance LensModality Definition where -instance LensQuantity Definition where -instance LensRelevance Definition where - -data NumGeneralizableArgs - = NoGeneralizableArgs - | SomeGeneralizableArgs !Int - -- ^ When lambda-lifting new args are generalizable if - -- 'SomeGeneralizableArgs', also when the number is zero. - deriving (Data, Show) - -theDefLens :: Lens' Defn Definition -theDefLens f d = f (theDef d) <&> \ df -> d { theDef = df } - --- | Create a definition with sensible defaults. -defaultDefn :: - ArgInfo -> QName -> Type -> Language -> Defn -> Definition -defaultDefn info x t lang def = Defn - { defArgInfo = info - , defName = x - , defType = t - , defPolarity = [] - , defArgOccurrences = [] - , defArgGeneralizable = NoGeneralizableArgs - , defGeneralizedParams = [] - , defDisplay = defaultDisplayForm x - , defMutual = 0 - , defCompiledRep = noCompiledRep - , defInstance = Nothing - , defCopy = False - , defMatchable = Set.empty - , defNoCompilation = False - , defInjective = False - , defCopatternLHS = False - , defBlocked = NotBlocked ReallyNotBlocked () - , defLanguage = lang - , theDef = def - } - --- | Polarity for equality and subtype checking. -data Polarity - = Covariant -- ^ monotone - | Contravariant -- ^ antitone - | Invariant -- ^ no information (mixed variance) - | Nonvariant -- ^ constant - deriving (Data, Show, Eq, Generic) - -instance Pretty Polarity where - pretty = text . \case - Covariant -> "+" - Contravariant -> "-" - Invariant -> "*" - Nonvariant -> "_" - --- | Information about whether an argument is forced by the type of a function. -data IsForced - = Forced - | NotForced - deriving (Data, Show, Eq, Generic) - --- | The backends are responsible for parsing their own pragmas. -data CompilerPragma = CompilerPragma Range String - deriving (Data, Show, Eq, Generic) - -instance HasRange CompilerPragma where - getRange (CompilerPragma r _) = r - -type BackendName = String - -jsBackendName, ghcBackendName :: BackendName -jsBackendName = "JS" -ghcBackendName = "GHC" - -type CompiledRepresentation = Map BackendName [CompilerPragma] - -noCompiledRep :: CompiledRepresentation -noCompiledRep = Map.empty - --- A face represented as a list of equality constraints. --- (r,False) ↦ (r = i0) --- (r,True ) ↦ (r = i1) -type Face = [(Term,Bool)] - --- | An alternative representation of partial elements in a telescope: --- Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T --- see cubicaltt paper (however we do not store the type T). -data System = System - { systemTel :: Telescope - -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ - , systemClauses :: [(Face,Term)] - -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ - } deriving (Data, Show, Generic) - --- | Additional information for extended lambdas. -data ExtLamInfo = ExtLamInfo - { extLamModule :: ModuleName - -- ^ For complicated reasons the scope checker decides the QName of a - -- pattern lambda, and thus its module. We really need to decide the - -- module during type checking though, since if the lambda appears in a - -- refined context the module picked by the scope checker has very much - -- the wrong parameters. - , extLamAbsurd :: Bool - -- ^ Was this definition created from an absurd lambda @λ ()@? - , extLamSys :: !(Strict.Maybe System) - } deriving (Data, Show, Generic) - -modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo -modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e' - --- | Additional information for projection 'Function's. -data Projection = Projection - { projProper :: Maybe QName - -- ^ @Nothing@ if only projection-like, @Just r@ if record projection. - -- The @r@ is the name of the record type projected from. - -- This field is updated by module application. - , projOrig :: QName - -- ^ The original projection name - -- (current name could be from module application). - , projFromType :: Arg QName - -- ^ Type projected from. Original record type if @projProper = Just{}@. - -- Also stores @ArgInfo@ of the principal argument. - -- This field is unchanged by module application. - , projIndex :: Int - -- ^ Index of the record argument. - -- Start counting with 1, because 0 means that - -- it is already applied to the record value. - -- This can happen in module instantiation, but - -- then either the record value is @var 0@, or @funProjection == Nothing@. - , projLams :: ProjLams - -- ^ Term @t@ to be be applied to record parameters and record value. - -- The parameters will be dropped. - -- In case of a proper projection, a postfix projection application - -- will be created: @t = \ pars r -> r .p@ - -- (Invariant: the number of abstractions equals 'projIndex'.) - -- In case of a projection-like function, just the function symbol - -- is returned as 'Def': @t = \ pars -> f@. - } deriving (Data, Show, Generic) - --- | Abstractions to build projection function (dropping parameters). -newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] } - deriving (Data, Show, Null, Generic) - --- | Building the projection function (which drops the parameters). -projDropPars :: Projection -> ProjOrigin -> Term --- Proper projections: -projDropPars (Projection Just{} d _ _ lams) o = - case initLast $ getProjLams lams of - Nothing -> Def d [] - Just (pars, Arg i y) -> - let core = Lam i $ Abs y $ Var 0 [Proj o d] in - List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars --- Projection-like functions: -projDropPars (Projection Nothing d _ _ lams) o = - List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $ - initWithDefault __IMPOSSIBLE__ $ getProjLams lams - --- | The info of the principal (record) argument. -projArgInfo :: Projection -> ArgInfo -projArgInfo (Projection _ _ _ _ lams) = - maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams - --- | Should a record type admit eta-equality? -data EtaEquality - = Specified { theEtaEquality :: !HasEta } -- ^ User specifed 'eta-equality' or 'no-eta-equality'. - | Inferred { theEtaEquality :: !HasEta } -- ^ Positivity checker inferred whether eta is safe. - deriving (Data, Show, Eq, Generic) - -instance PatternMatchingAllowed EtaEquality where - patternMatchingAllowed = patternMatchingAllowed . theEtaEquality - -instance CopatternMatchingAllowed EtaEquality where - copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality - --- | Make sure we do not overwrite a user specification. -setEtaEquality :: EtaEquality -> HasEta -> EtaEquality -setEtaEquality e@Specified{} _ = e -setEtaEquality _ b = Inferred b - -data FunctionFlag - = FunStatic -- ^ Should calls to this function be normalised at compile-time? - | FunInline -- ^ Should calls to this function be inlined by the compiler? - | FunMacro -- ^ Is this function a macro? - deriving (Data, Eq, Ord, Enum, Show, Generic) - -data CompKit = CompKit - { nameOfHComp :: Maybe QName - , nameOfTransp :: Maybe QName - } - deriving (Data, Eq, Ord, Show, Generic) - -emptyCompKit :: CompKit -emptyCompKit = CompKit Nothing Nothing - -defaultAxiom :: Defn -defaultAxiom = Axiom False - -constTranspAxiom :: Defn -constTranspAxiom = Axiom True - -data Defn = Axiom -- ^ Postulate - { axiomConstTransp :: Bool - -- ^ Can transp for this postulate be constant? - -- Set to @True@ for bultins like String. - } - | DataOrRecSig - { datarecPars :: Int } - -- ^ Data or record type signature that doesn't yet have a definition - | GeneralizableVar -- ^ Generalizable variable (introduced in `generalize` block) - | AbstractDefn Defn - -- ^ Returned by 'getConstInfo' if definition is abstract. - | Function - { funClauses :: [Clause] - , funCompiled :: Maybe CompiledClauses - -- ^ 'Nothing' while function is still type-checked. - -- @Just cc@ after type and coverage checking and - -- translation to case trees. - , funSplitTree :: Maybe SplitTree - -- ^ The split tree constructed by the coverage - -- checker. Needed to re-compile the clauses after - -- forcing translation. - , funTreeless :: Maybe Compiled - -- ^ Intermediate representation for compiler backends. - , funCovering :: [Clause] - -- ^ Covering clauses computed by coverage checking. - -- Erased by (IApply) confluence checking(?) - , funInv :: FunctionInverse - , funMutual :: Maybe [QName] - -- ^ Mutually recursive functions, @data@s and @record@s. - -- Does include this function. - -- Empty list if not recursive. - -- @Nothing@ if not yet computed (by positivity checker). - , funAbstr :: IsAbstract - , funDelayed :: Delayed - -- ^ Are the clauses of this definition delayed? - , funProjection :: Maybe Projection - -- ^ Is it a record projection? - -- If yes, then return the name of the record type and index of - -- the record argument. Start counting with 1, because 0 means that - -- it is already applied to the record. (Can happen in module - -- instantiation.) This information is used in the termination - -- checker. - , funFlags :: Set FunctionFlag - , funTerminates :: Maybe Bool - -- ^ Has this function been termination checked? Did it pass? - , funExtLam :: Maybe ExtLamInfo - -- ^ Is this function generated from an extended lambda? - -- If yes, then return the number of hidden and non-hidden lambda-lifted arguments - , funWith :: Maybe QName - -- ^ Is this a generated with-function? If yes, then what's the - -- name of the parent function. - } - | Datatype - { dataPars :: Nat -- ^ Number of parameters. - , dataIxs :: Nat -- ^ Number of indices. - , dataClause :: (Maybe Clause) -- ^ This might be in an instantiated module. - , dataCons :: [QName] - -- ^ Constructor names , ordered according to the order of their definition. - , dataSort :: Sort - , dataMutual :: Maybe [QName] - -- ^ Mutually recursive functions, @data@s and @record@s. - -- Does include this data type. - -- Empty if not recursive. - -- @Nothing@ if not yet computed (by positivity checker). - , dataAbstr :: IsAbstract - , dataPathCons :: [QName] -- ^ Path constructor names (subset of dataCons) - } - | Record - { recPars :: Nat - -- ^ Number of parameters. - , recClause :: Maybe Clause - -- ^ Was this record type created by a module application? - -- If yes, the clause is its definition (linking back to the original record type). - , recConHead :: ConHead - -- ^ Constructor name and fields. - , recNamedCon :: Bool - -- ^ Does this record have a @constructor@? - , recFields :: [Dom QName] - -- ^ The record field names. - , recTel :: Telescope - -- ^ The record field telescope. (Includes record parameters.) - -- Note: @TelV recTel _ == telView' recConType@. - -- Thus, @recTel@ is redundant. - , recMutual :: Maybe [QName] - -- ^ Mutually recursive functions, @data@s and @record@s. - -- Does include this record. - -- Empty if not recursive. - -- @Nothing@ if not yet computed (by positivity checker). - , recEtaEquality' :: EtaEquality - -- ^ Eta-expand at this record type? - -- @False@ for unguarded recursive records and coinductive records - -- unless the user specifies otherwise. - , recPatternMatching :: PatternOrCopattern - -- ^ In case eta-equality is off, do we allow pattern matching on the - -- constructor or construction by copattern matching? - -- Having both loses subject reduction, see issue #4560. - -- After positivity checking, this field is obsolete, part of 'EtaEquality'. - , recInduction :: Maybe Induction - -- ^ 'Inductive' or 'CoInductive'? Matters only for recursive records. - -- 'Nothing' means that the user did not specify it, which is an error - -- for recursive records. - , recAbstr :: IsAbstract - , recComp :: CompKit - } - | Constructor - { conPars :: Int -- ^ Number of parameters. - , conArity :: Int -- ^ Number of arguments (excluding parameters). - , conSrcCon :: ConHead -- ^ Name of (original) constructor and fields. (This might be in a module instance.) - , conData :: QName -- ^ Name of datatype or record type. - , conAbstr :: IsAbstract - , conInd :: Induction -- ^ Inductive or coinductive? - , conComp :: CompKit -- ^ Cubical composition. - , conProj :: Maybe [QName] -- ^ Projections. 'Nothing' if not yet computed. - , conForced :: [IsForced] - -- ^ Which arguments are forced (i.e. determined by the type of the constructor)? - -- Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@. - , conErased :: Maybe [Bool] - -- ^ Which arguments are erased at runtime (computed during compilation to treeless)? - -- 'True' means erased, 'False' means retained. - -- 'Nothing' if no erasure analysis has been performed yet. - -- The length of the list is @conArity@. - } - | Primitive -- ^ Primitive or builtin functions. - { primAbstr :: IsAbstract - , primName :: String - , primClauses :: [Clause] - -- ^ 'null' for primitive functions, @not null@ for builtin functions. - , primInv :: FunctionInverse - -- ^ Builtin functions can have inverses. For instance, natural number addition. - , primCompiled :: Maybe CompiledClauses - -- ^ 'Nothing' for primitive functions, - -- @'Just' something@ for builtin functions. - } - | PrimitiveSort - { primName :: String - , primSort :: Sort - } - deriving (Data, Show, Generic) - -instance Pretty Definition where - pretty Defn{..} = - "Defn {" vcat - [ "defArgInfo =" pshow defArgInfo - , "defName =" pretty defName - , "defType =" pretty defType - , "defPolarity =" pshow defPolarity - , "defArgOccurrences =" pshow defArgOccurrences - , "defGeneralizedParams =" pshow defGeneralizedParams - , "defDisplay =" pretty defDisplay - , "defMutual =" pshow defMutual - , "defCompiledRep =" pshow defCompiledRep - , "defInstance =" pshow defInstance - , "defCopy =" pshow defCopy - , "defMatchable =" pshow (Set.toList defMatchable) - , "defInjective =" pshow defInjective - , "defCopatternLHS =" pshow defCopatternLHS - , "theDef =" pretty theDef ] <+> "}" - -instance Pretty Defn where - pretty Axiom{} = "Axiom" - pretty (DataOrRecSig n) = "DataOrRecSig" <+> pretty n - pretty GeneralizableVar{} = "GeneralizableVar" - pretty (AbstractDefn def) = "AbstractDefn" parens (pretty def) - pretty Function{..} = - "Function {" vcat - [ "funClauses =" vcat (map pretty funClauses) - , "funCompiled =" pretty funCompiled - , "funSplitTree =" pretty funSplitTree - , "funTreeless =" pshow funTreeless - , "funInv =" pretty funInv - , "funMutual =" pshow funMutual - , "funAbstr =" pshow funAbstr - , "funDelayed =" pshow funDelayed - , "funProjection =" pretty funProjection - , "funFlags =" pshow funFlags - , "funTerminates =" pshow funTerminates - , "funWith =" pretty funWith ] "}" - pretty Datatype{..} = - "Datatype {" vcat - [ "dataPars =" pshow dataPars - , "dataIxs =" pshow dataIxs - , "dataClause =" pretty dataClause - , "dataCons =" pshow dataCons - , "dataSort =" pretty dataSort - , "dataMutual =" pshow dataMutual - , "dataAbstr =" pshow dataAbstr ] "}" - pretty Record{..} = - "Record {" vcat - [ "recPars =" pshow recPars - , "recClause =" pretty recClause - , "recConHead =" pretty recConHead - , "recNamedCon =" pretty recNamedCon - , "recFields =" pretty recFields - , "recTel =" pretty recTel - , "recMutual =" pshow recMutual - , "recEtaEquality' =" pshow recEtaEquality' - , "recInduction =" pshow recInduction - , "recAbstr =" pshow recAbstr ] "}" - pretty Constructor{..} = - "Constructor {" vcat - [ "conPars =" pshow conPars - , "conArity =" pshow conArity - , "conSrcCon =" pretty conSrcCon - , "conData =" pretty conData - , "conAbstr =" pshow conAbstr - , "conInd =" pshow conInd - , "conErased =" pshow conErased ] "}" - pretty Primitive{..} = - "Primitive {" vcat - [ "primAbstr =" pshow primAbstr - , "primName =" pshow primName - , "primClauses =" pshow primClauses - , "primCompiled =" pshow primCompiled ] "}" - pretty PrimitiveSort{..} = - "PrimitiveSort {" vcat - [ "primName =" pshow primName - , "primSort =" pshow primSort - ] "}" - -instance Pretty Projection where - pretty Projection{..} = - "Projection {" vcat - [ "projProper =" pretty projProper - , "projOrig =" pretty projOrig - , "projFromType =" pretty projFromType - , "projIndex =" pshow projIndex - , "projLams =" pretty projLams - ] - -instance Pretty c => Pretty (FunctionInverse' c) where - pretty NotInjective = "NotInjective" - pretty (Inverse inv) = "Inverse" - vcat [ pretty h <+> "->" pretty cs - | (h, cs) <- Map.toList inv ] - -instance Pretty ProjLams where - pretty (ProjLams args) = pretty args - --- | Is the record type recursive? -recRecursive :: Defn -> Bool -recRecursive (Record { recMutual = Just qs }) = not $ null qs -recRecursive _ = __IMPOSSIBLE__ - -recEtaEquality :: Defn -> HasEta -recEtaEquality = theEtaEquality . recEtaEquality' - --- | A template for creating 'Function' definitions, with sensible defaults. -emptyFunction :: Defn -emptyFunction = Function - { funClauses = [] - , funCompiled = Nothing - , funSplitTree = Nothing - , funTreeless = Nothing - , funInv = NotInjective - , funMutual = Nothing - , funAbstr = ConcreteDef - , funDelayed = NotDelayed - , funProjection = Nothing - , funFlags = Set.empty - , funTerminates = Nothing - , funExtLam = Nothing - , funWith = Nothing - , funCovering = [] - } - -funFlag :: FunctionFlag -> Lens' Bool Defn -funFlag flag f def@Function{ funFlags = flags } = - f (Set.member flag flags) <&> - \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags } -funFlag _ f def = f False $> def - -funStatic, funInline, funMacro :: Lens' Bool Defn -funStatic = funFlag FunStatic -funInline = funFlag FunInline -funMacro = funFlag FunMacro - -isMacro :: Defn -> Bool -isMacro = (^. funMacro) - --- | Checking whether we are dealing with a function yet to be defined. -isEmptyFunction :: Defn -> Bool -isEmptyFunction def = - case def of - Function { funClauses = [] } -> True - _ -> False - -isCopatternLHS :: [Clause] -> Bool -isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats) - -recCon :: Defn -> QName -recCon Record{ recConHead } = conName recConHead -recCon _ = __IMPOSSIBLE__ - -defIsRecord :: Defn -> Bool -defIsRecord Record{} = True -defIsRecord _ = False - -defIsDataOrRecord :: Defn -> Bool -defIsDataOrRecord Record{} = True -defIsDataOrRecord Datatype{} = True -defIsDataOrRecord _ = False - -defConstructors :: Defn -> [QName] -defConstructors Datatype{dataCons = cs} = cs -defConstructors Record{recConHead = c} = [conName c] -defConstructors _ = __IMPOSSIBLE__ - -newtype Fields = Fields [(C.Name, Type)] - deriving Null - --- | Did we encounter a simplifying reduction? --- In terms of CIC, that would be a iota-reduction. --- In terms of Agda, this is a constructor or literal --- pattern that matched. --- Just beta-reduction (substitution) or delta-reduction --- (unfolding of definitions) does not count as simplifying? - -data Simplification = YesSimplification | NoSimplification - deriving (Data, Eq, Show, Generic) - -instance Null Simplification where - empty = NoSimplification - null = (== NoSimplification) - -instance Semigroup Simplification where - YesSimplification <> _ = YesSimplification - NoSimplification <> s = s - -instance Monoid Simplification where - mempty = NoSimplification - mappend = (<>) - -data Reduced no yes - = NoReduction no - | YesReduction Simplification yes - deriving Functor - -redReturn :: a -> ReduceM (Reduced a' a) -redReturn = return . YesReduction YesSimplification - --- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@ - -redBind :: ReduceM (Reduced a a') -> (a -> b) -> - (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b') -redBind ma f k = do - r <- ma - case r of - NoReduction x -> return $ NoReduction $ f x - YesReduction _ y -> k y - --- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked. -data IsReduced - = NotReduced - | Reduced (Blocked ()) - -data MaybeReduced a = MaybeRed - { isReduced :: IsReduced - , ignoreReduced :: a - } - deriving (Functor) - -instance IsProjElim e => IsProjElim (MaybeReduced e) where - isProjElim = isProjElim . ignoreReduced - -type MaybeReducedArgs = [MaybeReduced (Arg Term)] -type MaybeReducedElims = [MaybeReduced Elim] - -notReduced :: a -> MaybeReduced a -notReduced x = MaybeRed NotReduced x - -reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term) -reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b - --- | Controlling 'reduce'. -data AllowedReduction - = ProjectionReductions -- ^ (Projection and) projection-like functions may be reduced. - | InlineReductions -- ^ Functions marked INLINE may be reduced. - | CopatternReductions -- ^ Copattern definitions may be reduced. - | FunctionReductions -- ^ Non-recursive functions and primitives may be reduced. - | RecursiveReductions -- ^ Even recursive functions may be reduced. - | LevelReductions -- ^ Reduce @'Level'@ terms. - | TypeLevelReductions -- ^ Allow @allReductions@ in types, even - -- if not allowed at term level (used - -- by confluence checker) - | UnconfirmedReductions -- ^ Functions whose termination has not (yet) been confirmed. - | NonTerminatingReductions -- ^ Functions that have failed termination checking. - deriving (Show, Eq, Ord, Enum, Bounded, Ix, Data, Generic) - -type AllowedReductions = SmallSet AllowedReduction - --- | Not quite all reductions (skip non-terminating reductions) -allReductions :: AllowedReductions -allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions - -reallyAllReductions :: AllowedReductions -reallyAllReductions = SmallSet.total - -data ReduceDefs - = OnlyReduceDefs (Set QName) - | DontReduceDefs (Set QName) - deriving (Data, Generic) - -reduceAllDefs :: ReduceDefs -reduceAllDefs = DontReduceDefs empty - -locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a -locallyReduceDefs = locallyTC eReduceDefs . const - -locallyReduceAllDefs :: MonadTCEnv m => m a -> m a -locallyReduceAllDefs = locallyReduceDefs reduceAllDefs - -shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool -shouldReduceDef f = asksTC envReduceDefs <&> \case - OnlyReduceDefs defs -> f `Set.member` defs - DontReduceDefs defs -> not $ f `Set.member` defs - -instance Semigroup ReduceDefs where - OnlyReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.intersection qs1 qs2 - OnlyReduceDefs qs1 <> DontReduceDefs qs2 = OnlyReduceDefs $ Set.difference qs1 qs2 - DontReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.difference qs2 qs1 - DontReduceDefs qs1 <> DontReduceDefs qs2 = DontReduceDefs $ Set.union qs1 qs2 - -instance Monoid ReduceDefs where - mempty = reduceAllDefs - mappend = (<>) - - -locallyReconstructed :: MonadTCEnv m => m a -> m a -locallyReconstructed = locallyTC eReconstructed . const $ True - -isReconstructed :: (MonadTCEnv m) => m Bool -isReconstructed = asksTC envReconstructed - --- | Primitives - -data PrimitiveImpl = PrimImpl Type PrimFun - -data PrimFun = PrimFun - { primFunName :: QName - , primFunArity :: Arity - , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term) - } - deriving Generic - -primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun -primFun q ar imp = PrimFun q ar (\ args _ -> imp args) - -defClauses :: Definition -> [Clause] -defClauses Defn{theDef = Function{funClauses = cs}} = cs -defClauses Defn{theDef = Primitive{primClauses = cs}} = cs -defClauses Defn{theDef = Datatype{dataClause = Just c}} = [c] -defClauses Defn{theDef = Record{recClause = Just c}} = [c] -defClauses _ = [] - -defCompiled :: Definition -> Maybe CompiledClauses -defCompiled Defn{theDef = Function {funCompiled = mcc}} = mcc -defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc -defCompiled _ = Nothing - -defParameters :: Definition -> Maybe Nat -defParameters Defn{theDef = Datatype{dataPars = n}} = Just n -defParameters Defn{theDef = Record {recPars = n}} = Just n -defParameters _ = Nothing - -defInverse :: Definition -> FunctionInverse -defInverse Defn{theDef = Function { funInv = inv }} = inv -defInverse Defn{theDef = Primitive{ primInv = inv }} = inv -defInverse _ = NotInjective - -defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma] -defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep - -- reversed because we add new pragmas to the front of the list - --- | Are the clauses of this definition delayed? -defDelayed :: Definition -> Delayed -defDelayed Defn{theDef = Function{funDelayed = d}} = d -defDelayed _ = NotDelayed - --- | Has the definition failed the termination checker? -defNonterminating :: Definition -> Bool -defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True -defNonterminating _ = False - --- | Has the definition not termination checked or did the check fail? -defTerminationUnconfirmed :: Definition -> Bool -defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False -defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _ }} = True -defTerminationUnconfirmed _ = False - -defAbstract :: Definition -> IsAbstract -defAbstract d = case theDef d of - Axiom{} -> ConcreteDef - DataOrRecSig{} -> ConcreteDef - GeneralizableVar{} -> ConcreteDef - AbstractDefn{} -> AbstractDef - Function{funAbstr = a} -> a - Datatype{dataAbstr = a} -> a - Record{recAbstr = a} -> a - Constructor{conAbstr = a} -> a - Primitive{primAbstr = a} -> a - PrimitiveSort{} -> ConcreteDef - -defForced :: Definition -> [IsForced] -defForced d = case theDef d of - Constructor{conForced = fs} -> fs - Axiom{} -> [] - DataOrRecSig{} -> [] - GeneralizableVar{} -> [] - AbstractDefn{} -> [] - Function{} -> [] - Datatype{} -> [] - Record{} -> [] - Primitive{} -> [] - PrimitiveSort{} -> [] - ---------------------------------------------------------------------------- --- ** Injectivity ---------------------------------------------------------------------------- - -type FunctionInverse = FunctionInverse' Clause -type InversionMap c = Map TermHead [c] - -data FunctionInverse' c - = NotInjective - | Inverse (InversionMap c) - deriving (Data, Show, Functor, Generic) - -data TermHead = SortHead - | PiHead - | ConsHead QName - | VarHead Nat - | UnknownHead - deriving (Data, Eq, Ord, Show, Generic) - -instance Pretty TermHead where - pretty = \ case - SortHead -> "SortHead" - PiHead -> "PiHead" - ConsHead q -> "ConsHead" <+> pretty q - VarHead i -> text ("VarHead " ++ show i) - UnknownHead -> "UnknownHead" - ---------------------------------------------------------------------------- --- ** Mutual blocks ---------------------------------------------------------------------------- - -newtype MutualId = MutId Int32 - deriving (Data, Eq, Ord, Show, Num, Enum, NFData) - ---------------------------------------------------------------------------- --- ** Statistics ---------------------------------------------------------------------------- - -type Statistics = Map String Integer - ---------------------------------------------------------------------------- --- ** Trace ---------------------------------------------------------------------------- - -data Call - = CheckClause Type A.SpineClause - | CheckLHS A.SpineLHS - | CheckPattern A.Pattern Telescope Type - | CheckPatternLinearityType C.Name - | CheckPatternLinearityValue C.Name - | CheckLetBinding A.LetBinding - | InferExpr A.Expr - | CheckExprCall Comparison A.Expr Type - | CheckDotPattern A.Expr Term - | CheckProjection Range QName Type - | IsTypeCall Comparison A.Expr Sort - | IsType_ A.Expr - | InferVar Name - | InferDef QName - | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type) - | CheckMetaSolution Range MetaId Type Term - | CheckTargetType Range Type Type - | CheckDataDef Range QName [A.LamBinding] [A.Constructor] - | CheckRecDef Range QName [A.LamBinding] [A.Constructor] - | CheckConstructor QName Telescope Sort A.Constructor - | CheckConstructorFitsIn QName Type Sort - | CheckFunDefCall Range QName [A.Clause] Bool - -- ^ Highlight (interactively) if and only if the boolean is 'True'. - | CheckPragma Range A.Pragma - | CheckPrimitive Range QName A.Expr - | CheckIsEmpty Range Type - | CheckConfluence QName QName - | CheckWithFunctionType Type - | CheckSectionApplication Range ModuleName A.ModuleApplication - | CheckNamedWhere ModuleName - | ScopeCheckExpr C.Expr - | ScopeCheckDeclaration NiceDeclaration - | ScopeCheckLHS C.QName C.Pattern - | NoHighlighting - | ModuleContents -- ^ Interaction command: show module contents. - | SetRange Range -- ^ used by 'setCurrentRange' - deriving (Data, Generic) - -instance Pretty Call where - pretty CheckClause{} = "CheckClause" - pretty CheckLHS{} = "CheckLHS" - pretty CheckPattern{} = "CheckPattern" - pretty CheckPatternLinearityType{} = "CheckPatternLinearityType" - pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue" - pretty InferExpr{} = "InferExpr" - pretty CheckExprCall{} = "CheckExprCall" - pretty CheckLetBinding{} = "CheckLetBinding" - pretty CheckProjection{} = "CheckProjection" - pretty IsTypeCall{} = "IsTypeCall" - pretty IsType_{} = "IsType_" - pretty InferVar{} = "InferVar" - pretty InferDef{} = "InferDef" - pretty CheckArguments{} = "CheckArguments" - pretty CheckMetaSolution{} = "CheckMetaSolution" - pretty CheckTargetType{} = "CheckTargetType" - pretty CheckDataDef{} = "CheckDataDef" - pretty CheckRecDef{} = "CheckRecDef" - pretty CheckConstructor{} = "CheckConstructor" - pretty CheckConstructorFitsIn{} = "CheckConstructorFitsIn" - pretty CheckFunDefCall{} = "CheckFunDefCall" - pretty CheckPragma{} = "CheckPragma" - pretty CheckPrimitive{} = "CheckPrimitive" - pretty CheckWithFunctionType{} = "CheckWithFunctionType" - pretty CheckNamedWhere{} = "CheckNamedWhere" - pretty ScopeCheckExpr{} = "ScopeCheckExpr" - pretty ScopeCheckDeclaration{} = "ScopeCheckDeclaration" - pretty ScopeCheckLHS{} = "ScopeCheckLHS" - pretty CheckDotPattern{} = "CheckDotPattern" - pretty SetRange{} = "SetRange" - pretty CheckSectionApplication{} = "CheckSectionApplication" - pretty CheckIsEmpty{} = "CheckIsEmpty" - pretty CheckConfluence{} = "CheckConfluence" - pretty NoHighlighting{} = "NoHighlighting" - pretty ModuleContents{} = "ModuleContents" - -instance HasRange Call where - getRange (CheckClause _ c) = getRange c - getRange (CheckLHS lhs) = getRange lhs - getRange (CheckPattern p _ _) = getRange p - getRange (CheckPatternLinearityType x) = getRange x - getRange (CheckPatternLinearityValue x) = getRange x - getRange (InferExpr e) = getRange e - getRange (CheckExprCall _ e _) = getRange e - getRange (CheckLetBinding b) = getRange b - getRange (CheckProjection r _ _) = r - getRange (IsTypeCall cmp e s) = getRange e - getRange (IsType_ e) = getRange e - getRange (InferVar x) = getRange x - getRange (InferDef f) = getRange f - getRange (CheckArguments r _ _ _) = r - getRange (CheckMetaSolution r _ _ _) = r - getRange (CheckTargetType r _ _) = r - getRange (CheckDataDef i _ _ _) = getRange i - getRange (CheckRecDef i _ _ _) = getRange i - getRange (CheckConstructor _ _ _ c) = getRange c - getRange (CheckConstructorFitsIn c _ _) = getRange c - getRange (CheckFunDefCall i _ _ _) = getRange i - getRange (CheckPragma r _) = r - getRange (CheckPrimitive i _ _) = getRange i - getRange CheckWithFunctionType{} = noRange - getRange (CheckNamedWhere m) = getRange m - getRange (ScopeCheckExpr e) = getRange e - getRange (ScopeCheckDeclaration d) = getRange d - getRange (ScopeCheckLHS _ p) = getRange p - getRange (CheckDotPattern e _) = getRange e - getRange (SetRange r) = r - getRange (CheckSectionApplication r _ _) = r - getRange (CheckIsEmpty r _) = r - getRange (CheckConfluence rule1 rule2) = max (getRange rule1) (getRange rule2) - getRange NoHighlighting = noRange - getRange ModuleContents = noRange - ---------------------------------------------------------------------------- --- ** Instance table ---------------------------------------------------------------------------- - --- | The instance table is a @Map@ associating to every name of --- record/data type/postulate its list of instances -type InstanceTable = Map QName (Set QName) - --- | When typechecking something of the following form: --- --- instance --- x : _ --- x = y --- --- it's not yet known where to add @x@, so we add it to a list of --- unresolved instances and we'll deal with it later. -type TempInstanceTable = (InstanceTable , Set QName) - ---------------------------------------------------------------------------- --- ** Builtin things ---------------------------------------------------------------------------- - -data BuiltinDescriptor - = BuiltinData (TCM Type) [String] - | BuiltinDataCons (TCM Type) - | BuiltinPrim String (Term -> TCM ()) - | BuiltinSort String - | BuiltinPostulate Relevance (TCM Type) - | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ()) - -- ^ Builtin of any kind. - -- Type can be checked (@Just t@) or inferred (@Nothing@). - -- The second argument is the hook for the verification function. - -data BuiltinInfo = - BuiltinInfo { builtinName :: String - , builtinDesc :: BuiltinDescriptor } - -type BuiltinThings pf = Map String (Builtin pf) - -data Builtin pf - = Builtin Term - | Prim pf - deriving (Show, Functor, Foldable, Traversable, Generic) - ---------------------------------------------------------------------------- --- * Highlighting levels ---------------------------------------------------------------------------- - --- | How much highlighting should be sent to the user interface? - -data HighlightingLevel - = None - | NonInteractive - | Interactive - -- ^ This includes both non-interactive highlighting and - -- interactive highlighting of the expression that is currently - -- being type-checked. - deriving (Eq, Ord, Show, Read, Data, Generic) - --- | How should highlighting be sent to the user interface? - -data HighlightingMethod - = Direct - -- ^ Via stdout. - | Indirect - -- ^ Both via files and via stdout. - deriving (Eq, Show, Read, Data, Generic) - --- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're --- type-checking the top-level module (or before we've started doing --- this) and either the highlighting level is /at least/ @l@ or @b@ is --- 'True'. - -ifTopLevelAndHighlightingLevelIsOr :: - MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm () -ifTopLevelAndHighlightingLevelIsOr l b m = do - e <- askTC - when (envHighlightingLevel e >= l || b) $ - case (envImportPath e) of - -- Below the main module. - (_:_:_) -> pure () - -- In or before the top-level module. - _ -> m - --- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're --- type-checking the top-level module (or before we've started doing --- this) and the highlighting level is /at least/ @l@. - -ifTopLevelAndHighlightingLevelIs :: - MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm () -ifTopLevelAndHighlightingLevelIs l = - ifTopLevelAndHighlightingLevelIsOr l False - ---------------------------------------------------------------------------- --- * Type checking environment ---------------------------------------------------------------------------- - -data TCEnv = - TCEnv { envContext :: Context - , envLetBindings :: LetBindings - , envCurrentModule :: ModuleName - , envCurrentPath :: Maybe AbsolutePath - -- ^ The path to the file that is currently being - -- type-checked. 'Nothing' if we do not have a file - -- (like in interactive mode see @CommandLine@). - , envAnonymousModules :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables - , envImportPath :: [C.TopLevelModuleName] - -- ^ The module stack with the entry being the top-level module as - -- Agda chases modules. It will be empty if there is no main - -- module, will have a single entry for the top level module, or - -- more when descending past the main module. This is used to - -- detect import cycles and in some cases highlighting behavior. - -- The level of a given module is not necessarily the same as the - -- length, in the module dependency graph, of the shortest path - -- from the top-level module; it depends on in which order Agda - -- chooses to chase dependencies. - , envMutualBlock :: Maybe MutualId -- ^ the current (if any) mutual block - , envTerminationCheck :: TerminationCheck () -- ^ are we inside the scope of a termination pragma - , envCoverageCheck :: CoverageCheck -- ^ are we inside the scope of a coverage pragma - , envMakeCase :: Bool -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier) - , envSolvingConstraints :: Bool - -- ^ Are we currently in the process of solving active constraints? - , envCheckingWhere :: Bool - -- ^ Have we stepped into the where-declarations of a clause? - -- Everything under a @where@ will be checked with this flag on. - , envWorkingOnTypes :: Bool - -- ^ Are we working on types? Turned on by 'workOnTypes'. - , envAssignMetas :: Bool - -- ^ Are we allowed to assign metas? - , envActiveProblems :: Set ProblemId - , envAbstractMode :: AbstractMode - -- ^ When checking the typesignature of a public definition - -- or the body of a non-abstract definition this is true. - -- To prevent information about abstract things leaking - -- outside the module. - , envModality :: Modality - -- ^ 'Relevance' component: - -- Are we checking an irrelevant argument? (=@Irrelevant@) - -- Then top-level irrelevant declarations are enabled. - -- Other value: @Relevant@, then only relevant decls. are available. - -- - -- 'Quantity' component: - -- Are we checking a runtime-irrelevant thing? (='Quantity0') - -- Then runtime-irrelevant things are usable. - -- Other value: @Quantity1@, runtime relevant. - -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018. - , envSplitOnStrict :: Bool - -- ^ Are we currently case-splitting on a strict - -- datatype (i.e. in SSet)? If yes, the - -- pattern-matching unifier will solve reflexive - -- equations even --without-K. - , envDisplayFormsEnabled :: Bool - -- ^ Sometimes we want to disable display forms. - , envRange :: Range - , envHighlightingRange :: Range - -- ^ Interactive highlighting uses this range rather - -- than 'envRange'. - , envClause :: IPClause - -- ^ What is the current clause we are type-checking? - -- Will be recorded in interaction points in this clause. - , envCall :: Maybe (Closure Call) - -- ^ what we're doing at the moment - , envHighlightingLevel :: HighlightingLevel - -- ^ Set to 'None' when imported modules are - -- type-checked. - , envHighlightingMethod :: HighlightingMethod - , envExpandLast :: ExpandHidden - -- ^ When type-checking an alias f=e, we do not want - -- to insert hidden arguments in the end, because - -- these will become unsolved metas. - , envAppDef :: Maybe QName - -- ^ We are reducing an application of this function. - -- (For debugging of incomplete matches only.) - , envSimplification :: Simplification - -- ^ Did we encounter a simplification (proper match) - -- during the current reduction process? - , envAllowedReductions :: AllowedReductions - , envReduceDefs :: ReduceDefs - , envReconstructed :: Bool - , envInjectivityDepth :: Int - -- ^ Injectivity can cause non-termination for unsolvable contraints - -- (#431, #3067). Keep a limit on the nesting depth of injectivity - -- uses. - , envCompareBlocked :: Bool - -- ^ When @True@, the conversion checker will consider - -- all term constructors as injective, including - -- blocked function applications and metas. Warning: - -- this should only be used when not assigning any - -- metas (e.g. when @envAssignMetas@ is @False@ or - -- when running @pureEqualTerms@) or else we get - -- non-unique meta solutions. - , envPrintDomainFreePi :: Bool - -- ^ When @True@, types will be omitted from printed pi types if they - -- can be inferred. - , envPrintMetasBare :: Bool - -- ^ When @True@, throw away meta numbers and meta elims. - -- This is used for reifying terms for feeding into the - -- user's source code, e.g., for the interaction tactics @solveAll@. - , envInsideDotPattern :: Bool - -- ^ Used by the scope checker to make sure that certain forms - -- of expressions are not used inside dot patterns: extended - -- lambdas and let-expressions. - , envUnquoteFlags :: UnquoteFlags - , envInstanceDepth :: !Int - -- ^ Until we get a termination checker for instance search (#1743) we - -- limit the search depth to ensure termination. - , envIsDebugPrinting :: Bool - , envPrintingPatternLambdas :: [QName] - -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We - -- don't have a good story for what to do in this case, but at least - -- printing shouldn't loop. Here we keep track of which pattern lambdas - -- we are currently in the process of printing. - , envCallByNeed :: Bool - -- ^ Use call-by-need evaluation for reductions. - , envCurrentCheckpoint :: CheckpointId - -- ^ Checkpoints track the evolution of the context as we go - -- under binders or refine it by pattern matching. - , envCheckpoints :: Map CheckpointId Substitution - -- ^ Keeps the substitution from each previous checkpoint to - -- the current context. - , envGeneralizeMetas :: DoGeneralize - -- ^ Should new metas generalized over. - , envGeneralizedVars :: Map QName GeneralizedValue - -- ^ Values for used generalizable variables. - , envActiveBackendName :: Maybe BackendName - -- ^ Is some backend active at the moment, and if yes, which? - -- NB: we only store the 'BackendName' here, otherwise - -- @instance Data TCEnv@ is not derivable. - -- The actual backend can be obtained from the name via 'stBackends'. - , envConflComputingOverlap :: Bool - -- ^ Are we currently computing the overlap between - -- two rewrite rules for the purpose of confluence checking? - , envCurrentlyElaborating :: Bool - -- ^ Are we currently in the process of executing an - -- elaborate-and-give interactive command? - } - deriving (Generic) - -initEnv :: TCEnv -initEnv = TCEnv { envContext = [] - , envLetBindings = Map.empty - , envCurrentModule = noModuleName - , envCurrentPath = Nothing - , envAnonymousModules = [] - , envImportPath = [] - , envMutualBlock = Nothing - , envTerminationCheck = TerminationCheck - , envCoverageCheck = YesCoverageCheck - , envMakeCase = False - , envSolvingConstraints = False - , envCheckingWhere = False - , envActiveProblems = Set.empty - , envWorkingOnTypes = False - , envAssignMetas = True - , envAbstractMode = ConcreteMode - -- Andreas, 2013-02-21: This was 'AbstractMode' until now. - -- However, top-level checks for mutual blocks, such as - -- constructor-headedness, should not be able to look into - -- abstract definitions unless abstract themselves. - -- (See also discussion on issue 796.) - -- The initial mode should be 'ConcreteMode', ensuring you - -- can only look into abstract things in an abstract - -- definition (which sets 'AbstractMode'). - , envModality = unitModality - , envSplitOnStrict = False - , envDisplayFormsEnabled = True - , envRange = noRange - , envHighlightingRange = noRange - , envClause = IPNoClause - , envCall = Nothing - , envHighlightingLevel = None - , envHighlightingMethod = Indirect - , envExpandLast = ExpandLast - , envAppDef = Nothing - , envSimplification = NoSimplification - , envAllowedReductions = allReductions - , envReduceDefs = reduceAllDefs - , envReconstructed = False - , envInjectivityDepth = 0 - , envCompareBlocked = False - , envPrintDomainFreePi = False - , envPrintMetasBare = False - , envInsideDotPattern = False - , envUnquoteFlags = defaultUnquoteFlags - , envInstanceDepth = 0 - , envIsDebugPrinting = False - , envPrintingPatternLambdas = [] - , envCallByNeed = True - , envCurrentCheckpoint = 0 - , envCheckpoints = Map.singleton 0 IdS - , envGeneralizeMetas = NoGeneralize - , envGeneralizedVars = Map.empty - , envActiveBackendName = Nothing - , envConflComputingOverlap = False - , envCurrentlyElaborating = False - } - -class LensTCEnv a where - lensTCEnv :: Lens' TCEnv a - -instance LensTCEnv TCEnv where - lensTCEnv = id - -instance LensModality TCEnv where - -- Cohesion shouldn't have an environment component. - getModality = setCohesion defaultCohesion . envModality - mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e } - -instance LensRelevance TCEnv where -instance LensQuantity TCEnv where - -data UnquoteFlags = UnquoteFlags - { _unquoteNormalise :: Bool } - deriving (Data, Generic) - -defaultUnquoteFlags :: UnquoteFlags -defaultUnquoteFlags = UnquoteFlags - { _unquoteNormalise = False } - -unquoteNormalise :: Lens' Bool UnquoteFlags -unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x } - -eUnquoteNormalise :: Lens' Bool TCEnv -eUnquoteNormalise = eUnquoteFlags . unquoteNormalise - --- * e-prefixed lenses ------------------------------------------------------------------------- - -eContext :: Lens' Context TCEnv -eContext f e = f (envContext e) <&> \ x -> e { envContext = x } - -eLetBindings :: Lens' LetBindings TCEnv -eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x } - -eCurrentModule :: Lens' ModuleName TCEnv -eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x } - -eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv -eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x } - -eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv -eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x } - -eImportPath :: Lens' [C.TopLevelModuleName] TCEnv -eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x } - -eMutualBlock :: Lens' (Maybe MutualId) TCEnv -eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x } - -eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv -eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x } - -eCoverageCheck :: Lens' CoverageCheck TCEnv -eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x } - -eMakeCase :: Lens' Bool TCEnv -eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x } - -eSolvingConstraints :: Lens' Bool TCEnv -eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x } - -eCheckingWhere :: Lens' Bool TCEnv -eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x } - -eWorkingOnTypes :: Lens' Bool TCEnv -eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x } - -eAssignMetas :: Lens' Bool TCEnv -eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x } - -eActiveProblems :: Lens' (Set ProblemId) TCEnv -eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x } - -eAbstractMode :: Lens' AbstractMode TCEnv -eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x } - --- Andrea 23/02/2020: use get/setModality to enforce invariants of the --- envModality field. -eModality :: Lens' Modality TCEnv -eModality f e = f (getModality e) <&> \ x -> setModality x e - -eRelevance :: Lens' Relevance TCEnv -eRelevance = eModality . lModRelevance - -eQuantity :: Lens' Quantity TCEnv -eQuantity = eModality . lModQuantity - -eSplitOnStrict :: Lens' Bool TCEnv -eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x } - -eDisplayFormsEnabled :: Lens' Bool TCEnv -eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x } - -eRange :: Lens' Range TCEnv -eRange f e = f (envRange e) <&> \ x -> e { envRange = x } - -eHighlightingRange :: Lens' Range TCEnv -eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x } - -eCall :: Lens' (Maybe (Closure Call)) TCEnv -eCall f e = f (envCall e) <&> \ x -> e { envCall = x } - -eHighlightingLevel :: Lens' HighlightingLevel TCEnv -eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x } - -eHighlightingMethod :: Lens' HighlightingMethod TCEnv -eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x } - -eExpandLast :: Lens' ExpandHidden TCEnv -eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x } - -eAppDef :: Lens' (Maybe QName) TCEnv -eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x } - -eSimplification :: Lens' Simplification TCEnv -eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x } - -eAllowedReductions :: Lens' AllowedReductions TCEnv -eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x } - -eReduceDefs :: Lens' ReduceDefs TCEnv -eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x } - -eReconstructed :: Lens' Bool TCEnv -eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x } - -eInjectivityDepth :: Lens' Int TCEnv -eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x } - -eCompareBlocked :: Lens' Bool TCEnv -eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x } - -ePrintDomainFreePi :: Lens' Bool TCEnv -ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x } - -ePrintMetasBare :: Lens' Bool TCEnv -ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x } - -eInsideDotPattern :: Lens' Bool TCEnv -eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x } - -eUnquoteFlags :: Lens' UnquoteFlags TCEnv -eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x } - -eInstanceDepth :: Lens' Int TCEnv -eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x } - -eIsDebugPrinting :: Lens' Bool TCEnv -eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x } - -ePrintingPatternLambdas :: Lens' [QName] TCEnv -ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x } - -eCallByNeed :: Lens' Bool TCEnv -eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x } - -eCurrentCheckpoint :: Lens' CheckpointId TCEnv -eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x } - -eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv -eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x } - -eGeneralizeMetas :: Lens' DoGeneralize TCEnv -eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x } - -eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv -eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x } - -eActiveBackendName :: Lens' (Maybe BackendName) TCEnv -eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x } - -eConflComputingOverlap :: Lens' Bool TCEnv -eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x } - -eCurrentlyElaborating :: Lens' Bool TCEnv -eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x } - ---------------------------------------------------------------------------- --- ** Context ---------------------------------------------------------------------------- - --- | The @Context@ is a stack of 'ContextEntry's. -type Context = [ContextEntry] -type ContextEntry = Dom (Name, Type) - ---------------------------------------------------------------------------- --- ** Let bindings ---------------------------------------------------------------------------- - -type LetBindings = Map Name (Open (Term, Dom Type)) - ---------------------------------------------------------------------------- --- ** Abstract mode ---------------------------------------------------------------------------- - -data AbstractMode - = AbstractMode -- ^ Abstract things in the current module can be accessed. - | ConcreteMode -- ^ No abstract things can be accessed. - | IgnoreAbstractMode -- ^ All abstract things can be accessed. - deriving (Data, Show, Eq, Generic) - -aDefToMode :: IsAbstract -> AbstractMode -aDefToMode AbstractDef = AbstractMode -aDefToMode ConcreteDef = ConcreteMode - -aModeToDef :: AbstractMode -> Maybe IsAbstract -aModeToDef AbstractMode = Just AbstractDef -aModeToDef ConcreteMode = Just ConcreteDef -aModeToDef _ = Nothing - ---------------------------------------------------------------------------- --- ** Insertion of implicit arguments ---------------------------------------------------------------------------- - -data ExpandHidden - = ExpandLast -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'. - | DontExpandLast -- ^ Do not append implicit arguments. - | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables. - deriving (Eq, Data, Generic) - -isDontExpandLast :: ExpandHidden -> Bool -isDontExpandLast ExpandLast = False -isDontExpandLast DontExpandLast = True -isDontExpandLast ReallyDontExpandLast = True - -data CandidateKind - = LocalCandidate - | GlobalCandidate QName - deriving (Show, Data, Generic) - --- | A candidate solution for an instance meta is a term with its type. --- It may be the case that the candidate is not fully applied yet or --- of the wrong type, hence the need for the type. -data Candidate = Candidate { candidateKind :: CandidateKind - , candidateTerm :: Term - , candidateType :: Type - , candidateOverlappable :: Bool - } - deriving (Show, Data, Generic) - -instance Free Candidate where - freeVars' (Candidate _ t u _) = freeVars' (t, u) - - ---------------------------------------------------------------------------- --- ** Checking arguments ---------------------------------------------------------------------------- - -data ArgsCheckState a = ACState - { acRanges :: [Maybe Range] - -- ^ Ranges of checked arguments, where present. - -- e.g. inserted implicits have no correponding abstract syntax. - , acElims :: Elims - -- ^ Checked and inserted arguments so far. - , acConstraints :: [Maybe (Abs Constraint)] - -- ^ Constraints for the head so far, - -- i.e. before applying the correponding elim. - , acType :: Type - -- ^ Type for the rest of the application. - , acData :: a - } - deriving (Show) - - ---------------------------------------------------------------------------- --- * Type checking warnings (aka non-fatal errors) ---------------------------------------------------------------------------- - --- | A non-fatal error is an error which does not prevent us from --- checking the document further and interacting with the user. - -data Warning - = NicifierIssue DeclarationWarning - | TerminationIssue [TerminationError] - | UnreachableClauses QName [Range] - -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs - -- are unreachable - | CoverageIssue QName [(Telescope, [NamedArg DeBruijnPattern])] - -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f` - | CoverageNoExactSplit QName [Clause] - | NotStrictlyPositive QName (Seq OccursWhere) - | UnsolvedMetaVariables [Range] -- ^ Do not use directly with 'warning' - | UnsolvedInteractionMetas [Range] -- ^ Do not use directly with 'warning' - | UnsolvedConstraints Constraints - -- ^ Do not use directly with 'warning' - | CantGeneralizeOverSorts [MetaId] - | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern] - | OldBuiltin String String - -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new - | EmptyRewritePragma - -- ^ If the user wrote just @{-\# REWRITE \#-}@. - | EmptyWhere - -- ^ An empty @where@ block is dead code. - | IllformedAsClause String - -- ^ If the user wrote something other than an unqualified name - -- in the @as@ clause of an @import@ statement. - -- The 'String' gives optionally extra explanation. - | ClashesViaRenaming NameOrModule [C.Name] - -- ^ If a `renaming' import directive introduces a name or module name clash - -- in the exported names of a module. - -- (See issue #4154.) - | UselessPatternDeclarationForRecord String - -- ^ The 'pattern' declaration is useless in the presence - -- of either @coinductive@ or @eta-equality@. - -- Content of 'String' is "coinductive" or "eta", resp. - | UselessPublic - -- ^ If the user opens a module public before the module header. - -- (See issue #2377.) - | UselessHiding [C.ImportedName] - -- ^ Names in `hiding` directive that don't hide anything - -- imported by a `using` directive. - | UselessInline QName - | WrongInstanceDeclaration - | InstanceWithExplicitArg QName - -- ^ An instance was declared with an implicit argument, which means it - -- will never actually be considered by instance search. - | InstanceNoOutputTypeName Doc - -- ^ The type of an instance argument doesn't end in a named or - -- variable type, so it will never be considered by instance search. - | InstanceArgWithExplicitArg Doc - -- ^ As InstanceWithExplicitArg, but for local bindings rather than - -- top-level instances. - | InversionDepthReached QName - -- ^ The --inversion-max-depth was reached. - | NoGuardednessFlag QName - -- ^ A coinductive record was declared but neither --guardedness nor - -- --sized-types is enabled. - - -- Generic warnings for one-off things - | GenericWarning Doc - -- ^ Harmless generic warning (not an error) - | GenericNonFatalError Doc - -- ^ Generic error which doesn't abort proceedings (not a warning) - | GenericUseless Range Doc - -- ^ Generic warning when code is useless and thus ignored. - -- 'Range' is for dead code highlighting. - - -- Safe flag errors - | SafeFlagPostulate C.Name - | SafeFlagPragma [String] -- ^ Unsafe OPTIONS. - | SafeFlagNonTerminating - | SafeFlagTerminating - | SafeFlagWithoutKFlagPrimEraseEquality - | WithoutKFlagPrimEraseEquality - | SafeFlagNoPositivityCheck - | SafeFlagPolarity - | SafeFlagNoUniverseCheck - | SafeFlagNoCoverageCheck - | SafeFlagInjective - | SafeFlagEta -- ^ ETA pragma is unsafe. - | ParseWarning ParseWarning - | LibraryWarning LibWarning - | DeprecationWarning String String String - -- ^ `DeprecationWarning old new version`: - -- `old` is deprecated, use `new` instead. This will be an error in Agda `version`. - | UserWarning Text - -- ^ User-defined warning (e.g. to mention that a name is deprecated) - | DuplicateUsing (List1 C.ImportedName) - -- ^ Duplicate mentions of the same name in @using@ directive(s). - | FixityInRenamingModule (List1 Range) - -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity). - | ModuleDoesntExport C.QName [C.Name] [C.Name] [C.ImportedName] - -- ^ Some imported names are not actually exported by the source module. - -- The second argument is the names that could be exported. - -- The third argument is the module names that could be exported. - | InfectiveImport String ModuleName - -- ^ Importing a file using an infective option into one which doesn't - | CoInfectiveImport String ModuleName - -- ^ Importing a file not using a coinfective option from one which does - | RewriteNonConfluent Term Term Term Doc - -- ^ Confluence checker found critical pair and equality checking - -- resulted in a type error - | RewriteMaybeNonConfluent Term Term [Doc] - -- ^ Confluence checker got stuck on computing overlap between two - -- rewrite rules - | RewriteAmbiguousRules Term Term Term - -- ^ The global confluence checker found a term @u@ that reduces - -- to both @v1@ and @v2@ and there is no rule to resolve the - -- ambiguity. - | RewriteMissingRule Term Term Term - -- ^ The global confluence checker found a term @u@ that reduces - -- to @v@, but @v@ does not reduce to @rho(u)@. - | PragmaCompileErased BackendName QName - -- ^ COMPILE directive for an erased symbol - | NotInScopeW [C.QName] - -- ^ Out of scope error we can recover from - | AsPatternShadowsConstructorOrPatternSynonym Bool - -- ^ The as-name in an as-pattern may not shadow a constructor (@False@) - -- or pattern synonym name (@True@), - -- because this can be confusing to read. - | RecordFieldWarning RecordFieldWarning - deriving (Show, Generic) - -data RecordFieldWarning - = DuplicateFieldsWarning [(C.Name, Range)] - -- ^ Each redundant field comes with a range of associated dead code. - | TooManyFieldsWarning QName [C.Name] [(C.Name, Range)] - -- ^ Record type, fields not supplied by user, non-fields but supplied. - -- The redundant fields come with a range of associated dead code. - deriving (Show, Data, Generic) - -recordFieldWarningToError :: RecordFieldWarning -> TypeError -recordFieldWarningToError = \case - DuplicateFieldsWarning xrs -> DuplicateFields $ map fst xrs - TooManyFieldsWarning q ys xrs -> TooManyFields q ys $ map fst xrs - -warningName :: Warning -> WarningName -warningName = \case - -- special cases - NicifierIssue dw -> declarationWarningName dw - ParseWarning pw -> parseWarningName pw - LibraryWarning lw -> libraryWarningName lw - AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_ - -- scope- and type-checking errors - AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_ - CantGeneralizeOverSorts{} -> CantGeneralizeOverSorts_ - CoverageIssue{} -> CoverageIssue_ - CoverageNoExactSplit{} -> CoverageNoExactSplit_ - DeprecationWarning{} -> DeprecationWarning_ - EmptyRewritePragma -> EmptyRewritePragma_ - EmptyWhere -> EmptyWhere_ - IllformedAsClause{} -> IllformedAsClause_ - WrongInstanceDeclaration{} -> WrongInstanceDeclaration_ - InstanceWithExplicitArg{} -> InstanceWithExplicitArg_ - InstanceNoOutputTypeName{} -> InstanceNoOutputTypeName_ - InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_ - DuplicateUsing{} -> DuplicateUsing_ - FixityInRenamingModule{} -> FixityInRenamingModule_ - GenericNonFatalError{} -> GenericNonFatalError_ - GenericUseless{} -> GenericUseless_ - GenericWarning{} -> GenericWarning_ - InversionDepthReached{} -> InversionDepthReached_ - ModuleDoesntExport{} -> ModuleDoesntExport_ - NoGuardednessFlag{} -> NoGuardednessFlag_ - NotInScopeW{} -> NotInScope_ - NotStrictlyPositive{} -> NotStrictlyPositive_ - OldBuiltin{} -> OldBuiltin_ - SafeFlagNoPositivityCheck -> SafeFlagNoPositivityCheck_ - SafeFlagNonTerminating -> SafeFlagNonTerminating_ - SafeFlagNoUniverseCheck -> SafeFlagNoUniverseCheck_ - SafeFlagPolarity -> SafeFlagPolarity_ - SafeFlagPostulate{} -> SafeFlagPostulate_ - SafeFlagPragma{} -> SafeFlagPragma_ - SafeFlagEta -> SafeFlagEta_ - SafeFlagInjective -> SafeFlagInjective_ - SafeFlagNoCoverageCheck -> SafeFlagNoCoverageCheck_ - SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_ - WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_ - SafeFlagTerminating -> SafeFlagTerminating_ - TerminationIssue{} -> TerminationIssue_ - UnreachableClauses{} -> UnreachableClauses_ - UnsolvedInteractionMetas{} -> UnsolvedInteractionMetas_ - UnsolvedConstraints{} -> UnsolvedConstraints_ - UnsolvedMetaVariables{} -> UnsolvedMetaVariables_ - UselessHiding{} -> UselessHiding_ - UselessInline{} -> UselessInline_ - UselessPublic{} -> UselessPublic_ - UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_ - ClashesViaRenaming{} -> ClashesViaRenaming_ - UserWarning{} -> UserWarning_ - InfectiveImport{} -> InfectiveImport_ - CoInfectiveImport{} -> CoInfectiveImport_ - RewriteNonConfluent{} -> RewriteNonConfluent_ - RewriteMaybeNonConfluent{} -> RewriteMaybeNonConfluent_ - RewriteAmbiguousRules{} -> RewriteAmbiguousRules_ - RewriteMissingRule{} -> RewriteMissingRule_ - PragmaCompileErased{} -> PragmaCompileErased_ - -- record field warnings - RecordFieldWarning w -> case w of - DuplicateFieldsWarning{} -> DuplicateFieldsWarning_ - TooManyFieldsWarning{} -> TooManyFieldsWarning_ - -data TCWarning - = TCWarning - { tcWarningLocation :: CallStack - -- ^ Location in the internal Agda source code location where the error raised - , tcWarningRange :: Range - -- ^ Range where the warning was raised - , tcWarning :: Warning - -- ^ The warning itself - , tcWarningPrintedWarning :: Doc - -- ^ The warning printed in the state and environment where it was raised - , tcWarningCached :: Bool - -- ^ Should the warning be affected by caching. - } - deriving (Show, Generic) - -tcWarningOrigin :: TCWarning -> SrcFile -tcWarningOrigin = rangeFile . tcWarningRange - -instance HasRange TCWarning where - getRange = tcWarningRange - --- used for merging lists of warnings -instance Eq TCWarning where - (==) = (==) `on` tcWarningPrintedWarning - ---------------------------------------------------------------------------- --- * Type checking errors ---------------------------------------------------------------------------- - --- | Information about a call. - -data CallInfo = CallInfo - { callInfoTarget :: QName - -- ^ Target function name. - , callInfoRange :: Range - -- ^ Range of the target function. - , callInfoCall :: Closure Term - -- ^ To be formatted representation of the call. - } deriving (Show, Generic) - -- no Eq, Ord instances: too expensive! (see issues 851, 852) - --- | We only 'show' the name of the callee. -instance Pretty CallInfo where pretty = pretty . callInfoTarget - --- | Information about a mutual block which did not pass the --- termination checker. - -data TerminationError = TerminationError - { termErrFunctions :: [QName] - -- ^ The functions which failed to check. (May not include - -- automatically generated functions.) - , termErrCalls :: [CallInfo] - -- ^ The problematic call sites. - } deriving (Show, Generic) - --- | Error when splitting a pattern variable into possible constructor patterns. -data SplitError - = NotADatatype (Closure Type) -- ^ Neither data type nor record. - | BlockedType Blocker (Closure Type) -- ^ Type could not be sufficiently reduced. - | ErasedDatatype Bool (Closure Type) -- ^ Data type, but in erased position. - -- If the boolean is 'True', - -- then the reason for the - -- error is that the K rule - -- is turned off. - | CoinductiveDatatype (Closure Type) -- ^ Split on codata not allowed. - -- UNUSED, but keep! - -- -- | NoRecordConstructor Type -- ^ record type, but no constructor - | UnificationStuck - { cantSplitBlocker :: Maybe Blocker -- ^ Blocking metavariable (if any) - , cantSplitConName :: QName -- ^ Constructor. - , cantSplitTel :: Telescope -- ^ Context for indices. - , cantSplitConIdx :: Args -- ^ Inferred indices (from type of constructor). - , cantSplitGivenIdx :: Args -- ^ Expected indices (from checking pattern). - , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck. - } - | CosplitCatchall - -- ^ Copattern split with a catchall - | CosplitNoTarget - -- ^ We do not know the target type of the clause. - | CosplitNoRecordType (Closure Type) - -- ^ Target type is not a record type. - | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type)) - - | GenericSplitError String - deriving (Show, Generic) - -data NegativeUnification - = UnifyConflict Telescope Term Term - | UnifyCycle Telescope Int Term - deriving (Show, Generic) - -data UnificationFailure - = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype - | UnifyRecursiveEq Telescope Type Int Term -- ^ Can't solve equation because variable occurs in (type of) lhs - | UnifyReflexiveEq Telescope Type Term -- ^ Can't solve reflexive equation because --without-K is enabled - | UnifyUnusableModality Telescope Type Int Term Modality -- ^ Can't solve equation because solution modality is less "usable" - deriving (Show, Generic) - -data UnquoteError - = BadVisibility String (Arg I.Term) - | ConInsteadOfDef QName String String - | DefInsteadOfCon QName String String - | NonCanonical String I.Term - | BlockedOnMeta TCState Blocker - | UnquotePanic String - deriving (Show, Generic) - -data TypeError - = InternalError String - | NotImplemented String - | NotSupported String - | CompilationError String - | PropMustBeSingleton - | DataMustEndInSort Term -{- UNUSED - | DataTooManyParameters - -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the - -- the parameters given in the forward declaraion @data D Gamma : T@. --} - | ShouldEndInApplicationOfTheDatatype Type - -- ^ The target of a constructor isn't an application of its - -- datatype. The 'Type' records what it does target. - | ShouldBeAppliedToTheDatatypeParameters Term Term - -- ^ The target of a constructor isn't its datatype applied to - -- something that isn't the parameters. First term is the correct - -- target and the second term is the actual target. - | ShouldBeApplicationOf Type QName - -- ^ Expected a type to be an application of a particular datatype. - | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype - | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName) - -- ^ Datatype, constructors. - | DoesNotConstructAnElementOf QName Type -- ^ constructor, type - | WrongHidingInLHS - -- ^ The left hand side of a function definition has a hidden argument - -- where a non-hidden was expected. - | WrongHidingInLambda Type - -- ^ Expected a non-hidden function and found a hidden lambda. - | WrongHidingInApplication Type - -- ^ A function is applied to a hidden argument where a non-hidden was expected. - | WrongNamedArgument (NamedArg A.Expr) [NamedName] - -- ^ A function is applied to a hidden named argument it does not have. - -- The list contains names of possible hidden arguments at this point. - | WrongIrrelevanceInLambda - -- ^ Wrong user-given relevance annotation in lambda. - | WrongQuantityInLambda - -- ^ Wrong user-given quantity annotation in lambda. - | WrongCohesionInLambda - -- ^ Wrong user-given cohesion annotation in lambda. - | QuantityMismatch Quantity Quantity - -- ^ The given quantity does not correspond to the expected quantity. - | HidingMismatch Hiding Hiding - -- ^ The given hiding does not correspond to the expected hiding. - | RelevanceMismatch Relevance Relevance - -- ^ The given relevance does not correspond to the expected relevane. - | UninstantiatedDotPattern A.Expr - | ForcedConstructorNotInstantiated A.Pattern - | IllformedProjectionPattern A.Pattern - | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type - | WrongNumberOfConstructorArguments QName Nat Nat - | ShouldBeEmpty Type [DeBruijnPattern] - | ShouldBeASort Type - -- ^ The given type should have been a sort. - | ShouldBePi Type - -- ^ The given type should have been a pi. - | ShouldBePath Type - | ShouldBeRecordType Type - | ShouldBeRecordPattern DeBruijnPattern - | NotAProjectionPattern (NamedArg A.Pattern) - | NotAProperTerm - | InvalidTypeSort Sort - -- ^ This sort is not a type expression. - | InvalidType Term - -- ^ This term is not a type expression. - | FunctionTypeInSizeUniv Term - -- ^ This term, a function type constructor, lives in - -- @SizeUniv@, which is not allowed. - | SplitOnIrrelevant (Dom Type) - | SplitOnUnusableCohesion (Dom Type) - -- UNUSED: -- | SplitOnErased (Dom Type) - | SplitOnNonVariable Term Type - | SplitOnNonEtaRecord QName - | DefinitionIsIrrelevant QName - | DefinitionIsErased QName - | VariableIsIrrelevant Name - | VariableIsErased Name - | VariableIsOfUnusableCohesion Name Cohesion - | UnequalLevel Comparison Level Level - | UnequalTerms Comparison Term Term CompareAs - | UnequalTypes Comparison Type Type --- | UnequalTelescopes Comparison Telescope Telescope -- UNUSED - | UnequalRelevance Comparison Term Term - -- ^ The two function types have different relevance. - | UnequalQuantity Comparison Term Term - -- ^ The two function types have different relevance. - | UnequalCohesion Comparison Term Term - -- ^ The two function types have different cohesion. - | UnequalHiding Term Term - -- ^ The two function types have different hiding. - | UnequalSorts Sort Sort - | UnequalBecauseOfUniverseConflict Comparison Term Term - | NotLeqSort Sort Sort - | MetaCannotDependOn MetaId Nat - -- ^ The arguments are the meta variable and the parameter that it wants to depend on. - | MetaOccursInItself MetaId - | MetaIrrelevantSolution MetaId Term - | MetaErasedSolution MetaId Term - | GenericError String - | GenericDocError Doc - | SortOfSplitVarError (Maybe Blocker) Doc - -- ^ the meta is what we might be blocked on. - | BuiltinMustBeConstructor String A.Expr - | NoSuchBuiltinName String - | DuplicateBuiltinBinding String Term Term - | NoBindingForBuiltin String - | NoSuchPrimitiveFunction String - | DuplicatePrimitiveBinding String QName QName - | WrongModalityForPrimitive String ArgInfo ArgInfo - | ShadowedModule C.Name [A.ModuleName] - | BuiltinInParameterisedModule String - | IllegalLetInTelescope C.TypedBinding - | IllegalPatternInTelescope C.Binder - | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern] - | TooManyFields QName [C.Name] [C.Name] - -- ^ Record type, fields not supplied by user, non-fields but supplied. - | DuplicateFields [C.Name] - | DuplicateConstructors [C.Name] - | WithOnFreeVariable A.Expr Term - | UnexpectedWithPatterns [A.Pattern] - | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern) - | FieldOutsideRecord - | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr] - | GeneralizeCyclicDependency - | GeneralizeUnsolvedMeta - -- Coverage errors --- UNUSED: | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off - | SplitError SplitError - | ImpossibleConstructor QName NegativeUnification - -- Positivity errors - | TooManyPolarities QName Int - -- Import errors - | LocalVsImportedModuleClash ModuleName - | SolvedButOpenHoles - -- ^ Some interaction points (holes) have not been filled by user. - -- There are not 'UnsolvedMetas' since unification solved them. - -- This is an error, since interaction points are never filled - -- without user interaction. - | CyclicModuleDependency [C.TopLevelModuleName] - | FileNotFound C.TopLevelModuleName [AbsolutePath] - | OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName - | AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath] - | ModuleNameUnexpected C.TopLevelModuleName C.TopLevelModuleName - -- ^ Found module name, expected module name. - | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath] - | ClashingFileNamesFor ModuleName [AbsolutePath] - | ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath - -- ^ Module name, file from which it was loaded, file which - -- the include path says contains the module. - -- Scope errors - | BothWithAndRHS - | AbstractConstructorNotInScope A.QName - | NotInScope [C.QName] - | NoSuchModule C.QName - | AmbiguousName C.QName (List1 A.QName) - | AmbiguousModule C.QName (List1 A.ModuleName) - | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration) - | ClashingModule A.ModuleName A.ModuleName - | ClashingImport C.Name A.QName - | ClashingModuleImport C.Name A.ModuleName - | PatternShadowsConstructor C.Name A.QName - | DuplicateImports C.QName [C.ImportedName] - | InvalidPattern C.Pattern - | RepeatedVariablesInPattern [C.Name] - | GeneralizeNotSupportedHere A.QName - | MultipleFixityDecls [(C.Name, [Fixity'])] - | MultiplePolarityPragmas [C.Name] - -- Concrete to Abstract errors - | NotAModuleExpr C.Expr - -- ^ The expr was used in the right hand side of an implicit module - -- definition, but it wasn't of the form @m Delta@. - | NotAnExpression C.Expr - | NotAValidLetBinding NiceDeclaration - | NotValidBeforeField NiceDeclaration - | NothingAppliedToHiddenArg C.Expr - | NothingAppliedToInstanceArg C.Expr - -- Pattern synonym errors - | BadArgumentsToPatternSynonym A.AmbiguousQName - | TooFewArgumentsToPatternSynonym A.AmbiguousQName - | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn)) - | UnusedVariableInPatternSynonym - -- Operator errors - | NoParseForApplication (List2 C.Expr) - | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr) - | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern - -- ^ The list contains patterns that failed to be interpreted. - -- If it is non-empty, the first entry could be printed as error hint. - | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern] - -- ^ Pattern and its possible interpretations. - | OperatorInformation [NotationSection] TypeError -{- UNUSED - | NoParseForPatternSynonym C.Pattern - | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern] --} - -- Usage errors - -- Instance search errors - | InstanceNoCandidate Type [(Term, TCErr)] - -- Reflection errors - | UnquoteFailed UnquoteError - | DeBruijnIndexOutOfScope Nat Telescope [Name] - -- Language option errors - | NeedOptionCopatterns - | NeedOptionRewriting - | NeedOptionProp - | NeedOptionTwoLevel - -- Failure associated to warnings - | NonFatalErrors [TCWarning] - -- Instance search errors - | InstanceSearchDepthExhausted Term Type Int - | TriedToCopyConstrainedPrim QName - deriving (Show, Generic) - --- | Distinguish error message when parsing lhs or pattern synonym, resp. -data LHSOrPatSyn = IsLHS | IsPatSyn - deriving (Eq, Show, Generic) - --- | Type-checking errors. - -data TCErr - = TypeError - { tcErrLocation :: CallStack - -- ^ Location in the internal Agda source code where the error was raised - , tcErrState :: TCState - -- ^ The state in which the error was raised. - , tcErrClosErr :: Closure TypeError - -- ^ The environment in which the error as raised plus the error. - } - | Exception Range Doc - | IOException TCState Range E.IOException - -- ^ The first argument is the state in which the error was - -- raised. - | PatternErr Blocker - -- ^ The exception which is usually caught. - -- Raised for pattern violations during unification ('assignV') - -- but also in other situations where we want to backtrack. - -- Contains an unblocker to control when the computation should - -- be retried. - -instance Show TCErr where - show (TypeError _ _ e) = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e) - show (Exception r d) = prettyShow r ++ ": " ++ render d - show (IOException _ r e) = prettyShow r ++ ": " ++ show e - show PatternErr{} = "Pattern violation (you shouldn't see this)" - -instance HasRange TCErr where - getRange (TypeError _ _ cl) = envRange $ clEnv cl - getRange (Exception r _) = r - getRange (IOException s r _) = r - getRange PatternErr{} = noRange - -instance E.Exception TCErr - ------------------------------------------------------------------------------ --- * Accessing options ------------------------------------------------------------------------------ - -instance MonadIO m => HasOptions (TCMT m) where - pragmaOptions = useTC stPragmaOptions - - commandLineOptions = do - p <- useTC stPragmaOptions - cl <- stPersistentOptions . stPersistentState <$> getTC - return $ cl { optPragmaOptions = p } - --- HasOptions lifts through monad transformers --- (see default signatures in the HasOptions class). - --- Ternary options are annoying to deal with so we provide auxiliary --- definitions using @collapseDefault@. - -sizedTypesOption :: HasOptions m => m Bool -sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions - -guardednessOption :: HasOptions m => m Bool -guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions - -withoutKOption :: HasOptions m => m Bool -withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions - -enableCaching :: HasOptions m => m Bool -enableCaching = optCaching <$> pragmaOptions ------------------------------------------------------------------------------ --- * The reduce monad ------------------------------------------------------------------------------ - --- | Environment of the reduce monad. -data ReduceEnv = ReduceEnv - { redEnv :: TCEnv -- ^ Read only access to environment. - , redSt :: TCState -- ^ Read only access to state (signature, metas...). - } - -mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv -mapRedEnv f s = s { redEnv = f (redEnv s) } - -mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv -mapRedSt f s = s { redSt = f (redSt s) } - -mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv - -> ReduceEnv -mapRedEnvSt f g (ReduceEnv e s) = ReduceEnv (f e) (g s) - --- Lenses -reduceEnv :: Lens' TCEnv ReduceEnv -reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e } - -reduceSt :: Lens' TCState ReduceEnv -reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e } - -newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a } --- deriving (Functor, Applicative, Monad) - -onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a -onReduceEnv f (ReduceM m) = ReduceM (m . f) - -fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b -fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e -{-# INLINE fmapReduce #-} - --- Andreas, 2021-05-12, issue #5379: --- It seems more stable to force to evaluate @mf <*> ma@ --- from left to right, for the sake of printing --- debug messages in order. -apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b -apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e -> - let g = f e - a = x e - in g `pseq` a `pseq` g a -{-# INLINE apReduce #-} - --- Andreas, 2021-05-12, issue #5379 --- Since the MonadDebug instance of ReduceM is implemented via --- unsafePerformIO, we need to force results that later --- computations do not depend on, otherwise we lose debug messages. -thenReduce :: ReduceM a -> ReduceM b -> ReduceM b -thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e -{-# INLINE thenReduce #-} - --- Andreas, 2021-05-14: --- `seq` does not force evaluation order, the optimizier is allowed to replace --- @ --- a `seq` b` --- @ --- by: --- @ --- b `seq` a `seq` b --- @ --- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html --- --- In contrast, `pseq` is only strict in its first argument, so such a permutation --- is forbidden. --- If we want to ensure that debug messages are printed before exceptions are --- propagated, we need to use `pseq`, as in: --- @ --- unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG --- @ -beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a -beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> - let a = x e - in a `pseq` y e `pseq` a -{-# INLINE beforeReduce #-} - -bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b -bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e -{-# INLINE bindReduce #-} - -instance Functor ReduceM where - fmap = fmapReduce - -instance Applicative ReduceM where - pure x = ReduceM (const x) - (<*>) = apReduce - (*>) = thenReduce - (<*) = beforeReduce - -instance Monad ReduceM where - return = pure - (>>=) = bindReduce - (>>) = (*>) -#if __GLASGOW_HASKELL__ < 808 - fail = Fail.fail -#endif - -instance Fail.MonadFail ReduceM where - fail = error - -instance ReadTCState ReduceM where - getTCState = ReduceM redSt - locallyTCState l f = onReduceEnv $ mapRedSt $ over l f - -runReduceM :: ReduceM a -> TCM a -runReduceM m = TCM $ \ r e -> do - s <- readIORef r - E.evaluate $ unReduceM m $ ReduceEnv e s - -- Andreas, 2021-05-13, issue #5379 - -- This was the following, which is apparently not strict enough - -- to force all unsafePerformIOs... - -- runReduceM m = do - -- e <- askTC - -- s <- getTC - -- return $! unReduceM m (ReduceEnv e s) - -runReduceF :: (a -> ReduceM b) -> TCM (a -> b) -runReduceF f = do - e <- askTC - s <- getTC - return $ \x -> unReduceM (f x) (ReduceEnv e s) - -instance MonadTCEnv ReduceM where - askTC = ReduceM redEnv - localTC = onReduceEnv . mapRedEnv - --- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084): --- --- useR forces the result of projecting the lens, --- this usually prevents retaining the whole structure when we only need a field. --- --- This fixes (or contributes to the fix of) the space leak issue #1829 (caching). -useR :: (ReadTCState m) => Lens' a TCState -> m a -useR l = do - !x <- (^.l) <$> getTCState - return x - -askR :: ReduceM ReduceEnv -askR = ReduceM ask - -localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a -localR f = ReduceM . local f . unReduceM - -instance HasOptions ReduceM where - pragmaOptions = useR stPragmaOptions - commandLineOptions = do - p <- useR stPragmaOptions - cl <- stPersistentOptions . stPersistentState <$> getTCState - return $ cl{ optPragmaOptions = p } - -class ( Applicative m - , MonadTCEnv m - , ReadTCState m - , HasOptions m - ) => MonadReduce m where - liftReduce :: ReduceM a -> m a - - default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a - liftReduce = lift . liftReduce - -instance MonadReduce ReduceM where - liftReduce = id - -instance MonadReduce m => MonadReduce (ChangeT m) -instance MonadReduce m => MonadReduce (ExceptT err m) -instance MonadReduce m => MonadReduce (IdentityT m) -instance MonadReduce m => MonadReduce (ListT m) -instance MonadReduce m => MonadReduce (MaybeT m) -instance MonadReduce m => MonadReduce (ReaderT r m) -instance MonadReduce m => MonadReduce (StateT w m) -instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m) -instance MonadReduce m => MonadReduce (BlockT m) - ---------------------------------------------------------------------------- --- * Monad with read-only 'TCEnv' ---------------------------------------------------------------------------- - --- | @MonadTCEnv@ made into its own dedicated service class. --- This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@. -class Monad m => MonadTCEnv m where - askTC :: m TCEnv - localTC :: (TCEnv -> TCEnv) -> m a -> m a - - default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv - askTC = lift askTC - - default localTC - :: (MonadTransControl t, MonadTCEnv n, t n ~ m) - => (TCEnv -> TCEnv) -> m a -> m a - localTC = liftThrough . localTC - -instance MonadTCEnv m => MonadTCEnv (ChangeT m) -instance MonadTCEnv m => MonadTCEnv (ExceptT err m) -instance MonadTCEnv m => MonadTCEnv (IdentityT m) -instance MonadTCEnv m => MonadTCEnv (MaybeT m) -instance MonadTCEnv m => MonadTCEnv (ReaderT r m) -instance MonadTCEnv m => MonadTCEnv (StateT s m) -instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m) - -instance MonadTCEnv m => MonadTCEnv (ListT m) where - localTC = mapListT . localTC - -asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a -asksTC f = f <$> askTC - -viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a -viewTC l = asksTC (^. l) - --- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation. -locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b -locallyTC l = localTC . over l - ---------------------------------------------------------------------------- --- * Monad with mutable 'TCState' ---------------------------------------------------------------------------- - --- | @MonadTCState@ made into its own dedicated service class. --- This allows us to use 'MonadState' for 'StateT' extensions of @TCM@. -class Monad m => MonadTCState m where - getTC :: m TCState - putTC :: TCState -> m () - modifyTC :: (TCState -> TCState) -> m () - - default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState - getTC = lift getTC - - default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m () - putTC = lift . putTC - - default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m () - modifyTC = lift . modifyTC - -instance MonadTCState m => MonadTCState (MaybeT m) -instance MonadTCState m => MonadTCState (ListT m) -instance MonadTCState m => MonadTCState (ExceptT err m) -instance MonadTCState m => MonadTCState (ReaderT r m) -instance MonadTCState m => MonadTCState (StateT s m) -instance MonadTCState m => MonadTCState (ChangeT m) -instance MonadTCState m => MonadTCState (IdentityT m) -instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m) - --- ** @TCState@ accessors (no lenses) - -getsTC :: ReadTCState m => (TCState -> a) -> m a -getsTC f = f <$> getTCState - --- | A variant of 'modifyTC' in which the computation is strict in the --- new state. -modifyTC' :: MonadTCState m => (TCState -> TCState) -> m () -modifyTC' f = do - s' <- getTC - putTC $! f s' - --- SEE TC.Monad.State --- -- | Restore the 'TCState' after computation. --- localTCState :: MonadTCState m => m a -> m a --- localTCState = bracket_ getTC putTC - --- ** @TCState@ accessors via lenses - -useTC :: ReadTCState m => Lens' a TCState -> m a -useTC l = do - !x <- getsTC (^. l) - return x - -infix 4 `setTCLens` - --- | Overwrite the part of the 'TCState' focused on by the lens. -setTCLens :: MonadTCState m => Lens' a TCState -> a -> m () -setTCLens l = modifyTC . set l - --- | Modify the part of the 'TCState' focused on by the lens. -modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m () -modifyTCLens l = modifyTC . over l - --- | Modify a part of the state monadically. -modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m () -modifyTCLensM l f = putTC =<< l f =<< getTC - --- | Modify the part of the 'TCState' focused on by the lens, and return some result. -stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r -stateTCLens l f = stateTCLensM l $ return . f - --- | Modify a part of the state monadically, and return some result. -stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r -stateTCLensM l f = do - s <- getTC - (result , x) <- f $ s ^. l - putTC $ set l x s - return result - - ---------------------------------------------------------------------------- --- ** Monad with capability to block a computation ---------------------------------------------------------------------------- - -class Monad m => MonadBlock m where - - -- | `patternViolation b` aborts the current computation - patternViolation :: Blocker -> m a - - default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a - patternViolation = lift . patternViolation - - -- | `catchPatternErr handle m` runs m, handling pattern violations - -- with `handle` (doesn't roll back the state) - catchPatternErr :: (Blocker -> m a) -> m a -> m a - -newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a } - deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2 - , MonadIO, Fail.MonadFail - , ReadTCState, HasOptions - , MonadTCEnv, MonadTCState, MonadTCM - ) - -instance Monad m => MonadBlock (BlockT m) where - patternViolation = BlockT . throwError - catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h) - -instance Monad m => MonadBlock (ExceptT TCErr m) where - patternViolation = throwError . PatternErr - catchPatternErr h f = catchError f $ \case - PatternErr b -> h b - err -> throwError err - -runBlocked :: Monad m => BlockT m a -> m (Either Blocker a) -runBlocked = runExceptT . unBlockT - -instance MonadBlock m => MonadBlock (MaybeT m) where - catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m - -instance MonadBlock m => MonadBlock (ReaderT e m) where - catchPatternErr h m = ReaderT $ \ e -> - let run = flip runReaderT e in catchPatternErr (run . h) (run m) - ---------------------------------------------------------------------------- --- * Type checking monad transformer ---------------------------------------------------------------------------- - --- | The type checking monad transformer. --- Adds readonly 'TCEnv' and mutable 'TCState'. -newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a } - --- | Type checking monad. -type TCM = TCMT IO - -{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-} -mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a -mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e) - -pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a -pureTCM f = TCM $ \ r e -> do - s <- liftIO $ readIORef r - return (f s e) - --- One goal of the definitions and pragmas below is to inline the --- monad operations as much as possible. This doesn't seem to have a --- large effect on the performance of the normal executable, but (at --- least on one machine/configuration) it has a massive effect on the --- performance of the profiling executable [1], and reduces the time --- attributed to bind from over 90% to about 25%. --- --- [1] When compiled with -auto-all and run with -p: roughly 750% --- faster for one example. - -returnTCMT :: Applicative m => a -> TCMT m a -returnTCMT = \x -> TCM $ \_ _ -> pure x -{-# INLINE returnTCMT #-} - -bindTCMT :: Monad m => TCMT m a -> (a -> TCMT m b) -> TCMT m b -bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e -{-# INLINE bindTCMT #-} - -thenTCMT :: Applicative m => TCMT m a -> TCMT m b -> TCMT m b -thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e *> m2 r e -{-# INLINE thenTCMT #-} - -instance Functor m => Functor (TCMT m) where - fmap = fmapTCMT - -fmapTCMT :: Functor m => (a -> b) -> TCMT m a -> TCMT m b -fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e) -{-# INLINE fmapTCMT #-} - -instance Applicative m => Applicative (TCMT m) where - pure = returnTCMT - (<*>) = apTCMT - -apTCMT :: Applicative m => TCMT m (a -> b) -> TCMT m a -> TCMT m b -apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> mf r e <*> m r e -{-# INLINE apTCMT #-} - -instance MonadTrans TCMT where - lift m = TCM $ \_ _ -> m - --- We want a special monad implementation of fail. -#if __GLASGOW_HASKELL__ < 808 -instance MonadIO m => Monad (TCMT m) where -#else --- Andreas, 2022-02-02, issue #5659: --- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here --- if we want @instance MonadTrans TCMT@. -instance Monad m => Monad (TCMT m) where -#endif - return = pure - (>>=) = bindTCMT - (>>) = (*>) -#if __GLASGOW_HASKELL__ < 808 - fail = Fail.fail -#endif - -instance MonadIO m => Fail.MonadFail (TCMT m) where - fail = internalError - -instance MonadIO m => MonadIO (TCMT m) where - liftIO m = TCM $ \ s env -> do - liftIO $ wrap s (envRange env) $ do - x <- m - x `seq` return x - where - wrap s r m = E.catch m $ \ err -> do - s <- readIORef s - E.throwIO $ IOException s r err - -instance MonadIO m => MonadTCEnv (TCMT m) where - askTC = TCM $ \ _ e -> return e - localTC f (TCM m) = TCM $ \ s e -> m s (f e) - -instance MonadIO m => MonadTCState (TCMT m) where - getTC = TCM $ \ r _e -> liftIO (readIORef r) - putTC s = TCM $ \ r _e -> liftIO (writeIORef r s) - modifyTC f = putTC . f =<< getTC - -instance MonadIO m => ReadTCState (TCMT m) where - getTCState = getTC - locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l) - -instance MonadBlock TCM where - patternViolation b = throwError (PatternErr b) - catchPatternErr handle v = - catchError_ v $ \err -> - case err of - -- Not putting s (which should really be the what's already there) makes things go - -- a lot slower (+20% total time on standard library). How is that possible?? - -- The problem is most likely that there are internal catchErrors which forgets the - -- state. catchError should preserve the state on pattern violations. - PatternErr u -> handle u - _ -> throwError err - - -instance MonadError TCErr TCM where - throwError = liftIO . E.throwIO - catchError m h = TCM $ \ r e -> do -- now we are in the IO monad - oldState <- readIORef r - unTCM m r e `E.catch` \err -> do - -- Reset the state, but do not forget changes to the persistent - -- component. Not for pattern violations. - case err of - PatternErr{} -> return () - _ -> - liftIO $ do - newState <- readIORef r - writeIORef r $ oldState { stPersistentState = stPersistentState newState } - unTCM (h err) r e - --- | Like 'catchError', but resets the state completely before running the handler. --- This means it also loses changes to the 'stPersistentState'. --- --- The intended use is to catch internal errors during debug printing. --- In debug printing, we are not expecting state changes. -instance CatchImpossible TCM where - catchImpossibleJust f m h = TCM $ \ r e -> do - -- save the state - s <- readIORef r - catchImpossibleJust f (unTCM m r e) $ \ err -> do - writeIORef r s - unTCM (h err) r e - -instance MonadIO m => MonadReduce (TCMT m) where - liftReduce = liftTCM . runReduceM - -instance (IsString a, MonadIO m) => IsString (TCMT m a) where - fromString s = return (fromString s) - --- | Strict (non-shortcut) semigroup. --- --- Note that there might be a lazy alternative, e.g., --- for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation, --- to shortcut conjunction in case we already have 'False'. --- -instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where - (<>) = liftA2 (<>) - --- | Strict (non-shortcut) monoid. -instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where - mempty = pure mempty - mappend = (<>) - mconcat = mconcat <.> sequence - -instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where - empty = return empty - null = __IMPOSSIBLE__ - --- | Preserve the state of the failing computation. -catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a -catchError_ m h = TCM $ \r e -> - unTCM m r e - `E.catch` \err -> unTCM (h err) r e - --- | Execute a finalizer even when an exception is thrown. --- Does not catch any errors. --- In case both the regular computation and the finalizer --- throw an exception, the one of the finalizer is propagated. -finally_ :: TCM a -> TCM b -> TCM a -finally_ m f = do - x <- m `catchError_` \ err -> f >> throwError err - _ <- f - return x - --- | Embedding a TCM computation. - -class ( Applicative tcm, MonadIO tcm - , MonadTCEnv tcm - , MonadTCState tcm - , HasOptions tcm - ) => MonadTCM tcm where - liftTCM :: TCM a -> tcm a - - default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a - liftTCM = lift . liftTCM - -{-# RULES "liftTCM/id" liftTCM = id #-} -instance MonadIO m => MonadTCM (TCMT m) where - liftTCM = mapTCMT liftIO - -instance MonadTCM tcm => MonadTCM (ChangeT tcm) -instance MonadTCM tcm => MonadTCM (ExceptT err tcm) -instance MonadTCM tcm => MonadTCM (IdentityT tcm) -instance MonadTCM tcm => MonadTCM (ListT tcm) -instance MonadTCM tcm => MonadTCM (MaybeT tcm) -instance MonadTCM tcm => MonadTCM (ReaderT r tcm) -instance MonadTCM tcm => MonadTCM (StateT s tcm) -instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm) - --- | We store benchmark statistics in an IORef. --- This enables benchmarking pure computation, see --- "Agda.Benchmarking". -instance MonadBench TCM where - type BenchPhase TCM = Phase - getBenchmark = liftIO $ getBenchmark - putBenchmark = liftIO . putBenchmark - finally = finally_ - -instance Null (TCM Doc) where - empty = return empty - null = __IMPOSSIBLE__ - -internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a -internalError s = withCallerCallStack $ \ loc -> - liftTCM $ typeError' loc $ InternalError s - --- | The constraints needed for 'typeError' and similar. -type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m) - --- | Utility function for 1-arg constructed type errors. --- Note that the @HasCallStack@ constraint is on the *resulting* function. -locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b) -locatedTypeError f e = withCallerCallStack (flip typeError' (f e)) - -genericError :: (HasCallStack, MonadTCError m) => String -> m a -genericError = locatedTypeError GenericError - -{-# SPECIALIZE genericDocError :: Doc -> TCM a #-} -genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a -genericDocError = locatedTypeError GenericDocError - -{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-} -typeError' :: MonadTCError m => CallStack -> TypeError -> m a -typeError' loc err = throwError =<< typeError'_ loc err - -{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-} -typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a -typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err - -{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-} -typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr -typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err - -{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-} -typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr -typeError_ = withCallerCallStack . flip typeError'_ - --- | Running the type checking monad (most general form). -{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-} -runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState) -runTCM e s m = do - r <- liftIO $ newIORef s - a <- unTCM m r e - s <- liftIO $ readIORef r - return (a, s) - --- | Running the type checking monad on toplevel (with initial state). -runTCMTop :: TCM a -> IO (Either TCErr a) -runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left) - -runTCMTop' :: MonadIO m => TCMT m a -> m a -runTCMTop' m = do - r <- liftIO $ newIORef initState - unTCM m r initEnv - --- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which --- cannot fail, except that it might raise 'IOException's) in the --- initial environment. - -runSafeTCM :: TCM a -> TCState -> IO (a, TCState) -runSafeTCM m st = - runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of - IOException _ _ err -> E.throwIO err - _ -> __IMPOSSIBLE__ - --- | Runs the given computation in a separate thread, with /a copy/ of --- the current state and environment. --- --- Note that Agda sometimes uses actual, mutable state. If the --- computation given to @forkTCM@ tries to /modify/ this state, then --- bad things can happen, because accesses are not mutually exclusive. --- The @forkTCM@ function has been added mainly to allow the thread to --- /read/ (a snapshot of) the current state in a convenient way. --- --- Note also that exceptions which are raised in the thread are not --- propagated to the parent, so the thread should not do anything --- important. - -forkTCM :: TCM a -> TCM () -forkTCM m = do - s <- getTC - e <- askTC - liftIO $ void $ C.forkIO $ void $ runTCM e s m - ---------------------------------------------------------------------------- --- * Names for generated definitions ---------------------------------------------------------------------------- - --- | Base name for patterns in telescopes -patternInTeleName :: String -patternInTeleName = ".patternInTele" - --- | Base name for extended lambda patterns -extendedLambdaName :: String -extendedLambdaName = ".extendedlambda" - --- | Check whether we have an definition from an extended lambda. -isExtendedLambdaName :: A.QName -> Bool -isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName - --- | Name of absurdLambda definitions. -absurdLambdaName :: String -absurdLambdaName = ".absurdlambda" - --- | Check whether we have an definition from an absurd lambda. -isAbsurdLambdaName :: QName -> Bool -isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName - --- | Base name for generalized variable projections -generalizedFieldName :: String -generalizedFieldName = ".generalizedField-" - --- | Check whether we have a generalized variable field -getGeneralizedFieldName :: A.QName -> Maybe String -getGeneralizedFieldName q - | generalizedFieldName `List.isPrefixOf` strName = Just (drop (length generalizedFieldName) strName) - | otherwise = Nothing - where strName = prettyShow $ nameConcrete $ qnameName q - ---------------------------------------------------------------------------- --- * KillRange instances ---------------------------------------------------------------------------- - -instance KillRange Signature where - killRange (Sig secs defs rews) = killRange2 Sig secs defs rews - -instance KillRange Sections where - killRange = fmap killRange - -instance KillRange Definitions where - killRange = fmap killRange - -instance KillRange RewriteRuleMap where - killRange = fmap killRange - -instance KillRange Section where - killRange (Section tel) = killRange1 Section tel - -instance KillRange Definition where - killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def) = - killRange19 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def - -- TODO clarify: Keep the range in the defName field? - -instance KillRange NumGeneralizableArgs where - killRange = id - -instance KillRange NLPat where - killRange (PVar x y) = killRange2 PVar x y - killRange (PDef x y) = killRange2 PDef x y - killRange (PLam x y) = killRange2 PLam x y - killRange (PPi x y) = killRange2 PPi x y - killRange (PSort x) = killRange1 PSort x - killRange (PBoundVar x y) = killRange2 PBoundVar x y - killRange (PTerm x) = killRange1 PTerm x - -instance KillRange NLPType where - killRange (NLPType s a) = killRange2 NLPType s a - -instance KillRange NLPSort where - killRange (PType l) = killRange1 PType l - killRange (PProp l) = killRange1 PProp l - killRange s@(PInf f n) = s - killRange PSizeUniv = PSizeUniv - killRange PLockUniv = PLockUniv - -instance KillRange RewriteRule where - killRange (RewriteRule q gamma f es rhs t c) = - killRange6 RewriteRule q gamma f es rhs t c - -instance KillRange CompiledRepresentation where - killRange = id - - -instance KillRange EtaEquality where - killRange = id - -instance KillRange System where - killRange (System tel sys) = System (killRange tel) (killRange sys) - -instance KillRange ExtLamInfo where - killRange (ExtLamInfo m b sys) = killRange3 ExtLamInfo m b sys - -instance KillRange FunctionFlag where - killRange = id - -instance KillRange CompKit where - killRange = id - -instance KillRange Defn where - killRange def = - case def of - Axiom a -> Axiom a - DataOrRecSig n -> DataOrRecSig n - GeneralizableVar -> GeneralizableVar - AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'! - Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with -> - killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with - Datatype a b c d e f g h -> killRange7 Datatype a b c d e f g h - Record a b c d e f g h i j k l -> killRange12 Record a b c d e f g h i j k l - Constructor a b c d e f g h i j-> killRange10 Constructor a b c d e f g h i j - Primitive a b c d e -> killRange5 Primitive a b c d e - PrimitiveSort a b -> killRange2 PrimitiveSort a b - -instance KillRange MutualId where - killRange = id - -instance KillRange c => KillRange (FunctionInverse' c) where - killRange NotInjective = NotInjective - killRange (Inverse m) = Inverse $ killRangeMap m - -instance KillRange TermHead where - killRange SortHead = SortHead - killRange PiHead = PiHead - killRange (ConsHead q) = ConsHead $ killRange q - killRange h@VarHead{} = h - killRange UnknownHead = UnknownHead - -instance KillRange Projection where - killRange (Projection a b c d e) = killRange5 Projection a b c d e - -instance KillRange ProjLams where - killRange = id - -instance KillRange a => KillRange (Open a) where - killRange = fmap killRange - -instance KillRange DisplayForm where - killRange (Display n es dt) = killRange3 Display n es dt - -instance KillRange Polarity where - killRange = id - -instance KillRange IsForced where - killRange = id - -instance KillRange DoGeneralize where - killRange = id - -instance KillRange DisplayTerm where - killRange dt = - case dt of - DWithApp dt dts es -> killRange3 DWithApp dt dts es - DCon q ci dts -> killRange3 DCon q ci dts - DDef q dts -> killRange2 DDef q dts - DDot v -> killRange1 DDot v - DTerm v -> killRange1 DTerm v - -instance KillRange a => KillRange (Closure a) where - killRange = id - ---------------------------------------------------------------------------- --- NFData instances ---------------------------------------------------------------------------- - -instance NFData NumGeneralizableArgs where - rnf NoGeneralizableArgs = () - rnf (SomeGeneralizableArgs _) = () - -instance NFData TCErr where - rnf (TypeError a b c) = rnf a `seq` rnf b `seq` rnf c - rnf (Exception a b) = rnf a `seq` rnf b - rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c) - -- At the time of writing there is no - -- NFData instance for E.IOException. - rnf (PatternErr a) = rnf a - --- | This instance could be optimised, some things are guaranteed to --- be forced. - -instance NFData PreScopeState - --- | This instance could be optimised, some things are guaranteed to --- be forced. - -instance NFData PostScopeState - -instance NFData TCState -instance NFData DisambiguatedName -instance NFData MutualBlock -instance NFData PersistentTCState -instance NFData LoadedFileCache -instance NFData TypeCheckAction -instance NFData ModuleCheckMode -instance NFData ModuleInfo -instance NFData ForeignCode -instance NFData Interface -instance NFData a => NFData (Closure a) -instance NFData ProblemConstraint -instance NFData Constraint -instance NFData Signature -instance NFData Comparison -instance NFData CompareAs -instance NFData a => NFData (Open a) -instance NFData a => NFData (Judgement a) -instance NFData DoGeneralize -instance NFData GeneralizedValue -instance NFData MetaVariable -instance NFData Listener -instance NFData MetaInstantiation -instance NFData Frozen -instance NFData PrincipalArgTypeMetas -instance NFData TypeCheckingProblem -instance NFData RunMetaOccursCheck -instance NFData MetaInfo -instance NFData InteractionPoint -instance NFData InteractionPoints -instance NFData Overapplied -instance NFData t => NFData (IPBoundary' t) -instance NFData IPClause -instance NFData DisplayForm -instance NFData DisplayTerm -instance NFData NLPat -instance NFData NLPType -instance NFData NLPSort -instance NFData RewriteRule -instance NFData Definition -instance NFData Polarity -instance NFData IsForced -instance NFData Projection -instance NFData ProjLams -instance NFData CompilerPragma -instance NFData System -instance NFData ExtLamInfo -instance NFData EtaEquality -instance NFData FunctionFlag -instance NFData CompKit +{-# LANGUAGE RecursiveDo #-} +-- {-# LANGUAGE UndecidableInstances #-} -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT + +module Agda.TypeChecking.Monad.Base + ( module Agda.TypeChecking.Monad.Base + , HasOptions (..) + ) where + +import Prelude hiding (null) + +import Control.Applicative hiding (empty) +import qualified Control.Concurrent as C +import Control.DeepSeq +import qualified Control.Exception as E + +import qualified Control.Monad.Fail as Fail + +import Control.Monad ( void ) +import Control.Monad.Except +import Control.Monad.Fix +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.State ( MonadState(..), modify, StateT(..), runStateT ) +import Control.Monad.Reader ( MonadReader(..), ReaderT(..), runReaderT ) +import Control.Monad.Writer ( WriterT ) +import Control.Monad.Trans ( MonadTrans(..), lift ) +import Control.Monad.Trans.Control ( MonadTransControl(..), liftThrough ) +import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT ) +import Control.Monad.Trans.Maybe ( MaybeT(..) ) + +import Control.Parallel ( pseq ) + +import Data.Array (Ix) +import Data.DList (DList) +import Data.Function (on) +import Data.Int +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.List as List +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map -- hiding (singleton, null, empty) +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Data.Set as Set -- hiding (singleton, null, empty) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMap +import Data.HashSet (HashSet) +import Data.Semigroup ( Semigroup, (<>)) --, Any(..) ) +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import Data.IORef + +import GHC.Generics (Generic) + +import Agda.Benchmarking (Benchmark, Phase) + +import Agda.Syntax.Common +import qualified Agda.Syntax.Concrete as C +import Agda.Syntax.Concrete.Definitions + (NiceDeclaration, DeclarationWarning, dwWarning, declarationWarningName) +import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Internal as I +import Agda.Syntax.Internal.MetaVars +import Agda.Syntax.Internal.Generic (TermLike(..)) +import Agda.Syntax.Parser (ParseWarning) +import Agda.Syntax.Parser.Monad (parseWarningName) +import Agda.Syntax.TopLevelModuleName + (RawTopLevelModuleName, TopLevelModuleName) +import Agda.Syntax.Treeless (Compiled) +import Agda.Syntax.Notation +import Agda.Syntax.Position +import Agda.Syntax.Scope.Base +import qualified Agda.Syntax.Info as Info + +import Agda.TypeChecking.CompiledClause +import Agda.TypeChecking.Coverage.SplitTree +import Agda.TypeChecking.Positivity.Occurrence +import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder) + +-- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend +-- conflicts with Args, defined in Agda.Syntax.Internal and also imported here. +-- This only matters when interpreted in ghci, which sees all of the module's +-- exported symbols, not just the ones defined in the `.hs-boot`. See the +-- comment in ../../Compiler/Backend.hs-boot +import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args) + +import Agda.Interaction.Options +import Agda.Interaction.Options.Warnings +import {-# SOURCE #-} Agda.Interaction.Response + (InteractionOutputCallback, defaultInteractionOutputCallback) +import Agda.Interaction.Highlighting.Precise + (HighlightingInfo, NameKind) +import Agda.Interaction.Library + +import Agda.Utils.Benchmark (MonadBench(..)) +import Agda.Utils.BiMap (BiMap, HasTag(..)) +import qualified Agda.Utils.BiMap as BiMap +import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack ) +import Agda.Utils.FileName +import Agda.Utils.Functor +import Agda.Utils.Hash +import Agda.Utils.Lens +import Agda.Utils.List +import Agda.Utils.ListT +import Agda.Utils.List1 (List1, pattern (:|)) +import Agda.Utils.List2 (List2, pattern List2) +import qualified Agda.Utils.List1 as List1 +import qualified Agda.Utils.Maybe.Strict as Strict +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.Permutation +import Agda.Utils.Pretty +import Agda.Utils.Singleton +import Agda.Utils.SmallSet (SmallSet) +import qualified Agda.Utils.SmallSet as SmallSet +import Agda.Utils.Update +import Agda.Utils.WithDefault ( collapseDefault ) + +import Agda.Utils.Impossible + +--------------------------------------------------------------------------- +-- * Type checking state +--------------------------------------------------------------------------- + +data TCState = TCSt + { stPreScopeState :: !PreScopeState + -- ^ The state which is frozen after scope checking. + , stPostScopeState :: !PostScopeState + -- ^ The state which is modified after scope checking. + , stPersistentState :: !PersistentTCState + -- ^ State which is forever, like a diamond. + } + deriving Generic + +class Monad m => ReadTCState m where + getTCState :: m TCState + locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b + + withTCState :: (TCState -> TCState) -> m a -> m a + withTCState = locallyTCState id + + default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState + getTCState = lift getTCState + + default locallyTCState + :: (MonadTransControl t, ReadTCState n, t n ~ m) + => Lens' a TCState -> (a -> a) -> m b -> m b + locallyTCState l = liftThrough . locallyTCState l + +instance ReadTCState m => ReadTCState (ListT m) where + locallyTCState l = mapListT . locallyTCState l + +instance ReadTCState m => ReadTCState (ChangeT m) +instance ReadTCState m => ReadTCState (ExceptT err m) +instance ReadTCState m => ReadTCState (IdentityT m) +instance ReadTCState m => ReadTCState (MaybeT m) +instance ReadTCState m => ReadTCState (ReaderT r m) +instance ReadTCState m => ReadTCState (StateT s m) +instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m) + + +instance Show TCState where + show _ = "TCSt{}" + +data PreScopeState = PreScopeState + { stPreTokens :: !HighlightingInfo + -- ^ Highlighting info for tokens and Happy parser warnings (but + -- not for those tokens/warnings for which highlighting exists in + -- 'stPostSyntaxInfo'). + , stPreImports :: !Signature -- XX populated by scope checker + -- ^ Imported declared identifiers. + -- Those most not be serialized! + , stPreImportedModules :: !(HashSet TopLevelModuleName) + -- ^ The top-level modules imported by the current module. + , stPreModuleToSource :: !ModuleToSource -- imports + , stPreVisitedModules :: !VisitedModules -- imports + , stPreScope :: !ScopeInfo + -- generated by scope checker, current file: + -- which modules you have, public definitions, current file, maps concrete names to abstract names. + , stPrePatternSyns :: !A.PatternSynDefns + -- ^ Pattern synonyms of the current file. Serialized. + , stPrePatternSynImports :: !A.PatternSynDefns + -- ^ Imported pattern synonyms. Must not be serialized! + , stPreGeneralizedVars :: !(Strict.Maybe (Set QName)) + -- ^ Collected generalizable variables; used during scope checking of terms + , stPrePragmaOptions :: !PragmaOptions + -- ^ Options applying to the current file. @OPTIONS@ + -- pragmas only affect this field. + , stPreImportedBuiltins :: !(BuiltinThings PrimFun) + , stPreImportedDisplayForms :: !DisplayForms + -- ^ Display forms added by someone else to imported identifiers + , stPreImportedInstanceDefs :: !InstanceTable + , stPreForeignCode :: !(Map BackendName [ForeignCode]) + -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output. + -- Does not include code for imported modules. + , stPreFreshInteractionId :: !InteractionId + , stPreImportedUserWarnings :: !(Map A.QName Text) + -- ^ Imported @UserWarning@s, not to be stored in the @Interface@ + , stPreLocalUserWarnings :: !(Map A.QName Text) + -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@ + , stPreWarningOnImport :: !(Strict.Maybe Text) + -- ^ Whether the current module should raise a warning when opened + , stPreImportedPartialDefs :: !(Set QName) + -- ^ Imported partial definitions, not to be stored in the @Interface@ + , stPreProjectConfigs :: !(Map FilePath ProjectConfig) + -- ^ Map from directories to paths of closest enclosing .agda-lib + -- files (or @Nothing@ if there are none). + , stPreAgdaLibFiles :: !(Map FilePath AgdaLibFile) + -- ^ Contents of .agda-lib files that have already been parsed. + , stPreImportedMetaStore :: !RemoteMetaStore + -- ^ Used for meta-variables from other modules. + } + deriving Generic + +-- | Name disambiguation for the sake of highlighting. +data DisambiguatedName = DisambiguatedName NameKind A.QName + deriving Generic +type DisambiguatedNames = IntMap DisambiguatedName + +type ConcreteNames = Map Name [C.Name] + +data PostScopeState = PostScopeState + { stPostSyntaxInfo :: !HighlightingInfo + -- ^ Highlighting info. + , stPostDisambiguatedNames :: !DisambiguatedNames + -- ^ Disambiguation carried out by the type checker. + -- Maps position of first name character to disambiguated @'A.QName'@ + -- for each @'A.AmbiguousQName'@ already passed by the type checker. + , stPostOpenMetaStore :: !LocalMetaStore + -- ^ Used for open meta-variables. + , stPostSolvedMetaStore :: !LocalMetaStore + -- ^ Used for local, instantiated meta-variables. + , stPostInteractionPoints :: !InteractionPoints -- scope checker first + , stPostAwakeConstraints :: !Constraints + , stPostSleepingConstraints :: !Constraints + , stPostDirty :: !Bool -- local + -- ^ Dirty when a constraint is added, used to prevent pointer update. + -- Currently unused. + , stPostOccursCheckDefs :: !(Set QName) -- local + -- ^ Definitions to be considered during occurs check. + -- Initialized to the current mutual block before the check. + -- During occurs check, we remove definitions from this set + -- as soon we have checked them. + , stPostSignature :: !Signature + -- ^ Declared identifiers of the current file. + -- These will be serialized after successful type checking. + , stPostModuleCheckpoints :: !(Map ModuleName CheckpointId) + -- ^ For each module remember the checkpoint corresponding to the orignal + -- context of the module parameters. + , stPostImportsDisplayForms :: !DisplayForms + -- ^ Display forms we add for imported identifiers + , stPostCurrentModule :: + !(Maybe (ModuleName, TopLevelModuleName)) + -- ^ The current module is available after it has been type + -- checked. + , stPostInstanceDefs :: !TempInstanceTable + , stPostConcreteNames :: !ConcreteNames + -- ^ Map keeping track of concrete names assigned to each abstract name + -- (can be more than one name in case the first one is shadowed) + , stPostUsedNames :: !(Map RawName (DList RawName)) + -- ^ Map keeping track for each name root (= name w/o numeric + -- suffixes) what names with the same root have been used during a + -- TC computation. This information is used to build the + -- @ShadowingNames@ map. + , stPostShadowingNames :: !(Map Name (DList RawName)) + -- ^ Map keeping track for each (abstract) name the list of all + -- (raw) names that it could maybe be shadowed by. + , stPostStatistics :: !Statistics + -- ^ Counters to collect various statistics about meta variables etc. + -- Only for current file. + , stPostTCWarnings :: ![TCWarning] + , stPostMutualBlocks :: !(Map MutualId MutualBlock) + , stPostLocalBuiltins :: !(BuiltinThings PrimFun) + , stPostFreshMetaId :: !MetaId + , stPostFreshMutualId :: !MutualId + , stPostFreshProblemId :: !ProblemId + , stPostFreshCheckpointId :: !CheckpointId + , stPostFreshInt :: !Int + , stPostFreshNameId :: !NameId + , stPostAreWeCaching :: !Bool + , stPostPostponeInstanceSearch :: !Bool + , stPostConsideringInstance :: !Bool + , stPostInstantiateBlocking :: !Bool + -- ^ Should we instantiate away blocking metas? + -- This can produce ill-typed terms but they are often more readable. See issue #3606. + -- Best set to True only for calls to pretty*/reify to limit unwanted reductions. + , stPostLocalPartialDefs :: !(Set QName) + -- ^ Local partial definitions, to be stored in the @Interface@ + } + deriving (Generic) + +-- | A mutual block of names in the signature. +data MutualBlock = MutualBlock + { mutualInfo :: Info.MutualInfo + -- ^ The original info of the mutual block. + , mutualNames :: Set QName + } deriving (Show, Eq, Generic) + +instance Null MutualBlock where + empty = MutualBlock empty empty + +-- | A part of the state which is not reverted when an error is thrown +-- or the state is reset. +data PersistentTCState = PersistentTCSt + { stDecodedModules :: !DecodedModules + , stPersistentTopLevelModuleNames :: + !(BiMap RawTopLevelModuleName ModuleNameHash) + -- ^ Module name hashes for top-level module names (and vice + -- versa). + , stPersistentOptions :: CommandLineOptions + , stInteractionOutputCallback :: InteractionOutputCallback + -- ^ Callback function to call when there is a response + -- to give to the interactive frontend. + -- See the documentation of 'InteractionOutputCallback'. + , stBenchmark :: !Benchmark + -- ^ Structure to track how much CPU time was spent on which Agda phase. + -- Needs to be a strict field to avoid space leaks! + , stAccumStatistics :: !Statistics + -- ^ Should be strict field. + , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache) + -- ^ Cached typechecking state from the last loaded file. + -- Should be @Nothing@ when checking imports. + , stPersistBackends :: [Backend] + -- ^ Current backends with their options + } + deriving Generic + +data LoadedFileCache = LoadedFileCache + { lfcCached :: !CachedTypeCheckLog + , lfcCurrent :: !CurrentTypeCheckLog + } + deriving Generic + +-- | A log of what the type checker does and states after the action is +-- completed. The cached version is stored first executed action first. +type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)] + +-- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type +-- checking of a module. Stored in reverse order (last performed action +-- first). +type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)] + +-- | A complete log for a module will look like this: +-- +-- * 'Pragmas' +-- +-- * 'EnterSection', entering the main module. +-- +-- * 'Decl'/'EnterSection'/'LeaveSection', for declarations and nested +-- modules +-- +-- * 'LeaveSection', leaving the main module. +data TypeCheckAction + = EnterSection !ModuleName !A.Telescope + | LeaveSection !ModuleName + | Decl !A.Declaration + -- ^ Never a Section or ScopeDecl + | Pragmas !PragmaOptions + deriving (Generic) + +-- | Empty persistent state. + +initPersistentState :: PersistentTCState +initPersistentState = PersistentTCSt + { stPersistentOptions = defaultOptions + , stPersistentTopLevelModuleNames = empty + , stDecodedModules = Map.empty + , stInteractionOutputCallback = defaultInteractionOutputCallback + , stBenchmark = empty + , stAccumStatistics = Map.empty + , stPersistLoadedFileCache = empty + , stPersistBackends = [] + } + +-- | An initial 'MetaId'. + +initialMetaId :: MetaId +initialMetaId = MetaId + { metaId = 0 + , metaModule = noModuleNameHash + } + +-- | Empty state of type checker. + +initPreScopeState :: PreScopeState +initPreScopeState = PreScopeState + { stPreTokens = mempty + , stPreImports = emptySignature + , stPreImportedModules = empty + , stPreModuleToSource = Map.empty + , stPreVisitedModules = Map.empty + , stPreScope = emptyScopeInfo + , stPrePatternSyns = Map.empty + , stPrePatternSynImports = Map.empty + , stPreGeneralizedVars = mempty + , stPrePragmaOptions = defaultInteractionOptions + , stPreImportedBuiltins = Map.empty + , stPreImportedDisplayForms = HMap.empty + , stPreImportedInstanceDefs = Map.empty + , stPreForeignCode = Map.empty + , stPreFreshInteractionId = 0 + , stPreImportedUserWarnings = Map.empty + , stPreLocalUserWarnings = Map.empty + , stPreWarningOnImport = empty + , stPreImportedPartialDefs = Set.empty + , stPreProjectConfigs = Map.empty + , stPreAgdaLibFiles = Map.empty + , stPreImportedMetaStore = HMap.empty + } + +initPostScopeState :: PostScopeState +initPostScopeState = PostScopeState + { stPostSyntaxInfo = mempty + , stPostDisambiguatedNames = IntMap.empty + , stPostOpenMetaStore = Map.empty + , stPostSolvedMetaStore = Map.empty + , stPostInteractionPoints = empty + , stPostAwakeConstraints = [] + , stPostSleepingConstraints = [] + , stPostDirty = False + , stPostOccursCheckDefs = Set.empty + , stPostSignature = emptySignature + , stPostModuleCheckpoints = Map.empty + , stPostImportsDisplayForms = HMap.empty + , stPostCurrentModule = empty + , stPostInstanceDefs = (Map.empty , Set.empty) + , stPostConcreteNames = Map.empty + , stPostUsedNames = Map.empty + , stPostShadowingNames = Map.empty + , stPostStatistics = Map.empty + , stPostTCWarnings = [] + , stPostMutualBlocks = Map.empty + , stPostLocalBuiltins = Map.empty + , stPostFreshMetaId = initialMetaId + , stPostFreshMutualId = 0 + , stPostFreshProblemId = 1 + , stPostFreshCheckpointId = 1 + , stPostFreshInt = 0 + , stPostFreshNameId = NameId 0 noModuleNameHash + , stPostAreWeCaching = False + , stPostPostponeInstanceSearch = False + , stPostConsideringInstance = False + , stPostInstantiateBlocking = False + , stPostLocalPartialDefs = Set.empty + } + +initState :: TCState +initState = TCSt + { stPreScopeState = initPreScopeState + , stPostScopeState = initPostScopeState + , stPersistentState = initPersistentState + } + +-- * st-prefixed lenses +------------------------------------------------------------------------ + +stTokens :: Lens' HighlightingInfo TCState +stTokens f s = + f (stPreTokens (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}} + +stImports :: Lens' Signature TCState +stImports f s = + f (stPreImports (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}} + +stImportedModules :: + Lens' (HashSet TopLevelModuleName) TCState +stImportedModules f s = + f (stPreImportedModules (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}} + +stModuleToSource :: Lens' ModuleToSource TCState +stModuleToSource f s = + f (stPreModuleToSource (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}} + +stVisitedModules :: Lens' VisitedModules TCState +stVisitedModules f s = + f (stPreVisitedModules (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}} + +stScope :: Lens' ScopeInfo TCState +stScope f s = + f (stPreScope (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}} + +stPatternSyns :: Lens' A.PatternSynDefns TCState +stPatternSyns f s = + f (stPrePatternSyns (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}} + +stPatternSynImports :: Lens' A.PatternSynDefns TCState +stPatternSynImports f s = + f (stPrePatternSynImports (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}} + +stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState +stGeneralizedVars f s = + f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}} + +stPragmaOptions :: Lens' PragmaOptions TCState +stPragmaOptions f s = + f (stPrePragmaOptions (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}} + +stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState +stImportedBuiltins f s = + f (stPreImportedBuiltins (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}} + +stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState +stForeignCode f s = + f (stPreForeignCode (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}} + +stFreshInteractionId :: Lens' InteractionId TCState +stFreshInteractionId f s = + f (stPreFreshInteractionId (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}} + +stImportedUserWarnings :: Lens' (Map A.QName Text) TCState +stImportedUserWarnings f s = + f (stPreImportedUserWarnings (stPreScopeState s)) <&> + \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}} + +stLocalUserWarnings :: Lens' (Map A.QName Text) TCState +stLocalUserWarnings f s = + f (stPreLocalUserWarnings (stPreScopeState s)) <&> + \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}} + +getUserWarnings :: ReadTCState m => m (Map A.QName Text) +getUserWarnings = do + iuw <- useR stImportedUserWarnings + luw <- useR stLocalUserWarnings + return $ iuw `Map.union` luw + +stWarningOnImport :: Lens' (Maybe Text) TCState +stWarningOnImport f s = + f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&> + \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}} + +stImportedPartialDefs :: Lens' (Set QName) TCState +stImportedPartialDefs f s = + f (stPreImportedPartialDefs (stPreScopeState s)) <&> + \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}} + +stLocalPartialDefs :: Lens' (Set QName) TCState +stLocalPartialDefs f s = + f (stPostLocalPartialDefs (stPostScopeState s)) <&> + \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}} + +getPartialDefs :: ReadTCState m => m (Set QName) +getPartialDefs = do + ipd <- useR stImportedPartialDefs + lpd <- useR stLocalPartialDefs + return $ ipd `Set.union` lpd + +stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState +stLoadedFileCache f s = + f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&> + \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}} + +stBackends :: Lens' [Backend] TCState +stBackends f s = + f (stPersistBackends (stPersistentState s)) <&> + \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}} + +stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState +stProjectConfigs f s = + f (stPreProjectConfigs (stPreScopeState s)) <&> + \ x -> s {stPreScopeState = (stPreScopeState s) {stPreProjectConfigs = x}} + +stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState +stAgdaLibFiles f s = + f (stPreAgdaLibFiles (stPreScopeState s)) <&> + \ x -> s {stPreScopeState = (stPreScopeState s) {stPreAgdaLibFiles = x}} + +stTopLevelModuleNames :: + Lens' (BiMap RawTopLevelModuleName ModuleNameHash) TCState +stTopLevelModuleNames f s = + f (stPersistentTopLevelModuleNames (stPersistentState s)) <&> + \ x -> s {stPersistentState = + (stPersistentState s) {stPersistentTopLevelModuleNames = x}} + +stImportedMetaStore :: Lens' RemoteMetaStore TCState +stImportedMetaStore f s = + f (stPreImportedMetaStore (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedMetaStore = x}} + +stFreshNameId :: Lens' NameId TCState +stFreshNameId f s = + f (stPostFreshNameId (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}} + +stSyntaxInfo :: Lens' HighlightingInfo TCState +stSyntaxInfo f s = + f (stPostSyntaxInfo (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}} + +stDisambiguatedNames :: Lens' DisambiguatedNames TCState +stDisambiguatedNames f s = + f (stPostDisambiguatedNames (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}} + +stOpenMetaStore :: Lens' LocalMetaStore TCState +stOpenMetaStore f s = + f (stPostOpenMetaStore (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostOpenMetaStore = x}} + +stSolvedMetaStore :: Lens' LocalMetaStore TCState +stSolvedMetaStore f s = + f (stPostSolvedMetaStore (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostSolvedMetaStore = x}} + +stInteractionPoints :: Lens' InteractionPoints TCState +stInteractionPoints f s = + f (stPostInteractionPoints (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}} + +stAwakeConstraints :: Lens' Constraints TCState +stAwakeConstraints f s = + f (stPostAwakeConstraints (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}} + +stSleepingConstraints :: Lens' Constraints TCState +stSleepingConstraints f s = + f (stPostSleepingConstraints (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}} + +stDirty :: Lens' Bool TCState +stDirty f s = + f (stPostDirty (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}} + +stOccursCheckDefs :: Lens' (Set QName) TCState +stOccursCheckDefs f s = + f (stPostOccursCheckDefs (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}} + +stSignature :: Lens' Signature TCState +stSignature f s = + f (stPostSignature (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}} + +stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState +stModuleCheckpoints f s = + f (stPostModuleCheckpoints (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}} + +stImportsDisplayForms :: Lens' DisplayForms TCState +stImportsDisplayForms f s = + f (stPostImportsDisplayForms (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}} + +stImportedDisplayForms :: Lens' DisplayForms TCState +stImportedDisplayForms f s = + f (stPreImportedDisplayForms (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}} + +-- | Note that the lens is \"strict\". + +stCurrentModule :: + Lens' (Maybe (ModuleName, TopLevelModuleName)) TCState +stCurrentModule f s = + f (stPostCurrentModule (stPostScopeState s)) <&> + \x -> s {stPostScopeState = + (stPostScopeState s) + {stPostCurrentModule = case x of + Nothing -> Nothing + Just (!m, !top) -> Just (m, top)}} + +stImportedInstanceDefs :: Lens' InstanceTable TCState +stImportedInstanceDefs f s = + f (stPreImportedInstanceDefs (stPreScopeState s)) <&> + \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}} + +stInstanceDefs :: Lens' TempInstanceTable TCState +stInstanceDefs f s = + f (stPostInstanceDefs (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}} + +stConcreteNames :: Lens' ConcreteNames TCState +stConcreteNames f s = + f (stPostConcreteNames (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}} + +stUsedNames :: Lens' (Map RawName (DList RawName)) TCState +stUsedNames f s = + f (stPostUsedNames (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}} + +stShadowingNames :: Lens' (Map Name (DList RawName)) TCState +stShadowingNames f s = + f (stPostShadowingNames (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}} + +stStatistics :: Lens' Statistics TCState +stStatistics f s = + f (stPostStatistics (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}} + +stTCWarnings :: Lens' [TCWarning] TCState +stTCWarnings f s = + f (stPostTCWarnings (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}} + +stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState +stMutualBlocks f s = + f (stPostMutualBlocks (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}} + +stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState +stLocalBuiltins f s = + f (stPostLocalBuiltins (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}} + +stFreshMetaId :: Lens' MetaId TCState +stFreshMetaId f s = + f (stPostFreshMetaId (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}} + +stFreshMutualId :: Lens' MutualId TCState +stFreshMutualId f s = + f (stPostFreshMutualId (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}} + +stFreshProblemId :: Lens' ProblemId TCState +stFreshProblemId f s = + f (stPostFreshProblemId (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}} + +stFreshCheckpointId :: Lens' CheckpointId TCState +stFreshCheckpointId f s = + f (stPostFreshCheckpointId (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}} + +stFreshInt :: Lens' Int TCState +stFreshInt f s = + f (stPostFreshInt (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}} + +-- use @areWeCaching@ from the Caching module instead. +stAreWeCaching :: Lens' Bool TCState +stAreWeCaching f s = + f (stPostAreWeCaching (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}} + +stPostponeInstanceSearch :: Lens' Bool TCState +stPostponeInstanceSearch f s = + f (stPostPostponeInstanceSearch (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}} + +stConsideringInstance :: Lens' Bool TCState +stConsideringInstance f s = + f (stPostConsideringInstance (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}} + +stInstantiateBlocking :: Lens' Bool TCState +stInstantiateBlocking f s = + f (stPostInstantiateBlocking (stPostScopeState s)) <&> + \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}} + +stBuiltinThings :: TCState -> BuiltinThings PrimFun +stBuiltinThings s = Map.unionWith unionBuiltin (s^.stLocalBuiltins) (s^.stImportedBuiltins) + +-- | Union two 'Builtin's. Only defined for 'BuiltinRewriteRelations'. +unionBuiltin :: Builtin a -> Builtin a -> Builtin a +unionBuiltin = curry $ \case + (BuiltinRewriteRelations xs, BuiltinRewriteRelations ys) -> BuiltinRewriteRelations $ xs <> ys + _ -> __IMPOSSIBLE__ + + +-- * Fresh things +------------------------------------------------------------------------ + +class Enum i => HasFresh i where + freshLens :: Lens' i TCState + nextFresh' :: i -> i + nextFresh' = succ + +nextFresh :: HasFresh i => TCState -> (i, TCState) +nextFresh s = + let !c = s^.freshLens + in (c, set freshLens (nextFresh' c) s) + +class Monad m => MonadFresh i m where + fresh :: m i + + default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i + fresh = lift fresh + +instance MonadFresh i m => MonadFresh i (ReaderT r m) +instance MonadFresh i m => MonadFresh i (StateT s m) +instance MonadFresh i m => MonadFresh i (ListT m) +instance MonadFresh i m => MonadFresh i (IdentityT m) + +instance HasFresh i => MonadFresh i TCM where + fresh = do + !s <- getTC + let (!c , !s') = nextFresh s + putTC s' + return c + +instance HasFresh MetaId where + freshLens = stFreshMetaId + +instance HasFresh MutualId where + freshLens = stFreshMutualId + +instance HasFresh InteractionId where + freshLens = stFreshInteractionId + +instance HasFresh NameId where + freshLens = stFreshNameId + -- nextFresh increments the current fresh name by 2 so @NameId@s used + -- before caching starts do not overlap with the ones used after. + nextFresh' = succ . succ + +instance HasFresh Int where + freshLens = stFreshInt + +instance HasFresh ProblemId where + freshLens = stFreshProblemId + +newtype CheckpointId = CheckpointId Int + deriving (Eq, Ord, Enum, Real, Integral, Num, NFData) + +instance Show CheckpointId where + show (CheckpointId n) = show n + +instance Pretty CheckpointId where + pretty (CheckpointId n) = pretty n + +instance HasFresh CheckpointId where + freshLens = stFreshCheckpointId + +freshName :: MonadFresh NameId m => Range -> String -> m Name +freshName r s = do + i <- fresh + return $ mkName r i s + +freshNoName :: MonadFresh NameId m => Range -> m Name +freshNoName r = + do i <- fresh + return $ makeName i (C.NoName noRange i) r noFixity' False + +freshNoName_ :: MonadFresh NameId m => m Name +freshNoName_ = freshNoName noRange + +freshRecordName :: MonadFresh NameId m => m Name +freshRecordName = do + i <- fresh + return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True + +-- | Create a fresh name from @a@. +class FreshName a where + freshName_ :: MonadFresh NameId m => a -> m Name + +instance FreshName (Range, String) where + freshName_ = uncurry freshName + +instance FreshName String where + freshName_ = freshName noRange + +instance FreshName Range where + freshName_ = freshNoName + +instance FreshName () where + freshName_ () = freshNoName_ + +--------------------------------------------------------------------------- +-- ** Managing file names +--------------------------------------------------------------------------- + +-- | Maps top-level module names to the corresponding source file +-- names. + +type ModuleToSource = Map TopLevelModuleName AbsolutePath + +--------------------------------------------------------------------------- +-- ** Associating concrete names to an abstract name +--------------------------------------------------------------------------- + +-- | A monad that has read and write access to the stConcreteNames +-- part of the TCState. Basically, this is a synonym for `MonadState +-- ConcreteNames m` (which cannot be used directly because of the +-- limitations of Haskell's typeclass system). +class Monad m => MonadStConcreteNames m where + runStConcreteNames :: StateT ConcreteNames m a -> m a + + useConcreteNames :: m ConcreteNames + useConcreteNames = runStConcreteNames get + + modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m () + modifyConcreteNames = runStConcreteNames . modify + +instance MonadStConcreteNames TCM where + runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m + +instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where + runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m + +instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where + runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m) + +instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where + runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do + ((x,ns'),s') <- runStateT (runStateT m ns) s + return ((x,s'),ns') + +--------------------------------------------------------------------------- +-- ** Interface +--------------------------------------------------------------------------- + + +-- | Distinguishes between type-checked and scope-checked interfaces +-- when stored in the map of `VisitedModules`. +data ModuleCheckMode + = ModuleScopeChecked + | ModuleTypeChecked + deriving (Eq, Ord, Bounded, Enum, Show, Generic) + + +data ModuleInfo = ModuleInfo + { miInterface :: Interface + , miWarnings :: [TCWarning] + -- ^ Warnings were encountered when the module was type checked. + -- These might include warnings not stored in the interface itself, + -- specifically unsolved interaction metas. + -- See "Agda.Interaction.Imports" + , miPrimitive :: Bool + -- ^ 'True' if the module is a primitive module, which should always + -- be importable. + , miMode :: ModuleCheckMode + -- ^ The `ModuleCheckMode` used to create the `Interface` + } + deriving Generic + +type VisitedModules = Map TopLevelModuleName ModuleInfo +type DecodedModules = Map TopLevelModuleName ModuleInfo + +data ForeignCode = ForeignCode Range String + deriving (Show, Generic) + +data Interface = Interface + { iSourceHash :: Hash + -- ^ Hash of the source code. + , iSource :: TL.Text + -- ^ The source code. The source code is stored so that the HTML + -- and LaTeX backends can generate their output without having to + -- re-read the (possibly out of date) source code. + , iFileType :: FileType + -- ^ Source file type, determined from the file extension + , iImportedModules :: [(TopLevelModuleName, Hash)] + -- ^ Imported modules and their hashes. + , iModuleName :: ModuleName + -- ^ Module name of this interface. + , iTopLevelModuleName :: TopLevelModuleName + -- ^ The module's top-level module name. + , iScope :: Map ModuleName Scope + -- ^ Scope defined by this module. + -- + -- Andreas, AIM XX: Too avoid duplicate serialization, this field is + -- not serialized, so if you deserialize an interface, @iScope@ + -- will be empty. + -- But 'constructIScope' constructs 'iScope' from 'iInsideScope'. + , iInsideScope :: ScopeInfo + -- ^ Scope after we loaded this interface. + -- Used in 'Agda.Interaction.BasicOps.AtTopLevel' + -- and 'Agda.Interaction.CommandLine.interactionLoop'. + , iSignature :: Signature + , iMetaBindings :: RemoteMetaStore + -- ^ Instantiations for meta-variables that come from this module. + , iDisplayForms :: DisplayForms + -- ^ Display forms added for imported identifiers. + , iUserWarnings :: Map A.QName Text + -- ^ User warnings for imported identifiers + , iImportWarning :: Maybe Text + -- ^ Whether this module should raise a warning when imported + , iBuiltin :: BuiltinThings (String, QName) + , iForeignCode :: Map BackendName [ForeignCode] + , iHighlighting :: HighlightingInfo + , iDefaultPragmaOptions :: [OptionsPragma] + -- ^ Pragma options set in library files. + , iFilePragmaOptions :: [OptionsPragma] + -- ^ Pragma options set in the file. + , iOptionsUsed :: PragmaOptions + -- ^ Options/features used when checking the file (can be different + -- from options set directly in the file). + , iPatternSyns :: A.PatternSynDefns + , iWarnings :: [TCWarning] + , iPartialDefs :: Set QName + } + deriving (Show, Generic) + +instance Pretty Interface where + pretty (Interface + sourceH source fileT importedM moduleN topModN scope insideS + signature metas display userwarn importwarn builtin + foreignCode highlighting libPragmaO filePragmaO oUsed + patternS warnings partialdefs) = + + hang "Interface" 2 $ vcat + [ "source hash:" <+> (pretty . show) sourceH + , "source:" $$ nest 2 (text $ TL.unpack source) + , "file type:" <+> (pretty . show) fileT + , "imported modules:" <+> (pretty . show) importedM + , "module name:" <+> pretty moduleN + , "top-level module name:" <+> pretty topModN + , "scope:" <+> (pretty . show) scope + , "inside scope:" <+> (pretty . show) insideS + , "signature:" <+> (pretty . show) signature + , "meta-variables:" <+> (pretty . show) metas + , "display:" <+> (pretty . show) display + , "user warnings:" <+> (pretty . show) userwarn + , "import warning:" <+> (pretty . show) importwarn + , "builtin:" <+> (pretty . show) builtin + , "Foreign code:" <+> (pretty . show) foreignCode + , "highlighting:" <+> (pretty . show) highlighting + , "library pragma options:" <+> (pretty . show) libPragmaO + , "file pragma options:" <+> (pretty . show) filePragmaO + , "options used:" <+> (pretty . show) oUsed + , "pattern syns:" <+> (pretty . show) patternS + , "warnings:" <+> (pretty . show) warnings + , "partial definitions:" <+> (pretty . show) partialdefs + ] + +-- | Combines the source hash and the (full) hashes of the imported modules. +iFullHash :: Interface -> Hash +iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i) + +-- | A lens for the 'iSignature' field of the 'Interface' type. + +intSignature :: Lens' Signature Interface +intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s } + +--------------------------------------------------------------------------- +-- ** Closure +--------------------------------------------------------------------------- + +data Closure a = Closure + { clSignature :: Signature + , clEnv :: TCEnv + , clScope :: ScopeInfo + , clModuleCheckpoints :: Map ModuleName CheckpointId + , clValue :: a + } + deriving (Functor, Foldable, Generic) + +instance Show a => Show (Closure a) where + show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }" + +instance HasRange a => HasRange (Closure a) where + getRange = getRange . clValue + +class LensClosure a b | b -> a where + lensClosure :: Lens' (Closure a) b + +instance LensClosure a (Closure a) where + lensClosure = id + +instance LensTCEnv (Closure a) where + lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env } + +buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a) +buildClosure x = do + env <- askTC + sig <- useR stSignature + scope <- useR stScope + cps <- useR stModuleCheckpoints + return $ Closure sig env scope cps x + +--------------------------------------------------------------------------- +-- ** Constraints +--------------------------------------------------------------------------- + +type Constraints = [ProblemConstraint] + +data ProblemConstraint = PConstr + { constraintProblems :: Set ProblemId + , constraintUnblocker :: Blocker + , theConstraint :: Closure Constraint + } + deriving (Show, Generic) + +instance HasRange ProblemConstraint where + getRange = getRange . theConstraint + +-- | Why are we performing a modality check? +data WhyCheckModality + = ConstructorType + -- ^ Because --without-K is enabled, so the types of data constructors + -- must be usable at the context's modality. + | IndexedClause + -- ^ Because --without-K is enabled, so the result type of clauses + -- must be usable at the context's modality. + | IndexedClauseArg Name Name + -- ^ Because --without-K is enabled, so any argument (second name) + -- which mentions a dotted argument (first name) must have a type + -- which is usable at the context's modality. + | GeneratedClause + -- ^ Because we double-check the --cubical-compatible clauses. This is + -- an internal error! + deriving (Show, Generic) + +data Constraint + = ValueCmp Comparison CompareAs Term Term + | ValueCmpOnFace Comparison Term Type Term Term + | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim] + | SortCmp Comparison Sort Sort + | LevelCmp Comparison Level Level +-- | ShortCut MetaId Term Type +-- -- ^ A delayed instantiation. Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'. + | HasBiggerSort Sort + | HasPTSRule (Dom Type) (Abs Sort) + | CheckDataSort QName Sort + -- ^ Check that the sort 'Sort' of data type 'QName' admits data/record types. + -- E.g., sorts @IUniv@, @SizeUniv@ etc. do not admit such constructions. + -- See 'Agda.TypeChecking.Rules.Data.checkDataSort'. + | CheckMetaInst MetaId + | CheckType Type + | UnBlock MetaId + -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved + -- constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst' + -- or 'PostponedTypeCheckingProblem'. + | IsEmpty Range Type + -- ^ The range is the one of the absurd pattern. + | CheckSizeLtSat Term + -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT. + | FindInstance MetaId (Maybe [Candidate]) + -- ^ the first argument is the instance argument and the second one is the list of candidates + -- (or Nothing if we haven’t determined the list of candidates yet) + | CheckFunDef Delayed A.DefInfo QName [A.Clause] TCErr + -- ^ Last argument is the error causing us to postpone. + | UnquoteTactic Term Term Type -- ^ First argument is computation and the others are hole and goal type + | CheckLockedVars Term Type (Arg Term) Type -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed. + | UsableAtModality WhyCheckModality (Maybe Sort) Modality Term + -- ^ Is the term usable at the given modality? + -- This check should run if the @Sort@ is @Nothing@ or @isFibrant@. + deriving (Show, Generic) + +instance HasRange Constraint where + getRange (IsEmpty r t) = r + getRange _ = noRange +{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId + getRange (ValueCmp cmp a u v) = getRange (a,u,v) + getRange (ElimCmp pol a v es es') = getRange (a,v,es,es') + getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel') + getRange (SortCmp cmp s s') = getRange (s,s') + getRange (LevelCmp cmp l l') = getRange (l,l') + getRange (UnBlock x) = getRange x + getRange (FindInstance x cands) = getRange x +-} + +instance Free Constraint where + freeVars' c = + case c of + ValueCmp _ t u v -> freeVars' (t, (u, v)) + ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v))) + ElimCmp _ _ t u es es' -> freeVars' ((t, u), (es, es')) + SortCmp _ s s' -> freeVars' (s, s') + LevelCmp _ l l' -> freeVars' (l, l') + UnBlock _ -> mempty + IsEmpty _ t -> freeVars' t + CheckSizeLtSat u -> freeVars' u + FindInstance _ cs -> freeVars' cs + CheckFunDef{} -> mempty + HasBiggerSort s -> freeVars' s + HasPTSRule a s -> freeVars' (a , s) + CheckLockedVars a b c d -> freeVars' ((a,b),(c,d)) + UnquoteTactic t h g -> freeVars' (t, (h, g)) + CheckDataSort _ s -> freeVars' s + CheckMetaInst m -> mempty + CheckType t -> freeVars' t + UsableAtModality _ ms mod t -> freeVars' (ms, t) + +instance TermLike Constraint where + foldTerm f = \case + ValueCmp _ t u v -> foldTerm f (t, u, v) + ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v) + ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es') + LevelCmp _ l l' -> foldTerm f (Level l, Level l') -- Note wrapping as term, to ensure f gets to act on l and l' + IsEmpty _ t -> foldTerm f t + CheckSizeLtSat u -> foldTerm f u + UnquoteTactic t h g -> foldTerm f (t, h, g) + SortCmp _ s1 s2 -> foldTerm f (Sort s1, Sort s2) -- Same as LevelCmp case + UnBlock _ -> mempty + CheckLockedVars a b c d -> foldTerm f (a, b, c, d) + FindInstance _ _ -> mempty + CheckFunDef{} -> mempty + HasBiggerSort s -> foldTerm f s + HasPTSRule a s -> foldTerm f (a, Sort <$> s) + CheckDataSort _ s -> foldTerm f s + CheckMetaInst m -> mempty + CheckType t -> foldTerm f t + UsableAtModality _ ms m t -> foldTerm f (Sort <$> ms, t) + + traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented + +instance AllMetas Constraint + +data Comparison = CmpEq | CmpLeq + deriving (Eq, Show, Generic) + +instance Pretty Comparison where + pretty CmpEq = "=" + pretty CmpLeq = "=<" + +-- | An extension of 'Comparison' to @>=@. +data CompareDirection = DirEq | DirLeq | DirGeq + deriving (Eq, Show) + +instance Pretty CompareDirection where + pretty = text . \case + DirEq -> "=" + DirLeq -> "=<" + DirGeq -> ">=" + +-- | Embed 'Comparison' into 'CompareDirection'. +fromCmp :: Comparison -> CompareDirection +fromCmp CmpEq = DirEq +fromCmp CmpLeq = DirLeq + +-- | Flip the direction of comparison. +flipCmp :: CompareDirection -> CompareDirection +flipCmp DirEq = DirEq +flipCmp DirLeq = DirGeq +flipCmp DirGeq = DirLeq + +-- | Turn a 'Comparison' function into a 'CompareDirection' function. +-- +-- Property: @dirToCmp f (fromCmp cmp) = f cmp@ +dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c +dirToCmp cont DirEq = cont CmpEq +dirToCmp cont DirLeq = cont CmpLeq +dirToCmp cont DirGeq = flip $ cont CmpLeq + +-- | We can either compare two terms at a given type, or compare two +-- types without knowing (or caring about) their sorts. +data CompareAs + = AsTermsOf Type -- ^ @Type@ should not be @Size@. + -- But currently, we do not rely on this invariant. + | AsSizes -- ^ Replaces @AsTermsOf Size@. + | AsTypes + deriving (Show, Generic) + +instance Free CompareAs where + freeVars' (AsTermsOf a) = freeVars' a + freeVars' AsSizes = mempty + freeVars' AsTypes = mempty + +instance TermLike CompareAs where + foldTerm f (AsTermsOf a) = foldTerm f a + foldTerm f AsSizes = mempty + foldTerm f AsTypes = mempty + + traverseTermM f = \case + AsTermsOf a -> AsTermsOf <$> traverseTermM f a + AsSizes -> return AsSizes + AsTypes -> return AsTypes + +instance AllMetas CompareAs + +instance Pretty CompareAs where + pretty (AsTermsOf a) = ":" <+> pretty a + pretty AsSizes = ":" <+> text "Size" + pretty AsTypes = empty + +--------------------------------------------------------------------------- +-- * Open things +--------------------------------------------------------------------------- + +-- | A thing tagged with the context it came from. Also keeps the substitution from previous +-- checkpoints. This lets us handle the case when an open thing was created in a context that we +-- have since exited. Remember which module it's from to make sure we don't get confused by +-- checkpoints from other files. +data Open a = OpenThing { openThingCheckpoint :: CheckpointId + , openThingCheckpointMap :: Map CheckpointId Substitution + , openThingModule :: ModuleNameHash + , openThing :: a } + deriving (Show, Functor, Foldable, Traversable, Generic) + +instance Decoration Open where + traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x + +instance Pretty a => Pretty (Open a) where + prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $ + "OpenThing" <+> pretty cp <+> pretty (Map.toList env) prettyPrec 10 x + +--------------------------------------------------------------------------- +-- * Judgements +-- +-- Used exclusively for typing of meta variables. +--------------------------------------------------------------------------- + +-- | Parametrized since it is used without MetaId when creating a new meta. +data Judgement a + = HasType + { jMetaId :: a + , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type? + , jMetaType :: Type + } + | IsSort + { jMetaId :: a + , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas + } + deriving (Show, Generic) + +instance Pretty a => Pretty (Judgement a) where + pretty (HasType a cmp t) = hsep [ pretty a, ":" , pretty t ] + pretty (IsSort a t) = hsep [ pretty a, ":sort", pretty t ] + +----------------------------------------------------------------------------- +-- ** Generalizable variables +----------------------------------------------------------------------------- + +data DoGeneralize + = YesGeneralizeVar -- ^ Generalize because it is a generalizable variable. + | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and + -- we're currently checking the type of a generalizable variable + -- (this should get the default modality). + | NoGeneralize -- ^ Don't generalize. + deriving (Eq, Ord, Show, Generic) + +-- | The value of a generalizable variable. This is created to be a +-- generalizable meta before checking the type to be generalized. +data GeneralizedValue = GeneralizedValue + { genvalCheckpoint :: CheckpointId + , genvalTerm :: Term + , genvalType :: Type + } deriving (Show, Generic) + +--------------------------------------------------------------------------- +-- ** Meta variables +--------------------------------------------------------------------------- + +-- | Information about local meta-variables. + +data MetaVariable = + MetaVar { mvInfo :: MetaInfo + , mvPriority :: MetaPriority -- ^ some metavariables are more eager to be instantiated + , mvPermutation :: Permutation + -- ^ a metavariable doesn't have to depend on all variables + -- in the context, this "permutation" will throw away the + -- ones it does not depend on + , mvJudgement :: Judgement MetaId + , mvInstantiation :: MetaInstantiation + , mvListeners :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one + , mvFrozen :: Frozen -- ^ are we past the point where we can instantiate this meta variable? + , mvTwin :: Maybe MetaId + -- ^ @Just m@ means that this meta-variable will be + -- equated to @m@ when the latter is unblocked. See + -- 'Agda.TypeChecking.MetaVars.blockTermOnProblem'. + } + deriving Generic + +data Listener = EtaExpand MetaId + | CheckConstraint Nat ProblemConstraint + deriving Generic + +instance Eq Listener where + EtaExpand x == EtaExpand y = x == y + CheckConstraint x _ == CheckConstraint y _ = x == y + _ == _ = False + +instance Ord Listener where + EtaExpand x `compare` EtaExpand y = x `compare` y + CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y + EtaExpand{} `compare` CheckConstraint{} = LT + CheckConstraint{} `compare` EtaExpand{} = GT + +-- | Frozen meta variable cannot be instantiated by unification. +-- This serves to prevent the completion of a definition by its use +-- outside of the current block. +-- (See issues 118, 288, 399). +data Frozen + = Frozen -- ^ Do not instantiate. + | Instantiable + deriving (Eq, Show, Generic) + +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) + deriving Generic + +-- | Meta-variable instantiations. + +data Instantiation = Instantiation + { instTel :: [Arg String] + -- ^ The solution is abstracted over these free variables. + , instBody :: Term + -- ^ The body of the solution. + } + deriving (Show, Generic) + +-- | Information about remote meta-variables. +-- +-- Remote meta-variables are meta-variables originating in other +-- modules. These meta-variables are always instantiated. We do not +-- retain all the information about a local meta-variable when +-- creating an interface: +-- +-- * The 'mvPriority' field is not needed, because the meta-variable +-- cannot be instantiated. +-- * The 'mvFrozen' field is not needed, because there is no point in +-- freezing instantiated meta-variables. +-- * The 'mvListeners' field is not needed, because no meta-variable +-- should be listening to this one. +-- * The 'mvTwin' field is not needed, because the meta-variable has +-- already been instantiated. +-- * The 'mvPermutation' is currently removed, but could be retained +-- if it turns out to be useful for something. +-- * The only part of the 'mvInfo' field that is kept is the +-- 'miModality' field. The 'miMetaOccursCheck' and 'miGeneralizable' +-- fields are omitted, because the meta-variable has already been +-- instantiated. The 'Range' that is part of the 'miClosRange' field +-- and the 'miNameSuggestion' field are omitted because instantiated +-- meta-variables are typically not presented to users. Finally the +-- 'Closure' part of the 'miClosRange' field is omitted because it +-- can be large (at least if we ignore potential sharing). + +data RemoteMetaVariable = RemoteMetaVariable + { rmvInstantiation :: Instantiation + , rmvModality :: Modality + , rmvJudgement :: Judgement MetaId + } + deriving (Show, Generic) + +-- | Solving a 'CheckArgs' constraint may or may not check the target type. If +-- it did, it returns a handle to any unsolved constraints. +data CheckedTarget = CheckedTarget (Maybe ProblemId) + | NotCheckedTarget + +data PrincipalArgTypeMetas = PrincipalArgTypeMetas + { patmMetas :: Args -- ^ metas created for hidden and instance arguments + -- in the principal argument's type + , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and + -- instance arguments + } + deriving Generic + +data TypeCheckingProblem + = CheckExpr Comparison A.Expr Type + | CheckArgs Comparison ExpandHidden Range [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term) + | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Args Type Int Term Type PrincipalArgTypeMetas + | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type + -- ^ @(λ (xs : t₀) → e) : t@ + -- This is not an instance of 'CheckExpr' as the domain type + -- has already been checked. + -- For example, when checking + -- @(λ (x y : Fin _) → e) : (x : Fin n) → ?@ + -- we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@ + -- is a 'Type' rather than an 'A.Expr'. + | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term` + deriving Generic + +instance Pretty MetaInstantiation where + pretty = \case + Open -> "Open" + OpenInstance -> "OpenInstance" + PostponedTypeCheckingProblem{} -> "PostponedTypeCheckingProblem (...)" + BlockedConst t -> hsep [ "BlockedConst", parens (pretty t) ] + InstV Instantiation{ instTel, instBody } -> hsep [ "InstV", pretty instTel, parens (pretty instBody) ] + +-- | Meta variable priority: +-- When we have an equation between meta-variables, which one +-- should be instantiated? +-- +-- Higher value means higher priority to be instantiated. +newtype MetaPriority = MetaPriority Int + deriving (Eq, Ord, Show, NFData) + +data RunMetaOccursCheck + = RunMetaOccursCheck + | DontRunMetaOccursCheck + deriving (Eq, Ord, Show, Generic) + +-- | @MetaInfo@ is cloned from one meta to the next during pruning. +data MetaInfo = MetaInfo + { miClosRange :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range. + , miModality :: Modality -- ^ Instantiable with irrelevant/erased solution? + , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions? + , miNameSuggestion :: MetaNameSuggestion + -- ^ Used for printing. + -- @Just x@ if meta-variable comes from omitted argument with name @x@. + , miGeneralizable :: Arg DoGeneralize + -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo? + } + deriving Generic + +instance LensModality MetaInfo where + getModality = miModality + setModality mod mi = mi { miModality = mod } + mapModality f mi = mi { miModality = f $ miModality mi } + +instance LensQuantity MetaInfo where + getQuantity = getQuantity . getModality + mapQuantity f = mapModality (mapQuantity f) + +instance LensRelevance MetaInfo where + mapRelevance f = mapModality (mapRelevance f) + +-- | Name suggestion for meta variable. Empty string means no suggestion. +type MetaNameSuggestion = String + +-- | For printing, we couple a meta with its name suggestion. +data NamedMeta = NamedMeta + { nmSuggestion :: MetaNameSuggestion + , nmid :: MetaId + } + +instance Pretty NamedMeta where + pretty (NamedMeta "" x) = pretty x + pretty (NamedMeta "_" x) = pretty x + pretty (NamedMeta s x) = text $ "_" ++ s ++ prettyShow x + +-- | Used for meta-variables from the current module. + +type LocalMetaStore = Map MetaId MetaVariable + +-- | Used for meta-variables from other modules (and in 'Interface's). + +type RemoteMetaStore = HashMap MetaId RemoteMetaVariable + +instance HasRange MetaInfo where + getRange = clValue . miClosRange + +instance HasRange MetaVariable where + getRange m = getRange $ getMetaInfo m + +instance SetRange MetaInfo where + setRange r m = m { miClosRange = (miClosRange m) { clValue = r }} + +instance SetRange MetaVariable where + setRange r m = m { mvInfo = setRange r (mvInfo m) } + +instance LensModality MetaVariable where + getModality = getModality . mvInfo + setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv } + mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv } + +instance LensRelevance MetaVariable where + setRelevance mod mv = mv { mvInfo = setRelevance mod $ mvInfo mv } + +instance LensQuantity MetaVariable where + getQuantity = getQuantity . getModality + mapQuantity f = mapModality (mapQuantity f) + +instance LensModality RemoteMetaVariable where + getModality = rmvModality + mapModality f mv = mv { rmvModality = f $ rmvModality mv } + +instance LensRelevance RemoteMetaVariable where + mapRelevance f = mapModality (mapRelevance f) + +instance LensQuantity RemoteMetaVariable where + mapQuantity f = mapModality (mapQuantity f) + +normalMetaPriority :: MetaPriority +normalMetaPriority = MetaPriority 0 + +lowMetaPriority :: MetaPriority +lowMetaPriority = MetaPriority (-10) + +highMetaPriority :: MetaPriority +highMetaPriority = MetaPriority 10 + +getMetaInfo :: MetaVariable -> Closure Range +getMetaInfo = miClosRange . mvInfo + +getMetaScope :: MetaVariable -> ScopeInfo +getMetaScope m = clScope $ getMetaInfo m + +getMetaEnv :: MetaVariable -> TCEnv +getMetaEnv m = clEnv $ getMetaInfo m + +getMetaSig :: MetaVariable -> Signature +getMetaSig m = clSignature $ getMetaInfo m + +-- Lenses + +metaFrozen :: Lens' Frozen MetaVariable +metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x } + +_mvInfo :: Lens' MetaInfo MetaVariable +_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi } + +-- Lenses onto Closure Range + +instance LensClosure Range MetaInfo where + lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl } + +instance LensClosure Range MetaVariable where + lensClosure = _mvInfo . lensClosure + +-- Lenses onto IsAbstract + +instance LensIsAbstract TCEnv where + lensIsAbstract f env = + -- Andreas, 2019-08-19 + -- Using $! to prevent space leaks like #1829. + -- This can crash when trying to get IsAbstract from IgnoreAbstractMode. + (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env)) + <&> \ a -> env { envAbstractMode = aDefToMode a } + +instance LensIsAbstract (Closure a) where + lensIsAbstract = lensTCEnv . lensIsAbstract + +instance LensIsAbstract MetaInfo where + lensIsAbstract = lensClosure . lensIsAbstract + +--------------------------------------------------------------------------- +-- ** Interaction meta variables +--------------------------------------------------------------------------- + +-- | Interaction points are created by the scope checker who sets the range. +-- The meta variable is created by the type checker and then hooked up to the +-- interaction point. +data InteractionPoint = InteractionPoint + { ipRange :: Range -- ^ The position of the interaction point. + , ipMeta :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc. + , ipSolved:: Bool -- ^ Has this interaction point already been solved? + , ipClause:: IPClause + -- ^ The clause of the interaction point (if any). + -- Used for case splitting. + } + deriving Generic + +instance Eq InteractionPoint where (==) = (==) `on` ipMeta + +instance HasTag InteractionPoint where + type Tag InteractionPoint = MetaId + tag = ipMeta + +-- | Data structure managing the interaction points. +-- +-- We never remove interaction points from this map, only set their +-- 'ipSolved' to @True@. (Issue #2368) +type InteractionPoints = BiMap InteractionId InteractionPoint + +-- | Flag to indicate whether the meta is overapplied in the +-- constraint. A meta is overapplied if it has more arguments than +-- the size of the telescope in its creation environment +-- (as stored in MetaInfo). +data Overapplied = Overapplied | NotOverapplied + deriving (Eq, Show, Generic) + +-- | Datatype representing a single boundary condition: +-- x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es +data IPBoundary' t = IPBoundary + { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n] + , ipbValue :: t -- ^ @t@ + , ipbMetaApp :: t -- ^ @?n es@ + , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ? + } + deriving (Show, Functor, Foldable, Traversable, Generic) + +type IPBoundary = IPBoundary' Term + +-- | Which clause is an interaction point located in? +data IPClause = IPClause + { ipcQName :: QName -- ^ The name of the function. + , ipcClauseNo :: Int -- ^ The number of the clause of this function. + , ipcType :: Type -- ^ The type of the function + , ipcWithSub :: Maybe Substitution -- ^ Module parameter substitution + , ipcClause :: A.SpineClause -- ^ The original AST clause. + , ipcClosure :: Closure () -- ^ Environment for rechecking the clause. + , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS. + } + | IPNoClause -- ^ The interaction point is not in the rhs of a clause. + deriving (Generic) + +instance Eq IPClause where + IPNoClause == IPNoClause = True + IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i' + _ == _ = False + +--------------------------------------------------------------------------- +-- ** Signature +--------------------------------------------------------------------------- + +data Signature = Sig + { _sigSections :: Sections + , _sigDefinitions :: Definitions + , _sigRewriteRules:: RewriteRuleMap -- ^ The rewrite rules defined in this file. + } + deriving (Show, Generic) + +sigSections :: Lens' Sections Signature +sigSections f s = + f (_sigSections s) <&> + \x -> s {_sigSections = x} + +sigDefinitions :: Lens' Definitions Signature +sigDefinitions f s = + f (_sigDefinitions s) <&> + \x -> s {_sigDefinitions = x} + +sigRewriteRules :: Lens' RewriteRuleMap Signature +sigRewriteRules f s = + f (_sigRewriteRules s) <&> + \x -> s {_sigRewriteRules = x} + +type Sections = Map ModuleName Section +type Definitions = HashMap QName Definition +type RewriteRuleMap = HashMap QName RewriteRules +type DisplayForms = HashMap QName [LocalDisplayForm] + +newtype Section = Section { _secTelescope :: Telescope } + deriving (Show, NFData) + +instance Pretty Section where + pretty = pretty . _secTelescope + +secTelescope :: Lens' Telescope Section +secTelescope f s = + f (_secTelescope s) <&> + \x -> s {_secTelescope = x} + +emptySignature :: Signature +emptySignature = Sig Map.empty HMap.empty HMap.empty + +-- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a +-- constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a +-- more readable 'Abstract.Syntax'. +-- +-- The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables +-- that matches any term. +data DisplayForm = Display + { dfPatternVars :: Nat + -- ^ Number @n@ of pattern variables in 'dfPats'. + , dfPats :: Elims + -- ^ Left hand side patterns, the @n@ first free variables are pattern variables, + -- any variables above @n@ are fixed and only match that particular variable. This + -- happens when you have display forms inside parameterised modules that match on the module + -- parameters. The 'ArgInfo' is ignored in these patterns. + , dfRHS :: DisplayTerm + -- ^ Right hand side. + } + deriving (Show, Generic) + +type LocalDisplayForm = Open DisplayForm + +-- | A structured presentation of a 'Term' for reification into +-- 'Abstract.Syntax'. +data DisplayTerm + = DWithApp DisplayTerm [DisplayTerm] Elims + -- ^ @(f vs | ws) es@. + -- The first 'DisplayTerm' is the parent function @f@ with its args @vs@. + -- The list of 'DisplayTerm's are the with expressions @ws@. + -- The 'Elims' are additional arguments @es@ + -- (possible in case the with-application is of function type) + -- or projections (if it is of record type). + | DCon ConHead ConInfo [Arg DisplayTerm] + -- ^ @c vs@. + | DDef QName [Elim' DisplayTerm] + -- ^ @d vs@. + | DDot Term + -- ^ @.v@. + | DTerm Term + -- ^ @v@. + deriving (Show, Generic) + +instance Free DisplayForm where + freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t) + +instance Free DisplayTerm where + freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es)) + freeVars' (DCon _ _ vs) = freeVars' vs + freeVars' (DDef _ es) = freeVars' es + freeVars' (DDot v) = freeVars' v + freeVars' (DTerm v) = freeVars' v + +instance Pretty DisplayTerm where + prettyPrec p v = + case v of + DTerm v -> prettyPrec p v + DDot v -> "." <> prettyPrec 10 v + DDef f es -> pretty f `pApp` es + DCon c _ vs -> pretty (conName c) `pApp` map Apply vs + DWithApp h ws es -> + mparens (p > 0) + (sep [ pretty h + , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ]) + `pApp` es + where + pApp :: Pretty el => Doc -> [el] -> Doc + pApp d els = mparens (not (null els) && p > 9) $ + sep [d, nest 2 $ fsep (map (prettyPrec 10) els)] + +instance Pretty DisplayForm where + prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $ + "Display" fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ] + +-- | By default, we have no display form. +defaultDisplayForm :: QName -> [LocalDisplayForm] +defaultDisplayForm c = [] + +-- | Non-linear (non-constructor) first-order pattern. +data NLPat + = PVar !Int [Arg Int] + -- ^ Matches anything (modulo non-linearity) that only contains bound + -- variables that occur in the given arguments. + | PDef QName PElims + -- ^ Matches @f es@ + | PLam ArgInfo (Abs NLPat) + -- ^ Matches @λ x → t@ + | PPi (Dom NLPType) (Abs NLPType) + -- ^ Matches @(x : A) → B@ + | PSort NLPSort + -- ^ Matches a sort of the given shape. + | PBoundVar {-# UNPACK #-} !Int PElims + -- ^ Matches @x es@ where x is a lambda-bound variable + | PTerm Term + -- ^ Matches the term modulo β (ideally βη). + deriving (Show, Generic) +type PElims = [Elim' NLPat] + +instance TermLike NLPat where + traverseTermM f = \case + p@PVar{} -> return p + PDef d ps -> PDef d <$> traverseTermM f ps + PLam i p -> PLam i <$> traverseTermM f p + PPi a b -> PPi <$> traverseTermM f a <*> traverseTermM f b + PSort s -> PSort <$> traverseTermM f s + PBoundVar i ps -> PBoundVar i <$> traverseTermM f ps + PTerm t -> PTerm <$> f t + + foldTerm f t = case t of + PVar{} -> mempty + PDef d ps -> foldTerm f ps + PLam i p -> foldTerm f p + PPi a b -> foldTerm f (a, b) + PSort s -> foldTerm f s + PBoundVar i ps -> foldTerm f ps + PTerm t -> foldTerm f t + +instance AllMetas NLPat + +data NLPType = NLPType + { nlpTypeSort :: NLPSort + , nlpTypeUnEl :: NLPat + } deriving (Show, Generic) + +instance TermLike NLPType where + traverseTermM f (NLPType s t) = NLPType <$> traverseTermM f s <*> traverseTermM f t + + foldTerm f (NLPType s t) = foldTerm f (s, t) + +instance AllMetas NLPType + +data NLPSort + = PType NLPat + | PProp NLPat + | PSSet NLPat + | PInf IsFibrant Integer + | PSizeUniv + | PLockUniv + | PIntervalUniv + deriving (Show, Generic) + +instance TermLike NLPSort where + traverseTermM f = \case + PType p -> PType <$> traverseTermM f p + PProp p -> PProp <$> traverseTermM f p + PSSet p -> PSSet <$> traverseTermM f p + s@PInf{} -> return s + s@PSizeUniv{} -> return s + s@PLockUniv{} -> return s + s@PIntervalUniv{} -> return s + + foldTerm f t = case t of + PType p -> foldTerm f p + PProp p -> foldTerm f p + PSSet p -> foldTerm f p + s@PInf{} -> mempty + s@PSizeUniv{} -> mempty + s@PLockUniv{} -> mempty + s@PIntervalUniv{} -> mempty + +instance AllMetas NLPSort + +type RewriteRules = [RewriteRule] + +-- | Rewrite rules can be added independently from function clauses. +data RewriteRule = RewriteRule + { rewName :: QName -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@ + -- where @≡@ is the rewrite relation. + , rewContext :: Telescope -- ^ @Γ@. + , rewHead :: QName -- ^ @f@. + , rewPats :: PElims -- ^ @Γ ⊢ f ps : t@. + , rewRHS :: Term -- ^ @Γ ⊢ rhs : t@. + , rewType :: Type -- ^ @Γ ⊢ t@. + , rewFromClause :: Bool -- ^ Was this rewrite rule created from a clause in the definition of the function? + } + deriving (Show, Generic) + +data Definition = Defn + { defArgInfo :: ArgInfo -- ^ Hiding should not be used. + , defName :: QName -- ^ The canonical name, used e.g. in compilation. + , defType :: Type -- ^ Type of the lifted definition. + , defPolarity :: [Polarity] + -- ^ Variance information on arguments of the definition. + -- Does not include info for dropped parameters to + -- projection(-like) functions and constructors. + , defArgOccurrences :: [Occurrence] + -- ^ Positivity information on arguments of the definition. + -- Does not include info for dropped parameters to + -- projection(-like) functions and constructors. + + -- Sometimes Agda looks up 'Occurrence's in these lists based on + -- their position, so one might consider replacing the list + -- with, say, an 'IntMap'. However, presumably these lists tend + -- to be short, in which case 'IntMap's could be slower than + -- lists. For instance, at one point the longest list + -- encountered for the standard library (in serialised + -- interfaces) had length 27. Distribution: + -- + -- Length, number of lists + -- ----------------------- + -- + -- 0, 2444 + -- 1, 721 + -- 2, 433 + -- 3, 668 + -- 4, 602 + -- 5, 624 + -- 6, 626 + -- 7, 484 + -- 8, 375 + -- 9, 264 + -- 10, 305 + -- 11, 188 + -- 12, 171 + -- 13, 108 + -- 14, 84 + -- 15, 80 + -- 16, 38 + -- 17, 23 + -- 18, 16 + -- 19, 8 + -- 20, 7 + -- 21, 5 + -- 22, 2 + -- 23, 3 + -- 27, 1 + + , defArgGeneralizable :: NumGeneralizableArgs + -- ^ How many arguments should be generalised. + , defGeneralizedParams :: [Maybe Name] + -- ^ Gives the name of the (bound variable) parameter for named generalized + -- parameters. This is needed to bring it into scope when type checking + -- the data/record definition corresponding to a type with generalized + -- parameters. + , defDisplay :: [LocalDisplayForm] + , defMutual :: MutualId + , defCompiledRep :: CompiledRepresentation + , defInstance :: Maybe QName + -- ^ @Just q@ when this definition is an instance of class q + , defCopy :: Bool + -- ^ Has this function been created by a module + -- instantiation? + , defMatchable :: Set QName + -- ^ The set of symbols with rewrite rules that match against this symbol + , defNoCompilation :: Bool + -- ^ should compilers skip this? Used for e.g. cubical's comp + , defInjective :: Bool + -- ^ Should the def be treated as injective by the pattern matching unifier? + , defCopatternLHS :: Bool + -- ^ Is this a function defined by copatterns? + , defBlocked :: Blocked_ + -- ^ What blocking tag to use when we cannot reduce this def? + -- Used when checking a function definition is blocked on a meta + -- in the type. + , defLanguage :: !Language + -- ^ The language used for the definition. + , theDef :: Defn + } + deriving (Show, Generic) + +instance LensArgInfo Definition where + getArgInfo = defArgInfo + mapArgInfo f def = def { defArgInfo = f $ defArgInfo def } + +instance LensModality Definition where +instance LensQuantity Definition where +instance LensRelevance Definition where + +data NumGeneralizableArgs + = NoGeneralizableArgs + | SomeGeneralizableArgs !Int + -- ^ When lambda-lifting new args are generalizable if + -- 'SomeGeneralizableArgs', also when the number is zero. + deriving Show + +lensTheDef :: Lens' Defn Definition +lensTheDef f d = f (theDef d) <&> \ df -> d { theDef = df } + +-- | Create a definition with sensible defaults. +defaultDefn :: + ArgInfo -> QName -> Type -> Language -> Defn -> Definition +defaultDefn info x t lang def = Defn + { defArgInfo = info + , defName = x + , defType = t + , defPolarity = [] + , defArgOccurrences = [] + , defArgGeneralizable = NoGeneralizableArgs + , defGeneralizedParams = [] + , defDisplay = defaultDisplayForm x + , defMutual = 0 + , defCompiledRep = noCompiledRep + , defInstance = Nothing + , defCopy = False + , defMatchable = Set.empty + , defNoCompilation = False + , defInjective = False + , defCopatternLHS = False + , defBlocked = NotBlocked ReallyNotBlocked () + , defLanguage = lang + , theDef = def + } + +-- | Polarity for equality and subtype checking. +data Polarity + = Covariant -- ^ monotone + | Contravariant -- ^ antitone + | Invariant -- ^ no information (mixed variance) + | Nonvariant -- ^ constant + deriving (Show, Eq, Generic) + +instance Pretty Polarity where + pretty = text . \case + Covariant -> "+" + Contravariant -> "-" + Invariant -> "*" + Nonvariant -> "_" + +-- | Information about whether an argument is forced by the type of a function. +data IsForced + = Forced + | NotForced + deriving (Show, Eq, Generic) + +-- | The backends are responsible for parsing their own pragmas. +data CompilerPragma = CompilerPragma Range String + deriving (Show, Eq, Generic) + +instance HasRange CompilerPragma where + getRange (CompilerPragma r _) = r + +type BackendName = String + +jsBackendName, ghcBackendName :: BackendName +jsBackendName = "JS" +ghcBackendName = "GHC" + +type CompiledRepresentation = Map BackendName [CompilerPragma] + +noCompiledRep :: CompiledRepresentation +noCompiledRep = Map.empty + +-- A face represented as a list of equality constraints. +-- (r,False) ↦ (r = i0) +-- (r,True ) ↦ (r = i1) +type Face = [(Term,Bool)] + +-- | An alternative representation of partial elements in a telescope: +-- Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T +-- see cubicaltt paper (however we do not store the type T). +data System = System + { systemTel :: Telescope + -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ + , systemClauses :: [(Face,Term)] + -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ + } deriving (Show, Generic) + +-- | Additional information for extended lambdas. +data ExtLamInfo = ExtLamInfo + { extLamModule :: ModuleName + -- ^ For complicated reasons the scope checker decides the QName of a + -- pattern lambda, and thus its module. We really need to decide the + -- module during type checking though, since if the lambda appears in a + -- refined context the module picked by the scope checker has very much + -- the wrong parameters. + , extLamAbsurd :: Bool + -- ^ Was this definition created from an absurd lambda @λ ()@? + , extLamSys :: !(Strict.Maybe System) + } deriving (Show, Generic) + +modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo +modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e' + +-- | Additional information for projection 'Function's. +data Projection = Projection + { projProper :: Maybe QName + -- ^ @Nothing@ if only projection-like, @Just r@ if record projection. + -- The @r@ is the name of the record type projected from. + -- This field is updated by module application. + , projOrig :: QName + -- ^ The original projection name + -- (current name could be from module application). + , projFromType :: Arg QName + -- ^ Type projected from. Original record type if @projProper = Just{}@. + -- Also stores @ArgInfo@ of the principal argument. + -- This field is unchanged by module application. + , projIndex :: Int + -- ^ Index of the record argument. + -- Start counting with 1, because 0 means that + -- it is already applied to the record value. + -- This can happen in module instantiation, but + -- then either the record value is @var 0@, or @funProjection == Nothing@. + , projLams :: ProjLams + -- ^ Term @t@ to be be applied to record parameters and record value. + -- The parameters will be dropped. + -- In case of a proper projection, a postfix projection application + -- will be created: @t = \ pars r -> r .p@ + -- (Invariant: the number of abstractions equals 'projIndex'.) + -- In case of a projection-like function, just the function symbol + -- is returned as 'Def': @t = \ pars -> f@. + } deriving (Show, Generic) + +-- | Abstractions to build projection function (dropping parameters). +newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] } + deriving (Show, Null, Generic) + +-- | Building the projection function (which drops the parameters). +projDropPars :: Projection -> ProjOrigin -> Term +-- Proper projections: +projDropPars (Projection Just{} d _ _ lams) o = + case initLast $ getProjLams lams of + Nothing -> Def d [] + Just (pars, Arg i y) -> + let core = Lam i $ Abs y $ Var 0 [Proj o d] in + List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars +-- Projection-like functions: +projDropPars (Projection Nothing d _ _ lams) o = + List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $ + initWithDefault __IMPOSSIBLE__ $ getProjLams lams + +-- | The info of the principal (record) argument. +projArgInfo :: Projection -> ArgInfo +projArgInfo (Projection _ _ _ _ lams) = + maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams + +-- | Should a record type admit eta-equality? +data EtaEquality + = Specified { theEtaEquality :: !HasEta } -- ^ User specifed 'eta-equality' or 'no-eta-equality'. + | Inferred { theEtaEquality :: !HasEta } -- ^ Positivity checker inferred whether eta is safe. + deriving (Show, Eq, Generic) + +instance PatternMatchingAllowed EtaEquality where + patternMatchingAllowed = patternMatchingAllowed . theEtaEquality + +instance CopatternMatchingAllowed EtaEquality where + copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality + +-- | Make sure we do not overwrite a user specification. +setEtaEquality :: EtaEquality -> HasEta -> EtaEquality +setEtaEquality e@Specified{} _ = e +setEtaEquality _ b = Inferred b + +data FunctionFlag + = FunStatic -- ^ Should calls to this function be normalised at compile-time? + | FunInline -- ^ Should calls to this function be inlined by the compiler? + | FunMacro -- ^ Is this function a macro? + deriving (Eq, Ord, Enum, Show, Generic) + +data CompKit = CompKit + { nameOfHComp :: Maybe QName + , nameOfTransp :: Maybe QName + } + deriving (Eq, Ord, Show, Generic) + +emptyCompKit :: CompKit +emptyCompKit = CompKit Nothing Nothing + +defaultAxiom :: Defn +defaultAxiom = Axiom False + +constTranspAxiom :: Defn +constTranspAxiom = Axiom True + +data Defn + = AxiomDefn AxiomData + -- ^ Postulate. + | DataOrRecSigDefn DataOrRecSigData + -- ^ Data or record type signature that doesn't yet have a definition. + | GeneralizableVar + -- ^ Generalizable variable (introduced in `generalize` block). + | AbstractDefn Defn + -- ^ Returned by 'getConstInfo' if definition is abstract. + | FunctionDefn FunctionData + | DatatypeDefn DatatypeData + | RecordDefn RecordData + | ConstructorDefn ConstructorData + | PrimitiveDefn PrimitiveData + -- ^ Primitive or builtin functions. + | PrimitiveSortDefn PrimitiveSortData + deriving (Show, Generic) + +-- The COMPLETE pragma is new in GHC 8.2 +#if __GLASGOW_HASKELL__ >= 802 +{-# COMPLETE + Axiom, DataOrRecSig, GeneralizableVar, AbstractDefn, + Function, Datatype, Record, Constructor, Primitive, PrimitiveSort #-} +#endif + +data AxiomData = AxiomData + { _axiomConstTransp :: Bool + -- ^ Can transp for this postulate be constant? + -- Set to @True@ for bultins like String. + } deriving (Show, Generic) + +pattern Axiom :: Bool -> Defn +pattern Axiom{ axiomConstTransp } = AxiomDefn (AxiomData axiomConstTransp) + +data DataOrRecSigData = DataOrRecSigData + { _datarecPars :: Int + } deriving (Show, Generic) + +pattern DataOrRecSig :: Int -> Defn +pattern DataOrRecSig{ datarecPars } = DataOrRecSigDefn (DataOrRecSigData datarecPars) + +-- | Indicates the reason behind a function having not been marked +-- projection-like. +data ProjectionLikenessMissing + = MaybeProjection + -- ^ Projection-likeness analysis has not run on this function yet. + -- It may do so in the future. + | NeverProjection + -- ^ The user has requested that this function be not be marked + -- projection-like. The analysis may already have run on this + -- function, but the results have been discarded, and it will not be + -- run again. + deriving (Show, Generic, Enum, Bounded) + +data FunctionData = FunctionData + { _funClauses :: [Clause] + , _funCompiled :: Maybe CompiledClauses + -- ^ 'Nothing' while function is still type-checked. + -- @Just cc@ after type and coverage checking and + -- translation to case trees. + , _funSplitTree :: Maybe SplitTree + -- ^ The split tree constructed by the coverage + -- checker. Needed to re-compile the clauses after + -- forcing translation. + , _funTreeless :: Maybe Compiled + -- ^ Intermediate representation for compiler backends. + , _funCovering :: [Clause] + -- ^ Covering clauses computed by coverage checking. + -- Erased by (IApply) confluence checking(?) + , _funInv :: FunctionInverse + , _funMutual :: Maybe [QName] + -- ^ Mutually recursive functions, @data@s and @record@s. + -- Does include this function. + -- Empty list if not recursive. + -- @Nothing@ if not yet computed (by positivity checker). + , _funAbstr :: IsAbstract + , _funDelayed :: Delayed + -- ^ Are the clauses of this definition delayed? + , _funProjection :: Either ProjectionLikenessMissing Projection + -- ^ Is it a record projection? + -- If yes, then return the name of the record type and index of + -- the record argument. Start counting with 1, because 0 means that + -- it is already applied to the record. (Can happen in module + -- instantiation.) This information is used in the termination + -- checker. + , _funFlags :: Set FunctionFlag + , _funTerminates :: Maybe Bool + -- ^ Has this function been termination checked? Did it pass? + , _funExtLam :: Maybe ExtLamInfo + -- ^ Is this function generated from an extended lambda? + -- If yes, then return the number of hidden and non-hidden lambda-lifted arguments. + , _funWith :: Maybe QName + -- ^ Is this a generated with-function? + -- If yes, then what's the name of the parent function? + , _funIsKanOp :: Maybe QName + -- ^ Is this a helper for one of the Kan operations (transp, + -- hcomp) on data types/records? If so, for which data type? + } deriving (Show, Generic) + +pattern Function + :: [Clause] + -> Maybe CompiledClauses + -> Maybe SplitTree + -> Maybe Compiled + -> [Clause] + -> FunctionInverse + -> Maybe [QName] + -> IsAbstract + -> Delayed + -> Either ProjectionLikenessMissing Projection + -> Set FunctionFlag + -> Maybe Bool + -> Maybe ExtLamInfo + -> Maybe QName + -> Maybe QName + -> Defn +pattern Function + { funClauses + , funCompiled + , funSplitTree + , funTreeless + , funCovering + , funInv + , funMutual + , funAbstr + , funDelayed + , funProjection + , funFlags + , funTerminates + , funExtLam + , funWith + , funIsKanOp + } = FunctionDefn (FunctionData + funClauses + funCompiled + funSplitTree + funTreeless + funCovering + funInv + funMutual + funAbstr + funDelayed + funProjection + funFlags + funTerminates + funExtLam + funWith + funIsKanOp + ) + +data DatatypeData = DatatypeData + { _dataPars :: Nat + -- ^ Number of parameters. + , _dataIxs :: Nat + -- ^ Number of indices. + , _dataClause :: Maybe Clause + -- ^ This might be in an instantiated module. + , _dataCons :: [QName] + -- ^ Constructor names, ordered according to the order of their definition. + , _dataSort :: Sort + , _dataMutual :: Maybe [QName] + -- ^ Mutually recursive functions, @data@s and @record@s. + -- Does include this data type. + -- Empty if not recursive. + -- @Nothing@ if not yet computed (by positivity checker). + , _dataAbstr :: IsAbstract + , _dataPathCons :: [QName] + -- ^ Path constructor names (subset of @dataCons@). + , _dataTranspIx :: Maybe QName + -- ^ If indexed datatype, name of the "index transport" function. + , _dataTransp :: Maybe QName + -- ^ Transport function, should be available for all datatypes in supported sorts. + } deriving (Show, Generic) + +pattern Datatype + :: Nat + -> Nat + -> (Maybe Clause) + -> [QName] + -> Sort + -> Maybe [QName] + -> IsAbstract + -> [QName] + -> Maybe QName + -> Maybe QName + -> Defn + +pattern Datatype + { dataPars + , dataIxs + , dataClause + , dataCons + , dataSort + , dataMutual + , dataAbstr + , dataPathCons + , dataTranspIx + , dataTransp + } = DatatypeDefn (DatatypeData + dataPars + dataIxs + dataClause + dataCons + dataSort + dataMutual + dataAbstr + dataPathCons + dataTranspIx + dataTransp + ) + +data RecordData = RecordData + { _recPars :: Nat + -- ^ Number of parameters. + , _recClause :: Maybe Clause + -- ^ Was this record type created by a module application? + -- If yes, the clause is its definition (linking back to the original record type). + , _recConHead :: ConHead + -- ^ Constructor name and fields. + , _recNamedCon :: Bool + -- ^ Does this record have a @constructor@? + , _recFields :: [Dom QName] + -- ^ The record field names. + , _recTel :: Telescope + -- ^ The record field telescope. (Includes record parameters.) + -- Note: @TelV recTel _ == telView' recConType@. + -- Thus, @recTel@ is redundant. + , _recMutual :: Maybe [QName] + -- ^ Mutually recursive functions, @data@s and @record@s. + -- Does include this record. + -- Empty if not recursive. + -- @Nothing@ if not yet computed (by positivity checker). + , _recEtaEquality' :: EtaEquality + -- ^ Eta-expand at this record type? + -- @False@ for unguarded recursive records and coinductive records + -- unless the user specifies otherwise. + , _recPatternMatching :: PatternOrCopattern + -- ^ In case eta-equality is off, do we allow pattern matching on the + -- constructor or construction by copattern matching? + -- Having both loses subject reduction, see issue #4560. + -- After positivity checking, this field is obsolete, part of 'EtaEquality'. + , _recInduction :: Maybe Induction + -- ^ 'Inductive' or 'CoInductive'? Matters only for recursive records. + -- 'Nothing' means that the user did not specify it, which is an error + -- for recursive records. + , _recTerminates :: Maybe Bool + -- ^ 'Just True' means that unfolding of the recursive record terminates, + -- 'Just False' means that we have no evidence for termination, + -- and 'Nothing' means we have not run the termination checker yet. + , _recAbstr :: IsAbstract + , _recComp :: CompKit + } deriving (Show, Generic) + +pattern Record + :: Nat + -> Maybe Clause + -> ConHead + -> Bool + -> [Dom QName] + -> Telescope + -> Maybe [QName] + -> EtaEquality + -> PatternOrCopattern + -> Maybe Induction + -> Maybe Bool + -> IsAbstract + -> CompKit + -> Defn + +pattern Record + { recPars + , recClause + , recConHead + , recNamedCon + , recFields + , recTel + , recMutual + , recEtaEquality' + , recPatternMatching + , recInduction + , recTerminates + , recAbstr + , recComp + } = RecordDefn (RecordData + recPars + recClause + recConHead + recNamedCon + recFields + recTel + recMutual + recEtaEquality' + recPatternMatching + recInduction + recTerminates + recAbstr + recComp + ) + +data ConstructorData = ConstructorData + { _conPars :: Int + -- ^ Number of parameters. + , _conArity :: Int + -- ^ Number of arguments (excluding parameters). + , _conSrcCon :: ConHead + -- ^ Name of (original) constructor and fields. (This might be in a module instance.) + , _conData :: QName + -- ^ Name of datatype or record type. + , _conAbstr :: IsAbstract + , _conInd :: Induction + -- ^ Inductive or coinductive? + , _conComp :: CompKit + -- ^ Cubical composition. + , _conProj :: Maybe [QName] + -- ^ Projections. 'Nothing' if not yet computed. + , _conForced :: [IsForced] + -- ^ Which arguments are forced (i.e. determined by the type of the constructor)? + -- Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@. + , _conErased :: Maybe [Bool] + -- ^ Which arguments are erased at runtime (computed during compilation to treeless)? + -- 'True' means erased, 'False' means retained. + -- 'Nothing' if no erasure analysis has been performed yet. + -- The length of the list is @conArity@. + } deriving (Show, Generic) + +pattern Constructor + :: Int + -> Int + -> ConHead + -> QName + -> IsAbstract + -> Induction + -> CompKit + -> Maybe [QName] + -> [IsForced] + -> Maybe [Bool] + -> Defn +pattern Constructor + { conPars + , conArity + , conSrcCon + , conData + , conAbstr + , conInd + , conComp + , conProj + , conForced + , conErased + } = ConstructorDefn (ConstructorData + conPars + conArity + conSrcCon + conData + conAbstr + conInd + conComp + conProj + conForced + conErased + ) + +data PrimitiveData = PrimitiveData + { _primAbstr :: IsAbstract + , _primName :: String + , _primClauses :: [Clause] + -- ^ 'null' for primitive functions, @not null@ for builtin functions. + , _primInv :: FunctionInverse + -- ^ Builtin functions can have inverses. For instance, natural number addition. + , _primCompiled :: Maybe CompiledClauses + -- ^ 'Nothing' for primitive functions, + -- @'Just' something@ for builtin functions. + } deriving (Show, Generic) + +pattern Primitive + :: IsAbstract + -> String + -> [Clause] + -> FunctionInverse + -> Maybe CompiledClauses + -> Defn +pattern Primitive + { primAbstr + , primName + , primClauses + , primInv + , primCompiled + } = PrimitiveDefn (PrimitiveData + primAbstr + primName + primClauses + primInv + primCompiled + ) + +data PrimitiveSortData = PrimitiveSortData + { _primSortName :: String + , _primSortSort :: Sort + } deriving (Show, Generic) + +pattern PrimitiveSort + :: String + -> Sort + -> Defn +pattern PrimitiveSort + { primSortName + , primSortSort + } = PrimitiveSortDefn (PrimitiveSortData + primSortName + primSortSort + ) + +-- TODO: lenses for all Defn variants + +lensFunction :: Lens' FunctionData Defn +lensFunction f = \case + FunctionDefn d -> FunctionDefn <$> f d + _ -> __IMPOSSIBLE__ + +lensConstructor :: Lens' ConstructorData Defn +lensConstructor f = \case + ConstructorDefn d -> ConstructorDefn <$> f d + _ -> __IMPOSSIBLE__ + +lensRecord :: Lens' RecordData Defn +lensRecord f = \case + RecordDefn d -> RecordDefn <$> f d + _ -> __IMPOSSIBLE__ + +-- Lenses for Record + +lensRecTel :: Lens' Telescope RecordData +lensRecTel f r = + f (_recTel r) <&> \ tel -> r { _recTel = tel } + +-- Pretty printing definitions + +instance Pretty Definition where + pretty Defn{..} = + "Defn {" vcat + [ "defArgInfo =" pshow defArgInfo + , "defName =" pretty defName + , "defType =" pretty defType + , "defPolarity =" pshow defPolarity + , "defArgOccurrences =" pshow defArgOccurrences + , "defGeneralizedParams =" pshow defGeneralizedParams + , "defDisplay =" pretty defDisplay + , "defMutual =" pshow defMutual + , "defCompiledRep =" pshow defCompiledRep + , "defInstance =" pshow defInstance + , "defCopy =" pshow defCopy + , "defMatchable =" pshow (Set.toList defMatchable) + , "defInjective =" pshow defInjective + , "defCopatternLHS =" pshow defCopatternLHS + , "theDef =" pretty theDef ] <+> "}" + +instance Pretty Defn where + pretty = \case + AxiomDefn _ -> "Axiom" + DataOrRecSigDefn d -> pretty d + GeneralizableVar -> "GeneralizableVar" + AbstractDefn def -> "AbstractDefn" parens (pretty def) + FunctionDefn d -> pretty d + DatatypeDefn d -> pretty d + RecordDefn d -> pretty d + ConstructorDefn d -> pretty d + PrimitiveDefn d -> pretty d + PrimitiveSortDefn d -> pretty d + +instance Pretty DataOrRecSigData where + pretty (DataOrRecSigData n) = "DataOrRecSig" <+> pretty n + +instance Pretty ProjectionLikenessMissing where + pretty MaybeProjection = "MaybeProjection" + pretty NeverProjection = "NeverProjection" + +instance Pretty FunctionData where + pretty (FunctionData + funClauses + funCompiled + funSplitTree + funTreeless + _funCovering + funInv + funMutual + funAbstr + funDelayed + funProjection + funFlags + funTerminates + _funExtLam + funWith + funIsKanOp + ) = + "Function {" vcat + [ "funClauses =" vcat (map pretty funClauses) + , "funCompiled =" pretty funCompiled + , "funSplitTree =" pretty funSplitTree + , "funTreeless =" pshow funTreeless + , "funInv =" pretty funInv + , "funMutual =" pshow funMutual + , "funAbstr =" pshow funAbstr + , "funDelayed =" pshow funDelayed + , "funProjection =" pretty funProjection + , "funFlags =" pshow funFlags + , "funTerminates =" pshow funTerminates + , "funWith =" pretty funWith + , "funIsKanOp =" pretty funWith + ] "}" + +instance Pretty DatatypeData where + pretty (DatatypeData + dataPars + dataIxs + dataClause + dataCons + dataSort + dataMutual + _dataAbstr + _dataPathCons + _dataTranspIx + _dataTransp + ) = + "Datatype {" vcat + [ "dataPars =" pshow dataPars + , "dataIxs =" pshow dataIxs + , "dataClause =" pretty dataClause + , "dataCons =" pshow dataCons + , "dataSort =" pretty dataSort + , "dataMutual =" pshow dataMutual + , "dataAbstr =" pshow dataAbstr + ] "}" + +instance Pretty RecordData where + pretty (RecordData + recPars + recClause + recConHead + recNamedCon + recFields + recTel + recMutual + recEtaEquality' + _recPatternMatching + recInduction + _recTerminates + recAbstr + _recComp + ) = + "Record {" vcat + [ "recPars =" pshow recPars + , "recClause =" pretty recClause + , "recConHead =" pretty recConHead + , "recNamedCon =" pretty recNamedCon + , "recFields =" pretty recFields + , "recTel =" pretty recTel + , "recMutual =" pshow recMutual + , "recEtaEquality' =" pshow recEtaEquality' + , "recInduction =" pshow recInduction + , "recAbstr =" pshow recAbstr + ] "}" + +instance Pretty ConstructorData where + pretty (ConstructorData + conPars + conArity + conSrcCon + conData + conAbstr + conInd + _conComp + _conProj + _conForced + conErased + ) = + "Constructor {" vcat + [ "conPars =" pshow conPars + , "conArity =" pshow conArity + , "conSrcCon =" pretty conSrcCon + , "conData =" pretty conData + , "conAbstr =" pshow conAbstr + , "conInd =" pshow conInd + , "conErased =" pshow conErased + ] "}" + +instance Pretty PrimitiveData where + pretty (PrimitiveData + primAbstr + primName + primClauses + _primInv + primCompiled + ) = + "Primitive {" vcat + [ "primAbstr =" pshow primAbstr + , "primName =" pshow primName + , "primClauses =" pshow primClauses + , "primCompiled =" pshow primCompiled + ] "}" + +instance Pretty PrimitiveSortData where + pretty (PrimitiveSortData primSortName primSortSort) = + "PrimitiveSort {" vcat + [ "primSortName =" pshow primSortName + , "primSortSort =" pshow primSortSort + ] "}" + +instance Pretty Projection where + pretty Projection{..} = + "Projection {" vcat + [ "projProper =" pretty projProper + , "projOrig =" pretty projOrig + , "projFromType =" pretty projFromType + , "projIndex =" pshow projIndex + , "projLams =" pretty projLams + ] + +instance Pretty c => Pretty (FunctionInverse' c) where + pretty NotInjective = "NotInjective" + pretty (Inverse inv) = "Inverse" + vcat [ pretty h <+> "->" pretty cs + | (h, cs) <- Map.toList inv ] + +instance Pretty ProjLams where + pretty (ProjLams args) = pretty args + +-- | Is the record type recursive? +recRecursive :: Defn -> Bool +recRecursive (Record { recMutual = Just qs }) = not $ null qs +recRecursive _ = __IMPOSSIBLE__ + +recEtaEquality :: Defn -> HasEta +recEtaEquality = theEtaEquality . recEtaEquality' + +-- | A template for creating 'Function' definitions, with sensible defaults. +emptyFunctionData :: FunctionData +emptyFunctionData = FunctionData + { _funClauses = [] + , _funCompiled = Nothing + , _funSplitTree = Nothing + , _funTreeless = Nothing + , _funInv = NotInjective + , _funMutual = Nothing + , _funAbstr = ConcreteDef + , _funDelayed = NotDelayed + , _funProjection = Left MaybeProjection + , _funFlags = Set.empty + , _funTerminates = Nothing + , _funExtLam = Nothing + , _funWith = Nothing + , _funCovering = [] + , _funIsKanOp = Nothing + } + +emptyFunction :: Defn +emptyFunction = FunctionDefn emptyFunctionData + +funFlag :: FunctionFlag -> Lens' Bool Defn +funFlag flag f def@Function{ funFlags = flags } = + f (Set.member flag flags) <&> + \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags } +funFlag _ f def = f False $> def + +funStatic, funInline, funMacro :: Lens' Bool Defn +funStatic = funFlag FunStatic +funInline = funFlag FunInline +funMacro = funFlag FunMacro + +isMacro :: Defn -> Bool +isMacro = (^. funMacro) + +-- | Checking whether we are dealing with a function yet to be defined. +isEmptyFunction :: Defn -> Bool +isEmptyFunction def = + case def of + Function { funClauses = [] } -> True + _ -> False + +isCopatternLHS :: [Clause] -> Bool +isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats) + +recCon :: Defn -> QName +recCon Record{ recConHead } = conName recConHead +recCon _ = __IMPOSSIBLE__ + +defIsRecord :: Defn -> Bool +defIsRecord Record{} = True +defIsRecord _ = False + +defIsDataOrRecord :: Defn -> Bool +defIsDataOrRecord Record{} = True +defIsDataOrRecord Datatype{} = True +defIsDataOrRecord _ = False + +defConstructors :: Defn -> [QName] +defConstructors Datatype{dataCons = cs} = cs +defConstructors Record{recConHead = c} = [conName c] +defConstructors _ = __IMPOSSIBLE__ + +newtype Fields = Fields [(C.Name, Type)] + deriving Null + +-- | Did we encounter a simplifying reduction? +-- In terms of CIC, that would be a iota-reduction. +-- In terms of Agda, this is a constructor or literal +-- pattern that matched. +-- Just beta-reduction (substitution) or delta-reduction +-- (unfolding of definitions) does not count as simplifying? + +data Simplification = YesSimplification | NoSimplification + deriving (Eq, Show, Generic) + +instance Null Simplification where + empty = NoSimplification + null = (== NoSimplification) + +instance Semigroup Simplification where + YesSimplification <> _ = YesSimplification + NoSimplification <> s = s + +instance Monoid Simplification where + mempty = NoSimplification + mappend = (<>) + +data Reduced no yes + = NoReduction no + | YesReduction Simplification yes + deriving Functor + +redReturn :: a -> ReduceM (Reduced a' a) +redReturn = return . YesReduction YesSimplification + +-- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@ + +redBind :: ReduceM (Reduced a a') -> (a -> b) -> + (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b') +redBind ma f k = do + r <- ma + case r of + NoReduction x -> return $ NoReduction $ f x + YesReduction _ y -> k y + +-- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked. +data IsReduced + = NotReduced + | Reduced (Blocked ()) + +data MaybeReduced a = MaybeRed + { isReduced :: IsReduced + , ignoreReduced :: a + } + deriving (Functor) + +instance IsProjElim e => IsProjElim (MaybeReduced e) where + isProjElim = isProjElim . ignoreReduced + +type MaybeReducedArgs = [MaybeReduced (Arg Term)] +type MaybeReducedElims = [MaybeReduced Elim] + +notReduced :: a -> MaybeReduced a +notReduced x = MaybeRed NotReduced x + +reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term) +reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b + +-- | Controlling 'reduce'. +data AllowedReduction + = ProjectionReductions -- ^ (Projection and) projection-like functions may be reduced. + | InlineReductions -- ^ Functions marked INLINE may be reduced. + | CopatternReductions -- ^ Copattern definitions may be reduced. + | FunctionReductions -- ^ Non-recursive functions and primitives may be reduced. + | RecursiveReductions -- ^ Even recursive functions may be reduced. + | LevelReductions -- ^ Reduce @'Level'@ terms. + | TypeLevelReductions -- ^ Allow @allReductions@ in types, even + -- if not allowed at term level (used + -- by confluence checker) + | UnconfirmedReductions -- ^ Functions whose termination has not (yet) been confirmed. + | NonTerminatingReductions -- ^ Functions that have failed termination checking. + deriving (Show, Eq, Ord, Enum, Bounded, Ix, Generic) + +type AllowedReductions = SmallSet AllowedReduction + +-- | Not quite all reductions (skip non-terminating reductions) +allReductions :: AllowedReductions +allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions + +reallyAllReductions :: AllowedReductions +reallyAllReductions = SmallSet.total + +data ReduceDefs + = OnlyReduceDefs (Set QName) + | DontReduceDefs (Set QName) + deriving Generic + +reduceAllDefs :: ReduceDefs +reduceAllDefs = DontReduceDefs empty + +locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a +locallyReduceDefs = locallyTC eReduceDefs . const + +locallyReduceAllDefs :: MonadTCEnv m => m a -> m a +locallyReduceAllDefs = locallyReduceDefs reduceAllDefs + +shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool +shouldReduceDef f = asksTC envReduceDefs <&> \case + OnlyReduceDefs defs -> f `Set.member` defs + DontReduceDefs defs -> not $ f `Set.member` defs + +instance Semigroup ReduceDefs where + OnlyReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.intersection qs1 qs2 + OnlyReduceDefs qs1 <> DontReduceDefs qs2 = OnlyReduceDefs $ Set.difference qs1 qs2 + DontReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.difference qs2 qs1 + DontReduceDefs qs1 <> DontReduceDefs qs2 = DontReduceDefs $ Set.union qs1 qs2 + +instance Monoid ReduceDefs where + mempty = reduceAllDefs + mappend = (<>) + + +locallyReconstructed :: MonadTCEnv m => m a -> m a +locallyReconstructed = locallyTC eReconstructed . const $ True + +isReconstructed :: (MonadTCEnv m) => m Bool +isReconstructed = asksTC envReconstructed + +-- | Primitives + +data PrimitiveImpl = PrimImpl Type PrimFun + +data PrimFun = PrimFun + { primFunName :: QName + , primFunArity :: Arity + , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term) + } + deriving Generic + +primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun +primFun q ar imp = PrimFun q ar (\ args _ -> imp args) + +defClauses :: Definition -> [Clause] +defClauses Defn{theDef = Function{funClauses = cs}} = cs +defClauses Defn{theDef = Primitive{primClauses = cs}} = cs +defClauses Defn{theDef = Datatype{dataClause = Just c}} = [c] +defClauses Defn{theDef = Record{recClause = Just c}} = [c] +defClauses _ = [] + +defCompiled :: Definition -> Maybe CompiledClauses +defCompiled Defn{theDef = Function {funCompiled = mcc}} = mcc +defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc +defCompiled _ = Nothing + +defParameters :: Definition -> Maybe Nat +defParameters Defn{theDef = Datatype{dataPars = n}} = Just n +defParameters Defn{theDef = Record {recPars = n}} = Just n +defParameters _ = Nothing + +defInverse :: Definition -> FunctionInverse +defInverse Defn{theDef = Function { funInv = inv }} = inv +defInverse Defn{theDef = Primitive{ primInv = inv }} = inv +defInverse _ = NotInjective + +defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma] +defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep + -- reversed because we add new pragmas to the front of the list + +-- | Are the clauses of this definition delayed? +defDelayed :: Definition -> Delayed +defDelayed Defn{theDef = Function{funDelayed = d}} = d +defDelayed _ = NotDelayed + +-- | Has the definition failed the termination checker? +defNonterminating :: Definition -> Bool +defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True +defNonterminating _ = False + +-- | Has the definition not termination checked or did the check fail? +defTerminationUnconfirmed :: Definition -> Bool +defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False +defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _ }} = True +defTerminationUnconfirmed _ = False + +defAbstract :: Definition -> IsAbstract +defAbstract d = case theDef d of + Axiom{} -> ConcreteDef + DataOrRecSig{} -> ConcreteDef + GeneralizableVar{} -> ConcreteDef + AbstractDefn{} -> AbstractDef + Function{funAbstr = a} -> a + Datatype{dataAbstr = a} -> a + Record{recAbstr = a} -> a + Constructor{conAbstr = a} -> a + Primitive{primAbstr = a} -> a + PrimitiveSort{} -> ConcreteDef + +defForced :: Definition -> [IsForced] +defForced d = case theDef d of + Constructor{conForced = fs} -> fs + Axiom{} -> [] + DataOrRecSig{} -> [] + GeneralizableVar{} -> [] + AbstractDefn{} -> [] + Function{} -> [] + Datatype{} -> [] + Record{} -> [] + Primitive{} -> [] + PrimitiveSort{} -> [] + +--------------------------------------------------------------------------- +-- ** Injectivity +--------------------------------------------------------------------------- + +type FunctionInverse = FunctionInverse' Clause +type InversionMap c = Map TermHead [c] + +data FunctionInverse' c + = NotInjective + | Inverse (InversionMap c) + deriving (Show, Functor, Generic) + +data TermHead = SortHead + | PiHead + | ConsHead QName + | VarHead Nat + | UnknownHead + deriving (Eq, Ord, Show, Generic) + +instance Pretty TermHead where + pretty = \ case + SortHead -> "SortHead" + PiHead -> "PiHead" + ConsHead q -> "ConsHead" <+> pretty q + VarHead i -> text ("VarHead " ++ show i) + UnknownHead -> "UnknownHead" + +--------------------------------------------------------------------------- +-- ** Mutual blocks +--------------------------------------------------------------------------- + +newtype MutualId = MutId Int32 + deriving (Eq, Ord, Show, Num, Enum, NFData) + +--------------------------------------------------------------------------- +-- ** Statistics +--------------------------------------------------------------------------- + +type Statistics = Map String Integer + +--------------------------------------------------------------------------- +-- ** Trace +--------------------------------------------------------------------------- + +data Call + = CheckClause Type A.SpineClause + | CheckLHS A.SpineLHS + | CheckPattern A.Pattern Telescope Type + | CheckPatternLinearityType C.Name + | CheckPatternLinearityValue C.Name + | CheckLetBinding A.LetBinding + | InferExpr A.Expr + | CheckExprCall Comparison A.Expr Type + | CheckDotPattern A.Expr Term + | CheckProjection Range QName Type + | IsTypeCall Comparison A.Expr Sort + | IsType_ A.Expr + | InferVar Name + | InferDef QName + | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type) + | CheckMetaSolution Range MetaId Type Term + | CheckTargetType Range Type Type + | CheckDataDef Range QName [A.LamBinding] [A.Constructor] + | CheckRecDef Range QName [A.LamBinding] [A.Constructor] + | CheckConstructor QName Telescope Sort A.Constructor + | CheckConstructorFitsIn QName Type Sort + | CheckFunDefCall Range QName [A.Clause] Bool + -- ^ Highlight (interactively) if and only if the boolean is 'True'. + | CheckPragma Range A.Pragma + | CheckPrimitive Range QName A.Expr + | CheckIsEmpty Range Type + | CheckConfluence QName QName + | CheckWithFunctionType Type + | CheckSectionApplication Range ModuleName A.ModuleApplication + | CheckNamedWhere ModuleName + -- | Checking a clause for confluence with endpoint reductions. Always + -- @φ ⊢ f vs = rhs@ for now, but we store the simplifications of + -- @f vs[φ]@ and @rhs[φ]@. + | CheckIApplyConfluence + Range -- ^ Clause range + QName -- ^ Function name + Term -- ^ (As-is) Function applied to the patterns in this clause + Term -- ^ (Simplified) Function applied to the patterns in this clause + Term -- ^ (Simplified) clause RHS + Type -- ^ (Simplified) clause type + | ScopeCheckExpr C.Expr + | ScopeCheckDeclaration NiceDeclaration + | ScopeCheckLHS C.QName C.Pattern + | NoHighlighting + | ModuleContents -- ^ Interaction command: show module contents. + | SetRange Range -- ^ used by 'setCurrentRange' + deriving Generic + +instance Pretty Call where + pretty CheckClause{} = "CheckClause" + pretty CheckLHS{} = "CheckLHS" + pretty CheckPattern{} = "CheckPattern" + pretty CheckPatternLinearityType{} = "CheckPatternLinearityType" + pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue" + pretty InferExpr{} = "InferExpr" + pretty CheckExprCall{} = "CheckExprCall" + pretty CheckLetBinding{} = "CheckLetBinding" + pretty CheckProjection{} = "CheckProjection" + pretty IsTypeCall{} = "IsTypeCall" + pretty IsType_{} = "IsType_" + pretty InferVar{} = "InferVar" + pretty InferDef{} = "InferDef" + pretty CheckArguments{} = "CheckArguments" + pretty CheckMetaSolution{} = "CheckMetaSolution" + pretty CheckTargetType{} = "CheckTargetType" + pretty CheckDataDef{} = "CheckDataDef" + pretty CheckRecDef{} = "CheckRecDef" + pretty CheckConstructor{} = "CheckConstructor" + pretty CheckConstructorFitsIn{} = "CheckConstructorFitsIn" + pretty CheckFunDefCall{} = "CheckFunDefCall" + pretty CheckPragma{} = "CheckPragma" + pretty CheckPrimitive{} = "CheckPrimitive" + pretty CheckWithFunctionType{} = "CheckWithFunctionType" + pretty CheckNamedWhere{} = "CheckNamedWhere" + pretty ScopeCheckExpr{} = "ScopeCheckExpr" + pretty ScopeCheckDeclaration{} = "ScopeCheckDeclaration" + pretty ScopeCheckLHS{} = "ScopeCheckLHS" + pretty CheckDotPattern{} = "CheckDotPattern" + pretty SetRange{} = "SetRange" + pretty CheckSectionApplication{} = "CheckSectionApplication" + pretty CheckIsEmpty{} = "CheckIsEmpty" + pretty CheckConfluence{} = "CheckConfluence" + pretty NoHighlighting{} = "NoHighlighting" + pretty ModuleContents{} = "ModuleContents" + pretty CheckIApplyConfluence{} = "ModuleContents" + +instance HasRange Call where + getRange (CheckClause _ c) = getRange c + getRange (CheckLHS lhs) = getRange lhs + getRange (CheckPattern p _ _) = getRange p + getRange (CheckPatternLinearityType x) = getRange x + getRange (CheckPatternLinearityValue x) = getRange x + getRange (InferExpr e) = getRange e + getRange (CheckExprCall _ e _) = getRange e + getRange (CheckLetBinding b) = getRange b + getRange (CheckProjection r _ _) = r + getRange (IsTypeCall cmp e s) = getRange e + getRange (IsType_ e) = getRange e + getRange (InferVar x) = getRange x + getRange (InferDef f) = getRange f + getRange (CheckArguments r _ _ _) = r + getRange (CheckMetaSolution r _ _ _) = r + getRange (CheckTargetType r _ _) = r + getRange (CheckDataDef i _ _ _) = getRange i + getRange (CheckRecDef i _ _ _) = getRange i + getRange (CheckConstructor _ _ _ c) = getRange c + getRange (CheckConstructorFitsIn c _ _) = getRange c + getRange (CheckFunDefCall i _ _ _) = getRange i + getRange (CheckPragma r _) = r + getRange (CheckPrimitive i _ _) = getRange i + getRange CheckWithFunctionType{} = noRange + getRange (CheckNamedWhere m) = getRange m + getRange (ScopeCheckExpr e) = getRange e + getRange (ScopeCheckDeclaration d) = getRange d + getRange (ScopeCheckLHS _ p) = getRange p + getRange (CheckDotPattern e _) = getRange e + getRange (SetRange r) = r + getRange (CheckSectionApplication r _ _) = r + getRange (CheckIsEmpty r _) = r + getRange (CheckConfluence rule1 rule2) = max (getRange rule1) (getRange rule2) + getRange NoHighlighting = noRange + getRange ModuleContents = noRange + getRange (CheckIApplyConfluence e _ _ _ _ _) = getRange e + +--------------------------------------------------------------------------- +-- ** Instance table +--------------------------------------------------------------------------- + +-- | The instance table is a @Map@ associating to every name of +-- record/data type/postulate its list of instances +type InstanceTable = Map QName (Set QName) + +-- | When typechecking something of the following form: +-- +-- instance +-- x : _ +-- x = y +-- +-- it's not yet known where to add @x@, so we add it to a list of +-- unresolved instances and we'll deal with it later. +type TempInstanceTable = (InstanceTable , Set QName) + +--------------------------------------------------------------------------- +-- ** Builtin things +--------------------------------------------------------------------------- + +data BuiltinDescriptor + = BuiltinData (TCM Type) [String] + | BuiltinDataCons (TCM Type) + | BuiltinPrim String (Term -> TCM ()) + | BuiltinSort String + | BuiltinPostulate Relevance (TCM Type) + | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ()) + -- ^ Builtin of any kind. + -- Type can be checked (@Just t@) or inferred (@Nothing@). + -- The second argument is the hook for the verification function. + +data BuiltinInfo = + BuiltinInfo { builtinName :: String + , builtinDesc :: BuiltinDescriptor } + +type BuiltinThings pf = Map String (Builtin pf) + +data Builtin pf + = Builtin Term + | Prim pf + | BuiltinRewriteRelations (Set QName) + -- ^ @BUILTIN REWRITE@. We can have several rewrite relations. + deriving (Show, Functor, Foldable, Traversable, Generic) + +--------------------------------------------------------------------------- +-- * Highlighting levels +--------------------------------------------------------------------------- + +-- | How much highlighting should be sent to the user interface? + +data HighlightingLevel + = None + | NonInteractive + | Interactive + -- ^ This includes both non-interactive highlighting and + -- interactive highlighting of the expression that is currently + -- being type-checked. + deriving (Eq, Ord, Show, Read, Generic) + +-- | How should highlighting be sent to the user interface? + +data HighlightingMethod + = Direct + -- ^ Via stdout. + | Indirect + -- ^ Both via files and via stdout. + deriving (Eq, Show, Read, Generic) + +-- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're +-- type-checking the top-level module (or before we've started doing +-- this) and either the highlighting level is /at least/ @l@ or @b@ is +-- 'True'. + +ifTopLevelAndHighlightingLevelIsOr :: + MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm () +ifTopLevelAndHighlightingLevelIsOr l b m = do + e <- askTC + when (envHighlightingLevel e >= l || b) $ + case (envImportPath e) of + -- Below the main module. + (_:_:_) -> pure () + -- In or before the top-level module. + _ -> m + +-- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're +-- type-checking the top-level module (or before we've started doing +-- this) and the highlighting level is /at least/ @l@. + +ifTopLevelAndHighlightingLevelIs :: + MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm () +ifTopLevelAndHighlightingLevelIs l = + ifTopLevelAndHighlightingLevelIsOr l False + +--------------------------------------------------------------------------- +-- * Type checking environment +--------------------------------------------------------------------------- + +data TCEnv = + TCEnv { envContext :: Context + , envLetBindings :: LetBindings + , envCurrentModule :: ModuleName + , envCurrentPath :: Maybe AbsolutePath + -- ^ The path to the file that is currently being + -- type-checked. 'Nothing' if we do not have a file + -- (like in interactive mode see @CommandLine@). + , envAnonymousModules :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables + , envImportPath :: [TopLevelModuleName] + -- ^ The module stack with the entry being the top-level module as + -- Agda chases modules. It will be empty if there is no main + -- module, will have a single entry for the top level module, or + -- more when descending past the main module. This is used to + -- detect import cycles and in some cases highlighting behavior. + -- The level of a given module is not necessarily the same as the + -- length, in the module dependency graph, of the shortest path + -- from the top-level module; it depends on in which order Agda + -- chooses to chase dependencies. + , envMutualBlock :: Maybe MutualId -- ^ the current (if any) mutual block + , envTerminationCheck :: TerminationCheck () -- ^ are we inside the scope of a termination pragma + , envCoverageCheck :: CoverageCheck -- ^ are we inside the scope of a coverage pragma + , envMakeCase :: Bool -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier) + , envSolvingConstraints :: Bool + -- ^ Are we currently in the process of solving active constraints? + , envCheckingWhere :: Bool + -- ^ Have we stepped into the where-declarations of a clause? + -- Everything under a @where@ will be checked with this flag on. + , envWorkingOnTypes :: Bool + -- ^ Are we working on types? Turned on by 'workOnTypes'. + , envAssignMetas :: Bool + -- ^ Are we allowed to assign metas? + , envActiveProblems :: Set ProblemId + , envAbstractMode :: AbstractMode + -- ^ When checking the typesignature of a public definition + -- or the body of a non-abstract definition this is true. + -- To prevent information about abstract things leaking + -- outside the module. + , envModality :: Modality + -- ^ 'Relevance' component: + -- Are we checking an irrelevant argument? (=@Irrelevant@) + -- Then top-level irrelevant declarations are enabled. + -- Other value: @Relevant@, then only relevant decls. are available. + -- + -- 'Quantity' component: + -- Are we checking a runtime-irrelevant thing? (='Quantity0') + -- Then runtime-irrelevant things are usable. + -- Other value: @Quantity1@, runtime relevant. + -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018. + , envSplitOnStrict :: Bool + -- ^ Are we currently case-splitting on a strict + -- datatype (i.e. in SSet)? If yes, the + -- pattern-matching unifier will solve reflexive + -- equations even --without-K. + , envDisplayFormsEnabled :: Bool + -- ^ Sometimes we want to disable display forms. + , envRange :: Range + , envHighlightingRange :: Range + -- ^ Interactive highlighting uses this range rather + -- than 'envRange'. + , envClause :: IPClause + -- ^ What is the current clause we are type-checking? + -- Will be recorded in interaction points in this clause. + , envCall :: Maybe (Closure Call) + -- ^ what we're doing at the moment + , envHighlightingLevel :: HighlightingLevel + -- ^ Set to 'None' when imported modules are + -- type-checked. + , envHighlightingMethod :: HighlightingMethod + , envExpandLast :: ExpandHidden + -- ^ When type-checking an alias f=e, we do not want + -- to insert hidden arguments in the end, because + -- these will become unsolved metas. + , envAppDef :: Maybe QName + -- ^ We are reducing an application of this function. + -- (For tracking of incomplete matches.) + , envSimplification :: Simplification + -- ^ Did we encounter a simplification (proper match) + -- during the current reduction process? + , envAllowedReductions :: AllowedReductions + , envReduceDefs :: ReduceDefs + , envReconstructed :: Bool + , envInjectivityDepth :: Int + -- ^ Injectivity can cause non-termination for unsolvable contraints + -- (#431, #3067). Keep a limit on the nesting depth of injectivity + -- uses. + , envCompareBlocked :: Bool + -- ^ When @True@, the conversion checker will consider + -- all term constructors as injective, including + -- blocked function applications and metas. Warning: + -- this should only be used when not assigning any + -- metas (e.g. when @envAssignMetas@ is @False@ or + -- when running @pureEqualTerms@) or else we get + -- non-unique meta solutions. + , envPrintDomainFreePi :: Bool + -- ^ When @True@, types will be omitted from printed pi types if they + -- can be inferred. + , envPrintMetasBare :: Bool + -- ^ When @True@, throw away meta numbers and meta elims. + -- This is used for reifying terms for feeding into the + -- user's source code, e.g., for the interaction tactics @solveAll@. + , envInsideDotPattern :: Bool + -- ^ Used by the scope checker to make sure that certain forms + -- of expressions are not used inside dot patterns: extended + -- lambdas and let-expressions. + , envUnquoteFlags :: UnquoteFlags + , envInstanceDepth :: !Int + -- ^ Until we get a termination checker for instance search (#1743) we + -- limit the search depth to ensure termination. + , envIsDebugPrinting :: Bool + , envPrintingPatternLambdas :: [QName] + -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We + -- don't have a good story for what to do in this case, but at least + -- printing shouldn't loop. Here we keep track of which pattern lambdas + -- we are currently in the process of printing. + , envCallByNeed :: Bool + -- ^ Use call-by-need evaluation for reductions. + , envCurrentCheckpoint :: CheckpointId + -- ^ Checkpoints track the evolution of the context as we go + -- under binders or refine it by pattern matching. + , envCheckpoints :: Map CheckpointId Substitution + -- ^ Keeps the substitution from each previous checkpoint to + -- the current context. + , envGeneralizeMetas :: DoGeneralize + -- ^ Should new metas generalized over. + , envGeneralizedVars :: Map QName GeneralizedValue + -- ^ Values for used generalizable variables. + , envActiveBackendName :: Maybe BackendName + -- ^ Is some backend active at the moment, and if yes, which? + -- NB: we only store the 'BackendName' here, otherwise + -- @instance Data TCEnv@ is not derivable. + -- The actual backend can be obtained from the name via 'stBackends'. + , envConflComputingOverlap :: Bool + -- ^ Are we currently computing the overlap between + -- two rewrite rules for the purpose of confluence checking? + , envCurrentlyElaborating :: Bool + -- ^ Are we currently in the process of executing an + -- elaborate-and-give interactive command? + , envSyntacticEqualityFuel :: !(Strict.Maybe Int) + -- ^ If this counter is 'Strict.Nothing', then + -- syntactic equality checking is unrestricted. If it + -- is zero, then syntactic equality checking is not + -- run at all. If it is a positive number, then + -- syntactic equality checking is allowed to run, but + -- the counter is decreased in the failure + -- continuation of + -- 'Agda.TypeChecking.SyntacticEquality.checkSyntacticEquality'. + } + deriving (Generic) + +initEnv :: TCEnv +initEnv = TCEnv { envContext = [] + , envLetBindings = Map.empty + , envCurrentModule = noModuleName + , envCurrentPath = Nothing + , envAnonymousModules = [] + , envImportPath = [] + , envMutualBlock = Nothing + , envTerminationCheck = TerminationCheck + , envCoverageCheck = YesCoverageCheck + , envMakeCase = False + , envSolvingConstraints = False + , envCheckingWhere = False + , envActiveProblems = Set.empty + , envWorkingOnTypes = False + , envAssignMetas = True + , envAbstractMode = ConcreteMode + -- Andreas, 2013-02-21: This was 'AbstractMode' until now. + -- However, top-level checks for mutual blocks, such as + -- constructor-headedness, should not be able to look into + -- abstract definitions unless abstract themselves. + -- (See also discussion on issue 796.) + -- The initial mode should be 'ConcreteMode', ensuring you + -- can only look into abstract things in an abstract + -- definition (which sets 'AbstractMode'). + , envModality = unitModality + , envSplitOnStrict = False + , envDisplayFormsEnabled = True + , envRange = noRange + , envHighlightingRange = noRange + , envClause = IPNoClause + , envCall = Nothing + , envHighlightingLevel = None + , envHighlightingMethod = Indirect + , envExpandLast = ExpandLast + , envAppDef = Nothing + , envSimplification = NoSimplification + , envAllowedReductions = allReductions + , envReduceDefs = reduceAllDefs + , envReconstructed = False + , envInjectivityDepth = 0 + , envCompareBlocked = False + , envPrintDomainFreePi = False + , envPrintMetasBare = False + , envInsideDotPattern = False + , envUnquoteFlags = defaultUnquoteFlags + , envInstanceDepth = 0 + , envIsDebugPrinting = False + , envPrintingPatternLambdas = [] + , envCallByNeed = True + , envCurrentCheckpoint = 0 + , envCheckpoints = Map.singleton 0 IdS + , envGeneralizeMetas = NoGeneralize + , envGeneralizedVars = Map.empty + , envActiveBackendName = Nothing + , envConflComputingOverlap = False + , envCurrentlyElaborating = False + , envSyntacticEqualityFuel = Strict.Nothing + } + +class LensTCEnv a where + lensTCEnv :: Lens' TCEnv a + +instance LensTCEnv TCEnv where + lensTCEnv = id + +instance LensModality TCEnv where + -- Cohesion shouldn't have an environment component. + getModality = setCohesion defaultCohesion . envModality + mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e } + +instance LensRelevance TCEnv where +instance LensQuantity TCEnv where + +data UnquoteFlags = UnquoteFlags + { _unquoteNormalise :: Bool } + deriving Generic + +defaultUnquoteFlags :: UnquoteFlags +defaultUnquoteFlags = UnquoteFlags + { _unquoteNormalise = False } + +unquoteNormalise :: Lens' Bool UnquoteFlags +unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x } + +eUnquoteNormalise :: Lens' Bool TCEnv +eUnquoteNormalise = eUnquoteFlags . unquoteNormalise + +-- * e-prefixed lenses +------------------------------------------------------------------------ + +eContext :: Lens' Context TCEnv +eContext f e = f (envContext e) <&> \ x -> e { envContext = x } + +eLetBindings :: Lens' LetBindings TCEnv +eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x } + +eCurrentModule :: Lens' ModuleName TCEnv +eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x } + +eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv +eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x } + +eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv +eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x } + +eImportPath :: Lens' [TopLevelModuleName] TCEnv +eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x } + +eMutualBlock :: Lens' (Maybe MutualId) TCEnv +eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x } + +eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv +eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x } + +eCoverageCheck :: Lens' CoverageCheck TCEnv +eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x } + +eMakeCase :: Lens' Bool TCEnv +eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x } + +eSolvingConstraints :: Lens' Bool TCEnv +eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x } + +eCheckingWhere :: Lens' Bool TCEnv +eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x } + +eWorkingOnTypes :: Lens' Bool TCEnv +eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x } + +eAssignMetas :: Lens' Bool TCEnv +eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x } + +eActiveProblems :: Lens' (Set ProblemId) TCEnv +eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x } + +eAbstractMode :: Lens' AbstractMode TCEnv +eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x } + +-- Andrea 23/02/2020: use get/setModality to enforce invariants of the +-- envModality field. +eModality :: Lens' Modality TCEnv +eModality f e = f (getModality e) <&> \ x -> setModality x e + +eRelevance :: Lens' Relevance TCEnv +eRelevance = eModality . lModRelevance + +eQuantity :: Lens' Quantity TCEnv +eQuantity = eModality . lModQuantity + +eSplitOnStrict :: Lens' Bool TCEnv +eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x } + +eDisplayFormsEnabled :: Lens' Bool TCEnv +eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x } + +eRange :: Lens' Range TCEnv +eRange f e = f (envRange e) <&> \ x -> e { envRange = x } + +eHighlightingRange :: Lens' Range TCEnv +eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x } + +eCall :: Lens' (Maybe (Closure Call)) TCEnv +eCall f e = f (envCall e) <&> \ x -> e { envCall = x } + +eHighlightingLevel :: Lens' HighlightingLevel TCEnv +eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x } + +eHighlightingMethod :: Lens' HighlightingMethod TCEnv +eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x } + +eExpandLast :: Lens' ExpandHidden TCEnv +eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x } + +eAppDef :: Lens' (Maybe QName) TCEnv +eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x } + +eSimplification :: Lens' Simplification TCEnv +eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x } + +eAllowedReductions :: Lens' AllowedReductions TCEnv +eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x } + +eReduceDefs :: Lens' ReduceDefs TCEnv +eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x } + +eReconstructed :: Lens' Bool TCEnv +eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x } + +eInjectivityDepth :: Lens' Int TCEnv +eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x } + +eCompareBlocked :: Lens' Bool TCEnv +eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x } + +ePrintDomainFreePi :: Lens' Bool TCEnv +ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x } + +ePrintMetasBare :: Lens' Bool TCEnv +ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x } + +eInsideDotPattern :: Lens' Bool TCEnv +eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x } + +eUnquoteFlags :: Lens' UnquoteFlags TCEnv +eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x } + +eInstanceDepth :: Lens' Int TCEnv +eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x } + +eIsDebugPrinting :: Lens' Bool TCEnv +eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x } + +ePrintingPatternLambdas :: Lens' [QName] TCEnv +ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x } + +eCallByNeed :: Lens' Bool TCEnv +eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x } + +eCurrentCheckpoint :: Lens' CheckpointId TCEnv +eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x } + +eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv +eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x } + +eGeneralizeMetas :: Lens' DoGeneralize TCEnv +eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x } + +eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv +eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x } + +eActiveBackendName :: Lens' (Maybe BackendName) TCEnv +eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x } + +eConflComputingOverlap :: Lens' Bool TCEnv +eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x } + +eCurrentlyElaborating :: Lens' Bool TCEnv +eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x } + +--------------------------------------------------------------------------- +-- ** Context +--------------------------------------------------------------------------- + +-- | The @Context@ is a stack of 'ContextEntry's. +type Context = [ContextEntry] +type ContextEntry = Dom (Name, Type) + +--------------------------------------------------------------------------- +-- ** Let bindings +--------------------------------------------------------------------------- + +type LetBindings = Map Name (Open (Term, Dom Type)) + +--------------------------------------------------------------------------- +-- ** Abstract mode +--------------------------------------------------------------------------- + +data AbstractMode + = AbstractMode -- ^ Abstract things in the current module can be accessed. + | ConcreteMode -- ^ No abstract things can be accessed. + | IgnoreAbstractMode -- ^ All abstract things can be accessed. + deriving (Show, Eq, Generic) + +aDefToMode :: IsAbstract -> AbstractMode +aDefToMode AbstractDef = AbstractMode +aDefToMode ConcreteDef = ConcreteMode + +aModeToDef :: AbstractMode -> Maybe IsAbstract +aModeToDef AbstractMode = Just AbstractDef +aModeToDef ConcreteMode = Just ConcreteDef +aModeToDef _ = Nothing + +--------------------------------------------------------------------------- +-- ** Insertion of implicit arguments +--------------------------------------------------------------------------- + +data ExpandHidden + = ExpandLast -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'. + | DontExpandLast -- ^ Do not append implicit arguments. + | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables. + deriving (Eq, Generic) + +isDontExpandLast :: ExpandHidden -> Bool +isDontExpandLast ExpandLast = False +isDontExpandLast DontExpandLast = True +isDontExpandLast ReallyDontExpandLast = True + +data CandidateKind + = LocalCandidate + | GlobalCandidate QName + deriving (Show, Generic) + +-- | A candidate solution for an instance meta is a term with its type. +-- It may be the case that the candidate is not fully applied yet or +-- of the wrong type, hence the need for the type. +data Candidate = Candidate { candidateKind :: CandidateKind + , candidateTerm :: Term + , candidateType :: Type + , candidateOverlappable :: Bool + } + deriving (Show, Generic) + +instance Free Candidate where + freeVars' (Candidate _ t u _) = freeVars' (t, u) + + +--------------------------------------------------------------------------- +-- ** Checking arguments +--------------------------------------------------------------------------- + +data ArgsCheckState a = ACState + { acRanges :: [Maybe Range] + -- ^ Ranges of checked arguments, where present. + -- e.g. inserted implicits have no correponding abstract syntax. + , acElims :: Elims + -- ^ Checked and inserted arguments so far. + , acConstraints :: [Maybe (Abs Constraint)] + -- ^ Constraints for the head so far, + -- i.e. before applying the correponding elim. + , acType :: Type + -- ^ Type for the rest of the application. + , acData :: a + } + deriving (Show) + + +--------------------------------------------------------------------------- +-- * Type checking warnings (aka non-fatal errors) +--------------------------------------------------------------------------- + +-- | A non-fatal error is an error which does not prevent us from +-- checking the document further and interacting with the user. + +data Warning + = NicifierIssue DeclarationWarning + | TerminationIssue [TerminationError] + | UnreachableClauses QName [Range] + -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs + -- are unreachable + | CoverageIssue QName [(Telescope, [NamedArg DeBruijnPattern])] + -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f` + | CoverageNoExactSplit QName [Clause] + | NotStrictlyPositive QName (Seq OccursWhere) + | UnsolvedMetaVariables [Range] -- ^ Do not use directly with 'warning' + | UnsolvedInteractionMetas [Range] -- ^ Do not use directly with 'warning' + | UnsolvedConstraints Constraints + -- ^ Do not use directly with 'warning' + | CantGeneralizeOverSorts [MetaId] + | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern] + | OldBuiltin String String + -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new + | EmptyRewritePragma + -- ^ If the user wrote just @{-\# REWRITE \#-}@. + | EmptyWhere + -- ^ An empty @where@ block is dead code. + | IllformedAsClause String + -- ^ If the user wrote something other than an unqualified name + -- in the @as@ clause of an @import@ statement. + -- The 'String' gives optionally extra explanation. + | ClashesViaRenaming NameOrModule [C.Name] + -- ^ If a `renaming' import directive introduces a name or module name clash + -- in the exported names of a module. + -- (See issue #4154.) + | UselessPatternDeclarationForRecord String + -- ^ The 'pattern' declaration is useless in the presence + -- of either @coinductive@ or @eta-equality@. + -- Content of 'String' is "coinductive" or "eta", resp. + | UselessPublic + -- ^ If the user opens a module public before the module header. + -- (See issue #2377.) + | UselessHiding [C.ImportedName] + -- ^ Names in `hiding` directive that don't hide anything + -- imported by a `using` directive. + | UselessInline QName + | WrongInstanceDeclaration + | InstanceWithExplicitArg QName + -- ^ An instance was declared with an implicit argument, which means it + -- will never actually be considered by instance search. + | InstanceNoOutputTypeName Doc + -- ^ The type of an instance argument doesn't end in a named or + -- variable type, so it will never be considered by instance search. + | InstanceArgWithExplicitArg Doc + -- ^ As InstanceWithExplicitArg, but for local bindings rather than + -- top-level instances. + | InversionDepthReached QName + -- ^ The --inversion-max-depth was reached. + | NoGuardednessFlag QName + -- ^ A coinductive record was declared but neither --guardedness nor + -- --sized-types is enabled. + + -- Generic warnings for one-off things + | GenericWarning Doc + -- ^ Harmless generic warning (not an error) + | GenericNonFatalError Doc + -- ^ Generic error which doesn't abort proceedings (not a warning) + | GenericUseless Range Doc + -- ^ Generic warning when code is useless and thus ignored. + -- 'Range' is for dead code highlighting. + + -- Safe flag errors + | SafeFlagPostulate C.Name + | SafeFlagPragma [String] -- ^ Unsafe OPTIONS. + | SafeFlagNonTerminating + | SafeFlagTerminating + | SafeFlagWithoutKFlagPrimEraseEquality + | WithoutKFlagPrimEraseEquality + | SafeFlagNoPositivityCheck + | SafeFlagPolarity + | SafeFlagNoUniverseCheck + | SafeFlagNoCoverageCheck + | SafeFlagInjective + | SafeFlagEta -- ^ ETA pragma is unsafe. + | OptionWarning OptionWarning + | ParseWarning ParseWarning + | LibraryWarning LibWarning + | DeprecationWarning String String String + -- ^ `DeprecationWarning old new version`: + -- `old` is deprecated, use `new` instead. This will be an error in Agda `version`. + | UserWarning Text + -- ^ User-defined warning (e.g. to mention that a name is deprecated) + | DuplicateUsing (List1 C.ImportedName) + -- ^ Duplicate mentions of the same name in @using@ directive(s). + | FixityInRenamingModule (List1 Range) + -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity). + | ModuleDoesntExport C.QName [C.Name] [C.Name] [C.ImportedName] + -- ^ Some imported names are not actually exported by the source module. + -- The second argument is the names that could be exported. + -- The third argument is the module names that could be exported. + | InfectiveImport Doc + -- ^ Importing a file using an infective option into one which doesn't + | CoInfectiveImport Doc + -- ^ Importing a file not using a coinfective option from one which does + | RewriteNonConfluent Term Term Term Doc + -- ^ Confluence checker found critical pair and equality checking + -- resulted in a type error + | RewriteMaybeNonConfluent Term Term [Doc] + -- ^ Confluence checker got stuck on computing overlap between two + -- rewrite rules + | RewriteAmbiguousRules Term Term Term + -- ^ The global confluence checker found a term @u@ that reduces + -- to both @v1@ and @v2@ and there is no rule to resolve the + -- ambiguity. + | RewriteMissingRule Term Term Term + -- ^ The global confluence checker found a term @u@ that reduces + -- to @v@, but @v@ does not reduce to @rho(u)@. + | PragmaCompileErased BackendName QName + -- ^ COMPILE directive for an erased symbol + | NotInScopeW [C.QName] + -- ^ Out of scope error we can recover from + | 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@), + -- because this can be confusing to read. + | RecordFieldWarning RecordFieldWarning + deriving (Show, Generic) + +data RecordFieldWarning + = DuplicateFieldsWarning [(C.Name, Range)] + -- ^ Each redundant field comes with a range of associated dead code. + | TooManyFieldsWarning QName [C.Name] [(C.Name, Range)] + -- ^ Record type, fields not supplied by user, non-fields but supplied. + -- The redundant fields come with a range of associated dead code. + deriving (Show, Generic) + +recordFieldWarningToError :: RecordFieldWarning -> TypeError +recordFieldWarningToError = \case + DuplicateFieldsWarning xrs -> DuplicateFields $ map fst xrs + TooManyFieldsWarning q ys xrs -> TooManyFields q ys $ map fst xrs + +warningName :: Warning -> WarningName +warningName = \case + -- special cases + NicifierIssue dw -> declarationWarningName dw + OptionWarning ow -> optionWarningName ow + ParseWarning pw -> parseWarningName pw + LibraryWarning lw -> libraryWarningName lw + AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_ + -- scope- and type-checking errors + AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_ + CantGeneralizeOverSorts{} -> CantGeneralizeOverSorts_ + CoverageIssue{} -> CoverageIssue_ + CoverageNoExactSplit{} -> CoverageNoExactSplit_ + DeprecationWarning{} -> DeprecationWarning_ + EmptyRewritePragma -> EmptyRewritePragma_ + EmptyWhere -> EmptyWhere_ + IllformedAsClause{} -> IllformedAsClause_ + WrongInstanceDeclaration{} -> WrongInstanceDeclaration_ + InstanceWithExplicitArg{} -> InstanceWithExplicitArg_ + InstanceNoOutputTypeName{} -> InstanceNoOutputTypeName_ + InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_ + DuplicateUsing{} -> DuplicateUsing_ + FixityInRenamingModule{} -> FixityInRenamingModule_ + GenericNonFatalError{} -> GenericNonFatalError_ + GenericUseless{} -> GenericUseless_ + GenericWarning{} -> GenericWarning_ + InversionDepthReached{} -> InversionDepthReached_ + ModuleDoesntExport{} -> ModuleDoesntExport_ + NoGuardednessFlag{} -> NoGuardednessFlag_ + NotInScopeW{} -> NotInScope_ + NotStrictlyPositive{} -> NotStrictlyPositive_ + UnsupportedIndexedMatch{} -> UnsupportedIndexedMatch_ + OldBuiltin{} -> OldBuiltin_ + SafeFlagNoPositivityCheck -> SafeFlagNoPositivityCheck_ + SafeFlagNonTerminating -> SafeFlagNonTerminating_ + SafeFlagNoUniverseCheck -> SafeFlagNoUniverseCheck_ + SafeFlagPolarity -> SafeFlagPolarity_ + SafeFlagPostulate{} -> SafeFlagPostulate_ + SafeFlagPragma{} -> SafeFlagPragma_ + SafeFlagEta -> SafeFlagEta_ + SafeFlagInjective -> SafeFlagInjective_ + SafeFlagNoCoverageCheck -> SafeFlagNoCoverageCheck_ + SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_ + WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_ + SafeFlagTerminating -> SafeFlagTerminating_ + TerminationIssue{} -> TerminationIssue_ + UnreachableClauses{} -> UnreachableClauses_ + UnsolvedInteractionMetas{} -> UnsolvedInteractionMetas_ + UnsolvedConstraints{} -> UnsolvedConstraints_ + UnsolvedMetaVariables{} -> UnsolvedMetaVariables_ + UselessHiding{} -> UselessHiding_ + UselessInline{} -> UselessInline_ + UselessPublic{} -> UselessPublic_ + UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_ + ClashesViaRenaming{} -> ClashesViaRenaming_ + UserWarning{} -> UserWarning_ + InfectiveImport{} -> InfectiveImport_ + CoInfectiveImport{} -> CoInfectiveImport_ + RewriteNonConfluent{} -> RewriteNonConfluent_ + RewriteMaybeNonConfluent{} -> RewriteMaybeNonConfluent_ + RewriteAmbiguousRules{} -> RewriteAmbiguousRules_ + RewriteMissingRule{} -> RewriteMissingRule_ + PragmaCompileErased{} -> PragmaCompileErased_ + -- record field warnings + RecordFieldWarning w -> case w of + DuplicateFieldsWarning{} -> DuplicateFieldsWarning_ + TooManyFieldsWarning{} -> TooManyFieldsWarning_ + +data TCWarning + = TCWarning + { tcWarningLocation :: CallStack + -- ^ Location in the internal Agda source code location where the error raised + , tcWarningRange :: Range + -- ^ Range where the warning was raised + , tcWarning :: Warning + -- ^ The warning itself + , tcWarningPrintedWarning :: Doc + -- ^ The warning printed in the state and environment where it was raised + , tcWarningCached :: Bool + -- ^ Should the warning be affected by caching. + } + deriving (Show, Generic) + +tcWarningOrigin :: TCWarning -> SrcFile +tcWarningOrigin = rangeFile . tcWarningRange + +instance HasRange TCWarning where + getRange = tcWarningRange + +-- used for merging lists of warnings +instance Eq TCWarning where + (==) = (==) `on` tcWarningPrintedWarning + +--------------------------------------------------------------------------- +-- * Type checking errors +--------------------------------------------------------------------------- + +-- | Information about a call. + +data CallInfo = CallInfo + { callInfoTarget :: QName + -- ^ Target function name. (Contains its range.) + , callInfoCall :: Closure Term + -- ^ To be formatted representation of the call. + } deriving (Show, Generic) + -- no Eq, Ord instances: too expensive! (see issues 851, 852) + +instance HasRange CallInfo where + getRange = getRange . callInfoTarget + +-- | We only 'show' the name of the callee. +instance Pretty CallInfo where pretty = pretty . callInfoTarget + +-- | Information about a mutual block which did not pass the +-- termination checker. + +data TerminationError = TerminationError + { termErrFunctions :: [QName] + -- ^ The functions which failed to check. (May not include + -- automatically generated functions.) + , termErrCalls :: [CallInfo] + -- ^ The problematic call sites. + } deriving (Show, Generic) + +-- | Error when splitting a pattern variable into possible constructor patterns. +data SplitError + = NotADatatype (Closure Type) -- ^ Neither data type nor record. + | BlockedType Blocker (Closure Type) -- ^ Type could not be sufficiently reduced. + | ErasedDatatype Bool (Closure Type) -- ^ Data type, but in erased position. + -- If the boolean is 'True', + -- then the reason for the + -- error is that the K rule + -- is turned off. + | CoinductiveDatatype (Closure Type) -- ^ Split on codata not allowed. + -- UNUSED, but keep! + -- -- | NoRecordConstructor Type -- ^ record type, but no constructor + | UnificationStuck + { cantSplitBlocker :: Maybe Blocker -- ^ Blocking metavariable (if any) + , cantSplitConName :: QName -- ^ Constructor. + , cantSplitTel :: Telescope -- ^ Context for indices. + , cantSplitConIdx :: Args -- ^ Inferred indices (from type of constructor). + , cantSplitGivenIdx :: Args -- ^ Expected indices (from checking pattern). + , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck. + } + | CosplitCatchall + -- ^ Copattern split with a catchall + | CosplitNoTarget + -- ^ We do not know the target type of the clause. + | CosplitNoRecordType (Closure Type) + -- ^ Target type is not a record type. + | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type)) + + | GenericSplitError String + deriving (Show, Generic) + +data NegativeUnification + = UnifyConflict Telescope Term Term + | UnifyCycle Telescope Int Term + deriving (Show, Generic) + +data UnificationFailure + = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype + | UnifyRecursiveEq Telescope Type Int Term -- ^ Can't solve equation because variable occurs in (type of) lhs + | UnifyReflexiveEq Telescope Type Term -- ^ Can't solve reflexive equation because --without-K is enabled + | UnifyUnusableModality Telescope Type Int Term Modality -- ^ Can't solve equation because solution modality is less "usable" + deriving (Show, Generic) + +data UnquoteError + = BadVisibility String (Arg I.Term) + | ConInsteadOfDef QName String String + | DefInsteadOfCon QName String String + | NonCanonical String I.Term + | BlockedOnMeta TCState Blocker + | UnquotePanic String + deriving (Show, Generic) + +data TypeError + = InternalError String + | NotImplemented String + | NotSupported String + | CompilationError String + | PropMustBeSingleton + | DataMustEndInSort Term +{- UNUSED + | DataTooManyParameters + -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the + -- the parameters given in the forward declaraion @data D Gamma : T@. +-} + | ShouldEndInApplicationOfTheDatatype Type + -- ^ The target of a constructor isn't an application of its + -- datatype. The 'Type' records what it does target. + | ShouldBeAppliedToTheDatatypeParameters Term Term + -- ^ The target of a constructor isn't its datatype applied to + -- something that isn't the parameters. First term is the correct + -- target and the second term is the actual target. + | ShouldBeApplicationOf Type QName + -- ^ Expected a type to be an application of a particular datatype. + | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype + | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName) + -- ^ Datatype, constructors. + | DoesNotConstructAnElementOf QName Type -- ^ constructor, type + | WrongHidingInLHS + -- ^ The left hand side of a function definition has a hidden argument + -- where a non-hidden was expected. + | WrongHidingInLambda Type + -- ^ Expected a non-hidden function and found a hidden lambda. + | WrongHidingInApplication Type + -- ^ A function is applied to a hidden argument where a non-hidden was expected. + | WrongNamedArgument (NamedArg A.Expr) [NamedName] + -- ^ A function is applied to a hidden named argument it does not have. + -- The list contains names of possible hidden arguments at this point. + | WrongIrrelevanceInLambda + -- ^ Wrong user-given relevance annotation in lambda. + | WrongQuantityInLambda + -- ^ Wrong user-given quantity annotation in lambda. + | WrongCohesionInLambda + -- ^ Wrong user-given cohesion annotation in lambda. + | QuantityMismatch Quantity Quantity + -- ^ The given quantity does not correspond to the expected quantity. + | HidingMismatch Hiding Hiding + -- ^ The given hiding does not correspond to the expected hiding. + | RelevanceMismatch Relevance Relevance + -- ^ The given relevance does not correspond to the expected relevane. + | UninstantiatedDotPattern A.Expr + | ForcedConstructorNotInstantiated A.Pattern + | IllformedProjectionPattern A.Pattern + | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type + | WrongNumberOfConstructorArguments QName Nat Nat + | ShouldBeEmpty Type [DeBruijnPattern] + | ShouldBeASort Type + -- ^ The given type should have been a sort. + | ShouldBePi Type + -- ^ The given type should have been a pi. + | ShouldBePath Type + | ShouldBeRecordType Type + | ShouldBeRecordPattern DeBruijnPattern + | NotAProjectionPattern (NamedArg A.Pattern) + | NotAProperTerm + | InvalidTypeSort Sort + -- ^ This sort is not a type expression. + | InvalidType Term + -- ^ This term is not a type expression. + | FunctionTypeInSizeUniv Term + -- ^ This term, a function type constructor, lives in + -- @SizeUniv@, which is not allowed. + | SplitOnIrrelevant (Dom Type) + | SplitOnUnusableCohesion (Dom Type) + -- UNUSED: -- | SplitOnErased (Dom Type) + | SplitOnNonVariable Term Type + | SplitOnNonEtaRecord QName + | DefinitionIsIrrelevant QName + | DefinitionIsErased QName + | VariableIsIrrelevant Name + | VariableIsErased Name + | VariableIsOfUnusableCohesion Name Cohesion + | UnequalLevel Comparison Level Level + | UnequalTerms Comparison Term Term CompareAs + | UnequalTypes Comparison Type Type +-- | UnequalTelescopes Comparison Telescope Telescope -- UNUSED + | UnequalRelevance Comparison Term Term + -- ^ The two function types have different relevance. + | UnequalQuantity Comparison Term Term + -- ^ The two function types have different relevance. + | UnequalCohesion Comparison Term Term + -- ^ The two function types have different cohesion. + | UnequalFiniteness Comparison Term Term + -- ^ One of the function types has a finite domain (i.e. is a @Partia@l@) and the other isonot. + | UnequalHiding Term Term + -- ^ The two function types have different hiding. + | UnequalSorts Sort Sort + | UnequalBecauseOfUniverseConflict Comparison Term Term + | NotLeqSort Sort Sort + | MetaCannotDependOn MetaId Nat + -- ^ The arguments are the meta variable and the parameter that it wants to depend on. + | MetaOccursInItself MetaId + | MetaIrrelevantSolution MetaId Term + | MetaErasedSolution MetaId Term + | GenericError String + | GenericDocError Doc + | SortOfSplitVarError (Maybe Blocker) Doc + -- ^ the meta is what we might be blocked on. + | BuiltinMustBeConstructor String A.Expr + | NoSuchBuiltinName String + | DuplicateBuiltinBinding String Term Term + | NoBindingForBuiltin String + | NoSuchPrimitiveFunction String + | DuplicatePrimitiveBinding String QName QName + | WrongModalityForPrimitive String ArgInfo ArgInfo + | ShadowedModule C.Name [A.ModuleName] + | BuiltinInParameterisedModule String + | IllegalLetInTelescope C.TypedBinding + | IllegalPatternInTelescope C.Binder + | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern] + | TooManyFields QName [C.Name] [C.Name] + -- ^ Record type, fields not supplied by user, non-fields but supplied. + | DuplicateFields [C.Name] + | DuplicateConstructors [C.Name] + | WithOnFreeVariable A.Expr Term + | UnexpectedWithPatterns [A.Pattern] + | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern) + | FieldOutsideRecord + | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr] + | GeneralizeCyclicDependency + | GeneralizeUnsolvedMeta + -- Coverage errors +-- UNUSED: | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off + | SplitError SplitError + | ImpossibleConstructor QName NegativeUnification + -- Positivity errors + | TooManyPolarities QName Int + -- Import errors + | LocalVsImportedModuleClash ModuleName + | SolvedButOpenHoles + -- ^ Some interaction points (holes) have not been filled by user. + -- There are not 'UnsolvedMetas' since unification solved them. + -- This is an error, since interaction points are never filled + -- without user interaction. + | CyclicModuleDependency [TopLevelModuleName] + | FileNotFound TopLevelModuleName [AbsolutePath] + | OverlappingProjects AbsolutePath TopLevelModuleName TopLevelModuleName + | AmbiguousTopLevelModuleName TopLevelModuleName [AbsolutePath] + | ModuleNameUnexpected TopLevelModuleName TopLevelModuleName + -- ^ Found module name, expected module name. + | ModuleNameDoesntMatchFileName TopLevelModuleName [AbsolutePath] + | ClashingFileNamesFor ModuleName [AbsolutePath] + | ModuleDefinedInOtherFile TopLevelModuleName AbsolutePath AbsolutePath + -- ^ Module name, file from which it was loaded, file which + -- the include path says contains the module. + -- Scope errors + | BothWithAndRHS + | AbstractConstructorNotInScope A.QName + | NotInScope [C.QName] + | NoSuchModule C.QName + | AmbiguousName C.QName AmbiguousNameReason + | AmbiguousModule C.QName (List1 A.ModuleName) + | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration) + | ClashingModule A.ModuleName A.ModuleName + | ClashingImport C.Name A.QName + | ClashingModuleImport C.Name A.ModuleName + | PatternShadowsConstructor C.Name A.QName + | DuplicateImports C.QName [C.ImportedName] + | InvalidPattern C.Pattern + | RepeatedVariablesInPattern [C.Name] + | GeneralizeNotSupportedHere A.QName + | MultipleFixityDecls [(C.Name, [Fixity'])] + | MultiplePolarityPragmas [C.Name] + -- Concrete to Abstract errors + | NotAModuleExpr C.Expr + -- ^ The expr was used in the right hand side of an implicit module + -- definition, but it wasn't of the form @m Delta@. + | NotAnExpression C.Expr + | NotAValidLetBinding NiceDeclaration + | NotValidBeforeField NiceDeclaration + | NothingAppliedToHiddenArg C.Expr + | NothingAppliedToInstanceArg C.Expr + -- Pattern synonym errors + | BadArgumentsToPatternSynonym A.AmbiguousQName + | TooFewArgumentsToPatternSynonym A.AmbiguousQName + | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn)) + | UnusedVariableInPatternSynonym + -- Operator errors + | NoParseForApplication (List2 C.Expr) + | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr) + | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern + -- ^ The list contains patterns that failed to be interpreted. + -- If it is non-empty, the first entry could be printed as error hint. + | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern] + -- ^ Pattern and its possible interpretations. + | OperatorInformation [NotationSection] TypeError +{- UNUSED + | NoParseForPatternSynonym C.Pattern + | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern] +-} + -- Usage errors + -- Instance search errors + | InstanceNoCandidate Type [(Term, TCErr)] + -- Reflection errors + | UnquoteFailed UnquoteError + | DeBruijnIndexOutOfScope Nat Telescope [Name] + -- Language option errors + | NeedOptionCopatterns + | NeedOptionRewriting + | NeedOptionProp + | NeedOptionTwoLevel + -- Failure associated to warnings + | NonFatalErrors [TCWarning] + -- Instance search errors + | InstanceSearchDepthExhausted Term Type Int + | TriedToCopyConstrainedPrim QName + deriving (Show, Generic) + +-- | Distinguish error message when parsing lhs or pattern synonym, resp. +data LHSOrPatSyn = IsLHS | IsPatSyn + deriving (Eq, Show, Generic) + +-- | Type-checking errors. + +data TCErr + = TypeError + { tcErrLocation :: CallStack + -- ^ Location in the internal Agda source code where the error was raised + , tcErrState :: TCState + -- ^ The state in which the error was raised. + , tcErrClosErr :: Closure TypeError + -- ^ The environment in which the error as raised plus the error. + } + | Exception Range Doc + | IOException TCState Range E.IOException + -- ^ The first argument is the state in which the error was + -- raised. + | PatternErr Blocker + -- ^ The exception which is usually caught. + -- Raised for pattern violations during unification ('assignV') + -- but also in other situations where we want to backtrack. + -- Contains an unblocker to control when the computation should + -- be retried. + +instance Show TCErr where + show (TypeError _ _ e) = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e) + show (Exception r d) = prettyShow r ++ ": " ++ render d + show (IOException _ r e) = prettyShow r ++ ": " ++ + E.displayException e + show PatternErr{} = "Pattern violation (you shouldn't see this)" + +instance HasRange TCErr where + getRange (TypeError _ _ cl) = envRange $ clEnv cl + getRange (Exception r _) = r + getRange (IOException s r _) = r + getRange PatternErr{} = noRange + +instance E.Exception TCErr + +----------------------------------------------------------------------------- +-- * Accessing options +----------------------------------------------------------------------------- + +instance MonadIO m => HasOptions (TCMT m) where + pragmaOptions = useTC stPragmaOptions + + commandLineOptions = do + p <- useTC stPragmaOptions + cl <- stPersistentOptions . stPersistentState <$> getTC + return $ cl { optPragmaOptions = p } + +-- HasOptions lifts through monad transformers +-- (see default signatures in the HasOptions class). + +-- Ternary options are annoying to deal with so we provide auxiliary +-- definitions using @collapseDefault@. + +sizedTypesOption :: HasOptions m => m Bool +sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions + +guardednessOption :: HasOptions m => m Bool +guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions + +withoutKOption :: HasOptions m => m Bool +withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions + +cubicalCompatibleOption :: HasOptions m => m Bool +cubicalCompatibleOption = collapseDefault . optCubicalCompatible <$> pragmaOptions + +enableCaching :: HasOptions m => m Bool +enableCaching = optCaching <$> pragmaOptions +----------------------------------------------------------------------------- +-- * The reduce monad +----------------------------------------------------------------------------- + +-- | Environment of the reduce monad. +data ReduceEnv = ReduceEnv + { redEnv :: TCEnv -- ^ Read only access to environment. + , redSt :: TCState -- ^ Read only access to state (signature, metas...). + , redPred :: Maybe (MetaId -> ReduceM Bool) + -- ^ An optional predicate that is used by 'instantiate'' and + -- 'instantiateFull'': meta-variables are only instantiated if + -- they satisfy this predicate. + } + +mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv +mapRedEnv f s = s { redEnv = f (redEnv s) } + +mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv +mapRedSt f s = s { redSt = f (redSt s) } + +mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv + -> ReduceEnv +mapRedEnvSt f g (ReduceEnv e s p) = ReduceEnv (f e) (g s) p + +-- Lenses +reduceEnv :: Lens' TCEnv ReduceEnv +reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e } + +reduceSt :: Lens' TCState ReduceEnv +reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e } + +newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a } +-- deriving (Functor, Applicative, Monad) + +onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a +onReduceEnv f (ReduceM m) = ReduceM (m . f) + +fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b +fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e +{-# INLINE fmapReduce #-} + +-- Andreas, 2021-05-12, issue #5379: +-- It seems more stable to force to evaluate @mf <*> ma@ +-- from left to right, for the sake of printing +-- debug messages in order. +apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b +apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e -> + let g = f e + a = x e + in g `pseq` a `pseq` g a +{-# INLINE apReduce #-} + +-- Andreas, 2021-05-12, issue #5379 +-- Since the MonadDebug instance of ReduceM is implemented via +-- unsafePerformIO, we need to force results that later +-- computations do not depend on, otherwise we lose debug messages. +thenReduce :: ReduceM a -> ReduceM b -> ReduceM b +thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e +{-# INLINE thenReduce #-} + +-- Andreas, 2021-05-14: +-- `seq` does not force evaluation order, the optimizier is allowed to replace +-- @ +-- a `seq` b` +-- @ +-- by: +-- @ +-- b `seq` a `seq` b +-- @ +-- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html +-- +-- In contrast, `pseq` is only strict in its first argument, so such a permutation +-- is forbidden. +-- If we want to ensure that debug messages are printed before exceptions are +-- propagated, we need to use `pseq`, as in: +-- @ +-- unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG +-- @ +beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a +beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> + let a = x e + in a `pseq` y e `pseq` a +{-# INLINE beforeReduce #-} + +bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b +bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e +{-# INLINE bindReduce #-} + +instance Functor ReduceM where + fmap = fmapReduce + +instance Applicative ReduceM where + pure x = ReduceM (const x) + (<*>) = apReduce + (*>) = thenReduce + (<*) = beforeReduce + +instance Monad ReduceM where + return = pure + (>>=) = bindReduce + (>>) = (*>) +#if __GLASGOW_HASKELL__ < 806 + fail = Fail.fail +#endif + +instance Fail.MonadFail ReduceM where + fail = error + +instance ReadTCState ReduceM where + getTCState = ReduceM redSt + locallyTCState l f = onReduceEnv $ mapRedSt $ over l f + +runReduceM :: ReduceM a -> TCM a +runReduceM m = TCM $ \ r e -> do + s <- readIORef r + E.evaluate $ unReduceM m $ ReduceEnv e s Nothing + -- Andreas, 2021-05-13, issue #5379 + -- This was the following, which is apparently not strict enough + -- to force all unsafePerformIOs... + -- runReduceM m = do + -- e <- askTC + -- s <- getTC + -- return $! unReduceM m (ReduceEnv e s) + +runReduceF :: (a -> ReduceM b) -> TCM (a -> b) +runReduceF f = do + e <- askTC + s <- getTC + return $ \x -> unReduceM (f x) (ReduceEnv e s Nothing) + +instance MonadTCEnv ReduceM where + askTC = ReduceM redEnv + localTC = onReduceEnv . mapRedEnv + +-- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084): +-- +-- useR forces the result of projecting the lens, +-- this usually prevents retaining the whole structure when we only need a field. +-- +-- This fixes (or contributes to the fix of) the space leak issue #1829 (caching). +useR :: (ReadTCState m) => Lens' a TCState -> m a +useR l = do + !x <- (^.l) <$> getTCState + return x + +askR :: ReduceM ReduceEnv +askR = ReduceM ask + +localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a +localR f = ReduceM . local f . unReduceM + +instance HasOptions ReduceM where + pragmaOptions = useR stPragmaOptions + commandLineOptions = do + p <- useR stPragmaOptions + cl <- stPersistentOptions . stPersistentState <$> getTCState + return $ cl{ optPragmaOptions = p } + +class ( Applicative m + , MonadTCEnv m + , ReadTCState m + , HasOptions m + ) => MonadReduce m where + liftReduce :: ReduceM a -> m a + + default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a + liftReduce = lift . liftReduce + +instance MonadReduce ReduceM where + liftReduce = id + +instance MonadReduce m => MonadReduce (ChangeT m) +instance MonadReduce m => MonadReduce (ExceptT err m) +instance MonadReduce m => MonadReduce (IdentityT m) +instance MonadReduce m => MonadReduce (ListT m) +instance MonadReduce m => MonadReduce (MaybeT m) +instance MonadReduce m => MonadReduce (ReaderT r m) +instance MonadReduce m => MonadReduce (StateT w m) +instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m) +instance MonadReduce m => MonadReduce (BlockT m) + +--------------------------------------------------------------------------- +-- * Monad with read-only 'TCEnv' +--------------------------------------------------------------------------- + +-- | @MonadTCEnv@ made into its own dedicated service class. +-- This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@. +class Monad m => MonadTCEnv m where + askTC :: m TCEnv + localTC :: (TCEnv -> TCEnv) -> m a -> m a + + default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv + askTC = lift askTC + + default localTC + :: (MonadTransControl t, MonadTCEnv n, t n ~ m) + => (TCEnv -> TCEnv) -> m a -> m a + localTC = liftThrough . localTC + +instance MonadTCEnv m => MonadTCEnv (ChangeT m) +instance MonadTCEnv m => MonadTCEnv (ExceptT err m) +instance MonadTCEnv m => MonadTCEnv (IdentityT m) +instance MonadTCEnv m => MonadTCEnv (MaybeT m) +instance MonadTCEnv m => MonadTCEnv (ReaderT r m) +instance MonadTCEnv m => MonadTCEnv (StateT s m) +instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m) + +instance MonadTCEnv m => MonadTCEnv (ListT m) where + localTC = mapListT . localTC + +asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a +asksTC f = f <$> askTC + +viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a +viewTC l = asksTC (^. l) + +-- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation. +locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b +locallyTC l = localTC . over l + +--------------------------------------------------------------------------- +-- * Monad with mutable 'TCState' +--------------------------------------------------------------------------- + +-- | @MonadTCState@ made into its own dedicated service class. +-- This allows us to use 'MonadState' for 'StateT' extensions of @TCM@. +class Monad m => MonadTCState m where + getTC :: m TCState + putTC :: TCState -> m () + modifyTC :: (TCState -> TCState) -> m () + + default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState + getTC = lift getTC + + default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m () + putTC = lift . putTC + + default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m () + modifyTC = lift . modifyTC + +instance MonadTCState m => MonadTCState (MaybeT m) +instance MonadTCState m => MonadTCState (ListT m) +instance MonadTCState m => MonadTCState (ExceptT err m) +instance MonadTCState m => MonadTCState (ReaderT r m) +instance MonadTCState m => MonadTCState (StateT s m) +instance MonadTCState m => MonadTCState (ChangeT m) +instance MonadTCState m => MonadTCState (IdentityT m) +instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m) + +-- ** @TCState@ accessors (no lenses) + +getsTC :: ReadTCState m => (TCState -> a) -> m a +getsTC f = f <$> getTCState + +-- | A variant of 'modifyTC' in which the computation is strict in the +-- new state. +modifyTC' :: MonadTCState m => (TCState -> TCState) -> m () +modifyTC' f = do + s' <- getTC + putTC $! f s' + +-- SEE TC.Monad.State +-- -- | Restore the 'TCState' after computation. +-- localTCState :: MonadTCState m => m a -> m a +-- localTCState = bracket_ getTC putTC + +-- ** @TCState@ accessors via lenses + +useTC :: ReadTCState m => Lens' a TCState -> m a +useTC l = do + !x <- getsTC (^. l) + return x + +infix 4 `setTCLens` + +-- | Overwrite the part of the 'TCState' focused on by the lens. +setTCLens :: MonadTCState m => Lens' a TCState -> a -> m () +setTCLens l = modifyTC . set l + +-- | Overwrite the part of the 'TCState' focused on by the lens +-- (strictly). +setTCLens' :: MonadTCState m => Lens' a TCState -> a -> m () +setTCLens' l = modifyTC' . set l + +-- | Modify the part of the 'TCState' focused on by the lens. +modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m () +modifyTCLens l = modifyTC . over l + +-- | Modify the part of the 'TCState' focused on by the lens +-- (strictly). +modifyTCLens' :: MonadTCState m => Lens' a TCState -> (a -> a) -> m () +modifyTCLens' l = modifyTC' . over l + +-- | Modify a part of the state monadically. +modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m () +modifyTCLensM l f = putTC =<< l f =<< getTC + +-- | Modify the part of the 'TCState' focused on by the lens, and return some result. +stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r +stateTCLens l f = stateTCLensM l $ return . f + +-- | Modify a part of the state monadically, and return some result. +stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r +stateTCLensM l f = do + s <- getTC + (result , x) <- f $ s ^. l + putTC $ set l x s + return result + + +--------------------------------------------------------------------------- +-- ** Monad with capability to block a computation +--------------------------------------------------------------------------- + +class Monad m => MonadBlock m where + + -- | `patternViolation b` aborts the current computation + patternViolation :: Blocker -> m a + + default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a + patternViolation = lift . patternViolation + + -- | `catchPatternErr handle m` runs m, handling pattern violations + -- with `handle` (doesn't roll back the state) + catchPatternErr :: (Blocker -> m a) -> m a -> m a + +newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a } + deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2 + , MonadIO, Fail.MonadFail + , ReadTCState, HasOptions + , MonadTCEnv, MonadTCState, MonadTCM + ) + +instance Monad m => MonadBlock (BlockT m) where + patternViolation = BlockT . throwError + catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h) + +instance Monad m => MonadBlock (ExceptT TCErr m) where + patternViolation = throwError . PatternErr + catchPatternErr h f = catchError f $ \case + PatternErr b -> h b + err -> throwError err + +runBlocked :: Monad m => BlockT m a -> m (Either Blocker a) +runBlocked = runExceptT . unBlockT + +instance MonadBlock m => MonadBlock (MaybeT m) where + catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m + +instance MonadBlock m => MonadBlock (ReaderT e m) where + catchPatternErr h m = ReaderT $ \ e -> + let run = flip runReaderT e in catchPatternErr (run . h) (run m) + +--------------------------------------------------------------------------- +-- * Type checking monad transformer +--------------------------------------------------------------------------- + +-- | The type checking monad transformer. +-- Adds readonly 'TCEnv' and mutable 'TCState'. +newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a } + +-- | Type checking monad. +type TCM = TCMT IO + +{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-} +mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a +mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e) + +pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a +pureTCM f = TCM $ \ r e -> do + s <- liftIO $ readIORef r + return (f s e) + +-- One goal of the definitions and pragmas below is to inline the +-- monad operations as much as possible. This doesn't seem to have a +-- large effect on the performance of the normal executable, but (at +-- least on one machine/configuration) it has a massive effect on the +-- performance of the profiling executable [1], and reduces the time +-- attributed to bind from over 90% to about 25%. +-- +-- [1] When compiled with -auto-all and run with -p: roughly 750% +-- faster for one example. + +returnTCMT :: Applicative m => a -> TCMT m a +returnTCMT = \x -> TCM $ \_ _ -> pure x +{-# INLINE returnTCMT #-} + +bindTCMT :: Monad m => TCMT m a -> (a -> TCMT m b) -> TCMT m b +bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e +{-# INLINE bindTCMT #-} + +thenTCMT :: Applicative m => TCMT m a -> TCMT m b -> TCMT m b +thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e *> m2 r e +{-# INLINE thenTCMT #-} + +instance Functor m => Functor (TCMT m) where + fmap = fmapTCMT + +fmapTCMT :: Functor m => (a -> b) -> TCMT m a -> TCMT m b +fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e) +{-# INLINE fmapTCMT #-} + +instance Applicative m => Applicative (TCMT m) where + pure = returnTCMT + (<*>) = apTCMT + +apTCMT :: Applicative m => TCMT m (a -> b) -> TCMT m a -> TCMT m b +apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> mf r e <*> m r e +{-# INLINE apTCMT #-} + +instance MonadTrans TCMT where + lift m = TCM $ \_ _ -> m + +-- We want a special monad implementation of fail. +#if __GLASGOW_HASKELL__ < 806 +instance MonadIO m => Monad (TCMT m) where +#else +-- Andreas, 2022-02-02, issue #5659: +-- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here +-- if we want @instance MonadTrans TCMT@. +instance Monad m => Monad (TCMT m) where +#endif + return = pure + (>>=) = bindTCMT + (>>) = (*>) +#if __GLASGOW_HASKELL__ < 806 + fail = Fail.fail +#endif + +instance MonadIO m => Fail.MonadFail (TCMT m) where + fail = internalError + +instance MonadIO m => MonadIO (TCMT m) where + liftIO m = TCM $ \ s env -> do + liftIO $ wrap s (envRange env) $ do + x <- m + x `seq` return x + where + wrap s r m = E.catch m $ \ err -> do + s <- readIORef s + E.throwIO $ IOException s r err + +instance ( MonadFix m +#if __GLASGOW_HASKELL__ < 806 + , MonadIO m +#endif + ) => MonadFix (TCMT m) where + mfix f = TCM $ \s env -> mdo + x <- unTCM (f x) s env + return x + +instance MonadIO m => MonadTCEnv (TCMT m) where + askTC = TCM $ \ _ e -> return e + localTC f (TCM m) = TCM $ \ s e -> m s (f e) + +instance MonadIO m => MonadTCState (TCMT m) where + getTC = TCM $ \ r _e -> liftIO (readIORef r) + putTC s = TCM $ \ r _e -> liftIO (writeIORef r s) + modifyTC f = putTC . f =<< getTC + +instance MonadIO m => ReadTCState (TCMT m) where + getTCState = getTC + locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l) + +instance MonadBlock TCM where + patternViolation b = throwError (PatternErr b) + catchPatternErr handle v = + catchError_ v $ \err -> + case err of + -- Not putting s (which should really be the what's already there) makes things go + -- a lot slower (+20% total time on standard library). How is that possible?? + -- The problem is most likely that there are internal catchErrors which forgets the + -- state. catchError should preserve the state on pattern violations. + PatternErr u -> handle u + _ -> throwError err + + +instance MonadError TCErr TCM where + throwError = liftIO . E.throwIO + catchError m h = TCM $ \ r e -> do -- now we are in the IO monad + oldState <- readIORef r + unTCM m r e `E.catch` \err -> do + -- Reset the state, but do not forget changes to the persistent + -- component. Not for pattern violations. + case err of + PatternErr{} -> return () + _ -> + liftIO $ do + newState <- readIORef r + writeIORef r $ oldState { stPersistentState = stPersistentState newState } + unTCM (h err) r e + +-- | Like 'catchError', but resets the state completely before running the handler. +-- This means it also loses changes to the 'stPersistentState'. +-- +-- The intended use is to catch internal errors during debug printing. +-- In debug printing, we are not expecting state changes. +instance CatchImpossible TCM where + catchImpossibleJust f m h = TCM $ \ r e -> do + -- save the state + s <- readIORef r + catchImpossibleJust f (unTCM m r e) $ \ err -> do + writeIORef r s + unTCM (h err) r e + +instance MonadIO m => MonadReduce (TCMT m) where + liftReduce = liftTCM . runReduceM + +instance (IsString a, MonadIO m) => IsString (TCMT m a) where + fromString s = return (fromString s) + +-- | Strict (non-shortcut) semigroup. +-- +-- Note that there might be a lazy alternative, e.g., +-- for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation, +-- to shortcut conjunction in case we already have 'False'. +-- +instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where + (<>) = liftA2 (<>) + +-- | Strict (non-shortcut) monoid. +instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where + mempty = pure mempty + mappend = (<>) + mconcat = mconcat <.> sequence + +instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where + empty = return empty + null = __IMPOSSIBLE__ + +-- | Preserve the state of the failing computation. +catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a +catchError_ m h = TCM $ \r e -> + unTCM m r e + `E.catch` \err -> unTCM (h err) r e + +-- | Execute a finalizer even when an exception is thrown. +-- Does not catch any errors. +-- In case both the regular computation and the finalizer +-- throw an exception, the one of the finalizer is propagated. +finally_ :: TCM a -> TCM b -> TCM a +finally_ m f = do + x <- m `catchError_` \ err -> f >> throwError err + _ <- f + return x + +-- | Embedding a TCM computation. + +class ( Applicative tcm, MonadIO tcm + , MonadTCEnv tcm + , MonadTCState tcm + , HasOptions tcm + ) => MonadTCM tcm where + liftTCM :: TCM a -> tcm a + + default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a + liftTCM = lift . liftTCM + +{-# RULES "liftTCM/id" liftTCM = id #-} +instance MonadIO m => MonadTCM (TCMT m) where + liftTCM = mapTCMT liftIO + +instance MonadTCM tcm => MonadTCM (ChangeT tcm) +instance MonadTCM tcm => MonadTCM (ExceptT err tcm) +instance MonadTCM tcm => MonadTCM (IdentityT tcm) +instance MonadTCM tcm => MonadTCM (ListT tcm) +instance MonadTCM tcm => MonadTCM (MaybeT tcm) +instance MonadTCM tcm => MonadTCM (ReaderT r tcm) +instance MonadTCM tcm => MonadTCM (StateT s tcm) +instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm) + +-- | We store benchmark statistics in an IORef. +-- This enables benchmarking pure computation, see +-- "Agda.Benchmarking". +instance MonadBench TCM where + type BenchPhase TCM = Phase + getBenchmark = liftIO $ getBenchmark + putBenchmark = liftIO . putBenchmark + finally = finally_ + +instance Null (TCM Doc) where + empty = return empty + null = __IMPOSSIBLE__ + +internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a +internalError s = withCallerCallStack $ \ loc -> + liftTCM $ typeError' loc $ InternalError s + +-- | The constraints needed for 'typeError' and similar. +type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m) + +-- | Utility function for 1-arg constructed type errors. +-- Note that the @HasCallStack@ constraint is on the *resulting* function. +locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b) +locatedTypeError f e = withCallerCallStack (flip typeError' (f e)) + +genericError :: (HasCallStack, MonadTCError m) => String -> m a +genericError = locatedTypeError GenericError + +{-# SPECIALIZE genericDocError :: Doc -> TCM a #-} +genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a +genericDocError = locatedTypeError GenericDocError + +{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-} +typeError' :: MonadTCError m => CallStack -> TypeError -> m a +typeError' loc err = throwError =<< typeError'_ loc err + +{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-} +typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a +typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err + +{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-} +typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr +typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err + +{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-} +typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr +typeError_ = withCallerCallStack . flip typeError'_ + +-- | Running the type checking monad (most general form). +{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-} +runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState) +runTCM e s m = do + r <- liftIO $ newIORef s + a <- unTCM m r e + s <- liftIO $ readIORef r + return (a, s) + +-- | Running the type checking monad on toplevel (with initial state). +runTCMTop :: TCM a -> IO (Either TCErr a) +runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left) + +runTCMTop' :: MonadIO m => TCMT m a -> m a +runTCMTop' m = do + r <- liftIO $ newIORef initState + unTCM m r initEnv + +-- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which +-- cannot fail, except that it might raise 'IOException's) in the +-- initial environment. + +runSafeTCM :: TCM a -> TCState -> IO (a, TCState) +runSafeTCM m st = + runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of + IOException _ _ err -> E.throwIO err + _ -> __IMPOSSIBLE__ + +-- | Runs the given computation in a separate thread, with /a copy/ of +-- the current state and environment. +-- +-- Note that Agda sometimes uses actual, mutable state. If the +-- computation given to @forkTCM@ tries to /modify/ this state, then +-- bad things can happen, because accesses are not mutually exclusive. +-- The @forkTCM@ function has been added mainly to allow the thread to +-- /read/ (a snapshot of) the current state in a convenient way. +-- +-- Note also that exceptions which are raised in the thread are not +-- propagated to the parent, so the thread should not do anything +-- important. + +forkTCM :: TCM a -> TCM () +forkTCM m = do + s <- getTC + e <- askTC + liftIO $ void $ C.forkIO $ void $ runTCM e s m + +--------------------------------------------------------------------------- +-- * Names for generated definitions +--------------------------------------------------------------------------- + +-- | Base name for patterns in telescopes +patternInTeleName :: String +patternInTeleName = ".patternInTele" + +-- | Base name for extended lambda patterns +extendedLambdaName :: String +extendedLambdaName = ".extendedlambda" + +-- | Check whether we have an definition from an extended lambda. +isExtendedLambdaName :: A.QName -> Bool +isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName + +-- | Name of absurdLambda definitions. +absurdLambdaName :: String +absurdLambdaName = ".absurdlambda" + +-- | Check whether we have an definition from an absurd lambda. +isAbsurdLambdaName :: QName -> Bool +isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName + +-- | Base name for generalized variable projections +generalizedFieldName :: String +generalizedFieldName = ".generalizedField-" + +-- | Check whether we have a generalized variable field +getGeneralizedFieldName :: A.QName -> Maybe String +getGeneralizedFieldName q + | generalizedFieldName `List.isPrefixOf` strName = Just (drop (length generalizedFieldName) strName) + | otherwise = Nothing + where strName = prettyShow $ nameConcrete $ qnameName q + +--------------------------------------------------------------------------- +-- * KillRange instances +--------------------------------------------------------------------------- + +instance KillRange Signature where + killRange (Sig secs defs rews) = killRange2 Sig secs defs rews + +instance KillRange Sections where + killRange = fmap killRange + +instance KillRange Definitions where + killRange = fmap killRange + +instance KillRange RewriteRuleMap where + killRange = fmap killRange + +instance KillRange Section where + killRange (Section tel) = killRange1 Section tel + +instance KillRange Definition where + killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def) = + killRange19 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def + -- TODO clarify: Keep the range in the defName field? + +instance KillRange NumGeneralizableArgs where + killRange = id + +instance KillRange NLPat where + killRange (PVar x y) = killRange2 PVar x y + killRange (PDef x y) = killRange2 PDef x y + killRange (PLam x y) = killRange2 PLam x y + killRange (PPi x y) = killRange2 PPi x y + killRange (PSort x) = killRange1 PSort x + killRange (PBoundVar x y) = killRange2 PBoundVar x y + killRange (PTerm x) = killRange1 PTerm x + +instance KillRange NLPType where + killRange (NLPType s a) = killRange2 NLPType s a + +instance KillRange NLPSort where + killRange (PType l) = killRange1 PType l + killRange (PProp l) = killRange1 PProp l + killRange (PSSet l) = killRange1 PSSet l + killRange s@(PInf f n) = s + killRange PSizeUniv = PSizeUniv + killRange PLockUniv = PLockUniv + killRange PIntervalUniv = PIntervalUniv + +instance KillRange RewriteRule where + killRange (RewriteRule q gamma f es rhs t c) = + killRange6 RewriteRule q gamma f es rhs t c + +instance KillRange CompiledRepresentation where + killRange = id + + +instance KillRange EtaEquality where + killRange = id + +instance KillRange System where + killRange (System tel sys) = System (killRange tel) (killRange sys) + +instance KillRange ExtLamInfo where + killRange (ExtLamInfo m b sys) = killRange3 ExtLamInfo m b sys + +instance KillRange FunctionFlag where + killRange = id + +instance KillRange CompKit where + killRange = id + +instance KillRange ProjectionLikenessMissing where + killRange = id + +instance KillRange Defn where + killRange def = + case def of + Axiom a -> Axiom a + DataOrRecSig n -> DataOrRecSig n + GeneralizableVar -> GeneralizableVar + AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'! + Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with iskan -> + killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with iskan + Datatype a b c d e f g h i j -> killRange10 Datatype a b c d e f g h i j + Record a b c d e f g h i j k l m -> killRange13 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-> killRange10 Constructor a b c d e f g h i j + Primitive a b c d e -> killRange5 Primitive a b c d e + PrimitiveSort a b -> killRange2 PrimitiveSort a b + +instance KillRange MutualId where + killRange = id + +instance KillRange c => KillRange (FunctionInverse' c) where + killRange NotInjective = NotInjective + killRange (Inverse m) = Inverse $ killRangeMap m + +instance KillRange TermHead where + killRange SortHead = SortHead + killRange PiHead = PiHead + killRange (ConsHead q) = ConsHead $ killRange q + killRange h@VarHead{} = h + killRange UnknownHead = UnknownHead + +instance KillRange Projection where + killRange (Projection a b c d e) = killRange5 Projection a b c d e + +instance KillRange ProjLams where + killRange = id + +instance KillRange a => KillRange (Open a) where + killRange = fmap killRange + +instance KillRange DisplayForm where + killRange (Display n es dt) = killRange3 Display n es dt + +instance KillRange Polarity where + killRange = id + +instance KillRange IsForced where + killRange = id + +instance KillRange DoGeneralize where + killRange = id + +instance KillRange DisplayTerm where + killRange dt = + case dt of + DWithApp dt dts es -> killRange3 DWithApp dt dts es + DCon q ci dts -> killRange3 DCon q ci dts + DDef q dts -> killRange2 DDef q dts + DDot v -> killRange1 DDot v + DTerm v -> killRange1 DTerm v + +instance KillRange a => KillRange (Closure a) where + killRange = id + +--------------------------------------------------------------------------- +-- NFData instances +--------------------------------------------------------------------------- + +instance NFData NumGeneralizableArgs where + rnf NoGeneralizableArgs = () + rnf (SomeGeneralizableArgs _) = () + +instance NFData TCErr where + rnf (TypeError a b c) = rnf a `seq` rnf b `seq` rnf c + rnf (Exception a b) = rnf a `seq` rnf b + rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c) + -- At the time of writing there is no + -- NFData instance for E.IOException. + rnf (PatternErr a) = rnf a + +-- | This instance could be optimised, some things are guaranteed to +-- be forced. + +instance NFData PreScopeState + +-- | This instance could be optimised, some things are guaranteed to +-- be forced. + +instance NFData PostScopeState + +instance NFData TCState +instance NFData DisambiguatedName +instance NFData MutualBlock +instance NFData (BiMap RawTopLevelModuleName ModuleNameHash) +instance NFData PersistentTCState +instance NFData LoadedFileCache +instance NFData TypeCheckAction +instance NFData ModuleCheckMode +instance NFData ModuleInfo +instance NFData ForeignCode +instance NFData Interface +instance NFData a => NFData (Closure a) +instance NFData ProblemConstraint +instance NFData WhyCheckModality +instance NFData Constraint +instance NFData Signature +instance NFData Comparison +instance NFData CompareAs +instance NFData a => NFData (Open a) +instance NFData a => NFData (Judgement a) +instance NFData DoGeneralize +instance NFData GeneralizedValue +instance NFData MetaVariable +instance NFData Listener +instance NFData MetaInstantiation +instance NFData Instantiation +instance NFData RemoteMetaVariable +instance NFData Frozen +instance NFData PrincipalArgTypeMetas +instance NFData TypeCheckingProblem +instance NFData RunMetaOccursCheck +instance NFData MetaInfo +instance NFData InteractionPoint +instance NFData InteractionPoints +instance NFData Overapplied +instance NFData t => NFData (IPBoundary' t) +instance NFData IPClause +instance NFData DisplayForm +instance NFData DisplayTerm +instance NFData NLPat +instance NFData NLPType +instance NFData NLPSort +instance NFData RewriteRule +instance NFData Definition +instance NFData Polarity +instance NFData IsForced +instance NFData Projection +instance NFData ProjLams +instance NFData CompilerPragma +instance NFData System +instance NFData ExtLamInfo +instance NFData EtaEquality +instance NFData FunctionFlag +instance NFData CompKit +instance NFData AxiomData +instance NFData DataOrRecSigData +instance NFData ProjectionLikenessMissing +instance NFData FunctionData +instance NFData DatatypeData +instance NFData RecordData +instance NFData ConstructorData +instance NFData PrimitiveData +instance NFData PrimitiveSortData instance NFData Defn instance NFData Simplification instance NFData AllowedReduction 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 @@ -7,7 +7,7 @@ import Data.Map (Map) import Agda.Syntax.Common (Nat) -import Agda.Syntax.Concrete.Name (TopLevelModuleName) +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.FileName (AbsolutePath) data Warning @@ -32,7 +32,7 @@ instance Functor m => Functor (TCMT m) instance MonadIO m => MonadIO (TCMT m) -#if __GLASGOW_HASKELL__ < 808 +#if __GLASGOW_HASKELL__ < 806 instance MonadIO m => Monad (TCMT m) where #else -- Andreas, 2022-02-02, issue #5659: @@ -49,3 +49,4 @@ data Comparison data Polarity +data IPBoundary' a diff --git a/src/full/Agda/TypeChecking/Monad/Benchmark.hs b/src/full/Agda/TypeChecking/Monad/Benchmark.hs --- a/src/full/Agda/TypeChecking/Monad/Benchmark.hs +++ b/src/full/Agda/TypeChecking/Monad/Benchmark.hs @@ -22,26 +22,9 @@ import Agda.Utils.Monad import Agda.Utils.Pretty (prettyShow) - -benchmarkKey :: String -benchmarkKey = "profile" - -benchmarkLevel :: Int -benchmarkLevel = 7 - -benchmarkModulesKey :: String -benchmarkModulesKey = "profile.modules" - -benchmarkModulesLevel :: Int -benchmarkModulesLevel = 10 - -benchmarkDefsKey :: String -benchmarkDefsKey = "profile.definitions" - -benchmarkDefsLevel :: Int -benchmarkDefsLevel = 10 +import qualified Agda.Utils.ProfileOptions as Profile --- | When verbosity is set or changes, we need to turn benchmarking on or off. +-- | When profile options are set or changed, we need to turn benchmarking on or off. updateBenchmarkingStatus :: TCM () -- {-# SPECIALIZE updateBenchmarkingStatus :: TCM () #-} -- updateBenchmarkingStatus :: (HasOptions m, MonadBench a m) => m () @@ -51,20 +34,14 @@ -- | Check whether benchmarking is activated. {-# SPECIALIZE benchmarking :: TCM (B.BenchmarkOn Phase) #-} benchmarking :: MonadTCM tcm => tcm (B.BenchmarkOn Phase) -benchmarking = liftTCM $ do - -- Ulf, 2016-12-13: Using verbosity levels to control the type of - -- benchmarking isn't ideal, but let's stick with it for now. - internal <- hasVerbosity benchmarkKey benchmarkLevel - defs <- hasVerbosity benchmarkDefsKey benchmarkDefsLevel - modules <- hasVerbosity benchmarkModulesKey benchmarkModulesLevel - return $ case (internal, defs, modules) of - (True, _, _) -> B.BenchmarkSome isInternalAccount - (_, True, _) -> B.BenchmarkSome isDefAccount - (_, _, True) -> B.BenchmarkSome isModuleAccount - _ -> B.BenchmarkOff +benchmarking = liftTCM $ + ifM (hasProfileOption Profile.Internal) (pure $ B.BenchmarkSome isInternalAccount) $ + ifM (hasProfileOption Profile.Definitions) (pure $ B.BenchmarkSome isDefAccount) $ + ifM (hasProfileOption Profile.Modules) (pure $ B.BenchmarkSome isModuleAccount) $ + pure B.BenchmarkOff -- | Prints the accumulated benchmark results. Does nothing if --- profiling is not activated at level 2. +-- no benchmark profiling is enabled. print :: MonadTCM tcm => tcm () print = liftTCM $ whenM (B.isBenchmarkOn [] <$> benchmarking) $ do b <- B.getBenchmark @@ -76,9 +53,8 @@ -- Ulf, 2020-03-04: Using benchmarkLevel here means that it only prints if internal benchmarking -- is turned on, effectively making module/definition benchmarking impossible (since internal -- takes precedence). It needs to be > 1 to avoid triggering #2602 though. Also use - -- displayDebugMessage instead of reportSLn to avoid requiring -v profile:2 in addition to the - -- specific profile levels. - displayDebugMessage benchmarkKey 2 $ prettyShow b + -- displayDebugMessage instead of reportSLn to avoid requiring -v profile:2. + displayDebugMessage "profile" 2 $ prettyShow b -- -- | Bill a computation to a specific account. -- {-# SPECIALIZE billTo :: Account -> TCM a -> TCM a #-} 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 @@ -15,21 +15,25 @@ import Control.Monad.Trans.Maybe import Control.Monad.Writer -import qualified Data.Map as Map import Data.Function ( on ) +import qualified Data.Map as Map +import Data.Set (Set) import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Literal import Agda.Syntax.Builtin import Agda.Syntax.Internal as I +import Agda.Interaction.Options.Base (PragmaOptions(..)) import Agda.TypeChecking.Monad.Base -- import Agda.TypeChecking.Functions -- LEADS TO IMPORT CYCLE import Agda.TypeChecking.Substitute +import Agda.Utils.Functor import Agda.Utils.ListT import Agda.Utils.Monad import Agda.Utils.Maybe +import Agda.Utils.Singleton import Agda.Utils.Tuple import Agda.Utils.Impossible @@ -54,8 +58,10 @@ deriving instance HasBuiltins m => HasBuiltins (BlockT m) instance MonadIO m => HasBuiltins (TCMT m) where - getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useTC stLocalBuiltins) - (Map.lookup b <$> useTC stImportedBuiltins) + getBuiltinThing b = + liftM2 (unionMaybeWith unionBuiltin) + (Map.lookup b <$> useTC stLocalBuiltins) + (Map.lookup b <$> useTC stImportedBuiltins) -- If Agda is changed so that the type of a literal can belong to an -- inductive family (with at least one index), then the implementation @@ -87,6 +93,7 @@ case builtin of Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x Just (Prim _) -> typeError $ NoSuchBuiltinName b + Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__ Nothing -> stLocalBuiltins `modifyTCLens` Map.insert b (Builtin x) bindPrimitive :: String -> PrimFun -> TCM () @@ -95,9 +102,25 @@ case builtin of Just (Builtin _) -> typeError $ NoSuchPrimitiveFunction b Just (Prim x) -> typeError $ (DuplicatePrimitiveBinding b `on` primFunName) x pf + Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__ Nothing -> stLocalBuiltins `modifyTCLens` Map.insert b (Prim pf) -getBuiltin :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) +-- | Add one (more) relation symbol to the rewrite relations. +bindBuiltinRewriteRelation :: QName -> TCM () +bindBuiltinRewriteRelation x = + stLocalBuiltins `modifyTCLens` + Map.insertWith unionBuiltin builtinRewrite (BuiltinRewriteRelations $ singleton x) + +-- | Get the currently registered rewrite relation symbols. +getBuiltinRewriteRelations :: HasBuiltins m => m (Maybe (Set QName)) +getBuiltinRewriteRelations = fmap rels <$> getBuiltinThing builtinRewrite + where + rels = \case + BuiltinRewriteRelations xs -> xs + Prim{} -> __IMPOSSIBLE__ + Builtin{} -> __IMPOSSIBLE__ + +getBuiltin :: (HasBuiltins m, MonadTCError m) => String -> m Term getBuiltin x = fromMaybeM (typeError $ NoBindingForBuiltin x) $ getBuiltin' x @@ -106,6 +129,7 @@ getBuiltin' x = do builtin <- getBuiltinThing x case builtin of + Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__ Just (Builtin t) -> return $ Just $ killRange t _ -> return Nothing @@ -113,6 +137,7 @@ getPrimitive' x = (getPrim =<<) <$> getBuiltinThing x where getPrim (Prim pf) = return pf + getPrim BuiltinRewriteRelations{} = __IMPOSSIBLE__ getPrim _ = Nothing getPrimitive :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) @@ -166,7 +191,7 @@ primFloat, primChar, primString, primUnit, primUnitUnit, primBool, primTrue, primFalse, primSigma, primList, primNil, primCons, primIO, primNat, primSuc, primZero, primMaybe, primNothing, primJust, - primPath, primPathP, primInterval, primIZero, primIOne, primPartial, primPartialP, + primPath, primPathP, primIntervalUniv, primInterval, primIZero, primIOne, primPartial, primPartialP, primIMin, primIMax, primINeg, primIsOne, primItIsOne, primIsOne1, primIsOne2, primIsOneEmpty, primSub, primSubIn, primSubOut, @@ -184,7 +209,6 @@ primSizeUniv, primSize, primSizeLt, primSizeSuc, primSizeInf, primSizeMax, primInf, primSharp, primFlat, primEquality, primRefl, - primRewrite, -- Name of rewrite relation primLevel, primLevelZero, primLevelSuc, primLevelMax, primLockUniv, primSet, primProp, primSetOmega, primStrictSet, primSSetOmega, @@ -193,7 +217,7 @@ primQName, primArgInfo, primArgArgInfo, primArg, primArgArg, primAbs, primAbsAbs, primAgdaTerm, primAgdaTermVar, primAgdaTermLam, primAgdaTermExtLam, primAgdaTermDef, primAgdaTermCon, primAgdaTermPi, primAgdaTermSort, primAgdaTermLit, primAgdaTermUnsupported, primAgdaTermMeta, - primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartName, + primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartPatt, primAgdaErrorPartName, primHiding, primHidden, primInstance, primVisible, primRelevance, primRelevant, primIrrelevant, primQuantity, primQuantity0, primQuantityω, @@ -214,15 +238,17 @@ primAgdaTCMTypeError, primAgdaTCMInferType, primAgdaTCMCheckType, primAgdaTCMNormalise, primAgdaTCMReduce, primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext, - primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDefineFun, + primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDeclareData, primAgdaTCMDefineData, primAgdaTCMDefineFun, primAgdaTCMGetType, primAgdaTCMGetDefinition, primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm, primAgdaTCMQuoteOmegaTerm, primAgdaTCMBlockOnMeta, primAgdaTCMCommit, primAgdaTCMIsMacro, - primAgdaTCMWithNormalisation, primAgdaTCMDebugPrint, primAgdaTCMWithReconsParams, + primAgdaTCMFormatErrorParts, primAgdaTCMDebugPrint, + primAgdaTCMWithNormalisation, primAgdaTCMWithReconsParams, primAgdaTCMOnlyReduceDefs, primAgdaTCMDontReduceDefs, primAgdaTCMNoConstraints, primAgdaTCMRunSpeculative, - primAgdaTCMExec + primAgdaTCMExec, + primAgdaTCMGetInstances :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term primInteger = getBuiltin builtinInteger @@ -245,10 +271,11 @@ primJust = getBuiltin builtinJust primIO = getBuiltin builtinIO primId = getBuiltin builtinId -primConId = getBuiltin builtinConId +primConId = getPrimitiveTerm builtinConId primIdElim = getPrimitiveTerm builtinIdElim primPath = getBuiltin builtinPath primPathP = getBuiltin builtinPathP +primIntervalUniv = getBuiltin builtinIntervalUniv primInterval = getBuiltin builtinInterval primIZero = getBuiltin builtinIZero primIOne = getBuiltin builtinIOne @@ -299,7 +326,6 @@ primFlat = getBuiltin builtinFlat primEquality = getBuiltin builtinEquality primRefl = getBuiltin builtinRefl -primRewrite = getBuiltin builtinRewrite primLevel = getBuiltin builtinLevel primLevelZero = getBuiltin builtinLevelZero primLevelSuc = getBuiltin builtinLevelSuc @@ -362,6 +388,7 @@ primAgdaErrorPart = getBuiltin builtinAgdaErrorPart primAgdaErrorPartString = getBuiltin builtinAgdaErrorPartString primAgdaErrorPartTerm = getBuiltin builtinAgdaErrorPartTerm +primAgdaErrorPartPatt = getBuiltin builtinAgdaErrorPartPatt primAgdaErrorPartName = getBuiltin builtinAgdaErrorPartName primAgdaLiteral = getBuiltin builtinAgdaLiteral primAgdaLitNat = getBuiltin builtinAgdaLitNat @@ -405,6 +432,8 @@ primAgdaTCMFreshName = getBuiltin builtinAgdaTCMFreshName primAgdaTCMDeclareDef = getBuiltin builtinAgdaTCMDeclareDef primAgdaTCMDeclarePostulate = getBuiltin builtinAgdaTCMDeclarePostulate +primAgdaTCMDeclareData = getBuiltin builtinAgdaTCMDeclareData +primAgdaTCMDefineData = getBuiltin builtinAgdaTCMDefineData primAgdaTCMDefineFun = getBuiltin builtinAgdaTCMDefineFun primAgdaTCMGetType = getBuiltin builtinAgdaTCMGetType primAgdaTCMGetDefinition = getBuiltin builtinAgdaTCMGetDefinition @@ -416,12 +445,14 @@ primAgdaTCMIsMacro = getBuiltin builtinAgdaTCMIsMacro primAgdaTCMWithNormalisation = getBuiltin builtinAgdaTCMWithNormalisation primAgdaTCMWithReconsParams = getBuiltin builtinAgdaTCMWithReconsParams +primAgdaTCMFormatErrorParts = getBuiltin builtinAgdaTCMFormatErrorParts primAgdaTCMDebugPrint = getBuiltin builtinAgdaTCMDebugPrint primAgdaTCMOnlyReduceDefs = getBuiltin builtinAgdaTCMOnlyReduceDefs primAgdaTCMDontReduceDefs = getBuiltin builtinAgdaTCMDontReduceDefs primAgdaTCMNoConstraints = getBuiltin builtinAgdaTCMNoConstraints primAgdaTCMRunSpeculative = getBuiltin builtinAgdaTCMRunSpeculative primAgdaTCMExec = getBuiltin builtinAgdaTCMExec +primAgdaTCMGetInstances = getBuiltin builtinAgdaTCMGetInstances -- | The coinductive primitives. @@ -456,13 +487,18 @@ , nameOfSetOmega :: IsFibrant -> QName } -sortKit :: HasBuiltins m => m SortKit +-- | Compute a 'SortKit' in an environment that supports failures. +-- +-- When 'optLoadPrimitives' is set to 'False', 'sortKit' is a fallible operation, +-- so for the uses of 'sortKit' in fallible contexts (e.g. 'TCM'), +-- we report a type error rather than exploding. +sortKit :: (HasBuiltins m, MonadTCError m, HasOptions m) => m SortKit sortKit = do - Def set _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSet - Def prop _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinProp - Def setomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega - Def sset _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet - Def ssetomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSSetOmega + Def set _ <- getBuiltin builtinSet + Def prop _ <- getBuiltin builtinProp + Def setomega _ <- getBuiltin builtinSetOmega + Def sset _ <- getBuiltin builtinStrictSet + Def ssetomega _ <- getBuiltin builtinSSetOmega return $ SortKit { nameOfSet = set , nameOfProp = prop @@ -472,6 +508,25 @@ IsStrict -> ssetomega } +-- | Compute a 'SortKit' in contexts that do not support failure (e.g. +-- 'Reify'). This should only be used when we are sure that the +-- primitive sorts have been bound, i.e. because it is "after" type +-- checking. +infallibleSortKit :: HasBuiltins m => m SortKit +infallibleSortKit = do + Def set _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSet + Def prop _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinProp + Def setomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega + Def sset _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet + Def ssetomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSSetOmega + return $ SortKit + { nameOfSet = set + , nameOfProp = prop + , nameOfSSet = sset + , nameOfSetOmega = \case + IsFibrant -> setomega + IsStrict -> ssetomega + } ------------------------------------------------------------------------ -- * Path equality @@ -495,6 +550,9 @@ isPrimitive :: HasBuiltins m => String -> QName -> m Bool isPrimitive n q = (Just q ==) <$> getPrimitiveName' n +intervalSort :: Sort +intervalSort = IntervalUniv + intervalView' :: HasBuiltins m => m (Term -> IntervalView) intervalView' = do iz <- getBuiltinName' builtinIZero @@ -595,6 +653,23 @@ El s $ Def path $ map Apply [l, t, lhs, rhs] ------------------------------------------------------------------------ +-- * Swan's Id Equality +------------------------------------------------------------------------ + +-- f x (< phi , p > : Id A x _) = Just (phi,p) +conidView' :: HasBuiltins m => m (Term -> Term -> Maybe (Arg Term,Arg Term)) +conidView' = do + mn <- sequence <$> mapM getName' [builtinReflId, builtinConId] + mio <- getTerm' builtinIOne + let fallback = return $ \ _ _ -> Nothing + caseMaybe mn fallback $ \ [refl,conid] -> + caseMaybe mio fallback $ \ io -> return $ \ x t -> + case t of + Con h _ [] | conName h == refl -> Just (defaultArg io,defaultArg (Lam defaultArgInfo $ NoAbs "_" $ x)) + Def d es | Just [l,a,x,y,phi,p] <- allApplyElims es, d == conid -> Just (phi, p) + _ -> Nothing + +------------------------------------------------------------------------ -- * Builtin equality ------------------------------------------------------------------------ @@ -638,11 +713,18 @@ -- -- Postcondition: type is reduced. -equalityUnview :: EqualityView -> Type -equalityUnview (OtherType t) = t -equalityUnview (IdiomType t) = t -equalityUnview (EqualityType s equality l t lhs rhs) = - El s $ Def equality $ map Apply (l ++ [t, lhs, rhs]) +class EqualityUnview a where + equalityUnview :: a -> Type + +instance EqualityUnview EqualityView where + equalityUnview = \case + OtherType t -> t + IdiomType t -> t + EqualityViewType eqt -> equalityUnview eqt + +instance EqualityUnview EqualityTypeData where + equalityUnview (EqualityTypeData s equality l t lhs rhs) = + El s $ Def equality $ map Apply (l ++ [t, lhs, rhs]) -- | Primitives with typechecking constrants. constrainedPrims :: [String] 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 @@ -11,6 +11,7 @@ import qualified Data.Set as Set import Data.Semigroup ((<>)) +import Agda.Interaction.Options.Base import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Closure @@ -173,7 +174,7 @@ addAndUnblocker :: MonadBlock m => Blocker -> m a -> m a addAndUnblocker u | u == alwaysUnblock = id - | otherwise = catchPatternErr $ \ u' -> patternViolation (u <> u') + | otherwise = catchPatternErr $ \ u' -> patternViolation (unblockOnBoth u u') addOrUnblocker :: MonadBlock m => Blocker -> m a -> m a addOrUnblocker u @@ -201,6 +202,7 @@ FindInstance{} -> False HasBiggerSort{} -> False HasPTSRule{} -> False + CheckDataSort{} -> False ValueCmp{} -> True ValueCmpOnFace{} -> True ElimCmp{} -> True @@ -224,6 +226,24 @@ -- | Add constraint if the action raises a pattern violation catchConstraint :: MonadConstraint m => Constraint -> m () -> m () catchConstraint c = catchPatternErr $ \ unblock -> addConstraint unblock c + +isInstanceConstraint :: Constraint -> Bool +isInstanceConstraint FindInstance{} = True +isInstanceConstraint _ = False + +shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool +shouldPostponeInstanceSearch = + and2M ((^. stConsideringInstance) <$> getTCState) + (not . optOverlappingInstances <$> pragmaOptions) + `or2M` ((^. stPostponeInstanceSearch) <$> getTCState) + +-- | Wake constraints matching the given predicate (and aren't instance +-- constraints if 'shouldPostponeInstanceSearch'). +wakeConstraints' :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m () +wakeConstraints' p = do + skipInstance <- shouldPostponeInstanceSearch + let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c) + wakeConstraints $ wakeUpWhen (not . skip) p --------------------------------------------------------------------------- -- * Lenses 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 @@ -1,6 +1,9 @@ module Agda.TypeChecking.Monad.Context where +import Data.Text (Text) +import qualified Data.Text as T + import Control.Monad ( (<=<), forM, when ) import Control.Monad.Except import Control.Monad.Reader @@ -8,10 +11,12 @@ import Control.Monad.Trans.Control ( MonadTransControl(..), liftThrough ) import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans.Maybe -import Control.Monad.Writer +import Control.Monad.Writer ( WriterT ) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) +import qualified Data.DList as DL +import Data.Foldable import qualified Data.List as List import qualified Data.Map as Map @@ -122,7 +127,7 @@ -- created under refined parent parameters, but as long as those modules -- aren't named we shouldn't look at the checkpoint. The right thing to do -- would be to not store these modules in the checkpoint map, but todo.. - stModuleCheckpoints `setTCLens` Map.union oldMods (old <$ Map.difference newMods oldMods) + stModuleCheckpoints `setTCLens` Map.union oldMods (old <$ newMods) unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 "}" return x @@ -228,19 +233,22 @@ setTCLens stUsedNames Map.empty result <- f newUsedNames <- useTC stUsedNames - setTCLens stUsedNames $ Map.unionWith (++) origUsedNames newUsedNames + setTCLens stUsedNames $ Map.unionWith (<>) origUsedNames newUsedNames return (result , newUsedNames) tellUsedName x = do let concreteX = nameConcrete x rawX = nameToRawName concreteX rootX = nameRoot concreteX - modifyTCLens (stUsedNames . key rootX) $ Just . (rawX:) . concat + modifyTCLens (stUsedNames . key rootX) $ + Just . (rawX `DL.cons`) . fold tellShadowing x useds = case Map.lookup (nameRoot $ nameConcrete x) useds of Just shadows -> do - reportSDoc "tc.cxt.shadowing" 80 $ pure $ "names shadowing" <+> pretty x <+> ": " <+> prettyList_ (map pretty shadows) - modifyTCLens stShadowingNames $ Map.insertWith (++) x shadows + reportSDoc "tc.cxt.shadowing" 80 $ pure $ + "names shadowing" <+> pretty x <+> ": " <+> + prettyList_ (map pretty $ toList shadows) + modifyTCLens stShadowingNames $ Map.insertWith (<>) x shadows Nothing -> return () instance MonadAddContext TCM where @@ -331,6 +339,10 @@ withFreshName noRange s $ \x -> addCtx (setNotInScope x) dom ret contextSize _ = 1 +instance AddContext (Text, Dom Type) where + addContext (s, dom) ret = addContext (T.unpack s, dom) ret + contextSize _ = 1 + instance AddContext (KeepNames String, Dom Type) where addContext (KeepNames s, dom) ret = withFreshName noRange s $ \ x -> addCtx x dom ret @@ -414,8 +426,8 @@ -- * Querying the context -- | Get the current context. -{-# SPECIALIZE getContext :: TCM [Dom (Name, Type)] #-} -getContext :: MonadTCEnv m => m [Dom (Name, Type)] +{-# SPECIALIZE getContext :: TCM Context #-} +getContext :: MonadTCEnv m => m Context getContext = asksTC envContext -- | Get the size of the current context. @@ -446,8 +458,8 @@ -- | get type of bound variable (i.e. deBruijn index) -- -{-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe (Dom (Name, Type))) #-} -lookupBV' :: MonadTCEnv m => Nat -> m (Maybe (Dom (Name, Type))) +{-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe ContextEntry) #-} +lookupBV' :: MonadTCEnv m => Nat -> m (Maybe ContextEntry) lookupBV' n = do ctx <- getContext return $ raise (n + 1) <$> ctx !!! n 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 @@ -7,6 +7,7 @@ import qualified Control.Exception as E import qualified Control.DeepSeq as DeepSeq (force) +import Control.Applicative ( liftA2 ) import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Except import Control.Monad.Reader @@ -17,6 +18,9 @@ import Control.Monad.Writer 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 {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base @@ -29,8 +33,10 @@ import Agda.Utils.List import Agda.Utils.ListT import Agda.Utils.Maybe +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Pretty +import Agda.Utils.ProfileOptions import Agda.Utils.Update import qualified Agda.Utils.Trie as Trie @@ -45,6 +51,7 @@ verboseBracket :: VerboseKey -> VerboseLevel -> String -> m a -> m a getVerbosity :: m Verbosity + getProfileOptions :: m ProfileOptions -- | Check whether we are currently debug printing. isDebugPrinting :: m Bool @@ -74,6 +81,11 @@ => m Verbosity getVerbosity = lift getVerbosity + default getProfileOptions + :: (MonadTrans t, MonadDebug n, m ~ t n) + => m ProfileOptions + getProfileOptions = lift getProfileOptions + default isDebugPrinting :: (MonadTrans t, MonadDebug n, m ~ t n) => m Bool @@ -90,6 +102,9 @@ defaultGetVerbosity :: HasOptions m => m Verbosity defaultGetVerbosity = optVerbose <$> pragmaOptions +defaultGetProfileOptions :: HasOptions m => m ProfileOptions +defaultGetProfileOptions = optProfiling <$> pragmaOptions + defaultIsDebugPrinting :: MonadTCEnv m => m Bool defaultIsDebugPrinting = asksTC envIsDebugPrinting @@ -124,8 +139,21 @@ -- Force any lazy 'Impossible' exceptions to the surface and handle them. s <- liftIO . catchAndPrintImpossible k n . E.evaluate . DeepSeq.force $ s cb <- getsTC $ stInteractionOutputCallback . stPersistentState - cb (Resp_RunningInfo n s) + + -- Andreas, 2022-06-15, prefix with time stamp if `-v debug.time:100`: + msg <- ifNotM (hasVerbosity "debug.time" 100) {-then-} (return s) {-else-} $ do + now <- liftIO $ trailingZeros . iso8601Show <$> liftA2 utcToLocalTime getCurrentTimeZone getCurrentTime + return $ concat [ now, ": ", s ] + + cb $ Resp_RunningInfo n msg cont + where + -- Surprisingly, iso8601Show gives us _up to_ 6 fractional digits (microseconds), + -- but not exactly 6. https://github.com/haskell/time/issues/211 + -- So we need to do the padding ourselves. + -- yyyy-mm-ddThh:mm:ss.ssssss + -- 12345678901234567890123456 + trailingZeros = take 26 . (++ repeat '0') formatDebugMessage k n d = catchAndPrintImpossible k n $ do render <$> d `catchError` \ err -> do @@ -144,9 +172,10 @@ closeVerboseBracketException k n throwError e - getVerbosity = defaultGetVerbosity - isDebugPrinting = defaultIsDebugPrinting - nowDebugPrinting = defaultNowDebugPrinting + getVerbosity = defaultGetVerbosity + getProfileOptions = defaultGetProfileOptions + isDebugPrinting = defaultIsDebugPrinting + nowDebugPrinting = defaultNowDebugPrinting -- MonadTrans default instances @@ -263,27 +292,40 @@ -- reportSLn -- reportSDoc -parseVerboseKey :: VerboseKey -> [String] -parseVerboseKey = wordsBy (`elem` (".:" :: String)) - -- | Check whether a certain verbosity level is activated. -- -- Precondition: The level must be non-negative. {-# SPECIALIZE hasVerbosity :: VerboseKey -> VerboseLevel -> TCM Bool #-} hasVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m Bool -hasVerbosity k n | n < 0 = __IMPOSSIBLE__ - | otherwise = do - t <- getVerbosity - let ks = parseVerboseKey k - m = lastWithDefault 0 $ Trie.lookupPath ks t - return (n <= m) +hasVerbosity k n = do + t <- getVerbosity + return $ case t of + Strict.Nothing -> n <= 1 + Strict.Just t + -- This code is not executed if no debug flags have been given. + | t == Trie.singleton [] 0 -> + -- A special case for "-v0". + n <= 0 + | otherwise -> + let ks = parseVerboseKey k + m = lastWithDefault 0 $ Trie.lookupPath ks t + in n <= m -- | Check whether a certain verbosity level is activated (exact match). {-# SPECIALIZE hasExactVerbosity :: VerboseKey -> VerboseLevel -> TCM Bool #-} hasExactVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m Bool -hasExactVerbosity k n = - (Just n ==) . Trie.lookup (parseVerboseKey k) <$> getVerbosity +hasExactVerbosity k n = do + t <- getVerbosity + return $ case t of + Strict.Nothing -> n == 1 + Strict.Just t + -- This code is not executed if no debug flags have been given. + | t == Trie.singleton [] 0 -> + -- A special case for "-v0". + n == 0 + | otherwise -> + Just n == Trie.lookup (parseVerboseKey k) t -- | Run a computation if a certain verbosity level is activated (exact match). @@ -312,13 +354,11 @@ applyWhenVerboseS :: MonadDebug m => VerboseKey -> VerboseLevel -> (m a -> m a) -> m a -> m a applyWhenVerboseS k n f a = ifM (hasVerbosity k n) (f a) a --- | Verbosity lens. -verbosity :: VerboseKey -> Lens' VerboseLevel TCState -verbosity k = stPragmaOptions . verbOpt . Trie.valueAt (parseVerboseKey k) . defaultTo 0 - where - verbOpt :: Lens' Verbosity PragmaOptions - verbOpt f opts = f (optVerbose opts) <&> \ v -> opts { optVerbose = v } - -- Andreas, 2019-08-20: this lens should go into Interaction.Option.Lenses! +-- | Check whether a certain profile option is activated. +{-# SPECIALIZE hasProfileOption :: ProfileOption -> TCM Bool #-} +hasProfileOption :: MonadDebug m => ProfileOption -> m Bool +hasProfileOption opt = containsProfileOption opt <$> getProfileOptions - defaultTo :: Eq a => a -> Lens' a (Maybe a) - defaultTo x f m = filterMaybe (== x) <$> f (fromMaybe x m) +-- | Run some code when the given profiling option is active. +whenProfile :: MonadDebug m => ProfileOption -> m () -> m () +whenProfile opt = whenM (hasProfileOption opt) diff --git a/src/full/Agda/TypeChecking/Monad/Env.hs b/src/full/Agda/TypeChecking/Monad/Env.hs --- a/src/full/Agda/TypeChecking/Monad/Env.hs +++ b/src/full/Agda/TypeChecking/Monad/Env.hs @@ -8,6 +8,7 @@ import Agda.Syntax.Common import Agda.Syntax.Abstract.Name +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base diff --git a/src/full/Agda/TypeChecking/Monad/Imports.hs b/src/full/Agda/TypeChecking/Monad/Imports.hs --- a/src/full/Agda/TypeChecking/Monad/Imports.hs +++ b/src/full/Agda/TypeChecking/Monad/Imports.hs @@ -7,11 +7,9 @@ , getDecodedModule , getDecodedModules , getImportPath - , getImports , getPrettyVisitedModules , getVisitedModule , getVisitedModules - , isImported , setDecodedModules , setVisitedModules , storeDecodedModule @@ -22,12 +20,11 @@ import Control.Arrow ( (***) ) import Control.Monad ( when ) -import Data.Set (Set) +import qualified Data.HashSet as HSet import qualified Data.Map as Map -import qualified Data.Set as Set import Agda.Syntax.Abstract.Name -import qualified Agda.Syntax.Concrete.Name as C +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base import Agda.Utils.List ( caseListM ) @@ -36,26 +33,20 @@ import Agda.Utils.Impossible -addImport :: ModuleName -> TCM () -addImport m = modifyTCLens stImportedModules $ Set.insert m +addImport :: TopLevelModuleName -> TCM () +addImport top = modifyTCLens' stImportedModules $ HSet.insert top -addImportCycleCheck :: C.TopLevelModuleName -> TCM a -> TCM a +addImportCycleCheck :: TopLevelModuleName -> TCM a -> TCM a addImportCycleCheck m = localTC $ \e -> e { envImportPath = m : envImportPath e } -getImports :: TCM (Set ModuleName) -getImports = useTC stImportedModules - -isImported :: ModuleName -> TCM Bool -isImported m = Set.member m <$> getImports - -getImportPath :: TCM [C.TopLevelModuleName] +getImportPath :: TCM [TopLevelModuleName] getImportPath = asksTC envImportPath visitModule :: ModuleInfo -> TCM () visitModule mi = modifyTCLens stVisitedModules $ - Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi + Map.insert (iTopLevelModuleName $ miInterface mi) mi setVisitedModules :: VisitedModules -> TCM () setVisitedModules ms = setTCLens stVisitedModules ms @@ -74,7 +65,7 @@ prettyCheckMode ModuleScopeChecked = " (scope only)" getVisitedModule :: ReadTCState m - => C.TopLevelModuleName + => TopLevelModuleName -> m (Maybe ModuleInfo) getVisitedModule x = Map.lookup x <$> useTC stVisitedModules @@ -85,19 +76,19 @@ setDecodedModules ms = modifyTC $ \s -> s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } } -getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe ModuleInfo) +getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo) getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> getTC storeDecodedModule :: ModuleInfo -> TCM () storeDecodedModule mi = modifyTC $ \s -> s { stPersistentState = (stPersistentState s) { stDecodedModules = - Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi $ + Map.insert (iTopLevelModuleName $ miInterface mi) mi $ stDecodedModules (stPersistentState s) } } -dropDecodedModule :: C.TopLevelModuleName -> TCM () +dropDecodedModule :: TopLevelModuleName -> TCM () dropDecodedModule x = modifyTC $ \s -> s { stPersistentState = (stPersistentState s) { stDecodedModules = @@ -105,7 +96,7 @@ } } -withImportPath :: [C.TopLevelModuleName] -> TCM a -> TCM a +withImportPath :: [TopLevelModuleName] -> TCM a -> TCM a withImportPath path = localTC $ \e -> e { envImportPath = path } -- | Assumes that the first module in the import path is the module we are 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 @@ -4,25 +4,28 @@ import Prelude hiding (null) -import Control.DeepSeq - -import Control.Monad ( (<=<), guard ) -import Control.Monad.Except -import Control.Monad.State +import Control.Monad ( (<=<), forM_, guard ) +import Control.Monad.Except ( MonadError ) +import Control.Monad.State ( StateT, execStateT, get, put ) +import Control.Monad.Trans ( MonadTrans, lift ) import Control.Monad.Trans.Identity ( IdentityT ) -import Control.Monad.Reader -import Control.Monad.Writer +import Control.Monad.Reader ( ReaderT(ReaderT), runReaderT ) +import Control.Monad.Writer ( WriterT, execWriterT, tell ) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) +import qualified Data.HashMap.Strict as HMap import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List +import qualified Data.Map.Strict as MapS import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Foldable as Fold +import GHC.Stack (HasCallStack) + import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars @@ -33,15 +36,18 @@ import Agda.TypeChecking.Monad.Builtin (HasBuiltins) import Agda.TypeChecking.Monad.Trace import Agda.TypeChecking.Monad.Closure -import Agda.TypeChecking.Monad.Constraints (MonadConstraint) -import Agda.TypeChecking.Monad.Debug (MonadDebug, reportSLn) +import Agda.TypeChecking.Monad.Constraints (MonadConstraint(..)) +import Agda.TypeChecking.Monad.Debug + (MonadDebug, reportSLn, __IMPOSSIBLE_VERBOSE__) import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Signature (HasConstInfo) +import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Substitute import {-# SOURCE #-} Agda.TypeChecking.Telescope import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor ((<.>)) +import Agda.Utils.Lens import Agda.Utils.List (nubOn) import Agda.Utils.Maybe import Agda.Utils.Monad @@ -104,8 +110,8 @@ -- metas. assignTerm' :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m () - -- | Eta expand a metavariable, if it is of the specified kind. - -- Don't do anything if the metavariable is a blocked term. + -- | 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 () -- | Update the status of the metavariable @@ -116,89 +122,219 @@ -- rolled back and 'fallback' is run instead. speculateMetas :: m () -> m KeepMetas -> m () +instance MonadMetaSolver m => MonadMetaSolver (ReaderT r m) where + newMeta' inst f i p perm j = lift $ newMeta' inst f i p perm j + assignV dir m us v cmp = lift $ assignV dir m us v cmp + assignTerm' m us v = lift $ assignTerm' m us v + etaExpandMeta k m = lift $ etaExpandMeta k m + updateMetaVar m f = lift $ updateMetaVar m f + speculateMetas fallback m = ReaderT $ \x -> speculateMetas (runReaderT fallback x) (runReaderT m x) + -- | Switch off assignment of metas. dontAssignMetas :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a dontAssignMetas cont = do reportSLn "tc.meta" 45 $ "don't assign metas" localTC (\ env -> env { envAssignMetas = False }) cont --- | Get the meta store. -getMetaStore :: (ReadTCState m) => m MetaStore -getMetaStore = useR stMetaStore +-- | Is the meta-variable from another top-level module? -modifyMetaStore :: (MetaStore -> MetaStore) -> TCM () -modifyMetaStore f = stMetaStore `modifyTCLens` f +isRemoteMeta :: ReadTCState m => m (MetaId -> Bool) +isRemoteMeta = do + h <- currentModuleNameHash + return (\m -> h /= metaModule m) +-- | If another meta-variable is created, then it will get this +-- 'MetaId' (unless the state is changed too much, for instance by +-- 'setTopLevelModule'). + +nextLocalMeta :: ReadTCState m => m MetaId +nextLocalMeta = useR stFreshMetaId + +-- | Pairs of local meta-stores. + +data LocalMetaStores = LocalMetaStores + { openMetas :: LocalMetaStore + -- ^ A 'MetaStore' containing open meta-variables. + , solvedMetas :: LocalMetaStore + -- ^ A 'MetaStore' containing instantiated meta-variables. + } + -- | Run a computation and record which new metas it created. -metasCreatedBy :: ReadTCState m => m a -> m (a, MetaStore) +metasCreatedBy :: + forall m a. ReadTCState m => m a -> m (a, LocalMetaStores) metasCreatedBy m = do - -- Compute largestMeta strictly to avoid leaking memory. - !largestMeta <- force . fmap fst . IntMap.lookupMax <$> - useTC stMetaStore - a <- m - ms <- useTC stMetaStore - let createdMetas = case largestMeta of - Nothing -> ms - Just largestMeta -> snd $ IntMap.split largestMeta ms - return (a, createdMetas) + !nextMeta <- nextLocalMeta + a <- m + os <- created stOpenMetaStore nextMeta + ss <- created stSolvedMetaStore nextMeta + return (a, LocalMetaStores { openMetas = os, solvedMetas = ss }) + where + created :: Lens' LocalMetaStore TCState -> MetaId -> m LocalMetaStore + created store next = do + ms <- useTC store + return $ case MapS.splitLookup next ms of + (_, Nothing, ms) -> ms + (_, Just m, ms) -> MapS.insert next m ms --- | Lookup a meta variable. -lookupMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable) -lookupMeta' m = IntMap.lookup (metaId m) <$> getMetaStore +-- | Find information about the given local meta-variable, if any. -lookupMeta :: (MonadFail m, ReadTCState m) => MetaId -> m MetaVariable -lookupMeta m = fromMaybeM failure $ lookupMeta' m - where failure = fail $ "no such meta variable " ++ prettyShow m +lookupLocalMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable) +lookupLocalMeta' m = do + mv <- lkup <$> useR stSolvedMetaStore + case mv of + mv@Just{} -> return mv + Nothing -> lkup <$> useR stOpenMetaStore + where + lkup = MapS.lookup m --- | Type of a term or sort meta. -metaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type -metaType x = jMetaType . mvJudgement <$> lookupMeta x +-- | Find information about the given local meta-variable. --- | Update the information associated with a meta variable. -updateMetaVarTCM :: MetaId -> (MetaVariable -> MetaVariable) -> TCM () -updateMetaVarTCM m f = modifyMetaStore $ IntMap.adjust f $ metaId m +lookupLocalMeta :: + (HasCallStack, MonadDebug m, ReadTCState m) => + MetaId -> m MetaVariable +lookupLocalMeta m = + fromMaybeM (__IMPOSSIBLE_VERBOSE__ err) $ lookupLocalMeta' m + where + err = "no such local meta-variable " ++ prettyShow m --- | Insert a new meta variable with associated information into the meta store. +-- | Find information about the (local or remote) meta-variable, if +-- any. +-- +-- If no meta-variable is found, then the reason could be that the +-- dead-code elimination +-- ('Agda.TypeChecking.DeadCode.eliminateDeadCode') failed to find the +-- meta-variable, perhaps because some 'NamesIn' instance is +-- incorrectly defined. + +lookupMeta :: + ReadTCState m => + MetaId -> m (Maybe (Either RemoteMetaVariable MetaVariable)) +lookupMeta m = do + mv <- lookupLocalMeta' m + case mv of + Just mv -> return (Just (Right mv)) + Nothing -> fmap Left . HMap.lookup m <$> useR stImportedMetaStore + +-- | Find the meta-variable's instantiation. + +lookupMetaInstantiation :: + ReadTCState m => MetaId -> m MetaInstantiation +lookupMetaInstantiation m = do + mi <- lookupMeta m + case mi of + Just (Left mv) -> return (InstV $ rmvInstantiation mv) + Just (Right mv) -> return (mvInstantiation mv) + Nothing -> __IMPOSSIBLE__ + +-- | Find the meta-variable's judgement. + +lookupMetaJudgement :: ReadTCState m => MetaId -> m (Judgement MetaId) +lookupMetaJudgement m = do + mi <- lookupMeta m + case mi of + Just (Left mv) -> return (rmvJudgement mv) + Just (Right mv) -> return (mvJudgement mv) + Nothing -> __IMPOSSIBLE__ + +-- | Find the meta-variable's modality. + +lookupMetaModality :: ReadTCState m => MetaId -> m Modality +lookupMetaModality m = do + mi <- lookupMeta m + case mi of + Just (Left mv) -> return (rmvModality mv) + Just (Right mv) -> return (getModality mv) + Nothing -> __IMPOSSIBLE__ + +-- | The type of a term or sort meta-variable. +metaType :: ReadTCState m => MetaId -> m Type +metaType x = jMetaType <$> lookupMetaJudgement x + +-- | Update the information associated with a local meta-variable. +updateMetaVarTCM :: + HasCallStack => MetaId -> (MetaVariable -> MetaVariable) -> TCM () +updateMetaVarTCM m f = do + mv <- lookupLocalMeta' m + case mv of + Nothing -> do + mv <- lookupMeta m + case mv of + Nothing -> __IMPOSSIBLE_VERBOSE__ + ("Meta-variable not found: " ++ prettyShow m) + Just{} -> __IMPOSSIBLE_VERBOSE__ + ("Attempt to update remote meta-variable: " ++ + prettyShow m) + Just mv -> do + let mv' = f mv + insert = (`modifyTCLens` MapS.insert m mv') + delete = (`modifyTCLens` MapS.delete m) + case ( isOpenMeta (mvInstantiation mv) + , isOpenMeta (mvInstantiation mv') + ) of + (True, True) -> insert stOpenMetaStore + (False, False) -> insert stSolvedMetaStore + (True, False) -> do + delete stOpenMetaStore + insert stSolvedMetaStore + (False, True) -> __IMPOSSIBLE__ + +-- | Insert a new meta-variable with associated information into the +-- local meta store. insertMetaVar :: MetaId -> MetaVariable -> TCM () -insertMetaVar m mv = modifyMetaStore $ IntMap.insert (metaId m) mv +insertMetaVar m mv + | isOpenMeta (mvInstantiation mv) = insert stOpenMetaStore + | otherwise = insert stSolvedMetaStore + where + insert = (`modifyTCLens` MapS.insert m mv) -getMetaPriority :: (MonadFail m, ReadTCState m) => MetaId -> m MetaPriority -getMetaPriority = mvPriority <.> lookupMeta +-- | Returns the 'MetaPriority' of the given local meta-variable. +getMetaPriority :: + (HasCallStack, MonadDebug m, ReadTCState m) => + MetaId -> m MetaPriority +getMetaPriority = mvPriority <.> lookupLocalMeta -isSortMeta :: (MonadFail m, ReadTCState m) => MetaId -> m Bool -isSortMeta m = isSortMeta_ <$> lookupMeta m +isSortMeta :: ReadTCState m => MetaId -> m Bool +isSortMeta m = isSortJudgement <$> lookupMetaJudgement m isSortMeta_ :: MetaVariable -> Bool -isSortMeta_ mv = case mvJudgement mv of - HasType{} -> False - IsSort{} -> True +isSortMeta_ mv = isSortJudgement (mvJudgement mv) -getMetaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type +isSortJudgement :: Judgement a -> Bool +isSortJudgement HasType{} = False +isSortJudgement IsSort{} = True + +getMetaType :: ReadTCState m => MetaId -> m Type getMetaType m = do - mv <- lookupMeta m - return $ case mvJudgement mv of + j <- lookupMetaJudgement m + return $ case j of HasType{ jMetaType = t } -> t IsSort{} -> __IMPOSSIBLE__ --- | Compute the context variables that a meta should be applied to, accounting --- for pruning. +-- | Compute the context variables that a local meta-variable should +-- be applied to, accounting for pruning. getMetaContextArgs :: MonadTCEnv m => MetaVariable -> m Args getMetaContextArgs MetaVar{ mvPermutation = p } = do args <- getContextArgs return $ permute (takeP (length args) p) args --- | Given a meta, return the type applied to the current context. -getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m) - => MetaId -> m Type +-- | Given a local meta-variable, return the type applied to the +-- current context. +getMetaTypeInContext :: + (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m, + MonadTCEnv m, ReadTCState m) => + MetaId -> m Type getMetaTypeInContext m = do - mv@MetaVar{ mvJudgement = j } <- lookupMeta m + mv@MetaVar{ mvJudgement = j } <- lookupLocalMeta m case j of HasType{ jMetaType = t } -> piApplyM t =<< getMetaContextArgs mv IsSort{} -> __IMPOSSIBLE__ --- | Is it a meta that might be generalized? -isGeneralizableMeta :: (ReadTCState m, MonadFail m) => MetaId -> m DoGeneralize -isGeneralizableMeta x = unArg . miGeneralizable . mvInfo <$> lookupMeta x +-- | Is it a local meta-variable that might be generalized? +isGeneralizableMeta :: + (HasCallStack, MonadDebug m, ReadTCState m) => + MetaId -> m DoGeneralize +isGeneralizableMeta x = + unArg . miGeneralizable . mvInfo <$> lookupLocalMeta x -- | Check whether all metas are instantiated. -- Precondition: argument is a meta (in some form) or a list of metas. @@ -242,11 +378,10 @@ isInstantiatedMeta' :: (MonadFail m, ReadTCState m) => MetaId -> m (Maybe Term) isInstantiatedMeta' m = do - mv <- lookupMeta m - return $ case mvInstantiation mv of - InstV tel v -> Just $ foldr mkLam v tel - _ -> Nothing - + inst <- lookupMetaInstantiation m + return $ case inst of + InstV inst -> Just $ foldr mkLam (instBody inst) (instTel inst) + _ -> Nothing -- | Returns all metavariables in a constraint. Slightly complicated by the -- fact that blocked terms are represented by two meta variables. To find the @@ -279,6 +414,7 @@ CheckSizeLtSat{} -> return mempty HasBiggerSort{} -> return mempty HasPTSRule{} -> return mempty + CheckDataSort{} -> return mempty CheckMetaInst x -> return mempty CheckType t -> return $ allMetas Set.singleton t CheckLockedVars a b c d -> return $ allMetas Set.singleton (a, b, c, d) @@ -319,8 +455,11 @@ "cannot set meta name; newMeta returns " ++ show u return () -getMetaNameSuggestion :: (MonadFail m, ReadTCState m) => MetaId -> m MetaNameSuggestion -getMetaNameSuggestion mi = miNameSuggestion . mvInfo <$> lookupMeta mi +getMetaNameSuggestion :: + (HasCallStack, MonadDebug m, ReadTCState m) => + MetaId -> m MetaNameSuggestion +getMetaNameSuggestion mi = + miNameSuggestion . mvInfo <$> lookupLocalMeta mi setMetaNameSuggestion :: MonadMetaSolver m => MetaId -> MetaNameSuggestion -> m () setMetaNameSuggestion mi s = unless (null s || isUnderscore s) $ do @@ -329,7 +468,8 @@ updateMetaVar mi $ \ mvar -> mvar { mvInfo = (mvInfo mvar) { miNameSuggestion = s }} --- | Change the ArgInfo that will be used when generalizing over this meta. +-- | Change the ArgInfo that will be used when generalizing over this +-- local meta-variable. setMetaGeneralizableArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m () setMetaGeneralizableArgInfo m i = updateMetaVar m $ \ mv -> mv { mvInfo = (mvInfo mv) @@ -413,7 +553,7 @@ sameRange (ii, InteractionPoint r' _ False _) | r == r' = Just ii sameRange _ = Nothing --- | Hook up meta variable to interaction point. +-- | Hook up a local meta-variable to an interaction point. connectInteractionPoint :: MonadInteractionPoints m => InteractionId -> MetaId -> m () @@ -441,16 +581,19 @@ getInteractionMetas = mapMaybe ipMeta . filter (not . ipSolved) . BiMap.elems <$> useR stInteractionPoints -getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range] +getUniqueMetasRanges :: + (HasCallStack, MonadDebug m, ReadTCState m) => [MetaId] -> m [Range] getUniqueMetasRanges = fmap (nubOn id) . mapM getMetaRange -getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range] +getUnsolvedMetas :: + (HasCallStack, MonadDebug m, ReadTCState m) => m [Range] getUnsolvedMetas = do openMetas <- getOpenMetas interactionMetas <- getInteractionMetas getUniqueMetasRanges (openMetas List.\\ interactionMetas) -getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range] +getUnsolvedInteractionMetas :: + (HasCallStack, MonadDebug m, ReadTCState m) => m [Range] getUnsolvedInteractionMetas = getUniqueMetasRanges =<< getInteractionMetas -- | Get all metas that correspond to unsolved interaction ids. @@ -523,14 +666,17 @@ => InteractionId -> m Range getInteractionRange = ipRange <.> lookupInteractionPoint --- | Get the 'Range' for a meta variable. -getMetaRange :: (MonadFail m, ReadTCState m) => MetaId -> m Range -getMetaRange = getRange <.> lookupMeta +-- | Get the 'Range' for a local meta-variable. +getMetaRange :: + (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Range +getMetaRange = getRange <.> lookupLocalMeta -getInteractionScope - :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m) - => InteractionId -> m ScopeInfo -getInteractionScope = getMetaScope <.> lookupMeta <=< lookupInteractionId +getInteractionScope :: + (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m, + MonadTCEnv m) => + InteractionId -> m ScopeInfo +getInteractionScope = + getMetaScope <.> lookupLocalMeta <=< lookupInteractionId withMetaInfo' :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaVariable -> m a -> m a withMetaInfo' mv = withMetaInfo (miClosRange $ mvInfo mv) @@ -539,27 +685,24 @@ withMetaInfo mI cont = enterClosure mI $ \ r -> setCurrentRange r cont -withInteractionId - :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m) - => InteractionId -> m a -> m a +withInteractionId :: + (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m, + MonadTCEnv m, MonadTrace m) => + InteractionId -> m a -> m a withInteractionId i ret = do m <- lookupInteractionId i withMetaId m ret -withMetaId - :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadTrace m) - => MetaId -> m a -> m a +withMetaId :: + (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m, + ReadTCState m) => + MetaId -> m a -> m a withMetaId m ret = do - mv <- lookupMeta m + mv <- lookupLocalMeta m withMetaInfo' mv ret -getMetaVariables :: ReadTCState m => (MetaVariable -> Bool) -> m [MetaId] -getMetaVariables p = do - store <- getMetaStore - return [ MetaId i | (i, mv) <- IntMap.assocs store, p mv ] - getOpenMetas :: ReadTCState m => m [MetaId] -getOpenMetas = getMetaVariables (isOpenMeta . mvInstantiation) +getOpenMetas = MapS.keys <$> useR stOpenMetaStore isOpenMeta :: MetaInstantiation -> Bool isOpenMeta Open = True @@ -579,56 +722,98 @@ unlistenToMeta l m = updateMetaVar m $ \mv -> mv { mvListeners = Set.delete l $ mvListeners mv } --- | Get the listeners to a meta. -getMetaListeners :: (MonadFail m, ReadTCState m) => MetaId -> m [Listener] -getMetaListeners m = Set.toList . mvListeners <$> lookupMeta m +-- | Get the listeners for a local meta-variable. +getMetaListeners :: + (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m [Listener] +getMetaListeners m = Set.toList . mvListeners <$> lookupLocalMeta m clearMetaListeners :: MonadMetaSolver m => MetaId -> m () clearMetaListeners m = updateMetaVar m $ \mv -> mv { mvListeners = Set.empty } +-- | Do safe eta-expansions for meta (@SingletonRecords,Levels@). +etaExpandMetaSafe :: (MonadMetaSolver m) => MetaId -> m () +etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels] + +-- | Eta expand metavariables listening on the current meta. +etaExpandListeners :: MonadMetaSolver m => MetaId -> m () +etaExpandListeners m = do + ls <- getMetaListeners m + clearMetaListeners m -- we don't really have to do this + mapM_ wakeupListener ls + +-- | Wake up a meta listener and let it do its thing +wakeupListener :: MonadMetaSolver m => Listener -> m () + -- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevance +wakeupListener (EtaExpand x) = etaExpandMetaSafe x +wakeupListener (CheckConstraint _ c) = do + --reportSDoc "tc.meta.blocked" 20 $ "waking boxed constraint" <+> prettyTCM c + modifyAwakeConstraints (c:) + solveAwakeConstraints + +solveAwakeConstraints :: (MonadConstraint m) => m () +solveAwakeConstraints = solveAwakeConstraints' False + +solveAwakeConstraints' :: (MonadConstraint m) => Bool -> m () +solveAwakeConstraints' = solveSomeAwakeConstraints (const True) + --------------------------------------------------------------------------- -- * Freezing and unfreezing metas. --------------------------------------------------------------------------- --- | Freeze the given meta-variables and return those that were not --- already frozen. -freezeMetas :: MetaStore -> TCM IntSet +-- | Freeze the given meta-variables (but only if they are open) and +-- return those that were not already frozen. +freezeMetas :: MonadTCState m => LocalMetaStore -> m (Set MetaId) freezeMetas ms = execWriterT $ - modifyTCLensM stMetaStore $ - execStateT (mapM_ freeze $ IntMap.keys ms) + modifyTCLensM stOpenMetaStore $ + execStateT (mapM_ freeze $ MapS.keys ms) where - freeze :: Monad m => Int -> StateT MetaStore (WriterT IntSet m) () + freeze :: + Monad m => + MetaId -> StateT LocalMetaStore (WriterT (Set MetaId) m) () freeze m = do store <- get - case IntMap.lookup m store of + case MapS.lookup m store of Just mvar | mvFrozen mvar /= Frozen -> do - lift $ tell (IntSet.singleton m) - put $ IntMap.insert m (mvar { mvFrozen = Frozen }) store + lift $ tell (Set.singleton m) + put $ MapS.insert m (mvar { mvFrozen = Frozen }) store | otherwise -> return () - Nothing -> __IMPOSSIBLE__ + Nothing -> return () --- | Thaw all meta variables. +-- | Thaw all open meta variables. unfreezeMetas :: TCM () -unfreezeMetas = modifyMetaStore $ IntMap.map unfreeze +unfreezeMetas = stOpenMetaStore `modifyTCLens` MapS.map unfreeze where unfreeze :: MetaVariable -> MetaVariable unfreeze mvar = mvar { mvFrozen = Instantiable } -isFrozen :: (MonadFail m, ReadTCState m) => MetaId -> m Bool +isFrozen :: + (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Bool isFrozen x = do - mvar <- lookupMeta x + mvar <- lookupLocalMeta x return $ mvFrozen mvar == Frozen --- | Unfreeze meta and its type if this is a meta again. --- Does not unfreeze deep occurrences of metas. +withFrozenMetas + :: (MonadMetaSolver m, MonadTCState m) + => m a -> m a +withFrozenMetas act = do + openMetas <- useR stOpenMetaStore + frozenMetas <- freezeMetas openMetas + result <- act + forM_ (Set.toList frozenMetas) $ \m -> + updateMetaVar m $ \ mv -> mv { mvFrozen = Instantiable } + return result + +-- | Unfreeze a meta and its type if this is a meta again. +-- Does not unfreeze deep occurrences of meta-variables or remote +-- meta-variables. class UnFreezeMeta a where unfreezeMeta :: MonadMetaSolver m => a -> m () instance UnFreezeMeta MetaId where - unfreezeMeta x = do + unfreezeMeta x = unlessM (($ x) <$> isRemoteMeta) $ do updateMetaVar x $ \ mv -> mv { mvFrozen = Instantiable } unfreezeMeta =<< metaType x diff --git a/src/full/Agda/TypeChecking/Monad/Mutual.hs b/src/full/Agda/TypeChecking/Monad/Mutual.hs --- a/src/full/Agda/TypeChecking/Monad/Mutual.hs +++ b/src/full/Agda/TypeChecking/Monad/Mutual.hs @@ -66,14 +66,11 @@ currentOrFreshMutualBlock :: TCM MutualId currentOrFreshMutualBlock = maybe fresh return =<< asksTC envMutualBlock -lookupMutualBlock :: MutualId -> TCM MutualBlock -lookupMutualBlock mi = do - mbs <- useTC stMutualBlocks - case Map.lookup mi mbs of - Just mb -> return mb - Nothing -> return empty -- can end up here if we ask for the current mutual block and there is none +lookupMutualBlock :: ReadTCState tcm => MutualId -> tcm MutualBlock +lookupMutualBlock mi = Map.findWithDefault empty mi <$> useTC stMutualBlocks + -- can be empty if we ask for the current mutual block and there is none --- | Reverse lookup of a mutual block id for a names. +-- | Reverse lookup of a mutual block id for a name. mutualBlockOf :: QName -> TCM MutualId mutualBlockOf x = do mb <- Map.toList <$> useTC stMutualBlocks diff --git a/src/full/Agda/TypeChecking/Monad/Open.hs b/src/full/Agda/TypeChecking/Monad/Open.hs --- a/src/full/Agda/TypeChecking/Monad/Open.hs +++ b/src/full/Agda/TypeChecking/Monad/Open.hs @@ -60,11 +60,9 @@ if m == cur then return o else return $ OpenThing (-1) (Map.filterWithKey (\ k _ -> k == 0) env) m x - findParent m1 m2 - | Set.null keys = empty - | otherwise = return $ Set.findMax keys - where - keys = Set.intersection (Map.keysSet m1) (Map.keysSet m2) + findParent m1 m2 = case Map.lookupMax (Map.intersection m1 m2) of + Nothing -> empty + Just (max, _) -> return max -- | An 'Open' is closed if it has checkpoint 0. isClosed :: Open a -> Bool 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 @@ -1,6 +1,8 @@ module Agda.TypeChecking.Monad.Options where +import Prelude hiding (null) + import Control.Arrow ( (&&&) ) import Control.Monad ( unless, when ) import Control.Monad.IO.Class ( MonadIO(..) ) @@ -19,24 +21,28 @@ import System.FilePath import Agda.Syntax.Common -import Agda.Syntax.Concrete (TopLevelModuleName) import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.TopLevelModuleName + import Agda.TypeChecking.Monad.Debug (reportSDoc) import Agda.TypeChecking.Warnings import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Imports import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.Benchmark + import Agda.Interaction.FindFile import Agda.Interaction.Options import qualified Agda.Interaction.Options.Lenses as Lens import Agda.Interaction.Library + import Agda.Utils.FileName import Agda.Utils.Functor import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G import Agda.Utils.List import Agda.Utils.Maybe +import Agda.Utils.Null import Agda.Utils.Pretty import Agda.Utils.Tuple import Agda.Utils.WithDefault @@ -44,26 +50,23 @@ import Agda.Utils.Impossible -- | Sets the pragma options. - +-- Checks for unsafe combinations. setPragmaOptions :: PragmaOptions -> TCM () setPragmaOptions opts = do - stPragmaOptions `modifyTCLens` Lens.mapSafeMode (Lens.getSafeMode opts ||) - clo <- commandLineOptions - let unsafe = unsafePragmaOptions clo opts - when (Lens.getSafeMode opts && not (null unsafe)) $ warning $ SafeFlagPragma unsafe - runOptM (checkOpts clo{ optPragmaOptions = opts }) >>= \case - Left err -> __IMPOSSIBLE__ - Right opts -> do - stPragmaOptions `setTCLens` optPragmaOptions opts - updateBenchmarkingStatus + -- Check for unsafe pragma options if @--safe@ is on. + when (Lens.getSafeMode opts) $ + unlessNull (unsafePragmaOptions opts) $ \ unsafe -> + warning $ SafeFlagPragma unsafe + stPragmaOptions `setTCLens` opts + updateBenchmarkingStatus + -- | Sets the command line options (both persistent and pragma options -- are updated). -- -- Relative include directories are made absolute with respect to the -- current working directory. If the include directories have changed --- (thus, they are 'Left' now, and were previously @'Right' something@), --- then the state is reset (completely, see setIncludeDirs) . +-- then the state is reset (partly, see 'setIncludeDirs'). -- -- An empty list of relative include directories (@'Left' []@) is -- interpreted as @["."]@. @@ -78,9 +81,7 @@ -> CommandLineOptions -> TCM () setCommandLineOptions' root opts = do - runOptM (checkOpts opts) >>= \case - Left err -> __IMPOSSIBLE__ - Right opts -> do + -- Andreas, 2022-11-19: removed a call to checkOpts which did nothing. incs <- case optAbsoluteIncludePaths opts of [] -> do opts' <- setLibraryPaths root opts @@ -108,15 +109,27 @@ Left s -> typeError $ GenericDocError s Right x -> return x -getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile] -getAgdaLibFiles root = do +-- | Returns the library files for a given file. + +getAgdaLibFiles + :: AbsolutePath -- ^ The file name. + -> TopLevelModuleName -- ^ The top-level module name. + -> TCM [AgdaLibFile] +getAgdaLibFiles f m = do useLibs <- optUseLibs <$> commandLineOptions if | useLibs -> libToTCM $ mkLibM [] $ getAgdaLibFiles' root | otherwise -> return [] + where + root = filePath (projectRoot f m) -getLibraryOptions :: FilePath -> TCM [OptionsPragma] -getLibraryOptions root = map _libPragmas <$> getAgdaLibFiles root +-- | Returns the library options for a given file. +getLibraryOptions + :: AbsolutePath -- ^ The file name. + -> TopLevelModuleName -- ^ The top-level module name. + -> TCM [OptionsPragma] +getLibraryOptions f m = map _libPragmas <$> getAgdaLibFiles f m + setLibraryPaths :: AbsolutePath -- ^ The base directory of relative paths. @@ -161,7 +174,9 @@ setOptionsFromPragma :: OptionsPragma -> TCM () setOptionsFromPragma ps = do opts <- commandLineOptions - runOptM (parsePragmaOptions ps opts) >>= \case + let (z, warns) = runOptM (parsePragmaOptions ps opts) + mapM_ (warning . OptionWarning) warns + case z of Left err -> typeError $ GenericError err Right opts' -> setPragmaOptions opts' @@ -278,16 +293,16 @@ -- A graph with one node per module in old, and an edge from m to -- n if the module corresponding to m imports the module -- corresponding to n. - dependencyGraph :: G.Graph A.ModuleName () + dependencyGraph :: G.Graph TopLevelModuleName () dependencyGraph = G.fromNodes - [ iModuleName $ miInterface m + [ iTopLevelModuleName $ miInterface m | m <- Map.elems old ] `G.union` G.fromEdges [ G.Edge - { source = iModuleName $ miInterface m + { source = iTopLevelModuleName $ miInterface m , target = d , label = () } @@ -304,17 +319,16 @@ -- Agda does not allow cycles in the dependency graph. __IMPOSSIBLE__ Graph.AcyclicSCC m -> - case Map.lookup (A.toTopLevelModuleName m) old of + case Map.lookup m old of Just m -> m Nothing -> __IMPOSSIBLE__) $ G.sccs' dependencyGraph process :: - Map A.ModuleName ModuleInfo -> ModuleToSource -> [ModuleInfo] -> - TCM (DecodedModules, ModuleToSource) + Map TopLevelModuleName ModuleInfo -> ModuleToSource -> + [ModuleInfo] -> TCM (DecodedModules, ModuleToSource) process !keep !modFile [] = return ( Map.fromList $ - map (mapFst A.toTopLevelModuleName) $ Map.toList keep , modFile ) @@ -323,13 +337,12 @@ depsKept = all (`Map.member` keep) deps (keep, modFile) <- if not depsKept then return (keep, modFile) else do - let n = iModuleName $ miInterface m - t = A.toTopLevelModuleName n + let t = iTopLevelModuleName $ miInterface m oldF <- findFile' t (newF, modFile) <- liftIO $ findFile'' incs t modFile return $ case (oldF, newF) of (Right f1, Right f2) | f1 == f2 -> - (Map.insert n m keep, modFile) + (Map.insert t m keep, modFile) _ -> (keep, modFile) process keep modFile ms 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 @@ -38,6 +38,7 @@ import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Context +import Agda.TypeChecking.Monad.Constraints import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Mutual import Agda.TypeChecking.Monad.Open @@ -82,7 +83,7 @@ tel <- getContextTelescope let tel' = replaceEmptyName "r" $ killRange $ case theDef d of Constructor{} -> fmap hideOrKeepInstance tel - Function{ funProjection = Just Projection{ projProper = Just{}, projIndex = n } } -> + Function{ funProjection = Right Projection{ projProper = Just{}, projIndex = n } } -> let fallback = fmap hideOrKeepInstance tel in if n > 0 then fallback else -- if the record value is part of the telescope, its hiding should left unchanged @@ -109,9 +110,10 @@ addConstant q $ defaultDefn info x t lang def -- | Set termination info of a defined function symbol. -setTerminates :: QName -> Bool -> TCM () +setTerminates :: MonadTCState m => QName -> Bool -> m () setTerminates q b = modifySignature $ updateDefinition q $ updateTheDef $ \case def@Function{} -> def { funTerminates = Just b } + def@Record{} -> def { recTerminates = Just b } def -> def -- | Set CompiledClauses of a defined function symbol. @@ -135,13 +137,17 @@ -- | Lifts clauses to the top-level and adds them to definition. -- Also adjusts the 'funCopatternLHS' field if necessary. -addClauses :: QName -> [Clause] -> TCM () +addClauses :: (MonadConstraint m, MonadTCState m) => QName -> [Clause] -> m () addClauses q cls = do tel <- getContextTelescope modifySignature $ updateDefinition q $ updateTheDef (updateFunClauses (++ abstract tel cls)) . updateDefCopatternLHS (|| isCopatternLHS cls) + -- Jesper, 2022-10-13: unblock any constraints that were + -- waiting for more clauses of this function + wakeConstraints' $ wakeIfBlockedOnDef q . constraintUnblocker + mkPragma :: String -> TCM CompilerPragma mkPragma s = CompilerPragma <$> getCurrentRange <*> pure s @@ -180,7 +186,7 @@ vcat [ "-" <+> pretty (getRange p) | p <- ps ] setFunctionFlag :: FunctionFlag -> Bool -> QName -> TCM () -setFunctionFlag flag val q = modifyGlobalDefinition q $ set (theDefLens . funFlag flag) val +setFunctionFlag flag val q = modifyGlobalDefinition q $ set (lensTheDef . funFlag flag) val markStatic :: QName -> TCM () markStatic = setFunctionFlag FunStatic True @@ -507,14 +513,20 @@ -- This is because we may abstract the record argument later again. -- See succeed/ProjectionNotNormalized.agda isVar0 t = case unArg t of Var 0 [] -> True; _ -> False + proj :: Either ProjectionLikenessMissing Projection proj = case oldDef of - Function{funProjection = Just p@Projection{projIndex = n}} + Function{funProjection = Right p@Projection{projIndex = n}} | size ts' < n || (size ts' == n && maybe True isVar0 (lastMaybe ts')) - -> Just $ p { projIndex = n - size ts' - , projLams = projLams p `apply` ts' - , projProper= copyName <$> projProper p - } - _ -> Nothing + -> Right p { projIndex = n - size ts' + , projLams = projLams p `apply` ts' + , projProper= copyName <$> projProper p + } + -- Preserve no-projection-likeness flag if it exists, and + -- it's set to @Left _@. For future reference: The match + -- on left can't be simplified or it accidentally + -- circumvents the guard above. + Function{funProjection = Left projl} -> Left projl + _ -> Left MaybeProjection def = case oldDef of Constructor{ conPars = np, conData = d } -> return $ @@ -538,37 +550,38 @@ set funMacro (oldDef ^. funMacro) $ set funStatic (oldDef ^. funStatic) $ set funInline True $ - emptyFunction - { funClauses = [cl] - , funCompiled = Just cc - , funSplitTree = mst - , funMutual = mutual - , funProjection = proj - , funTerminates = Just True - , funExtLam = extlam - , funWith = with + FunctionDefn emptyFunctionData + { _funClauses = [cl] + , _funCompiled = Just cc + , _funSplitTree = mst + , _funMutual = mutual + , _funProjection = proj + , _funTerminates = Just True + , _funExtLam = extlam + , _funWith = with } reportSDoc "tc.mod.apply" 80 $ ("new def for" <+> pretty x) pretty newDef return newDef - cl = Clause { clauseLHSRange = getRange $ defClauses d - , clauseFullRange = getRange $ defClauses d - , clauseTel = EmptyTel - , namedClausePats = [] - , clauseBody = Just $ dropArgs pars $ case oldDef of - Function{funProjection = Just p} -> projDropParsApply p ProjSystem rel ts' + cl = Clause { clauseLHSRange = getRange $ defClauses d + , clauseFullRange = getRange $ defClauses d + , clauseTel = EmptyTel + , namedClausePats = [] + , clauseBody = Just $ dropArgs pars $ case oldDef of + Function{funProjection = Right p} -> projDropParsApply p ProjSystem rel ts' _ -> Def x $ map Apply ts' - , clauseType = Just $ defaultArg t - , clauseCatchall = False + , clauseType = Just $ defaultArg t + , clauseCatchall = False , clauseExact = Just True , clauseRecursive = Just False -- definitely not recursive , clauseUnreachable = Just False -- definitely not unreachable - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } where -- The number of remaining parameters. We need to drop the -- lambdas corresponding to these from the clause body above. - pars = max 0 $ maybe 0 (pred . projIndex) proj + pars = max 0 $ either (const 0) (pred . projIndex) proj rel = getRelevance $ defArgInfo d {- Example @@ -1241,8 +1254,8 @@ isProjection_ :: Defn -> Maybe Projection isProjection_ def = case def of - Function { funProjection = result } -> result - _ -> Nothing + Function { funProjection = Right result } -> Just result + _ -> Nothing -- | Is it the name of a non-irrelevant record projection? {-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-} diff --git a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs --- a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs +++ b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs @@ -8,8 +8,6 @@ import Control.Monad.Except import qualified Data.Foldable as Fold -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Traversable as Trav import Agda.Syntax.Common @@ -22,6 +20,8 @@ import Agda.TypeChecking.Substitute import Agda.Utils.List +import Agda.Utils.List1 (List1, pattern (:|)) +import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty @@ -164,7 +164,7 @@ -- | Transform list of terms into a term build from binary maximum. sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) - => NonEmpty Term -> m Term + => List1 Term -> m Term sizeMax vs = case vs of v :| [] -> return v vs -> do @@ -295,7 +295,7 @@ -- * View on sizes where maximum is pulled to the top ------------------------------------------------------------------------ -type SizeMaxView = NonEmpty DeepSizeView +type SizeMaxView = List1 DeepSizeView type SizeMaxView' = [DeepSizeView] maxViewMax :: SizeMaxView -> SizeMaxView -> SizeMaxView @@ -310,7 +310,7 @@ maxViewCons _ (DSizeInf :| _) = singleton DSizeInf maxViewCons DSizeInf _ = singleton DSizeInf maxViewCons v ws = case sizeViewComparableWithMax v ws of - NotComparable -> NonEmpty.cons v ws + NotComparable -> List1.cons v ws YesAbove _ ws' -> v :| ws' YesBelow{} -> ws 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 @@ -5,14 +5,13 @@ import qualified Control.Exception as E -import Control.Monad (void) +import Control.Monad (void, when) import Control.Monad.Trans (MonadIO, liftIO) import Data.Maybe import qualified Data.Map as Map -import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap @@ -29,6 +28,8 @@ import Agda.Syntax.Abstract.PatternSynonyms import Agda.Syntax.Abstract.Name import Agda.Syntax.Internal +import Agda.Syntax.Position +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Warnings @@ -37,8 +38,10 @@ import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.CompiledClause +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Hash import Agda.Utils.Lens +import qualified Agda.Utils.List1 as List1 import Agda.Utils.Monad (bracket_) import Agda.Utils.Pretty import Agda.Utils.Tuple @@ -326,23 +329,70 @@ -- * Top level module --------------------------------------------------------------------------- +-- | Tries to convert a raw top-level module name to a top-level +-- module name. + +topLevelModuleName :: RawTopLevelModuleName -> TCM TopLevelModuleName +topLevelModuleName raw = do + hash <- BiMap.lookup raw <$> useR stTopLevelModuleNames + case hash of + Just hash -> return (unsafeTopLevelModuleName raw hash) + Nothing -> do + let hash = hashRawTopLevelModuleName raw + when (hash == noModuleNameHash) $ typeError $ GenericError $ + "The module name " ++ prettyShow raw ++ " has a reserved " ++ + "hash (you may want to consider renaming the module with " ++ + "this name)" + raw' <- BiMap.invLookup hash <$> useR stTopLevelModuleNames + case raw' of + Just raw' -> typeError $ GenericError $ + "Module name hash collision for " ++ prettyShow raw ++ + " and " ++ prettyShow raw' ++ " (you may want to consider " ++ + "renaming one of these modules)" + Nothing -> do + stTopLevelModuleNames `modifyTCLens'` + BiMap.insert (killRange raw) hash + return (unsafeTopLevelModuleName raw hash) + -- | Set the top-level module. This affects the global module id of freshly -- generated names. --- TODO: Is the hash-function collision-free? If not, then the --- implementation of 'setTopLevelModule' should be changed. +setTopLevelModule :: TopLevelModuleName -> TCM () +setTopLevelModule top = do + let hash = moduleNameId top + stFreshNameId `setTCLens'` NameId 0 hash + stFreshMetaId `setTCLens'` + MetaId { metaId = 0 + , metaModule = hash + } -setTopLevelModule :: C.QName -> TCM () -setTopLevelModule x = stFreshNameId `setTCLens` NameId 0 (ModuleNameHash $ hashString $ prettyShow x) +-- | The name of the current top-level module, if any. +{-# SPECIALIZE + currentTopLevelModule :: TCM (Maybe TopLevelModuleName) #-} +{-# SPECIALIZE + currentTopLevelModule :: ReduceM (Maybe TopLevelModuleName) #-} +currentTopLevelModule :: + (MonadTCEnv m, ReadTCState m) => m (Maybe TopLevelModuleName) +currentTopLevelModule = do + m <- useR stCurrentModule + case m of + Just (_, top) -> return (Just top) + Nothing -> do + p <- asksTC envImportPath + return $ case p of + top : _ -> Just top + [] -> Nothing -- | Use a different top-level module for a computation. Used when generating -- names for imported modules. -withTopLevelModule :: C.QName -> TCM a -> TCM a +withTopLevelModule :: TopLevelModuleName -> TCM a -> TCM a withTopLevelModule x m = do - next <- useTC stFreshNameId + nextN <- useTC stFreshNameId + nextM <- useTC stFreshMetaId setTopLevelModule x y <- m - stFreshNameId `setTCLens` next + stFreshMetaId `setTCLens` nextM + stFreshNameId `setTCLens` nextN return y currentModuleNameHash :: ReadTCState m => m ModuleNameHash @@ -401,7 +451,7 @@ defs <- traverse lookupSinglePatternSyn xs case mergePatternSynDefs defs of Just def -> return def - Nothing -> typeError $ CannotResolveAmbiguousPatternSynonym (NonEmpty.zip xs defs) + Nothing -> typeError $ CannotResolveAmbiguousPatternSynonym $ List1.zip xs defs lookupSinglePatternSyn :: QName -> TCM PatternSynDefn lookupSinglePatternSyn x = do diff --git a/src/full/Agda/TypeChecking/Monad/Statistics.hs b/src/full/Agda/TypeChecking/Monad/Statistics.hs --- a/src/full/Agda/TypeChecking/Monad/Statistics.hs +++ b/src/full/Agda/TypeChecking/Monad/Statistics.hs @@ -14,7 +14,7 @@ import qualified Data.Map as Map import qualified Text.PrettyPrint.Boxes as Boxes -import Agda.Syntax.Concrete.Name as C +import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug @@ -76,17 +76,17 @@ tickMax :: MonadStatistics m => String -> Integer -> m () tickMax s n = modifyCounter s (max n) --- | Print the given statistics if verbosity "profile.ticks" is given. +-- | Print the given statistics. printStatistics :: (MonadDebug m, MonadTCEnv m, HasOptions m) - => Int -> Maybe C.TopLevelModuleName -> Statistics -> m () -printStatistics vl mmname stats = verboseS "profile.ticks" vl $ do + => Maybe TopLevelModuleName -> Statistics -> m () +printStatistics mmname stats = do unlessNull (Map.toList stats) $ \ stats -> do let -- First column (left aligned) is accounts. col1 = Boxes.vcat Boxes.left $ map (Boxes.text . fst) stats -- Second column (right aligned) is numbers. col2 = Boxes.vcat Boxes.right $ map (Boxes.text . showThousandSep . snd) stats table = Boxes.hsep 1 Boxes.left [col1, col2] - reportSLn "profile" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname -> + reportSLn "" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname -> "Statistics for " ++ prettyShow mname - reportSLn "profile" 1 $ Boxes.render table + reportSLn "" 1 $ Boxes.render table diff --git a/src/full/Agda/TypeChecking/Monad/Trace.hs b/src/full/Agda/TypeChecking/Monad/Trace.hs --- a/src/full/Agda/TypeChecking/Monad/Trace.hs +++ b/src/full/Agda/TypeChecking/Monad/Trace.hs @@ -61,6 +61,7 @@ CheckDataDef{} -> True CheckRecDef{} -> True CheckConstructor{} -> True + CheckIApplyConfluence{} -> True CheckConstructorFitsIn{} -> True CheckFunDefCall{} -> True CheckPragma{} -> True @@ -135,7 +136,7 @@ verboseS "check.ranges" 90 $ Strict.whenJust (rangeFile callRange) $ \f -> do currentFile <- asksTC envCurrentPath - when (currentFile /= Just f) $ do + when (currentFile /= Just (rangeFilePath f)) $ do reportSLn "check.ranges" 90 $ prettyShow call ++ " is setting the current range to " ++ show callRange ++ @@ -190,6 +191,7 @@ CheckPrimitive{} -> True CheckIsEmpty{} -> True CheckConfluence{} -> False + CheckIApplyConfluence{} -> False CheckWithFunctionType{} -> True CheckSectionApplication{} -> True CheckNamedWhere{} -> False 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 @@ -1,7 +1,7 @@ {-| EDSL to construct terms without touching De Bruijn indices. -e.g. if given t, u :: Term, Γ ⊢ t, u : A, we can build "λ f. f t u" like this: +e.g. given t, u :: Term, Γ ⊢ t, u : A, we can build "λ f. f t u" like this: runNames [] $ do -- @open@ binds @t@ and @u@ to computations that know how to weaken themselves in @@ -9,10 +9,10 @@ [t,u] <- mapM open [t,u] - -- @lam@ gives the illusion of HOAS by providing f as a computation + -- @lam@ gives the illusion of HOAS by providing f as a computation. -- It also extends the internal context with the name "f", so that -- @t@ and @u@ will get weakened in the body. - -- Then we finish the job using the (<@>) combinator from Agda.TypeChecking.Primitive + -- We apply f with the (<@>) combinator from Agda.TypeChecking.Primitive. lam "f" $ \ f -> f <@> t <@> u @@ -36,9 +36,14 @@ import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst) import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Errors +import Agda.TypeChecking.Level +import Agda.TypeChecking.Pretty () -- instances only import Agda.TypeChecking.Free import Agda.Utils.Fail (Fail, runFail_) +import Agda.Utils.Impossible instance HasBuiltins m => HasBuiltins (NamesT m) where getBuiltinThing b = lift $ getBuiltinThing b @@ -64,66 +69,77 @@ , PureTCM ) --- deriving instance MonadState s m => MonadState s (NamesT m) +-- | A list of variable names from a context. type Names = [String] runNamesT :: Names -> NamesT m a -> m a runNamesT n m = runReaderT (unName m) n --- We use @Fail@ instead of @Identity@ because the computation can fail. runNames :: Names -> NamesT Fail a -> a runNames n m = runFail_ (runNamesT n m) currentCxt :: Monad m => NamesT m Names currentCxt = NamesT ask +-- | @cxtSubst Γ@ returns the substitution needed to go +-- from Γ to the current context. +-- +-- Fails if @Γ@ is not a subcontext of the current one. cxtSubst :: MonadFail m => Names -> NamesT m (Substitution' a) cxtSubst ctx = do ctx' <- currentCxt if (ctx `isSuffixOf` ctx') then return $ raiseS (length ctx' - length ctx) - else fail $ "thing out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")" + else fail $ "out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")" +-- | @inCxt Γ t@ takes a @t@ in context @Γ@ and produce an action that +-- will return @t@ weakened to the current context. +-- +-- Fails whenever @cxtSubst Γ@ would. inCxt :: (MonadFail m, Subst a) => Names -> a -> NamesT m a inCxt ctx a = do sigma <- cxtSubst ctx return $ applySubst sigma a --- closed terms +-- | Closed terms cl' :: Applicative m => a -> NamesT m a cl' = pure cl :: Monad m => m a -> NamesT m a cl = lift +-- | Open terms in the current context. open :: (MonadFail m, Subst a) => a -> NamesT m (NamesT m a) open a = do ctx <- NamesT ask pure $ inCxt ctx a -bind' :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a +-- | Monadic actions standing for variables. +-- +-- @b@ is quantified over so the same variable can be used e.g. both +-- as a pattern and as an expression. +type Var m = forall b. (Subst b, DeBruijn b) => NamesT m b + + +-- | @bind n f@ provides @f@ with a fresh variable, which can be used in any extended context. +-- +-- Returns an @Abs@ which binds the extra variable. +bind :: MonadFail m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m (Abs a) +bind n f = Abs n <$> bind' n f + +-- | Like @bind@ but returns a bare term. +bind' :: MonadFail m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m a bind' n f = do cxt <- NamesT ask (NamesT . local (n:) . unName $ f (inCxt (n:cxt) (deBruijnVar 0))) -bind :: ( MonadFail m - , Subst b - , DeBruijn b - , Subst a - , Free a - ) => - ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a) -bind n f = Abs n <$> bind' n f +-- * Helpers to build lambda abstractions. + glam :: MonadFail m => ArgInfo -> ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term -glam info n f = Lam info <$> bind n f - -glamN :: (Functor m, MonadFail m) => - [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term -glamN [] f = f $ pure [] -glamN (Arg i n:ns) f = glam i n $ \ x -> glamN ns (\ xs -> f ((:) <$> (Arg i <$> x) <*> xs)) +glam info n f = Lam info <$> bind n (\ x -> f x) lam :: MonadFail m => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term @@ -132,3 +148,89 @@ ilam :: MonadFail m => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term ilam n f = glam (setRelevance Irrelevant defaultArgInfo) n f + + +-- * Combinators for n-ary binders. + +data AbsN a = AbsN { absNName :: [ArgName], unAbsN :: a } deriving (Functor,Foldable,Traversable) + +instance Subst a => Subst (AbsN a) where + type SubstArg (AbsN a) = SubstArg a + applySubst rho (AbsN xs a) = AbsN xs (applySubst (liftS (length xs) rho) a) + +-- | Will crash on @NoAbs@ +toAbsN :: Abs (AbsN a) -> AbsN a +toAbsN (Abs n x') = AbsN (n : absNName x') (unAbsN x') +toAbsN NoAbs{} = __IMPOSSIBLE__ + +absAppN :: Subst a => AbsN a -> [SubstArg a] -> a +absAppN f xs = (parallelS $ reverse xs) `applySubst` unAbsN f + +type ArgVars m = (forall b. (Subst b, DeBruijn b) => [NamesT m (Arg b)]) + +type Vars m = (forall b. (Subst b, DeBruijn b) => [NamesT m b]) + +bindN :: ( MonadFail m + ) => + [ArgName] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a) +bindN [] f = AbsN [] <$> f [] +bindN (x:xs) f = toAbsN <$> bind x (\ x -> bindN xs (\ xs -> f (x:xs))) + +bindNArg :: ( MonadFail m + ) => + [Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a) +bindNArg [] f = AbsN [] <$> f [] +bindNArg (Arg i x:xs) f = toAbsN <$> bind x (\ x -> bindNArg xs (\ xs -> f ((Arg i <$> x):xs))) + + +glamN :: (Functor m, MonadFail m) => + [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term +glamN [] f = f $ pure [] +glamN (Arg i n:ns) f = glam i n $ \ x -> glamN ns (\ xs -> f ((:) <$> (Arg i <$> x) <*> xs)) + + +applyN :: ( Monad m + , Subst a + ) => + NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a +applyN f xs = do + f <- f + xs <- sequence xs + unless (length xs == length (absNName f)) $ __IMPOSSIBLE__ + return $ absAppN f xs + +applyN' :: ( Monad m + , Subst a + ) => + NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a +applyN' f xs = do + f <- f + xs <- xs + unless (length xs == length (absNName f)) $ __IMPOSSIBLE__ + return $ absAppN f xs + +abstractN :: ( MonadFail m + , Abstract a + ) => + NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a +abstractN tel f = do + tel <- tel + u <- bindN (teleNames tel) f + return $ abstract tel $ unAbsN u + +abstractT :: ( MonadFail m + , Abstract a + ) => + String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a +abstractT n ty f = do + u <- bind n f + ty <- ty + let tel = ExtendTel (defaultDom ty) $ Abs n EmptyTel + return $ abstract tel $ unAbs u + + +lamTel :: Monad m => NamesT m (Abs [Term]) -> NamesT m ([Term]) +lamTel t = map (Lam defaultArgInfo) . sequenceA <$> t + +appTel :: Monad m => NamesT m [Term] -> NamesT m Term -> NamesT m [Term] +appTel = liftM2 (\ fs x -> map (`apply` [Arg defaultArgInfo x]) fs) 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 @@ -19,6 +19,7 @@ import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad hiding (constructorForm) +import Agda.TypeChecking.Monad.Builtin (getName',builtinHComp, builtinConId) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records @@ -56,7 +57,7 @@ buildSubstitution :: (DeBruijn a) => Impossible -> Int -> IntMap (Arg a) -> Substitution' a buildSubstitution err n vs = foldr cons idS $ matchedArgs' n vs - where cons Nothing = Strengthen err + where cons Nothing = strengthenS' err 1 cons (Just v) = consS (unArg v) @@ -262,12 +263,16 @@ -- can be matched on. isMatchable' :: HasBuiltins m => m (Blocked Term -> Maybe Term) isMatchable' = do - mhcomp <- getName' builtinHComp + [mhcomp,mconid] <- mapM getName' [builtinHComp, builtinConId] return $ \ r -> case ignoreBlocking r of t@Con{} -> Just t t@(Def q [l,a,phi,u,u0]) | Just q == mhcomp -> Just t + t@(Def q [l,a,x,y,phi,p]) | Just q == mconid + -> Just t + -- TODO this covers the transpIx functions, but it's a hack. + t@(Def q _) | NotBlocked{blockingStatus = MissingClauses _} <- r -> Just t _ -> Nothing -- DefP hcomp and ConP matching. 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE NondecreasingIndentation #-} -- | Check that a datatype is strictly positive. module Agda.TypeChecking.Positivity where @@ -11,7 +12,7 @@ import Data.Either import qualified Data.Foldable as Fold -import Data.Function +import Data.Function (on) import Data.Graph (SCC(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -28,6 +29,7 @@ import Agda.Syntax.Common import qualified Agda.Syntax.Info as Info import Agda.Syntax.Internal +import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position (HasRange(..), noRange) import Agda.TypeChecking.Datatypes ( isDataOrRecordType ) import Agda.TypeChecking.Functions @@ -407,6 +409,8 @@ occurrences cl = do let ps = namedClausePats cl items = IntMap.elems $ patItems ps -- sorted from low to high DBI + -- TODO #3733: handle hcomp/transp clauses properly + if hasDefP ps then return mempty else do (Concat (mapMaybe matching (zip [0..] ps)) <>) <$> do withExtendedOccEnv' items $ occurrences $ clauseBody cl diff --git a/src/full/Agda/TypeChecking/Positivity/Occurrence.hs b/src/full/Agda/TypeChecking/Positivity/Occurrence.hs --- a/src/full/Agda/TypeChecking/Positivity/Occurrence.hs +++ b/src/full/Agda/TypeChecking/Positivity/Occurrence.hs @@ -11,8 +11,6 @@ import Control.DeepSeq import Control.Monad -import Data.Data (Data) - import Data.Foldable (toList) import Data.Map.Strict (Map) @@ -46,7 +44,7 @@ -- includes the main information, and if the first sequence is -- non-empty, then it includes information about the context of -- the second sequence. - deriving (Show, Eq, Ord, Data, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData OccursWhere @@ -63,7 +61,7 @@ | Matched -- ^ matched against in a clause of a defined function | IsIndex -- ^ is an index of an inductive family | InDefOf QName -- ^ in the definition of a constant - deriving (Show, Eq, Ord, Data, Generic) + deriving (Show, Eq, Ord, Generic) instance NFData Where @@ -78,7 +76,7 @@ | StrictPos -- ^ Strictly positive occurrence. | GuardPos -- ^ Guarded strictly positive occurrence (i.e., under ∞). For checking recursive records. | Unused -- ^ No occurrence. - deriving (Data, Show, Eq, Ord, Enum, Bounded) + deriving (Show, Eq, Ord, Enum, Bounded) -- Pretty instances. 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 @@ -39,12 +39,14 @@ import qualified Agda.Syntax.Info as A import Agda.Syntax.Scope.Base (AbstractName(..)) import Agda.Syntax.Scope.Monad (withContextPrecedence) +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Substitute +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph) import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph import Agda.Utils.List1 ( List1, pattern (:|) ) @@ -144,13 +146,7 @@ -- * The PrettyTCM class --------------------------------------------------------------------------- -type MonadPretty m = - ( MonadReify m - , MonadAbsToCon m - , IsString (m Doc) - , Null (m Doc) - , Semigroup (m Doc) - ) +type MonadPretty m = MonadAbsToCon m -- This instance is to satify the constraints of superclass MonadPretty: -- | This instance is more specific than a generic instance @@ -169,6 +165,8 @@ instance PrettyTCM Bool where prettyTCM = pretty instance PrettyTCM C.Name where prettyTCM = pretty instance PrettyTCM C.QName where prettyTCM = pretty +instance PrettyTCM TopLevelModuleName + where prettyTCM = pretty instance PrettyTCM Comparison where prettyTCM = pretty instance PrettyTCM Literal where prettyTCM = pretty instance PrettyTCM Nat where prettyTCM = pretty @@ -209,7 +207,7 @@ instance PrettyTCM (NamedArg A.Expr) where prettyTCM = prettyA <=< reify instance PrettyTCM (NamedArg Term) where prettyTCM = prettyA <=< reify instance PrettyTCM (Dom Type) where prettyTCM = prettyA <=< reify -instance PrettyTCM (Dom (Name, Type)) where prettyTCM = prettyA <=< reify +instance PrettyTCM ContextEntry where prettyTCM = prettyA <=< reify instance PrettyTCM Permutation where prettyTCM = text . show instance PrettyTCM Polarity where prettyTCM = text . show @@ -241,8 +239,26 @@ instance PrettyTCM MetaId where prettyTCM x = do mn <- getMetaNameSuggestion x - pretty $ NamedMeta mn x + prettyTCM $ NamedMeta mn x +instance PrettyTCM NamedMeta where + prettyTCM (NamedMeta s m) = do + current <- currentModuleNameHash + prefix <- + if metaModule m == current + then return empty + else do + modName <- BiMap.invLookup (metaModule m) <$> + useR stTopLevelModuleNames + return $ case modName of + Nothing -> __IMPOSSIBLE__ + Just modName -> pretty modName <> text "." + let inBetween = case s of + "" -> text "_" + "_" -> text "_" + s -> text $ "_" ++ s ++ "_" + prefix <> inBetween <> text (show (metaId m)) + instance PrettyTCM a => PrettyTCM (Blocked a) where prettyTCM (Blocked x a) = ("[" <+> prettyTCM a <+> "]") <> text (P.prettyShow x) prettyTCM (NotBlocked _ x) = prettyTCM x @@ -272,6 +288,9 @@ instance PrettyTCM A.TypedBinding where prettyTCM = prettyA +instance PrettyTCM A.Pattern where + prettyTCM = prettyA + instance PrettyTCM Relevance where prettyTCM = pretty @@ -289,6 +308,7 @@ prettyTCM (UnblockOnAny us) = "any" <> parens (fsep $ punctuate "," $ map prettyTCM $ Set.toList us) prettyTCM (UnblockOnMeta m) = prettyTCM m prettyTCM (UnblockOnProblem p) = "problem" <+> pretty p + prettyTCM (UnblockOnDef q) = "definition" <+> pretty q instance PrettyTCM CompareAs where prettyTCM (AsTermsOf a) = ":" <+> prettyTCMCtx TopCtx a @@ -412,9 +432,11 @@ prettyTCM = \case PType l -> parens $ "Set" <+> prettyTCM l PProp l -> parens $ "Prop" <+> prettyTCM l + PSSet l -> parens $ "SSet" <+> prettyTCM l PInf f n -> prettyTCM (Inf f n :: Sort) PSizeUniv -> prettyTCM (SizeUniv :: Sort) PLockUniv -> prettyTCM (LockUniv :: Sort) + PIntervalUniv -> prettyTCM (IntervalUniv :: Sort) instance PrettyTCM (Elim' NLPat) where prettyTCM (IApply x y v) = prettyTCM v diff --git a/src/full/Agda/TypeChecking/Pretty.hs-boot b/src/full/Agda/TypeChecking/Pretty.hs-boot --- a/src/full/Agda/TypeChecking/Pretty.hs-boot +++ b/src/full/Agda/TypeChecking/Pretty.hs-boot @@ -31,20 +31,15 @@ pretty :: (Applicative m, P.Pretty a) => a -> m Doc prettyList_ :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc --- Inlining definitions of MonadReify and MonadAbsToCon to avoid --- having to import them +-- The definition of MonadAbsToCon is inlined so that the module +-- Agda.Syntax.Translation.AbstractToConcrete does not need to be +-- imported. type MonadPretty m = - ( ( PureTCM m - , MonadInteractionPoints m - , MonadFresh NameId m - ) - , ( MonadTCEnv m - , ReadTCState m - , MonadStConcreteNames m - , HasOptions m - , HasBuiltins m - , MonadDebug m - ) + ( MonadFresh NameId m + , MonadInteractionPoints m + , MonadStConcreteNames m + , HasOptions m + , PureTCM m , IsString (m Doc) , Null (m Doc) , Semigroup (m Doc) @@ -65,6 +60,7 @@ instance PrettyTCM Name instance PrettyTCM QName +instance PrettyTCM NamedMeta instance PrettyTCM Term instance PrettyTCM Elim instance PrettyTCM Type diff --git a/src/full/Agda/TypeChecking/Pretty/Call.hs b/src/full/Agda/TypeChecking/Pretty/Call.hs --- a/src/full/Agda/TypeChecking/Pretty/Call.hs +++ b/src/full/Agda/TypeChecking/Pretty/Call.hs @@ -15,6 +15,7 @@ import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Context +import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Pretty @@ -24,6 +25,8 @@ import Agda.Utils.Impossible +import Agda.Version (docsUrl) + sayWhere :: MonadPretty m => HasRange a => a -> m Doc -> m Doc sayWhere x d = applyUnless (null r) (prettyTCM r $$) d where r = getRange x @@ -33,9 +36,9 @@ sayWhen r (Just cl) m = sayWhere r (m $$ prettyTCM cl) instance PrettyTCM CallInfo where - prettyTCM c = do - let call = prettyTCM $ callInfoCall c - r = callInfoRange c + prettyTCM (CallInfo callInfoTarget callInfoCall) = do + let call = prettyTCM callInfoCall + r = getRange callInfoTarget if null $ P.pretty r then call else call $$ nest 2 ("(at" <+> prettyTCM r) <> ")" @@ -142,7 +145,8 @@ CheckWithFunctionType a -> fsep $ pwords "when checking that the type" ++ - [prettyTCM a] ++ pwords "of the generated with function is well-formed" + [prettyTCM a] ++ pwords "of the generated with function is well-formed" ++ + [parens $ text $ docsUrl "language/with-abstraction.html#ill-typed-with-abstractions"] CheckDotPattern e v -> fsep $ pwords "when checking that the given dot pattern" ++ [prettyA e] ++ @@ -192,6 +196,17 @@ info = A.ModuleInfo noRange noRange Nothing Nothing Nothing ModuleContents -> fsep $ pwords "when retrieving the contents of a module" + + CheckIApplyConfluence _ qn fn l r t -> do + vcat + [ fsep (pwords "when checking that a clause of" ++ [prettyTCM qn] ++ pwords "has the correct boundary.") + , "" + , "Specifically, the terms" + , nest 2 (prettyTCM l) + , "and" + , nest 2 (prettyTCM r) + , fsep (pwords "must be equal, since" ++ [prettyTCM fn] ++ pwords "could reduce to either.") + ] where hPretty :: MonadPretty m => Arg (Named_ Expr) -> m Doc 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 @@ -4,8 +4,10 @@ import Prelude hiding (null) import qualified Data.Set as Set +import Data.Foldable (Foldable) +import qualified Data.Foldable as Foldable import qualified Data.List as List -import Data.Function +import Data.Function (on) import Agda.Syntax.Common import Agda.Syntax.Position @@ -48,20 +50,37 @@ interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs' stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c -instance PrettyTCM ProblemConstraint where - prettyTCM (PConstr pids unblock c) = prettyTCM c parensNonEmpty (sep [blockedOn unblock, prPids (Set.toList pids)]) - where - prPids [] = empty - prPids [pid] = "belongs to problem" <+> prettyTCM pid - prPids pids = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids) +prettyRangeConstraint :: + (MonadPretty m, Foldable f, Null (f ProblemId)) => + Range -> f ProblemId -> Blocker -> Doc -> m Doc +prettyRangeConstraint r pids unblock c = + return c + sep [ prange r + , parensNonEmpty $ sep + [ blockedOn unblock + , prPids (Foldable.toList pids) + ] + ] + where + prPids [] = empty + prPids [pid] = "belongs to problem" <+> prettyTCM pid + prPids pids = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids) - comma | null pids = empty - | otherwise = "," + comma | null pids = empty + | otherwise = "," - blockedOn (UnblockOnAll bs) | Set.null bs = empty - blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma - blockedOn u = "blocked on" <+> (prettyTCM u <> comma) + blockedOn (UnblockOnAll bs) | Set.null bs = empty + blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma + blockedOn u = "blocked on" <+> (prettyTCM u <> comma) + prange r | null s = pure empty + | otherwise = text $ " [ at " ++ s ++ " ]" + where s = P.prettyShow r + +instance PrettyTCM ProblemConstraint where + prettyTCM (PConstr pids unblock c) = + prettyRangeConstraint noRange pids unblock =<< prettyTCM c + instance PrettyTCM Constraint where prettyTCM = \case ValueCmp cmp ty s t -> prettyCmp (prettyTCM cmp) s t prettyTCM ty @@ -74,7 +93,7 @@ SortCmp cmp s1 s2 -> prettyCmp (prettyTCM cmp) s1 s2 UnBlock m -> do -- BlockedConst t <- mvInstantiation <$> lookupMeta m - mi <- mvInstantiation <$> lookupMeta m + mi <- lookupMetaInstantiation m case mi of BlockedConst t -> prettyCmp ":=" m t PostponedTypeCheckingProblem cl -> enterClosure cl $ \p -> @@ -127,8 +146,10 @@ UnquoteTactic v _ _ -> do e <- reify v prettyTCM (A.App A.defaultAppInfo_ (A.Unquote A.exprNoRange) (defaultNamedArg e)) + CheckDataSort q s -> do + hsep [ "Sort", prettyTCM s, "of", prettyTCM q, "admits data/record definitions." ] CheckMetaInst x -> do - m <- lookupMeta x + m <- lookupLocalMeta x case mvJudgement m of HasType{ jMetaType = t } -> prettyTCM x <+> ":" <+> prettyTCM t IsSort{} -> prettyTCM x <+> "is a sort" @@ -136,7 +157,8 @@ prettyTCM t <+> "is a well-formed type" CheckLockedVars t ty lk lk_ty -> do "Lock" <+> prettyTCM lk <+> "|-" <+> prettyTCMCtx TopCtx t <+> ":" <+> prettyTCM ty - UsableAtModality mod t -> "Is usable at" <+> prettyTCM mod <+> ":" <+> prettyTCM t + UsableAtModality _ ms mod t -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> prettyTCM t + -- TODO: print @ms : Maybe Sort@ as well? where prettyCmp 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 @@ -9,7 +9,7 @@ import Control.Monad.Fail ( MonadFail ) import Data.Char ( toLower ) -import Data.Function +import Data.Function (on) import Data.Maybe import qualified Data.Set as Set @@ -82,7 +82,7 @@ concatMap termErrFunctions because) $$ fwords "Problematic calls:" $$ nest 2 (fmap (P.vcat . List.nub) $ - mapM prettyTCM $ List.sortBy (compare `on` callInfoRange) $ + mapM prettyTCM $ List.sortOn getRange $ concatMap termErrCalls because) UnreachableClauses f pss -> fsep $ @@ -108,6 +108,15 @@ [prettyTCM d] ++ pwords "is not strictly positive, because it occurs" ++ [prettyTCM ocs] + UnsupportedIndexedMatch doc -> vcat + [ fsep (pwords "This clause uses pattern-matching features that are not yet supported by Cubical Agda," + ++ pwords "the function to which it belongs will not compute when applied to transports." + ) + , "" + , "Reason:" <+> pure doc + , "" + ] + CantGeneralizeOverSorts ms -> vcat [ text "Cannot generalize over unsolved sort metas:" , nest 2 $ vcat [ prettyTCM x <+> text "at" <+> (pretty =<< getMetaRange x) | x <- ms ] @@ -137,6 +146,7 @@ UselessPatternDeclarationForRecord s -> fwords $ unwords [ "`pattern' attribute ignored for", s, "record" ] + -- the @s@ is a qualifier like "eta" or "coinductive" UselessPublic -> fwords $ "Keyword `public' is ignored here" @@ -149,14 +159,17 @@ pwords "It is pointless for INLINE'd function" ++ [prettyTCM q] ++ pwords "to have a separate Haskell definition" - WrongInstanceDeclaration -> fwords "Terms marked as eligible for instance search should end with a name, so `instance' is ignored here." + WrongInstanceDeclaration -> fwords $ + "Instances should be of type {Γ} → C, where C evaluates to a postulated name or the name of " ++ + "a data or record type, so `instance' is ignored here." InstanceWithExplicitArg q -> fsep $ pwords "Instance declarations with explicit arguments are never considered by instance search," ++ pwords "so making" ++ [prettyTCM q] ++ pwords "into an instance has no effect." InstanceNoOutputTypeName b -> fsep $ - pwords "Instance arguments whose type does not end in a named or variable type are never considered by instance search," ++ + pwords "Instance arguments whose type is not {Γ} → C, where C evaluates to a postulated type, " ++ + pwords "a parameter type or the name of a data or record type, are never considered by instance search," ++ pwords "so having an instance argument" ++ [return b] ++ pwords "has no effect." InstanceArgWithExplicitArg b -> fsep $ @@ -220,6 +233,8 @@ SafeFlagNoCoverageCheck -> fsep $ pwords "Cannot use NON_COVERING pragma with safe flag." + OptionWarning ow -> pretty ow + ParseWarning pw -> pretty pw DeprecationWarning old new version -> fsep $ @@ -248,13 +263,9 @@ LibraryWarning lw -> pretty lw - InfectiveImport o m -> fsep $ - pwords "Importing module" ++ [pretty m] ++ pwords "using the" ++ - [pretty o] ++ pwords "flag from a module which does not." + InfectiveImport msg -> return msg - CoInfectiveImport o m -> fsep $ - pwords "Importing module" ++ [pretty m] ++ pwords "not using the" ++ - [pretty o] ++ pwords "flag from a module which does." + CoInfectiveImport msg -> return msg RewriteNonConfluent lhs rhs1 rhs2 err -> fsep [ "Local confluence check failed:" diff --git a/src/full/Agda/TypeChecking/Primitive.hs b/src/full/Agda/TypeChecking/Primitive.hs --- a/src/full/Agda/TypeChecking/Primitive.hs +++ b/src/full/Agda/TypeChecking/Primitive.hs @@ -33,14 +33,16 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Level -import Agda.TypeChecking.Quote (quoteTermWithKit, quoteTypeWithKit, quotingKit) +import Agda.TypeChecking.Quote (quoteTermWithKit, quoteTypeWithKit, quoteDomWithKit, quotingKit) import Agda.TypeChecking.Primitive.Base import Agda.TypeChecking.Primitive.Cubical +import Agda.TypeChecking.Primitive.Cubical.Base import Agda.TypeChecking.Warnings import Agda.Utils.Char import Agda.Utils.Float import Agda.Utils.List +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Pretty import Agda.Utils.Singleton @@ -167,8 +169,8 @@ instance ToTerm QName where toTerm = return $ Lit . LitQName instance ToTerm MetaId where toTerm = do - file <- getCurrentPath - return $ Lit . LitMeta file + top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule + return $ Lit . LitMeta top instance ToTerm Integer where toTerm = do @@ -190,6 +192,10 @@ toTerm = do kit <- quotingKit; runReduceF (quoteTermWithKit kit) toTermR = do quoteTermWithKit <$> quotingKit; +instance ToTerm (Dom Type) where + toTerm = do kit <- quotingKit; runReduceF (quoteDomWithKit kit) + toTermR = do quoteDomWithKit <$> quotingKit + instance ToTerm Type where toTerm = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit) toTermR = quoteTypeWithKit <$> quotingKit @@ -452,6 +458,13 @@ Con{} -> redReturn $ refl t _ -> return $ NoReduction $ map notReduced ts +-- | Converts 'MetaId's to natural numbers. + +metaToNat :: MetaId -> Nat +metaToNat m = + fromIntegral (moduleNameHash $ metaModule m) * 2^64 + + fromIntegral (metaId m) + primMetaToNatInjective :: TCM PrimitiveImpl primMetaToNatInjective = do meta <- primType (undefined :: MetaId) @@ -490,9 +503,9 @@ primFloatToWord64Injective :: TCM PrimitiveImpl primFloatToWord64Injective = do float <- primType (undefined :: Double) - word <- primType (undefined :: Word64) + mword <- primType (undefined :: Maybe Word64) toWord <- primFunName <$> getPrimitive "primFloatToWord64" - mkPrimInjective float word toWord + mkPrimInjective float mword toWord primQNameToWord64sInjective :: TCM PrimitiveImpl primQNameToWord64sInjective = do @@ -937,7 +950,7 @@ , "primMetaEquality" |-> mkPrimFun2 ((==) :: Rel MetaId) , "primMetaLess" |-> mkPrimFun2 ((<) :: Rel MetaId) , "primShowMeta" |-> mkPrimFun1 (T.pack . prettyShow :: MetaId -> Text) - , "primMetaToNat" |-> mkPrimFun1 (fromIntegral . metaId :: MetaId -> Nat) + , "primMetaToNat" |-> mkPrimFun1 metaToNat , "primMetaToNatInjective" |-> primMetaToNatInjective , "primIMin" |-> primIMin' , "primIMax" |-> primIMax' @@ -946,7 +959,6 @@ , "primComp" |-> primComp , builtinTrans |-> primTrans' , builtinHComp |-> primHComp' - , "primIdJ" |-> primIdJ , "primPartial" |-> primPartial' , "primPartialP" |-> primPartialP' , builtinGlue |-> primGlue' @@ -958,6 +970,7 @@ , "primIdPath" |-> primIdPath' , builtinIdElim |-> primIdElim' , builtinSubOut |-> primSubOut' + , builtinConId |-> primConId' , builtin_glueU |-> prim_glueU' , builtin_unglueU |-> prim_unglueU' , builtinLockUniv |-> primLockUniv' diff --git a/src/full/Agda/TypeChecking/Primitive/Base.hs b/src/full/Agda/TypeChecking/Primitive/Base.hs --- a/src/full/Agda/TypeChecking/Primitive/Base.hs +++ b/src/full/Agda/TypeChecking/Primitive/Base.hs @@ -2,8 +2,10 @@ module Agda.TypeChecking.Primitive.Base where --- Control.Monad.Fail import is redundant since GHC 8.8.1 -import Control.Monad.Fail (MonadFail) +import Control.Monad ( mzero ) +import Control.Monad.Fail ( MonadFail ) + -- Control.Monad.Fail import is redundant since GHC 8.8.1 +import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT ) import qualified Data.Map as Map @@ -62,19 +64,24 @@ hPi', nPi' :: (MonadFail m, MonadAddContext m, MonadDebug m) => String -> NamesT m Type -> (NamesT m Term -> NamesT m Type) -> NamesT m Type -hPi' s a b = hPi s a (bind' s b) -nPi' s a b = nPi s a (bind' s b) +hPi' s a b = hPi s a (bind' s (\ x -> b x)) +nPi' s a b = nPi s a (bind' s (\ x -> b x)) pPi' :: (MonadAddContext m, HasBuiltins m, MonadDebug m) => String -> NamesT m Term -> (NamesT m Term -> NamesT m Type) -> NamesT m Type pPi' n phi b = toFinitePi <$> nPi' n (elSSet $ cl isOne <@> phi) b where - toFinitePi :: Type -> Type - toFinitePi (El s (Pi d b)) = El s $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b - toFinitePi _ = __IMPOSSIBLE__ - isOne = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIsOne +-- | Turn a 'Pi' type into one whose domain is annotated finite, i.e., +-- one that represents a @Partial@ element rather than an actual +-- function. +toFinitePi :: Type -> Type +toFinitePi (El s (Pi d b)) = El s $ Pi + (setRelevance Irrelevant $ d { domIsFinite = True }) + b +toFinitePi _ = __IMPOSSIBLE__ + el' :: Applicative m => m Term -> m Term -> m Type el' l a = El <$> (tmSort <$> l) <*> a @@ -132,22 +139,16 @@ el :: Functor m => m Term -> m Type el t = El (mkType 0) <$> t +-- | The universe @Set0@ as a type. tset :: Applicative m => m Type tset = pure $ sort (mkType 0) +-- | @SizeUniv@ as a sort. sSizeUniv :: Sort --- sSizeUniv = mkType 0 --- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428 sSizeUniv = SizeUniv +-- | @SizeUniv@ as a type. tSizeUniv :: Applicative m => m Type --- tSizeUniv = tset --- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428 --- tSizeUniv = return $ El sSizeUniv $ Sort sSizeUniv --- Andreas, 2015-03-16 Since equality checking for types --- includes equality checking for sorts, we cannot put --- SizeUniv in Setω. (SizeUniv : Setω) == (_0 : suc _0) --- will first instantiate _0 := Setω, which is wrong. tSizeUniv = pure $ sort sSizeUniv -- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@. @@ -182,16 +183,18 @@ return (s, PrimImpl t $ pf { primFunName = q }) getBuiltinName :: (HasBuiltins m, MonadReduce m) => String -> m (Maybe QName) -getBuiltinName b = do - caseMaybeM (getBuiltin' b) (return Nothing) (Just <.> getName) - where - getName v = do +getBuiltinName b = runMaybeT $ getQNameFromTerm =<< MaybeT (getBuiltin' b) + +-- | Convert a name in 'Term' form back to 'QName'. +-- +getQNameFromTerm :: MonadReduce m => Term -> MaybeT m QName +getQNameFromTerm v = do v <- reduce v - case unSpine $ v of + case unSpine v of Def x _ -> return x Con x _ _ -> return $ conName x - Lam _ b -> getName $ unAbs b - _ -> __IMPOSSIBLE__ + Lam _ b -> getQNameFromTerm $ unAbs b + _ -> mzero isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> String -> m Bool isBuiltin q b = (Just q ==) <$> getBuiltinName b 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 @@ -1,1821 +1,1281 @@ {-# LANGUAGE NondecreasingIndentation #-} - -module Agda.TypeChecking.Primitive.Cubical where - -import Prelude hiding (null, (!!)) - -import Control.Monad -import Control.Monad.Except -import Control.Monad.Trans ( lift ) - -import Data.Either ( partitionEithers ) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Foldable hiding (null) - -import Agda.Interaction.Options ( optCubical ) - -import Agda.Syntax.Common -import Agda.Syntax.Internal - -import Agda.TypeChecking.Names -import Agda.TypeChecking.Primitive.Base -import Agda.TypeChecking.Monad - -import Agda.TypeChecking.Free -import Agda.TypeChecking.Substitute -import Agda.TypeChecking.Reduce -import Agda.TypeChecking.Telescope - -import Agda.Utils.Functor -import Agda.Utils.Impossible -import Agda.Utils.Maybe -import Agda.Utils.Monad -import Agda.Utils.Null -import Agda.Utils.Tuple - --- | Checks that the correct variant of Cubical Agda is activated. --- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased --- contexts. - -requireCubical - :: Cubical -- ^ Which variant of Cubical Agda is required? - -> String -> TCM () -requireCubical wanted s = do - cubical <- optCubical <$> pragmaOptions - inErasedContext <- hasQuantity0 <$> getEnv - case cubical of - Just CFull -> return () - Just CErased | wanted == CErased || inErasedContext -> return () - _ -> typeError $ GenericError $ "Missing option " ++ opt ++ s - where - opt = case wanted of - CFull -> "--cubical" - CErased -> "--cubical or --erased-cubical" - -primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type -primIntervalType = El (SSet $ ClosedLevel 0) <$> primInterval - -primINeg' :: TCM PrimitiveImpl -primINeg' = do - requireCubical CErased "" - t <- primIntervalType --> primIntervalType - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ts -> do - case ts of - [x] -> do - unview <- intervalUnview' - view <- intervalView' - sx <- reduceB' x - ix <- intervalView (unArg $ ignoreBlocking sx) - let - ineg :: Arg Term -> Arg Term - ineg = fmap (unview . f . view) - f ix = case ix of - IZero -> IOne - IOne -> IZero - IMin x y -> IMax (ineg x) (ineg y) - IMax x y -> IMin (ineg x) (ineg y) - INeg x -> OTerm (unArg x) - OTerm t -> INeg (Arg defaultArgInfo t) - case ix of - OTerm t -> return $ NoReduction [reduced sx] - _ -> redReturn (unview $ f ix) - _ -> __IMPOSSIBLE__ - -primDepIMin' :: TCM PrimitiveImpl -primDepIMin' = do - requireCubical CErased "" - t <- runNamesT [] $ - nPi' "φ" primIntervalType $ \ φ -> - pPi' "o" φ (\ o -> primIntervalType) --> primIntervalType - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do - case ts of - [x,y] -> do - sx <- reduceB' x - ix <- intervalView (unArg $ ignoreBlocking sx) - itisone <- getTerm "primDepIMin" builtinItIsOne - case ix of - IZero -> redReturn =<< intervalUnview IZero - IOne -> redReturn =<< (pure (unArg y) <@> pure itisone) - _ -> do - sy <- reduceB' y - iy <- intervalView =<< reduce' =<< (pure (unArg $ ignoreBlocking sy) <@> pure itisone) - case iy of - IZero -> redReturn =<< intervalUnview IZero - IOne -> redReturn (unArg $ ignoreBlocking sx) - _ -> return $ NoReduction [reduced sx, reduced sy] - _ -> __IMPOSSIBLE__ - -primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl -primIBin unit absorber = do - requireCubical CErased "" - t <- primIntervalType --> primIntervalType --> primIntervalType - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do - case ts of - [x,y] -> do - sx <- reduceB' x - ix <- intervalView (unArg $ ignoreBlocking sx) - case ix of - ix | ix ==% absorber -> redReturn =<< intervalUnview absorber - ix | ix ==% unit -> return $ YesReduction YesSimplification (unArg y) - _ -> do - sy <- reduceB' y - iy <- intervalView (unArg $ ignoreBlocking sy) - case iy of - iy | iy ==% absorber -> redReturn =<< intervalUnview absorber - iy | iy ==% unit -> return $ YesReduction YesSimplification (unArg x) - _ -> return $ NoReduction [reduced sx,reduced sy] - _ -> __IMPOSSIBLE__ - where - (==%) IZero IZero = True - (==%) IOne IOne = True - (==%) _ _ = False - - -primIMin' :: TCM PrimitiveImpl -primIMin' = do - requireCubical CErased "" - primIBin IOne IZero - -primIMax' :: TCM PrimitiveImpl -primIMax' = do - requireCubical CErased "" - primIBin IZero IOne - -imax :: HasBuiltins m => m Term -> m Term -> m Term -imax x y = do - x' <- x - y' <- y - intervalUnview (IMax (argN x') (argN y')) - -imin :: HasBuiltins m => m Term -> m Term -> m Term -imin x y = do - x' <- x - y' <- y - intervalUnview (IMin (argN x') (argN y')) - --- ∀ {a}{c}{A : Set a}{x : A}(C : ∀ y → Id x y → Set c) → C x (conid i1 (\ i → x)) → ∀ {y} (p : Id x y) → C y p -primIdJ :: TCM PrimitiveImpl -primIdJ = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - hPi' "c" (el $ cl primLevel) $ \ c -> - hPi' "A" (sort . tmSort <$> a) $ \ bA -> - hPi' "x" (el' a bA) $ \ x -> - nPi' "C" (nPi' "y" (el' a bA) $ \ y -> - el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC -> - el' c (bC <@> x <@> - (cl primConId <#> a <#> bA <#> x <#> x <@> cl primIOne - <@> lam "i" (\ _ -> x))) --> - hPi' "y" (el' a bA) (\ y -> - nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p -> - el' c $ bC <@> y <@> p) - conidn <- getBuiltinName builtinConId - conid <- primConId - -- TODO make a kit - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do - unview <- intervalUnview' - let imax x y = do x' <- x; unview . IMax (argN x') . argN <$> y; - imin x y = do x' <- x; unview . IMin (argN x') . argN <$> y; - ineg x = unview . INeg . argN <$> x - mcomp <- getTerm' "primComp" - case ts of - [la,lc,a,x,c,d,y,eq] -> do - seq <- reduceB' eq - case unArg $ ignoreBlocking $ seq of - (Def q [Apply la,Apply a,Apply x,Apply y,Apply phi,Apply p]) - | Just q == conidn, Just comp <- mcomp -> do - redReturn $ runNames [] $ do - [lc,c,d,la,a,x,y,phi,p] <- mapM (open . unArg) [lc,c,d,la,a,x,y,phi,p] - let w i = do - [x,y,p,i] <- sequence [x,y,p,i] - pure $ p `applyE` [IApply x y i] - pure comp <#> lam "i" (\ _ -> lc) - <@> lam "i" (\ i -> - c <@> (w i) - <@> (pure conid <#> la <#> a <#> x <#> (w i) - <@> (phi `imax` ineg i) - <@> lam "j" (\ j -> w $ imin i j))) - <#> phi - <@> lam "i" (\ _ -> nolam <$> d) -- TODO block - <@> d - _ -> return $ NoReduction $ map notReduced [la,lc,a,x,c,d,y] ++ [reduced seq] - _ -> __IMPOSSIBLE__ - -primIdElim' :: TCM PrimitiveImpl -primIdElim' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - hPi' "c" (el $ cl primLevel) $ \ c -> - hPi' "A" (sort . tmSort <$> a) $ \ bA -> - hPi' "x" (el' a bA) $ \ x -> - nPi' "C" (nPi' "y" (el' a bA) $ \ y -> - el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC -> - nPi' "φ" primIntervalType (\ phi -> - nPi' "y" (el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (const x)) $ \ y -> - let pathxy = (cl primPath <#> a <@> bA <@> x <@> oucy) - oucy = (cl primSubOut <#> a <#> bA <#> phi <#> lam "o" (const x) <@> y) - reflx = (lam "o" $ \ _ -> lam "i" $ \ _ -> x) -- TODO Andrea, should block on o - in - nPi' "w" (el's a $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w -> - let oucw = (cl primSubOut <#> a <#> pathxy <#> phi <#> reflx <@> w) in - el' c $ bC <@> oucy <@> (cl primConId <#> a <#> bA <#> x <#> oucy <@> phi <@> oucw)) - --> - hPi' "y" (el' a bA) (\ y -> - nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p -> - el' c $ bC <@> y <@> p) - conid <- primConId - sin <- primSubIn - path <- primPath - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do - case ts of - [a,c,bA,x,bC,f,y,p] -> do - sp <- reduceB' p - case unArg $ ignoreBlocking sp of - Def q [Apply _a, Apply _bA, Apply _x, Apply _y, Apply phi , Apply w] -> do - let y' = sin `apply` [a,bA ,phi,argN $ unArg y] - let w' = sin `apply` [a,argN $ path `apply` [a,bA,x,y],phi,argN $ unArg w] - redReturn $ unArg f `apply` [phi, defaultArg y', defaultArg w'] - _ -> return $ NoReduction $ map notReduced [a,c,bA,x,bC,f,y] ++ [reduced sp] - _ -> __IMPOSSIBLE__ - - -primPOr :: TCM PrimitiveImpl -primPOr = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - nPi' "i" primIntervalType $ \ i -> - nPi' "j" primIntervalType $ \ j -> - hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> - ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) --> - ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) --> - pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o) - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do - case ts of - [l,i,j,a,u,v] -> do - si <- reduceB' i - vi <- intervalView $ unArg $ ignoreBlocking si - case vi of - IOne -> redReturn (unArg u) - IZero -> redReturn (unArg v) - _ -> do - sj <- reduceB' j - vj <- intervalView $ unArg $ ignoreBlocking sj - case vj of - IOne -> redReturn (unArg v) - IZero -> redReturn (unArg u) - _ -> return $ NoReduction [notReduced l,reduced si,reduced sj,notReduced a,notReduced u,notReduced v] - - - _ -> __IMPOSSIBLE__ - -primPartial' :: TCM PrimitiveImpl -primPartial' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) (\ a -> - nPi' "φ" primIntervalType $ \ _ -> - nPi' "A" (sort . tmSort <$> a) $ \ bA -> - (sort . tmSSort <$> a)) - isOne <- primIsOne - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ ts -> do - case ts of - [l,phi,a] -> do - (El s (Pi d b)) <- runNamesT [] $ do - [l,a,phi] <- mapM (open . unArg) [l,a,phi] - elSSet (pure isOne <@> phi) --> el' l a - redReturn $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b - _ -> __IMPOSSIBLE__ - -primPartialP' :: TCM PrimitiveImpl -primPartialP' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) (\ a -> - nPi' "φ" primIntervalType $ \ phi -> - nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> - (sort . tmSSort <$> a)) - let toFinitePi :: Type -> Term - toFinitePi (El _ (Pi d b)) = Pi (setRelevance Irrelevant $ d { domFinite = True }) b - toFinitePi _ = __IMPOSSIBLE__ - v <- runNamesT [] $ - lam "a" $ \ l -> - lam "φ" $ \ phi -> - lam "A" $ \ a -> - toFinitePi <$> nPi' "p" (elSSet $ cl primIsOne <@> phi) (\ p -> el' l (a <@> p)) - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v - -primSubOut' :: TCM PrimitiveImpl -primSubOut' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> - hPi' "φ" primIntervalType $ \ phi -> - hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u -> - el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do - case ts of - [a,bA,phi,u,x] -> do - view <- intervalView' - sphi <- reduceB' phi - case view $ unArg $ ignoreBlocking sphi of - IOne -> redReturn =<< (return (unArg u) <..> (getTerm builtinSubOut builtinItIsOne)) - _ -> do - sx <- reduceB' x - mSubIn <- getBuiltinName' builtinSubIn - case unArg $ ignoreBlocking $ sx of - Def q [_,_,_, Apply t] | Just q == mSubIn -> redReturn (unArg t) - _ -> return $ NoReduction $ map notReduced [a,bA] ++ [reduced sphi, notReduced u, reduced sx] - _ -> __IMPOSSIBLE__ - -primIdFace' :: TCM PrimitiveImpl -primIdFace' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - hPi' "A" (sort . tmSort <$> a) $ \ bA -> - hPi' "x" (el' a bA) $ \ x -> - hPi' "y" (el' a bA) $ \ y -> - el' a (cl primId <#> a <#> bA <@> x <@> y) - --> primIntervalType - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do - case ts of - [l,bA,x,y,t] -> do - st <- reduceB' t - mConId <- getName' builtinConId - case unArg (ignoreBlocking st) of - Def q [_,_,_,_, Apply phi,_] | Just q == mConId -> redReturn (unArg phi) - _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st] - _ -> __IMPOSSIBLE__ - -primIdPath' :: TCM PrimitiveImpl -primIdPath' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - hPi' "A" (sort . tmSort <$> a) $ \ bA -> - hPi' "x" (el' a bA) $ \ x -> - hPi' "y" (el' a bA) $ \ y -> - el' a (cl primId <#> a <#> bA <@> x <@> y) - --> el' a (cl primPath <#> a <#> bA <@> x <@> y) - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do - case ts of - [l,bA,x,y,t] -> do - st <- reduceB' t - mConId <- getName' builtinConId - case unArg (ignoreBlocking st) of - Def q [_,_,_,_,_,Apply w] | Just q == mConId -> redReturn (unArg w) - _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st] - _ -> __IMPOSSIBLE__ - - -primTrans' :: TCM PrimitiveImpl -primTrans' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a -> - nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA -> - nPi' "φ" primIntervalType $ \ phi -> - (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne)) - return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ ts nelims -> do - primTransHComp DoTransp ts nelims - -primHComp' :: TCM PrimitiveImpl -primHComp' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (el $ cl primLevel) $ \ a -> - hPi' "A" (sort . tmSort <$> a) $ \ bA -> - hPi' "φ" primIntervalType $ \ phi -> - nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) --> - (el' a bA --> el' a bA) - return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do - primTransHComp DoHComp ts nelims - -data TranspOrHComp = DoTransp | DoHComp deriving (Eq,Show) - -cmdToName :: TranspOrHComp -> String -cmdToName DoTransp = builtinTrans -cmdToName DoHComp = builtinHComp - -data FamilyOrNot a - = IsFam { famThing :: a } - | IsNot { famThing :: a } - deriving (Eq,Show,Functor,Foldable,Traversable) - -instance Reduce a => Reduce (FamilyOrNot a) where - reduceB' x = traverse id <$> traverse reduceB' x - reduce' x = traverse reduce' x - - --- | Define a "ghcomp" version of gcomp. Normal comp looks like: --- --- comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0) --- --- So for "gcomp" we compute: --- --- gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0) --- --- The point of this is that gcomp does not produce any empty --- systems (if phi = 0 it will reduce to "forward A 0 u". -mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term) -mkGComp s = do - let getTermLocal = getTerm s - tPOr <- getTermLocal "primPOr" - tIMax <- getTermLocal builtinIMax - tIMin <- getTermLocal builtinIMin - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - io <- getTermLocal builtinIOne - iz <- getTermLocal builtinIZero - let ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r)) - <@> lam "i" (\ i -> bA <@> (i `imax` r)) - <@> r - <@> u - return $ \ la bA phi u u0 -> - pure tHComp <#> (la <@> pure io) - <#> (bA <@> pure io) - <#> imax phi (ineg phi) - <@> lam "i" (\ i -> - pure tPOr <#> (la <@> i) - <@> phi - <@> ineg phi - <@> ilam "o" (\ a -> bA <@> i) - <@> ilam "o" (\ o -> forward la bA i (u <@> i <..> o)) - <@> ilam "o" (\ o -> forward la bA (pure iz) u0)) - <@> forward la bA (pure iz) u0 - - -unglueTranspGlue :: PureTCM m => - Arg Term - -> Arg Term - -> FamilyOrNot - (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) - -> m Term --- ... |- psi, u0 --- ..., i |- la, lb, bA, phi, bT, e -unglueTranspGlue psi u0 (IsFam (la, lb, bA, phi, bT, e)) = do - let - localUse = builtinTrans ++ " for " ++ builtinGlue - getTermLocal = getTerm localUse - tPOr <- getTermLocal "primPOr" - tIMax <- getTermLocal builtinIMax - tIMin <- getTermLocal builtinIMin - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - tForall <- getTermLocal builtinFaceForall - tEFun <- getTermLocal builtinEquivFun - tEProof <- getTermLocal builtinEquivProof - tglue <- getTermLocal builtin_glue - tunglue <- getTermLocal builtin_unglue - io <- getTermLocal builtinIOne - iz <- getTermLocal builtinIZero - tLMax <- getTermLocal builtinLevelMax - tPath <- getTermLocal builtinPath - tTransp <- getTermLocal builtinTranspProof - tItIsOne <- getTermLocal builtinItIsOne - kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit - runNamesT [] $ do - let ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - imin i j = pure tIMin <@> i <@> j - - gcomp <- mkGComp localUse - - let transpFill la bA phi u0 i = - pure tTrans <#> ilam "j" (\ j -> la <@> imin i j) - <@> ilam "j" (\ j -> bA <@> imin i j) - <@> (imax phi (ineg i)) - <@> u0 - [psi,u0] <- mapM (open . unArg) [psi,u0] - - -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a - glue1 <- do - g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e] - return $ \ t a -> g <@> t <@> a - - [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e] - - -- Andreas, 2022-03-24, fixing #5838 - -- Following the updated note - -- - -- Simon Huber, A Cubical Type Theory for Higher Inductive Types - -- https://simhu.github.io/misc/hcomp.pdf (February 2022) - -- - -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776 - - -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/i] u0 - let unglue_u0 i = - foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0 - - view <- intervalView' - - let - tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i - t1 o = tf (pure io) o - - -- compute "forall. phi" - forallphi = pure tForall <@> phi - - -- a1 with gcomp - a1 = gcomp la bA - (imax psi forallphi) - (lam "i" $ \ i -> pure tPOr <#> (la <@> i) - <@> psi - <@> forallphi - <@> ilam "o" (\ a -> bA <@> i) - <@> ilam "o" (\ _ -> unglue_u0 i) - <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i) - <#> (la <@> i) - <#> (bT <@> i <..> o) - <#> (bA <@> i) - <@> (e <@> i <..> o) - <@> (tf i o))) - (unglue_u0 (pure iz)) - - max l l' = pure tLMax <@> l <@> l' - sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y - w i o = pure tEFun <#> (lb <@> i) - <#> (la <@> i) - <#> (bT <@> i <..> o) - <#> (bA <@> i) - <@> (e <@> i <..> o) - fiber la lb bA bB f b = - (pure (Def (sigmaName kit) []) <#> la - <#> lb - <@> bA - <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b)) - - -- We don't have to do anything special for "~ forall. phi" - -- here (to implement "ghcomp") as it is taken care off by - -- tEProof in t1'alpha below - pe o = -- o : [ φ 1 ] - pure tPOr <#> max (la <@> pure io) (lb <@> pure io) - <@> psi - <@> forallphi - <@> ilam "o" (\ _ -> - fiber (lb <@> pure io) (la <@> pure io) - (bT <@> (pure io) <..> o) (bA <@> pure io) - (w (pure io) o) a1) - <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1)) - <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1)) - - -- "ghcomp" is implemented in the proof of tEProof - -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda) - t1'alpha o = -- o : [ φ 1 ] - pure tEProof <#> (lb <@> pure io) - <#> (la <@> pure io) - <@> (bT <@> pure io <..> o) - <@> (bA <@> pure io) - <@> (e <@> pure io <..> o) - <@> a1 - <@> (imax psi forallphi) - <@> pe o - - -- TODO: optimize? - t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)]) - alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)]) - a1' = pure tHComp - <#> (la <@> pure io) - <#> (bA <@> pure io) - <#> (imax (phi <@> pure io) psi) - <@> lam "j" (\ j -> - pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io) - <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j)) - <@> ilam "o" (\ _ -> a1)) - <@> a1 - -- glue1 (ilam "o" t1') a1' - a1' -unglueTranspGlue _ _ _ = __IMPOSSIBLE__ - -data TermPosition = Head | Eliminated deriving (Eq,Show) - -headStop :: PureTCM m => TermPosition -> m Term -> m Bool -headStop tpos phi - | Head <- tpos = do - phi <- intervalView =<< (reduce =<< phi) - return $ not $ isIOne phi - | otherwise = return False - -compGlue :: PureTCM m => - TranspOrHComp - -> Arg Term - -> Maybe (Arg Term) - -> Arg Term - -> FamilyOrNot - (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) - -> TermPosition - -> m (Maybe Term) -compGlue DoHComp psi (Just u) u0 (IsNot (la, lb, bA, phi, bT, e)) tpos = do - let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinGlue) - tPOr <- getTermLocal "primPOr" - tIMax <- getTermLocal builtinIMax - tIMin <- getTermLocal builtinIMin - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tEFun <- getTermLocal builtinEquivFun - tglue <- getTermLocal builtin_glue - tunglue <- getTermLocal builtin_unglue - io <- getTermLocal builtinIOne - tItIsOne <- getTermLocal builtinItIsOne - view <- intervalView' - runNamesT [] $ do - [psi, u, u0] <- mapM (open . unArg) [psi, u, u0] - [la, lb, bA, phi, bT, e] <- mapM (open . unArg) [la, lb, bA, phi, bT, e] - ifM (headStop tpos phi) (return Nothing) $ Just <$> do - - let - hfill la bA phi u u0 i = pure tHComp <#> la - <#> bA - <#> (pure tIMax <@> phi <@> (pure tINeg <@> i)) - <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA) - <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o) - <@> ilam "o" (\ _ -> u0)) - <@> u0 - tf i o = hfill lb (bT <..> o) psi u u0 i - unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g - a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi) - <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA) - <@> ilam "o" (\ o -> unglue (u <@> i <..> o)) - <@> ilam "o" (\ o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o)) - <@> (unglue u0) - t1 = tf (pure io) - -- pure tglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> (ilam "o" $ \ o -> t1 o) <@> a1 - case tpos of - Head -> t1 (pure tItIsOne) - Eliminated -> a1 - --- ... |- psi, u0 --- ..., i |- la, lb, bA, phi, bT, e -compGlue DoTransp psi Nothing u0 (IsFam (la, lb, bA, phi, bT, e)) tpos = do - let - localUse = builtinTrans ++ " for " ++ builtinGlue - getTermLocal = getTerm localUse - tPOr <- getTermLocal "primPOr" - tIMax <- getTermLocal builtinIMax - tIMin <- getTermLocal builtinIMin - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - tForall <- getTermLocal builtinFaceForall - tEFun <- getTermLocal builtinEquivFun - tEProof <- getTermLocal builtinEquivProof - tglue <- getTermLocal builtin_glue - tunglue <- getTermLocal builtin_unglue - io <- getTermLocal builtinIOne - iz <- getTermLocal builtinIZero - tLMax <- getTermLocal builtinLevelMax - tPath <- getTermLocal builtinPath - tTransp <- getTermLocal builtinTranspProof - tItIsOne <- getTermLocal builtinItIsOne - kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit - runNamesT [] $ do - let ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - imin i j = pure tIMin <@> i <@> j - - gcomp <- mkGComp localUse - - let transpFill la bA phi u0 i = - pure tTrans <#> ilam "j" (\ j -> la <@> imin i j) - <@> ilam "j" (\ j -> bA <@> imin i j) - <@> (imax phi (ineg i)) - <@> u0 - [psi,u0] <- mapM (open . unArg) [psi,u0] - - -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a - glue1 <- do - g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e] - return $ \ t a -> g <@> t <@> a - - [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e] - - -- Andreas, 2022-03-24, fixing #5838 - -- Following the updated note - -- - -- Simon Huber, A Cubical Type Theory for Higher Inductive Types - -- https://simhu.github.io/misc/hcomp.pdf (February 2022) - -- - -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776 - - -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0 - let unglue_u0 i = - foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0 - - view <- intervalView' - - ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do - let - tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i - t1 o = tf (pure io) o - - -- compute "forall. phi" - forallphi = pure tForall <@> phi - - -- a1 with gcomp - a1 = gcomp la bA - (imax psi forallphi) - (lam "i" $ \ i -> pure tPOr <#> (la <@> i) - <@> psi - <@> forallphi - <@> ilam "o" (\ _ -> bA <@> i) - <@> ilam "o" (\ _ -> unglue_u0 i) - <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i) - <#> (la <@> i) - <#> (bT <@> i <..> o) - <#> (bA <@> i) - <@> (e <@> i <..> o) - <@> (tf i o))) - (unglue_u0 (pure iz)) - - max l l' = pure tLMax <@> l <@> l' - sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y - w i o = pure tEFun <#> (lb <@> i) - <#> (la <@> i) - <#> (bT <@> i <..> o) - <#> (bA <@> i) - <@> (e <@> i <..> o) - fiber la lb bA bB f b = - (pure (Def (sigmaName kit) []) <#> la - <#> lb - <@> bA - <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b)) - - -- We don't have to do anything special for "~ forall. phi" - -- here (to implement "ghcomp") as it is taken care off by - -- tEProof in t1'alpha below - pe o = -- o : [ φ 1 ] - pure tPOr <#> max (la <@> pure io) (lb <@> pure io) - <@> psi - <@> forallphi - <@> ilam "o" (\ _ -> - fiber (lb <@> pure io) (la <@> pure io) - (bT <@> (pure io) <..> o) (bA <@> pure io) - (w (pure io) o) a1) - <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1)) - <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1)) - - -- "ghcomp" is implemented in the proof of tEProof - -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda) - t1'alpha o = -- o : [ φ 1 ] - pure tEProof <#> (lb <@> pure io) - <#> (la <@> pure io) - <@> (bT <@> pure io <..> o) - <@> (bA <@> pure io) - <@> (e <@> pure io <..> o) - <@> a1 - <@> (imax psi forallphi) - <@> pe o - - -- TODO: optimize? - t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)]) - alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)]) - a1' = pure tHComp - <#> (la <@> pure io) - <#> (bA <@> pure io) - <#> (imax (phi <@> pure io) psi) - <@> lam "j" (\ j -> - pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io) - <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j)) - <@> ilam "o" (\ _ -> a1)) - <@> a1 - - -- glue1 (ilam "o" t1') a1' - case tpos of - Head -> t1' (pure tItIsOne) - Eliminated -> a1' -compGlue cmd phi u u0 _ _ = __IMPOSSIBLE__ - -compHCompU :: PureTCM m => - TranspOrHComp - -> Arg Term - -> Maybe (Arg Term) - -> Arg Term - -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term) - -> TermPosition - -> m (Maybe Term) - -compHCompU DoHComp psi (Just u) u0 (IsNot (la, phi, bT, bA)) tpos = do - let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinHComp ++ " of Set") - io <- getTermLocal builtinIOne - iz <- getTermLocal builtinIZero - tPOr <- getTermLocal "primPOr" - tIMax <- getTermLocal builtinIMax - tIMin <- getTermLocal builtinIMin - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tTransp <- getTermLocal builtinTrans - tglue <- getTermLocal builtin_glueU - tunglue <- getTermLocal builtin_unglueU - tLSuc <- getTermLocal builtinLevelSuc - tSubIn <- getTermLocal builtinSubIn - tItIsOne <- getTermLocal builtinItIsOne - runNamesT [] $ do - [psi, u, u0] <- mapM (open . unArg) [psi, u, u0] - [la, phi, bT, bA] <- mapM (open . unArg) [la, phi, bT, bA] - - ifM (headStop tpos phi) (return Nothing) $ Just <$> do - - let - hfill la bA phi u u0 i = pure tHComp <#> la - <#> bA - <#> (pure tIMax <@> phi <@> (pure tINeg <@> i)) - <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA) - <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o) - <@> ilam "o" (\ _ -> u0)) - <@> u0 - transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0 - tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i - bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA - unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g - a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi) - <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA) - <@> ilam "o" (\ o -> unglue (u <@> i <..> o)) - <@> ilam "o" (\ o -> transp la (\ i -> bT <@> (pure tINeg <@> i) <..> o) (tf i o))) - <@> unglue u0 - t1 = tf (pure io) - - -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1 - case tpos of - Eliminated -> a1 - Head -> t1 (pure tItIsOne) - - - -compHCompU DoTransp psi Nothing u0 (IsFam (la, phi, bT, bA)) tpos = do - let - localUse = builtinTrans ++ " for " ++ builtinHComp ++ " of Set" - getTermLocal = getTerm localUse - tPOr <- getTermLocal "primPOr" - tIMax <- getTermLocal builtinIMax - tIMin <- getTermLocal builtinIMin - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - tTranspProof <- getTermLocal builtinTranspProof - tSubIn <- getTermLocal builtinSubIn - tForall <- getTermLocal builtinFaceForall - io <- getTermLocal builtinIOne - iz <- getTermLocal builtinIZero - tLSuc <- getTermLocal builtinLevelSuc - tPath <- getTermLocal builtinPath - tItIsOne <- getTermLocal builtinItIsOne - kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit - runNamesT [] $ do - let ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - imin i j = pure tIMin <@> i <@> j - transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0 - - gcomp <- mkGComp localUse - - let transpFill la bA phi u0 i = - pure tTrans <#> ilam "j" (\ j -> la <@> imin i j) - <@> ilam "j" (\ j -> bA <@> imin i j) - <@> (imax phi (ineg i)) - <@> u0 - [psi,u0] <- mapM (open . unArg) [psi,u0] - glue1 <- do - tglue <- cl $ getTermLocal builtin_glueU - [la, phi, bT, bA] <- mapM (open . unArg . subst 0 io) $ [la, phi, bT, bA] - let bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA - g <- (open =<<) $ pure tglue <#> la <#> phi <#> bT <#> bAS - return $ \ t a -> g <@> t <@> a - - [la, phi, bT, bA] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, phi, bT, bA] - - -- Andreas, 2022-03-25, issue #5838. - -- Port the fix of @unglueTranspGlue@ and @compGlue DoTransp@ - -- also to @compHCompU DoTransp@, as suggested by Tom Jack and Anders Mörtberg. - -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@. - -- The original code used it only with @i0@. - tunglue <- cl $ getTermLocal builtin_unglueU - let bAS i = - pure tSubIn <#> (pure tLSuc <@> (la <@> i)) - <#> (Sort . tmSort <$> (la <@> i)) - <#> (phi <@> i) - <@> (bA <@> i) - let unglue_u0 i = - pure tunglue <#> (la <@> i) - <#> (phi <@> i) - <#> (bT <@> i) - <#> bAS i - <@> u0 - - ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do - - let - lb = la - tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <@> pure io <..> o) psi u0 i - t1 o = tf (pure io) o - - -- compute "forall. phi" - forallphi = pure tForall <@> phi - - -- a1 with gcomp - a1 = gcomp la bA - (imax psi forallphi) - (lam "i" $ \ i -> pure tPOr <#> (la <@> i) - <@> psi - <@> forallphi - <@> ilam "o" (\ _ -> bA <@> i) - <@> ilam "o" (\ _ -> unglue_u0 i) - <@> ilam "o" (\ o -> transp (la <@> i) - (\ j -> bT <@> i <@> ineg j <..> o) - (tf i o))) - (unglue_u0 (pure iz)) - - w i o = lam "x" $ - transp (la <@> i) - (\ j -> bT <@> i <@> ineg j <..> o) - - pt o = -- o : [ φ 1 ] - pure tPOr <#> (la <@> pure io) - <@> psi - <@> forallphi - <@> ilam "o" (\ _ -> bT <@> pure io <@> pure io <..> o) - <@> ilam "o" (\ o -> u0) - <@> ilam "o" (\ o -> t1 o) - - -- "ghcomp" is implemented in the proof of tTranspProof - -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda) - t1'alpha o = -- o : [ φ 1 ] - pure tTranspProof <#> (la <@> pure io) - <@> lam "i" (\ i -> bT <@> pure io <@> ineg i <..> o) - <@> imax psi forallphi - <@> pt o - <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io) - <#> imax psi forallphi - <@> a1) - - -- TODO: optimize? - t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)]) - alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)]) - a1' = pure tHComp - <#> (la <@> pure io) - <#> (bA <@> pure io) - <#> (imax (phi <@> pure io) psi) - <@> lam "j" (\ j -> - pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io) - <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j)) - <@> ilam "o" (\ _ -> a1)) - <@> a1 - - -- glue1 (ilam "o" t1') a1' - case tpos of - Eliminated -> a1' - Head -> t1' (pure tItIsOne) -compHCompU _ psi _ u0 _ _ = __IMPOSSIBLE__ - - -primTransHComp :: TranspOrHComp -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term) -primTransHComp cmd ts nelims = do - (l,bA,phi,u,u0) <- case (cmd,ts) of - (DoTransp, [l,bA,phi, u0]) -> do - -- u <- runNamesT [] $ do - -- u0 <- open $ unArg u0 - -- defaultArg <$> (ilam "o" $ \ _ -> u0) - return $ (IsFam l,IsFam bA,phi,Nothing,u0) - (DoHComp, [l,bA,phi,u,u0]) -> do - -- [l,bA] <- runNamesT [] $ do - -- forM [l,bA] $ \ a -> do - -- let info = argInfo a - -- a <- open $ unArg a - -- Arg info <$> (lam "i" $ \ _ -> a) - return $ (IsNot l,IsNot bA,phi,Just u,u0) - _ -> __IMPOSSIBLE__ - sphi <- reduceB' phi - vphi <- intervalView $ unArg $ ignoreBlocking sphi - let clP s = getTerm (cmdToName cmd) s - - -- WORK - case vphi of - IOne -> redReturn =<< case u of - -- cmd == DoComp - Just u -> runNamesT [] $ do - u <- open (unArg u) - u <@> clP builtinIOne <..> clP builtinItIsOne - -- cmd == DoTransp - Nothing -> return $ unArg u0 - _ -> do - let fallback' sc = do - u' <- case u of - -- cmd == DoComp - Just u -> - (:[]) <$> case vphi of - IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do - [l,c] <- mapM (open . unArg) [famThing l, ignoreBlocking sc] - lam "i" $ \ i -> clP builtinIsOneEmpty <#> l - <#> ilam "o" (\ _ -> c) - _ -> return (notReduced u) - -- cmd == DoTransp - Nothing -> return [] - return $ NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0] - sbA <- reduceB' bA - t <- case unArg <$> ignoreBlocking sbA of - IsFam (Lam _info t) -> Just . fmap IsFam <$> reduceB' (absBody t) - IsFam _ -> return Nothing - IsNot t -> return . Just . fmap IsNot $ (t <$ sbA) - case t of - Nothing -> fallback' (famThing <$> sbA) - Just st -> do - let - fallback = fallback' (fmap famThing $ st *> sbA) - t = ignoreBlocking st - mHComp <- getPrimitiveName' builtinHComp - mGlue <- getPrimitiveName' builtinGlue - mId <- getBuiltinName' builtinId - pathV <- pathView' - case famThing t of - MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA) - -- absName t instead of "i" - Pi a b | nelims > 0 -> maybe fallback redReturn =<< compPi cmd "i" ((a,b) <$ t) (ignoreBlocking sphi) u u0 - | otherwise -> fallback - - Sort (Type l) | DoTransp <- cmd -> compSort cmd fallback phi u u0 (l <$ t) - - Def q [Apply la, Apply lb, Apply bA, Apply phi', Apply bT, Apply e] | Just q == mGlue -> do - maybe fallback redReturn =<< compGlue cmd phi u u0 ((la, lb, bA, phi', bT, e) <$ t) Head - - Def q [Apply _, Apply s, Apply phi', Apply bT, Apply bA] - | Just q == mHComp, Sort (Type la) <- unArg s -> do - maybe fallback redReturn =<< compHCompU cmd phi u u0 ((Level la <$ s, phi', bT, bA) <$ t) Head - - -- Path/PathP - d | PathType _ _ _ bA x y <- pathV (El __DUMMY_SORT__ d) -> do - if nelims > 0 then compPathP cmd sphi u u0 l ((bA, x, y) <$ t) else fallback - - Def q [Apply _ , Apply bA , Apply x , Apply y] | Just q == mId -> do - maybe fallback return =<< compId cmd sphi u u0 l ((bA, x, y) <$ t) - - Def q es -> do - info <- getConstInfo q - let lam_i = Lam defaultArgInfo . Abs "i" - - case theDef info of - r@Record{recComp = kit} | nelims > 0, Just as <- allApplyElims es, DoTransp <- cmd, Just transpR <- nameOfTransp kit - -> if recPars r == 0 - then redReturn $ unArg u0 - else redReturn $ (Def transpR []) `apply` - (map (fmap lam_i) as ++ [ignoreBlocking sphi,u0]) - | nelims > 0, Just as <- allApplyElims es, DoHComp <- cmd, Just hCompR <- nameOfHComp kit - -> redReturn $ (Def hCompR []) `apply` - (as ++ [ignoreBlocking sphi,fromMaybe __IMPOSSIBLE__ u,u0]) - - | Just as <- allApplyElims es, [] <- recFields r -> compData False (recPars r) cmd l (as <$ t) sbA sphi u u0 - Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons} - | and [null pcons | DoHComp <- [cmd]], Just as <- allApplyElims es -> compData (not $ null $ pcons) (pars+ixs) cmd l (as <$ t) sbA sphi u u0 - Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0 - _ -> fallback - - _ -> fallback - where - compSort DoTransp fallback phi Nothing u0 (IsFam l) = do - -- TODO should check l is constant - redReturn $ unArg u0 - -- compSort DoHComp fallback phi (Just u) u0 (IsNot l) = -- hcomp for Set is a whnf, handled above. - compSort _ fallback phi u u0 _ = __IMPOSSIBLE__ - compPi :: TranspOrHComp -> ArgName -> FamilyOrNot (Dom Type, Abs Type) -- Γ , i : I - -> Arg Term -- Γ - -> Maybe (Arg Term) -- Γ - -> Arg Term -- Γ - -> ReduceM (Maybe Term) - compPi cmd t ab phi u u0 = do - let getTermLocal = getTerm $ cmdToName cmd ++ " for function types" - - tTrans <- getTermLocal builtinTrans - tHComp <- getTermLocal builtinHComp - tINeg <- getTermLocal builtinINeg - tIMax <- getTermLocal builtinIMax - iz <- getTermLocal builtinIZero - let - toLevel' t = do - s <- reduce $ getSort t - case s of - (Type l) -> return (Just l) - _ -> return Nothing - toLevel t = fromMaybe __IMPOSSIBLE__ <$> toLevel' t - -- make sure the codomain has a level. - caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ _ -> do - runNamesT [] $ do - labA <- do - let (x,f) = case ab of - IsFam (a,_) -> (a, \ a -> runNames [] $ lam "i" (const (pure a))) - IsNot (a,_) -> (a, id) - s <- reduce $ getSort x - case s of - Type lx -> do - [la,bA] <- mapM (open . f) [Level lx, unEl . unDom $ x] - pure $ Just $ \ iOrNot phi a0 -> pure tTrans <#> lam "j" (\ j -> la <@> iOrNot j) - <@> lam "j" (\ j -> bA <@> iOrNot j) - <@> phi - <@> a0 - LockUniv -> return $ Just $ \ _ _ a0 -> a0 - _ -> return Nothing - caseMaybe labA (return Nothing) $ \ trA -> Just <$> do - [phi, u0] <- mapM (open . unArg) [phi, u0] - u <- traverse open (unArg <$> u) - - glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \ u1 -> do - case (cmd, ab, u) of - (DoHComp, IsNot (a , b), Just u) -> do - bT <- (raise 1 b `absApp`) <$> u1 - let v = u1 - pure tHComp <#> (Level <$> toLevel bT) - <#> pure (unEl $ bT) - <#> phi - <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) v) - <@> (gApply (getHiding a) u0 v) - (DoTransp, IsFam (a , b), Nothing) -> do - let v i = do - let - iOrNot j = pure tIMax <@> i <@> (pure tINeg <@> j) - trA iOrNot (pure tIMax <@> phi <@> i) - u1 - -- Γ , u1 : A[i1] , i : I - bB v = consS v (liftS 1 $ raiseS 1) `applySubst` (absBody b {- Γ , i : I , x : A[i] -}) - tLam = Lam defaultArgInfo - bT <- bind "i" $ fmap bB . v - -- Γ , u1 : A[i1] - (pure tTrans <#> (tLam <$> traverse (fmap Level . toLevel) bT) - <@> (pure . tLam $ unEl <$> bT) - <@> phi - <@> gApply (getHiding a) u0 (v (pure iz))) - (_,_,_) -> __IMPOSSIBLE__ - compPathP cmd@DoHComp sphi (Just u) u0 (IsNot l) (IsNot (bA,x,y)) = do - let getTermLocal = getTerm $ cmdToName cmd ++ " for path types" - tHComp <- getTermLocal builtinHComp - tINeg <- getTermLocal builtinINeg - tIMax <- getTermLocal builtinIMax - tOr <- getTermLocal "primPOr" - let - ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - - redReturn . runNames [] $ do - [l,u,u0] <- mapM (open . unArg) [l,u,u0] - phi <- open . unArg . ignoreBlocking $ sphi - [bA, x, y] <- mapM (open . unArg) [bA, x, y] - lam "j" $ \ j -> - pure tHComp <#> l - <#> (bA <@> j) - <#> (phi `imax` (ineg j `imax` j)) - <@> lam "i'" (\ i -> - let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i) - in or phi (ineg j `imax` j) - <@> ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j)) -- a0 <@@> (x <@> i, y <@> i, j) - <@> (or (ineg j) j <@> ilam "_" (const x) - <@> ilam "_" (const y))) - <@> (u0 <@@> (x, y, j)) - compPathP cmd@DoTransp sphi Nothing u0 (IsFam l) (IsFam (bA,x,y)) = do - -- Γ ⊢ l - -- Γ, i ⊢ bA, x, y - let getTermLocal = getTerm $ cmdToName cmd ++ " for path types" - tINeg <- getTermLocal builtinINeg - tIMax <- getTermLocal builtinIMax - tOr <- getTermLocal "primPOr" - iz <- getTermLocal builtinIZero - io <- getTermLocal builtinIOne - let - ineg j = pure tINeg <@> j - imax i j = pure tIMax <@> i <@> j - comp <- do - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r)) - <@> lam "i" (\ i -> bA <@> (i `imax` r)) - <@> r - <@> u - return $ \ la bA phi u u0 -> - pure tHComp <#> (la <@> pure io) - <#> (bA <@> pure io) - <#> phi - <@> lam "i" (\ i -> ilam "o" $ \ o -> - forward la bA i (u <@> i <..> o)) - <@> forward la bA (pure iz) u0 - redReturn . runNames [] $ do - [l,u0] <- mapM (open . unArg) [l,u0] - phi <- open . unArg . ignoreBlocking $ sphi - [bA, x, y] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y] - lam "j" $ \ j -> - comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j)) - (lam "i'" $ \ i -> - let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i <@> j) in - or phi (ineg j `imax` j) - <@> ilam "o" (\ o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j)) - <@> (or (ineg j) j <@> ilam "_" (const (x <@> i)) - <@> ilam "_" (const (y <@> i)))) - (u0 <@@> (x <@> pure iz, y <@> pure iz, j)) - compPathP _ sphi u a0 _ _ = __IMPOSSIBLE__ - compId cmd sphi u a0 l bA_x_y = do - let getTermLocal = getTerm $ cmdToName cmd ++ " for " ++ builtinId - unview <- intervalUnview' - mConId <- getBuiltinName' builtinConId - let isConId (Def q _) = Just q == mConId - isConId _ = False - sa0 <- reduceB' a0 - -- wasteful to compute b even when cheaper checks might fail - b <- case u of - Nothing -> return True - Just u -> allComponents unview (unArg . ignoreBlocking $ sphi) (unArg u) isConId - case mConId of - Just conid | isConId (unArg . ignoreBlocking $ sa0) , b -> (Just <$>) . (redReturn =<<) $ do - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - tIMin <- getTermLocal "primDepIMin" - tFace <- getTermLocal "primIdFace" - tPath <- getTermLocal "primIdPath" - tPathType <- getTermLocal builtinPath - runNamesT [] $ do - let io = pure $ unview IOne - iz = pure $ unview IZero - conId = pure $ Def conid [] - l <- case l of - IsFam l -> open . unArg $ l - IsNot l -> do - open (Lam defaultArgInfo $ NoAbs "_" $ unArg l) - [p0] <- mapM (open . unArg) [a0] - p <- case u of - Just u -> do - u <- open . unArg $ u - return $ \ i o -> u <@> i <..> o - Nothing -> do - return $ \ i o -> p0 - phi <- open . unArg . ignoreBlocking $ sphi - [bA, x, y] <- - case bA_x_y of - IsFam (bA,x,y) -> mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y] - IsNot (bA,x,y) -> forM [bA,x,y] $ \ a -> open (Lam defaultArgInfo $ NoAbs "_" $ unArg a) - let - eval DoTransp l bA phi _ u0 = pure tTrans <#> l <@> bA <@> phi <@> u0 - eval DoHComp l bA phi u u0 = pure tHComp <#> (l <@> io) <#> (bA <@> io) <#> phi - <@> u <@> u0 - conId <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io) - <@> (pure tIMin <@> phi - <@> ilam "o" (\ o -> pure tFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io) - <@> (p io o))) - <@> (eval cmd l - (lam "i" $ \ i -> pure tPathType <#> (l <@> i) <#> (bA <@> i) <@> (x <@> i) <@> (y <@> i)) - phi - (lam "i" $ \ i -> ilam "o" $ \ o -> pure tPath <#> (l <@> i) <#> (bA <@> i) - <#> (x <@> i) <#> (y <@> i) - <@> (p i o) - ) - (pure tPath <#> (l <@> iz) <#> (bA <@> iz) <#> (x <@> iz) <#> (y <@> iz) - <@> p0) - ) - _ -> return $ Nothing - allComponents unview phi u p = do - let - boolToI b = if b then unview IOne else unview IZero - as <- decomposeInterval phi - andM . for as $ \ (bs,ts) -> do - let u' = listS (Map.toAscList $ Map.map boolToI bs) `applySubst` u - t <- reduce2Lam u' - return $! p $ ignoreBlocking t - reduce2Lam t = do - t <- reduce' t - case lam2Abs t of - t -> underAbstraction_ t $ \ t -> do - t <- reduce' t - case lam2Abs t of - t -> underAbstraction_ t reduceB' - where - lam2Abs (Lam _ t) = absBody t <$ t - lam2Abs t = Abs "y" (raise 1 t `apply` [argN $ var 0]) - allComponentsBack unview phi u p = do - let - boolToI b = if b then unview IOne else unview IZero - lamlam t = Lam defaultArgInfo (Abs "i" (Lam (setRelevance Irrelevant defaultArgInfo) (Abs "o" t))) - as <- decomposeInterval phi - (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do - let u' = listS bs' `applySubst` u - bs' = (Map.toAscList $ Map.map boolToI bs) - -- Γ₁, i : I, Γ₂, j : I, Γ₃ ⊢ weaken : Γ₁, Γ₂, Γ₃ for bs' = [(j,_),(i,_)] - -- ordering of "j,i,.." matters. - let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs') - t <- reduce2Lam u' - return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ]) - return $ (flags,t_alphas) - compData False _ cmd@DoHComp (IsNot l) (IsNot ps) fsc sphi (Just u) a0 = do - let getTermLocal = getTerm $ cmdToName cmd ++ " for data types" - - let sc = famThing <$> fsc - tEmpty <- getTermLocal builtinIsOneEmpty - tPOr <- getTermLocal builtinPOr - iO <- getTermLocal builtinIOne - iZ <- getTermLocal builtinIZero - tMin <- getTermLocal builtinIMin - tNeg <- getTermLocal builtinINeg - let iNeg t = tNeg `apply` [argN t] - iMin t u = tMin `apply` [argN t, argN u] - iz = pure iZ - constrForm <- do - mz <- getTerm' builtinZero - ms <- getTerm' builtinSuc - return $ \ t -> fromMaybe t (constructorForm' mz ms t) - su <- reduceB' u - sa0 <- reduceB' a0 - view <- intervalView' - unview <- intervalUnview' - let f = unArg . ignoreBlocking - phi = f sphi - a0 = f sa0 - isLit t@(Lit lt) = Just t - isLit _ = Nothing - isCon (Con h _ _) = Just h - isCon _ = Nothing - combine l ty d [] = d - combine l ty d [(psi,u)] = u - combine l ty d ((psi,u):xs) - = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs - <#> ilam "o" (\ _ -> ty) -- the type - <@> u <@> (combine l ty d xs) - noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0] - where - su' = case view phi of - IZero -> notBlocked $ argN $ runNames [] $ do - [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc] - lam "i" $ \ i -> pure tEmpty <#> l - <#> ilam "o" (\ _ -> c) - _ -> su - sameConHeadBack Nothing Nothing su k = noRed' su - sameConHeadBack lt h su k = do - let u = unArg . ignoreBlocking $ su - (b, ts) <- allComponentsBack unview phi u $ \ t -> - (isLit t == lt, isCon (constrForm t) == h) - let - (lit,hd) = unzip b - - if isJust lt && and lit then redReturn a0 else do - su <- caseMaybe (sequence ts) (return su) $ \ ts -> do - let (us,bools) = unzip ts - fmap ((sequenceA_ us $>) . argN) $ do - let - phis :: [Term] - phis = for bools $ \ m -> - foldr (iMin . (\(i,b) -> if b then var i else iNeg (var i))) iO (Map.toList m) - runNamesT [] $ do - u <- open u - [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc] - phis <- mapM open phis - us <- mapM (open . ignoreBlocking) us - lam "i" $ \ i -> do - combine l c (u <@> i) $ zip phis (map (\ t -> t <@> i) us) - - if isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su - else noRed' su - - sameConHeadBack (isLit a0) (isCon a0) su $ \ h su -> do - let u = unArg . ignoreBlocking $ su - Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h) - case nameOfHComp cm of - Just hcompD -> redReturn $ Def hcompD [] `apply` - (ps ++ map argN [phi,u,a0]) - Nothing -> noRed' su - - compData _ 0 DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = redReturn $ unArg a0 - compData isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do - let getTermLocal = getTerm $ cmdToName cmd ++ " for data types" - let sc = famThing <$> fsc - mhcompName <- getName' builtinHComp - constrForm <- do - mz <- getTerm' builtinZero - ms <- getTerm' builtinSuc - return $ \ t -> fromMaybe t (constructorForm' mz ms t) - sa0 <- reduceB' a0 - let f = unArg . ignoreBlocking - phi = f sphi - a0 = f sa0 - noRed = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced sa0] - let lam_i = Lam defaultArgInfo . Abs "i" - case constrForm a0 of - Con h _ args -> do - Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h) - case nameOfTransp cm of - Just transpD -> redReturn $ Def transpD [] `apply` - (map (fmap lam_i) ps ++ map argN [phi,a0]) - Nothing -> noRed - Def q es | isHIT, Just q == mhcompName, Just [_l0,_c0,psi,u,u0] <- allApplyElims es -> do - let bC = ignoreBlocking sc - hcomp <- getTermLocal builtinHComp - transp <- getTermLocal builtinTrans - io <- getTermLocal builtinIOne - iz <- getTermLocal builtinIZero - redReturn <=< runNamesT [] $ do - [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0] - -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0) - pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi - <@> lam "j" (\ j -> ilam "o" $ \ o -> - pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o)) - <@> (pure transp <#> l <@> bC <@> phi <@> u0) - _ -> noRed - compData _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__ - -primComp :: TCM PrimitiveImpl -primComp = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a -> - nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA -> - hPi' "φ" primIntervalType $ \ phi -> - nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) --> - (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne)) - one <- primItIsOne - io <- primIOne - return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do - case ts of - [l,c,phi,u,a0] -> do - sphi <- reduceB' phi - vphi <- intervalView $ unArg $ ignoreBlocking sphi - case vphi of - IOne -> redReturn (unArg u `apply` [argN io, argN one]) - _ -> do - let getTermLocal = getTerm $ builtinComp - tIMax <- getTermLocal builtinIMax - tINeg <- getTermLocal builtinINeg - tHComp <- getTermLocal builtinHComp - tTrans <- getTermLocal builtinTrans - iz <- getTermLocal builtinIZero - redReturn <=< runNamesT [] $ do - comp <- do - let imax i j = pure tIMax <@> i <@> j - forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r)) - <@> (lam "i" $ \ i -> bA <@> (i `imax` r)) - <@> r - <@> u - return $ \ la bA phi u u0 -> - pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi - <@> lam "i" (\ i -> ilam "o" $ \ o -> - forward la bA i (u <@> i <..> o)) - <@> forward la bA (pure iz) u0 - - [l,c,phi,u,a0] <- mapM (open . unArg) [l,c,phi,u,a0] - comp l c phi u a0 - - _ -> __IMPOSSIBLE__ - - -prim_glueU' :: TCM PrimitiveImpl -prim_glueU' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "la" (el $ cl primLevel) (\ la -> - hPi' "φ" primIntervalType $ \ φ -> - hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t -> - hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do - let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a) - pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o)) - --> (el' la bA) - --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)) - view <- intervalView' - one <- primItIsOne - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts -> - case ts of - [la,phi,bT,bA,t,a] -> do - sphi <- reduceB' phi - case view $ unArg $ ignoreBlocking $ sphi of - IOne -> redReturn $ unArg t `apply` [argN one] - _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA,t,a]) - _ -> __IMPOSSIBLE__ - -prim_unglueU' :: TCM PrimitiveImpl -prim_unglueU' = do - requireCubical CErased "" - t <- runNamesT [] $ - hPi' "la" (el $ cl primLevel) (\ la -> - hPi' "φ" primIntervalType $ \ φ -> - hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t -> - hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do - let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a) - el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA) - --> el' la bA) - view <- intervalView' - one <- primItIsOne - mglueU <- getPrimitiveName' builtin_glueU - mtransp <- getPrimitiveName' builtinTrans - mHCompU <- getPrimitiveName' builtinHComp - let mhcomp = mHCompU - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ts -> - case ts of - [la,phi,bT,bA,b] -> do - sphi <- reduceB' phi - case view $ unArg $ ignoreBlocking $ sphi of - IOne -> do - tTransp <- getTerm builtin_unglueU builtinTrans - iNeg <- getTerm builtin_unglueU builtinINeg - iZ <- getTerm builtin_unglueU builtinIZero - redReturn <=< runNamesT [] $ do - [la,bT,b] <- mapM (open . unArg) [la,bT,b] - pure tTransp <#> lam "i" (\ _ -> la) - <@> lam "i" (\ i -> bT <@> (pure iNeg <@> i) <..> pure one) - <@> pure iZ - <@> b - _ -> do - sb <- reduceB' b - let fallback sbA = return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb]) - case unArg $ ignoreBlocking $ sb of - Def q [Apply _,Apply _,Apply _,Apply _,Apply _,Apply a] - | Just q == mglueU -> redReturn $ unArg a - Def q [Apply l,Apply bA,Apply r,Apply u0] - | Just q == mtransp -> do - sbA <- reduceB bA - case unArg $ ignoreBlocking sbA of - Lam _ t -> do - st <- reduceB' (absBody t) - case ignoreBlocking st of - Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do - redReturn . fromMaybe __IMPOSSIBLE__ =<< compHCompU DoTransp r Nothing u0 (IsFam (la,phi,bT,bA)) Eliminated - _ -> fallback (st *> sbA) - _ -> fallback sbA - Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] - | Just q == mhcomp -> do - sbA <- reduceB bA - case unArg $ ignoreBlocking sbA of - Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do - redReturn . fromMaybe __IMPOSSIBLE__ =<< compHCompU DoHComp r (Just u) u0 (IsNot (la,phi,bT,bA)) Eliminated - _ -> fallback sbA - _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb]) - _ -> __IMPOSSIBLE__ - - -primGlue' :: TCM PrimitiveImpl -primGlue' = do - requireCubical CFull "" - -- Glue' : ∀ {l} (A : Set l) → ∀ φ → (T : Partial (Set a) φ) (f : (PartialP φ \ o → (T o) -> A)) - -- ([f] : PartialP φ \ o → isEquiv (T o) A (f o)) → Set l - t <- runNamesT [] $ - hPi' "la" (el $ cl primLevel) (\ la -> - hPi' "lb" (el $ cl primLevel) $ \ lb -> - nPi' "A" (sort . tmSort <$> la) $ \ a -> - hPi' "φ" primIntervalType $ \ φ -> - nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t -> - pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) - --> (sort . tmSort <$> lb)) - view <- intervalView' - one <- primItIsOne - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts -> - case ts of - [la,lb,a,phi,t,e] -> do - sphi <- reduceB' phi - case view $ unArg $ ignoreBlocking $ sphi of - IOne -> redReturn $ unArg t `apply` [argN one] - _ -> return (NoReduction $ map notReduced [la,lb,a] ++ [reduced sphi] ++ map notReduced [t,e]) - _ -> __IMPOSSIBLE__ - -prim_glue' :: TCM PrimitiveImpl -prim_glue' = do - requireCubical CFull "" - t <- runNamesT [] $ - hPi' "la" (el $ cl primLevel) (\ la -> - hPi' "lb" (el $ cl primLevel) $ \ lb -> - hPi' "A" (sort . tmSort <$> la) $ \ a -> - hPi' "φ" primIntervalType $ \ φ -> - hPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t -> - hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e -> - pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e))) - view <- intervalView' - one <- primItIsOne - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ts -> - case ts of - [la,lb,bA,phi,bT,e,t,a] -> do - sphi <- reduceB' phi - case view $ unArg $ ignoreBlocking $ sphi of - IOne -> redReturn $ unArg t `apply` [argN one] - _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e,t,a]) - _ -> __IMPOSSIBLE__ - -prim_unglue' :: TCM PrimitiveImpl -prim_unglue' = do - requireCubical CFull "" - t <- runNamesT [] $ - hPi' "la" (el $ cl primLevel) (\ la -> - hPi' "lb" (el $ cl primLevel) $ \ lb -> - hPi' "A" (sort . tmSort <$> la) $ \ a -> - hPi' "φ" primIntervalType $ \ φ -> - hPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t -> - hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e -> - (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a) - view <- intervalView' - one <- primItIsOne - mGlue <- getPrimitiveName' builtinGlue - mglue <- getPrimitiveName' builtin_glue - mtransp <- getPrimitiveName' builtinTrans - mhcomp <- getPrimitiveName' builtinHComp - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 7 $ \ts -> - case ts of - [la,lb,bA,phi,bT,e,b] -> do - sphi <- reduceB' phi - case view $ unArg $ ignoreBlocking $ sphi of - IOne -> do - let argOne = setRelevance Irrelevant $ argN one - tEFun <- getTerm builtin_unglue builtinEquivFun - redReturn $ tEFun `apply` [lb,la,argH $ unArg bT `apply` [argOne],bA, argN $ unArg e `apply` [argOne],b] - _ -> do - sb <- reduceB' b - let fallback sbA = return (NoReduction $ map notReduced [la,lb] ++ map reduced [sbA, sphi] ++ map notReduced [bT,e] ++ [reduced sb]) - case unArg $ ignoreBlocking $ sb of - Def q [Apply _,Apply _,Apply _,Apply _,Apply _,Apply _,Apply _,Apply a] - | Just q == mglue -> redReturn $ unArg a - Def q [Apply l,Apply bA,Apply r,Apply u0] - | Just q == mtransp -> do - sbA <- reduceB' bA - case unArg $ ignoreBlocking sbA of - Lam _ t -> do - st <- reduceB' (absBody t) - case ignoreBlocking st of - Def g es | Just [la',lb',bA',phi',bT',e'] <- allApplyElims es, Just g == mGlue -> do - redReturn . fromMaybe __IMPOSSIBLE__ =<< compGlue DoTransp r Nothing u0 (IsFam (la',lb',bA',phi',bT',e')) Eliminated - _ -> fallback (st *> sbA) - _ -> fallback sbA - Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] - | Just q == mhcomp -> do - sbA <- reduceB' bA - case unArg $ ignoreBlocking sbA of - Def g es | Just [la',lb',bA',phi',bT',e'] <- allApplyElims es, Just g == mGlue -> do - redReturn . fromMaybe __IMPOSSIBLE__ =<< compGlue DoHComp r (Just u) u0 (IsNot (la',lb',bA',phi',bT',e')) Eliminated - _ -> fallback sbA - _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e] ++ [reduced sb]) - _ -> __IMPOSSIBLE__ - - --- TODO Andrea: keep reductions that happen under foralls? -primFaceForall' :: TCM PrimitiveImpl -primFaceForall' = do - requireCubical CErased "" - t <- (primIntervalType --> primIntervalType) --> primIntervalType - return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts -> case ts of - [phi] -> do - sphi <- reduceB' phi - case unArg $ ignoreBlocking $ sphi of - Lam _ t -> do - t <- reduce' t - case t of - NoAbs _ t -> redReturn t - Abs _ t -> - maybe (return $ NoReduction [reduced sphi]) redReturn - =<< toFaceMapsPrim t - _ -> return (NoReduction [reduced sphi]) - _ -> __IMPOSSIBLE__ - where - toFaceMapsPrim t = do - view <- intervalView' - unview <- intervalUnview' - us' <- decomposeInterval t - fr <- getTerm builtinFaceForall builtinFaceForall - let v = view t - us = - [ map Left (Map.toList bsm) ++ map Right ts - | (bsm, ts) <- us', - 0 `Map.notMember` bsm - ] - fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1))) - ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t] - r = - Just $ - foldr - ( (\x r -> unview (IMax (argN x) (argN r))) - . foldr - (\x r -> unview (IMin (argN (either fm ffr x)) (argN r))) - (unview IOne) - ) - (unview IZero) - us - -- traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $ - return $ case us' of - [(m, [_])] | Map.null m -> Nothing - v -> r - -decomposeInterval :: HasBuiltins m => Term -> m [(Map Int Bool,[Term])] -decomposeInterval t = do - xs <- decomposeInterval' t - let isConsistent xs = all (\ xs -> Set.size xs == 1) . Map.elems $ xs -- optimize by not doing generate + filter - return [ (Map.map (head . Set.toList) bsm,ts) - | (bsm,ts) <- xs - , isConsistent bsm - ] - -decomposeInterval' :: HasBuiltins m => Term -> m [(Map Int (Set Bool),[Term])] -decomposeInterval' t = do - view <- intervalView' - unview <- intervalUnview' - let f :: IntervalView -> [[Either (Int,Bool) Term]] - -- TODO handle primIMinDep - -- TODO? handle forall - f IZero = mzero - f IOne = return [] - f (IMin x y) = do xs <- (f . view . unArg) x; ys <- (f . view . unArg) y; return (xs ++ ys) - f (IMax x y) = msum $ map (f . view . unArg) [x,y] - f (INeg x) = map (either (\ (x,y) -> Left (x,not y)) (Right . unview . INeg . argN)) <$> (f . view . unArg) x - f (OTerm (Var i [])) = return [Left (i,True)] - f (OTerm t) = return [Right t] - v = view t - return [ (bsm,ts) - | xs <- f v - , let (bs,ts) = partitionEithers xs - , let bsm = (Map.fromListWith Set.union . map (id -*- Set.singleton)) bs - ] - - --- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types. --- If a type in the telescope does not support transp, @transpTel@ throws it as an exception. -transpTel :: Abs Telescope -- Γ ⊢ i.Δ - -> Term -- Γ ⊢ φ : F -- i.Δ const on φ - -> Args -- Γ ⊢ δ : Δ[0] - -> ExceptT (Closure (Abs Type)) TCM Args -- Γ ⊢ Δ[1] -transpTel delta phi args = do - tTransp <- liftTCM primTrans - imin <- liftTCM primIMin - imax <- liftTCM primIMax - ineg <- liftTCM primINeg - let - noTranspError t = lift . throwError =<< liftTCM (buildClosure t) - bapp :: (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a - bapp t u = lazyAbsApp <$> t <*> u - gTransp (Just l) t phi a = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a - gTransp Nothing t phi a = do - -- Γ ⊢ i.Ξ - xi <- (open =<<) $ do - bind "i" $ \ i -> do - TelV xi _ <- (liftTCM . telView =<<) $ t `bapp` i - return xi - argnames <- do - teleArgNames . unAbs <$> xi - glamN argnames $ \ xi_args -> do - b' <- bind "i" $ \ i -> do - ti <- t `bapp` i - xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i) - xi_args <- xi_args - ni <- pure ineg <@> i - phi <- phi - lift $ piApplyM ti =<< trFillTel xin phi xi_args ni - axi <- do - a <- a - xif <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i) - phi <- phi - xi_args <- xi_args - lift $ apply a <$> transpTel xif phi xi_args - s <- reduce $ getSort (absBody b') - case s of - Type l -> do - l <- open $ lam_i (Level l) - b' <- open b' - axi <- open axi - gTransp (Just l) b' phi axi - Inf _ n -> - if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi - SSet _ -> - if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi - _ -> noTranspError b' - lam_i = Lam defaultArgInfo . Abs "i" - go :: Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args - go EmptyTel _ [] = return [] - go (ExtendTel t delta) phi (a:args) = do - -- Γ,i ⊢ t - -- Γ,i ⊢ (x : t). delta - -- Γ ⊢ a : t[0] - s <- reduce $ getSort t - -- Γ ⊢ b : t[1], Γ,i ⊢ b : t[i] - (b,bf) <- runNamesT [] $ do - l <- case s of - SSet _ -> return Nothing - Inf _ n -> return Nothing - Type l -> Just <$> open (lam_i (Level l)) - _ -> noTranspError (Abs "i" (unDom t)) - t <- open $ Abs "i" (unDom t) - [phi,a] <- mapM open [phi, unArg a] - b <- gTransp l t phi a - bf <- bind "i" $ \ i -> do - gTransp ((<$> l) $ \ l -> lam "j" $ \ j -> l <@> (pure imin <@> i <@> j)) - (bind "j" $ \ j -> t `bapp` (pure imin <@> i <@> j)) - (pure imax <@> (pure ineg <@> i) <@> phi) - a - return (b, absBody bf) - (:) (b <$ a) <$> go (lazyAbsApp delta bf) phi args - go (ExtendTel t delta) phi [] = __IMPOSSIBLE__ - go EmptyTel _ (_:_) = __IMPOSSIBLE__ - go (absBody delta) phi args - --- | Like @transpTel@ but performing a transpFill. -trFillTel :: Abs Telescope -- Γ ⊢ i.Δ - -> Term - -> Args -- Γ ⊢ δ : Δ[0] - -> Term -- Γ ⊢ r : I - -> ExceptT (Closure (Abs Type)) TCM Args -- Γ ⊢ Δ[r] -trFillTel delta phi args r = do - imin <- liftTCM primIMin - imax <- liftTCM primIMax - ineg <- liftTCM primINeg - transpTel (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r]))) - (imax `apply` [argN $ ineg `apply` [argN r], argN phi]) - args +{-# LANGUAGE TypeFamilies #-} + +module Agda.TypeChecking.Primitive.Cubical + ( module Agda.TypeChecking.Primitive.Cubical + , module Agda.TypeChecking.Primitive.Cubical.Id + , module Agda.TypeChecking.Primitive.Cubical.Base + , module Agda.TypeChecking.Primitive.Cubical.Glue + , module Agda.TypeChecking.Primitive.Cubical.HCompU + ) + where + +import Prelude hiding (null, (!!)) + +import Control.Monad +import Control.Monad.Except +import Control.Monad.Trans ( lift ) +import Control.Exception + +import Data.String + +import Data.Bifunctor ( second ) +import Data.Either ( partitionEithers ) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.List as List +import Data.Foldable hiding (null) + +import Agda.Interaction.Options ( optCubical ) + +import Agda.Syntax.Common +import Agda.Syntax.Internal +import Agda.Syntax.Internal.Pattern + +import Agda.TypeChecking.Names +import Agda.TypeChecking.Primitive.Base +import Agda.TypeChecking.Monad + +import Agda.TypeChecking.Free +import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Telescope + +import Agda.Utils.Either +import Agda.Utils.Function +import Agda.Utils.Functor +import Agda.Utils.Maybe + +import Agda.Utils.Impossible +import Agda.Utils.Maybe +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.Tuple +import Agda.Utils.Size +import Agda.Utils.BoolSet (BoolSet) +import qualified Agda.Utils.Pretty as P +import qualified Agda.Utils.BoolSet as BoolSet + +import Agda.TypeChecking.Primitive.Cubical.HCompU +import Agda.TypeChecking.Primitive.Cubical.Glue +import Agda.TypeChecking.Primitive.Cubical.Base +import Agda.TypeChecking.Primitive.Cubical.Id + +primPOr :: TCM PrimitiveImpl +primPOr = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + nPi' "i" primIntervalType $ \ i -> + nPi' "j" primIntervalType $ \ j -> + hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> + ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) --> + ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) --> + pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o) + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do + case ts of + [l,i,j,a,u,v] -> do + si <- reduceB' i + vi <- intervalView $ unArg $ ignoreBlocking si + case vi of + IOne -> redReturn (unArg u) + IZero -> redReturn (unArg v) + _ -> do + sj <- reduceB' j + vj <- intervalView $ unArg $ ignoreBlocking sj + case vj of + IOne -> redReturn (unArg v) + IZero -> redReturn (unArg u) + _ -> return $ NoReduction [notReduced l,reduced si,reduced sj,notReduced a,notReduced u,notReduced v] + + + _ -> __IMPOSSIBLE__ + +primPartial' :: TCM PrimitiveImpl +primPartial' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) (\ a -> + nPi' "φ" primIntervalType $ \ _ -> + nPi' "A" (sort . tmSort <$> a) $ \ bA -> + (sort . tmSSort <$> a)) + isOne <- primIsOne + v <- runNamesT [] $ + lam "a" $ \ l -> + lam "φ" $ \ phi -> + lam "A" $ \ a -> + unEl <$> pPi' "p" phi (\_ -> el' l a) + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v + +primPartialP' :: TCM PrimitiveImpl +primPartialP' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) (\ a -> + nPi' "φ" primIntervalType $ \ phi -> + nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> + (sort . tmSSort <$> a)) + v <- runNamesT [] $ + lam "a" $ \ l -> + lam "φ" $ \ phi -> + lam "A" $ \ a -> + unEl <$> pPi' "p" phi (\ p -> el' l (a <@> p)) + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v + +primSubOut' :: TCM PrimitiveImpl +primSubOut' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> + hPi' "φ" primIntervalType $ \ phi -> + hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u -> + el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do + case ts of + [a,bA,phi,u,x] -> do + view <- intervalView' + sphi <- reduceB' phi + case view $ unArg $ ignoreBlocking sphi of + IOne -> redReturn =<< (return (unArg u) <..> (getTerm builtinSubOut builtinItIsOne)) + _ -> do + sx <- reduceB' x + mSubIn <- getBuiltinName' builtinSubIn + case unArg $ ignoreBlocking $ sx of + Def q [_,_,_, Apply t] | Just q == mSubIn -> redReturn (unArg t) + _ -> return $ NoReduction $ map notReduced [a,bA] ++ [reduced sphi, notReduced u, reduced sx] + _ -> __IMPOSSIBLE__ + +primTrans' :: TCM PrimitiveImpl +primTrans' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a -> + nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA -> + nPi' "φ" primIntervalType $ \ phi -> + (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne)) + return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ ts nelims -> do + primTransHComp DoTransp ts nelims + +primHComp' :: TCM PrimitiveImpl +primHComp' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + hPi' "A" (sort . tmSort <$> a) $ \ bA -> + hPi' "φ" primIntervalType $ \ phi -> + nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) --> + (el' a bA --> el' a bA) + return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do + primTransHComp DoHComp ts nelims + +-- | Construct a helper for CCHM composition, with a string indicating +-- what function uses it. +mkComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term) +mkComp s = do + let getTermLocal = getTerm s + tIMax <- getTermLocal builtinIMax + tINeg <- getTermLocal builtinINeg + tHComp <- getTermLocal builtinHComp + tTrans <- getTermLocal builtinTrans + iz <- getTermLocal builtinIZero + io <- getTermLocal builtinIOne + + let + forward la bA r u = pure tTrans + <#> (lam "i" $ \i -> la <@> (i `imax` r)) + <@> (lam "i" $ \i -> bA <@> (i `imax` r)) + <@> r + <@> u + + pure $ \la bA phi u u0 -> + pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi + <@> lam "i" (\i -> ilam "o" $ \o -> + forward la bA i (u <@> i <..> o)) + <@> forward la bA (pure iz) u0 + +-- | Construct an application of buitlinComp. Use instead of 'mkComp' if +-- reducing directly to hcomp + transport would be problematic. +mkCompLazy + :: HasBuiltins m + => String + -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term) +mkCompLazy s = do + let getTermLocal = getTerm s + tComp <- getTermLocal builtinComp + pure $ \la bA phi u u0 -> pure tComp <#> la <#> bA <#> phi <@> u <@> u0 + +-- | Implementation of Kan operations for Pi types. The implementation +-- of @transp@ and @hcomp@ for Pi types has many commonalities, so most +-- of it is shared between the two cases. +doPiKanOp + :: KanOperation -- ^ Are we composing or transporting? + -> ArgName -- ^ Name of the binder + -> FamilyOrNot (Dom Type, Abs Type) + -- ^ The domain and codomain of the Pi type. + -> ReduceM (Maybe Term) +doPiKanOp cmd t ab = do + let getTermLocal = getTerm $ kanOpName cmd ++ " for function types" + + tTrans <- getTermLocal builtinTrans + tHComp <- getTermLocal builtinHComp + tINeg <- getTermLocal builtinINeg + tIMax <- getTermLocal builtinIMax + iz <- getTermLocal builtinIZero + + -- We must guarantee that the codomain is a fibrant type, i.e. one + -- that supports hcomp and transp. Otherwise, what are we even doing! + let + toLevel' t = do + s <- reduce $ getSort t + case s of + Type l -> return (Just l) + _ -> return Nothing + -- But this case is actually impossible: + toLevel t = fromMaybe __IMPOSSIBLE__ <$> toLevel' t + + caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ _ -> do + runNamesT [] $ do + + -- When doing transport in Pi types, we need to distinguish a couple + -- of different cases depending on the sort of the domain, since + -- there are a couple of different possibilities for how we end up + -- with a fibrant Pi type: + trFibrantDomain <- do + let + (x, f) = case ab of + IsFam (a, _) -> (a, \ a -> runNames [] $ lam "i" (const (pure a))) + IsNot (a, _) -> (a, id) + s <- reduce $ getSort x + case s of + -- We're looking at a fibrant Pi with fibrant domain: Transport + -- backwards along the domain. + Type lx -> do + [la, bA] <- mapM (open . f) [Level lx, unEl . unDom $ x] + pure $ Just $ \iOrNot phi a0 -> + pure tTrans <#> lam "j" (\j -> la <@> iOrNot j) + <@> lam "j" (\ j -> bA <@> iOrNot j) + <@> phi + <@> a0 + + -- We're looking a fibrant Pi whose domain is a lock: No need to do anything. + LockUniv -> return $ Just $ \_ _ a0 -> a0 + + -- We're looking at an unmarked path type. Make sure that the + -- domain is actually the interval before continuing without an + -- adjustment, though! + IntervalUniv -> do + x' <- reduceB $ unDom x + mInterval <- getBuiltinName' builtinInterval + case unEl $ ignoreBlocking x' of + Def q [] | Just q == mInterval -> return $ Just $ \_ _ a0 -> a0 + _ -> return Nothing + + _ -> return Nothing + + caseMaybe trFibrantDomain (return Nothing) $ \trA -> Just <$> do + [phi, u0] <- mapM (open . unArg) [ignoreBlocking (kanOpCofib cmd), kanOpBase cmd] + + glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \u1 -> do + case (cmd, ab) of + + -- hcomp u u0 x = hcomp (λ i o → u i o x) (u0 x). Short and sweet :) + (HCompOp _ u _, IsNot (a , b)) -> do + bT <- (raise 1 b `absApp`) <$> u1 + u <- open (raise 1 (unArg u)) + pure tHComp + <#> (Level <$> toLevel bT) + <#> pure (unEl bT) + <#> phi + <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) u1) + <@> gApply (getHiding a) u0 u1 + + -- transp (λ i → (a : A i) → B i x) φ f u1 = + -- transp (λ i → B i (transp (λ j → A (i ∨ ~ j)) (φ ∨ i) x)) φ + -- (f (transp (λ j → A (~ j) φ x))) + (TranspOp _ _, IsFam (a , b)) -> do + -- trA is a function of three arguments which builds the + -- transport fillers in the opposite direction, hence its + -- first argument is called "iOrNot" where it's relevant. + let + -- Γ , u1 : A[i1] , i : I + v i = trA (imax i . ineg) (imax phi i) u1 + bB v = consS v (liftS 1 $ raiseS 1) `applySubst` + (absBody b {- Γ , i : I , x : A[i] -}) + + -- Compute B @0 v, in the right scope + tLam = Lam defaultArgInfo + + -- We know how to substitute v into B, but it's open in a + -- variable, so we close over it here: + bT <- bind "i" $ \ x -> fmap bB . v $ x + + pure tTrans + <#> (tLam <$> traverse (fmap Level . toLevel) bT) + <@> (pure . tLam $ unEl <$> bT) + <@> phi + <@> gApply (getHiding a) u0 (v (pure iz)) + + (_, _) -> __IMPOSSIBLE_VERBOSE__ "Invalid Kan operation in doPiKanOp" + +-- | Compute Kan operations in a type of dependent paths. +doPathPKanOp + :: KanOperation + -> FamilyOrNot (Arg Term) + -> FamilyOrNot (Arg Term, Arg Term, Arg Term) + -> ReduceM (Reduced MaybeReducedArgs Term) +doPathPKanOp (HCompOp phi u u0) (IsNot l) (IsNot (bA,x,y)) = do + let getTermLocal = getTerm "primHComp for path types" + tHComp <- getTermLocal builtinHComp + + redReturn <=< runNamesT [] $ do + [l, u, u0, phi, bA, x, y] <- mapM (open . unArg) [l, u, u0, ignoreBlocking phi, bA, x, y] + + -- hcomp in path spaces is simply hcomp in the underlying space, but + -- fixing the endpoints at (j ∨ ~ j) in the new direction to those + -- in the Path type. + lam "j" $ \ j -> + pure tHComp <#> l <#> (bA <@> j) <#> (phi `imax` (ineg j `imax` j)) + <@> lam "i'" (\i -> combineSys l (bA <@> i) + [ (phi, ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j))) + , (j, ilam "o" (const y)) + , (ineg j, ilam "o" (const x)) ]) + <@> (u0 <@@> (x, y, j)) + +doPathPKanOp (TranspOp phi u0) (IsFam l) (IsFam (bA,x,y)) = do + -- Γ ⊢ l + -- Γ, i ⊢ bA, x, y + let getTermLocal = getTerm "transport for path types" + iz <- getTermLocal builtinIZero + io <- getTermLocal builtinIOne + + -- Transport in path types becomes /CCHM/ composition in the + -- underlying line of spaces. The intuition is that not only do we + -- have to fix the endpoints (using composition) but also actually + -- transport. CCHM composition conveniently does that for us! + + redReturn <=< runNamesT [] $ do + -- In reality to avoid a round-trip between primComp we use mkComp + -- here. + comp <- mkComp $ "transport for path types" + [l, u0, phi] <- traverse (open . unArg) [l, u0, ignoreBlocking phi] + [bA, x, y] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y] + + lam "j" $ \ j -> + comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j)) + (lam "i'" $ \i -> combineSys l (bA <@> i <@> j) + [ (phi, ilam "o" (\o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j))) + -- Note that here we have lines of endpoints which we must + -- apply to fix the endpoints: + , (j, ilam "_" (const (y <@> i))) + , (ineg j, ilam "_" (const (x <@> i))) + ]) + (u0 <@@> (x <@> pure iz, y <@> pure iz, j)) +doPathPKanOp a0 _ _ = __IMPOSSIBLE__ + +redReturnNoSimpl :: a -> ReduceM (Reduced a' a) +redReturnNoSimpl = pure . YesReduction NoSimplification + +primTransHComp :: Command -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term) +primTransHComp cmd ts nelims = do + (l,bA,phi,u,u0) <- pure $ case (cmd,ts) of + (DoTransp, [l, bA, phi, u0]) -> (IsFam l, IsFam bA, phi, Nothing, u0) + (DoHComp, [l, bA, phi, u, u0]) -> (IsNot l, IsNot bA, phi, Just u, u0) + _ -> __IMPOSSIBLE__ + sphi <- reduceB' phi + vphi <- intervalView $ unArg $ ignoreBlocking sphi + let clP s = getTerm "primTransHComp" s + + -- WORK + case vphi of + -- When φ = i1, we know what to do! These cases are counted as + -- simplifications. + IOne -> redReturn =<< case cmd of + DoHComp -> runNamesT [] $ do + -- If we're composing, then we definitely had a partial element + -- to extend. But now it's just a total element, so we can + -- just.. return it: + u <- open $ unArg $ fromMaybe __IMPOSSIBLE__ u + u <@> clP builtinIOne <..> clP builtinItIsOne + DoTransp -> + -- Otherwise we're in the constant part of the line to transport + -- over, so we must return the argument unchanged. + pure $ unArg u0 + + _ -> do + let + fallback' sc = do + -- Possibly optimise the partial element to reduce the size of + -- hcomps: + u' <- case cmd of + DoHComp -> (:[]) <$> case vphi of + -- If φ=i0 then tabulating equality for Partial φ A + -- guarantees that u = is constantly isOneEmpty, + -- regardless of how big the original term is, and + -- isOneEmpty is *tiny*, so let's use that: + IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do + [l,c] <- mapM (open . unArg) [famThing l, ignoreBlocking sc] + lam "i" $ \ i -> clP builtinIsOneEmpty <#> l <#> ilam "o" (\ _ -> c) + + -- Otherwise we have some interesting formula (though + -- definitely not IOne!) and we have to keep the partial + -- element as-is. + _ -> pure $ notReduced $ fromMaybe __IMPOSSIBLE__ u + DoTransp -> return [] + + pure . NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0] + + -- Reduce the type whose Kan operations we're composing over: + sbA <- reduceB' bA + t <- case unArg <$> ignoreBlocking sbA of + IsFam (Lam _ t) -> Just . fmap IsFam <$> reduceB' (absBody t) + IsFam _ -> pure Nothing + IsNot t -> pure . Just . fmap IsNot $ (t <$ sbA) + + case t of + -- If we don't have a grasp of the Kan operations then at least we + -- can reuse the work we did for reducing the type later. + Nothing -> fallback' (famThing <$> sbA) + Just st -> do + -- Similarly, if we're stuck for another reason, we can reuse + -- the work for reducing the family. + let + fallback = fallback' (fmap famThing $ st *> sbA) + t = ignoreBlocking st + operation = case cmd of + DoTransp -> TranspOp { kanOpCofib = sphi, kanOpBase = u0 } + DoHComp -> HCompOp + { kanOpCofib = sphi, kanOpSides = fromMaybe __IMPOSSIBLE__ u, kanOpBase = u0 } + + mHComp <- getPrimitiveName' builtinHComp + mGlue <- getPrimitiveName' builtinGlue + mId <- getBuiltinName' builtinId + pathV <- pathView' + + -- By cases on the family, determine what Kan operation we defer + -- to: + case famThing t of + -- Metavariables are stuck + MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA) + + -- TODO: absName t instead of "i" + Pi a b + -- For Π types, we prefer to keep the Kan operations around, + -- so only actually reduce if we applied them to a nonzero + -- positive of eliminations + | nelims > 0 -> maybe fallback redReturn =<< doPiKanOp operation "i" ((a, b) <$ t) + | otherwise -> fallback + + -- For Type, we have two possibilities: + Sort (Type l) + -- transp (λ i → Type _) φ is always the identity function. + | DoTransp <- cmd -> redReturn $ unArg u0 + -- hcomp {Type} is actually a normal form! This is the + -- "HCompU" optimisation; We do not use Glue for hcomp in + -- the universe. + | DoHComp <- cmd -> fallback + + -- Glue types have their own implementation of Kan operations + -- which are implemented in a different module: + Def q [Apply la, Apply lb, Apply bA, Apply phi', Apply bT, Apply e] | Just q == mGlue -> do + maybe fallback redReturn =<< doGlueKanOp + operation ((la, lb, bA, phi', bT, e) <$ t) Head + + -- Formal homogeneous compositions in the universe: Our family + -- is @hcomp {A = Type l}@, so we defer to the implementation + -- of Kan operations for HCompU implemented above. + Def q [Apply _, Apply s, Apply phi', Apply bT, Apply bA] + | Just q == mHComp, Sort (Type la) <- unArg s -> do + maybe fallback redReturn =<< doHCompUKanOp + operation ((Level la <$ s, phi', bT, bA) <$ t) Head + + -- PathP types have the same optimisation as for Pi types: + -- Only compute the Kan operation if there's >0 eliminations. + d | PathType _ _ _ bA x y <- pathV (El __DUMMY_SORT__ d) -> do + if nelims > 0 then doPathPKanOp operation l ((bA, x, y) <$ t) else fallback + + -- Identity types: + Def q [Apply _ , Apply bA , Apply x , Apply y] | Just q == mId -> do + maybe fallback return =<< doIdKanOp operation l ((bA, x, y) <$ t) + + Def q es -> do + info <- getConstInfo q + let lam_i = Lam defaultArgInfo . Abs "i" + + -- Record and data types have their own implementations of + -- the Kan operations, which get generated as part of their + -- definition. + case theDef info of + r@Record{recComp = kit} + | nelims > 0, Just as <- allApplyElims es, DoTransp <- cmd, Just transpR <- nameOfTransp kit -> + -- Optimisation: If the record has no parameters then we can ditch the transport. + if recPars r == 0 + then redReturn $ unArg u0 + else redReturn $ Def transpR [] `apply` (map (fmap lam_i) as ++ [ignoreBlocking sphi, u0]) + + -- Records know how to hcomp themselves: + | nelims > 0, Just as <- allApplyElims es, DoHComp <- cmd, Just hCompR <- nameOfHComp kit -> + redReturn $ Def hCompR [] `apply` (as ++ [ignoreBlocking sphi, fromMaybe __IMPOSSIBLE__ u,u0]) + + -- If this is a record with no fields, then compData + -- will know what to do with it: + | Just as <- allApplyElims es, [] <- recFields r -> compData Nothing False (recPars r) cmd l (as <$ t) sbA sphi u u0 + + -- For data types, if this data type is indexed and/or a + -- higher inductive type, then hcomp is normal; But + -- compData knows what to do for the general cases. + Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons, dataTransp = mtrD} + | and [null pcons && ixs == 0 | DoHComp <- [cmd]], Just as <- allApplyElims es -> + compData mtrD ((not $ null $ pcons) || ixs > 0) (pars+ixs) cmd l (as <$ t) sbA sphi u u0 + + -- Is this an axiom with constrant transport? Then. Well. Transport is constant. + Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0 + + _ -> fallback + + _ -> fallback + where + allComponentsBack unview phi u p = do + let + boolToI b = if b then unview IOne else unview IZero + lamlam t = Lam defaultArgInfo (Abs "i" (Lam (setRelevance Irrelevant defaultArgInfo) (Abs "o" t))) + as <- decomposeInterval phi + (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do + let u' = listS bs' `applySubst` u + bs' = IntMap.toAscList $ IntMap.map boolToI bs + -- Γ₁, i : I, Γ₂, j : I, Γ₃ ⊢ weaken : Γ₁, Γ₂, Γ₃ for bs' = [(j,_),(i,_)] + -- ordering of "j,i,.." matters. + let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs') + t <- reduce2Lam u' + return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ]) + return $ (flags,t_alphas) + compData mtrD False _ cmd@DoHComp (IsNot l) (IsNot ps) fsc sphi (Just u) a0 = do + let getTermLocal = getTerm $ "builtinHComp for data types" + + let sc = famThing <$> fsc + tEmpty <- getTermLocal builtinIsOneEmpty + tPOr <- getTermLocal builtinPOr + iO <- getTermLocal builtinIOne + iZ <- getTermLocal builtinIZero + tMin <- getTermLocal builtinIMin + tNeg <- getTermLocal builtinINeg + let iNeg t = tNeg `apply` [argN t] + iMin t u = tMin `apply` [argN t, argN u] + iz = pure iZ + constrForm <- do + mz <- getTerm' builtinZero + ms <- getTerm' builtinSuc + return $ \ t -> fromMaybe t (constructorForm' mz ms t) + su <- reduceB' u + sa0 <- reduceB' a0 + view <- intervalView' + unview <- intervalUnview' + let f = unArg . ignoreBlocking + phi = f sphi + a0 = f sa0 + isLit t@(Lit lt) = Just t + isLit _ = Nothing + isCon (Con h _ _) = Just h + isCon _ = Nothing + combine l ty d [] = d + combine l ty d [(psi,u)] = u + combine l ty d ((psi,u):xs) + = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs + <#> ilam "o" (\ _ -> ty) -- the type + <@> u <@> (combine l ty d xs) + noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0] + where + su' = case view phi of + IZero -> notBlocked $ argN $ runNames [] $ do + [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc] + lam "i" $ \ i -> pure tEmpty <#> l + <#> ilam "o" (\ _ -> c) + _ -> su + sameConHeadBack Nothing Nothing su k = noRed' su + sameConHeadBack lt h su k = do + let u = unArg . ignoreBlocking $ su + (b, ts) <- allComponentsBack unview phi u $ \ t -> + (isLit t == lt, isCon (constrForm t) == h) + let + (lit,hd) = unzip b + + if isJust lt && and lit then redReturn a0 else do + su <- caseMaybe (sequence ts) (return su) $ \ ts -> do + let (us,bools) = unzip ts + fmap ((sequenceA_ us $>) . argN) $ do + let + phis :: [Term] + phis = for bools $ \ m -> + foldr (iMin . (\(i,b) -> applyUnless b iNeg $ var i)) iO (IntMap.toList m) + runNamesT [] $ do + u <- open u + [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc] + phis <- mapM open phis + us <- mapM (open . ignoreBlocking) us + lam "i" $ \ i -> do + combine l c (u <@> i) $ zip phis (map (\ t -> t <@> i) us) + + if isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su + else noRed' su + + sameConHeadBack (isLit a0) (isCon a0) su $ \ h su -> do + let u = unArg . ignoreBlocking $ su + Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h) + case nameOfHComp cm of + Just hcompD -> redReturn $ Def hcompD [] `apply` + (ps ++ map argN [phi,u,a0]) + Nothing -> noRed' su + + compData mtrD _ 0 DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = redReturn $ unArg a0 + compData (Just trD) isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do + let sc = famThing <$> fsc + let f = unArg . ignoreBlocking + phi :: Term + phi = f $ sphi + let lam_i = Lam defaultArgInfo . Abs "i" + redReturn $ Def trD [] `apply` (map (fmap lam_i) ps ++ map argN [phi,unArg a0]) + + compData mtrD isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do + let getTermLocal = getTerm $ builtinTrans ++ " for data types" + let sc = famThing <$> fsc + mhcompName <- getName' builtinHComp + constrForm <- do + mz <- getTerm' builtinZero + ms <- getTerm' builtinSuc + return $ \ t -> fromMaybe t (constructorForm' mz ms t) + sa0 <- reduceB' a0 + let f = unArg . ignoreBlocking + phi = f sphi + a0 = f sa0 + noRed = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced sa0] + let lam_i = Lam defaultArgInfo . Abs "i" + case constrForm a0 of + Con h _ args -> do + Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h) + case nameOfTransp cm of + Just transpD -> redReturn $ Def transpD [] `apply` + (map (fmap lam_i) ps ++ map argN [phi,a0]) + Nothing -> noRed + Def q es | isHIT, Just q == mhcompName, Just [_l0,_c0,psi,u,u0] <- allApplyElims es -> do + let bC = ignoreBlocking sc + hcomp <- getTermLocal builtinHComp + transp <- getTermLocal builtinTrans + io <- getTermLocal builtinIOne + iz <- getTermLocal builtinIZero + redReturn <=< runNamesT [] $ do + [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0] + -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0) + pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi + <@> lam "j" (\ j -> ilam "o" $ \ o -> + pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o)) + <@> (pure transp <#> l <@> bC <@> phi <@> u0) + _ -> noRed + compData mtrX isHITorIx nargs cmd l t sbA sphi u u0 = do + () <- reportSDoc "impossible" 10 $ "compData" <+> (nest 2 . vcat) + [ "mtrX: " <+> pretty mtrX + , "isHITorIx: " <+> pretty isHITorIx + , "nargs: " <+> pretty nargs + , "cmd: " <+> text (show cmd) + , "l: " <+> familyOrNot l + , "t: " <+> familyOrNot t <+> pretty (famThing t) + , "sbA: " <+> familyOrNot (ignoreBlocking $ sbA) + , "sphi: " <+> pretty (ignoreBlocking sphi) + , "isJust u: " <+> pretty (isJust u) + , "u0: " <+> pretty u0 + ] + __IMPOSSIBLE__ + +-- compData _ _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__ + +-- | CCHM 'primComp' is implemented in terms of 'hcomp' and 'transport'. +-- The definition of it comes from 'mkComp'. +primComp :: TCM PrimitiveImpl +primComp = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a -> + nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA -> + hPi' "φ" primIntervalType $ \ phi -> + nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) --> + (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne)) + one <- primItIsOne + io <- primIOne + return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do + case ts of + [l,c,phi,u,a0] -> do + sphi <- reduceB' phi + vphi <- intervalView $ unArg $ ignoreBlocking sphi + case vphi of + -- Though we short-circuit evaluation for the rule + -- comp A i1 (λ _ .1=1 → u) u ==> u + -- rather than going through the motions of hcomp and transp. + IOne -> redReturn (unArg u `apply` [argN io, argN one]) + _ -> do + redReturnNoSimpl <=< runNamesT [] $ do + comp <- mkComp builtinComp + [l,c,phi,u,a0] <- mapM (open . unArg) [l,c,phi,u,a0] + comp l c phi u a0 + + _ -> __IMPOSSIBLE__ + + +-- TODO Andrea: keep reductions that happen under foralls? +primFaceForall' :: TCM PrimitiveImpl +primFaceForall' = do + requireCubical CErased "" + t <- (primIntervalType --> primIntervalType) --> primIntervalType + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case + [phi] -> do + sphi <- reduceB' phi + case unArg $ ignoreBlocking $ sphi of + Lam _ t -> do + t <- reduce' t + case t of + NoAbs _ t -> redReturn t + Abs _ t -> + maybe (return $ NoReduction [reduced sphi]) redReturn + =<< toFaceMapsPrim t + _ -> return (NoReduction [reduced sphi]) + _ -> __IMPOSSIBLE__ + where + toFaceMapsPrim t = do + view <- intervalView' + unview <- intervalUnview' + us' <- decomposeInterval t + fr <- getTerm builtinFaceForall builtinFaceForall + let + v = view t + -- We decomposed the interval expression, without regard for + -- inconsistent mappings, and now we keep only those which are + -- stuck (the ts) and those which do not mention the 0th variable. + us :: [[Either (Int, Bool) Term]] + us = [ map Left (IntMap.toList bsm) ++ map Right ts + | (bsm, ts) <- us', 0 `IntMap.notMember` bsm + ] + + -- Turn a face mapping back into an interval expression: + fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1))) + -- Apply ∀ to any indecomposable expressions we have encountered + ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t] + + -- Unfold one step of the foldr to avoid generation of the last + -- ∧ i1. Marginal savings at best but it's cleaner. + conjuncts :: [Either (Int, Bool) Term] -> Term + conjuncts [] = unview IOne + conjuncts [x] = either fm ffr x + conjuncts (x:xs) = + foldr (\x r -> unview (IMin (argN (either fm ffr x)) (argN r))) + (either fm ffr x) + xs + + disjuncts = foldr + (\conj rest -> unview (IMax (argN (conjuncts conj)) (argN rest))) + (unview IZero) + us + -- traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $ + return $ case us' of + [(m, [_])] | null m -> Nothing + _ -> Just disjuncts + +-- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types. +-- If a type in the telescope does not support transp, @transpTel@ throws it as an exception. +transpTel :: Abs Telescope -- Γ ⊢ i.Δ + -> Term -- Γ ⊢ φ : F -- i.Δ const on φ + -> Args -- Γ ⊢ δ : Δ[0] + -> ExceptT (Closure (Abs Type)) TCM Args -- Γ ⊢ Δ[1] +transpTel = transpTel' False + + +transpTel' :: (PureTCM m, MonadError TCErr m) => + Bool -> Abs Telescope -- Γ ⊢ i.Δ + -> Term -- Γ ⊢ φ : F -- i.Δ const on φ + -> Args -- Γ ⊢ δ : Δ[0] + -> ExceptT (Closure (Abs Type)) m Args -- Γ ⊢ Δ[1] +transpTel' flag delta phi args = transpSysTel' flag delta [] phi args + +type LM m a = NamesT (ExceptT (Closure (Abs Type)) m) a +-- transporting with an extra system/partial element +-- or composing when some of the system is known to be constant. +transpSysTel' :: forall m. (PureTCM m, MonadError TCErr m) => + Bool + -> Abs Telescope -- Γ ⊢ i.Δ + -> [(Term,Abs [Term])] -- [(ψ,i.δ)] with Γ,ψ ⊢ i.δ : [i : I]. Δ[i] -- the proof of [ψ] is not in scope. + -> Term -- Γ ⊢ φ : F -- i.Δ const on φ and all i.δ const on φ ∧ ψ + -> Args -- Γ ⊢ δ : Δ[0] + -> ExceptT (Closure (Abs Type)) m Args -- Γ ⊢ Δ[1] +transpSysTel' flag delta us phi args = do + reportSDoc "cubical.prim.transpTel" 20 $ + sep [ text "transpSysTel'" + , (text "delta =" <+>) $ nest 2 $ addContext ("i" :: String, __DUMMY_DOM__) $ prettyTCM (unAbs delta) +-- , (text "us =" <+>) $ nest 2 $ prettyList $ map prettyTCM us + , (text "phi =" <+>) $ nest 2 $ prettyTCM phi + , (text "args =" <+>) $ nest 2 $ prettyList $ map prettyTCM args + ] + let getTermLocal = getTerm "transpSys" + tTransp <- lift primTrans + tComp <- getTermLocal builtinComp + tPOr <- getTermLocal builtinPOr + iz <- lift primIZero + imin <- lift primIMin + imax <- lift primIMax + ineg <- lift primINeg + let + noTranspError t = do + reportSDoc "cubical.prim.transpTel" 20 $ nest 2 $ (text "error type =" <+>) $ + addContext ("i" :: String, __DUMMY_DOM__) $ prettyTCM $ unAbs t + lift . throwError =<< buildClosure t + bapp :: forall m a. (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a + bapp t u = lazyAbsApp <$> t <*> u + doGTransp l t us phi a | null us = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a + | otherwise = pure tComp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <#> face <@> uphi <@> a + where + -- [phi -> a; us] + face = foldr (\ x y -> pure imax <@> x <@> y) (pure iz) (phi : map fst us) + uphi = lam "i" $ \ i -> ilam "o" $ \ o -> do + let sys' = (phi , a) : map (mapSnd (`bapp` i)) us + sys = map (mapSnd $ ilam "o" . const) sys' + combine (l <@> i) (unEl <$> bapp t i) __IMPOSSIBLE__ sys <..> o + combine l ty d [] = d + combine l ty d [(psi,u)] = u + combine l ty d ((psi,u):xs) + = pure tPOr <#> l <@> psi <@> (foldr (\ x y -> pure imax <@> x <@> y) (pure iz) (map fst xs)) + <#> (ilam "o" $ \ _ -> ty) -- the type + <@> u <@> (combine l ty d xs) + + gTransp :: Maybe (LM m Term) -> LM m (Abs Type) -> [(LM m Term,LM m (Abs Term))] -> LM m Term -> LM m Term -> LM m Term + gTransp (Just l) t u phi a + | flag = do + t' <- t + us' <- mapM snd u + case ( 0 `freeIn` (raise 1 t' `lazyAbsApp` var 0) + , 0 `freeIn` map (\ u -> raise 1 u `lazyAbsApp` var 0) us' + ) of + (False,False) -> a + (False,True) -> doGTransp l t u phi a -- TODO? optimize to "hcomp (l <@> io) (bapp t io) ((phi,NoAbs a):u) a" ? + (True,_) -> doGTransp l t u phi a + | otherwise = doGTransp l t u phi a + + gTransp Nothing t sys phi a = do + let (psis,us) = unzip sys + -- Γ ⊢ i.Ξ + xi <- (open =<<) $ do + bind "i" $ \ i -> do + TelV xi _ <- (lift . telView =<<) $ t `bapp` i + return xi + argnames <- do + teleArgNames . unAbs <$> xi + glamN argnames $ \ xi_args -> do + b' <- bind "i" $ \ i -> do + ti <- t `bapp` i + xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i) + xi_args <- xi_args + ni <- pure ineg <@> i + phi <- phi + lift $ piApplyM ti =<< trFillTel' flag xin phi xi_args ni + usxi <- forM us $ \ u -> bind "i" $ \ i -> do + ui <- u `bapp` i + xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i) + xi_args <- xi_args + ni <- pure ineg <@> i + phi <- phi + lift $ apply ui <$> trFillTel' flag xin phi xi_args ni + axi <- do + a <- a + xif <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i) + phi <- phi + xi_args <- xi_args + lift $ apply a <$> transpTel' flag xif phi xi_args + s <- reduce $ getSort (absBody b') + reportSDoc "cubical.transp" 20 $ pretty (raise 1 b' `lazyAbsApp` var 0) + let noTranspSort = if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) || 0 `freeIn` (map (`lazyAbsApp` var 0) (raise 1 usxi)) + then noTranspError b' + else return axi + + case s of + Type l -> do + l <- open $ lam_i (Level l) + b' <- open b' + axi <- open axi + usxi <- mapM open usxi + gTransp (Just l) b' (zip psis usxi) phi axi + Inf _ n -> noTranspSort + SSet _ -> noTranspSort + SizeUniv -> noTranspSort + LockUniv -> noTranspSort + IntervalUniv -> noTranspSort + Prop{} -> noTranspSort + _ -> noTranspError b' + lam_i = Lam defaultArgInfo . Abs "i" + go :: Telescope -> [[(Term,Term)]] -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args + go EmptyTel [] _ [] = return [] + go (ExtendTel t delta) (u:us) phi (a:args) = do + -- Γ,i ⊢ t + -- Γ,i ⊢ (x : t). delta + -- Γ ⊢ a : t[0] + s <- reduce $ getSort t + -- Γ ⊢ b : t[1] Γ, i ⊢ bf : t[i] + (b,bf) <- runNamesT [] $ do + l <- case s of + SSet _ -> return Nothing + IntervalUniv -> return Nothing + SizeUniv -> return Nothing + LockUniv -> return Nothing + Inf _ n -> return Nothing + Type l -> Just <$> open (lam_i (Level l)) + _ -> noTranspError (Abs "i" (unDom t)) + t <- open $ Abs "i" (unDom t) + u <- forM u $ \ (psi,upsi) -> do + (,) <$> open psi <*> open (Abs "i" upsi) + [phi,a] <- mapM open [phi, unArg a] + b <- gTransp l t u phi a + bf <- bind "i" $ \ i -> do + gTransp ((<$> l) $ \ l -> lam "j" $ \ j -> l <@> (pure imin <@> i <@> j)) + (bind "j" $ \ j -> t `bapp` (pure imin <@> i <@> j)) + u + (pure imax <@> (pure ineg <@> i) <@> phi) + a + return (b, absBody bf) + (:) (b <$ a) <$> go (lazyAbsApp delta bf) us phi args + go EmptyTel _ _ _ = __IMPOSSIBLE__ + go (ExtendTel t delta) _ _ _ = __IMPOSSIBLE__ + let (psis,uss) = unzip us + us' | null us = replicate (length args) [] + | otherwise = map (zip psis) $ List.transpose (map absBody uss) + go (absBody delta) us' phi args + +-- | Like @transpTel@ but performing a transpFill. +trFillTel :: Abs Telescope -- Γ ⊢ i.Δ + -> Term + -> Args -- Γ ⊢ δ : Δ[0] + -> Term -- Γ ⊢ r : I + -> ExceptT (Closure (Abs Type)) TCM Args -- Γ ⊢ Δ[r] +trFillTel = trFillTel' False + +trFillTel' :: (PureTCM m, MonadError TCErr m) => + Bool + -> Abs Telescope -- Γ ⊢ i.Δ + -> Term + -> Args -- Γ ⊢ δ : Δ[0] + -> Term -- Γ ⊢ r : I + -> ExceptT (Closure (Abs Type)) m Args -- Γ ⊢ Δ[r] +trFillTel' flag delta phi args r = do + imin <- lift primIMin + imax <- lift primIMax + ineg <- lift primINeg + transpTel' flag (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r]))) + (imax `apply` [argN $ ineg `apply` [argN r], argN phi]) + args + + + +-- hcompTel' :: Bool -> Telescope -> [(Term,Abs [Term])] -> [Term] -> ExceptT (Closure (Abs Type)) TCM [Term] +-- hcompTel' b delta sides base = undefined + +-- hFillTel' :: Bool -> Telescope -- Γ ⊢ Δ +-- -> [(Term,Abs [Term])] -- [(φ,i.δ)] with Γ,φ ⊢ i.δ : I → Δ +-- -> [Term] -- Γ ⊢ δ0 : Δ, matching the [(φ,i.δ)] +-- -> Term -- Γ ⊢ r : I +-- -> ExceptT (Closure (Abs Type)) TCM [Term] +-- hFillTel' b delta sides base = undefined + +pathTelescope + :: forall m. (PureTCM m, MonadError TCErr m) => + Telescope -- Δ + -> [Arg Term] -- lhs : Δ + -> [Arg Term] -- rhs : Δ + -> m Telescope +pathTelescope tel lhs rhs = do + x <- runExceptT (pathTelescope' tel lhs rhs) + case x of + Left t -> do + enterClosure t $ \ t -> + typeError . GenericDocError =<< + (text "The sort of" <+> pretty t <+> text "should be of the form \"Set l\"") + Right tel -> return tel + +pathTelescope' + :: forall m. (PureTCM m, MonadError (Closure Type) m) => + Telescope -- Δ + -> [Arg Term] -- lhs : Δ + -> [Arg Term] -- rhs : Δ + -> m Telescope +pathTelescope' tel lhs rhs = do + pathp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPathP + go pathp (raise 1 tel) lhs rhs + where + -- Γ,i ⊢ Δ, Γ ⊢ lhs : Δ[0], Γ ⊢ rhs : Δ[1] + go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope + go pathp (ExtendTel a tel) (u : lhs) (v : rhs) = do + let t = unDom a + l <- subst 0 __DUMMY_TERM__ <$> getLevel t + let a' = El (Type l) (apply pathp $ [argH $ Level l] ++ map argN [Lam defaultArgInfo (Abs "i" $ unEl t), unArg u, unArg v]) + -- Γ,eq : u ≡ v, i : I ⊢ m = eq i : t[i] + -- m = runNames [] $ do + -- [u,v] <- mapM (open . unArg) [u,v] + -- bind "eq" $ \ eq -> bind "i" $ \ i -> + (ExtendTel (a' <$ a) <$>) . runNamesT [] $ do + let nm = (absName tel) + tel <- open $ Abs "i" tel + [u,v] <- mapM (open . unArg) [u,v] + [lhs,rhs] <- mapM open [lhs,rhs] + bind nm $ \ eq -> do + lhs <- lhs + rhs <- rhs + tel' <- bind "i" $ \ i -> + lazyAbsApp <$> (lazyAbsApp <$> tel <*> i) <*> (eq <@@> (u, v, i)) + lift $ go pathp (absBody tel') lhs rhs + go _ EmptyTel [] [] = return EmptyTel + go _ _ _ _ = __IMPOSSIBLE__ + getLevel :: Type -> m Level + getLevel t = do + s <- reduce $ getSort t + case s of + Type l -> pure l + s -> throwError =<< buildClosure t + +data TranspError = CannotTransp {errorType :: (Closure (Abs Type)) } + +instance Exception TranspError +instance Show TranspError where + show _ = "TranspError" + +tryTranspError :: TCM a -> TCM (Either (Closure (Abs Type)) a) +tryTranspError (TCM m) = TCM $ \ s env -> do + mapLeft errorType <$> (try (m s env)) + +transpPathPTel' :: + NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ const on φ + -> [NamesT TCM Term] -- ^ x : (i : I) → Δ[0,i] const on φ + -> [NamesT TCM Term] -- ^ y : (i : I) → Δ[1,i] const on φ + -> NamesT TCM Term -- ^ φ + -> [NamesT TCM Term] -- ^ p : PathP (λ j → Δ[j,0]) (x 0) (y 0) + -> NamesT TCM [Arg Term] -- PathP (λ j → Δ[j,0]) (x 1) (y 1) [ φ ↦ q ] +transpPathPTel' theTel x y phi p = do + let neg j = cl primINeg <@> j + -- is the open overkill? + qs <- (open =<<) $ fmap (fmap (\ (Abs n (Arg i t)) -> Arg i (Lam defaultArgInfo $ Abs n t)) . sequenceA) + $ bind "j" $ \ j -> do + theTel <- absApp <$> theTel <*> j + faces <- sequence [neg j, j] + us <- forM [x,y] $ \ z -> do + bind "i" $ \ i -> forM z (<@> i) + let sys = zip faces us + -- [(neg j, bind "i" $ \ i -> flip map x (<@> i)) + -- ,(j , bind "i" $ \ i -> flip map y (<@> i))] + phi <- phi + p0 <- mapM (<@> j) p + let toArgs = zipWith (\ a t -> t <$ a) (teleArgNames (unAbs $ theTel)) + eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0) + either (lift . lift . throw . CannotTransp) pure eq + qs + +transpPathTel' :: + NamesT TCM (Abs Telescope) -- ^ i.Δ const on φ + -> [NamesT TCM Term] -- ^ x : (i : I) → Δ[i] const on φ + -> [NamesT TCM Term] -- ^ y : (i : I) → Δ[i] const on φ + -> NamesT TCM Term -- ^ φ + -> [NamesT TCM Term] -- ^ p : Path (Δ[0]) (x 0) (y 0) + -> NamesT TCM [Arg Term] -- Path (Δ[1]) (x 1) (y 1) [ φ ↦ q ] +transpPathTel' theTel x y phi p = do + let neg j = cl primINeg <@> j + -- is the open overkill? + qs <- (open =<<) $ fmap (fmap (\ (Abs n (Arg i t)) -> Arg i (Lam defaultArgInfo $ Abs n t)) . sequenceA) + $ bind "j" $ \ j -> do + theTel <- theTel + faces <- sequence $ [neg j, j] + us <- forM [x,y] $ \ z -> do + bind "i" $ \ i -> forM z (<@> i) + let sys = zip faces us + -- [(neg j, bind "i" $ \ i -> flip map x (<@> i)) + -- ,(j , bind "i" $ \ i -> flip map y (<@> i))] + phi <- phi + p0 <- mapM (<@> j) p + let toArgs = zipWith (\ a t -> t <$ a) (teleArgNames (unAbs theTel)) + eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0) + either (lift . lift . throw . CannotTransp) pure eq + qs + +trFillPathTel' :: + NamesT TCM (Abs Telescope) -- ^ i.Δ const on φ + -> [NamesT TCM Term] -- ^ x : (i : I) → Δ[i] const on φ + -> [NamesT TCM Term] -- ^ y : (i : I) → Δ[i] const on φ + -> NamesT TCM Term -- ^ φ + -> [NamesT TCM Term] -- ^ p : Path (Δ[0]) (x 0) (y 0) + -> NamesT TCM Term -- ^ r + -> NamesT TCM [Arg Term] -- Path (Δ[r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ] +trFillPathTel' tel x y phi p r = do + let max i j = cl primIMin <@> i <@> j + let min i j = cl primIMin <@> i <@> j + let neg i = cl primINeg <@> i + x' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM x (<@> (min r i)) + y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM y (<@> (min r i)) + transpPathTel' (bind "i" $ \ i -> absApp <$> tel <*> min r i) + x' + y' + (max phi (neg r)) + p + +trFillPathPTel' :: + NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ const on φ + -> [NamesT TCM Term] -- ^ x : (i : I) → Δ[0,i] const on φ + -> [NamesT TCM Term] -- ^ y : (i : I) → Δ[1,i] const on φ + -> NamesT TCM Term -- ^ φ + -> [NamesT TCM Term] -- ^ p : Path (\ j -> Δ[j,0]) (x 0) (y 0) + -> NamesT TCM Term -- ^ r + -> NamesT TCM [Arg Term] -- Path (\ j → Δ[j,r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ] +trFillPathPTel' tel x y phi p r = do + let max i j = cl primIMin <@> i <@> j + let min i j = cl primIMin <@> i <@> j + let neg i = cl primINeg <@> i + x' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM x (<@> (min r i)) + y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM y (<@> (min r i)) + transpPathPTel' (bind "j" $ \ j -> bind "i" $ \ i -> absApp <$> (absApp <$> tel <*> j) <*> min r i) + x' + y' + (max phi (neg r)) + p + + + +-- given Γ ⊢ I type, and Γ ⊢ Δ telescope, build Δ^I such that +-- Γ ⊢ (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...) +expTelescope :: Type -> Telescope -> Telescope +expTelescope int tel = unflattenTel names ys + where + stel = size tel + xs = flattenTel tel + names = teleNames tel + t = ExtendTel (defaultDom $ raise stel int) (Abs "i" EmptyTel) + s = expS stel + ys = map (fmap (abstract t) . applySubst s) xs + + +-- | Γ, Δ^I, i : I |- expS |Δ| : Γ, Δ +expS :: Nat -> Substitution +expS stel = prependS __IMPOSSIBLE__ + [ Just (var n `apply` [Arg defaultArgInfo $ var 0]) | n <- [1..stel] ] + (raiseS (stel + 1)) + + +-- * Special cases of Type +----------------------------------------------------------- + +-- | A @Type@ with sort @Type l@ +-- Such a type supports both hcomp and transp. +data LType = LEl Level Term deriving (Eq,Show) + +fromLType :: LType -> Type +fromLType (LEl l t) = El (Type l) t + +lTypeLevel :: LType -> Level +lTypeLevel (LEl l t) = l + +toLType :: MonadReduce m => Type -> m (Maybe LType) +toLType ty = do + sort <- reduce $ getSort ty + case sort of + Type l -> return $ Just $ LEl l (unEl ty) + _ -> return $ Nothing + +instance Subst LType where + type SubstArg LType = Term + applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t) + +-- | A @Type@ that either has sort @Type l@ or is a closed definition. +-- Such a type supports some version of transp. +-- In particular we want to allow the Interval as a @ClosedType@. +data CType = ClosedType Sort QName | LType LType deriving (Eq,Show) + +instance P.Pretty CType where + pretty = P.pretty . fromCType + +fromCType :: CType -> Type +fromCType (ClosedType s q) = El s (Def q []) +fromCType (LType t) = fromLType t + +toCType :: MonadReduce m => Type -> m (Maybe CType) +toCType ty = do + sort <- reduce $ getSort ty + case sort of + Type l -> return $ Just $ LType (LEl l (unEl ty)) + SSet{} -> do + t <- reduce (unEl ty) + case t of + Def q [] -> return $ Just $ ClosedType sort q + _ -> return $ Nothing + _ -> return $ Nothing + +instance Subst CType where + type SubstArg CType = Term + applySubst rho (ClosedType s q) = ClosedType (applySubst rho s) q + applySubst rho (LType t) = LType $ applySubst rho t + +hcomp + :: (HasBuiltins m, MonadError TCErr m, MonadReduce m, MonadPretty m) + => NamesT m Type + -> [(NamesT m Term, NamesT m Term)] + -> NamesT m Term + -> NamesT m Term +hcomp ty sys u0 = do + iz <- primIZero + tHComp <- primHComp + let max i j = cl primIMax <@> i <@> j + ty <- ty + (l, ty) <- toLType ty >>= \case + Just (LEl l ty) -> return (l, ty) + Nothing -> lift $ do -- TODO: support Setω properly + typeError . GenericDocError =<< sep + [ text "Cubical Agda: cannot generate hcomp clauses at type", prettyTCM ty ] + l <- open $ Level l + ty <- open $ ty + face <- (foldr max (pure iz) $ map fst $ sys) + sys <- lam "i'" $ \ i -> combineSys l ty [(phi, u <@> i) | (phi,u) <- sys] + pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0 + +transpSys :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) => + NamesT m (Abs Type) -- ty + -> [(NamesT m Term, NamesT m Term)] -- sys + -> NamesT m Term -- φ + -> NamesT m Term + -> NamesT m Term +transpSys ty sys phi u = do + let max i j = cl primIMax <@> i <@> j + iz <- primIZero + tTransp <- primTrans + tComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp + l_ty <- bind "i" $ \ i -> do + ty <- absApp <$> ty <*> i + toLType ty >>= \case + Just (LEl l ty) -> return (l,ty) + Nothing -> return (__DUMMY_LEVEL__, unEl ty) -- TODO: properly support Setω + l <- open $ Lam defaultArgInfo . fmap (Level . fst) $ l_ty + ty <- open $ Lam defaultArgInfo . fmap snd $ l_ty + + if null sys then pure tTransp <#> l <@> ty <@> phi <@> u else do + + let face = max phi (foldr max (pure iz) $ map fst $ sys) + sys <- (open =<<) $ lam "i'" $ \ i -> do + let base = (phi, ilam "o" $ \ _ -> u) + combineSys l ty $ base : [(phi, u <@> i) | (phi,u) <- sys] + + pure tComp <#> l <@> ty <#> face <@> sys <@> u + +debugClause :: String -> Clause -> TCM () +debugClause s c = do + reportSDoc s 20 $ + "gamma:" <+> prettyTCM gamma + reportSDoc s 20 $ addContext gamma $ + "ps :" <+> prettyTCM (patternsToElims ps) + reportSDoc s 20 $ addContext gamma $ + "type :" <+> maybe "nothing" prettyTCM rhsTy + reportSDoc s 20 $ addContext gamma $ + "body :" <+> maybe "nothing" prettyTCM rhs + + reportSDoc s 30 $ + addContext gamma $ "c:" <+> pretty c + where + gamma = clauseTel c + ps = namedClausePats c + rhsTy = clauseType c + rhs = clauseBody c diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs b/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs @@ -0,0 +1,438 @@ +-- | Implementations of the basic primitives of Cubical Agda: The +-- interval and its operations. +module Agda.TypeChecking.Primitive.Cubical.Base + ( requireCubical + , primIntervalType + , primIMin', primIMax', primDepIMin', primINeg' + , imax, imin, ineg + + , Command(..), KanOperation(..), kanOpName, TermPosition(..), headStop + , FamilyOrNot(..), familyOrNot + + -- * Helper functions for building terms + , combineSys, combineSys' + , fiber, hfill + , decomposeInterval', decomposeInterval + , reduce2Lam + , isCubicalSubtype + ) + where + +import Control.Monad ( msum, mzero ) +import Control.Monad.Except ( MonadError ) + +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import Data.String (IsString (fromString)) +import Data.Bifunctor (second) +import Data.Either (partitionEithers) +import Data.Maybe (fromMaybe, maybeToList) + +import qualified Agda.Utils.BoolSet as BoolSet +import Agda.Utils.Impossible (__IMPOSSIBLE__) +import Agda.Utils.BoolSet (BoolSet) +import Agda.Utils.Functor + +import Agda.TypeChecking.Monad.Signature (HasConstInfo) +import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__) +import Agda.TypeChecking.Monad.Builtin +import Agda.TypeChecking.Monad.Context +import Agda.TypeChecking.Monad.Pure +import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Env + +import Agda.TypeChecking.Substitute.Class (absBody, raise, apply) + +import Agda.TypeChecking.Reduce (Reduce(..), reduceB', reduce', reduce) +import Agda.TypeChecking.Names (NamesT, runNamesT, ilam, lam) + +import Agda.Interaction.Options.Base (optCubical) + +import Agda.Syntax.Common + (Cubical(..), Arg(..), Relevance(..), setRelevance, defaultArgInfo, hasQuantity0) + +import Agda.TypeChecking.Primitive.Base + (SigmaKit(..), (-->), el', nPi', pPi', (<@>), (<#>), (<..>), argN, getSigmaKit) + +import Agda.Syntax.Internal + + +-- | Checks that the correct variant of Cubical Agda is activated. +-- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased +-- contexts. +requireCubical + :: Cubical -- ^ Which variant of Cubical Agda is required? + -> String -- ^ Why, exactly, do we need Cubical to be enabled? + -> TCM () +requireCubical wanted s = do + cubical <- optCubical <$> pragmaOptions + inErasedContext <- hasQuantity0 <$> getEnv + case cubical of + Just CFull -> return () + Just CErased | wanted == CErased || inErasedContext -> return () + _ -> typeError $ GenericError $ "Missing option " ++ opt ++ s + where + opt = case wanted of + CFull -> "--cubical" + CErased -> "--cubical or --erased-cubical" + +-- | Our good friend the interval type. +primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type +primIntervalType = El intervalSort <$> primInterval + +-- | Negation on the interval. Negation satisfies De Morgan's laws, and +-- their implementation is handled here. +primINeg' :: TCM PrimitiveImpl +primINeg' = do + requireCubical CErased "" + t <- primIntervalType --> primIntervalType + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case + [x] -> do + unview <- intervalUnview' + view <- intervalView' + sx <- reduceB' x + ix <- intervalView (unArg $ ignoreBlocking sx) + + -- Apply De Morgan's laws. + let + ineg :: Arg Term -> Arg Term + ineg = fmap (unview . f . view) + + f ix = case ix of + IZero -> IOne + IOne -> IZero + IMin x y -> IMax (ineg x) (ineg y) + IMax x y -> IMin (ineg x) (ineg y) + INeg x -> OTerm (unArg x) + OTerm t -> INeg (Arg defaultArgInfo t) + + -- We force the argument in case it happens to be an interval + -- expression, but it's quite possible that it's _not_. In those + -- cases, negation is stuck. + case ix of + OTerm t -> return $ NoReduction [reduced sx] + _ -> redReturn (unview $ f ix) + _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primINeg called with wrong arity" + +-- | 'primDepIMin' expresses that cofibrations are closed under @Σ@. +-- Thus, it serves as a dependent version of 'primIMin' (which, recall, +-- implements @_∧_@). This is required for the construction of the Kan +-- operations in @Id@. +primDepIMin' :: TCM PrimitiveImpl +primDepIMin' = do + requireCubical CErased "" + t <- runNamesT [] $ + nPi' "φ" primIntervalType $ \ φ -> + pPi' "o" φ (\ o -> primIntervalType) --> primIntervalType + -- Note that the type here is @(φ : I) → (.(IsOne φ) → I) → I@, since + -- @Partial φ I@ is not well-sorted. + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \case + [x,y] -> do + sx <- reduceB' x + ix <- intervalView (unArg $ ignoreBlocking sx) + itisone <- getTerm "primDepIMin" builtinItIsOne + case ix of + -- Σ 0 iy is 0, and additionally P is def.eq. to isOneEmpty. + IZero -> redReturn =<< intervalUnview IZero + -- Σ 1 iy is (iy 1=1). + IOne -> redReturn =<< (pure (unArg y) <@> pure itisone) + _ -> do + -- Hack: We cross our fingers and really hope that eventually + -- ix may turn out to be i1. Regardless we evaluate iy 1=1, to + -- short-circuit evaluate a couple of cases: + sy <- reduceB' y + iy <- intervalView =<< reduce' =<< (pure (unArg $ ignoreBlocking sy) <@> pure itisone) + case iy of + -- Σ _ (λ _ → 0) is always 0 + IZero -> redReturn =<< intervalUnview IZero + -- Σ ix (λ _ → 1) only depends on ix + IOne -> redReturn (unArg $ ignoreBlocking sx) + -- Otherwise we're well and truly blocked. + _ -> return $ NoReduction [reduced sx, reduced sy] + _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primDepIMin called with wrong arity" + +-- | Internal helper for constructing binary operations on the interval, +-- parameterised by their unit and absorbing elements. +primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl +primIBin unit absorber = do + requireCubical CErased "" + t <- primIntervalType --> primIntervalType --> primIntervalType + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \case + [x,y] -> do + -- Evaluation here is short-circuiting: If the LHS is either the + -- absorbing or unit element, then the RHS does not matter. + sx <- reduceB' x + ix <- intervalView (unArg $ ignoreBlocking sx) + case ix of + ix | ix ==% absorber -> redReturn =<< intervalUnview absorber + ix | ix ==% unit -> return $ YesReduction YesSimplification (unArg y) + _ -> do + -- And in the case where the LHS is stuck, we can make + -- progress by comparing the LHS to the absorbing/unit + -- elements. + sy <- reduceB' y + iy <- intervalView (unArg $ ignoreBlocking sy) + case iy of + iy | iy ==% absorber -> redReturn =<< intervalUnview absorber + iy | iy ==% unit -> return $ YesReduction YesSimplification (unArg x) + _ -> return $ NoReduction [reduced sx,reduced sy] + _ -> __IMPOSSIBLE_VERBOSE__ "binary operation on the interval called with incorrect arity" + where + (==%) IZero IZero = True + (==%) IOne IOne = True + (==%) _ _ = False +{-# INLINE primIBin #-} + +-- | Implements both the @min@ connection /and/ conjunction on the +-- cofibration classifier. +primIMin' :: TCM PrimitiveImpl +primIMin' = do + requireCubical CErased "" + primIBin IOne IZero + +-- | Implements both the @max@ connection /and/ disjunction on the +-- cofibration classifier. +primIMax' :: TCM PrimitiveImpl +primIMax' = do + requireCubical CErased "" + primIBin IZero IOne + +-- | A helper for evaluating @max@ on the interval in TCM&co. +imax :: HasBuiltins m => m Term -> m Term -> m Term +imax x y = do + x' <- x + y' <- y + intervalUnview (IMax (argN x') (argN y')) + +-- | A helper for evaluating @min@ on the interval in TCM&co. +imin :: HasBuiltins m => m Term -> m Term -> m Term +imin x y = do + x' <- x + y' <- y + intervalUnview (IMin (argN x') (argN y')) + +-- | A helper for evaluating @neg@ on the interval in TCM&co. +ineg :: HasBuiltins m => m Term -> m Term +ineg x = do + x' <- x + intervalUnview (INeg (argN x')) + +data Command = DoTransp | DoHComp + deriving (Eq, Show) + +-- | The built-in name associated with a particular Kan operation. +kanOpName :: KanOperation -> String +kanOpName TranspOp{} = builtinTrans +kanOpName HCompOp{} = builtinHComp + +-- | Our Kan operations are @transp@ and @hcomp@. The KanOperation +-- record stores the data associated with a Kan operation on arbitrary +-- types: A cofibration and an element of that type. +data KanOperation + -- | A transport problem consists of a cofibration, marking where the + -- transport is constant, and a term to move from the fibre over i0 to + -- the fibre over i1. + = TranspOp + { kanOpCofib :: Blocked (Arg Term) + -- ^ When this cofibration holds, the transport must + -- definitionally be the identity. This is handled generically by + -- 'primTransHComp' but specific Kan operations may still need it. + , kanOpBase :: Arg Term + -- ^ This is the term in @A i0@ which we are transporting. + } + -- | A composition problem consists of a partial element and a base. + -- Semantically, this is justified by the types being Kan fibrations, + -- i.e., having the lifting property against trivial cofibrations. + -- While the specified cofibration may not be trivial, (φ ∨ ~ r) for r + -- ∉ φ is *always* a trivial cofibration. + | HCompOp + { kanOpCofib :: Blocked (Arg Term) + -- ^ Extent of definition of the partial element we are lifting + -- against. + , kanOpSides :: Arg Term + -- ^ The partial element itself + , kanOpBase :: Arg Term + -- ^ The base. + } + +-- | Are we looking at a family of things, or at a single thing? +data FamilyOrNot a + = IsFam { famThing :: a } + | IsNot { famThing :: a } + deriving (Eq,Show,Functor,Foldable,Traversable) + +familyOrNot :: IsString p => FamilyOrNot a -> p +familyOrNot (IsFam x) = "IsFam" +familyOrNot (IsNot x) = "IsNot" + +instance Reduce a => Reduce (FamilyOrNot a) where + reduceB' x = traverse id <$> traverse reduceB' x + reduce' x = traverse reduce' x + +-- | For the Kan operations in @Glue@ and @hcomp {Type}@, we optimise +-- evaluation a tiny bit by differentiating the term produced when +-- evaluating a Kan operation by itself vs evaluating it under @unglue@. +data TermPosition + = Head + | Eliminated + deriving (Eq,Show) + +-- | If we're computing a Kan operation for one of the "unstable" type +-- formers (@Glue@, @hcomp {Type}@), this tells us whether the type will +-- reduce further, and whether we should care. +-- +-- When should we care? When we're in the 'Head' 'TermPosition'. When +-- will the type reduce further? When @φ@, its formula, is not i1. +headStop :: PureTCM m => TermPosition -> m Term -> m Bool +headStop tpos phi + | Head <- tpos = do + phi <- intervalView =<< (reduce =<< phi) + return $ not $ isIOne phi + | otherwise = return False + +-- | Build a partial element. The type of the resulting partial element +-- can depend on the computed extent, which we denote by @φ@ here. Note +-- that @φ@ is the n-ary disjunction of all the @ψ@s. +combineSys + :: HasBuiltins m + => NamesT m Term -- The level @l : Level@ + -> NamesT m Term -- The type @A : Partial φ (Type l)@. + -> [(NamesT m Term, NamesT m Term)] + -- ^ A list of @(ψ, PartialP ψ λ o → A (... o ...))@ mappings. Note + -- that by definitional proof-irrelevance of @IsOne@, the actual + -- injection can not matter here. + -> NamesT m Term +combineSys l ty xs = snd <$> combineSys' l ty xs + +-- | Build a partial element, and compute its extent. See 'combineSys' +-- for the details. +combineSys' + :: forall m. HasBuiltins m + => NamesT m Term -- The level @l@ + -> NamesT m Term -- The type @A@ + -> [(NamesT m Term, NamesT m Term)] + -> NamesT m (Term,Term) +combineSys' l ty xs = do + tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr + tMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax + iz <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero + tEmpty <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIsOneEmpty + + let + pOr l ty phi psi u0 u1 = pure tPOr + <#> l <@> phi <@> psi <#> (ilam "o" $ \ _ -> ty) + <@> u0 <@> u1 + + -- In one pass, compute the disjunction of all the cofibrations and + -- compute the primPOr expression. + combine :: [(NamesT m Term, NamesT m Term)] -> NamesT m (Term, Term) + combine [] = (iz,) <$> (pure tEmpty <#> l <#> (ilam "o" $ \ _ -> ty)) + combine [(psi, u)] = (,) <$> psi <*> u + combine ((psi, u):xs) = do + (phi, c) <- combine xs + (,) <$> imax psi (pure phi) <*> pOr l ty psi (pure phi) u (pure c) + combine xs + +-- | Helper function for constructing the type of fibres of a function +-- over a given point. +fiber + :: (HasBuiltins m, HasConstInfo m) + => NamesT m Term -- @la : Level@ + -> NamesT m Term -- @lb : Level@ + -> NamesT m Term -- @A : Type la@ + -> NamesT m Term -- @B : Type lb@ + -> NamesT m Term -- @f : A → B@ + -> NamesT m Term -- @x : B@ + -> NamesT m Term -- @Σ[ x ∈ A ] (f a ≡ x)@ +fiber la lb bA bB f b = do + tPath <- getTerm "fiber" builtinPath + kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit + pure (Def (sigmaName kit) []) + <#> la <#> lb + <@> bA + <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b) + +-- | Helper function for constructing the filler of a given composition +-- problem. +hfill + :: (HasBuiltins m, HasConstInfo m) + => NamesT m Term -- @la : Level@ + -> NamesT m Term -- @A : Type la@ + -> NamesT m Term -- @φ : I@. Cofibration + -> NamesT m Term -- @u : Partial φ A@. + -> NamesT m Term -- @u0 : A@. Must agree with @u@ on @φ@ + -> NamesT m Term -- @i : I@. Position along the cube. + -> NamesT m Term +hfill la bA phi u u0 i = do + tHComp <- getTerm "hfill" builtinHComp + pure tHComp <#> la <#> bA <#> (imax phi (ineg i)) + <@> lam "j" (\ j -> combineSys la bA + [ (phi, ilam "o" (\o -> u <@> (imin i j) <..> o)) + , (ineg i, ilam "o" (\_ -> u0)) + ]) + <@> u0 + +-- | Decompose an interval expression @i : I@ as in +-- 'decomposeInterval'', but discard any inconsistent mappings. +decomposeInterval :: HasBuiltins m => Term -> m [(IntMap Bool, [Term])] +decomposeInterval t = do + decomposeInterval' t <&> \xs -> + [ (bm, ts) | (bsm, ts) <- xs, bm <- maybeToList $ traverse BoolSet.toSingleton bsm ] + +-- | Decompose an interval expression @φ : I@ into a set of possible +-- assignments for the variables mentioned in @φ@, together any leftover +-- neutral terms that could not be put into 'IntervalView' form. +decomposeInterval' :: HasBuiltins m => Term -> m [(IntMap BoolSet, [Term])] +decomposeInterval' t = do + view <- intervalView' + unview <- intervalUnview' + let + f :: IntervalView -> [[Either (Int,Bool) Term]] + -- TODO handle primIMinDep + -- TODO? handle forall + f IZero = mzero -- No assignments are possible + f IOne = return [] -- No assignments are necessary + -- Take the cartesian product + f (IMin x y) = do + xs <- (f . view . unArg) x + ys <- (f . view . unArg) y + return (xs ++ ys) + -- Take the union + f (IMax x y) = msum $ map (f . view . unArg) [x,y] + -- Invert the possible assignments and negate the neutrals + f (INeg x) = + map (either (\ (x,y) -> Left (x,not y)) (Right . unview . INeg . argN)) + <$> (f . view . unArg) x + f (OTerm (Var i [])) = return [Left (i,True)] + f (OTerm t) = return [Right t] + + return [ (bsm, ts) + | xs <- f (view t) + , let (bs,ts) = partitionEithers xs + , let bsm = IntMap.fromListWith BoolSet.union $ map (second BoolSet.singleton) bs + ] + +reduce2Lam :: Term -> ReduceM (Blocked Term) +reduce2Lam t = do + t <- reduce' t + case lam2Abs Relevant t of + t -> underAbstraction_ t $ \ t -> do + t <- reduce' t + case lam2Abs Irrelevant t of + t -> underAbstraction_ t reduceB' + where + lam2Abs rel (Lam _ t) = absBody t <$ t + lam2Abs rel t = Abs "y" (raise 1 t `apply` [setRelevance rel $ argN $ var 0]) + +-- | Are we looking at an application of the 'Sub' type? If so, return: +-- * The type we're an extension of +-- * The extent +-- * The partial element. +isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term)) +isCubicalSubtype t = do + t <- reduce t + msub <- getBuiltinName' builtinSub + case unEl t of + Def q es | Just q == msub, Just (level:typ:phi:ext:_) <- allApplyElims es -> do + pure (pure (unArg level, unArg typ, unArg phi, unArg ext)) + _ -> pure Nothing diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs-boot b/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs-boot @@ -0,0 +1,6 @@ +module Agda.TypeChecking.Primitive.Cubical.Base where + +import Agda.TypeChecking.Monad.Pure +import Agda.Syntax.Internal + +isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term)) diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs b/src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs @@ -0,0 +1,402 @@ +{-# LANGUAGE NondecreasingIndentation #-} +module Agda.TypeChecking.Primitive.Cubical.Glue + ( mkGComp + , doGlueKanOp + + , primGlue' + , prim_glue' + , prim_unglue' + ) + where + +import Control.Monad.Except + +import Agda.Utils.Functor +import Agda.Utils.Monad +import Agda.Utils.Maybe + +import Agda.TypeChecking.Monad.Builtin +import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Pure +import Agda.TypeChecking.Monad.Env +import Agda.TypeChecking.Substitute (absBody, apply, sort, subst, applyE) +import Agda.TypeChecking.Reduce (reduceB', reduce') +import Agda.TypeChecking.Names (NamesT, runNamesT, runNames, cl, lam, open, ilam) + +import Agda.Interaction.Options.Base (optCubical) + +import Agda.Syntax.Common + ( Hiding(..), Cubical(..), Arg(..) + , ConOrigin(..), ProjOrigin(..) + , Relevance(..) + , setRelevance + , defaultArgInfo, hasQuantity0, defaultArg, setHiding + ) + +import Agda.TypeChecking.Primitive.Base + ( (-->), nPi', pPi', hPi', el, el', el's, (<@>), (<@@>), (<#>), argN, argH, (<..>) + , SigmaKit(..), getSigmaKit + ) + +import Agda.Syntax.Internal +import Agda.Utils.Impossible (__IMPOSSIBLE__) +import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__) + +import Agda.TypeChecking.Primitive.Cubical.Base + +-- | Define a "ghcomp" version of gcomp. Normal comp looks like: +-- +-- comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0) +-- +-- So for "gcomp" we compute: +-- +-- gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0) +-- +-- The point of this is that gcomp does not produce any empty +-- systems (if phi = 0 it will reduce to "forward A 0 u". +mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term) +mkGComp s = do + let getTermLocal = getTerm s + tPOr <- getTermLocal "primPOr" + tIMax <- getTermLocal builtinIMax + tIMin <- getTermLocal builtinIMin + tINeg <- getTermLocal builtinINeg + tHComp <- getTermLocal builtinHComp + tTrans <- getTermLocal builtinTrans + io <- getTermLocal builtinIOne + iz <- getTermLocal builtinIZero + let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r)) + <@> lam "i" (\ i -> bA <@> (i `imax` r)) + <@> r + <@> u + return $ \ la bA phi u u0 -> + pure tHComp <#> (la <@> pure io) + <#> (bA <@> pure io) + <#> imax phi (ineg phi) + <@> lam "i" (\ i -> combineSys (la <@> i) (bA <@> i) + [ (phi, ilam "o" $ \o -> forward la bA i (u <@> i <..> o)) + , (ineg phi, ilam "o" $ \o -> forward la bA (pure iz) u0) + ]) + <@> forward la bA (pure iz) u0 + +-- | Perform the Kan operations for a @Glue φ A (T , e)@ type. +doGlueKanOp + :: PureTCM m + => KanOperation -- ^ Are we composing or transporting? + -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) + -- ^ The data of the Glue operation: The levels of @A@ and @T@, @A@ + -- itself, the extent of @T@, @T@ itself, and the family of + -- equivalences. + -> TermPosition + -- ^ Are we computing a plain hcomp/transp or are we computing under + -- @unglue@? + -> m (Maybe Term) + +doGlueKanOp (HCompOp psi u u0) (IsNot (la, lb, bA, phi, bT, e)) tpos = do +-- hcomp {psi} u u0 : Glue {la} {lb} bA {φ} (bT, e) +-- ... |- la, lb : Level +-- ... |- bA : Type la +-- ... |- bT : Partial φ (Type lB) +-- ... |- e : PartialP φ λ o → bT o ≃ bA + let getTermLocal = getTerm $ builtinHComp ++ " for " ++ builtinGlue + tHComp <- getTermLocal builtinHComp + tEFun <- getTermLocal builtinEquivFun + tglue <- getTermLocal builtin_glue + tunglue <- getTermLocal builtin_unglue + io <- getTermLocal builtinIOne + tItIsOne <- getTermLocal builtinItIsOne + view <- intervalView' + + runNamesT [] $ do + [psi, u, u0] <- mapM (open . unArg) [ignoreBlocking psi, u, u0] + [la, lb, bA, phi, bT, e] <- mapM (open . unArg) [la, lb, bA, phi, bT, e] + + ifM (headStop tpos phi) (return Nothing) $ Just <$> do + let + tf i o = hfill lb (bT <..> o) psi u u0 i + unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g + + a1 = pure tHComp <#> la <#> bA <#> (imax psi phi) + <@> lam "i" (\i -> combineSys la bA + [ (psi, ilam "o" (\o -> unglue (u <@> i <..> o))) + , (phi, ilam "o" (\o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o)) + ]) + <@> unglue u0 + + t1 = tf (pure io) + + case tpos of + Head -> t1 (pure tItIsOne) + Eliminated -> a1 + +-- ... |- psi, u0 +-- ..., i |- la, lb, bA, phi, bT, e +doGlueKanOp (TranspOp psi u0) (IsFam (la, lb, bA, phi, bT, e)) tpos = do +-- transp (λ i → Glue {la} {lb} bA {φ} (bT , e)) ψ u0 + let + localUse = builtinTrans ++ " for " ++ builtinGlue + getTermLocal = getTerm localUse + tHComp <- getTermLocal builtinHComp + tTrans <- getTermLocal builtinTrans + tForall <- getTermLocal builtinFaceForall + tEFun <- getTermLocal builtinEquivFun + tEProof <- getTermLocal builtinEquivProof + toutS <- getTermLocal builtinSubOut + tglue <- getTermLocal builtin_glue + tunglue <- getTermLocal builtin_unglue + io <- getTermLocal builtinIOne + iz <- getTermLocal builtinIZero + tLMax <- getTermLocal builtinLevelMax + tTransp <- getTermLocal builtinTranspProof + tItIsOne <- getTermLocal builtinItIsOne + kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit + runNamesT [] $ do + + gcomp <- mkGComp localUse + + -- transpFill: transp (λ j → bA (i ∧ j)) (φ ∨ ~ i) u0 + -- connects u0 and transp bA i0 u0 + let transpFill la bA phi u0 i = + pure tTrans <#> lam "j" (\ j -> la <@> imin i j) + <@> lam "j" (\ j -> bA <@> imin i j) + <@> (imax phi (ineg i)) + <@> u0 + [psi,u0] <- mapM (open . unArg) [ignoreBlocking psi,u0] + + -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a + glue1 <- do + g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e] + return $ \ t a -> g <@> t <@> a + + [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e] + + -- Andreas, 2022-03-24, fixing #5838 + -- Following the updated note + -- + -- Simon Huber, A Cubical Type Theory for Higher Inductive Types + -- https://simhu.github.io/misc/hcomp.pdf (February 2022) + -- + -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776 + + -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0 + let unglue_u0 i = foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0 + + view <- intervalView' + + ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do + let + tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i + t1 o = tf (pure io) o + + -- compute "forall. phi" + forallphi = pure tForall <@> phi + + -- a1 with gcomp + -- a1 = gcomp (ψ ∨ (∀ i. φ)) (λ { i (ψ = i1) → unglue_u0 i ; i ((∀ i. φ) = i1) → equivFun ... }) + -- (unglue_u0 i0) + a1 = gcomp la bA (imax psi forallphi) + (lam "i" $ \ i -> combineSys (la <@> i) (bA <@> i) + [ (psi, ilam "o" $ \_ -> unglue_u0 i) + , (forallphi, ilam "o" $ \o -> w i o <@> (tf i o)) + ]) + (unglue_u0 (pure iz)) + + max l l' = pure tLMax <@> l <@> l' + sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y + + -- The underlying function of our partial equivalence at the given + -- endpoint of the interval, together with proof (o : IsOne φ). + w i o = pure tEFun <#> (lb <@> i) + <#> (la <@> i) + <#> (bT <@> i <..> o) + <#> (bA <@> i) + <@> (e <@> i <..> o) + + -- Type of fibres of the partial equivalence over a1. + fiberT o = fiber (lb <@> pure io) (la <@> pure io) + (bT <@> (pure io) <..> o) (bA <@> pure io) + (w (pure io) o) + a1 + + -- We don't have to do anything special for "~ forall. phi" + -- here (to implement "ghcomp") as it is taken care off by + -- tEProof in t1'alpha below + pe o = -- o : IsOne φ + combineSys (max (la <@> pure io) (lb <@> pure io)) (fiberT o) + [ (psi , ilam "o" $ \_ -> sigCon u0 (lam "_" $ \_ -> a1)) + , (forallphi , ilam "o" $ \o -> sigCon (t1 o) (lam "_" $ \_ -> a1)) + ] + -- pe is a partial fibre of the equivalence with extent (ψ ∨ ∀ i. φ) + -- over a1 + + -- "ghcomp" is implemented in the proof of tEProof + -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda) + t1'alpha o = -- o : IsOne φ + -- Because @e i1 1=1@ is an equivalence, we can extend the + -- partial fibre @pe@ to an actual fibre of (e i1 1=1) over a1. + pure toutS <#> (max (la <@> pure io) (lb <@> pure io)) <#> fiberT o + <#> imax psi forallphi + <#> pe o + <@> (pure tEProof + <#> (lb <@> pure io) <#> (la <@> pure io) + <@> (bT <@> pure io <..> o) <@> (bA <@> pure io) + <@> (e <@> pure io <..> o) <@> a1 + <@> (imax psi forallphi) + <@> pe o) + + -- TODO: optimize? + t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)]) + alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)]) + a1' = pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) + <#> imax (phi <@> pure io) psi + <@> lam "j" (\j -> combineSys (la <@> pure io) (bA <@> pure io) + [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, j)) + , (psi, ilam "o" $ \o -> a1) + ]) + <@> a1 + + -- glue1 (ilam "o" t1') a1' + case tpos of + Head -> t1' (pure tItIsOne) + Eliminated -> a1' +doGlueKanOp _ _ _ = __IMPOSSIBLE__ + +-- The implementation of 'primGlue'. Handles reduction where the partial +-- element is defined. +primGlue' :: TCM PrimitiveImpl +primGlue' = do + requireCubical CFull "" + -- primGlue + -- : {la lb : Level} (A : Type la) {φ : I} + -- → (T : Partial φ (Type lb) + -- → (e : PartialP φ λ o → A ≃ T o) + -- → Type lb + t <- runNamesT [] $ + hPi' "la" (el $ cl primLevel) (\ la -> + hPi' "lb" (el $ cl primLevel) $ \ lb -> + nPi' "A" (sort . tmSort <$> la) $ \ a -> + hPi' "φ" primIntervalType $ \ φ -> + nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t -> + pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) + --> (sort . tmSort <$> lb)) + view <- intervalView' + one <- primItIsOne + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts -> + case ts of + [la,lb,a,phi,t,e] -> do + sphi <- reduceB' phi + -- If @φ = i1@ then we reduce to @T 1=1@, since @Glue@ is also a Kan operation. + case view $ unArg $ ignoreBlocking $ sphi of + IOne -> redReturn $ unArg t `apply` [argN one] + -- Otherwise we're a regular ol' type. + _ -> return (NoReduction $ map notReduced [la,lb,a] ++ [reduced sphi] ++ map notReduced [t,e]) + _ -> __IMPOSSIBLE__ + +-- | The implementation of 'prim_glue', the introduction form for @Glue@ +-- types. +prim_glue' :: TCM PrimitiveImpl +prim_glue' = do + requireCubical CFull "" + t <- runNamesT [] $ + hPi' "la" (el $ cl primLevel) (\ la -> + hPi' "lb" (el $ cl primLevel) $ \ lb -> + hPi' "A" (sort . tmSort <$> la) $ \ a -> + hPi' "φ" primIntervalType $ \ φ -> + hPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t -> + hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e -> + pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e))) + + -- Takes a partial element of @t : T@ and an element of the base type @A@ + -- which extends @e t@, and makes it into a Glue. + view <- intervalView' + one <- primItIsOne + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \case + [la, lb, bA, phi, bT, e, t, a] -> do + sphi <- reduceB' phi + -- When @φ = 1@ then @t : T@ is totally defined. + case view $ unArg $ ignoreBlocking $ sphi of + IOne -> redReturn $ unArg t `apply` [argN one] + -- Otherwise we'll just wait to get unglued. + _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e,t,a]) + _ -> __IMPOSSIBLE__ + +-- | The implementation of 'prim_unglue', the elimination form for +-- @Glue@ types. +prim_unglue' :: TCM PrimitiveImpl +prim_unglue' = do + requireCubical CFull "" + t <- runNamesT [] $ + hPi' "la" (el $ cl primLevel) (\ la -> + hPi' "lb" (el $ cl primLevel) $ \ lb -> + hPi' "A" (sort . tmSort <$> la) $ \ a -> + hPi' "φ" primIntervalType $ \ φ -> + hPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t -> + hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e -> + (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a) + + -- Takes an element @b : Glue φ A (T, e)@ to an element of @A@ which, + -- under @φ@, agrees with @e b@. Recall that @φ ⊢ e : A → T@ and @φ ⊢ + -- Glue φ A (T, e) = T@ so this is well-typed. + view <- intervalView' + one <- primItIsOne + mGlue <- getPrimitiveName' builtinGlue + mglue <- getPrimitiveName' builtin_glue + mtransp <- getPrimitiveName' builtinTrans + mhcomp <- getPrimitiveName' builtinHComp + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 7 $ \case + [la, lb, bA, phi, bT, e, b] -> do + sphi <- reduceB' phi + case view $ unArg $ ignoreBlocking $ sphi of + -- When @φ = i1@ we have @Glue i1 A (T , e) = T@ so @b : T@, + -- and we must produce @unglue b : A [ i1 → e b ]@. But that's + -- just @e b@! + IOne -> do + let argOne = setRelevance Irrelevant $ argN one + tEFun <- getTerm builtin_unglue builtinEquivFun + redReturn $ tEFun `apply` [lb,la,argH $ unArg bT `apply` [argOne],bA, argN $ unArg e `apply` [argOne],b] + + -- Otherwise we're dealing with a proper glued thing. + -- Definitely a sticky situation! + _ -> do + sb <- reduceB' b + let fallback sbA = return (NoReduction $ map notReduced [la,lb] ++ map reduced [sbA, sphi] ++ map notReduced [bT,e] ++ [reduced sb]) + case unArg $ ignoreBlocking $ sb of + -- Case 1: unglue (glue a) = a. This agrees with the @φ = + -- i1@ reduction because under @φ@, the argument to + -- @glue@ must be in the image of the equivalence. + Def q es + | Just [_, _, _, _, _, _, _, a] <- allApplyElims es + , Just q == mglue -> redReturn $ unArg a + + -- Case 2: unglue (transp (λ i → Glue ...) r u0). + -- Defer to the implementation of @doGlueKanOp DoTransp ... Eliminated@: It knows how to unglue itself. + Def q [Apply l, Apply bA, Apply r, Apply u0] | Just q == mtransp -> do + sbA <- reduceB' bA + -- Require that bA be a lambda abstraction... + case unArg $ ignoreBlocking sbA of + Lam _ t -> do + -- And that its body reduces to a Glue type. + st <- reduceB' (absBody t) + case ignoreBlocking st of + -- In this case, we use the Glue data extracted from + -- the family we're transporting over. + Def g es | Just [la', lb', bA', phi', bT', e'] <- allApplyElims es, Just g == mGlue -> do + redReturn . fromMaybe __IMPOSSIBLE__ =<< + doGlueKanOp (TranspOp (notBlocked r) u0) (IsFam (la',lb',bA',phi',bT',e')) Eliminated + _ -> fallback (st *> sbA) + _ -> fallback sbA + + -- Case 3: unglue (hcomp u u0). + -- Defer to the implementation of @doGlueKanOp DoHComp ... Eliminated@: It knows how to unglue itself. + Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] | Just q == mhcomp -> do + sbA <- reduceB' bA + case unArg $ ignoreBlocking sbA of + -- Idem: use the Glue data from the type we're doing + -- hcomp in. + Def g es | Just [la', lb', bA', phi', bT', e'] <- allApplyElims es, Just g == mGlue -> do + redReturn . fromMaybe __IMPOSSIBLE__ =<< + doGlueKanOp (HCompOp (notBlocked r) u u0) (IsNot (la',lb',bA',phi',bT',e')) Eliminated + _ -> fallback sbA + + _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e] ++ [reduced sb]) + _ -> __IMPOSSIBLE__ diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs b/src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE NondecreasingIndentation #-} +module Agda.TypeChecking.Primitive.Cubical.HCompU + ( doHCompUKanOp + , prim_glueU' + , prim_unglueU' + ) + where + +import Control.Monad +import Control.Monad.Except ( MonadError ) + +import Agda.Utils.Functor +import Agda.Utils.Monad +import Agda.Utils.Maybe + +import Agda.TypeChecking.Monad.Builtin +import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Pure +import Agda.TypeChecking.Monad.Env +import Agda.TypeChecking.Substitute (absBody, apply, sort, subst, applyE) +import Agda.TypeChecking.Reduce (reduceB', reduceB, reduce') +import Agda.TypeChecking.Names (NamesT, runNamesT, runNames, cl, lam, open, ilam) + +import Agda.Interaction.Options.Base (optCubical) + +import Agda.Syntax.Common + ( Hiding(..), Cubical(..), Arg(..) + , ConOrigin(..), ProjOrigin(..) + , Relevance(..) + , setRelevance + , defaultArgInfo, hasQuantity0, defaultArg, setHiding + ) + +import Agda.TypeChecking.Primitive.Base + ( (-->), nPi', pPi', hPi', el, el', el's, (<@>), (<@@>), (<#>), argN, argH, (<..>) + , SigmaKit(..), getSigmaKit + ) + +import Agda.Syntax.Internal +import Agda.Utils.Impossible (__IMPOSSIBLE__) +import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__) + +import Agda.TypeChecking.Primitive.Cubical.Glue +import Agda.TypeChecking.Primitive.Cubical.Base + +-- | Perform the Kan operations for an @hcomp {A = Type} {φ} u u0@ type. +doHCompUKanOp + :: PureTCM m + => KanOperation + -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term) + -> TermPosition + -> m (Maybe Term) + +-- TODO (Amy, 2022-08-17): This is literally the same algorithm as +-- doGlueKanOp, but specialised for using transport as the equivalence. +-- Can we deduplicate them? +doHCompUKanOp (HCompOp psi u u0) (IsNot (la, phi, bT, bA)) tpos = do + let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinHComp ++ " of Set") + io <- getTermLocal builtinIOne + iz <- getTermLocal builtinIZero + tHComp <- getTermLocal builtinHComp + tTransp <- getTermLocal builtinTrans + tglue <- getTermLocal builtin_glueU + tunglue <- getTermLocal builtin_unglueU + tLSuc <- getTermLocal builtinLevelSuc + tSubIn <- getTermLocal builtinSubIn + tItIsOne <- getTermLocal builtinItIsOne + runNamesT [] $ do + [psi, u, u0] <- mapM (open . unArg) [ignoreBlocking psi, u, u0] + [la, phi, bT, bA] <- mapM (open . unArg) [la, phi, bT, bA] + + ifM (headStop tpos phi) (return Nothing) $ Just <$> do + + let + transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0 + tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i + + bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA + unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g + + a1 = pure tHComp <#> la <#> bA <#> (imax psi phi) + <@> lam "i" (\i -> combineSys la bA + [ (psi, ilam "o" (\o -> unglue (u <@> i <..> o))) + , (phi, ilam "o" (\ o -> transp la (\i -> bT <@> (ineg i) <..> o) (tf i o))) + ]) + <@> unglue u0 + + t1 = tf (pure io) + + -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1 + case tpos of + Eliminated -> a1 + Head -> t1 (pure tItIsOne) + + +doHCompUKanOp (TranspOp psi u0) (IsFam (la, phi, bT, bA)) tpos = do + let + localUse = builtinTrans ++ " for " ++ builtinHComp ++ " of Set" + getTermLocal = getTerm localUse + tPOr <- getTermLocal "primPOr" + tIMax <- getTermLocal builtinIMax + tIMin <- getTermLocal builtinIMin + tINeg <- getTermLocal builtinINeg + tHComp <- getTermLocal builtinHComp + tTrans <- getTermLocal builtinTrans + tTranspProof <- getTermLocal builtinTranspProof + tSubIn <- getTermLocal builtinSubIn + tForall <- getTermLocal builtinFaceForall + io <- getTermLocal builtinIOne + iz <- getTermLocal builtinIZero + tLSuc <- getTermLocal builtinLevelSuc + tPath <- getTermLocal builtinPath + tItIsOne <- getTermLocal builtinItIsOne + kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit + runNamesT [] $ do + -- Helper definitions we'll use: + gcomp <- mkGComp localUse + + let + transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0 + transpFill la bA phi u0 i = pure tTrans + <#> ilam "j" (\ j -> la <@> imin i j) + <@> ilam "j" (\ j -> bA <@> imin i j) + <@> (imax phi (ineg i)) + <@> u0 + + [psi, u0] <- mapM (open . unArg) [ignoreBlocking psi, u0] + glue1 <- do + tglue <- cl $ getTermLocal builtin_glueU + [la, phi, bT, bA] <- mapM (open . unArg . subst 0 io) $ [la, phi, bT, bA] + let bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA + g <- (open =<<) $ pure tglue <#> la <#> phi <#> bT <#> bAS + return $ \ t a -> g <@> t <@> a + + [la, phi, bT, bA] <- mapM (\a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, phi, bT, bA] + + -- Andreas, 2022-03-25, issue #5838. + -- Port the fix of @unglueTranspGlue@ and @doGlueKanOp DoTransp@ + -- also to @doHCompUKanOp DoTransp@, as suggested by Tom Jack and Anders Mörtberg. + -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@. + -- The original code used it only with @i0@. + tunglue <- cl $ getTermLocal builtin_unglueU + let + bAS i = pure tSubIn + <#> (pure tLSuc <@> (la <@> i)) <#> (Sort . tmSort <$> (la <@> i)) <#> (phi <@> i) + <@> (bA <@> i) + unglue_u0 i = pure tunglue + <#> (la <@> i) <#> (phi <@> i) <#> (bT <@> i) + <#> bAS i <@> u0 + + ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do + + let + tf i o = transpFill la (lam "i" $ \ i -> bT <@> i <@> pure io <..> o) psi u0 i + t1 o = tf (pure io) o + + -- compute "forall. phi" + forallphi = pure tForall <@> phi + + -- a1 with gcomp + a1 = gcomp la bA (imax psi forallphi) + (lam "i" $ \ i -> combineSys (la <@> i) (bA <@> i) + [ (psi, ilam "o" $ \_ -> unglue_u0 i) + , (forallphi, ilam "o" (\o -> transp (la <@> i) (\j -> bT <@> i <@> ineg j <..> o) (tf i o))) + ]) + (unglue_u0 (pure iz)) + + w i o = lam "x" $ transp (la <@> i) (\j -> bT <@> i <@> ineg j <..> o) + + pt o = -- o : [ φ 1 ] + combineSys (la <@> pure io) (bT <@> pure io <@> pure io <..> o) + [ (psi , ilam "o" $ \_ -> u0) + , (forallphi , ilam "o" $ \o -> t1 o) + ] + + -- "ghcomp" is implemented in the proof of tTranspProof + -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda) + t1'alpha o = -- o : [ φ 1 ] + pure tTranspProof + <#> (la <@> pure io) <@> lam "i" (\i -> bT <@> pure io <@> ineg i <..> o) + <@> imax psi forallphi + <@> pt o + <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io) <#> imax psi forallphi + <@> a1) + + -- TODO: optimize? + t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)]) + alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)]) + a1' = pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) + <#> imax (phi <@> pure io) psi + <@> lam "j" (\j -> combineSys (la <@> pure io) (bA <@> pure io) + [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, j)) + , (psi, ilam "o" $ \o -> a1) + ]) + <@> a1 + + -- glue1 (ilam "o" t1') a1' + case tpos of + Eliminated -> a1' + Head -> t1' (pure tItIsOne) +doHCompUKanOp _ _ _ = __IMPOSSIBLE__ + +-- | The implementation of 'prim_glueU', the introduction form for +-- @hcomp@ types. +prim_glueU' :: TCM PrimitiveImpl +prim_glueU' = do +-- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue +-- applies here. + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "la" (el $ cl primLevel) (\ la -> + hPi' "φ" primIntervalType $ \ φ -> + hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t -> + hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do + let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a) + pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o)) + --> (el' la bA) + --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)) + view <- intervalView' + one <- primItIsOne + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts -> + case ts of + [la,phi,bT,bA,t,a] -> do + sphi <- reduceB' phi + case view $ unArg $ ignoreBlocking $ sphi of + IOne -> redReturn $ unArg t `apply` [argN one] + _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA,t,a]) + _ -> __IMPOSSIBLE__ + +-- | The implementation of 'prim_unglueU', the elimination form for +-- @hcomp@ types. +prim_unglueU' :: TCM PrimitiveImpl +prim_unglueU' = do +-- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue +-- applies here. + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "la" (el $ cl primLevel) (\ la -> + hPi' "φ" primIntervalType $ \ φ -> + hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t -> + hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do + let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a) + el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA) + --> el' la bA) + + view <- intervalView' + one <- primItIsOne + mglueU <- getPrimitiveName' builtin_glueU + mtransp <- getPrimitiveName' builtinTrans + mHCompU <- getPrimitiveName' builtinHComp + let mhcomp = mHCompU + + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case + [la,phi,bT,bA,b] -> do + sphi <- reduceB' phi + case view $ unArg $ ignoreBlocking $ sphi of + -- Case where the hcomp has reduced away: Transport backwards + -- along the partial element we've glued. + IOne -> do + tTransp <- getTerm builtin_unglueU builtinTrans + iNeg <- getTerm builtin_unglueU builtinINeg + iZ <- getTerm builtin_unglueU builtinIZero + redReturn <=< runNamesT [] $ do + [la,bT,b] <- mapM (open . unArg) [la,bT,b] + pure tTransp <#> lam "i" (\ _ -> la) <@> lam "i" (\ i -> bT <@> ineg i <..> pure one) + <@> pure iZ <@> b + + -- Otherwise, we're dealing with a proper glu- didn't I already + -- make this joke? Oh, yeah, in prim_unglue, right. + _ -> do + sb <- reduceB' b + let fallback sbA = return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb]) + case unArg $ ignoreBlocking $ sb of + -- Project: + Def q es | Just [_,_,_,_,_, a] <- allApplyElims es, Just q == mglueU -> redReturn $ unArg a + + -- Transport: + Def q [Apply l, Apply bA, Apply r, Apply u0] | Just q == mtransp -> do + sbA <- reduceB bA + case unArg $ ignoreBlocking sbA of + Lam _ t -> do + st <- reduceB' (absBody t) + case ignoreBlocking st of + Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do + redReturn . fromMaybe __IMPOSSIBLE__ =<< + doHCompUKanOp (TranspOp (notBlocked r) u0) (IsFam (la,phi,bT,bA)) Eliminated + _ -> fallback (st *> sbA) + _ -> fallback sbA + + -- Compose: + Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] | Just q == mhcomp -> do + sbA <- reduceB bA + case unArg $ ignoreBlocking sbA of + Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do + redReturn . fromMaybe __IMPOSSIBLE__ =<< + doHCompUKanOp (HCompOp (notBlocked r) u u0) (IsNot (la,phi,bT,bA)) Eliminated + _ -> fallback sbA + _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb]) + + _ -> __IMPOSSIBLE__ diff --git a/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs b/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs @@ -0,0 +1,293 @@ +-- | Implementation of the primitives relating to Cubical identity types. +module Agda.TypeChecking.Primitive.Cubical.Id + ( -- * General elimination form + primIdElim' + -- * Introduction form + , primConId' + -- * Projection maps (primarily used internally) + , primIdFace' + , primIdPath' + -- * Kan operations + , doIdKanOp + ) + where + +import Control.Monad.Except + +import Agda.Utils.Impossible (__IMPOSSIBLE__) +import Agda.Utils.Monad + +import qualified Data.IntMap as IntMap +import Data.Traversable +import Data.Maybe + +import Agda.TypeChecking.Monad.Builtin +import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Env +import Agda.TypeChecking.Substitute (apply, sort, listS, applySubst) +import Agda.TypeChecking.Reduce (reduceB', reduce') +import Agda.TypeChecking.Names + (runNamesT, runNames, cl, lam, ilam, open) + +import Agda.Interaction.Options.Base (optCubical) + +import Agda.Syntax.Common (Cubical(..), Arg(..), defaultArgInfo, hasQuantity0, defaultArg) + +import Agda.TypeChecking.Primitive.Base + ((-->), nPi', pPi', hPi', el, el', el's, (<@>), (<#>), (<..>), argN) + +import Agda.Syntax.Internal +import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__) + +import Agda.TypeChecking.Primitive.Cubical.Base + +-- | Primitive elimination rule for the cubical identity types. Unlike +-- J, @idElim@ makes explicit the structure of Swan's identity types as +-- being pairs of a cofibration and a path. Moreover, it records that +-- the path is definitionally @refl@ under that cofibration. +primIdElim' :: TCM PrimitiveImpl +primIdElim' = do + -- The implementation here looks terrible but most of it is actually + -- the type. + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + hPi' "c" (el $ cl primLevel) $ \ c -> + hPi' "A" (sort . tmSort <$> a) $ \ bA -> + hPi' "x" (el' a bA) $ \ x -> + nPi' "C" (nPi' "y" (el' a bA) $ \ y -> + el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC -> + -- To construct (C : (y : A) → Id A x y → Type c), it suffices to: + + -- For all cofibrations φ, + nPi' "φ" primIntervalType (\ phi -> + -- For all y : A [ φ → (λ _ → x) ] + nPi' "y" (el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (const x)) $ \ y -> + let pathxy = cl primPath <#> a <@> bA <@> x <@> outSy + outSy = cl primSubOut <#> a <#> bA <#> phi <#> lam "o" (const x) <@> y + reflx = lam "o" $ \ _ -> lam "i" $ \ _ -> x -- TODO Andrea, should block on o + -- For all w : (Path A x (outS y)) [ φ (λ _ → refl {x = outS y} ] + in nPi' "w" (el's a $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w -> + let outSw = (cl primSubOut <#> a <#> pathxy <#> phi <#> reflx <@> w) + in el' c $ bC <@> outSy <@> (cl primConId <#> a <#> bA <#> x <#> outSy <@> phi <@> outSw)) + -- Construct an inhabitant of (C (outS y) (conid φ (outS w))) + --> + hPi' "y" (el' a bA) (\ y -> + nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p -> + el' c $ bC <@> y <@> p) + + -- Implementation starts here: + conid <- primConId + sin <- primSubIn + path <- primPath + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \case + [a,c,bA,x,bC,f,y,p] -> do + sp <- reduceB' p + cview <- conidView' + case cview (unArg x) $ unArg $ ignoreBlocking sp of + -- Record that the right endpoint and the path definitionally + -- agree with x φ holds. This is guaranteed internally by the + -- typing rule for @conId@ but can't be recovered from + -- @primIdPath@ and @primIdFace@ (see #2598) + Just (phi, w) -> do + let y' = sin `apply` [a, bA, phi, argN (unArg y)] + let w' = sin `apply` [a, argN (path `apply` [a, bA, x, y]), phi, argN (unArg w)] + redReturn $ unArg f `apply` [phi, defaultArg y', defaultArg w'] + _ -> return $ NoReduction $ map notReduced [a,c,bA,x,bC,f,y] ++ [reduced sp] + _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primIdElim called with wrong arity" + +-- | Introduction form for the cubical identity types. +primConId' :: TCM PrimitiveImpl +primConId' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + hPi' "A" (sort . tmSort <$> a) $ \ bA -> + hPi' "x" (el' a bA) $ \ x -> + hPi' "y" (el' a bA) $ \ y -> + primIntervalType -- Cofibration + --> (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 + -- it (but we, internally, can: see createMissingConIdClause). + + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \case + [l,bA,x,y,phi,p] -> do + sphi <- reduceB' phi + view <- intervalView' + case view $ unArg $ ignoreBlocking sphi of + -- But even though it's a constructor, it does reduce, in some + -- cases: If the cofibration is definitely true, then we return + -- reflId. TODO: Handle this in the conversion checker instead? + IOne -> do + reflId <- getTerm builtinConId builtinReflId + redReturn $ reflId + _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced sphi, notReduced p] + _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primConId called with wrong arity" + +-- | Extract the underlying cofibration from an inhabitant of the +-- cubical identity types. +-- +-- TODO (Amy, 2022-08-17): Projecting a cofibration from a Kan type +-- violates the cubical phase distinction. +primIdFace' :: TCM PrimitiveImpl +primIdFace' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + hPi' "A" (sort . tmSort <$> a) $ \ bA -> + hPi' "x" (el' a bA) $ \ x -> + hPi' "y" (el' a bA) $ \ y -> + el' a (cl primId <#> a <#> bA <@> x <@> y) + --> primIntervalType + + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case + [l,bA,x,y,t] -> do + st <- reduceB' t + mConId <- getName' builtinConId + cview <- conidView' + case cview (unArg x) $ unArg (ignoreBlocking st) of + Just (phi, _) -> redReturn (unArg phi) + _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st] + _ -> __IMPOSSIBLE__ + +-- | Extract the underlying path from an inhabitant of the +-- cubical identity types. +primIdPath' :: TCM PrimitiveImpl +primIdPath' = do + requireCubical CErased "" + t <- runNamesT [] $ + hPi' "a" (el $ cl primLevel) $ \ a -> + hPi' "A" (sort . tmSort <$> a) $ \ bA -> + hPi' "x" (el' a bA) $ \ x -> + hPi' "y" (el' a bA) $ \ y -> + el' a (cl primId <#> a <#> bA <@> x <@> y) + --> el' a (cl primPath <#> a <#> bA <@> x <@> y) + + return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case + [l,bA,x,y,t] -> do + st <- reduceB' t + mConId <- getName' builtinConId + cview <- conidView' + case cview (unArg x) $ unArg (ignoreBlocking st) of + Just (_, w) -> redReturn (unArg w) + _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st] + _ -> __IMPOSSIBLE__ + +-- | Check that a term matches a given predicate on every consistent +-- substitution of interval variables which makes the given cofibration +-- hold. +onEveryFace + :: Term -- ^ The cofibration @φ@ + -> Term -- ^ The term to test + -> (Term -> Bool) + -- ^ The predicate to test with. + -> ReduceM Bool +onEveryFace phi u p = do + unview <- intervalUnview' + let boolToI b = if b then unview IOne else unview IZero + as <- decomposeInterval phi + bools <- for as $ \ (bs,ts) -> do + let u' = listS (IntMap.toAscList $ IntMap.map boolToI bs) `applySubst` u + t <- reduce2Lam u' + return $! p $ ignoreBlocking t + pure (and bools) + +doIdKanOp + :: KanOperation -- ^ Are we composing or transporting? + -> FamilyOrNot (Arg Term) -- ^ Level argument + -> FamilyOrNot (Arg Term, Arg Term, Arg Term) + -- ^ Domain, left and right endpoints of the identity type + -> ReduceM (Maybe (Reduced t Term)) +doIdKanOp kanOp l bA_x_y = do + let getTermLocal = getTerm $ kanOpName kanOp ++ " for " ++ builtinId + + unview <- intervalUnview' + mConId <- getName' builtinConId + cview <- conidView' + let isConId t = isJust $ cview __DUMMY_TERM__ t + + sa0 <- reduceB' (kanOpBase kanOp) + -- TODO: wasteful to compute b even when cheaper checks might fail + -- + -- Should we go forward with the Kan operation? This is the case when + -- doing transport always, and when every face fo the partial element + -- has reduced to @conid@ otherwise. Note that @conidView@ treats + -- @reflId@ as though it were @conid i1 refl@. + b <- case kanOp of + TranspOp{} -> return True + HCompOp _ u _ -> + onEveryFace (unArg . ignoreBlocking . kanOpCofib $ kanOp) (unArg u) isConId + + case mConId of + Just conid | isConId (unArg . ignoreBlocking $ sa0), b -> (Just <$>) . (redReturn =<<) $ do + tHComp <- getTermLocal builtinHComp + tTrans <- getTermLocal builtinTrans + tIMin <- getTermLocal "primDepIMin" + idFace <- getTermLocal "primIdFace" + idPath <- getTermLocal "primIdPath" + tPathType <- getTermLocal builtinPath + tConId <- getTermLocal builtinConId + + runNamesT [] $ do + let + io = pure $ unview IOne + iz = pure $ unview IZero + conId = pure tConId + + eval TranspOp{} l bA phi _ u0 = + pure tTrans <#> l <@> bA <@> phi <@> u0 + eval HCompOp{} l bA phi u u0 = + pure tHComp <#> (l <@> io) <#> (bA <@> io) <#> phi <@> u <@> u0 + + -- Compute a line of levels. So we can invoke 'eval' uniformly. + l <- case l of + IsFam l -> open . unArg $ l + IsNot l -> open (Lam defaultArgInfo $ NoAbs "_" $ unArg l) + + p0 <- open . unArg $ kanOpBase kanOp + + -- p is the partial element we are extending against. This is + -- used to compute the resulting cofibration, so we fake a + -- partial element when doing transport. + p <- case kanOp of + HCompOp _ u _ -> do + u <- open . unArg $ u + pure $ \i o -> u <@> i <..> o + TranspOp{} -> do + pure $ \i o -> p0 + + phi <- open . unArg . ignoreBlocking $ kanOpCofib kanOp + + -- Similarly to the fake line of levels above, fake lines of + -- everything even when we're doing composition, for uniformity + -- of eval. + [bA, x, y] <- case bA_x_y of + IsFam (bA, x, y) -> for [bA, x, y] $ \a -> + open $ runNames [] $ lam "i" (const (pure $ unArg a)) + IsNot (bA, x, y) -> for [bA, x, y] $ \a -> + open (Lam defaultArgInfo $ NoAbs "_" $ unArg a) + + -- The resulting path is constant when when + -- @Σ φ λ o → -- primIdFace p i1 o@ + -- holds. That's why cofibrations have to be closed under Σ, + -- c.f. primDepIMin. + cof <- pure tIMin + <@> phi + <@> ilam "o" (\o -> + pure idFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io) <@> (p io o)) + + -- Do the Kan operation for our faces in the Path type. + path <- eval kanOp l + (lam "i" $ \i -> pure tPathType <#> (l <@> i) <#> (bA <@> i) <@> (x <@> i) <@> (y <@> i)) + phi + (lam "i" $ \i -> ilam "o" $ \o -> + pure idPath <#> (l <@> i) <#> (bA <@> i) <#> (x <@> i) <#> (y <@> i) <@> (p i o)) + (pure idPath <#> (l <@> iz) <#> (bA <@> iz) <#> (x <@> iz) <#> (y <@> iz) <@> p0) + + conId <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io) + <@> pure cof + <@> pure path + _ -> return $ Nothing 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 @@ -161,9 +161,9 @@ -- on (applications of) projection-like functions. elimView :: PureTCM m => ProjEliminator -> Term -> m Term elimView pe v = do - reportSDoc "tc.conv.elim" 30 $ "elimView of " <+> prettyTCM v + reportSDoc "tc.conv.elim" 60 $ "elimView of " <+> prettyTCM v v <- reduceProjectionLike v - reportSDoc "tc.conv.elim" 40 $ + reportSDoc "tc.conv.elim" 65 $ "elimView (projections reduced) of " <+> prettyTCM v case pe of NoPostfix -> return v @@ -262,7 +262,7 @@ -- the dropped arguments. -- Nor can abstract definitions be projection-like since they won't reduce -- outside the abstract block. - def@Function{funProjection = Nothing, funClauses = cls, + def@Function{funProjection = Left MaybeProjection, funClauses = cls, funSplitTree = st0, funCompiled = cc0, funInv = NotInjective, funMutual = Just [], -- Andreas, 2012-09-28: only consider non-mutual funs funAbstr = ConcreteDef} -> do @@ -307,7 +307,7 @@ , projLams = ProjLams $ map (argFromDom . fmap fst) tel } let newDef = def - { funProjection = Just projection + { funProjection = Right projection , funClauses = cls' , funSplitTree = st , funCompiled = cc @@ -322,8 +322,10 @@ reportSLn "tc.proj.like" 30 $ " injective functions can't be projections" Function{funAbstr = AbstractDef} -> reportSLn "tc.proj.like" 30 $ " abstract functions can't be projections" - Function{funProjection = Just{}} -> + Function{funProjection = Right{}} -> reportSLn "tc.proj.like" 30 $ " already projection like" + Function{funProjection = Left NeverProjection} -> + reportSLn "tc.proj.like" 30 $ " the user has asked for it not to be projection-like" Function{funMutual = Just (_:_)} -> reportSLn "tc.proj.like" 30 $ " mutual functions can't be projections" Function{funMutual = Nothing} -> 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 @@ -10,8 +10,10 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal as I +import Agda.Syntax.Internal.Pattern ( hasDefP, dbPatPerm ) import Agda.Syntax.Literal import Agda.Syntax.Position +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.DropArgs @@ -57,7 +59,7 @@ quotingKit :: TCM QuotingKit quotingKit = do - currentFile <- fromMaybe __IMPOSSIBLE__ <$> asksTC envCurrentPath + currentModule <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule hidden <- primHidden instanceH <- primInstance visible <- primVisible @@ -174,6 +176,7 @@ quoteSort SSet{} = pure unsupportedSort quoteSort SizeUniv = pure unsupportedSort quoteSort LockUniv = pure unsupportedSort + quoteSort IntervalUniv = pure unsupportedSort quoteSort PiSort{} = pure unsupportedSort quoteSort FunSort{} = pure unsupportedSort quoteSort UnivSort{} = pure unsupportedSort @@ -198,10 +201,11 @@ quotePat (ConP c _ ps) = conP !@ quoteQName (conName c) @@ quotePats ps quotePat (LitP _ l) = litP !@ quoteLit l quotePat (ProjP _ x) = projP !@ quoteQName x - quotePat (IApplyP o t u x) = pure unsupported + -- #4763: quote IApply co/patterns as though they were variables + quotePat (IApplyP _ _ _ x) = varP !@! quoteNat (toInteger $ dbPatVarIndex x) quotePat DefP{} = pure unsupported - quoteClause :: Maybe Projection -> Clause -> ReduceM Term + quoteClause :: Either a Projection -> Clause -> ReduceM Term quoteClause proj cl@Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body} = case body of Nothing -> absurdClause !@ quoteTelescope tel @@ quotePats ps' @@ -210,8 +214,8 @@ -- #5128: restore dropped parameters if projection-like ps' = case proj of - Nothing -> ps - Just p -> pars ++ ps + Left _ -> ps + Right p -> pars ++ ps where n = projIndex p - 1 pars = map toVar $ take n $ zip (downFrom $ size tel) (telToList tel) @@ -219,12 +223,12 @@ quoteTelescope :: Telescope -> ReduceM Term quoteTelescope tel = quoteList quoteTelEntry $ telToList tel - where - quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term - quoteTelEntry dom@Dom{ unDom = (x , t) } = do - SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit - Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom) + quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term + quoteTelEntry dom@Dom{ unDom = (x , t) } = do + SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit + Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom) + list :: [ReduceM Term] -> ReduceM Term list = foldr (\ a as -> cons !@ a @@ as) (pure nil) @@ -244,6 +248,11 @@ quoteArgs :: Args -> ReduceM Term quoteArgs ts = list (map (quoteArg quoteTerm) ts) + -- has the clause been generated (in particular by --cubical)? + -- TODO: have an explicit clause origin field? + generatedClause :: Clause -> Bool + generatedClause cl = hasDefP (namedClausePats cl) + quoteTerm :: Term -> ReduceM Term quoteTerm v = do v <- instantiate' v @@ -262,15 +271,16 @@ qx Function{ funExtLam = Just (ExtLamInfo m False _), funClauses = cs } = do -- An extended lambda should not have any extra parameters! unless (null conOrProjPars) __IMPOSSIBLE__ + cs <- return $ filter (not . generatedClause) cs n <- size <$> lookupSection m let (pars, args) = splitAt n ts - extlam !@ list (map (quoteClause Nothing . (`apply` pars)) cs) + extlam !@ list (map (quoteClause (Left ()) . (`apply` pars)) cs) @@ list (map (quoteArg quoteTerm) args) qx df@Function{ funExtLam = Just (ExtLamInfo _ True _), funCompiled = Just Fail{}, funClauses = [cl] } = do -- See also corresponding code in InternalToAbstract let n = length (namedClausePats cl) - 1 pars = take n ts - extlam !@ list [quoteClause Nothing $ cl `apply` pars ] + extlam !@ list [quoteClause (Left ()) $ cl `apply` pars ] @@ list (drop n $ map (quoteArg quoteTerm) ts) qx _ = do n <- getDefFreeVars x @@ -289,7 +299,8 @@ Level l -> quoteTerm (unlevelWithKit lkit l) Lit l -> lit !@ quoteLit l Sort s -> sort !@ quoteSort s - MetaV x es -> meta !@! quoteMeta currentFile x @@ quoteArgs vs + MetaV x es -> meta !@! quoteMeta currentModule x + @@ quoteArgs vs where vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es DontCare u -> quoteTerm u Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s @@ -299,9 +310,9 @@ defParameters def False = map par hiding where np = case theDef def of - Constructor{ conPars = np } -> np - Function{ funProjection = Just p } -> projIndex p - 1 - _ -> 0 + Constructor{ conPars = np } -> np + Function{ funProjection = Right p } -> projIndex p - 1 + _ -> 0 TelV tel _ = telView' (defType def) hiding = take np $ telToList tel par d = arg !@ quoteArgInfo (domInfo d) @@ -311,6 +322,9 @@ quoteDefn def = case theDef def of Function{funClauses = cs, funProjection = proj} -> + do + -- re #3733: maybe these should be quoted but marked as generated? + cs <- return $ filter (not . generatedClause) cs agdaDefinitionFunDef !@ quoteList (quoteClause proj) cs Datatype{dataPars = np, dataCons = cs} -> agdaDefinitionDataDef !@! quoteNat (fromIntegral np) @@ quoteList (pure . quoteName) cs @@ -323,7 +337,7 @@ GeneralizableVar{} -> pure agdaDefinitionPostulate -- TODO: reflect generalizable vars AbstractDefn{}-> pure agdaDefinitionPostulate Primitive{primClauses = cs} | not $ null cs -> - agdaDefinitionFunDef !@ quoteList (quoteClause Nothing) cs + agdaDefinitionFunDef !@ quoteList (quoteClause (Left ())) cs Primitive{} -> pure agdaDefinitionPrimitive PrimitiveSort{} -> pure agdaDefinitionPrimitive Constructor{conData = d} -> @@ -345,8 +359,8 @@ quoteConName :: ConHead -> Term quoteConName = quoteName . conName -quoteMeta :: AbsolutePath -> MetaId -> Term -quoteMeta file = Lit . LitMeta file +quoteMeta :: TopLevelModuleName -> MetaId -> Term +quoteMeta m = Lit . LitMeta m quoteTerm :: Term -> TCM Term quoteTerm v = do 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 @@ -6,7 +6,9 @@ module Agda.TypeChecking.ReconstructParameters where +import Data.Functor ( ($>) ) import Data.Maybe + import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic @@ -55,116 +57,109 @@ reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term reconstructParameters' act a v = do - reportSDoc "tc.with.reconstruct" 30 $ + reportSDoc "tc.reconstruct" 30 $ sep [ "reconstructing parameters in" , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ] - v <- checkInternal' reconstructAction v CmpLeq a + v <- checkInternal' (reconstructAction' act) v CmpLeq a - reportSDoc "tc.with.reconstruct" 30 $ + reportSDoc "tc.reconstruct" 30 $ nest 2 $ "-->" <+> prettyTCM v return v - where - reconstructAction = defaultAction{ postAction = reconstruct } - reconstruct a v = do - reportSDoc "tc.with.reconstruct" 30 $ - sep [ "reconstructing in" - , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ] - case unSpine v of - Con h ci vs -> do - hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h) - TelV tel a <- telView a - let under = size tel -- under-applied when under > 0 - reportSDoc "tc.reconstruct" 50 $ - sep [ "reconstructing" - , nest 2 $ sep [ prettyTCM v <+> ":" - , nest 2 $ prettyTCM a ] ] - case (unEl a) of - Def d es -> do - Just n <- defParameters <$> getConstInfo d - let prePs = applySubst (strengthenS impossible under) . take n $ es - let hiddenPs = map (Apply . hideAndRelParams) $ fromMaybe __IMPOSSIBLE__ $ - allApplyElims prePs - reportSDoc "tc.reconstruct" 50 $ "The hiddenPs are" <+> pretty hiddenPs - tyCon <- defType <$> getConstInfo (conName hh) - reportSDoc "tc.reconstruct" 50 $ "Here we start infering spine" - ((_,Con hh ci psAfterAct),_) <- inferSpine' act tyCon (Con hh ci []) (Con hh ci []) hiddenPs - ((_,conWithPars),_) <- inferSpine' reconstructAction tyCon (Con hh ci []) (Con hh ci []) psAfterAct - reportSDoc "tc.reconstruct" 50 $ "The spine has been inferred:" <+> pretty conWithPars - return $ applyWithoutReversing conWithPars vs - _ -> __IMPOSSIBLE__ - _ -> do - vv <- elimView EvenLone v - unSpineAndReconstruct a vv - unSpineAndReconstruct :: Type -> Term -> TCM Term - unSpineAndReconstruct a v = - case v of - Var i vs -> do - ty <- typeOfBV i - ctx <- getContextTelescope - reportSDoc "tc.reconstruct" 50 $ (text ("Var case "++(show i)++" with context")) <+> prettyTCM ctx - loop ty (Var i) vs - Def nam vs -> do - reportSDoc "tc.reconstruct" 50 $ "Def case" - ty <- defType <$> getConstInfo nam - loop ty (Def nam) vs - MetaV id vs -> do - reportSDoc "tc.reconstruct" 50 $ "MetaVar case" - ty <- getMetaType id - loop ty (MetaV id) vs - _ -> do - reportSDoc "tc.reconstruct" 50 $ "Another case" <+> pretty v - return v +reconstructAction :: Action TCM +reconstructAction = reconstructAction' defaultAction + +reconstructAction' :: Action TCM -> Action TCM +reconstructAction' act = act{ postAction = \ty tm -> postAction act ty tm >>= reconstruct ty } + +reconstruct :: Type -> Term -> TCM Term +reconstruct ty v = do + reportSDoc "tc.reconstruct" 30 $ + sep [ "reconstructing in" + , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM ty ] ] + case v of + Con h ci vs -> do + hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h) + TelV tel dataTy <- telView ty + reportSDoc "tc.reconstruct" 50 $ + sep [ "reconstructing" + , nest 2 $ sep [ prettyTCM v <+> ":" + , nest 2 $ prettyTCM dataTy ] ] + pars <- addContext tel $ extractParameters (conName h) dataTy + -- If the constructor is underapplied, we need to escape from the telescope. + let escape = applySubst $ strengthenS __IMPOSSIBLE__ $ size tel + return $ Con hh ci $ map Apply (escape pars) ++ vs + Def f es -> projView v >>= \case + ProjectionView _f a es -> do + recTy <- infer =<< dropParameters (unArg a) + pars <- extractParameters f recTy + loop ty (Def f . (map Apply pars ++) . (Apply a:)) es + LoneProjectionLike _f i -> reduce (unEl ty) >>= \case + Pi recTy _ -> do + pars <- extractParameters f (unDom recTy) + return $ Def f $ map Apply pars + _ -> __IMPOSSIBLE__ + NoProjection{} -> do + ty <- defType <$> getConstInfo f + loop ty (Def f) es + Var i es -> do + ty <- typeOfBV i + loop ty (Var i) es + MetaV m es -> do + ty <- getMetaType m + loop ty (MetaV m) es + _ -> return v + + where -- @loop ty f vs@ where @ty@ is the type of @f []@ and vs are valid -- arguments to something of type @ty@ loop :: Type -> (Elims -> Term) -> Elims -> TCM Term - loop ty f = loop' ty f f - -- We duplicate @f@ because we don't want the parameters to be reconstructed in - -- type, since it would cause type-checking error when running @checkInternal'@. - -- The first one @fTe@ is for term, the other one @fTy@ for type. - loop' ty fTe _ [] = do - reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> (pretty $ fTe []) - return $ fTe [] - loop' ty fTe fTy (Apply u:es) = do + loop ty f [] = do + reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> pretty (f []) + return $ f [] + loop ty f (Apply u:es) = do reportSDoc "tc.reconstruct" 50 $ "The type before app is:" <+> pretty ty - reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (fTe []) + reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (f []) uu <- dropParameters u reportSDoc "tc.reconstruct" 50 $ "The app is:" <+> pretty uu ty' <- piApplyM ty uu reportSDoc "tc.reconstruct" 50 $ "The type after app is:" <+> pretty ty' - loop' ty' (fTe . (Apply u :)) (fTy . (Apply uu :)) es - loop' ty fTe fTy (Proj o p:es) = do + loop ty' (f . (Apply u :)) es + loop ty f (Proj o p:es) = do reportSDoc "tc.reconstruct" 50 $ "The type is:" <+> pretty ty - reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (fTe []) + reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (f []) reportSDoc "tc.reconstruct" 50 $ "The proj is:" <+> prettyTCM p - ty' <- reduce ty - case unEl ty' of - Def r pars -> do - ~(Just (El _ (Pi _ b))) <- getDefType p ty' - tyProj <- defType <$> getConstInfo p - let reconstructWithoutPostFixing = reconstructAction { elimViewAction = elimView NoPostfix } - let hiddenPs = map Apply $ mapHide tyProj $ fromMaybe __IMPOSSIBLE__ $ - allApplyElims pars - reportSDoc "tc.reconstruct" 50 $ "The params are" <+> pretty hiddenPs - ((_,Def p psAfterAct),_) <- inferSpine' act tyProj (Def p []) (Def p []) hiddenPs - ((_,projWithPars),_) <- inferSpine' reconstructWithoutPostFixing tyProj (Def p []) (Def p []) psAfterAct - reportSDoc "tc.reconstruct" 50 $ "Spine infered" <+> pretty projWithPars - let fTe' x = applyWithoutReversing projWithPars ((Apply $ defaultArg $ fTe []):x) - loop' (absApp b (fTy [])) fTe' (fTy . (Proj o p:)) es - _ -> __IMPOSSIBLE__ - loop' ty _ _ (IApply {}:vs) = __IMPOSSIBLE__ - - applyWithoutReversing :: Term -> Elims -> Term - applyWithoutReversing (Var i es) ess = Var i (es++ess) - applyWithoutReversing (Def n es) ess = Def n (es++ess) - applyWithoutReversing (Con h i es) ess = Con h i (es++ess) - applyWithoutReversing (MetaV i es) ess = MetaV i (es++ess) - applyWithoutReversing (Dummy s es) ess = Dummy s (es++ess) - applyWithoutReversing _ _ = __IMPOSSIBLE__ + pars <- extractParameters p ty + ~(Just (El _ (Pi _ b))) <- getDefType p =<< reduce ty + let fTm = f [] + fe <- dropParameters fTm + loop (absApp b fe) (Def p . (map Apply pars ++) . (Apply (defaultArg fTm) :)) es + loop ty _ (IApply {}:vs) = __IMPOSSIBLE__ - mapHide (El _ (Pi a b)) (p:tl) = - applyWhen (getHiding a == Hidden) hideAndRelParams p : mapHide (unAbs b) tl - mapHide t l = l +-- Extract the parameters from the type of a constructor +-- application or the type of the principal argument of a +-- projection. +extractParameters :: QName -> Type -> TCM Args +extractParameters q ty = reduce (unEl ty) >>= \case + Def d prePs -> do + dt <- defType <$> getConstInfo d + reportSDoc "tc.reconstruct" 50 $ "Here we start infering spine" + ((_,Def _ postPs),_) <- inferSpine' reconstructAction dt (Def d []) (Def d []) prePs + reportSDoc "tc.reconstruct" 50 $ "The spine has been inferred:" <+> pretty postPs + info <- getConstInfo q + let mkParam = hideAndRelParams + . isApplyElim' __IMPOSSIBLE__ + if -- Case: data or record constructor + | Constructor{ conPars = n } <- theDef info -> + return $ map mkParam $ take n postPs + -- Case: regular projection + | isProperProjection (theDef info) -> + return $ map mkParam postPs + -- Case: projection-like function + | otherwise -> do + TelV tel _ <- telViewUpTo (size postPs) $ defType info + return $ zipWith ($>) (teleArgs tel :: Args) $ map (unArg . isApplyElim' __IMPOSSIBLE__) postPs + _ -> __IMPOSSIBLE__ dropParameters :: TermLike a => a -> TCM a dropParameters = traverseTermM $ 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 @@ -178,8 +178,8 @@ -- inferred eta. _ | Just (ch, b) <- eta -> yesEtaCase b ch [(c, b)] | not comatch -> -- possible eta-match - getConstructorInfo c >>= \ case - RecordCon pm YesEta fs -> yesEtaCase b $ + getConstructorInfo' c >>= \ case + Just (RecordCon pm YesEta fs) -> yesEtaCase b $ ConHead c (IsRecord pm) Inductive (map argFromDom fs) _ -> noEtaCase _ -> noEtaCase 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 @@ -2,14 +2,18 @@ module Agda.TypeChecking.Records where +import Prelude hiding (null) + import Control.Monad import Control.Monad.Except import Control.Monad.Trans.Maybe import Control.Monad.Writer +import Control.Applicative import Data.Bifunctor import qualified Data.List as List import Data.Maybe +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap @@ -17,6 +21,7 @@ import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Concrete (FieldAssignment'(..)) import Agda.Syntax.Abstract.Name +import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn) import Agda.Syntax.Internal as I import Agda.Syntax.Position import Agda.Syntax.Scope.Base (isNameInScope) @@ -29,11 +34,14 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings +import {-# SOURCE #-} Agda.TypeChecking.Primitive.Cubical.Base (isCubicalSubtype) import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike (eligibleForProjectionLike) import Agda.Utils.Either -import Agda.Utils.Functor (for, ($>)) +import Agda.Utils.Function (applyWhen) +import Agda.Utils.Functor (for, ($>), (<&>)) +import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad @@ -395,10 +403,23 @@ IApply{} -> __IMPOSSIBLE__ -- | Check if a name refers to an eta expandable record. +-- +-- The answer is no for a record type with an erased constructor +-- unless the current quantity is \"erased\". {-# SPECIALIZE isEtaRecord :: QName -> TCM Bool #-} {-# SPECIALIZE isEtaRecord :: QName -> ReduceM Bool #-} isEtaRecord :: HasConstInfo m => QName -> m Bool -isEtaRecord r = maybe False ((YesEta ==) . recEtaEquality) <$> isRecord r +isEtaRecord r = do + isRec <- isRecord r + case isRec of + 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 isEtaCon :: HasConstInfo m => QName -> m Bool isEtaCon c = getConstInfo' c >>= \case @@ -457,30 +478,31 @@ r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) $ NoEta pat } _ -> __IMPOSSIBLE__ +-- | Turn on eta for non-recursive and inductive guarded recursive records, +-- unless user declared otherwise. +-- Projections do not preserve guardedness. +updateEtaForRecord :: QName -> TCM () +updateEtaForRecord q = whenM etaEnabled $ do + + -- Do we need to switch on eta for record q? + switchEta <- getConstInfo q <&> theDef <&> \case + Record{ recInduction = ind, recEtaEquality' = eta } + | Inferred NoEta{} <- eta, ind /= Just CoInductive -> True + | otherwise -> False + _ -> __IMPOSSIBLE__ + + when switchEta $ do + modifySignature $ updateDefinition q $ over (lensTheDef . lensRecord) $ \ d -> + d{ _recEtaEquality' = Inferred YesEta } + -- | Turn on eta for inductive guarded recursive records. -- Projections do not preserve guardedness. recursiveRecord :: QName -> TCM () -recursiveRecord q = do - ok <- etaEnabled - modifySignature $ updateDefinition q $ updateTheDef $ \case - r@Record{ recInduction = ind, recEtaEquality' = eta } -> - r { recEtaEquality' = eta' } - where - eta' | ok, Inferred NoEta{} <- eta, ind /= Just CoInductive = Inferred YesEta - | otherwise = eta - _ -> __IMPOSSIBLE__ +recursiveRecord = updateEtaForRecord -- | Turn on eta for non-recursive record, unless user declared otherwise. nonRecursiveRecord :: QName -> TCM () -nonRecursiveRecord q = whenM etaEnabled $ do - -- Do nothing if eta is disabled by option. - modifySignature $ updateDefinition q $ updateTheDef $ \case - r@Record{ recInduction = ind, recEtaEquality' = Inferred (NoEta _) } - | ind /= Just CoInductive -> - r { recEtaEquality' = Inferred YesEta } - r@Record{} -> r - _ -> __IMPOSSIBLE__ - +nonRecursiveRecord = updateEtaForRecord -- | Check whether record type is marked as recursive. -- @@ -508,7 +530,7 @@ -- -- Postcondition: @Δ = Γ₁, Γ', Γ₂[c Γ']@ and @Γ ⊢ σ : Δ@ and @Δ ⊢ τ : Γ@. -expandRecordVar :: Int -> Telescope -> TCM (Maybe (Telescope, Substitution, Substitution, Telescope)) +expandRecordVar :: PureTCM m => Int -> Telescope -> m (Maybe (Telescope, Substitution, Substitution, Telescope)) expandRecordVar i gamma0 = do -- Get the context with last variable added last in list. let gamma = telToList gamma0 @@ -759,59 +781,117 @@ -- Precondition: The name should refer to a record type, and the -- arguments should be the parameters to the type. isSingletonRecord :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool -isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps +isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps mempty isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool -isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps +isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps mempty -- | Return the unique (closed) inhabitant if exists. -- In case of counting irrelevance in, the returned inhabitant -- contains dummy terms. -isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m) - => Bool -> QName -> Args -> m (Maybe Term) -isSingletonRecord' regardIrrelevance r ps = do - reportSDoc "tc.meta.eta" 30 $ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?" - isRecord r >>= \case - Nothing -> return Nothing - Just def -> do - fmap (mkCon (recConHead def) ConOSystem) <$> check (recTel def `apply` ps) +isSingletonRecord' + :: forall m. (PureTCM m, MonadBlock m) + => Bool -- ^ Should disregard irrelevant fields? + -> QName -- ^ Name of record type to check. + -> Args -- ^ Parameters given to the record type. + -> Set QName -- ^ Non-terminating record types we already encountered. + -- These are considered as non-singletons, + -- otherwise we would construct an infinite inhabitant (in an infinite time...). + -> m (Maybe Term) -- ^ The unique inhabitant, if any. May contain dummy terms in irrelevant positions. +isSingletonRecord' regardIrrelevance r ps rs = do + reportSDoc "tc.meta.eta" 30 $ vcat + [ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?" + , " already visited:" <+> hsep (map prettyTCM $ Set.toList rs) + ] + -- Andreas, 2022-03-10, issue #5823 + -- We need to make sure we are not infinitely unfolding records, so we only expand each once, + -- and keep track of the recursive ones we have already seen. + if r `Set.member` rs then no else do + caseMaybeM (isRecord r) no $ \ def -> do + -- We might not know yet whether a record type is recursive because the positivity checker hasn't run yet. + -- In this case, we pessimistically consider the record type to be recursive (@True@). + let recursive = maybe True (not . null) $ recMutual def + -- Andreas, 2022-03-23, issue #5823 + -- We may pass through terminating record types as often as we want. + -- If the termination checker has not run yet, we pessimistically consider the record type + -- to be non-terminating. + let nonTerminating = maybe True not $ recTerminates def + reportSDoc "tc.meta.eta" 30 $ vcat + [ hsep [ prettyTCM r, "is recursive :", prettyTCM recursive ] + , hsep [ prettyTCM r, "is non-terminating:", prettyTCM nonTerminating ] + ] + fmap (mkCon (recConHead def) ConOSystem) <$> do + check (applyWhen (recursive && nonTerminating) (Set.insert r) rs) $ recTel def `apply` ps where - check :: Telescope -> m (Maybe [Arg Term]) - check tel = do + -- Check that all entries of the constructor telescope are singletons. + check :: Set QName -> Telescope -> m (Maybe [Arg Term]) + check rs tel = do reportSDoc "tc.meta.eta" 30 $ "isSingletonRecord' checking telescope " <+> prettyTCM tel case tel of - EmptyTel -> return $ Just [] + EmptyTel -> yes ExtendTel dom tel -> ifM (return regardIrrelevance `and2M` isIrrelevantOrPropM dom) {-then-} - (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check) + (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check rs) {-else-} $ do - isSing <- isSingletonType' regardIrrelevance $ unDom dom - case isSing of - Nothing -> return Nothing - (Just v) -> underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check + caseMaybeM (isSingletonType' regardIrrelevance (unDom dom) rs) no $ \ v -> do + underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check rs + no = return Nothing + yes = return $ Just [] -- | Check whether a type has a unique inhabitant and return it. -- Can be blocked by a metavar. isSingletonType :: (PureTCM m, MonadBlock m) => Type -> m (Maybe Term) -isSingletonType = isSingletonType' False +isSingletonType t = isSingletonType' False t mempty -- | Check whether a type has a unique inhabitant (irrelevant parts ignored). -- Can be blocked by a metavar. isSingletonTypeModuloRelevance :: (PureTCM m, MonadBlock m) => Type -> m Bool -isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t +isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t mempty -isSingletonType' :: (PureTCM m, MonadBlock m) => Bool -> Type -> m (Maybe Term) -isSingletonType' regardIrrelevance t = do +isSingletonType' + :: forall m. (PureTCM m, MonadBlock m) + => Bool -- ^ Should disregard irrelevant fields? + -> Type -- ^ Type to check. + -> Set QName -- ^ Non-terminating record typess we already encountered. + -- These are considered as non-singletons, + -- otherwise we would construct an infinite inhabitant (in an infinite time...). + -> m (Maybe Term) -- ^ The unique inhabitant, if any. May contain dummy terms in irrelevant positions. +isSingletonType' regardIrrelevance t rs = do TelV tel t <- telView t t <- abortIfBlocked t addContext tel $ do - res <- isRecordType t - case res of - Just (r, ps, def) | YesEta <- recEtaEquality def -> do - fmap (abstract tel) <$> isSingletonRecord' regardIrrelevance r ps - _ -> return Nothing + let + -- Easy case: η for records. + record :: m (Maybe Term) + record = runMaybeT $ do + (r, ps, def) <- MaybeT $ isRecordType t + guard (YesEta == recEtaEquality def) + abstract tel <$> MaybeT (isSingletonRecord' regardIrrelevance r ps rs) + + -- Slightly harder case: η for Sub {level} tA phi elt. + -- tA : Type level, phi : I, elt : Partial phi tA. + subtype :: m (Maybe Term) + subtype = runMaybeT $ do + (level, tA, phi, elt) <- MaybeT $ isCubicalSubtype t + subin <- MaybeT $ getBuiltinName' builtinSubIn + itIsOne <- MaybeT $ getBuiltinName' builtinIsOne + phiV <- intervalView phi + case phiV of + -- If phi = i1, then inS (elt 1=1) is the only inhabitant. + IOne -> do + let + argH = Arg $ setHiding Hidden defaultArgInfo + it = elt `apply` [defaultArg (Def itIsOne [])] + pure (Def subin [] `apply` [argH level, argH tA, argH phi, defaultArg it]) + -- Otherwise we're blocked + OTerm phi' -> patternViolation (unblockOnAnyMetaIn phi') + -- This fails the MaybeT: we're not looking at a + -- definitional singleton. + _ -> fail "" + + (<|>) <$> record <*> subtype -- | Checks whether the given term (of the given type) is beta-eta-equivalent -- to a variable. Returns just the de Bruijn-index of the variable if it is, 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 @@ -1,6 +1,29 @@ {-# LANGUAGE NondecreasingIndentation #-} -module Agda.TypeChecking.Reduce where +module Agda.TypeChecking.Reduce + -- Meta instantiation + ( Instantiate, instantiate', instantiate, instantiateWhen + -- Recursive meta instantiation + , InstantiateFull, instantiateFull', instantiateFull + , instantiateFullExceptForDefinitions + -- Check for meta (no reduction) + , IsMeta, isMeta + -- Reduction and blocking + , Reduce, reduce', reduceB', reduce, reduceB, reduceWithBlocker, reduceIApply' + , reduceDefCopy, reduceDefCopyTCM + , reduceHead + , slowReduceTerm + , unfoldCorecursion, unfoldCorecursionE + , unfoldDefinitionE, unfoldDefinitionStep + , unfoldInlined + , appDef', appDefE' + , abortIfBlocked, ifBlocked, isBlocked + -- Simplification + , Simplify, simplify, simplifyBlocked' + -- Normalization + , Normalise, normalise', normalise + , slowNormaliseArgs + ) where import Control.Monad ( (>=>), void ) @@ -56,6 +79,18 @@ instantiateFull :: (InstantiateFull a, MonadReduce m) => a -> m a instantiateFull = liftReduce . instantiateFull' +-- | A variant of 'instantiateFull' that only instantiates those +-- meta-variables that satisfy the predicate. + +instantiateWhen :: + (InstantiateFull a, MonadReduce m) => + (MetaId -> ReduceM Bool) -> + a -> m a +instantiateWhen p = + liftReduce . + localR (\env -> env { redPred = Just p }) . + instantiateFull' + reduce :: (Reduce a, MonadReduce m) => a -> m a reduce = liftReduce . reduce' @@ -80,10 +115,11 @@ normalise :: (Normalise a, MonadReduce m) => a -> m a normalise = liftReduce . normalise' --- | Normalise the given term but also preserve blocking tags --- TODO: implement a more efficient version of this. -normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t) -normaliseB = normalise >=> reduceB +-- UNUSED +-- -- | Normalise the given term but also preserve blocking tags +-- -- TODO: implement a more efficient version of this. +-- normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t) +-- normaliseB = normalise >=> reduceB simplify :: (Simplify a, MonadReduce m) => a -> m a simplify = liftReduce . simplify' @@ -91,9 +127,9 @@ -- | Meaning no metas left in the instantiation. isFullyInstantiatedMeta :: MetaId -> TCM Bool isFullyInstantiatedMeta m = do - mv <- lookupMeta m - case mvInstantiation mv of - InstV _tel v -> noMetas <$> instantiateFull v + inst <- lookupMetaInstantiation m + case inst of + InstV inst -> noMetas <$> instantiateFull (instBody inst) _ -> return False -- | Blocking on all blockers. @@ -139,34 +175,64 @@ instance (Instantiate a, Instantiate b,Instantiate c) => Instantiate (a,b,c) where instantiate' (x,y,z) = (,,) <$> instantiate' x <*> instantiate' y <*> instantiate' z +-- | Run the second computation if the 'redPred' predicate holds for +-- the given meta-variable (or if the predicate is not defined), and +-- otherwise the first computation. + +ifPredicateDoesNotHoldFor :: + MetaId -> ReduceM a -> ReduceM a -> ReduceM a +ifPredicateDoesNotHoldFor m doesNotHold holds = do + pred <- redPred <$> askR + case pred of + Nothing -> holds + Just p -> ifM (p m) holds doesNotHold + instance Instantiate Term where - instantiate' t@(MetaV x es) = do + instantiate' t@(MetaV x es) = ifPredicateDoesNotHoldFor x (return t) $ do blocking <- view stInstantiateBlocking <$> getTCState - mv <- lookupMeta x - let mi = mvInstantiation mv + m <- lookupMeta x + case m of + Just (Left rmv) -> cont (rmvInstantiation rmv) - case mi of - InstV tel v -> instantiate' inst - where - -- A slight complication here is that the meta might be underapplied, - -- in which case we have to build the lambda abstraction before - -- applying the substitution, or overapplied in which case we need to - -- fall back to applyE. - (es1, es2) = splitAt (length tel) es - vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1 - rho = vs1 ++# wkS (length vs1) idS - -- really should be .. ++# emptyS but using wkS makes it reduce to idS - -- when applicable - -- specification: inst == foldr mkLam v tel `applyE` es - inst = applySubst rho (foldr mkLam v $ drop (length es1) tel) `applyE` es2 - _ | Just m' <- mvTwin mv, blocking -> do - instantiate' (MetaV m' es) - Open -> return t - OpenInstance -> return t - BlockedConst u | blocking -> instantiate' . unBrave $ BraveTerm u `applyE` es - | otherwise -> return t - PostponedTypeCheckingProblem _ -> return t + Just (Right mv) -> case mvInstantiation mv of + InstV inst -> cont inst + + _ | Just m' <- mvTwin mv, blocking -> + instantiate' (MetaV m' es) + + Open -> return t + + OpenInstance -> return t + + BlockedConst u + | blocking -> instantiate' . unBrave $ + BraveTerm u `applyE` es + | otherwise -> return t + + PostponedTypeCheckingProblem _ -> return t + + Nothing -> __IMPOSSIBLE_VERBOSE__ + ("Meta-variable not found: " ++ prettyShow x) + where + cont i = instantiate' inst + where + -- A slight complication here is that the meta might be underapplied, + -- in which case we have to build the lambda abstraction before + -- applying the substitution, or overapplied in which case we need to + -- fall back to applyE. + (es1, es2) = splitAt (length (instTel i)) es + vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1 + rho = vs1 ++# wkS (length vs1) idS + -- really should be .. ++# emptyS but using wkS makes it reduce to idS + -- when applicable + -- specification: + -- inst == foldr mkLam (instBody i) (instTel i) `applyE` es + inst = + applySubst rho + (foldr mkLam (instBody i) $ drop (length es1) (instTel i)) + `applyE` es2 + instantiate' (Level l) = levelTm <$> instantiate' l instantiate' (Sort s) = Sort <$> instantiate' s instantiate' t = return t @@ -192,6 +258,7 @@ instantiate' b@(UnblockOnMeta x) = ifM (isInstantiatedMeta x) (return alwaysUnblock) (return b) instantiate' b@UnblockOnProblem{} = return b + instantiate' b@UnblockOnDef{} = return b instance Instantiate Sort where instantiate' = \case @@ -203,7 +270,7 @@ s -> return s instance (Instantiate t, Instantiate e) => Instantiate (Dom' t e) where - instantiate' (Dom i fin n tac x) = Dom i fin n <$> instantiate' tac <*> instantiate' x + instantiate' (Dom i n b tac x) = Dom i n b <$> instantiate' tac <*> instantiate' x instance Instantiate a => Instantiate (Closure a) where instantiate' cl = do @@ -231,9 +298,10 @@ instantiate' (CheckLockedVars a b c d) = CheckLockedVars <$> instantiate' a <*> instantiate' b <*> instantiate' c <*> instantiate' d instantiate' (UnquoteTactic t h g) = UnquoteTactic <$> instantiate' t <*> instantiate' h <*> instantiate' g + instantiate' (CheckDataSort q s) = CheckDataSort q <$> instantiate' s instantiate' c@CheckMetaInst{} = return c instantiate' (CheckType t) = CheckType <$> instantiate' t - instantiate' (UsableAtModality mod t) = UsableAtModality mod <$> instantiate' t + instantiate' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> instantiate' ms <*> instantiate' t instance Instantiate CompareAs where instantiate' (AsTermsOf a) = AsTermsOf <$> instantiate' a @@ -332,27 +400,42 @@ reduceB' (El s t) = workOnTypes $ fmap (El s) <$> reduceB' t instance Reduce Sort where - reduce' s = do + reduceB' s = do s <- instantiate' s + let done | MetaS x _ <- s = return $ blocked x s + | otherwise = return $ notBlocked s case s of - PiSort a s1 s2 -> do - (s1' , s2') <- reduce' (s1 , s2) - maybe (return $ PiSort a s1' s2') reduce' $ piSort' a s1' s2' - FunSort s1 s2 -> do - (s1' , s2') <- reduce (s1 , s2) - maybe (return $ FunSort s1' s2') reduce' $ funSort' s1' s2' - UnivSort s' -> do - s' <- reduce' s' - caseMaybe (univSort' s') (return $ UnivSort s') reduce' - Prop s' -> Prop <$> reduce' s' - Type s' -> Type <$> reduce' s' - Inf f n -> return $ Inf f n - SSet s' -> SSet <$> reduce' s' - SizeUniv -> return SizeUniv - LockUniv -> return LockUniv - MetaS x es -> return s - DefS d es -> return s -- postulated sorts do not reduce - DummyS{} -> return s + PiSort a s1 s2 -> reduceB' (s1 , s2) >>= \case + Blocked b (s1',s2') -> return $ Blocked b $ PiSort a s1' s2' + NotBlocked _ (s1',s2') -> do + -- Jesper, 2022-10-12: do instantiateFull here because + -- `piSort'` does checking of free variables, and if we + -- don't instantiate we might end up blocking on a solved + -- metavariable. + s2' <- instantiateFull s2' + case piSort' a s1' s2' of + Left b -> return $ Blocked b $ PiSort a s1' s2' + Right s -> reduceB' s + FunSort s1 s2 -> reduceB' (s1 , s2) >>= \case + Blocked b (s1',s2') -> return $ Blocked b $ FunSort s1' s2' + NotBlocked _ (s1',s2') -> case funSort' s1' s2' of + Left b -> return $ Blocked b $ FunSort s1' s2' + Right s -> reduceB' s + UnivSort s1 -> reduceB' s1 >>= \case + Blocked b s1' -> return $ Blocked b $ UnivSort s1' + NotBlocked _ s1' -> case univSort' s1' of + Left b -> return $ Blocked b $ UnivSort s1' + Right s -> reduceB' s + Prop l -> notBlocked . Prop <$> reduce l + Type l -> notBlocked . Type <$> reduce l + Inf f n -> done + SSet l -> notBlocked . SSet <$> reduce l + SizeUniv -> done + LockUniv -> done + IntervalUniv -> done + MetaS x es -> done + DefS d es -> done -- postulated sorts do not reduce + DummyS{} -> done instance Reduce Elim where reduce' (Apply v) = Apply <$> reduce' v @@ -367,13 +450,17 @@ reduceB' (Plus n l) = fmap (Plus n) <$> reduceB' l instance (Subst a, Reduce a) => Reduce (Abs a) where - reduce' b@(Abs x _) = Abs x <$> underAbstraction_ b reduce' - reduce' (NoAbs x v) = NoAbs x <$> reduce' v + reduceB' b@(Abs x _) = fmap (Abs x) <$> underAbstraction_ b reduceB' + reduceB' (NoAbs x v) = fmap (NoAbs x) <$> reduceB' v -- Lists are never blocked instance Reduce t => Reduce [t] where reduce' = traverse reduce' +-- Maybes are never blocked +instance Reduce t => Reduce (Maybe t) where + reduce' = traverse reduce' + instance Reduce t => Reduce (Arg t) where reduce' a = case getRelevance a of Irrelevant -> return a -- Don't reduce' irr. args!? @@ -448,7 +535,7 @@ MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v) _ -> maybeFast v where - isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x + isOpen x = isOpenMeta <$> lookupMetaInstantiation x maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v) slowReduceTerm :: Term -> ReduceM (Blocked Term) @@ -470,7 +557,7 @@ v <- flip reduceIApply es $ unfoldDefinitionE False reduceB' (Con c ci []) (conName c) es traverse reduceNat v - Sort s -> fmap Sort <$> reduceB' s + Sort s -> done Level l -> ifM (SmallSet.member LevelReductions <$> asksTC envAllowedReductions) {- then -} (fmap levelTm <$> reduceB' l) {- else -} done @@ -575,7 +662,7 @@ then reducePrimitive x v0 f es pf dontUnfold cls (defCompiled info) rewr else noReduction $ notBlocked v - PrimitiveSort{ primSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es + PrimitiveSort{ primSortSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es _ -> do if or @@ -753,7 +840,7 @@ appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) appDefE_ f v0 cls mcc rewr args = localTC (\ e -> e { envAppDef = Just f }) $ - maybe (appDefE' v0 cls rewr args) + maybe (appDefE'' v0 cls rewr args) (\cc -> appDefE v0 cc rewr args) mcc @@ -771,11 +858,17 @@ NoReduction es' -> rewrite (void es') (applyE v) rewr (ignoreBlocking es') -- | Apply a defined function to it's arguments, using the original clauses. -appDef' :: Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term) -appDef' v cls rewr args = appDefE' v cls rewr $ map (fmap Apply) args +appDef' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term) +appDef' f v cls rewr args = appDefE' f v cls rewr $ map (fmap Apply) args -appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) -appDefE' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do +appDefE' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) +appDefE' f v cls rewr es = + localTC (\ e -> e { envAppDef = Just f }) $ + appDefE'' v cls rewr es + +-- | Expects @'envAppDef' = Just f@ in 'TCEnv' to be able to report @'MissingClauses' f@. +appDefE'' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) +appDefE'' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do goCls cls $ map ignoreReduced es where goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term) @@ -787,7 +880,9 @@ -- the remaining clauses (see Issue 907). -- Andrea(s), 2014-12-05: We return 'MissingClauses' here, since this -- is the most conservative reason. - [] -> rewrite (NotBlocked MissingClauses ()) (applyE v) rewr es + [] -> do + f <- fromMaybe __IMPOSSIBLE__ <$> asksTC envAppDef + rewrite (NotBlocked (MissingClauses f) ()) (applyE v) rewr es cl : cls -> do let pats = namedClausePats cl body = clauseBody cl @@ -840,9 +935,10 @@ reduce' (UnquoteTactic t h g) = UnquoteTactic <$> reduce' t <*> reduce' h <*> reduce' g reduce' (CheckLockedVars a b c d) = CheckLockedVars <$> reduce' a <*> reduce' b <*> reduce' c <*> reduce' d + reduce' (CheckDataSort q s) = CheckDataSort q <$> reduce' s reduce' c@CheckMetaInst{} = return c reduce' (CheckType t) = CheckType <$> reduce' t - reduce' (UsableAtModality mod t) = UsableAtModality mod <$> reduce' t + reduce' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> reduce' ms <*> reduce' t instance Reduce CompareAs where reduce' (AsTermsOf a) = AsTermsOf <$> reduce' a @@ -919,9 +1015,9 @@ Def f vs -> iapp vs $ do let keepGoing simp v = return (simp, notBlocked v) (simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs - traceSDoc "tc.simplify'" 90 ( - text ("simplify': unfolding definition returns " ++ show simpl) - <+> pretty (ignoreBlocking v)) $ do + when (simpl == YesSimplification) $ + reportSDoc "tc.simplify'" 90 $ + pretty f <+> text ("simplify': unfolding definition returns " ++ show simpl) <+> pretty (ignoreBlocking v) case simpl of YesSimplification -> simplifyBlocked' v -- Dangerous, but if @simpl@ then @v /= Def f vs@ NoSimplification -> Def f <$> simplify' vs @@ -955,6 +1051,7 @@ SSet s -> SSet <$> simplify' s SizeUniv -> return s LockUniv -> return s + IntervalUniv -> return s MetaS x es -> MetaS x <$> simplify' es DefS d es -> DefS d <$> simplify' es DummyS{} -> return s @@ -1005,9 +1102,10 @@ simplify' (UnquoteTactic t h g) = UnquoteTactic <$> simplify' t <*> simplify' h <*> simplify' g simplify' (CheckLockedVars a b c d) = CheckLockedVars <$> simplify' a <*> simplify' b <*> simplify' c <*> simplify' d + simplify' (CheckDataSort q s) = CheckDataSort q <$> simplify' s simplify' c@CheckMetaInst{} = return c simplify' (CheckType t) = CheckType <$> simplify' t - simplify' (UsableAtModality mod t) = UsableAtModality mod <$> simplify' t + simplify' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> simplify' ms <*> simplify' t instance Simplify CompareAs where simplify' (AsTermsOf a) = AsTermsOf <$> simplify' a @@ -1104,6 +1202,7 @@ SSet s -> SSet <$> normalise' s SizeUniv -> return SizeUniv LockUniv -> return LockUniv + IntervalUniv -> return IntervalUniv MetaS x es -> return s DefS d es -> return s DummyS{} -> return s @@ -1185,9 +1284,10 @@ normalise' (UnquoteTactic t h g) = UnquoteTactic <$> normalise' t <*> normalise' h <*> normalise' g normalise' (CheckLockedVars a b c d) = CheckLockedVars <$> normalise' a <*> normalise' b <*> normalise' c <*> normalise' d + normalise' (CheckDataSort q s) = CheckDataSort q <$> normalise' s normalise' c@CheckMetaInst{} = return c normalise' (CheckType t) = CheckType <$> normalise' t - normalise' (UsableAtModality mod t) = UsableAtModality mod <$> normalise' t + normalise' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> normalise' ms <*> normalise' t instance Normalise CompareAs where normalise' (AsTermsOf a) = AsTermsOf <$> normalise' a @@ -1311,6 +1411,7 @@ Inf _ _ -> return s SizeUniv -> return s LockUniv -> return s + IntervalUniv -> return s MetaS x es -> MetaS x <$> instantiateFull' es DefS d es -> DefS d <$> instantiateFull' es DummyS{} -> return s @@ -1346,13 +1447,13 @@ instance InstantiateFull Substitution where instantiateFull' sigma = case sigma of - IdS -> return IdS - EmptyS err -> return $ EmptyS err - Wk n sigma -> Wk n <$> instantiateFull' sigma - Lift n sigma -> Lift n <$> instantiateFull' sigma - Strengthen bot sigma -> Strengthen bot <$> instantiateFull' sigma - t :# sigma -> consS <$> instantiateFull' t - <*> instantiateFull' sigma + IdS -> return IdS + EmptyS err -> return $ EmptyS err + Wk n sigma -> Wk n <$> instantiateFull' sigma + Lift n sigma -> Lift n <$> instantiateFull' sigma + Strengthen bot n sigma -> Strengthen bot n <$> instantiateFull' sigma + t :# sigma -> consS <$> instantiateFull' t + <*> instantiateFull' sigma instance InstantiateFull ConPatternInfo where instantiateFull' i = instantiateFull' (conPType i) <&> \ t -> i { conPType = t } @@ -1371,7 +1472,7 @@ instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a instance (InstantiateFull t, InstantiateFull e) => InstantiateFull (Dom' t e) where - instantiateFull' (Dom i fin n tac x) = Dom i fin n <$> instantiateFull' tac <*> instantiateFull' x + instantiateFull' (Dom i n b tac x) = Dom i n b <$> instantiateFull' tac <*> instantiateFull' x -- Andreas, 2021-09-13, issue #5544, need to traverse @checkpoints@ map instance InstantiateFull t => InstantiateFull (Open t) where @@ -1418,9 +1519,10 @@ UnquoteTactic t g h -> UnquoteTactic <$> instantiateFull' t <*> instantiateFull' g <*> instantiateFull' h CheckLockedVars a b c d -> CheckLockedVars <$> instantiateFull' a <*> instantiateFull' b <*> instantiateFull' c <*> instantiateFull' d + CheckDataSort q s -> CheckDataSort q <$> instantiateFull' s c@CheckMetaInst{} -> return c CheckType t -> CheckType <$> instantiateFull' t - UsableAtModality mod t -> UsableAtModality mod <$> instantiateFull' t + UsableAtModality cc ms mod t -> flip (UsableAtModality cc) mod <$> instantiateFull' ms <*> instantiateFull' t instance InstantiateFull CompareAs where instantiateFull' (AsTermsOf a) = AsTermsOf <$> instantiateFull' a @@ -1459,9 +1561,11 @@ instance InstantiateFull NLPSort where instantiateFull' (PType x) = PType <$> instantiateFull' x instantiateFull' (PProp x) = PProp <$> instantiateFull' x + instantiateFull' (PSSet x) = PSSet <$> instantiateFull' x instantiateFull' (PInf f n) = return $ PInf f n instantiateFull' PSizeUniv = return PSizeUniv instantiateFull' PLockUniv = return PLockUniv + instantiateFull' PIntervalUniv = return PIntervalUniv instance InstantiateFull RewriteRule where instantiateFull' (RewriteRule q gamma f ps rhs t c) = @@ -1535,7 +1639,7 @@ instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs instance InstantiateFull Clause where - instantiateFull' (Clause rl rf tel ps b t catchall exact recursive unreachable ell) = + instantiateFull' (Clause rl rf tel ps b t catchall exact recursive unreachable ell wm) = Clause rl rf <$> instantiateFull' tel <*> instantiateFull' ps <*> instantiateFull' b @@ -1545,7 +1649,24 @@ <*> return recursive <*> return unreachable <*> return ell + <*> return wm +instance InstantiateFull Instantiation where + instantiateFull' (Instantiation a b) = + Instantiation a <$> instantiateFull' b + +instance InstantiateFull (Judgement MetaId) where + instantiateFull' (HasType a b c) = + HasType a b <$> instantiateFull' c + instantiateFull' (IsSort a b) = + IsSort a <$> instantiateFull' b + +instance InstantiateFull RemoteMetaVariable where + instantiateFull' (RemoteMetaVariable a b c) = RemoteMetaVariable + <$> instantiateFull' a + <*> return b + <*> instantiateFull' c + instance InstantiateFull Interface where instantiateFull' i = do defs <- instantiateFull' (i ^. intSignature . sigDefinitions) @@ -1556,16 +1677,17 @@ instantiateFullExceptForDefinitions' :: Interface -> ReduceM Interface instantiateFullExceptForDefinitions' - (Interface h s ft ms mod scope inside sig display userwarn importwarn - b foreignCode highlighting libPragmas filePragmas usedOpts patsyns - warnings partialdefs) = - Interface h s ft ms mod scope inside + (Interface h s ft ms mod tlmod scope inside sig metas display userwarn + importwarn b foreignCode highlighting libPragmas filePragmas + usedOpts patsyns warnings partialdefs) = + 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 @@ -1589,6 +1711,7 @@ instance InstantiateFull a => InstantiateFull (Builtin a) where instantiateFull' (Builtin t) = Builtin <$> instantiateFull' t instantiateFull' (Prim x) = Prim <$> instantiateFull' x + instantiateFull' b@(BuiltinRewriteRelations xs) = pure b instance InstantiateFull Candidate where instantiateFull' (Candidate q u t ov) = 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 @@ -35,13 +35,16 @@ module Agda.TypeChecking.Reduce.Fast ( fastReduce, fastNormalise ) where +import Prelude hiding ((!!)) + import Control.Applicative hiding (empty) import Control.Monad.ST import Control.Monad.ST.Unsafe (unsafeSTToIO, unsafeInterleaveST) +import qualified Data.HashMap.Strict as HMap import Data.Map (Map) import qualified Data.Map as Map -import qualified Data.IntMap as IntMap +import qualified Data.Map.Strict as MapS import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Semigroup ((<>)) @@ -138,7 +141,7 @@ Constructor{conSrcCon = c, conArity = n} -> pure CCon{cconSrcCon = c, cconArity = n} Function{funCompiled = Just cc, funClauses = _:_, funProjection = proj} -> pure CFun{ cfunCompiled = fastCompiledClauses bEnv cc - , cfunProjection = projOrig <$> proj } + , cfunProjection = projOrig <$> either (const Nothing) Just proj } Function{funClauses = []} -> pure CAxiom Function{} -> pure COther -- Incomplete definition Datatype{dataClause = Nothing} -> pure CTyCon @@ -181,7 +184,7 @@ "primFloatIsDenormalized" -> mkPrim 1 $ floatPred isDenormalized "primFloatIsNegativeZero" -> mkPrim 1 $ floatPred isNegativeZero "primFloatIsSafeInteger" -> mkPrim 1 $ floatPred isSafeInteger - "primFloatToWord64" -> mkPrim 1 $ \ [LitFloat a] -> word (doubleToWord64 a) + -- "primFloatToWord64" -- returns a maybe -- "primFloatToWord64Injective" -- identities are not literals "primNatToFloat" -> mkPrim 1 $ \ [LitNat a] -> float (fromIntegral a) -- "primIntToFloat" -- integers are not literals @@ -804,11 +807,15 @@ compileAndRun . traceDoc "-- fast reduce --" where -- Helpers to get information from the ReduceEnv. - metaStore = redSt rEnv ^. stMetaStore + localMetas = redSt rEnv ^. stSolvedMetaStore + remoteMetas = redSt rEnv ^. stImportedMetaStore -- Are we currently instance searching. In that case we don't fail hard on missing clauses. This -- is a (very unsatisfactory) work-around for #3870. speculative = redSt rEnv ^. stConsideringInstance - getMeta m = maybe __IMPOSSIBLE__ mvInstantiation (IntMap.lookup (metaId m) metaStore) + getMetaInst m = case MapS.lookup m localMetas of + Just mv -> Just (mvInstantiation mv) + Nothing -> InstV . rmvInstantiation <$> + HMap.lookup m remoteMetas partialDefs = runReduce getPartialDefs rewriteRules f = cdefRewriteRules (constInfo f) callByNeed = envCallByNeed (redEnv rEnv) && not (optCallByName $ redSt rEnv ^. stPragmaOptions) @@ -860,7 +867,7 @@ -- - Look up in the environment if variable -- - Perform a beta step if lambda and application elimination in the spine -- - Perform a record beta step if record constructor and projection elimination in the spine - runAM' s@(Eval cl@(Closure Unevaled t env spine) !ctrl) = {-# SCC "runAM.Eval" #-} + runAM' s@(Eval cl@(Closure Unevaled t env spine) ctrl) = {-# SCC "runAM.Eval" #-} case t of -- Case: definition. Enter 'Match' state if defined function or shift to evaluating an @@ -959,12 +966,17 @@ -- environment for the closure. Avoiding shifting spines for open metas -- save a bit of performance. MetaV m es -> evalIApplyAM spine ctrl $ - case getMeta m of - InstV xs t -> do + case getMetaInst m of + Nothing -> + runAM (Eval (mkValue (blocked m ()) cl) ctrl) + Just (InstV i) -> do spine' <- elimsToSpine env es - let (zs, env, !spine'') = buildEnv xs (spine' <> spine) - runAM (evalClosure (lams zs t) env spine'' ctrl) - _ -> runAM (Eval (mkValue (blocked m ()) cl) ctrl) + let (zs, env, !spine'') = buildEnv (instTel i) (spine' <> spine) + runAM (evalClosure (lams zs (instBody i)) env spine'' ctrl) + Just Open{} -> __IMPOSSIBLE__ + Just OpenInstance{} -> __IMPOSSIBLE__ + Just BlockedConst{} -> __IMPOSSIBLE__ + Just PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__ -- Case: unsupported. These terms are not handled by the abstract machine, so we fall back -- to slowReduceTerm for these. @@ -1251,7 +1263,7 @@ (spine0, Proj o p : spine1) -> case lookupCon p bs <|> ((`lookupCon` bs) =<< op) of Nothing - | f `elem` partialDefs -> stuckMatch (NotBlocked MissingClauses ()) stack ctrl + | f `elem` partialDefs -> stuckMatch (NotBlocked (MissingClauses f) ()) stack ctrl | otherwise -> __IMPOSSIBLE__ Just cc -> runAM (Match f cc (spine0 <> spine1) stack ctrl) where CFun{ cfunProjection = op } = cdefDef (constInfo p) @@ -1374,8 +1386,8 @@ failedMatch f (CatchAll cc spine : stack :> cl) ctrl = runAM (Match f cc spine (stack :> cl) ctrl) failedMatch f ([] :> cl) ctrl -- Bad work-around for #3870: don't fail hard during instance search. - | speculative = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl) - | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl) + | speculative = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl) + | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl) | hasRewriting = rewriteAM (Eval (mkValue (NotBlocked ReallyNotBlocked ()) cl) ctrl) -- See #5396 | otherwise = runReduce $ traceSLn "impossible" 10 ("Incomplete pattern matching when applying " ++ prettyShow f) diff --git a/src/full/Agda/TypeChecking/Reduce/Monad.hs b/src/full/Agda/TypeChecking/Reduce/Monad.hs --- a/src/full/Agda/TypeChecking/Reduce/Monad.hs +++ b/src/full/Agda/TypeChecking/Reduce/Monad.hs @@ -18,18 +18,20 @@ import System.IO.Unsafe import Agda.Syntax.Internal -import Agda.TypeChecking.Monad hiding - ( enterClosure, isInstantiatedMeta, verboseS, typeOfConst, lookupMeta, lookupMeta', constructorForm ) +import Agda.TypeChecking.Monad hiding (enterClosure, constructorForm) import Agda.TypeChecking.Substitute import Agda.Utils.Lens +import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty () --instance only instance HasBuiltins ReduceM where - getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useR stLocalBuiltins) - (Map.lookup b <$> useR stImportedBuiltins) + getBuiltinThing b = + liftM2 (unionMaybeWith unionBuiltin) + (Map.lookup b <$> useR stLocalBuiltins) + (Map.lookup b <$> useR stImportedBuiltins) constructorForm :: HasBuiltins m => Term -> m Term constructorForm v = do @@ -72,13 +74,13 @@ instance MonadDebug ReduceM where traceDebugMessage k n s cont = do - ReduceEnv env st <- askR + ReduceEnv env st _ <- askR unsafePerformIO $ do _ <- runTCM env st $ displayDebugMessage k n s return $ cont formatDebugMessage k n d = do - ReduceEnv env st <- askR + ReduceEnv env st _ <- askR unsafePerformIO $ do (s , _) <- runTCM env st $ formatDebugMessage k n d return $ return s @@ -86,14 +88,15 @@ verboseBracket k n s = applyWhenVerboseS k n $ bracket_ (openVerboseBracket k n s) (const $ closeVerboseBracket k n) - getVerbosity = defaultGetVerbosity - isDebugPrinting = defaultIsDebugPrinting - nowDebugPrinting = defaultNowDebugPrinting + getVerbosity = defaultGetVerbosity + getProfileOptions = defaultGetProfileOptions + isDebugPrinting = defaultIsDebugPrinting + nowDebugPrinting = defaultNowDebugPrinting instance HasConstInfo ReduceM where getRewriteRulesFor = defaultGetRewriteRulesFor getConstInfo' q = do - ReduceEnv env st <- askR + ReduceEnv env st _ <- askR defaultGetConstInfo st env q instance PureTCM ReduceM where 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 @@ -48,9 +48,12 @@ import Control.Monad +import Data.Foldable (toList) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List +import Data.Set (Set) +import qualified Data.Set as Set import Agda.Interaction.Options @@ -83,6 +86,7 @@ import qualified Agda.Utils.SmallSet as SmallSet import Agda.Utils.Impossible +import Agda.Utils.Either requireOptionRewriting :: TCM () requireOptionRewriting = @@ -152,6 +156,9 @@ -- Run confluence check for the new rules -- (should be done after adding all rules, see #3795) whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do + -- Warn if --cubical is enabled + whenJustM (optCubical <$> pragmaOptions) $ \_ -> genericWarning + "Confluence checking for --cubical is not yet supported, confluence checking might be incomplete" -- Global confluence checker requires rules to be sorted -- according to the generality of their lhs when (confChk == GlobalConfluenceCheck) $ @@ -160,6 +167,19 @@ reportSDoc "rewriting" 10 $ "done checking confluence of rules" <+> prettyList_ (map (prettyTCM . rewName) rews) +-- Auxiliary function for checkRewriteRule. +-- | Get domain of rewrite relation. +rewriteRelationDom :: QName -> TCM (ListTel, Dom Type) +rewriteRelationDom rel = do + -- We know that the type of rel is that of a relation. + relV <- relView =<< do defType <$> getConstInfo rel + let RelView _tel delta a _a' _core = fromMaybe __IMPOSSIBLE__ relV + reportSDoc "rewriting" 30 $ do + "rewrite relation at type " <+> do + inTopContext $ prettyTCM (telFromList delta) <+> " |- " <+> do + addContext delta $ prettyTCM a + return (delta, a) + -- | Check the validity of @q : Γ → rel us lhs rhs@ as rewrite rule -- @ -- Γ ⊢ lhs ↦ rhs : B @@ -173,7 +193,11 @@ requireOptionRewriting let failNoBuiltin = typeError $ GenericError $ "Cannot add rewrite rule without prior BUILTIN REWRITE" - rel <- fromMaybeM failNoBuiltin $ getBuiltinName builtinRewrite + rels <- fromMaybeM failNoBuiltin getBuiltinRewriteRelations + reportSDoc "rewriting.relations" 40 $ vcat + [ "Rewrite relations:" + , prettyList $ map prettyTCM $ toList rels + ] def <- instantiateDef =<< getConstInfo q -- Issue 1651: Check that we are not adding a rewrite rule -- for a type signature whose body has not been type-checked yet. @@ -183,13 +207,6 @@ , prettyTCM q , " cannot be added before the function definition" ] - -- We know that the type of rel is that of a relation. - relV <- relView =<< do defType <$> getConstInfo rel - let RelView _tel delta a _a' _core = fromMaybe __IMPOSSIBLE__ relV - reportSDoc "rewriting" 30 $ do - "rewrite relation at type " <+> do - inTopContext $ prettyTCM (telFromList delta) <+> " |- " <+> do - addContext delta $ prettyTCM a -- Get rewrite rule (type of q). TelV gamma1 core <- telView $ defType def reportSDoc "rewriting" 30 $ vcat @@ -200,22 +217,38 @@ let failureWrongTarget :: TCM a failureWrongTarget = typeError . GenericDocError =<< hsep [ prettyTCM q , " does not target rewrite relation" ] - let failureMetas :: TCM a - failureMetas = typeError . GenericDocError =<< hsep - [ prettyTCM q , " is not a legal rewrite rule, since it contains unsolved meta variables" ] + let failureBlocked :: Blocker -> TCM a + failureBlocked b + | not (null ms) = err $ "it contains the unsolved meta variable(s)" <+> prettyList_ (map prettyTCM $ Set.toList ms) + | not (null ps) = err $ "it is blocked on problem(s)" <+> prettyList_ (map prettyTCM $ Set.toList ps) + | not (null qs) = err $ "it requires the definition(s) of" <+> prettyList_ (map prettyTCM $ Set.toList qs) + | otherwise = __IMPOSSIBLE__ + where + err reason = typeError . GenericDocError =<< hsep + [ prettyTCM q , " is not a legal rewrite rule, since" , reason ] + ms = allBlockingMetas b + ps = allBlockingProblems b + qs = allBlockingDefs b let failureNotDefOrCon :: TCM a failureNotDefOrCon = typeError . GenericDocError =<< hsep [ prettyTCM q , " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ] let failureFreeVars :: IntSet -> TCM a failureFreeVars xs = typeError . GenericDocError =<< hsep [ prettyTCM q , " is not a legal rewrite rule, since the following variables are not bound by the left hand side: " , prettyList_ (map (prettyTCM . var) $ IntSet.toList xs) ] + let failureNonLinearPars :: IntSet -> TCM a + failureNonLinearPars xs = typeError . GenericDocError =<< 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?" let failureIllegalRule :: TCM a -- TODO:: Defined but not used failureIllegalRule = typeError . GenericDocError =<< hsep [ prettyTCM q , " is not a legal rewrite rule" ] -- Check that type of q targets rel. case unEl core of - Def rel' es@(_:_:_) | rel == rel' -> do + Def rel es@(_:_:_) | rel `elem` rels -> do + (delta, a) <- rewriteRelationDom rel -- Because of the type of rel (Γ → sort), all es are applications. let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es -- The last two arguments are lhs and rhs. @@ -230,10 +263,6 @@ gamma1 <- instantiateFull gamma1 let gamma = gamma0 `abstract` gamma1 - unless (noMetas (telToList gamma1)) $ do - reportSDoc "rewriting" 30 $ "metas in gamma1: " <+> text (show $ allMetasList $ telToList gamma1) - failureMetas - -- 2017-06-18, Jesper: Unfold inlined definitions on the LHS. -- This is necessary to replace copies created by imports by their -- original definition. @@ -258,13 +287,9 @@ checkNoLhsReduction f hd es - unless (noMetas (es, rhs, b)) $ do - reportSDoc "rewriting" 30 $ "metas in lhs: " <+> text (show $ allMetasList es) - reportSDoc "rewriting" 30 $ "metas in rhs: " <+> text (show $ allMetasList rhs) - reportSDoc "rewriting" 30 $ "metas in b : " <+> text (show $ allMetasList b) - failureMetas + ps <- catchPatternErr failureBlocked $ + patternFrom Relevant 0 (t , Def f []) es - ps <- patternFrom Relevant 0 (t , Def f []) es reportSDoc "rewriting" 30 $ "Pattern generated from lhs: " <+> prettyTCM (PDef f ps) @@ -295,6 +320,10 @@ unlessNull (freeVars IntSet.\\ boundVars) failureFreeVars unlessNull (usedVars IntSet.\\ (boundVars `IntSet.union` IntSet.fromList pars)) failureFreeVars + reportSDoc "rewriting" 70 $ + "variables bound in (erased) parameter position: " <+> text (show pars) + unlessNull (boundVars `IntSet.intersection` IntSet.fromList pars) failureNonLinearPars + let rew = RewriteRule q gamma f ps rhs (unDom b) False reportSDoc "rewriting" 10 $ vcat @@ -335,7 +364,20 @@ checkAxFunOrCon :: QName -> Definition -> TCM () checkAxFunOrCon f def = case theDef def of Axiom{} -> return () - Function{} -> return () + def@Function{} -> whenJust (maybeRight (funProjection def)) $ \proj -> + case projProper proj of + Just{} -> typeError . GenericDocError =<< hsep + [ prettyTCM q , " is not a legal rewrite rule, since the head symbol" + , prettyTCM f , "is a projection" + ] + Nothing -> typeError . GenericDocError =<< 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 Constructor{} -> return () AbstractDefn{} -> return () Primitive{} -> return () -- TODO: is this fine? diff --git a/src/full/Agda/TypeChecking/Rewriting/Clause.hs b/src/full/Agda/TypeChecking/Rewriting/Clause.hs --- a/src/full/Agda/TypeChecking/Rewriting/Clause.hs +++ b/src/full/Agda/TypeChecking/Rewriting/Clause.hs @@ -5,6 +5,7 @@ import Agda.Syntax.Common import Agda.Syntax.Internal +import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position import Agda.TypeChecking.Monad @@ -38,6 +39,7 @@ -- if @clauseBody cl@ is @Nothing@. Precondition: @clauseType cl@ is -- not @Nothing@. clauseToRewriteRule :: QName -> QName -> Clause -> Maybe RewriteRule +clauseToRewriteRule f q cl | hasDefP (namedClausePats cl) = Nothing clauseToRewriteRule f q cl = clauseBody cl <&> \rhs -> RewriteRule { rewName = q , rewContext = clauseTel cl 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 @@ -98,6 +98,14 @@ checkConfluenceOfClauses :: ConfluenceCheck -> QName -> TCM () checkConfluenceOfClauses confChk f = do 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 + rews <- filterM noMetasInPats rews let matchables = map getMatchables rews reportSDoc "rewriting.confluence" 30 $ "Function" <+> prettyTCM f <+> "has matchable symbols" <+> prettyList_ (map prettyTCM matchables) @@ -263,6 +271,11 @@ es0 = applySubst (liftS k sub1) $ ohElims hole0 qs2 = rewPats rew2 + -- TODO: support IApply in forceEtaExpansion + let isIApply IApply{} = True + isIApply _ = False + unless (any isIApply $ drop (size es0) qs2) $ do + -- If the second rewrite rule has more eliminations than the -- subpattern of the first rule, the only chance of overlap is -- by eta-expanding the subpattern of the first rule. @@ -474,7 +487,7 @@ -- For record projections @f : R Δ → A@, we rely on the invariant -- that any clause is fully general in the parameters, i.e. it -- is quantified over the parameter telescope @Δ@ - Function { funProjection = Just proj } -> do + Function { funProjection = Right proj } -> do let f = projOrig proj r = unArg $ projFromType proj rtype <- defType <$> getConstInfo r @@ -604,7 +617,7 @@ instance ParallelReduce a => ParallelReduce (Elim' a) where parReduce (Apply u) = Apply <$> parReduce u parReduce e@Proj{} = pure e - parReduce IApply{} = __IMPOSSIBLE__ -- not yet supported + parReduce e@IApply{} = pure e -- TODO instance (Free a, Subst a, ParallelReduce a) => ParallelReduce (Abs a) where parReduce = mapAbstraction __DUMMY_DOM__ parReduce @@ -625,11 +638,11 @@ ns <- forM ms' getMetaNameSuggestion -- Construct telescope (still containing the metas) - let gamma = unflattenTel ns $ map defaultDom as + let n = size ms' + gamma = unflattenTel' n ns $ map defaultDom as -- Replace metas by variables - let n = size ms' - metaIndex x = (n-1-) <$> elemIndex x ms' + let metaIndex x = (n-1-) <$> elemIndex x ms' runReaderT (metasToVars (gamma, x)) metaIndex -- ^ A @OneHole p@ is a @p@ with a subpattern @f ps@ singled out. @@ -788,7 +801,7 @@ let a' = c `absApp` hd [] hd' <- applyE <$> applyDef o f (argFromDom b $> hd []) fmap (e:) <$> allHoles (a' , hd') es - IApply x y u -> __IMPOSSIBLE__ -- Not yet implemented + IApply x y u -> empty -- TODO: support --confluence-check + --cubical instance AllHoles Type where type PType Type = () @@ -835,6 +848,7 @@ SSet l -> fmap SSet <$> allHoles_ l SizeUniv -> empty LockUniv -> empty + IntervalUniv -> empty PiSort{} -> __IMPOSSIBLE__ FunSort{} -> __IMPOSSIBLE__ UnivSort{} -> __IMPOSSIBLE__ @@ -858,7 +872,7 @@ instance AllHoles PlusLevel where type PType PlusLevel = () allHoles _ (Plus n l) = do - la <- levelType + la <- levelType' fmap (Plus n) <$> allHoles la l @@ -911,6 +925,7 @@ SSet l -> SSet <$> metasToVars l SizeUniv -> pure SizeUniv LockUniv -> pure LockUniv + IntervalUniv -> pure IntervalUniv PiSort s t u -> PiSort <$> metasToVars s <*> metasToVars t <*> metasToVars u FunSort s t -> FunSort <$> metasToVars s <*> metasToVars t UnivSort s -> UnivSort <$> metasToVars s 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 @@ -53,7 +53,7 @@ import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope -import Agda.TypeChecking.Primitive.Cubical +import Agda.TypeChecking.Primitive.Cubical.Base import Agda.Utils.Either import Agda.Utils.Functor @@ -165,6 +165,8 @@ [ "matching elimination " <+> addContext (gamma `abstract` k) (prettyTCM p) , " with " <+> addContext k (prettyTCM v) , " eliminating head " <+> addContext k (prettyTCM $ hd []) <+> ":" <+> addContext k (prettyTCM t)]) $ do + + let no = matchingBlocked $ NotBlocked ReallyNotBlocked () case (p,v) of (Apply p, Apply v) -> (addContext k $ unEl <$> reduce t) >>= \case Pi a b -> do @@ -186,19 +188,21 @@ ("interval application at non-pi type (possible non-confluence?) " <+> prettyTCM (pathUnview t)) mzero (Proj o f, Proj o' f') | f == f' -> do - ~(Just (El _ (Pi a b))) <- addContext k $ getDefType f =<< reduce t - let u = hd [] - t' = b `absApp` u - hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u) - match r gamma k (t',hd') ps vs + addContext k (getDefType f =<< reduce t) >>= \case + Just (El _ (Pi a b)) -> do + let u = hd [] + t' = b `absApp` u + hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u) + match r gamma k (t',hd') ps vs + _ -> no (Proj _ f, Proj _ f') | otherwise -> do traceSDoc "rewriting.match" 20 (sep [ "mismatch between projections " <+> prettyTCM f , " and " <+> prettyTCM f' ]) mzero - (Apply{}, Proj{} ) -> __IMPOSSIBLE__ - (Proj{} , Apply{}) -> __IMPOSSIBLE__ + (Apply{}, Proj{} ) -> no + (Proj{} , Apply{}) -> no (IApply{} , _ ) -> __IMPOSSIBLE__ -- TODO (_ , IApply{} ) -> __IMPOSSIBLE__ -- TODO @@ -224,10 +228,12 @@ case (p , s) of (PType lp , Type l ) -> match r gamma k () lp l (PProp lp , Prop l ) -> match r gamma k () lp l + (PSSet lp , SSet l ) -> match r gamma k () lp l (PInf fp np , Inf f n) | fp == f, np == n -> yes (PSizeUniv , SizeUniv) -> yes (PLockUniv , LockUniv) -> yes + (PIntervalUniv , IntervalUniv) -> yes -- blocked cases (_ , UnivSort{}) -> matchingBlocked b @@ -254,6 +260,7 @@ prettyTerm = withShowAllArguments $ addContext k $ prettyTCM v prettyType = withShowAllArguments $ addContext k $ prettyTCM t etaRecord <- addContext k $ isEtaRecordType t + pview <- pathViewAsPi'whnf prop <- fromRight __IMPOSSIBLE__ <.> runBlocked . addContext k $ isPropM t let r = if prop then Irrelevant else r0 traceSDoc "rewriting.match" 30 (sep @@ -315,8 +322,9 @@ match r gamma k (ft , Def f) ps es Con c ci vs | f == conName c -> do - ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t - match r gamma k (ct , Con c ci) ps vs + addContext k (getFullyAppliedConType c t) >>= \case + Just (_ , ct) -> match r gamma k (ct , Con c ci) ps vs + Nothing -> no "" _ | Pi a b <- unEl t -> do let ai = domInfo a pbody = PDef f $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ] @@ -329,21 +337,27 @@ -- the pattern (p = PDef f ps) to @c (p .f1) ... (p .fn)@. def <- addContext k $ theDef <$> getConstInfo d (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v - ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t - let flds = map argFromDom $ recFields def - mkField fld = PDef f (ps ++ [Proj ProjSystem fld]) - -- Issue #3335: when matching against the record constructor, - -- don't add projections but take record field directly. - ps' - | conName c == f = ps - | otherwise = map (Apply . fmap mkField) flds - match r gamma k (ct, Con c ci) ps' (map Apply vs) + addContext k (getFullyAppliedConType c t) >>= \case + Just (_ , ct) -> do + let flds = map argFromDom $ recFields def + mkField fld = PDef f (ps ++ [Proj ProjSystem fld]) + -- Issue #3335: when matching against the record constructor, + -- don't add projections but take record field directly. + ps' + | conName c == f = ps + | otherwise = map (Apply . fmap mkField) flds + match r gamma k (ct, Con c ci) ps' (map Apply vs) + Nothing -> no "" v -> maybeBlock v PLam i p' -> case unEl t of Pi a b -> do let body = raise 1 v `apply` [Arg i (var 0)] k' = ExtendTel a (Abs (absName b) k) 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) + match r gamma k' (absBody b) (absBody p') body v -> maybeBlock v PPi pa pb -> case v of Pi a b -> do @@ -367,46 +381,19 @@ _ | Just (d, pars) <- etaRecord -> do def <- addContext k $ theDef <$> getConstInfo d (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v - ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t - let flds = map argFromDom $ recFields def - ps' = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds - match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs) + addContext k (getFullyAppliedConType c t) >>= \case + Just (_ , ct) -> do + let flds = map argFromDom $ recFields def + ps' = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds + match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs) + Nothing -> no "" v -> maybeBlock v PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext (gamma `abstract` k) (prettyTCM u)) $ tellEq gamma k t u v --- Checks if the given term contains any free variables that satisfy the --- given condition on their DBI, possibly reducing the term in the process. --- Returns `Right Nothing` if there are such variables, `Right (Just v')` --- if there are none (where v' is the possibly reduced version of the given --- term) or `Left b` if the problem is blocked on a meta. -reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a) - => IntSet -> a -> m (Either Blocked_ (Maybe a)) -reallyFree xs v = do - (mxs , v') <- forceNotFree xs v - case IntMap.foldr pickFree NotFree mxs of - MaybeFree ms - | null ms -> return $ Right Nothing - | otherwise -> return $ Left $ Blocked blocker () - where blocker = unblockOnAll $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms - NotFree -> return $ Right (Just v') - - where - -- Check if any of the variables occur freely. - -- Prefer occurrences that do not depend on any metas. - pickFree :: IsFree -> IsFree -> IsFree - pickFree f1@(MaybeFree ms1) f2 - | null ms1 = f1 - pickFree f1@(MaybeFree ms1) f2@(MaybeFree ms2) - | null ms2 = f2 - | otherwise = f1 - pickFree f1@(MaybeFree ms1) NotFree = f1 - pickFree NotFree f2 = f2 - - -makeSubstitution :: Telescope -> Sub -> Substitution +makeSubstitution :: Telescope -> Sub -> Maybe Substitution makeSubstitution gamma sub = - parallelS $ map (fromMaybe __DUMMY_TERM__ . val) [0 .. size gamma-1] + parallelS <$> traverse val [0 .. size gamma-1] where val i = case IntMap.lookup i sub of Just (Irrelevant, v) -> Just $ dontCare v @@ -431,13 +418,15 @@ [ "matching failed during" <+> text msg , "blocking: " <+> text (show b) ]) $ return (Left b) caseEitherM (runNLM $ match Relevant gamma EmptyTel t p v) (no "matching") $ \ s -> do - let sub = makeSubstitution gamma $ s^.nlmSub + let msub = makeSubstitution gamma $ s^.nlmSub eqs = s^.nlmEqs - traceSDoc "rewriting.match" 90 (text $ "sub = " ++ show sub) $ do - ok <- checkPostponedEquations sub eqs - case ok of - Nothing -> return $ Right sub - Just b -> no "checking of postponed equations" b + traceSDoc "rewriting.match" 90 (text $ "msub = " ++ show msub) $ case msub of + Nothing -> no "checking that all variables are bound" notBlocked_ + Just sub -> do + ok <- checkPostponedEquations sub eqs + case ok of + Nothing -> return $ Right sub + Just b -> no "checking of postponed equations" b -- | Typed βη-equality, also handles empty record types. -- Returns `Nothing` if the terms are equal, or `Just b` if the terms are not @@ -463,9 +452,11 @@ vs <- freeVarsToApply c -- Jesper, 2020-06-17, issue #4755: add dummy arguments in -- case we don't have enough parameters - npars <- fromMaybe __IMPOSSIBLE__ <$> getNumberOfParameters c - let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__ - t0 <- defType <$> getConstInfo c - t <- t0 `piApplyM` (vs ++ ws) - return $ Just (c , t) + getNumberOfParameters c >>= \case + Just npars -> do + let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__ + t0 <- defType <$> getConstInfo c + t <- t0 `piApplyM` (vs ++ ws) + return $ Just (c , t) + Nothing -> return Nothing _ -> return Nothing 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 @@ -6,6 +6,8 @@ module Agda.TypeChecking.Rewriting.NonLinPattern where +import Prelude hiding ( null ) + import Control.Monad ( (>=>), forM ) import Control.Monad.Reader ( asks ) @@ -15,6 +17,7 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Defs +import Agda.Syntax.Internal.MetaVars ( AllMetas, unblockOnAllMetasIn ) import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free @@ -27,7 +30,7 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope -import Agda.TypeChecking.Primitive.Cubical +import Agda.TypeChecking.Primitive.Cubical.Base import Agda.Utils.Either import Agda.Utils.Functor @@ -57,14 +60,14 @@ patternFrom r k (t,hd) = \case [] -> return [] (Apply u : es) -> do - ~(Pi a b) <- unEl <$> reduce t + (a, b) <- assertPi t p <- patternFrom r k a u - t' <- t `piApplyM` u + let t' = absApp b (unArg u) let hd' = hd `apply` [ u ] ps <- patternFrom r k (t',hd') es return $ Apply p : ps (IApply x y i : es) -> do - ~(PathType s q l b u v) <- pathView =<< reduce t + (s, q, l, b, u, v) <- assertPath t let t' = El s $ unArg b `apply` [ defaultArg i ] let hd' = hd `applyE` [IApply x y i] interval <- primIntervalType @@ -72,7 +75,7 @@ ps <- patternFrom r k (t',hd') es return $ IApply (PTerm x) (PTerm y) p : ps (Proj o f : es) -> do - ~(Just (El _ (Pi a b))) <- getDefType f =<< reduce t + (a,b) <- assertProjOf f t let t' = b `absApp` hd hd' <- applyDef o f (argFromDom a $> hd) ps <- patternFrom r k (t',hd') es @@ -88,14 +91,15 @@ instance PatternFrom () Sort NLPSort where patternFrom r k _ s = do - s <- reduce s + s <- abortIfBlocked s case s of Type l -> PType <$> patternFrom r k () l Prop l -> PProp <$> patternFrom r k () l + SSet l -> PSSet <$> patternFrom r k () l Inf f n -> return $ PInf f n - SSet l -> __IMPOSSIBLE__ SizeUniv -> return PSizeUniv LockUniv -> return PLockUniv + IntervalUniv -> return PIntervalUniv PiSort _ _ _ -> __IMPOSSIBLE__ FunSort _ _ -> __IMPOSSIBLE__ UnivSort _ -> __IMPOSSIBLE__ @@ -116,21 +120,26 @@ instance PatternFrom Type Term NLPat where patternFrom r0 k t v = do - t <- reduce t + t <- abortIfBlocked t etaRecord <- isEtaRecordType t - prop <- fromRight __IMPOSSIBLE__ <.> runBlocked $ isPropM t + prop <- isPropM t let r = if prop then Irrelevant else r0 - v <- unLevel =<< reduce v + v <- unLevel =<< abortIfBlocked v reportSDoc "rewriting.build" 60 $ sep [ "building a pattern from term v = " <+> prettyTCM v , " of type " <+> prettyTCM t ] - let done = return $ PTerm v + pview <- pathViewAsPi'whnf + let done = blockOnMetasIn v >> return (PTerm v) case (unEl t , stripDontCare v) of (Pi a b , _) -> do let body = raise 1 v `apply` [ Arg (domInfo a) $ var 0 ] p <- addContext a (patternFrom r (k+1) (absBody b) body) return $ PLam (domInfo a) $ Abs (absName b) p + _ | Left ((a,b),(x,y)) <- pview t -> do + let body = raise 1 v `applyE` [ IApply (raise 1 $ x) (raise 1 $ y) $ var 0 ] + p <- addContext a (patternFrom r (k+1) (absBody b) body) + return $ PLam (domInfo a) $ Abs (absName b) p (_ , Var i es) | i < k -> do t <- typeOfBV i @@ -138,10 +147,11 @@ -- The arguments of `var i` should be distinct bound variables -- in order to build a Miller pattern | Just vs <- allApplyElims es -> do - TelV tel _ <- telView =<< typeOfBV i - unless (size tel >= size vs) __IMPOSSIBLE__ + TelV tel rest <- telViewPath =<< typeOfBV i + unless (size tel >= size vs) $ blockOnMetasIn rest >> addContext tel (errNotPi rest) let ts = applySubst (parallelS $ reverse $ map unArg vs) $ map unDom $ flattenTel tel mbvs <- forM (zip ts vs) $ \(t , v) -> do + blockOnMetasIn (v,t) isEtaVar (unArg v) t >>= \case Just j | j < k -> return $ Just $ v $> j _ -> return Nothing @@ -156,9 +166,9 @@ (_ , _ ) | Just (d, pars) <- etaRecord -> do def <- theDef <$> getConstInfo d (tel, c, ci, vs) <- etaExpandRecord_ d pars def v - caseMaybeM (getFullyAppliedConType c t) __IMPOSSIBLE__ $ \ (_ , ct) -> do + ct <- assertConOf c t PDef (conName c) <$> patternFrom r k (ct , Con c ci []) (map Apply vs) - (_ , Lam i t) -> __IMPOSSIBLE__ + (_ , Lam{}) -> errNotPi t (_ , Lit{}) -> done (_ , Def f es) | isIrrelevant r -> done (_ , Def f es) -> do @@ -171,8 +181,8 @@ ft <- defType <$> getConstInfo f PDef f <$> patternFrom r k (ft , Def f []) es (_ , Con c ci vs) | isIrrelevant r -> done - (_ , Con c ci vs) -> - caseMaybeM (getFullyAppliedConType c t) __IMPOSSIBLE__ $ \ (_ , ct) -> do + (_ , Con c ci vs) -> do + ct <- assertConOf c t PDef (conName c) <$> patternFrom r k (ct , Con c ci []) vs (_ , Pi a b) | isIrrelevant r -> done (_ , Pi a b) -> do @@ -182,7 +192,7 @@ (_ , Sort s) -> PSort <$> patternFrom r k () s (_ , Level l) -> __IMPOSSIBLE__ (_ , DontCare{}) -> __IMPOSSIBLE__ - (_ , MetaV{}) -> __IMPOSSIBLE__ + (_ , MetaV m _) -> __IMPOSSIBLE__ (_ , Dummy s _) -> __IMPOSSIBLE_VERBOSE__ s -- | Convert from a non-linear pattern to a term. @@ -226,9 +236,11 @@ instance NLPatToTerm NLPSort Sort where nlPatToTerm (PType l) = Type <$> nlPatToTerm l nlPatToTerm (PProp l) = Prop <$> nlPatToTerm l + nlPatToTerm (PSSet l) = SSet <$> nlPatToTerm l nlPatToTerm (PInf f n) = return $ Inf f n nlPatToTerm PSizeUniv = return SizeUniv nlPatToTerm PLockUniv = return LockUniv + nlPatToTerm PIntervalUniv = return IntervalUniv -- | Gather the set of pattern variables of a non-linear pattern class NLPatVars a where @@ -247,9 +259,11 @@ nlPatVarsUnder k = \case PType l -> nlPatVarsUnder k l PProp l -> nlPatVarsUnder k l + PSSet l -> nlPatVarsUnder k l PInf f n -> empty PSizeUniv -> empty PLockUniv -> empty + PIntervalUniv -> empty instance NLPatVars NLPat where nlPatVarsUnder k = \case @@ -289,7 +303,7 @@ getMatchables p = case p of PVar _ _ -> empty - PDef f _ -> singleton f + PDef f es -> singleton f ++ getMatchables es PLam _ x -> getMatchables x PPi a b -> getMatchables (a,b) PSort s -> getMatchables s @@ -303,9 +317,11 @@ getMatchables = \case PType l -> getMatchables l PProp l -> getMatchables l + PSSet l -> getMatchables l PInf f n -> empty PSizeUniv -> empty PLockUniv -> empty + PIntervalUniv -> empty instance GetMatchables Term where getMatchables = getDefs' __IMPOSSIBLE__ singleton @@ -336,6 +352,68 @@ freeVars' = \case PType l -> freeVars' l PProp l -> freeVars' l + PSSet l -> freeVars' l PInf f n -> mempty PSizeUniv -> mempty PLockUniv -> mempty + PIntervalUniv -> mempty + +-- Throws a pattern violation if the given term contains any +-- metavariables. +blockOnMetasIn :: (MonadBlock m, AllMetas t) => t -> m () +blockOnMetasIn t = case unblockOnAllMetasIn t of + UnblockOnAll ms | null ms -> return () + b -> patternViolation b + +-- Helper functions + + +assertPi :: Type -> TCM (Dom Type, Abs Type) +assertPi t = abortIfBlocked t >>= \case + El _ (Pi a b) -> return (a,b) + t -> errNotPi t + +errNotPi :: Type -> TCM a +errNotPi t = typeError . GenericDocError =<< fsep + [ prettyTCM t + , "should be a function type, but it isn't." + , "Do you have any non-confluent rewrite rules?" + ] + +assertPath :: Type -> TCM (Sort, QName, Arg Term, Arg Term, Arg Term, Arg Term) +assertPath t = abortIfBlocked t >>= pathView >>= \case + PathType s q l b u v -> return (s,q,l,b,u,v) + OType t -> errNotPath t + +errNotPath :: Type -> TCM a +errNotPath t = typeError . GenericDocError =<< fsep + [ prettyTCM t + , "should be a path type, but it isn't." + , "Do you have any non-confluent rewrite rules?" + ] + +assertProjOf :: QName -> Type -> TCM (Dom Type, Abs Type) +assertProjOf f t = do + t <- abortIfBlocked t + getDefType f t >>= \case + Just (El _ (Pi a b)) -> return (a,b) + _ -> errNotProjOf f t + +errNotProjOf :: QName -> Type -> TCM a +errNotProjOf f t = typeError . GenericDocError =<< fsep + [ prettyTCM f , "should be a projection from type" + , prettyTCM t , "but it isn't." + , "Do you have any non-confluent rewrite rules?" + ] + +assertConOf :: ConHead -> Type -> TCM Type +assertConOf c t = getFullyAppliedConType c t >>= \case + Just (_ , ct) -> return ct + Nothing -> errNotConOf c t + +errNotConOf :: ConHead -> Type -> TCM a +errNotConOf c t = typeError . GenericDocError =<< fsep + [ prettyTCM c , "should be a constructor of type" + , prettyTCM t , "but it isn't." + , "Do you have any non-confluent rewrite rules?" + ] 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 @@ -11,11 +11,10 @@ import Prelude hiding ( null ) import Control.Applicative ( (<|>) ) -import Control.Monad ( forM, forM_, guard, liftM2 ) -import Control.Monad.Except +import Control.Monad ( filterM, forM, forM_, guard, liftM2 ) +import Control.Monad.Except ( ExceptT, runExceptT, MonadError, catchError, throwError ) import Control.Monad.Trans import Control.Monad.Trans.Maybe -import Control.Monad.Reader import Data.Bifunctor import Data.Maybe @@ -48,7 +47,7 @@ import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Names import Agda.TypeChecking.Pretty -import Agda.TypeChecking.Primitive +import Agda.TypeChecking.Primitive hiding (Nat) import Agda.TypeChecking.Monad import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce @@ -61,6 +60,7 @@ import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List ( (!!!), groupOn, initWithDefault ) +import qualified Agda.Utils.List as List import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe @@ -558,44 +558,100 @@ checkArgumentsE :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Maybe Type -> ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget) -checkArgumentsE = checkArgumentsE' NotCheckedTarget +checkArgumentsE sComp sExpand sRange sArgs sFun sApp = do + sPathView <- pathView' + checkArgumentsE' + S{ sChecked = NotCheckedTarget + , sArgs = zip sArgs $ + List.suffixesSatisfying visible sArgs + , sArgsLen = length sArgs + , sSizeLtChecked = False + , sSkipCheck = DontSkip + , .. + } +-- | State used by 'checkArgumentsE''. + +data CheckArgumentsE'State = S + { sChecked :: CheckedTarget + -- ^ Have we already checked the target? + , sComp :: Comparison + -- ^ Comparison to use if checking the target type. + , sExpand :: ExpandHidden + -- ^ Insert trailing hidden arguments? + , sRange :: Range + -- ^ Range of the function. + , sArgs :: [(NamedArg A.Expr, Bool)] + -- ^ Arguments, along with information about whether a given + -- argument and all remaining arguments are 'visible'. + , sArgsLen :: !Nat + -- ^ The length of 'sArgs'. + , sFun :: Type + -- ^ The function's type. + , sApp :: Maybe Type + -- ^ The type of the application. + , sSizeLtChecked :: !Bool + -- ^ Have we checked if 'sApp' is 'BoundedLt'? + , sSkipCheck :: !SkipCheck + -- ^ Should the target type check be skipped? + , sPathView :: Type -> PathView + -- ^ The function returned by 'pathView''. + } + +-- | Should the target type check in 'checkArgumentsE'' be skipped? + +data SkipCheck + = Skip + | SkipNext !Nat + -- ^ Skip the given number of checks. + | DontSkip + checkArgumentsE' - :: CheckedTarget -- ^ Have we already checked the target? - -> Comparison -- ^ Comparison to use if checking target type - -> ExpandHidden -- ^ Insert trailing hidden arguments? - -> Range -- ^ Range of the function. - -> [NamedArg A.Expr] -- ^ Arguments. - -> Type -- ^ Type of the function. - -> Maybe Type -- ^ Type of the application. + :: CheckArgumentsE'State -> ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget) -- Case: no arguments, do not insert trailing hidden arguments: We are done. -checkArgumentsE' chk cmp exh _ [] t0 _ | isDontExpandLast exh = return $ ACState [] [] [] t0 chk +checkArgumentsE' S{ sArgs = [], .. } + | isDontExpandLast sExpand = + return $ ACState + { acRanges = [] + , acElims = [] + , acConstraints = [] + , acType = sFun + , acData = sChecked + } -- Case: no arguments, but need to insert trailing hiddens. -checkArgumentsE' chk cmp _ExpandLast r [] t0 mt1 = - traceCallE (CheckArguments r [] t0 mt1) $ lift $ do - mt1' <- traverse (unEl <.> reduce) mt1 - (us, t) <- implicitArgs (-1) (expand mt1') t0 - return $ ACState (replicate (length us) Nothing) (map Apply us) (replicate (length us) Nothing) t chk - where - expand (Just (Pi dom _)) Hidden = not (hidden dom) - expand _ Hidden = True - expand (Just (Pi dom _)) Instance{} = not (isInstance dom) - expand _ Instance{} = True - expand _ NotHidden = False +checkArgumentsE' S{ sArgs = [], .. } = + traceCallE (CheckArguments sRange [] sFun sApp) $ lift $ do + sApp <- traverse (unEl <.> reduce) sApp + (us, t) <- implicitArgs (-1) (expand sApp) sFun + return $ ACState + { acRanges = replicate (length us) Nothing + , acElims = map Apply us + , acConstraints = replicate (length us) Nothing + , acType = t + , acData = sChecked + } + where + expand (Just (Pi dom _)) Hidden = not (hidden dom) + expand _ Hidden = True + expand (Just (Pi dom _)) Instance{} = not (isInstance dom) + expand _ Instance{} = True + expand _ NotHidden = False -- Case: argument given. -checkArgumentsE' chk cmp exh r args0@(arg@(Arg info e) : args) t0 mt1 = - traceCallE (CheckArguments r args0 t0 mt1) $ do +checkArgumentsE' + s@S{ sArgs = sArgs@((arg@(Arg info e), sArgsVisible) : args), .. } = + + traceCallE (CheckArguments sRange (map fst sArgs) sFun sApp) $ do lift $ reportSDoc "tc.term.args" 30 $ sep [ "checkArgumentsE" --- , " args0 =" <+> prettyA args0 +-- , " sArgs =" <+> prettyA sArgs , nest 2 $ vcat [ "e =" <+> prettyA e - , "t0 =" <+> prettyTCM t0 - , "t1 =" <+> maybe "Nothing" prettyTCM mt1 + , "sFun =" <+> prettyTCM sFun + , "sApp =" <+> maybe "Nothing" prettyTCM sApp ] ] -- First, insert implicit arguments, depending on current argument @arg@. @@ -609,11 +665,11 @@ expand hy y = not (sameHiding hy hx) || maybe False (y /=) mx reportSDoc "tc.term.args" 30 $ vcat [ "calling implicitNamedArgs" - , nest 2 $ "t0 = " <+> prettyTCM t0 - , nest 2 $ "hx = " <+> text (show hx) - , nest 2 $ "mx = " <+> maybe "nothing" prettyTCM mx + , nest 2 $ "sFun = " <+> prettyTCM sFun + , nest 2 $ "hx = " <+> text (show hx) + , nest 2 $ "mx = " <+> maybe "nothing" prettyTCM mx ] - (nargs, t) <- lift $ implicitNamedArgs (-1) expand t0 + (nargs, sFun) <- lift $ implicitNamedArgs (-1) expand sFun -- Separate names from args. let (mxs, us) = unzip $ map (\ (Arg ai (Named mx u)) -> (mx, Apply $ Arg ai u)) nargs xs = catMaybes mxs @@ -621,20 +677,27 @@ -- We need a function type here, but we don't know which kind -- (implicit/explicit). But it might be possible to use injectivity to -- force a pi. - t <- lift $ forcePiUsingInjectivity t + sFun <- lift $ forcePiUsingInjectivity sFun -- We are done inserting implicit args. Now, try to check @arg@. - ifBlocked t (\ m t -> throwError $ ACState (replicate (length us) Nothing) us (replicate (length us) Nothing) t args0) $ \ _ t0' -> do + ifBlocked sFun + (\_ sFun -> throwError $ ACState + { acRanges = replicate (length us) Nothing + , acElims = us + , acConstraints = replicate (length us) Nothing + , acType = sFun + , acData = map fst sArgs + }) $ \_ sFun -> do -- What can go wrong? -- 1. We ran out of function types. let shouldBePi -- a) It is an explicit argument, but we ran out of function types. - | visible info = lift $ typeError $ ShouldBePi t0' + | visible info = lift $ typeError $ ShouldBePi sFun -- b) It is an implicit argument, and we did not insert any implicits. -- Thus, the type was not a function type to start with. - | null xs = lift $ typeError $ ShouldBePi t0' + | null xs = lift $ typeError $ ShouldBePi sFun -- c) We did insert implicits, but we ran out of implicit function types. -- Then, we should inform the user that we did not find his one. | otherwise = lift $ typeError $ WrongNamedArgument arg xs @@ -644,59 +707,106 @@ -- (Otherwise we would have ran out of function types instead.) let wrongPi -- b) We have not inserted any implicits. - | null xs = lift $ typeError $ WrongHidingInApplication t0' + | null xs = lift $ typeError $ + WrongHidingInApplication sFun -- c) We inserted implicits, but did not find his one. | otherwise = lift $ typeError $ WrongNamedArgument arg xs - viewPath <- lift pathView' + let (skip, next) = case sSkipCheck of + Skip -> (True, Skip) + DontSkip -> (False, DontSkip) + SkipNext n -> case compare n 1 of + LT -> (False, DontSkip) + EQ -> (True, DontSkip) + GT -> (True, SkipNext (n - 1)) + s <- return s + { sRange = fuseRange sRange e + , sArgs = args + , sArgsLen = sArgsLen - 1 + , sFun = sFun + , sSkipCheck = next + } + -- Check the target type if we can get away with it. - chk' <- lift $ - case (chk, mt1) of - (NotCheckedTarget, Just t1) | all visible args0 -> do - let n = length args0 - TelV tel tgt <- telViewUpTo n t0' - let dep = any (< n) $ IntSet.toList $ freeVars tgt - vis = all visible (telToList tel) - isRigid t | PathType{} <- viewPath t = return False -- Path is not rigid! - isRigid (El _ (Pi dom _)) = return $ visible dom - isRigid (El _ (Def d _)) = getConstInfo d <&> theDef <&> \ case - Axiom{} -> True - DataOrRecSig{} -> True - AbstractDefn{} -> True - Function{funClauses = cs} -> null cs - Datatype{} -> True - Record{} -> True - Constructor{} -> __IMPOSSIBLE__ - GeneralizableVar{} -> __IMPOSSIBLE__ - Primitive{} -> False - PrimitiveSort{} -> False - isRigid _ = return False - rigid <- isRigid tgt - -- Andreas, 2019-03-28, issue #3248: - -- If the target type is SIZELT, we need coerce, leqType is insufficient. - -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i). - isSizeLt <- reduce t1 >>= isSizeType <&> \case - Just (BoundedLt _) -> True - _ -> False - if | dep -> return chk -- must be non-dependent - | not rigid -> return chk -- with a rigid target - | not vis -> return chk -- and only visible arguments - | isSizeLt -> return chk -- Issue #3248, not Size< - | otherwise -> do - let tgt1 = applySubst (strengthenS impossible $ size tel) tgt + s <- lift $ + case (sChecked, skip, sApp) of + (NotCheckedTarget, False, Just sApp) | sArgsVisible -> do + -- How many visible Π's (up to at most sArgsLen) does + -- sFun start with? + TelV tel tgt <- telViewUpTo' sArgsLen visible sFun + let visiblePis = size tel + + -- The free variables less than visiblePis in tgt. + freeInTgt = + fst $ IntSet.split visiblePis $ freeVars tgt + + rigid <- isRigid s tgt + -- The target must be rigid. + case rigid of + IsNotRigid reason -> + -- Skip the next visiblePis - 1 - k checks. + let skip k = s{ sSkipCheck = + SkipNext $ visiblePis - 1 - k + } + dontSkip = s + in return $ case reason of + Permanent -> skip 0 + Unspecified -> dontSkip + AVar x -> + if x `IntSet.member` freeInTgt + then skip x + else skip 0 + IsRigid -> do + + -- Is any free variable in tgt less than + -- visiblePis? + let dep = not (IntSet.null freeInTgt) + -- The target must be non-dependent. + if dep then return s else do + + -- Andreas, 2019-03-28, issue #3248: + -- If the target type is SIZELT, we need coerce, leqType is insufficient. + -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i). + (isSizeLt, sApp, s) <- + if sSizeLtChecked + then return (False, sApp, s) + else do + sApp <- reduce sApp + isSizeLt <- isSizeType sApp <&> \case + Just (BoundedLt _) -> True + _ -> False + return ( isSizeLt + , sApp + , s{ sApp = Just sApp + , sSizeLtChecked = True + , sSkipCheck = + if isSizeLt then Skip else DontSkip + } + ) + if isSizeLt then return s else do + + let tgt1 = applySubst + (strengthenS impossible visiblePis) + tgt reportSDoc "tc.term.args.target" 30 $ vcat [ "Checking target types first" , nest 2 $ "inferred =" <+> prettyTCM tgt1 - , nest 2 $ "expected =" <+> prettyTCM t1 ] - traceCall (CheckTargetType (fuseRange r args0) tgt1 t1) $ - CheckedTarget <$> ifNoConstraints_ (compareType cmp tgt1 t1) - (return Nothing) (return . Just) + , nest 2 $ "expected =" <+> prettyTCM sApp ] + chk <- + traceCall + (CheckTargetType + (fuseRange sRange sArgs) tgt1 sApp) $ + CheckedTarget <$> + ifNoConstraints_ (compareType sComp tgt1 sApp) + (return Nothing) (return . Just) + return s{ sChecked = chk } - _ -> return chk + _ -> return s - -- t0' <- lift $ forcePi (getHiding info) (maybe "_" rangedThing $ nameOf e) t0' - case unEl t0' of + -- sFun <- lift $ forcePi (getHiding info) + -- (maybe "_" rangedThing $ nameOf e) sFun + case unEl sFun of Pi (Dom{domInfo = info', domName = dname, unDom = a}) b | let name = bareNameWithDefault "_" dname, sameHiding info info' @@ -718,13 +828,18 @@ let e' = e { nameOf = (nameOf e) <|> dname } checkNamedArg (Arg info' e') a - let c | IsLock == getLock info' = Just $ Abs "t" (CheckLockedVars (Var 0 []) (raise 1 t0') (raise 1 $ Arg info' u) (raise 1 a)) + let c | IsLock == getLock info' = + Just $ Abs "t" $ + CheckLockedVars (Var 0 []) (raise 1 sFun) + (raise 1 $ Arg info' u) (raise 1 a) | otherwise = Nothing lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info') - lift $ reportSDoc "tc.term.lock" 40 $ addContext (defaultDom $ t0') $ maybe (text "nothing") prettyTCM (absBody <$> c) + lift $ reportSDoc "tc.term.lock" 40 $ + addContext (defaultDom $ sFun) $ + maybe (text "nothing") prettyTCM (absBody <$> c) -- save relevance info' from domain in argument addCheckedArgs us (getRange e) (Apply $ Arg info' u) c $ - checkArgumentsE' chk' cmp exh (fuseRange r e) args (absApp b u) mt1 + checkArgumentsE' s{ sFun = absApp b u } | otherwise -> do reportSDoc "error" 10 $ nest 2 $ vcat [ text $ "info = " ++ show info @@ -735,11 +850,14 @@ wrongPi _ | visible info - , PathType s _ _ bA x y <- viewPath t0' -> do + , PathType sort _ _ bA x y <- sPathView sFun -> do lift $ reportSDoc "tc.term.args" 30 $ text $ show bA u <- lift $ checkExpr (namedThing e) =<< primIntervalType addCheckedArgs us (getRange e) (IApply (unArg x) (unArg y) u) Nothing $ - checkArgumentsE cmp exh (fuseRange r e) args (El s $ unArg bA `apply` [argN u]) mt1 + checkArgumentsE' + s{ sChecked = NotCheckedTarget + , sFun = El sort $ unArg bA `apply` [argN u] + } _ -> shouldBePi where -- Andrea: Here one would add constraints too. @@ -752,6 +870,61 @@ let rs' = replicate (length us) Nothing ++ Just r : rs cs' = replicate (length us) Nothing ++ c : acConstraints st throwError $ st { acRanges = rs', acElims = us ++ u : vs, acConstraints = cs' } + +-- | The result of 'isRigid'. + +data IsRigid + = IsRigid + -- ^ The type is rigid. + | IsNotRigid !IsPermanent + -- ^ The type is not rigid. If the argument is 'Nothing', then + -- this will not change. If the argument is @'Just' reason@, then + -- this might change for the given @reason@. + +-- | Is the result of 'isRigid' \"permanent\"? + +data IsPermanent + = Permanent + -- ^ Yes. + | AVar !Nat + -- ^ The result does not change unless the given variable is + -- instantiated. + | Unspecified + -- ^ Maybe, maybe not. + +-- | Is the type \"rigid\"? + +isRigid :: CheckArgumentsE'State -> Type -> TCM IsRigid +isRigid s t | PathType{} <- sPathView s t = + -- Path is not rigid. + return $ IsNotRigid Permanent +isRigid _ (El _ t) = case t of + Var x _ -> return $ IsNotRigid (AVar x) + Lam{} -> return $ IsNotRigid Permanent + Lit{} -> return $ IsNotRigid Permanent + Con{} -> return $ IsNotRigid Permanent + Pi dom _ -> return $ + if visible dom then IsRigid else IsNotRigid Permanent + Sort{} -> return $ IsNotRigid Permanent + Level{} -> return $ IsNotRigid Permanent + MetaV{} -> return $ IsNotRigid Unspecified + DontCare{} -> return $ IsNotRigid Permanent + Dummy{} -> return $ IsNotRigid Permanent + Def d _ -> getConstInfo d <&> theDef <&> \case + Axiom{} -> IsRigid + DataOrRecSig{} -> IsRigid + AbstractDefn{} -> IsRigid + Function{funClauses = cs} -> if null cs + then IsRigid + else IsNotRigid Unspecified + -- This Reason could perhaps be + -- more precise (in some cases). + Datatype{} -> IsRigid + Record{} -> IsRigid + Constructor{} -> __IMPOSSIBLE__ + GeneralizableVar{} -> __IMPOSSIBLE__ + Primitive{} -> IsNotRigid Unspecified + PrimitiveSort{} -> IsNotRigid Unspecified -- | Check that a list of arguments fits a telescope. -- Inserts hidden arguments as necessary. 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 @@ -13,9 +13,9 @@ import Control.Monad import Control.Monad.Except +import Control.Monad.Trans.Maybe import Data.List (find, sortBy) -import Data.List.NonEmpty (NonEmpty(..)) import Data.Function (on) import qualified Agda.Syntax.Abstract as A @@ -47,6 +47,7 @@ import Agda.Utils.Functor import Agda.Utils.List +import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null @@ -121,8 +122,9 @@ (El (varSort 1) <$> varM 0 <@> primIZero) --> (El (varSort 1) <$> varM 0 <@> primIOne) --> return (sort $ varSort 1))) + , (builtinIntervalUniv |-> BuiltinSort "primIntervalUniv") , (builtinInterval |-> BuiltinData (requireCubical CErased "" >> - (return $ ssort $ ClosedLevel 0)) [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 -> @@ -131,7 +133,7 @@ , (builtinSubIn |-> builtinPostulateC CErased (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a -> hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA -> - hPi' "φ" (elSSet $ cl primInterval) $ \ phi -> + hPi' "φ" (cl tinterval) $ \ phi -> nPi' "x" (el' a bA) $ \ x -> el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (\ _ -> x))) , (builtinIZero |-> BuiltinDataCons tinterval) @@ -157,18 +159,16 @@ pPi' "o" (cl primIZero) (\ o -> el' l $ gApply' (setRelevance Irrelevant defaultArgInfo) bA o))) - , (builtinId |-> builtinPostulateC CErased (hPi "a" (el primLevel) $ + , (builtinId |-> BuiltinData ((>>) (requireCubical CErased "") $ hPi "a" (el primLevel) $ hPi "A" (return $ sort $ varSort 0) $ (El (varSort 1) <$> varM 0) --> (El (varSort 1) <$> varM 0) --> - return (sort $ varSort 1))) - , (builtinConId |-> builtinPostulateC CErased (hPi "a" (el primLevel) $ - hPi "A" (return $ sort $ varSort 0) $ - hPi "x" (El (varSort 1) <$> varM 0) $ - hPi "y" (El (varSort 2) <$> varM 1) $ - tinterval --> - (El (varSort 3) <$> primPath <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0) --> - (El (varSort 3) <$> primId <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0))) + return (sort $ varSort 1)) [builtinReflId]) + , (builtinReflId |-> BuiltinDataCons ((>>) (requireCubical CErased "") $ runNamesT [] $ + hPi' "a" (el primLevel) $ \ l -> + hPi' "A" (sort . tmSort <$> l) $ \ bA -> + hPi' "x" (el' l bA) $ \ x -> + el' l (primId <#> l <#> bA <@> x <@> x))) , (builtinEquiv |-> BuiltinUnknown (Just $ requireCubical CFull "" >> runNamesT [] ( hPi' "l" (el $ cl primLevel) $ \ a -> hPi' "l'" (el $ cl primLevel) $ \ b -> @@ -195,13 +195,15 @@ (cl primEquiv <#> la <#> lb <@> bA <@> bB)) $ \ e -> do nPi' "b" (el' lb bB) $ \ b -> do let f = cl primEquivFun <#> la <#> lb <#> bA <#> bB <@> e - fiber = el' (cl primLevelMax <@> la <@> lb) + lub = cl primLevelMax <@> la <@> lb + fiber = el' lub (cl primSigma <#> la <#> lb <@> bA <@> lam "a" (\ a -> cl primPath <#> lb <#> bB <@> (f <@> a) <@> b)) nPi' "φ" (cl tinterval) $ \ phi -> - pPi' "o" phi (\ o -> fiber) --> fiber + nPi' "f" (pPi' "o" phi (\ o -> fiber)) $ \ pfib -> + el' lub (cl primSub <#> lub <#> fmap unEl fiber <@> phi <@> pfib) )) (const $ const $ return ())) , (builtinTranspProof |-> BuiltinUnknown (Just $ requireCubical CErased "" >> runNamesT [] ( @@ -232,9 +234,10 @@ , builtinAgdaTermPi, builtinAgdaTermSort , builtinAgdaTermLit, builtinAgdaTermMeta , builtinAgdaTermUnsupported]) - , builtinAgdaErrorPart |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName ] + , builtinAgdaErrorPart |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartPatt, builtinAgdaErrorPartName ] , builtinAgdaErrorPartString |-> BuiltinDataCons (tstring --> terrorpart) , builtinAgdaErrorPartTerm |-> BuiltinDataCons (tterm --> terrorpart) + , builtinAgdaErrorPartPatt |-> BuiltinDataCons (tpat --> terrorpart) , builtinAgdaErrorPartName |-> BuiltinDataCons (tqname --> terrorpart) -- Andreas, 2017-01-12, issue #2386: special handling of builtinEquality -- , (builtinEquality |-> BuiltinData (hPi "a" (el primLevel) $ @@ -304,9 +307,7 @@ , (builtinHidden |-> BuiltinDataCons thiding) , (builtinInstance |-> BuiltinDataCons thiding) , (builtinVisible |-> BuiltinDataCons thiding) - , (builtinSizeUniv |-> builtinPostulate tSizeUniv) -- SizeUniv : SizeUniv --- See comment on tSizeUniv: the following does not work currently. --- , (builtinSizeUniv |-> builtinPostulate tSetOmega) -- SizeUniv : Setω + , (builtinSizeUniv |-> builtinPostulate tsetOmega) -- SizeUniv : Setω , (builtinSize |-> builtinPostulate tSizeUniv) , (builtinSizeLt |-> builtinPostulate (tsize ..--> tSizeUniv)) , (builtinSizeSuc |-> builtinPostulate (tsize --> tsize)) @@ -365,14 +366,16 @@ , builtinAgdaTCMReduce |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm) , builtinAgdaTCMCatchError |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) - , builtinAgdaTCMGetContext |-> builtinPostulate (tTCM_ (unEl <$> tlist (targ ttype))) + , builtinAgdaTCMGetContext |-> builtinPostulate (tTCM_ (unEl <$> ttelescope)) , builtinAgdaTCMExtendContext |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ - targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) + tstring --> targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) , builtinAgdaTCMInContext |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ - tlist (targ ttype) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) + ttelescope --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) , builtinAgdaTCMFreshName |-> builtinPostulate (tstring --> tTCM_ primQName) , builtinAgdaTCMDeclareDef |-> builtinPostulate (targ tqname --> ttype --> tTCM_ primUnit) , builtinAgdaTCMDeclarePostulate |-> builtinPostulate (targ tqname --> ttype --> tTCM_ primUnit) + , builtinAgdaTCMDeclareData |-> builtinPostulate (tqname --> tnat --> ttype --> tTCM_ primUnit) + , builtinAgdaTCMDefineData |-> builtinPostulate (tqname --> tlist (tpair primLevelZero primLevelZero tqname ttype) --> tTCM_ primUnit) , builtinAgdaTCMDefineFun |-> builtinPostulate (tqname --> tlist tclause --> tTCM_ primUnit) , builtinAgdaTCMGetType |-> builtinPostulate (tqname --> tTCM_ primAgdaTerm) , builtinAgdaTCMGetDefinition |-> builtinPostulate (tqname --> tTCM_ primAgdaDefinition) @@ -384,6 +387,7 @@ , builtinAgdaTCMIsMacro |-> builtinPostulate (tqname --> tTCM_ primBool) , builtinAgdaTCMWithNormalisation |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) , builtinAgdaTCMWithReconsParams |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0)) + , builtinAgdaTCMFormatErrorParts |-> builtinPostulate (tlist terrorpart --> tTCM_ primString) , builtinAgdaTCMDebugPrint |-> builtinPostulate (tstring --> tnat --> tlist terrorpart --> tTCM_ primUnit) , builtinAgdaTCMOnlyReduceDefs |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) , builtinAgdaTCMDontReduceDefs |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0)) @@ -395,6 +399,7 @@ tTCM_ (primSigma <#> primLevelZero <#> primLevelZero <@> primNat <@> (Lam defaultArgInfo . Abs "_" <$> (primSigma <#> primLevelZero <#> primLevelZero <@> primString <@> (Lam defaultArgInfo . Abs "_" <$> primString))))) + , builtinAgdaTCMGetInstances |-> builtinPostulate (tmeta --> tTCM_ (list primAgdaTerm)) ] where (|->) = BuiltinInfo @@ -453,7 +458,7 @@ ttelescope = tlist (tpair primLevelZero primLevelZero tstring (targ ttype)) tTCM l a = elV l (primAgdaTCM <#> varM l <@> a) tTCM_ a = el (primAgdaTCM <#> primLevelZero <@> a) - tinterval = El (SSet $ ClosedLevel 0) <$> primInterval + tinterval = El IntervalUniv <$> primInterval verifyPlus plus = verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do @@ -844,7 +849,10 @@ t <- tcmt (,t) <$> checkExpr e t f v t - bindBuiltinName s v + if | s == builtinRewrite -> runMaybeT (getQNameFromTerm v) >>= \case + Nothing -> genericError "Invalid rewrite relation" + Just q -> bindBuiltinRewriteRelation q + | otherwise -> bindBuiltinName s v setConstTranspAxiom :: QName -> TCM () setConstTranspAxiom q = @@ -856,6 +864,19 @@ $ updateDefPolarity id . updateDefArgOccurrences (const [Unused,StrictPos,Mixed,Mixed]) +builtinIdHook :: QName -> TCM () +builtinIdHook q = do + modifySignature $ updateDefinition q + $ updateDefPolarity id + . updateDefArgOccurrences (const [Unused,StrictPos,Mixed,Mixed]) + modifySignature $ updateDefinition q + $ updateTheDef (\ def@Datatype{} -> def { dataPars = 3, dataIxs = 1}) + +builtinReflIdHook :: QName -> TCM () +builtinReflIdHook q = do + modifySignature $ updateDefinition q + $ updateTheDef (\ def@Constructor{} -> def { conPars = 3, conArity = 0}) + -- | Bind a builtin thing to an expression. bindBuiltin :: String -> ResolvedName -> TCM () bindBuiltin b x = do @@ -938,11 +959,11 @@ where -- Andreas, 2015-02-14 -- Special treatment of SizeUniv, should maybe be a primitive. - def | b == builtinSizeUniv = emptyFunction - { funClauses = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ] - , funCompiled = Just (CC.Done [] $ Sort sSizeUniv) - , funMutual = Just [] - , funTerminates = Just True + def | b == builtinSizeUniv = FunctionDefn $ emptyFunctionData + { _funClauses = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ] + , _funCompiled = Just (CC.Done [] $ Sort sSizeUniv) + , _funMutual = Just [] + , _funTerminates = Just True } | otherwise = defaultAxiom @@ -979,11 +1000,15 @@ } addConstant' q defaultArgInfo q t def addDataCons d [q] + + when (b == builtinReflId) $ builtinReflIdHook q + bindBuiltinName b $ Con ch ConOSystem [] Just (BuiltinData mt cs) -> do t <- mt addConstant' q defaultArgInfo q t (def t) + when (b == builtinId) $ builtinIdHook q bindBuiltinName b $ Def q [] where def t = Datatype @@ -995,6 +1020,8 @@ , dataAbstr = ConcreteDef , dataMutual = Nothing , dataPathCons = [] + , dataTranspIx = Nothing -- Id has custom transp def. + , dataTransp = Nothing } Just (BuiltinSort sortname) -> do @@ -1004,8 +1031,13 @@ "primStrictSet" -> mkSSet 0 "primSetOmega" -> Inf IsFibrant 0 "primStrictSetOmega" -> Inf IsStrict 0 + "primIntervalUniv" -> IntervalUniv _ -> __IMPOSSIBLE__ def = PrimitiveSort sortname s + -- Check for the cubical flag if the sort requries it + case sortname of + "primIntervalUniv" -> requireCubical CErased "" + _ -> return () addConstant' q defaultArgInfo q (sort $ univSort s) def bindBuiltinName b $ Def q [] diff --git a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs --- a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs +++ b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs @@ -22,6 +22,8 @@ import Agda.TypeChecking.Rules.Builtin import Agda.TypeChecking.Rules.Term +import Agda.Utils.Lens + -- | The type of @∞@. typeOfInf :: TCM Type @@ -82,6 +84,7 @@ , recEtaEquality' = Inferred $ NoEta CopatternMatching , recPatternMatching= CopatternMatching , recMutual = Just [] + , recTerminates = Just True -- not recursive , recAbstr = ConcreteDef , recComp = emptyCompKit } @@ -134,11 +137,12 @@ ConP sharpCon cpi [ argN $ Named Nothing $ debruijnNamedVar "x" 0 ] ] , clauseBody = Just $ var 0 , clauseType = Just $ defaultArg $ El (varSort 2) $ var 1 - , clauseCatchall = False + , clauseCatchall = False , clauseExact = Just True , clauseRecursive = Just False , clauseUnreachable = Just False - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } cc = Case (defaultArg 0) $ conCase sharp False $ WithArity 1 $ Done [defaultArg "x"] $ var 0 projection = Projection @@ -152,20 +156,20 @@ flatDefn { defPolarity = [] , defArgOccurrences = [StrictPos] -- changing that to [Mixed] destroys monotonicity of 'Rec' in test/succeed/GuardednessPreservingTypeConstructors , defCopatternLHS = hasProjectionPatterns cc - , theDef = emptyFunction - { funClauses = [clause] - , funCompiled = Just $ cc - , funProjection = Just projection - , funMutual = Just [] - , funTerminates = Just True + , theDef = FunctionDefn emptyFunctionData + { _funClauses = [clause] + , _funCompiled = Just $ cc + , _funProjection = Right projection + , _funMutual = Just [] + , _funTerminates = Just True } } -- register flat as record field for constructor sharp - modifySignature $ updateDefinition sharp $ updateTheDef $ \ def -> - def { conSrcCon = sharpCon } - modifySignature $ updateDefinition inf $ updateTheDef $ \ def -> - def { recConHead = sharpCon, recFields = [defaultDom flat] } + modifySignature $ updateDefinition sharp $ updateTheDef $ over lensConstructor $ \ def -> + def { _conSrcCon = sharpCon } + modifySignature $ updateDefinition inf $ updateTheDef $ over lensRecord $ \ def -> + def { _recConHead = sharpCon, _recFields = [defaultDom flat] } return $ Def flat [] -- The coinductive primitives. 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 @@ -8,14 +8,23 @@ import Control.Monad.Except import Control.Monad.Trans import Control.Monad.Trans.Maybe +import Control.Exception as E +-- Control.Monad.Fail import is redundant since GHC 8.8.1 +import Control.Monad.Fail (MonadFail) + import Data.Set (Set) import qualified Data.Set as Set +import Data.List (nub) +import Agda.Interaction.Options.Base + import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Abstract.Views (deepUnscope) import Agda.Syntax.Internal +import Agda.Syntax.Internal.Pattern +import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn) import Agda.Syntax.Common import Agda.Syntax.Position import qualified Agda.Syntax.Info as Info @@ -40,6 +49,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ ) +import Agda.Utils.Either import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 @@ -48,6 +58,7 @@ import Agda.Utils.Null import qualified Agda.Utils.Pretty as P import Agda.Utils.Size +import Agda.Utils.WithDefault import Agda.Utils.Impossible @@ -85,11 +96,6 @@ dataDef <- bindGeneralizedParameters parNames t $ \ gtel t0 -> bindParameters (npars - length parNames) ps t0 $ \ ptel t0 -> do - -- Parameters are always hidden in constructors - let tel = abstract gtel ptel - tel' = hideAndRelParams <$> tel - -- let tel' = hideTel tel - -- The type we get from bindParameters is Θ -> s where Θ is the type of -- the indices. We count the number of indices and return s. -- We check that s is a sort. @@ -114,15 +120,9 @@ else throwError err reduce s - -- when `--without-K`, all the indices should fit in the - -- sort of the datatype (see #3420). - let s' = case s of - Prop l -> Type l - _ -> s - -- Andreas, 2019-07-16, issue #3916: - -- NoUniverseCheck should also disable the index sort check! - unless (uc == NoUniverseCheck) $ - whenM withoutKOption $ checkIndexSorts s' ixTel + -- Parameters are always hidden in constructors. + let tel = abstract gtel ptel + tel' = hideAndRelParams <$> tel reportSDoc "tc.data.sort" 20 $ vcat [ "checking datatype" <+> prettyTCM name @@ -138,19 +138,21 @@ let npars = size tel -- Change the datatype from an axiom to a datatype with no constructors. - let dataDef = Datatype - { dataPars = npars - , dataIxs = nofIxs - , dataClause = Nothing - , dataCons = [] -- Constructors are added later - , dataSort = s - , dataAbstr = Info.defAbstract i - , dataMutual = Nothing - , dataPathCons = [] -- Path constructors are added later + let dataDef = DatatypeData + { _dataPars = npars + , _dataIxs = nofIxs + , _dataClause = Nothing + , _dataCons = [] -- Constructors are added later + , _dataSort = s + , _dataAbstr = Info.defAbstract i + , _dataMutual = Nothing + , _dataPathCons = [] -- Path constructors are added later + , _dataTranspIx = Nothing -- Generated later if nofIxs > 0. + , _dataTransp = Nothing -- Added later } escapeContext impossible npars $ do - addConstant' name defaultArgInfo name t dataDef + addConstant' name defaultArgInfo name t $ DatatypeDefn dataDef -- polarity and argOcc.s determined by the positivity checker -- Check the types of the constructors @@ -158,16 +160,81 @@ isPathCons <- checkConstructor name uc tel' nofIxs s c return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing + + -- cubical: the interval universe does not contain datatypes + -- similar: SizeUniv, ... + checkDataSort name s + + -- when `--without-K`, all the indices should fit in the + -- sort of the datatype (see #3420). + -- Andreas, 2019-07-16, issue #3916: + -- NoUniverseCheck should also disable the index sort check! + unless (uc == NoUniverseCheck) $ + whenM withoutKOption $ do + let s' = case s of + Prop l -> Type l + _ -> s + checkIndexSorts s' ixTel + -- Return the data definition - return dataDef{ dataPathCons = catMaybes pathCons } + return dataDef{ _dataPathCons = catMaybes pathCons + } let cons = map A.axiomName cs -- get constructor names + (mtranspix, transpFun) <- + ifM (collapseDefault . optCubicalCompatible <$> pragmaOptions) + (do mtranspix <- inTopContext $ defineTranspIx name + transpFun <- inTopContext $ + defineTranspFun name mtranspix cons + (_dataPathCons dataDef) + return (mtranspix, transpFun)) + (return (Nothing, Nothing)) + -- Add the datatype to the signature with its constructors. -- It was previously added without them. - addConstant' name defaultArgInfo name t $ - dataDef{ dataCons = cons } + addConstant' name defaultArgInfo name t $ DatatypeDefn + dataDef{ _dataCons = cons + , _dataTranspIx = mtranspix + , _dataTransp = transpFun + } +-- | Make sure that the target universe admits data type definitions. +-- E.g. @IUniv@, @SizeUniv@ etc. do not accept new constructions. +checkDataSort :: QName -> Sort -> TCM () +checkDataSort name s = setCurrentRange name $ do + ifBlocked s postpone {-else-} $ \ _ (s :: Sort) -> do + let + yes :: TCM () + yes = return () + no :: TCM () + no = typeError . GenericDocError =<< + fsep [ "The universe" + , prettyTCM s + , "of" + , prettyTCM name + , "does not admit data or record declarations" + ] + case s of + -- Sorts that admit data definitions. + Type _ -> yes + Prop _ -> yes + Inf _ _ -> yes + SSet _ -> yes + DefS _ _ -> yes + -- Sorts that do not admit data definitions. + SizeUniv -> no + LockUniv -> no + IntervalUniv -> no + -- Blocked sorts. + PiSort _ _ _ -> __IMPOSSIBLE__ + FunSort _ _ -> __IMPOSSIBLE__ + UnivSort _ -> __IMPOSSIBLE__ + MetaS _ _ -> __IMPOSSIBLE__ + DummyS _ -> __IMPOSSIBLE__ + where + postpone :: Blocker -> Sort -> TCM () + postpone b s = addConstraint b $ CheckDataSort name s -- | Ensure that the type is a sort. -- If it is not directly a sort, compare it to a 'newSortMetaBelowInf'. @@ -358,20 +425,22 @@ , builtinItIsOne ] if not (all isJust required) then return $ emptyCompKit else do - hcomp <- whenDefined (null boundary) [builtinHComp,builtinTrans] (defineTranspOrHCompD DoHComp d con params names fsT t boundary) - transp <- whenDefined True [builtinTrans] (defineTranspOrHCompD DoTransp d con params names fsT t boundary) + hcomp <- whenDefined (null boundary) [builtinHComp,builtinTrans] + (defineKanOperationD DoHComp d con params names fsT t boundary) + transp <- whenDefined True [builtinTrans] + (defineKanOperationD DoTransp d con params names fsT t boundary) return $ CompKit { nameOfTransp = transp , nameOfHComp = hcomp } where -- Δ^I, i : I |- sub Δ : Δ - sub tel = parallelS [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ] + sub tel = [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ] ++# EmptyS __IMPOSSIBLE__ withArgInfo tel = zipWith Arg (map domInfo . telToList $ tel) - defineTranspOrHCompD cmd d con params names fsT t boundary = do + defineKanOperationD cmd d con params names fsT t boundary = do let project = (\ t p -> apply (Def p []) [argN t]) - stuff <- defineTranspOrHCompForFields cmd + stuff <- defineKanOperationForFields cmd (guard (not $ null boundary) >> Just (Con con ConOSystem $ teleElims fsT boundary)) project d params fsT (map argN names) t caseMaybe stuff (return Nothing) $ \ ((theName, gamma , ty, _cl_types , bodies), theSub) -> do @@ -380,7 +449,7 @@ body <- do case cmd of DoHComp -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies) - DoTransp | null boundary -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies) + DoTransp | null boundary {- && null ixs -} -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies) | otherwise -> do io <- primIOne tIMax <- primIMax @@ -416,6 +485,7 @@ the_phi = raise (size fsT) $ var 0 -- Γ ⊢ sigma : Δ.Φ -- sigma = [δ i1,bodies] + -- sigma = theSub[i1] sigma = reverse bodies ++# d1 where -- δ i1 @@ -535,6 +605,7 @@ -- Or: Just False; is it known to be non-recursive? , clauseUnreachable = Just False , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } cs = [clause] addClauses theName cs @@ -595,23 +666,23 @@ noMutualBlock $ do let cs = [ clause ] (mst, _, cc) <- compileClauses Nothing cs - let fun = emptyFunction - { funClauses = cs - , funCompiled = Just cc - , funSplitTree = mst - , funProjection = Just $ Projection + let fun = emptyFunctionData + { _funClauses = cs + , _funCompiled = Just cc + , _funSplitTree = mst + , _funProjection = Right Projection { projProper = Nothing , projOrig = projName , projFromType = Arg (getArgInfo ty) dataName , projIndex = np + 1 , projLams = ProjLams $ map (argFromDom . fmap fst) $ telToList projTel } - , funMutual = Just [] - , funTerminates = Just True + , _funMutual = Just [] + , _funTerminates = Just True } lang <- getLanguage inTopContext $ addConstant projName $ - (defaultDefn defaultArgInfo projName (unDom projType) lang fun) + (defaultDefn defaultArgInfo projName (unDom projType) lang $ FunctionDefn fun) { defNoCompilation = True , defArgOccurrences = [StrictPos] } @@ -626,59 +697,602 @@ freshAbstractQName'_ = freshAbstractQName noFixity' . C.simpleName --- * Special cases of Type ------------------------------------------------------------ +-- | Defines and returns the name of the `transpIx` function. +defineTranspIx :: QName -- ^ datatype name + -> TCM (Maybe QName) +defineTranspIx d = do + def <- getConstInfo d + case theDef def of + Datatype { dataPars = npars + , dataIxs = nixs + , dataSort = s} + -> do + let t = defType def + reportSDoc "tc.data.ixs" 20 $ vcat + [ "name :" <+> prettyTCM d + , "type :" <+> prettyTCM t + , "npars:" <+> pretty npars + , "nixs :" <+> pretty nixs + ] + if nixs == 0 then return Nothing else do + trIx <- freshAbstractQName'_ $ "transpX-" ++ P.prettyShow (A.qnameName d) + TelV params t' <- telViewUpTo npars t + TelV ixs dT <- telViewUpTo nixs t' + -- params ⊢ s + -- params ⊢ ixs + -- params.ixs ⊢ dT + reportSDoc "tc.data.ixs" 20 $ vcat + [ "params :" <+> prettyTCM params + , "ixs :" <+> (addContext params $ prettyTCM ixs) + , "dT :" <+> (addContext params $ addContext ixs $ prettyTCM dT) + ] + -- theType <- abstract params <$> undefined + interval <- primIntervalType + let deltaI = expTelescope interval ixs + iz <- primIZero + io@(Con c _ _) <- primIOne + imin <- getPrimitiveTerm "primIMin" + imax <- getPrimitiveTerm "primIMax" + ineg <- getPrimitiveTerm "primINeg" + transp <- getPrimitiveTerm builtinTrans + por <- getPrimitiveTerm "primPOr" + one <- primItIsOne + -- reportSDoc "trans.rec" 20 $ text $ show params + -- reportSDoc "trans.rec" 20 $ text $ show deltaI + -- reportSDoc "trans.rec" 10 $ text $ show fsT --- | A @Type@ with sort @Type l@ --- Such a type supports both hcomp and transp. -data LType = LEl Level Term deriving (Eq,Show) + -- let thePrefix = "transp-" + -- theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name) -fromLType :: LType -> Type -fromLType (LEl l t) = El (Type l) t + -- reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName) -lTypeLevel :: LType -> Level -lTypeLevel (LEl l t) = l + -- record type in 'exponentiated' context + -- (params : Γ)(ixs : Δ^I), i : I |- T[params, ixs i] + let rect' = sub ixs `applySubst` El (raise (size ixs) s) (Def d (teleElims (abstract params ixs) [])) + addContext params $ reportSDoc "tc.data.ixs" 20 $ "deltaI:" <+> prettyTCM deltaI + addContext params $ addContext deltaI $ addContext ("i"::String, defaultDom interval) $ do + reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty (sub ixs) + reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty rect' -toLType :: MonadReduce m => Type -> m (Maybe LType) -toLType ty = do - sort <- reduce $ getSort ty - case sort of - Type l -> return $ Just $ LEl l (unEl ty) - _ -> return $ Nothing + theType <- (abstract (setHiding Hidden <$> params) <$>) . (abstract deltaI <$>) $ runNamesT [] $ do + rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in + pure rect') + nPi' "phi" (primIntervalType) $ \ phi -> + (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io) -instance Subst LType where - type SubstArg LType = Term - applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t) + reportSDoc "tc.data.ixs" 20 $ "transpIx:" <+> prettyTCM theType + let + ctel = abstract params $ abstract deltaI $ ExtendTel (defaultDom $ subst 0 iz rect') (Abs "t" EmptyTel) + ps = telePatterns ctel [] + cpi = noConPatternInfo { conPType = Just (defaultArg interval) } + pat :: NamedArg (Pattern' DBPatVar) + pat = defaultNamedArg $ ConP c cpi [] + clause = empty + { clauseTel = ctel + , namedClausePats = init ps ++ [pat, last ps] --- | A @Type@ that either has sort @Type l@ or is a closed definition. --- Such a type supports some version of transp. --- In particular we want to allow the Interval as a @ClosedType@. -data CType = ClosedType Sort QName | LType LType deriving (Eq,Show) + , clauseBody = Just $ var 0 + , clauseType = Just $ defaultArg $ raise 1 $ subst 0 io rect' + , clauseRecursive = Just False -- non-recursive + , clauseUnreachable = Just False + } -fromCType :: CType -> Type -fromCType (ClosedType s q) = El s (Def q []) -fromCType (LType t) = fromLType t + noMutualBlock $ do + let cs = [ clause ] +-- we do not compile clauses as that leads to throwing missing clauses errors. +-- (mst, _, cc) <- compileClauses Nothing cs + let fun = emptyFunctionData + { _funClauses = cs + -- , _funCompiled = Just cc + -- , _funSplitTree = mst + , _funProjection = Left MaybeProjection + , _funMutual = Just [] + , _funTerminates = Just True + , _funIsKanOp = Just d + } + inTopContext $ do + reportSDoc "tc.transpx.type" 15 $ vcat + [ "type of" <+> prettyTCM trIx <+> ":" + , nest 2 $ prettyTCM theType + ] -toCType :: MonadReduce m => Type -> m (Maybe CType) -toCType ty = do - sort <- reduce $ getSort ty - case sort of - Type l -> return $ Just $ LType (LEl l (unEl ty)) - SSet l -> do - t <- reduce (unEl ty) - case t of - Def q [] -> return $ Just $ ClosedType (SSet l) q - _ -> return $ Nothing - _ -> return $ Nothing + addConstant trIx $ + (defaultDefn defaultArgInfo trIx theType (Cubical CErased) $ FunctionDefn fun) + { defNoCompilation = True + } -instance Subst CType where - type SubstArg CType = Term - applySubst rho (ClosedType s t) = ClosedType (applySubst rho s) t - applySubst rho (LType t) = LType $ applySubst rho t + -- reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat + -- [ "proj" <+> prettyTCM i + -- , nest 2 $ pretty fun + -- ] + -- addContext ctel $ do + -- let es = teleElims ctel [] + -- r <- reduce $ Def trIx es + -- reportSDoc "tc.data.ixs" 20 $ "reducedx:" <+> prettyTCM r + -- r <- reduce $ Def trIx (init es ++ [Apply $ argN io, last es]) + -- reportSDoc "tc.data.ixs" 20 $ "reduced1:" <+> prettyTCM r + return $ Just trIx + _ -> __IMPOSSIBLE__ + where + -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ + sub tel = expS $ size tel -defineTranspOrHCompForFields - :: TranspOrHComp + +defineTranspFun :: QName -- ^ datatype + -> Maybe QName -- ^ transpX "constructor" + -> [QName] -- ^ constructor names + -> [QName] -- ^ path cons + -> TCM (Maybe QName) -- transp function for the datatype. +defineTranspFun d mtrX cons pathCons = do + def <- getConstInfo d + case theDef def of + Datatype { dataPars = npars + , dataIxs = nixs + , dataSort = s@(Type _) +-- , dataCons = cons -- not there yet + } + -> do + let t = defType def + reportSDoc "tc.data.transp" 20 $ vcat + [ "name :" <+> prettyTCM d + , "type :" <+> prettyTCM t + , "npars:" <+> pretty npars + , "nixs :" <+> pretty nixs + ] + trD <- freshAbstractQName'_ $ "transp" ++ P.prettyShow (A.qnameName d) + TelV params t' <- telViewUpTo npars t + TelV ixs dT <- telViewUpTo nixs t' + + let tel = abstract params ixs + mixs <- runMaybeT $ traverse (traverse (MaybeT . toLType)) ixs + caseMaybe mixs (return Nothing) $ \ _ -> do + + io@(Con io_c _ []) <- primIOne + iz <- primIZero + + interval <- primIntervalType + let telI = expTelescope interval tel + sigma = sub tel + dTs = (sigma `applySubst` El s (Def d $ map Apply $ teleArgs tel)) + + theType <- (abstract telI <$>) $ runNamesT [] $ do + dT <- open $ Abs "i" $ dTs + nPi' "phi" primIntervalType $ \ phi -> + (absApp <$> dT <*> pure iz) --> (absApp <$> dT <*> pure io) + + + reportSDoc "tc.data.transp" 20 $ "transpD:" <+> prettyTCM theType + + + noMutualBlock $ do + inTopContext $ addConstant trD $ + (defaultDefn defaultArgInfo trD theType (Cubical CErased) emptyFunction) + let + ctel = abstract telI $ ExtendTel (defaultDom $ subst 0 iz dTs) (Abs "t" EmptyTel) + ps = telePatterns ctel [] + cpi = noConPatternInfo { conPType = Just (defaultArg interval) + , conPFallThrough = True + } + pat :: NamedArg (Pattern' DBPatVar) + pat = defaultNamedArg $ ConP io_c cpi [] + clause = empty + { clauseTel = ctel + , namedClausePats = init ps ++ [pat, last ps] + + , clauseBody = Just $ var 0 + , clauseType = Just $ defaultArg $ raise 1 $ subst 0 io dTs + , clauseRecursive = Just False -- non-recursive + , clauseUnreachable = Just False + } + let debugNoTransp cl = enterClosure cl $ \ t -> do + reportSDoc "tc.data.transp" 20 $ addContext ("i" :: String, __DUMMY_DOM__) $ + "could not transp" <+> prettyTCM (absBody t) + -- TODO: if no params nor indexes trD phi u0 = u0. + ecs <- tryTranspError $ (clause:) <$> defineConClause trD (not $ null pathCons) mtrX npars nixs ixs telI sigma dTs cons + caseEitherM (pure ecs) (\ cl -> debugNoTransp cl >> return Nothing) $ \ cs -> do + (mst, _, cc) <- compileClauses Nothing cs + let fun = emptyFunctionData + { _funClauses = cs + , _funCompiled = Just cc + , _funSplitTree = mst + , _funProjection = Left MaybeProjection + , _funMutual = Just [] + , _funTerminates = Just True + , _funIsKanOp = Just d + } + inTopContext $ addConstant trD $ + (defaultDefn defaultArgInfo trD theType (Cubical CErased) $ FunctionDefn fun) + { defNoCompilation = True + } + reportSDoc "tc.data.transp" 20 $ sep + [ "transp: compiled clauses of " <+> prettyTCM trD + , nest 2 $ return $ P.pretty cc + ] + + return $ Just trD + + + Datatype {} -> return Nothing + _ -> __IMPOSSIBLE__ + where + -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ + sub tel = expS (size tel) + +defineConClause :: QName -- ^ trD + -> Bool -- ^ HIT + -> Maybe QName -- ^ trX + -> Nat -- ^ npars = size Δ + -> Nat -- ^ nixs = size X + -> Telescope -- ^ Δ ⊢ X + -> Telescope -- ^ (Δ.X)^I + -> Substitution -- ^ (Δ.X)^I, i : I ⊢ σ : Δ.X + -> Type -- ^ (Δ.X)^I, i : I ⊢ D[δ i,x i] -- datatype + -> [QName] -- ^ Constructors + -> TCM [Clause] +defineConClause trD' isHIT mtrX npars nixs xTel' telI sigma dT' cnames = do + + unless (isNothing mtrX == (nixs == 0)) $ __IMPOSSIBLE__ + + io <- primIOne + iz <- primIZero + tHComp <- primHComp + tINeg <- primINeg + let max i j = cl primIMax <@> i <@> j + let min i j = cl primIMin <@> i <@> j + let neg i = cl primINeg <@> i + let hcomp ty sys u0 = do + ty <- ty + Just (LEl l ty) <- toLType ty + l <- open $ Level l + ty <- open $ ty + face <- (foldr max (pure iz) $ map fst $ sys) + sys <- lam "i'" $ \ i -> combineSys l ty [(phi, u <@> i) | (phi,u) <- sys] + pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0 + interval <- primIntervalType + let intervalTel nm = ExtendTel (defaultDom interval) (Abs nm EmptyTel) + + let (parI,ixsI) = splitTelescopeAt npars telI + let + abstract_trD :: MonadFail m => (Vars m -> Vars m -> Vars m -> NamesT m Telescope) -> NamesT m Telescope + abstract_trD k = do + ixsI <- open $ AbsN (teleNames parI) ixsI + parI <- open parI + abstractN parI $ \ delta -> do + abstractN (ixsI `applyN` delta) $ \ x -> do + abstractN (pure $ intervalTel "phi") $ \ phi -> do + k delta x phi + bind_trD :: MonadFail m => (ArgVars m -> ArgVars m -> ArgVars m -> NamesT m b) -> + NamesT m (AbsN (AbsN (AbsN b))) + bind_trD k = do + bindNArg (teleArgNames parI) $ \ delta_ps -> do + bindNArg (teleArgNames ixsI) $ \ x_ps -> do + bindNArg (teleArgNames $ intervalTel "phi") $ \ phi_ps -> do + k delta_ps x_ps phi_ps + let trD = bindNArg (teleArgNames parI) $ \ delta -> + bindNArg (teleArgNames ixsI) $ \ x -> + bindN ["phi","u0"] $ \ [phi,u0] -> + ((Def trD' [] `apply`) <$> sequence (delta ++ x)) <@> phi <@> u0 + -- [Δ] ⊢ X + let xTel = pure $ AbsN (teleNames parI) xTel' + -- [δ : Δ^I, x : X^I, i : I] ⊢ D (δ i) (x i) + let dT = pure $ AbsN (teleNames parI ++ teleNames ixsI ++ ["i"]) dT' + + let hcompComputes = not $ isHIT || nixs > 0 + c_HComp <- if hcompComputes then return [] else do + reportSDoc "tc.data.transp.con" 20 $ "=======================" + reportSDoc "tc.data.transp.con" 20 $ "hcomp" + qHComp <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp + hcomp_ty <- defType <$> getConstInfo qHComp + gamma <- runNamesT [] $ do + ixsI <- open $ AbsN (teleNames parI) ixsI + parI <- open parI + abstract_trD $ \ delta x _ -> do + Just (LEl l ty) <- toLType =<< (dT `applyN` (delta ++ x ++ [pure iz])) + -- (φ : I), (I → Partial φ (D (δ i0) (x i0))), D (δ i0) (x i0) + TelV args _ <- lift $ telView =<< piApplyM hcomp_ty [Level l,ty] + unless (size args == 3) __IMPOSSIBLE__ + pure args + res <- runNamesT [] $ do + let hcompArgs = map argN ["phi","u","u0"] + bind_trD $ \ delta_ps x_ps phi_ps -> do + let x = map (fmap unArg) x_ps + let delta = map (fmap unArg) delta_ps + let [phi] = map (fmap unArg) phi_ps + bindNArg hcompArgs $ \ as0 -> do -- as0 : aTel[delta 0] + let + origPHComp = do + Just (LEl l t) <- toLType =<< (dT `applyN` (delta ++ x ++ [pure iz])) + let ds = map (argH . unnamed . dotP) [Level l, t] + ps0@[_hphi,_u,_u0] <- sequence $ as0 + pure $ DefP defaultPatternInfo qHComp $ ds ++ ps0 + psHComp = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPHComp] + let + rhsTy = dT `applyN` (delta ++ x ++ [pure io]) + -- trD δ x φ (hcomp [hφ ↦ u] u0) ↦ rhsHComp + let rhsHComp = do + let [hphi,u,u0] = map (fmap unArg) as0 + -- TODO: should trD be transp for the datatype? + let baseHComp = trD `applyN` delta `applyN` x `applyN` [phi,u0] + let sideHComp = lam "i" $ \ i -> ilam "o" $ \ o -> do + trD `applyN` delta `applyN` x `applyN` [phi,u <@> i <..> o] + hcomp rhsTy [(hphi, sideHComp)] baseHComp + (,,) <$> psHComp <*> rhsTy <*> rhsHComp + let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res + (:[]) <$> mkClause gamma ps rhsTy rhs + + + c_trX <- caseMaybe mtrX (pure []) $ \ trX -> do + reportSDoc "tc.data.transp.con" 20 $ "=======================" + reportSDoc "tc.data.transp.con" 20 $ prettyTCM trX + gamma <- runNamesT [] $ do + ixsI <- open $ AbsN (teleNames parI) ixsI + parI <- open parI + abstract_trD $ \ delta _ _ -> do + let delta0_refl = flip map delta $ \ p -> lam "i" $ \ _ -> p <@> pure iz + abstractN (ixsI `applyN` delta0_refl) $ \ x' -> do + abstractN (pure $ intervalTel "phi'") $ \ _ -> do + ty <- dT `applyN` (delta0_refl ++ x' ++ [pure iz]) + pure $ ExtendTel (defaultDom ty) $ Abs "t" EmptyTel + res <- runNamesT [] $ + bind_trD $ \ delta_ps x_ps phi_ps -> do + let x = map (fmap unArg) x_ps + let delta = map (fmap unArg) delta_ps + let [phi] = map (fmap unArg) phi_ps + --- pattern matching args below + bindNArg (map (fmap (++ "'")) (teleArgNames ixsI)) $ \ x'_ps -> do + let x' = map (fmap unArg) x'_ps :: [NamesT TCM Term] + let phi'name = teleArgNames $ intervalTel "phi'" + bindNArg phi'name $ \ phi'_ps -> do + let phi's = map (fmap unArg) phi'_ps + bindNArg [argN "t"] $ \ as0 -> do + let deltaArg i = do + i <- i + xs <- sequence delta_ps + pure $ map (fmap (`apply` [argN i])) xs + + let + origPTrX = do + x'_ps <- sequence x'_ps + phi'_ps <- sequence phi'_ps + ds <- map (setHiding Hidden . fmap (unnamed . dotP)) <$> deltaArg (pure iz) + ps0@[_t] <- sequence as0 + pure $ DefP defaultPatternInfo trX $ ds ++ x'_ps ++ phi'_ps ++ ps0 + psTrX = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPTrX] + + rhsTy = dT `applyN` (delta ++ x ++ [pure io]) + + -- trD δ x φ (trX x' φ' t) ↦ rhsTrx + let rhsTrX = do + let [t] = map (fmap unArg) as0 + let [phi'] = phi's + let telXdeltai = bind "i" $ \ i -> applyN xTel (map (<@> i) delta) + let reflx1 = flip map x $ \ q -> lam "i" $ \ _ -> q <@> pure io + let symx' = flip map x' $ \ q' -> lam "i" $ \ i -> q' <@> neg i + x_tr <- mapM (open . unArg) =<< transpPathTel' telXdeltai symx' reflx1 phi' x + let baseTrX = trD `applyN` delta `applyN` x_tr `applyN` [phi `min` phi',t] + let sideTrX = lam "j" $ \ j -> ilam "o" $ \ _ -> do + let trD_f = trD `applyN` (flip map delta $ \ p -> lam "i" $ \ i -> p <@> (i `min` neg j)) + `applyN` (flip map x_tr $ \ p -> lam "i" $ \ i -> p <@> (i `min` neg j)) + `applyN` [(phi `min` phi') `max` j,t] + let x_tr_f = fmap (fmap (\ (Abs n (Arg i t)) -> Arg i $ Lam defaultArgInfo (Abs n t)) . sequence) $ + bind "i" $ \ i -> do + j <- j + map (fmap (`apply` [argN j])) <$> trFillPathTel' telXdeltai symx' reflx1 phi' x (neg i) + let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) x_tr_f + (apply (Def trX []) <$> args) <@> (phi' `max` neg j) <@> trD_f + hcomp rhsTy [(phi,sideTrX),(phi',lam "i" $ \ _ -> ilam "o" $ \ _ -> baseTrX)] + baseTrX + + (,,) <$> psTrX <*> rhsTy <*> rhsTrX + + + let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ res + (:[]) <$> mkClause gamma ps rhsTy rhs + + fmap ((c_HComp ++ c_trX) ++) $ forM cnames $ \ cname -> do + def <- getConstInfo cname + let + Constructor + { conPars = npars' + , conArity = nargs + , conSrcCon = chead + } = theDef def + do + let tcon = defType def + + reportSDoc "tc.data.transp.con" 20 $ "=======================" + reportSDoc "tc.data.transp.con" 20 $ "tcon:" <+> prettyTCM (conName chead) <+> prettyTCM tcon + + unless (conName chead == cname && npars' == npars) $ __IMPOSSIBLE__ + + + TelV prm tcon' <- telViewUpTo npars' tcon + -- Δ ⊢ aTel + -- Δ.aTel ⊢ ty + -- Δ.aTel ⊢ [(φ,(l,r))] = boundary : ty + (TelV aTel ty, boundary) <- telViewUpToPathBoundary nargs tcon' + + Def _ es <- unEl <$> reduce ty + -- Δ.aTel ⊢ con_ixs : X + let con_ixs = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop npars es + + reportSDoc "tc.data.transp.con" 20 $ + addContext prm $ "aTel:" <+> prettyTCM aTel + reportSDoc "tc.data.transp.con" 20 $ + addContext prm $ addContext aTel $ "ty:" <+> prettyTCM ty + reportSDoc "tc.data.transp.con" 20 $ + addContext prm $ addContext aTel $ "boundary:" <+> prettyTCM boundary + + gamma <- runNamesT [] $ do + ixsI <- open $ AbsN (teleNames parI) ixsI + aTel <- open $ AbsN (teleNames prm) aTel + parI <- open parI + abstract_trD $ \ delta _ _ -> do + let args = aTel `applyN` map (<@> pure iz) delta + args + res <- runNamesT [] $ do + let aTelNames = teleNames aTel + aTelArgs = teleArgNames aTel + con_ixs <- open $ AbsN (teleNames prm ++ teleNames aTel) $ map unArg con_ixs + bndry <- open $ AbsN (teleNames prm ++ teleNames aTel) $ boundary + u <- open $ AbsN (teleNames prm ++ aTelNames) $ Con chead ConOSystem (teleElims aTel boundary) + aTel <- open $ AbsN (teleNames prm) aTel + -- bsys : Abs Δ.Args ([phi] → ty) + (bsysFace,bsys) <- do + p <- bindN (teleNames prm ++ aTelNames) $ \ ts -> do + Just (LEl l ty) <- toLType ty + l <- open (Level l) + ty <- open ty + bs <- bndry `applyN` ts + xs <- mapM (\(phi,u) -> (,) <$> open phi <*> open u) $ do + (i,(l,r)) <- bs + let pElem t = Lam (setRelevance Irrelevant defaultArgInfo) $ NoAbs "o" t + [(tINeg `apply` [argN i],pElem l),(i,pElem r)] + combineSys' l ty xs + (,) <$> open (fst <$> p) <*> open (snd <$> p) + bind_trD $ \ delta_ps x_ps phi_ps -> do + let x = map (fmap unArg) x_ps + let delta = map (fmap unArg) delta_ps + let [phi] = map (fmap unArg) phi_ps + --- pattern matching args below + bindNArg aTelArgs $ \ as0 -> do -- as0 : aTel[delta 0] + + let aTel0 = aTel `applyN` map (<@> pure iz) delta + + -- telePatterns is not context invariant, so we need an open here where the context ends in aTel0. + ps0 <- (open =<<) $ (telePatterns <$> aTel0 <*> (applyN bndry $ map (<@> pure iz) delta ++ map (fmap unArg) as0)) + + let deltaArg i = do + i <- i + xs <- sequence delta_ps + pure $ map (fmap (`apply` [argN i])) xs + + let + origP = ConP chead noConPatternInfo <$> ps0 + ps = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origP] + let + orig = patternToTerm <$> origP + rhsTy = dT `applyN` (delta ++ x ++ [pure io]) + + (,,) <$> ps <*> rhsTy <*> do + + -- Declared Constructors. + let aTelI = bind "i" $ \ i -> aTel `applyN` map (<@> i) delta + + eas1 <- (=<<) (lift . runExceptT) $ transpTel <$> aTelI <*> phi <*> sequence as0 + + caseEitherM (pure eas1) (lift . lift . E.throw . CannotTransp) $ \ as1 -> do + + as1 <- mapM (open . unArg) as1 + + as01 <- (open =<<) $ bind "i" $ \ i -> do + eas01 <- (=<<) (lift . runExceptT) $ trFillTel <$> aTelI <*> phi <*> sequence as0 <*> i + caseEitherM (pure eas01) (lift . lift . E.throw . CannotTransp) pure + + let argApp a t = liftM2 (\ a t -> fmap (`apply` [argN t]) a) a t + let + argLam :: MonadFail m => String -> (Var m -> NamesT m (Arg Term)) -> NamesT m (Arg Term) + argLam n f = (\ (Abs n (Arg i t)) -> Arg i $ Lam defaultArgInfo $ Abs n t) <$> bind "n" f + let cas1 = applyN u $ map (<@> pure io) delta ++ as1 + + let base | Nothing <- mtrX = cas1 + | Just trX <- mtrX = do + let theTel = bind "j" $ \ j -> bind "i" $ \ i -> applyN xTel (map (<@> max i j) delta) + let theLeft = lamTel $ bind "i" $ \ i -> do + as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i) + con_ixs `applyN` (map (<@> i) delta ++ as01) + theLeft <- mapM open =<< theLeft + theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> do + con_ixs `applyN` (map (<@> pure io) delta ++ as1) + + trx' <- transpPathPTel' theTel x theRight phi theLeft + let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) (forM trx' $ \ q' -> do + q' <- open q' + argLam "i" $ \ i -> q' `argApp` neg i) + (apply (Def trX []) <$> args) <@> phi <@> cas1 + + + if null boundary then base else do + + -- We have to correct the boundary for path constructors. + + -- bline : Abs I ([phi] → ty) + let blineFace = applyN bsysFace $ map (<@> pure io) delta ++ as1 + let bline = do + let theTel = bind "j" $ \ j -> bind "i" $ \ i -> applyN xTel (map (<@> max i j) delta) + let theLeft = lamTel $ bind "i" $ \ i -> do + as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i) + con_ixs `applyN` (map (<@> i) delta ++ as01) + theLeft <- mapM open =<< theLeft + theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> do + con_ixs `applyN` (map (<@> pure io) delta ++ as1) + let q2_f = bind "i" $ \ i -> map unArg <$> trFillPathPTel' theTel x theRight phi theLeft i + + lam "i" $ \ i -> do + let v0 = do + as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i) + applyN bsys $ map (<@> i) delta ++ as01 + let squeezedv0 = ilam "o" $ \ o -> do + let + delta_f :: [NamesT TCM Term] + delta_f = flip map delta $ \ p -> lam "j" $ \ j -> p <@> (j `max` i) + x_f <- (mapM open =<<) $ lamTel $ bind "j" $ \ j -> + (absApp <$> q2_f <*> j) `appTel` i + trD `applyN` delta_f `applyN` x_f `applyN` [phi `max` i, v0 <..> o] + + caseMaybe mtrX squeezedv0 $ \ trX -> ilam "o" $ \ o -> do + q2 <- transpPathPTel' theTel x theRight phi theLeft + let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) + (forM q2 $ \ q' -> do + q' <- open q' + argLam "j" $ \ j -> q' `argApp` (neg j `min` i)) + + (apply (Def trX []) <$> args) <@> (neg i `max` phi) <@> (squeezedv0 <..> o) + hcomp + rhsTy + [(blineFace,lam "i" $ \ i -> bline <@> (neg i)) + ,(phi ,lam "i" $ \ _ -> ilam "o" $ \ _ -> orig) + ] + base + + let + (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res + mkClause gamma ps rhsTy rhs + where + mkClause gamma ps rhsTy rhs = do + let + c = Clause + { clauseTel = gamma + , clauseType = Just . argN $ rhsTy + , namedClausePats = ps + , clauseFullRange = noRange + , clauseLHSRange = noRange + , clauseCatchall = False + , clauseBody = Just $ rhs + , clauseRecursive = Nothing + -- it is indirectly recursive through transp, does it count? + , clauseUnreachable = Just False + , clauseEllipsis = NoEllipsis + , clauseExact = Nothing + , clauseWhereModule = Nothing + } + reportSDoc "tc.data.transp.con" 20 $ + "gamma:" <+> prettyTCM gamma + reportSDoc "tc.data.transp.con" 20 $ addContext gamma $ + "ps :" <+> prettyTCM (patternsToElims ps) + reportSDoc "tc.data.transp.con" 20 $ addContext gamma $ + "type :" <+> prettyTCM rhsTy + reportSDoc "tc.data.transp.con" 20 $ addContext gamma $ + "body :" <+> prettyTCM rhs + + reportSDoc "tc.data.transp.con" 30 $ + addContext gamma $ "c:" <+> pretty c + return c + + +defineKanOperationForFields + :: Command -> (Maybe Term) -- ^ PathCons, Δ.Φ ⊢ u : R δ -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term -> QName -- ^ some name, e.g. record name @@ -687,7 +1301,7 @@ -> [Arg QName] -- ^ fields' names -> Type -- ^ record type Δ ⊢ T -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution)) -defineTranspOrHCompForFields cmd pathCons project name params fsT fns rect = +defineKanOperationForFields cmd pathCons project name params fsT fns rect = case cmd of DoTransp -> runMaybeT $ do fsT' <- traverse (traverse (MaybeT . toCType)) fsT @@ -709,6 +1323,13 @@ -> [Arg QName] -- ^ fields' names -> Type -- ^ record type Δ ⊢ T -> TCM ((QName, Telescope, Type, [Dom Type], [Term]), Substitution) + -- ^ @((name, tel, rtype, clause_types, bodies), sigma)@ + -- name: name of transport function for this constructor/record. clauses still missing. + -- tel: Ξ telescope for the RHS, Ξ ⊃ (Δ^I, φ : I), also Ξ ⊢ us0 : Φ[δ 0] + -- rtype: Ξ ⊢ T' := T[δ 1] + -- clause_types: Ξ ⊢ Φ' := Φ[δ 1] + -- bodies: Ξ ⊢ us1 : Φ' + -- sigma: Ξ, i : I ⊢ σ : Δ.Φ -- line [δ 0,us0] ≡ [δ 0,us1] defineTranspForFields pathCons applyProj name params fsT fns rect = do interval <- primIntervalType let deltaI = expTelescope interval params @@ -720,9 +1341,9 @@ transp <- getPrimitiveTerm builtinTrans -- por <- getPrimitiveTerm "primPOr" -- one <- primItIsOne - reportSDoc "trans.rec" 20 $ text $ show params - reportSDoc "trans.rec" 20 $ text $ show deltaI - reportSDoc "trans.rec" 10 $ text $ show fsT + reportSDoc "trans.rec" 20 $ pretty params + reportSDoc "trans.rec" 20 $ pretty deltaI + reportSDoc "trans.rec" 10 $ pretty fsT let thePrefix = "transp-" theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name) @@ -741,7 +1362,7 @@ lang <- getLanguage noMutualBlock $ addConstant theName $ (defaultDefn defaultArgInfo theName theType lang - (emptyFunction { funTerminates = Just True })) + (FunctionDefn $ emptyFunctionData { _funTerminates = Just True, _funIsKanOp = Just name })) { defNoCompilation = True } -- ⊢ Γ = gamma = (δ : Δ^I) (φ : I) (u0 : R (δ i0)) -- Γ ⊢ rtype = R (δ i1) @@ -852,17 +1473,7 @@ -- (params : Δ^I), i : I |- T[params i] rect' = sub params `applySubst` rect -- Δ^I, i : I |- sub Δ : Δ - sub tel = parallelS [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ] - -- given I type, and Δ telescope, build Δ^I such that - -- (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...) - expTelescope :: Type -> Telescope -> Telescope - expTelescope int tel = unflattenTel names ys - where - xs = flattenTel tel - names = teleNames tel - t = ExtendTel (defaultDom $ raise (size tel) int) (Abs "i" EmptyTel) - s = sub tel - ys = map (fmap (abstract t) . applySubst s) xs + sub tel = expS $ size tel -- invariant: resulting tel Γ is such that Γ = (δ : Δ), (φ : I), (u : ...), (a0 : R δ)) -- where u and a0 have types matching the arguments of primHComp. @@ -909,7 +1520,7 @@ lang <- getLanguage noMutualBlock $ addConstant theName $ (defaultDefn defaultArgInfo theName theType lang - (emptyFunction { funTerminates = Just True })) + (FunctionDefn $ emptyFunctionData { _funTerminates = Just True, _funIsKanOp = Just name })) { defNoCompilation = True } -- ⊢ Γ = gamma = (δ : Δ) (φ : I) (_ : (i : I) -> Partial φ (R δ)) (_ : R δ) -- Γ ⊢ rtype = R δ @@ -996,7 +1607,7 @@ comp lvl filled_ty phi - (lam "i" $ \ i -> lam "o" $ \ o -> proj $ w <@> i <@> o) -- TODO wait for phi = 1 + (lam "i" $ \ i -> ilam "o" $ \ o -> proj $ w <@> i <..> o) -- TODO wait for phi = 1 (proj w0) reportSDoc "hcomp.rec" 60 $ text $ "filled_types sorts:" ++ show (map (getSort . fromLType . unDom) filled_types) @@ -1118,9 +1729,9 @@ -- noConstraints $ s' `leqSort` s withoutK <- withoutKOption - when withoutK $ whenM (isFibrant s) $ do + when withoutK $ do q <- viewTC eQuantity - usableAtModality (setQuantity q defaultModality) (unEl t) + usableAtModality' (Just s) ConstructorType (setQuantity q defaultModality) (unEl t) fitsIn' withoutK forceds t s where diff --git a/src/full/Agda/TypeChecking/Rules/Data.hs-boot b/src/full/Agda/TypeChecking/Rules/Data.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Rules/Data.hs-boot @@ -0,0 +1,6 @@ +module Agda.TypeChecking.Rules.Data where + +import Agda.Syntax.Internal ( QName, Sort ) +import Agda.TypeChecking.Monad.Base ( TCM ) + +checkDataSort :: QName -> Sort -> TCM () 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 @@ -9,8 +9,7 @@ import Data.Either (partitionEithers) import qualified Data.Foldable as Fold -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet +import qualified Data.Map.Strict as MapS import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) @@ -194,6 +193,9 @@ -- TODO: Benchmarking for unquote. A.UnquoteDecl mi is xs e -> checkMaybeAbstractly is $ checkUnquoteDecl mi is xs e A.UnquoteDef is xs e -> impossible $ checkMaybeAbstractly is $ checkUnquoteDef is xs e + A.UnquoteData is x uc js cs e -> checkMaybeAbstractly (is ++ js) $ do + reportSDoc "tc.unquote.data" 20 $ "Checking unquoteDecl data" <+> prettyTCM x + Nothing <$ unquoteTop (x:cs) e whenNothingM (asksTC envMutualBlock) $ do @@ -201,7 +203,8 @@ highlight_ DontHightlightModuleContents d -- Defaulting of levels (only when --cumulativity) - whenM (optCumulativity <$> pragmaOptions) $ defaultLevelsToZero metas + whenM (optCumulativity <$> pragmaOptions) $ + defaultLevelsToZero (openMetas metas) -- Post-typing checks. whenJust finalChecks $ \ theMutualChecks -> do @@ -213,17 +216,13 @@ case d of A.Generalize{} -> pure () _ -> do - reportSLn "tc.decl" 20 $ "Freezing all metas." - void $ freezeMetas metas + reportSLn "tc.decl" 20 $ "Freezing all open metas." + void $ freezeMetas (openMetas metas) theMutualChecks where - -- check record or data type signature - checkSig kind i x gtel t = checkTypeSignature' (Just gtel) $ - A.Axiom kind i defaultArgInfo Nothing x t - -- Switch maybe to abstract mode, benchmark, and debug print bracket. check :: forall m i a . ( MonadTCEnv m, MonadPretty m, MonadDebug m @@ -308,7 +307,7 @@ case theDef def of Record{ recEtaEquality' = Inferred YesEta } -> return $ Just $ Left q Function - { funProjection = Nothing + { funProjection = Left MaybeProjection -- Andreas, 2017-08-10, issue #2664: -- Do not record pattern translate record projection definitions! , funCompiled = Just cc @@ -384,6 +383,10 @@ -- mutual block we have. Hence the flag. highlight_ :: HighlightModuleContents -> A.Declaration -> TCM () highlight_ hlmod d = do + reportSDoc "tc.decl" 45 $ + text "Highlighting a declaration with the following spine:" + $$ + text (show $ A.declarationSpine d) let highlight d = generateAndPrintSyntaxInfo d Full True Bench.billTo [Bench.Highlighting] $ case d of A.Axiom{} -> highlight d @@ -402,11 +405,13 @@ A.Generalize{} -> highlight d A.UnquoteDecl{} -> highlight d A.UnquoteDef{} -> highlight d + A.UnquoteData{} -> highlight d A.Section i x tel ds -> do highlight (A.Section i x tel []) when (hlmod == DoHighlightModuleContents) $ mapM_ (highlight_ hlmod) (deepUnscopeDecls ds) A.RecSig{} -> highlight d - A.RecDef i x uc dir ps tel cs -> highlight (A.RecDef i x uc dir A.noDataDefParams dummy cs) + A.RecDef i x uc dir ps tel cs -> + highlight (A.RecDef i x uc dir ps dummy cs) -- The telescope has already been highlighted. where -- Andreas, 2016-01-22, issue 1790 @@ -524,10 +529,12 @@ (a, ms) <- metasCreatedBy m reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing." wakeupConstraints_ -- solve emptiness and instance constraints - xs <- freezeMetas ms + xs <- freezeMetas (openMetas ms) reportSDoc "tc.decl.ax" 20 $ vcat - [ "Abstract type signature produced new metas: " <+> sep (map prettyTCM $ IntMap.keys ms) - , "We froze the following ones of these: " <+> sep (map prettyTCM $ IntSet.toList xs) + [ "Abstract type signature produced new open metas: " <+> + sep (map prettyTCM $ MapS.keys (openMetas ms)) + , "We froze the following ones of these: " <+> + sep (map prettyTCM $ Set.toList xs) ] return a @@ -635,8 +642,8 @@ -- Set blocking tag to MissingClauses if we still expect clauses let blk = case kind of - FunName -> NotBlocked MissingClauses () - MacroName -> NotBlocked MissingClauses () + FunName -> NotBlocked (MissingClauses x) () + MacroName -> NotBlocked (MissingClauses x) () _ -> NotBlocked ReallyNotBlocked () -- Not safe. See Issue 330 @@ -645,12 +652,13 @@ lang <- getLanguage let defn = defaultDefn info x t lang $ case kind of -- #4833: set abstract already here so it can be inherited by with functions - FunName -> emptyFunction{ funAbstr = Info.defAbstract i } - MacroName -> set funMacro True emptyFunction{ funAbstr = Info.defAbstract i } + FunName -> fun + MacroName -> set funMacro True fun DataName -> DataOrRecSig npars RecName -> DataOrRecSig npars AxiomName -> defaultAxiom -- Old comment: NB: used also for data and record type sigs _ -> __IMPOSSIBLE__ + where fun = FunctionDefn $ emptyFunctionData{ _funAbstr = Info.defAbstract i } addConstant x =<< do useTerPragma $ defn @@ -741,6 +749,12 @@ Function{} -> markStatic x _ -> typeError $ GenericError "STATIC directive only works on functions" A.InjectivePragma x -> markInjective x + A.NotProjectionLikePragma qn -> do + def <- 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" A.InlinePragma b x -> do def <- getConstInfo x case theDef def of @@ -781,6 +795,12 @@ (blockId, ) . mutualNames <$> lookupMutualBlock blockId + -- check record or data type signature +checkSig :: KindOfName -> A.DefInfo -> QName -> A.GeneralizeTelescope -> A.Expr -> TCM () +checkSig kind i x gtel t = checkTypeSignature' (Just gtel) $ + A.Axiom kind i defaultArgInfo Nothing x t + + -- | Type check the type signature of an inductive or recursive definition. checkTypeSignature :: A.TypeSignature -> TCM () checkTypeSignature = checkTypeSignature' Nothing @@ -1029,6 +1049,7 @@ A.UnquoteDecl {} -> "UnquoteDecl" A.ScopedDecl {} -> "ScopedDecl" A.UnquoteDef {} -> "UnquoteDef" + A.UnquoteData {} -> "UnquoteDecl data" debugPrintDecl :: A.Declaration -> TCM () debugPrintDecl d = do diff --git a/src/full/Agda/TypeChecking/Rules/Decl.hs-boot b/src/full/Agda/TypeChecking/Rules/Decl.hs-boot --- a/src/full/Agda/TypeChecking/Rules/Decl.hs-boot +++ b/src/full/Agda/TypeChecking/Rules/Decl.hs-boot @@ -3,8 +3,10 @@ import Agda.Syntax.Info (ModuleInfo) import Agda.Syntax.Abstract +import Agda.Syntax.Scope.Base import Agda.TypeChecking.Monad.Base (TCM) checkDecls :: [Declaration] -> TCM () checkDecl :: Declaration -> TCM () +checkSig :: KindOfName -> DefInfo -> QName -> GeneralizeTelescope -> Expr -> TCM () checkSectionApplication :: ModuleInfo -> ModuleName -> ModuleApplication -> ScopeCopyInfo -> TCM () 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 @@ -8,7 +8,7 @@ import Control.Monad.Except ( MonadError(..) ) import Data.Bifunctor -import Data.Function +import Data.Function (on) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List @@ -73,6 +73,7 @@ import qualified Agda.Utils.SmallSet as SmallSet import Agda.Utils.Impossible +import Agda.Utils.WithDefault --------------------------------------------------------------------------- -- * Definitions by pattern matching @@ -82,7 +83,7 @@ checkFunDef delayed i name cs = do -- Reset blocking tag (in case a previous attempt was blocked) modifySignature $ updateDefinition name $ updateDefBlocked $ const $ - NotBlocked MissingClauses () + NotBlocked (MissingClauses name) () -- Get the type and relevance of the function def <- instantiateDef =<< getConstInfo name let t = defType def @@ -97,7 +98,7 @@ -- See issue 729. -- Ulf, 2021-02-09: also unfreeze metas in the sort of this type whenM (isFrozen x) $ do - xs <- allMetasList . jMetaType . mvJudgement <$> lookupMeta x + xs <- allMetasList . jMetaType . mvJudgement <$> lookupLocalMeta x mapM_ unfreezeMeta (x : xs) checkAlias t info delayed i name e mc | otherwise -> do -- Warn about abstract alias (will never work!) @@ -106,7 +107,7 @@ -- blocks you might actually have solved the type of an alias by the time you get to -- the definition. See test/Succeed/SizeInfinity.agda for an example where this -- happens. - whenM (isOpenMeta . mvInstantiation <$> lookupMeta x) $ + whenM (isOpenMeta <$> lookupMetaInstantiation x) $ setCurrentRange i $ genericWarning =<< "Missing type signature for abstract definition" <+> (prettyTCM name <> ".") $$ fsep (pwords "Types of abstract definitions are never inferred since this would leak" ++ @@ -184,27 +185,27 @@ _ -> id -- Add the definition - addConstant' name ai name t - $ set funMacro (Info.defMacro i == MacroDef) $ - emptyFunction - { funClauses = [ Clause -- trivial clause @name = v@ - { clauseLHSRange = getRange i - , clauseFullRange = getRange i - , clauseTel = EmptyTel - , namedClausePats = [] - , clauseBody = Just $ bodyMod v - , clauseType = Just $ Arg ai t - , clauseCatchall = False - , clauseExact = Just True - , clauseRecursive = Nothing -- we don't know yet - , clauseUnreachable = Just False - , clauseEllipsis = NoEllipsis - } ] - , funCompiled = Just $ Done [] $ bodyMod v - , funSplitTree = Just $ SplittingDone 0 - , funDelayed = delayed - , funAbstr = Info.defAbstract i - } + addConstant' name ai name t $ set funMacro (Info.defMacro i == MacroDef) $ + FunctionDefn emptyFunctionData + { _funClauses = [ Clause -- trivial clause @name = v@ + { clauseLHSRange = getRange i + , clauseFullRange = getRange i + , clauseTel = EmptyTel + , namedClausePats = [] + , clauseBody = Just $ bodyMod v + , clauseType = Just $ Arg ai t + , clauseCatchall = False + , clauseExact = Just True + , clauseRecursive = Nothing -- we don't know yet + , clauseUnreachable = Just False + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing + } ] + , _funCompiled = Just $ Done [] $ bodyMod v + , _funSplitTree = Just $ SplittingDone 0 + , _funDelayed = delayed + , _funAbstr = Info.defAbstract i + } -- Andreas, 2017-01-01, issue #2372: -- Add the definition to the instance table, if needed, to update its type. @@ -332,15 +333,16 @@ let c = Clause { clauseFullRange = noRange , clauseLHSRange = noRange - , clauseTel = tel + , clauseTel = tel , namedClausePats = teleNamedArgs tel - , clauseBody = Nothing - , clauseType = Just (defaultArg t) - , clauseCatchall = False - , clauseExact = Just True - , clauseRecursive = Just False + , clauseBody = Nothing + , clauseType = Just (defaultArg t) + , clauseCatchall = False + , clauseExact = Just True + , clauseRecursive = Just False , clauseUnreachable = Just False - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } return (cs ++ [c], pure sys) @@ -408,20 +410,26 @@ -- Add the definition inTopContext $ addConstant name =<< do + + reportSDoc "tc.def.fun.clauses" 15 $ inTopContext $ do + vcat [ "final clauses for" <+> prettyTCM name <+> ":" + , nest 2 $ vcat $ map (prettyTCM . QNamed name) cs + ] + -- If there was a pragma for this definition, we can set the -- funTerminates field directly. defn <- autoInline $ set funMacro (ismacro || Info.defMacro i == MacroDef) $ - emptyFunction - { funClauses = cs - , funCompiled = Just cc - , funSplitTree = mst - , funDelayed = delayed - , funInv = inv - , funAbstr = Info.defAbstract i - , funExtLam = (\ e -> e { extLamSys = sys }) <$> extlam - , funWith = with - , funCovering = covering + FunctionDefn emptyFunctionData + { _funClauses = cs + , _funCompiled = Just cc + , _funSplitTree = mst + , _funDelayed = delayed + , _funInv = inv + , _funAbstr = Info.defAbstract i + , _funExtLam = (\ e -> e { extLamSys = sys }) <$> extlam + , _funWith = with + , _funCovering = covering } lang <- getLanguage useTerPragma $ @@ -476,7 +484,10 @@ A.LHSWith core wps [] -> let ps' = map (fmap $ fmap patOfName) ps in A.LHSWith core (insertIn ps' wps) [] - _ -> __IMPOSSIBLE__ + -- Andreas, AIM XXXV, 2022-05-09, issue #5728: + -- Cases other than LHSWith actually do not make sense, but let them + -- through to get a proper error later. + lhs -> lhs where @@ -590,7 +601,7 @@ initWithDefault __IMPOSSIBLE__ $ List.tails pcs) $ \ ((phi1,cl1):pcs') -> do forM_ pcs' $ \ (phi2,cl2) -> do phi12 <- reduce (imin `apply` [argN phi1, argN phi2]) - forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \ sigma -> do + forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \_ sigma -> do let args = sigma `applySubst` teleArgs gamma t' = sigma `applySubst` t fromReduced (YesReduction _ x) = x @@ -600,7 +611,7 @@ TelV delta _ <- telViewUpTo extra t' fmap (abstract delta) $ addContext delta $ do fmap fromReduced $ runReduceM $ - appDef' (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta) + appDef' f (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta) v1 <- body cl1 v2 <- body cl2 equalTerm t' v1 v2 @@ -670,7 +681,7 @@ checkClause t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do cxtNames <- reverse . map (fst . unDom) <$> getContext - checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit) -> do + checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit ixsplit) -> do -- Note that we might now be in irrelevant context, -- in case checkLeftHandSide walked over an irrelevant projection pattern. @@ -715,7 +726,7 @@ [ "double checking rhs" , nest 2 (prettyTCM v <+> " : " <+> prettyTCM (unArg trhs)) ] - nonConstraining $ checkInternal v CmpLeq $ unArg trhs + noConstraints $ withFrozenMetas $ checkInternal v CmpLeq $ unArg trhs Nothing -> return () reportSDoc "tc.lhs.top" 10 $ vcat @@ -737,19 +748,6 @@ ] ] - -- check naturality wrt the interval. - let - -- TODO:: Defined but not used - iApplyVars :: [NamedArg DeBruijnPattern] -> [(Int, (Term,Term))] - iApplyVars ps = flip concatMap (map namedArg ps) $ \case - IApplyP _ t u x -> [(dbPatVarIndex x,(t,u))] - VarP{} -> [] - ProjP{}-> [] - LitP{} -> [] - DotP{} -> [] - DefP _ _ ps -> iApplyVars ps - ConP _ _ ps -> iApplyVars ps - -- compute body modification for irrelevant definitions, see issue 610 rel <- asksTC getRelevance let bodyMod body = case rel of @@ -774,7 +772,8 @@ , clauseExact = exact , clauseRecursive = Nothing -- we don't know yet , clauseUnreachable = Nothing -- we don't know yet - , clauseEllipsis = lhsEllipsis i + , clauseEllipsis = lhsEllipsis i + , clauseWhereModule = A.whereModule wh } @@ -802,7 +801,7 @@ -> A.RHS -- ^ Rhs to check. -> TCM (Maybe Term, WithFunctionProblem) -- Note: the as-bindings are already bound (in checkClause) -checkRHS i x aps t lhsResult@(LHSResult _ delta ps absurdPat trhs _ _asb _) rhs0 = +checkRHS i x aps t lhsResult@(LHSResult _ delta ps absurdPat trhs _ _asb _ _) rhs0 = handleRHS rhs0 where handleRHS :: A.RHS -> TCM (Maybe Term, WithFunctionProblem) @@ -1018,7 +1017,7 @@ -> [A.Clause] -- ^ With-clauses to check. -> TCM (Maybe Term, WithFunctionProblem) -- Note: as-bindings already bound (in checkClause) -checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _) vtys0 cs = +checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _ _) vtys0 cs = verboseBracket "tc.with.top" 25 "checkWithRHS" $ do Bench.billTo [Bench.Typing, Bench.With] $ do withArgs <- withArguments vtys0 @@ -1206,7 +1205,8 @@ -- Check the with function let info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess abstr (getRange cs) - checkFunDefS withFunType defaultArgInfo NotDelayed Nothing (Just f) info aux (Just withSub) cs + ai <- defArgInfo <$> getConstInfo f + checkFunDefS withFunType ai NotDelayed Nothing (Just f) info aux (Just withSub) cs return $ Just $ call_in_parent -- | Type check a where clause. @@ -1214,8 +1214,8 @@ :: A.WhereDeclarations -- ^ Where-declarations to check. -> TCM a -- ^ Continuation. -> TCM a -checkWhere wh@(A.WhereDecls whmod ds) ret = do - ensureNoNamedWhereInRefinedContext whmod +checkWhere wh@(A.WhereDecls whmod whNamed ds) ret = do + when (not whNamed) $ ensureNoNamedWhereInRefinedContext whmod loop ds where loop = \case diff --git a/src/full/Agda/TypeChecking/Rules/Display.hs b/src/full/Agda/TypeChecking/Rules/Display.hs --- a/src/full/Agda/TypeChecking/Rules/Display.hs +++ b/src/full/Agda/TypeChecking/Rules/Display.hs @@ -1,7 +1,6 @@ module Agda.TypeChecking.Rules.Display (checkDisplayPragma) where -import qualified Data.List.NonEmpty as NonEmpty import Control.Monad.State import Data.Maybe @@ -65,7 +64,7 @@ pars = case theDef def of Constructor { conPars = p } -> p - Function { funProjection = Just Projection{projIndex = i} } + Function { funProjection = Right Projection{projIndex = i} } | i > 0 -> i - 1 _ -> 0 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 @@ -92,6 +92,8 @@ import Agda.Utils.Tuple import Agda.Utils.Impossible +import Agda.Utils.WithDefault +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 @@ -639,10 +641,12 @@ -- (Issue 2303). , lhsPartialSplit :: IntSet -- ^ have we done a partial split? + , lhsIndexedSplit :: Bool + -- ^ have we split on an indexed type? } instance InstantiateFull LHSResult where - instantiateFull' (LHSResult n tel ps abs t sub as psplit) = LHSResult n + instantiateFull' (LHSResult n tel ps abs t sub as psplit ixsplit) = LHSResult n <$> instantiateFull' tel <*> instantiateFull' ps <*> instantiateFull' abs @@ -650,6 +654,7 @@ <*> instantiateFull' sub <*> instantiateFull' as <*> pure psplit + <*> pure ixsplit -- | Check a LHS. Main function. -- @@ -688,7 +693,7 @@ eqs0 = zipWith3 ProblemEq (map namedArg cps) (map var $ downFrom $ size tel) (flattenTel tel) let finalChecks :: LHSState a -> TCM a - finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit) = do + finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit ixsplit) = do reportSDoc "tc.lhs.top" 20 $ vcat [ "lhs: final checks with remaining equations" @@ -701,6 +706,22 @@ addContext delta $ do mapM_ noShadowingOfConstructors eqs + -- When working --without-K or --cubical-compatible, we have + -- to check that the target type can be used at the “ambient” + -- modality. For --cubical-compatible, this just improves an + -- error message (printing the type rather than the generated + -- RHS). For --without-K, it implements the same check without + -- necessarily generating --cubical code. + -- The reason for this check is that a clause + -- foo : x ≡ y → ... → T y + -- foo refl ... = ... + -- in Cubical mode, gets elaborated to an extra clause of the + -- form + -- foo (transp p φ x) ... = transp (λ i → T (p i)) φ (foo x ...) + -- (approximately), where T is the target type. That is: to + -- implement the substitution T[y/x], we use an actual + -- transport. See #5448. + arity_a <- arityPiPath a -- Compute substitution from the out patterns @qs0@ let notProj ProjP{} = False @@ -768,7 +789,7 @@ let hasAbsurd = not . null $ absurds - let lhsResult = LHSResult (length cxt) delta qs hasAbsurd b patSub asb (IntSet.fromList $ catMaybes psplit) + let lhsResult = LHSResult (length cxt) delta qs hasAbsurd b patSub asb (IntSet.fromList $ catMaybes psplit) ixsplit -- Debug output reportSDoc "tc.lhs.top" 10 $ @@ -779,11 +800,13 @@ , "asb = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM asb) , "absurds = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM absurds) , "qs = " <+> addContext delta (prettyList $ map pretty qs) + , "b = " <+> addContext delta (prettyTCM b) ] ] reportSDoc "tc.lhs.top" 30 $ nest 2 $ vcat [ "vars = " <+> pretty vars + , "b = " <+> pretty b ] reportSDoc "tc.lhs.top" 20 $ nest 2 $ "withSub = " <+> pretty withSub reportSDoc "tc.lhs.top" 20 $ nest 2 $ "weakSub = " <+> pretty weakSub @@ -825,6 +848,107 @@ (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` (size cxt)) $ checkLHS f st return result +-- | Check that this split will generate a modality-correct internal +-- clause when --cubical-compatible is used. This means that the type of +-- anything which might be transported must be modality-correct. This is +-- necessarily an approximate check. We assume that any argument which +-- (a) comes after and (b) mentions a dotted argument will be +-- transported, which is probably an overestimate. +conSplitModalityCheck + :: Modality + -- ^ Modality to check at + -> PatternSubstitution + -- ^ Substitution resulting from index unification. @Γ ⊢ ρ : Δ'@, + -- where @Δ'@ is the context we're in, and @Γ@ is the clause telescope + -- before unification. + -> Int -- ^ Variable x at which we split + -> Telescope -- ^ The telescope @Γ@ itself + -> Type -- ^ Target type of the clause. + -> TCM () +conSplitModalityCheck 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 (applyPatSubst rho target) + , "blocking:" <+> prettyTCM blocking + ] + case firstForced rho (length gamma) of + Just ix -> do + -- We've found a forced argument. This means that the unifier has + -- decided to kill a unification variable, and any of its + -- occurrences in the generated term will be replaced by an + -- occurrence of a path, and any terms whose types mention that + -- variable will be transported. + let + (gamma0, delta) = splitTelescopeAt (length gamma - ix) gamma + name = inTopContext . addContext gamma . nameOfBV + delta'target = applyPatSubst rho target + reportSDoc "tc.lhs.top" 30 $ vcat + [ "found forced argument!" + , "forced: " <+> prettyTCM ix + , "before: " <+> inTopContext (prettyTCM gamma0) + , "after: " <+> inTopContext (addContext gamma0 (prettyTCM delta)) + ] + forced <- name ix + forM_ (zip [ix - 1, ix - 2 ..] (telToList delta)) $ \(arg, d) -> do + -- Example: The first argument after the first forced variable. So + -- we have e.g.: + -- Γ = Γ₀.x.Δ + -- Δ' ⊢ ρ : Γ₀.x.Δ + -- Γ₀ ⊢ x : Type + -- but we need + -- Δ' ⊢ x : Type, + -- since Δ' is the context we are in. Then we have + -- Γ ⊢ x[wkS |Δ|] : Type + -- and consequently + -- Δ' ⊢ x[wkS |Δ|][ρ] : Type + let + rho' = composeS rho (wkS (arg + 1) idS) + ty' <- reduce (applyPatSubst rho' (unEl (snd (unDom d)))) + let + -- It's actually rather tricky to know when, exactly, a + -- transport will be needed in a position that forces an + -- usable-at-modality check. Our current heuristic is: + -- + -- The variable we're looking at has a fibrant type, with the + -- first forced variable free. + -- The variable appears free in the result type. + docheck = and + [ ix `freeIn` applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d))) + , arg /= blocking + , arg `freeIn` target + ] + reportSDoc "tc.lhs.top" 30 $ vcat + [ "arg: " <+> pretty arg + , "arg type: " <+> prettyTCM (applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d)))) + , "check " <+> pretty docheck + ] + argn <- name arg + when docheck $ + usableAtModality (IndexedClauseArg forced argn) mod ty' + 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 + -- quantity violation which is masked by an indexed match (recall that + -- the unifier likes to replace @0-variables for @ω-variables). A + -- concrete case where this happens is #5468. Check in Δ' first since + -- that will have the forced variable names. + usableAtModality IndexedClause mod (unEl (applyPatSubst rho target)) + inTopContext $ addContext gamma $ usableAtModality IndexedClause mod (unEl target) + where + -- Find the first dotted pattern in the substitution. "First" = + -- "earliest bound", so counts down from the length of the + -- telescope. + firstForced :: PatternSubstitution -> Int -> Maybe Int + firstForced pat level + | level >= 0 = case lookupS pat level of + DotP{} -> Just level + _ -> firstForced pat (level - 1) + | otherwise = Nothing + -- | Determine which splits should be tried. splitStrategy :: [ProblemEq] -> [ProblemEq] splitStrategy = filter shouldSplit @@ -859,7 +983,7 @@ checkLHS mf = updateModality checkLHS_ where -- If the target type is irrelevant or in Prop, -- we need to check the lhs in irr. cxt. (see Issue 939). - updateModality cont st@(LHSState tel ip problem target psplit) = do + updateModality cont st@(LHSState tel ip problem target psplit _) = do let m = getModality target applyModalityToContext m $ do cont $ over (lhsTel . listTel) @@ -867,9 +991,10 @@ -- Andreas, 2018-10-23, issue #3309 -- the modalities in the clause telescope also need updating. - checkLHS_ st@(LHSState tel ip problem target psplit) = do - reportSDoc "lhs" 10 $ "tel is" <+> prettyTCM tel - reportSDoc "lhs" 10 $ "ip is" <+> pretty ip + checkLHS_ st@(LHSState tel ip problem target psplit ixsplit) = do + reportSDoc "tc.lhs" 40 $ "tel is" <+> prettyTCM tel + reportSDoc "tc.lhs" 40 $ "ip is" <+> pretty ip + reportSDoc "tc.lhs" 40 $ "target is" <+> addContext tel (prettyTCM target) if isSolvedProblem problem then liftTCM $ (problem ^. problemCont) st else do @@ -981,7 +1106,7 @@ ip' = ip ++ [projP] -- drop the projection pattern (already splitted) problem' = over problemRestPats tail problem - liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit) + liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit) -- Split a Partial. @@ -1041,9 +1166,9 @@ -> ExceptT TCErr tcm (LHSState a) splitPartial delta1 dom adelta2 ts = do - unless (domFinite dom) $ liftTCM $ addContext delta1 $ + unless (domIsFinite dom) $ liftTCM $ addContext delta1 $ softTypeError . GenericDocError =<< - hsep [ "Not a finite domain:" , prettyTCM $ unDom dom ] + vcat [ "Splitting on partial elements is only allowed at the type Partial, but the domain here is" , nest 2 $ prettyTCM $ unDom dom ] tInterval <- liftTCM $ primIntervalType @@ -1107,7 +1232,7 @@ phi <- reduce phi reportSDoc "tc.lhs.split.partial" 10 $ text "phi (reduced) =" <+> prettyTCM phi refined <- forallFaceMaps phi (\ bs m t -> typeError $ GenericError $ "face blocked on meta") - (\ sigma -> (,sigma) <$> getContextTelescope) + (\_ sigma -> (,sigma) <$> getContextTelescope) case refined of [(gamma,sigma)] -> return (gamma,sigma) [] -> typeError $ GenericError $ "The face constraint is unsatisfiable." @@ -1141,7 +1266,7 @@ -- Compute the new state let problem' = set problemEqs eqs' problem reportSDoc "tc.lhs.split.partial" 60 $ text (show problem') - liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n])) + liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n]) ixsplit) splitLit :: Telescope -- The types of arguments before the one we split on @@ -1180,7 +1305,7 @@ -- Compute the new state let problem' = set problemEqs eqs' problem - liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit) + liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit ixsplit) splitCon :: Telescope -- The types of arguments before the one we split on @@ -1223,6 +1348,15 @@ unlessM (splittableCohesion info) $ addContext delta1 $ softTypeError $ SplitOnUnusableCohesion dom + -- Should we attempt to compute a left inverse for this clause? When + -- --cubical-compatible --flat-split is given, we don't generate a + -- left inverse (at all). This means that, when the coverage checker + -- gets to the clause this was in, it won't generate a (malformed!) + -- transpX clause for @♭ matching. + -- TODO(Amy): properly support transpX when @♭ stuff is in the + -- context. + let genTrx = boolToMaybe ((getCohesion info == Flat)) SplitOnFlat + -- We should be at a data/record type (dr, d, pars, ixs) <- addContext delta1 $ isDataOrRecordType a let isRec = case dr of @@ -1335,7 +1469,7 @@ -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope -- TODO: should we propagate the modality in general? -- See also Coverage checking. - da' <- do + da' <- addContext delta1Gamma $ do let updCoh = composeCohesion (getCohesion info) TelV tel dt <- telView da' return $ abstract (mapCohesion updCoh <$> tel) a @@ -1343,7 +1477,7 @@ let stuck b errs = softTypeError $ SplitError $ UnificationStuck b (conName c) (delta1 `abstract` gamma) cixs ixs' errs - liftTCM (withKIfStrict $ unifyIndices delta1Gamma flex da' cixs ixs') >>= \case + liftTCM (withKIfStrict $ unifyIndices genTrx delta1Gamma flex da' cixs ixs') >>= \case -- Mismatch. Report and abort. NoUnify neg -> hardTypeError $ ImpossibleConstructor (conName c) neg @@ -1433,9 +1567,16 @@ Quantity1{} -> __IMPOSSIBLE__ Quantityω{} -> q + liftTCM $ addContext delta' $ do + withoutK <- collapseDefault . optWithoutK <$> pragmaOptions + cubical <- collapseDefault . optCubicalCompatible <$> pragmaOptions + mod <- viewTC eModality + when ((withoutK || cubical) && not (null ixs)) $ + conSplitModalityCheck mod rho (length delta2) tel (unArg target) + -- if rest type reduces, -- extend the split problem by previously not considered patterns - st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit + st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit (ixsplit || not (null ixs)) reportSDoc "tc.lhs.top" 12 $ sep [ "new problem from rest" diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs b/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs @@ -90,7 +90,8 @@ let ps0@(~(p1 : ps1)) = hs ++ ps reduce a >>= piOrPath >>= \case -- If @a@ is a function (or path) type, continue inserting after @p1@. - Left (_, b) -> (p1 :) <$> insertImplicitPatternsT exh ps1 (absBody b) + Left (dom, cod) -> underAbstraction dom cod $ \b -> + (p1 :) <$> insertImplicitPatternsT exh ps1 b -- Otherwise, we are done. Right{} -> return ps0 where diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs b/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs @@ -236,6 +236,8 @@ -- be type-checked in irrelevant mode. , _lhsPartialSplit :: ![Maybe Int] -- ^ have we splitted with a PartialFocus? + , _lhsIndexedSplit :: !Bool + -- ^ Have we split on any indexed inductive types? } lhsTel :: Lens' Telescope (LHSState a) @@ -409,7 +411,7 @@ instantiateFull' (AsB x v a m) = AsB x <$> instantiateFull' v <*> instantiateFull' a <*> pure m instance PrettyTCM (LHSState a) where - prettyTCM (LHSState tel outPat (Problem eqs rps _) target _) = vcat + prettyTCM (LHSState tel outPat (Problem eqs rps _) target _ _) = vcat [ "tel = " <+> prettyTCM tel , "outPat = " <+> addContext tel (prettyTCMPatternList outPat) , "problemEqs = " <+> addContext tel (prettyList_ $ map prettyTCM eqs) diff --git a/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs b/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs @@ -96,18 +96,23 @@ -> (LHSState a -> TCM a) -- ^ Continuation for when checking the patterns is complete. -> TCM (LHSState a) -- ^ The initial LHS state constructed from the user patterns. initLHSState delta eqs ps a ret = do + reportSDoc "tc.lhs.init" 40 $ vcat + [ "initLHSState" + , nest 2 $ "delta = " <+> prettyTCM delta + , nest 2 $ "a = " <+> addContext delta (prettyTCM a) + ] let problem = Problem eqs ps ret qs0 = teleNamedArgs delta - updateProblemRest $ LHSState delta qs0 problem (defaultArg a) [] + updateProblemRest $ LHSState delta qs0 problem (defaultArg a) [] False -- | Try to move patterns from the problem rest into the problem. -- Possible if type of problem rest has been updated to a function type. updateProblemRest :: forall m a. (PureTCM m, MonadError TCErr m, MonadTrace m, MonadFresh NameId m) => LHSState a -> m (LHSState a) -updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit) = do - ps <- addContext tel0 $ insertImplicitPatternsT ExpandLast ps $ unArg a +updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit ixsplit) = addContext tel0 $ do + ps <- insertImplicitPatternsT ExpandLast ps $ unArg a reportSDoc "tc.lhs.imp" 20 $ "insertImplicitPatternsT returned" <+> fsep (map prettyA ps) -- (Issue 734: Do only the necessary telView to preserve clause types as much as possible.) @@ -157,4 +162,5 @@ } , _lhsTarget = a $> b , _lhsPartialSplit = psplit + , _lhsIndexedSplit = ixsplit } 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 @@ -118,6 +118,8 @@ module Agda.TypeChecking.Rules.LHS.Unify ( UnificationResult , UnificationResult'(..) + , NoLeftInv(..) + , unifyIndices' , unifyIndices ) where import Prelude hiding (null) @@ -135,7 +137,7 @@ import qualified Agda.Benchmarking as Bench -import Agda.Interaction.Options (optInjectiveTypeConstructors) +import Agda.Interaction.Options (optInjectiveTypeConstructors, optCubical, optWithoutK) import Agda.Syntax.Common import Agda.Syntax.Internal @@ -143,6 +145,11 @@ import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench +import Agda.TypeChecking.Monad.Builtin -- (constructorForm, getTerm, builtinPathP) +import Agda.TypeChecking.Primitive hiding (Nat) +import Agda.TypeChecking.Primitive.Cubical +import Agda.TypeChecking.Names +import Agda.TypeChecking.Conversion -- equalTerm import Agda.TypeChecking.Conversion.Pure import Agda.TypeChecking.Constraints import Agda.TypeChecking.Datatypes @@ -159,7 +166,11 @@ import Agda.TypeChecking.Records import Agda.TypeChecking.Rules.LHS.Problem +import Agda.TypeChecking.Rules.LHS.Unify.Types +import Agda.TypeChecking.Rules.LHS.Unify.LeftInverse +import Agda.Utils.Empty +import Agda.Utils.Either import Agda.Utils.Benchmark import Agda.Utils.Either import Agda.Utils.Function @@ -174,10 +185,12 @@ import Agda.Utils.Permutation import Agda.Utils.Singleton import Agda.Utils.Size +import Agda.Utils.WithDefault import Agda.Utils.Tuple import Agda.Utils.Impossible + -- | Result of 'unifyIndices'. type UnificationResult = UnificationResult' ( Telescope -- @tel@ @@ -185,6 +198,13 @@ , [NamedArg DeBruijnPattern] -- @ps@ s.t. @tel ⊢ ps : eqTel @ ) +type FullUnificationResult = UnificationResult' + ( Telescope -- @tel@ + , PatternSubstitution -- @sigma@ s.t. @tel ⊢ sigma : varTel@ + , [NamedArg DeBruijnPattern] -- @ps@ s.t. @tel ⊢ ps : eqTel @ + , Either NoLeftInv (Substitution, Substitution) -- (τ,leftInv) + ) + data UnificationResult' a = Unifies a -- ^ Unification succeeded. | NoUnify NegativeUnification -- ^ Terms are not unifiable. @@ -204,27 +224,29 @@ -- -- The result is the most general unifier of @us@ and @vs@. unifyIndices - :: (PureTCM m, MonadBench m, BenchPhase m ~ Bench.Phase) - => Telescope -- ^ @gamma@ - -> FlexibleVars -- ^ @flex@ - -> Type -- ^ @a@ - -> Args -- ^ @us@ - -> Args -- ^ @vs@ + :: (PureTCM m, MonadBench m, BenchPhase m ~ Bench.Phase, MonadError TCErr m) + => Maybe NoLeftInv -- ^ Do we have a reason for not computing a left inverse? + -> Telescope -- ^ @gamma@ + -> FlexibleVars -- ^ @flex@ + -> Type -- ^ @a@ + -> Args -- ^ @us@ + -> Args -- ^ @vs@ -> m UnificationResult -unifyIndices tel flex a us vs = +unifyIndices linv tel flex a us vs = Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $ - unifyIndices' tel flex a us vs + fmap (\(a,b,c,_) -> (a,b,c)) <$> unifyIndices' linv tel flex a us vs unifyIndices' - :: (PureTCM m) - => Telescope -- ^ @gamma@ + :: (PureTCM m, MonadError TCErr m) + => Maybe NoLeftInv -- ^ Do we have a reason for not computing a left inverse? + -> Telescope -- ^ @gamma@ -> FlexibleVars -- ^ @flex@ -> Type -- ^ @a@ -> Args -- ^ @us@ -> Args -- ^ @vs@ - -> m UnificationResult -unifyIndices' tel flex a [] [] = return $ Unifies (tel, idS, []) -unifyIndices' tel flex a us vs = do + -> m FullUnificationResult +unifyIndices' linv tel flex a [] [] = return $ Unifies (tel, idS, [], Right (idS, raiseS 1)) +unifyIndices' linv tel flex a us vs = do reportSDoc "tc.lhs.unify" 10 $ sep [ "unifyIndices" , ("tel =" <+>) $ nest 2 $ prettyTCM tel @@ -235,376 +257,29 @@ ] initialState <- initUnifyState tel flex a us vs reportSDoc "tc.lhs.unify" 20 $ "initial unifyState:" <+> prettyTCM initialState - reportSDoc "tc.lhs.unify" 70 $ "initial unifyState:" <+> text (show initialState) - (result,output) <- runUnifyLogT $ unify initialState rightToLeftStrategy - let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState) - return $ fmap (\s -> (varTel s , unifySubst output , ps)) result - ----------------------------------------------------- --- Equalities ----------------------------------------------------- - -data Equality = Equal - { _eqType :: Dom Type - , _eqLeft :: Term - , _eqRight :: Term - } - -instance Reduce Equality where - reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v - -eqConstructorForm :: HasBuiltins m => Equality -> m Equality -eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v - -eqUnLevel :: HasBuiltins m => Equality -> m Equality -eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v - where - unLevel (Level l) = reallyUnLevelView l - unLevel u = return u - ----------------------------------------------------- --- Unify state ----------------------------------------------------- - -data UnifyState = UState - { varTel :: Telescope -- ^ Don't reduce! - , flexVars :: FlexibleVars - , eqTel :: Telescope -- ^ Can be reduced eagerly. - , eqLHS :: [Arg Term] -- ^ Ends up in dot patterns (should not be reduced eagerly). - , eqRHS :: [Arg Term] -- ^ Ends up in dot patterns (should not be reduced eagerly). - } deriving (Show) --- Issues #3578 and #4125: avoid unnecessary reduction in unifier. - -lensVarTel :: Lens' Telescope UnifyState -lensVarTel f s = f (varTel s) <&> \ tel -> s { varTel = tel } ---UNUSED Liang-Ting Chen 2019-07-16 ---lensFlexVars :: Lens' FlexibleVars UnifyState ---lensFlexVars f s = f (flexVars s) <&> \ flex -> s { flexVars = flex } - -lensEqTel :: Lens' Telescope UnifyState -lensEqTel f s = f (eqTel s) <&> \ x -> s { eqTel = x } - ---UNUSED Liang-Ting Chen 2019-07-16 ---lensEqLHS :: Lens' Args UnifyState ---lensEqLHS f s = f (eqLHS s) <&> \ x -> s { eqLHS = x } - ---UNUSED Liang-Ting Chen 2019-07-16 ---lensEqRHS :: Lens' Args UnifyState ---lensEqRHS f s = f (eqRHS s) <&> \ x -> s { eqRHS = x } - --- UNUSED Andreas, 2019-10-14 --- instance Reduce UnifyState where --- reduce' (UState var flex eq lhs rhs) = --- UState <$> reduce' var --- <*> pure flex --- <*> reduce' eq --- <*> reduce' lhs --- <*> reduce' rhs - --- Andreas, 2019-10-14, issues #3578 and #4125: --- | Don't ever reduce the whole 'varTel', as it will destroy --- readability of the context in interactive editing! --- To make sure this insight is not lost, the following --- dummy instance should prevent a proper 'Reduce' instance for 'UnifyState'. -instance Reduce UnifyState where - reduce' = __IMPOSSIBLE__ - ---UNUSED Liang-Ting Chen 2019-07-16 ---reduceEqTel :: UnifyState -> TCM UnifyState ---reduceEqTel = lensEqTel reduce - --- UNUSED Andreas, 2019-10-14 --- instance Normalise UnifyState where --- normalise' (UState var flex eq lhs rhs) = --- UState <$> normalise' var --- <*> pure flex --- <*> normalise' eq --- <*> normalise' lhs --- <*> normalise' rhs - -instance PrettyTCM UnifyState where - prettyTCM state = "UnifyState" $$ nest 2 (vcat $ - [ "variable tel: " <+> prettyTCM gamma - , "flexible vars: " <+> pshow (map flexVarF $ flexVars state) - , "equation tel: " <+> addContext gamma (prettyTCM delta) - , "equations: " <+> addContext gamma (prettyList_ (zipWith prettyEquality (eqLHS state) (eqRHS state))) - ]) - where - flexVarF fi = (flexVar fi, flexForced fi) - gamma = varTel state - delta = eqTel state - prettyEquality x y = prettyTCM x <+> "=?=" <+> prettyTCM y - -initUnifyState - :: PureTCM m - => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState -initUnifyState tel flex a lhs rhs = do - (tel, a, lhs, rhs) <- instantiateFull (tel, a, lhs, rhs) - let n = size lhs - unless (n == size rhs) __IMPOSSIBLE__ - TelV eqTel _ <- telView a - unless (n == size eqTel) __IMPOSSIBLE__ - return $ UState tel flex eqTel lhs rhs - -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce - -- reduce $ UState tel flex eqTel lhs rhs - -isUnifyStateSolved :: UnifyState -> Bool -isUnifyStateSolved = null . eqTel - -varCount :: UnifyState -> Int -varCount = size . varTel - --- | Get the type of the i'th variable in the given state -getVarType :: Int -> UnifyState -> Dom Type -getVarType i s = indexWithDefault __IMPOSSIBLE__ (flattenTel $ varTel s) i - -getVarTypeUnraised :: Int -> UnifyState -> Dom Type -getVarTypeUnraised i s = snd <$> indexWithDefault __IMPOSSIBLE__ (telToList $ varTel s) i - -eqCount :: UnifyState -> Int -eqCount = size . eqTel - --- | Get the k'th equality in the given state. The left- and right-hand sides --- of the equality live in the varTel telescope, and the type of the equality --- lives in the varTel++eqTel telescope -getEquality :: Int -> UnifyState -> Equality -getEquality k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } = - Equal (indexWithDefault __IMPOSSIBLE__ (flattenTel eqs) k) - (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k) - (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k) - --- | As getEquality, but with the unraised type -getEqualityUnraised :: Int -> UnifyState -> Equality -getEqualityUnraised k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } = - Equal (snd <$> indexWithDefault __IMPOSSIBLE__ (telToList eqs) k) - (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k) - (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k) - ---UNUSED Liang-Ting Chen 2019-07-16 ---getEqInfo :: Int -> UnifyState -> ArgInfo ---getEqInfo k UState { eqTel = eqs } = --- domInfo $ indexWithDefault __IMPOSSIBLE__ (telToList eqs) k --- ----- | Add a list of equations to the front of the equation telescope ---addEqs :: Telescope -> [Arg Term] -> [Arg Term] -> UnifyState -> UnifyState ---addEqs tel us vs s = --- s { eqTel = tel `abstract` eqTel s --- , eqLHS = us ++ eqLHS s --- , eqRHS = vs ++ eqRHS s --- } --- where k = size tel --- ---addEq :: Type -> Arg Term -> Arg Term -> UnifyState -> UnifyState ---addEq a u v = addEqs (ExtendTel (defaultDom a) (Abs underscore EmptyTel)) [u] [v] + (result,log) <- runUnifyLogT $ unify initialState rightToLeftStrategy + forM result $ \ s -> do -- Unifies case + let output = mconcat [output | (UnificationStep _ _ output,_) <- log ] + let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState) + tauInv <- do + strict <- asksTC envSplitOnStrict + cubicalCompatible <- cubicalCompatibleOption + withoutK <- withoutKOption + case linv of + Just reason -> pure (Left reason) + Nothing + | strict -> pure (Left SplitOnStrict) + | cubicalCompatible -> buildLeftInverse initialState log + | withoutK -> pure (Left NoCubical) + | otherwise -> pure (Left WithKEnabled) + reportSDoc "tc.lhs.unify" 20 $ "ps:" <+> pretty ps + return $ (varTel s, unifySubst output, ps, tauInv) --- | Instantiate the k'th variable with the given value. --- Returns Nothing if there is a cycle. -solveVar :: Int -- ^ Index @k@ - -> DeBruijnPattern -- ^ Solution @u@ - -> UnifyState -> Maybe (UnifyState, PatternSubstitution) -solveVar k u s = case instantiateTelescope (varTel s) k u of - Nothing -> Nothing - Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState - { varTel = tel' - , flexVars = permuteFlex (reverseP rho) $ flexVars s - , eqTel = applyPatSubst sigma $ eqTel s - , eqLHS = applyPatSubst sigma $ eqLHS s - , eqRHS = applyPatSubst sigma $ eqRHS s - } - where - permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars - permuteFlex perm = - mapMaybe $ \(FlexibleVar ai fc k p x) -> - FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm) - -applyUnder :: Int -> Telescope -> Term -> Telescope -applyUnder k tel u - | k < 0 = __IMPOSSIBLE__ - | k == 0 = tel `apply1` u - | otherwise = case tel of - EmptyTel -> __IMPOSSIBLE__ - ExtendTel a tel' -> ExtendTel a $ - Abs (absName tel') $ applyUnder (k-1) (absBody tel') u - -dropAt :: Int -> [a] -> [a] -dropAt _ [] = __IMPOSSIBLE__ -dropAt k (x:xs) - | k < 0 = __IMPOSSIBLE__ - | k == 0 = xs - | otherwise = x : dropAt (k-1) xs - --- | Solve the k'th equation with the given value, which can depend on --- regular variables but not on other equation variables. -solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution) -solveEq k u s = (,sigma) $ s - { eqTel = applyUnder k (eqTel s) u' - , eqLHS = dropAt k $ eqLHS s - , eqRHS = dropAt k $ eqRHS s - } - where - u' = raise k u - n = eqCount s - sigma = liftS (n-k-1) $ consS (dotP u') idS - ---UNUSED Liang-Ting Chen 2019-07-16 ----- | Simplify the k'th equation with the given value (which can depend on other ----- equation variables). Returns Nothing if there is a cycle. ---simplifyEq :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution) ---simplifyEq k u s = case instantiateTelescope (eqTel s) k u of --- Nothing -> Nothing --- Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState --- { varTel = varTel s --- , flexVars = flexVars s --- , eqTel = tel' --- , eqLHS = permute rho $ eqLHS s --- , eqRHS = permute rho $ eqRHS s --- } --- ----------------------------------------------------- --- Unification strategies ----------------------------------------------------- - -data UnifyStep - = Deletion - { deleteAt :: Int - , deleteType :: Type - , deleteLeft :: Term - , deleteRight :: Term - } - | Solution - { solutionAt :: Int - , solutionType :: Dom Type - , solutionVar :: FlexibleVar Int - , solutionTerm :: Term - } - | Injectivity - { injectAt :: Int - , injectType :: Type - , injectDatatype :: QName - , injectParameters :: Args - , injectIndices :: Args - , injectConstructor :: ConHead - } - | Conflict - { conflictAt :: Int - , conflictType :: Type - , conflictDatatype :: QName - , conflictParameters :: Args - , conflictLeft :: Term - , conflictRight :: Term - } - | Cycle - { cycleAt :: Int - , cycleType :: Type - , cycleDatatype :: QName - , cycleParameters :: Args - , cycleVar :: Int - , cycleOccursIn :: Term - } - | EtaExpandVar - { expandVar :: FlexibleVar Int - , expandVarRecordType :: QName - , expandVarParameters :: Args - } - | EtaExpandEquation - { expandAt :: Int - , expandRecordType :: QName - , expandParameters :: Args - } - | LitConflict - { litConflictAt :: Int - , litType :: Type - , litConflictLeft :: Literal - , litConflictRight :: Literal - } - | StripSizeSuc - { stripAt :: Int - , stripArgLeft :: Term - , stripArgRight :: Term - } - | SkipIrrelevantEquation - { skipIrrelevantAt :: Int - } - | TypeConInjectivity - { typeConInjectAt :: Int - , typeConstructor :: QName - , typeConArgsLeft :: Args - , typeConArgsRight :: Args - } deriving (Show) - -instance PrettyTCM UnifyStep where - prettyTCM step = case step of - Deletion k a u v -> "Deletion" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "type: " <+> prettyTCM a - , "lhs: " <+> prettyTCM u - , "rhs: " <+> prettyTCM v - ]) - Solution k a i u -> "Solution" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "type: " <+> prettyTCM a - , "variable: " <+> text (show (flexVar i, flexPos i, flexForced i, flexKind i)) - , "term: " <+> prettyTCM u - ]) - Injectivity k a d pars ixs c -> "Injectivity" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "type: " <+> prettyTCM a - , "datatype: " <+> prettyTCM d - , "parameters: " <+> prettyList_ (map prettyTCM pars) - , "indices: " <+> prettyList_ (map prettyTCM ixs) - , "constructor:" <+> prettyTCM c - ]) - Conflict k a d pars u v -> "Conflict" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "type: " <+> prettyTCM a - , "datatype: " <+> prettyTCM d - , "parameters: " <+> prettyList_ (map prettyTCM pars) - , "lhs: " <+> prettyTCM u - , "rhs: " <+> prettyTCM v - ]) - Cycle k a d pars i u -> "Cycle" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "type: " <+> prettyTCM a - , "datatype: " <+> prettyTCM d - , "parameters: " <+> prettyList_ (map prettyTCM pars) - , "variable: " <+> text (show i) - , "term: " <+> prettyTCM u - ]) - EtaExpandVar fi r pars -> "EtaExpandVar" $$ nest 2 (vcat $ - [ "variable: " <+> text (show fi) - , "record type:" <+> prettyTCM r - , "parameters: " <+> prettyTCM pars - ]) - EtaExpandEquation k r pars -> "EtaExpandEquation" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "record type:" <+> prettyTCM r - , "parameters: " <+> prettyTCM pars - ]) - LitConflict k a u v -> "LitConflict" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "type: " <+> prettyTCM a - , "lhs: " <+> prettyTCM u - , "rhs: " <+> prettyTCM v - ]) - StripSizeSuc k u v -> "StripSizeSuc" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "lhs: " <+> prettyTCM u - , "rhs: " <+> prettyTCM v - ]) - SkipIrrelevantEquation k -> "SkipIrrelevantEquation" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - ]) - TypeConInjectivity k d us vs -> "TypeConInjectivity" $$ nest 2 (vcat $ - [ "position: " <+> text (show k) - , "datatype: " <+> prettyTCM d - , "lhs: " <+> prettyList_ (map prettyTCM us) - , "rhs: " <+> prettyList_ (map prettyTCM vs) - ]) - type UnifyStrategy = forall m. (PureTCM m, MonadPlus m) => UnifyState -> m UnifyStep + --UNUSED Liang-Ting Chen 2019-07-16 --leftToRightStrategy :: UnifyStrategy --leftToRightStrategy s = @@ -657,10 +332,10 @@ | Just fi <- findFlexible i flex , Just fj <- findFlexible j flex -> do let choice = chooseFlex fi fj - firstTryLeft = msum [ return (Solution k dom{unDom = ha} fi v) - , return (Solution k dom{unDom = ha} fj u)] - firstTryRight = msum [ return (Solution k dom{unDom = ha} fj u) - , return (Solution k dom{unDom = ha} fi v)] + firstTryLeft = msum [ return (Solution k dom{unDom = ha} fi v left) + , return (Solution k dom{unDom = ha} fj u right)] + firstTryRight = msum [ return (Solution k dom{unDom = ha} fj u right) + , return (Solution k dom{unDom = ha} fi v left)] reportSDoc "tc.lhs.unify" 40 $ "fi = " <+> text (show fi) reportSDoc "tc.lhs.unify" 40 $ "fj = " <+> text (show fj) reportSDoc "tc.lhs.unify" 40 $ "chooseFlex: " <+> text (show choice) @@ -670,20 +345,25 @@ ExpandBoth -> mzero -- This should be taken care of by etaExpandEquationStrategy ChooseEither -> firstTryRight (Just i, _) - | Just fi <- findFlexible i flex -> return $ Solution k dom{unDom = ha} fi v + | Just fi <- findFlexible i flex -> return $ Solution k dom{unDom = ha} fi v left (_, Just j) - | Just fj <- findFlexible j flex -> return $ Solution k dom{unDom = ha} fj u + | Just fj <- findFlexible j flex -> return $ Solution k dom{unDom = ha} fj u right _ -> mzero where flex = flexVars s n = eqCount s + left = Left (); right = Right () dataStrategy :: Int -> UnifyStrategy dataStrategy k s = do - Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< reduce (getEqualityUnraised k s) - sa <- reduce $ getSort a + Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< getReducedEqualityUnraised k s + sortOk <- reduce (getSort a) <&> \case + Type{} -> True + Inf{} -> True + SSet{} -> True + _ -> False case unEl a of - Def d es | Type{} <- sa -> do + Def d es | sortOk -> do npars <- catMaybesMP $ getNumberOfParameters d let (pars,ixs) = splitAt npars $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es reportSDoc "tc.lhs.unify" 40 $ addContext (varTel s `abstract` eqTel s) $ @@ -726,7 +406,7 @@ etaExpandVarStrategy :: Int -> UnifyStrategy etaExpandVarStrategy k s = do - Equal Dom{unDom = a} u v <- eqUnLevel <=< reduce $ getEquality k s + Equal Dom{unDom = a} u v <- eqUnLevel =<< getReducedEquality k s shouldEtaExpand u v a s `mplus` shouldEtaExpand v u a s where -- TODO: use IsEtaVar to check if the term is a variable @@ -739,7 +419,9 @@ -- record or if it's unified against a record constructor term. Basically -- we need to avoid EtaExpandEquation if EtaExpandVar is possible, or the -- forcing translation is unhappy. - b <- reduce $ unDom $ getVarTypeUnraised (varCount s - 1 - i) s + let k = varCount s - 1 - i -- position of var i in telescope + b0 = unDom $ getVarTypeUnraised k s + b <- addContext (telFromList $ take k $ telToList $ varTel s) $ reduce b0 (d, pars) <- catMaybesMP $ isEtaRecordType b ps <- fromMaybeMP $ allProjElims es guard =<< orM @@ -760,7 +442,7 @@ etaExpandEquationStrategy :: Int -> UnifyStrategy etaExpandEquationStrategy k s = do -- Andreas, 2019-02-23, re #3578, is the following reduce redundant? - Equal Dom{unDom = a} u v <- reduce $ getEqualityUnraised k s + Equal Dom{unDom = a} u v <- getReducedEqualityUnraised k s (d, pars) <- catMaybesMP $ addContext tel $ isEtaRecordType a guard =<< orM [ (Right True ==) <$> runBlocked (isSingletonRecord d pars) @@ -789,7 +471,7 @@ simplifySizesStrategy :: Int -> UnifyStrategy simplifySizesStrategy k s = do isSizeName <- isSizeNameTest - Equal Dom{unDom = a} u v <- reduce $ getEquality k s + Equal Dom{unDom = a} u v <- getReducedEquality k s case unEl a of Def d _ -> do guard $ isSizeName d @@ -806,7 +488,7 @@ injectiveTypeConStrategy k s = do injTyCon <- optInjectiveTypeConstructors <$> pragmaOptions guard injTyCon - eq <- eqUnLevel <=< reduce $ getEquality k s + eq <- eqUnLevel =<< getReducedEquality k s case eq of Equal a u@(Def d es) v@(Def d' es') | d == d' -> do -- d must be a data, record or axiom @@ -829,7 +511,7 @@ injectivePragmaStrategy :: Int -> UnifyStrategy injectivePragmaStrategy k s = do - eq <- eqUnLevel <=< reduce $ getEquality k s + eq <- eqUnLevel =<< getReducedEquality k s case eq of Equal a u@(Def d es) v@(Def d' es') | d == d' -> do -- d must have an injective pragma @@ -842,8 +524,9 @@ skipIrrelevantStrategy :: Int -> UnifyStrategy skipIrrelevantStrategy k s = do - let Equal a _ _ = getEquality k s -- reduce not necessary - guard . (== Right True) =<< runBlocked (isIrrelevantOrPropM a) -- reduction takes place here + let Equal a _ _ = getEquality k s -- reduce not necessary + addContext (varTel s `abstract` eqTel s) $ + guard . (== Right True) =<< runBlocked (isIrrelevantOrPropM a) -- reduction takes place here -- TODO: do something in case the above is blocked (i.e. `Left b`) return $ SkipIrrelevantEquation k @@ -852,47 +535,9 @@ -- Actually doing the unification ---------------------------------------------------- -data UnifyLogEntry - = UnificationStep UnifyState UnifyStep --- | UnificationDone UnifyState -- unused? - -type UnifyLog = [UnifyLogEntry] - -data UnifyOutput = UnifyOutput - { unifySubst :: PatternSubstitution - , unifyProof :: PatternSubstitution - , unifyLog :: UnifyLog - } - -instance Semigroup UnifyOutput where - x <> y = UnifyOutput - { unifySubst = unifySubst y `composeS` unifySubst x - , unifyProof = unifyProof y `composeS` unifyProof x - , unifyLog = unifyLog x ++ unifyLog y - } - -instance Monoid UnifyOutput where - mempty = UnifyOutput IdS IdS [] - mappend = (<>) - -type UnifyLogT m a = WriterT UnifyOutput m a - -tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m () -tellUnifySubst sub = tell $ UnifyOutput sub IdS [] - -tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m () -tellUnifyProof sub = tell $ UnifyOutput IdS sub [] - -writeUnifyLog :: MonadWriter UnifyOutput m => UnifyLogEntry -> m () -writeUnifyLog x = tell $ UnifyOutput IdS IdS [x] - -runUnifyLogT :: UnifyLogT m a -> m (a,UnifyOutput) -runUnifyLogT = runWriterT - unifyStep - :: (PureTCM m, MonadWriter UnifyOutput m) + :: (PureTCM m, MonadWriter UnifyOutput m, MonadError TCErr m) => UnifyState -> UnifyStep -> m (UnificationResult' UnifyState) - unifyStep s Deletion{ deleteAt = k , deleteType = a , deleteLeft = u , deleteRight = v } = do -- Check definitional equality of u and v isReflexive <- addContext (varTel s) $ runBlocked $ pureEqualTerm a u v @@ -923,7 +568,7 @@ let ctype = defType cdef `piApply` pars addContext (varTel s `abstract` eqTel1) $ reportSDoc "tc.lhs.unify" 40 $ "Constructor type: " <+> prettyTCM ctype - TelV ctel ctarget <- telView ctype + TelV ctel ctarget <- addContext (varTel s `abstract` eqTel1) $ telView ctype let cixs = case unEl ctarget of Def d' es | d == d' -> let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es @@ -943,7 +588,12 @@ -- computeNeighbourhood function in Agda.TypeChecking.Coverage. let hduTel = eqTel1 `abstract` ctel notforced = replicate (size hduTel) NotForced - res <- addContext (varTel s) $ unifyIndices' + + -- The left inverse computed here is not actually used when computing + -- a left inverse for the overall match, so as a slight optimisation + -- we just don't bother computing it. __IMPOSSIBLE__ because that + -- field in the result is never evaluated. + res <- addContext (varTel s) $ unifyIndices' (Just __IMPOSSIBLE__) hduTel (allFlexVars notforced hduTel) (raise (size ctel) dtype) @@ -973,10 +623,10 @@ tellUnifyProof rho - eqTel' <- reduce eqTel' + eqTel' <- addContext (varTel s) $ reduce eqTel' -- Compute new lhs and rhs by matching the old ones against rho - (lhs', rhs') <- do + (lhs', rhs') <- addContext (varTel s) $ do let ps = applySubst rho $ teleNamedArgs $ eqTel s (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s @@ -995,7 +645,7 @@ (varTel s `abstract` eqTel s) a (raise n u) (raise n v) (raise (n-k) ixs)] - Unifies (eqTel1', rho0, _) -> do + Unifies (eqTel1', rho0, _, _) -> do -- Split ps0 into parts for eqTel1 and ctel let (rho1, rho2) = splitS (size ctel) rho0 @@ -1008,10 +658,10 @@ tellUnifyProof rho - eqTel' <- reduce eqTel' + eqTel' <- addContext (varTel s) $ reduce eqTel' -- Compute new lhs and rhs by matching the old ones against rho - (lhs', rhs') <- do + (lhs', rhs') <- addContext (varTel s) $ do let ps = applySubst rho $ teleNamedArgs $ eqTel s (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s @@ -1226,7 +876,7 @@ caseEitherM (return eusable) (return . UnifyBlocked) $ \ usable -> do reportSDoc "tc.lhs.unify" 45 $ "Modality ok: " <+> prettyTCM usable - unless usable $ reportSLn "tc.lhs.unify" 65 $ "Rejected solution: " ++ show u + unless usable $ reportSDoc "tc.lhs.unify" 65 $ "Rejected solution: " <+> prettyTCM u -- We need a Flat equality to solve a Flat variable. -- This also ought to take care of the need for a usableCohesion check. @@ -1255,14 +905,14 @@ solutionStep _ _ _ = __IMPOSSIBLE__ unify - :: (PureTCM m, MonadWriter UnifyOutput m) + :: (PureTCM m, MonadWriter UnifyLog' m, MonadError TCErr m) => UnifyState -> UnifyStrategy -> m (UnificationResult' UnifyState) unify s strategy = if isUnifyStateSolved s then return $ Unifies s else tryUnifyStepsAndContinue (strategy s) where tryUnifyStepsAndContinue - :: (PureTCM m, MonadWriter UnifyOutput m) + :: (PureTCM m, MonadWriter UnifyLog' m, MonadError TCErr m) => ListT m UnifyStep -> m (UnificationResult' UnifyState) tryUnifyStepsAndContinue steps = do x <- foldListT tryUnifyStep failure steps @@ -1272,19 +922,20 @@ UnifyBlocked b -> return $ UnifyBlocked b UnifyStuck err -> return $ UnifyStuck err - tryUnifyStep :: (PureTCM m, MonadWriter UnifyOutput m) + tryUnifyStep :: (PureTCM m, MonadWriter UnifyLog' m, MonadError TCErr m) => UnifyStep -> m (UnificationResult' UnifyState) -> m (UnificationResult' UnifyState) tryUnifyStep step fallback = do addContext (varTel s) $ reportSDoc "tc.lhs.unify" 20 $ "trying unifyStep" <+> prettyTCM step - x <- unifyStep s step + (x, output) <- runWriterT $ unifyStep s step case x of Unifies s' -> do reportSDoc "tc.lhs.unify" 20 $ "unifyStep successful." reportSDoc "tc.lhs.unify" 20 $ "new unifyState:" <+> prettyTCM s' - writeUnifyLog $ UnificationStep s step + -- tell output + writeUnifyLog $ (UnificationStep s step output,s') return x NoUnify{} -> return x UnifyBlocked b1 -> do diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs b/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs @@ -0,0 +1,479 @@ +{-# LANGUAGE NondecreasingIndentation #-} +module Agda.TypeChecking.Rules.LHS.Unify.LeftInverse where + +import Prelude hiding ((!!), null) + +import Control.Monad +import Control.Monad.State +import Control.Monad.Writer (WriterT(..), MonadWriter(..)) +import Control.Monad.Except + +import Data.Semigroup hiding (Arg) +import qualified Data.List as List +import qualified Data.IntSet as IntSet +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) + +import qualified Agda.Benchmarking as Bench + +import Agda.Interaction.Options (optInjectiveTypeConstructors, optCubical, optWithoutK) + +import Agda.Syntax.Common +import Agda.Syntax.Internal +import Agda.Syntax.Literal + +import Agda.TypeChecking.Monad +import qualified Agda.TypeChecking.Monad.Benchmark as Bench +import Agda.TypeChecking.Monad.Builtin -- (constructorForm, getTerm, builtinPathP) +import Agda.TypeChecking.Primitive hiding (Nat) +import Agda.TypeChecking.Primitive.Cubical +import Agda.TypeChecking.Names +import Agda.TypeChecking.Conversion -- equalTerm +import Agda.TypeChecking.Conversion.Pure +import Agda.TypeChecking.Constraints +import Agda.TypeChecking.Datatypes +import Agda.TypeChecking.Irrelevance +import Agda.TypeChecking.Level (reallyUnLevelView) +import Agda.TypeChecking.Reduce +import qualified Agda.TypeChecking.Patterns.Match as Match +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Free +import Agda.TypeChecking.Free.Precompute +import Agda.TypeChecking.Free.Reduce +import Agda.TypeChecking.Records + +import Agda.TypeChecking.Rules.LHS.Problem +import Agda.TypeChecking.Rules.LHS.Unify.Types + +import Agda.Utils.Empty +import Agda.Utils.Either +import Agda.Utils.Benchmark +import Agda.Utils.Either +import Agda.Utils.Function +import Agda.Utils.Functor +import Agda.Utils.Lens +import Agda.Utils.List +import Agda.Utils.ListT +import Agda.Utils.Maybe +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.PartialOrd +import Agda.Utils.Permutation +import Agda.Utils.Singleton +import Agda.Utils.Size +import Agda.Utils.WithDefault +import Agda.Utils.Tuple + +import Agda.Utils.Impossible + +instance PrettyTCM NoLeftInv where + prettyTCM (UnsupportedYet s) = fsep $ pwords "It relies on" ++ [explainStep s <> ","] ++ pwords "which is not yet supported" + prettyTCM UnsupportedCxt = fwords "it relies on higher-dimensional unification, which is not yet supported" + prettyTCM (Illegal s) = fsep $ pwords "It relies on" ++ [explainStep s <> ","] ++ pwords "which is incompatible with" ++ [text "Cubical Agda"] + prettyTCM NoCubical = fwords "Cubical Agda is disabled" + prettyTCM WithKEnabled = fwords "The K rule is enabled" + prettyTCM SplitOnStrict = fwords "It splits on a type in SSet" + prettyTCM SplitOnFlat = fwords "It splits on a @♭ argument" + +data NoLeftInv + = UnsupportedYet {badStep :: UnifyStep} + | Illegal {badStep :: UnifyStep} + | NoCubical + | WithKEnabled + | SplitOnStrict -- ^ splitting on a Strict Set. + | SplitOnFlat -- ^ splitting on a @♭ argument + | UnsupportedCxt + deriving Show + +buildLeftInverse :: (PureTCM tcm, MonadError TCErr tcm) => UnifyState -> UnifyLog -> tcm (Either NoLeftInv (Substitution, Substitution)) +buildLeftInverse s0 log = do + reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do + cubical <- optCubical <$> pragmaOptions + "cubical:" <+> text (show cubical) + reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do + pathp <- getTerm' builtinPathP + "pathp:" <+> text (show $ isJust pathp) + let cond = andM + -- TODO: handle open contexts: they happen during "higher dimensional" unification, + -- in injectivity cases. + [ + null <$> getContext + ] + ifNotM cond (return $ Left UnsupportedCxt) $ do + equivs <- forM log $ uncurry buildEquiv + case sequence equivs of + Left no -> do + reportSDoc "tc.lhs.unify.inv.badstep" 20 $ "No Left Inverse:" <+> prettyTCM (badStep no) + return (Left no) + Right xs -> do + -- Γ,φ,us =_Δ vs ⊢ τ0 : Γ', φ + -- Γ,φ,us =_Δ vs, i : I ⊢ leftInv0 : Γ,φ,us =_Δ vs + -- leftInv0 : [wkS |φ,us =_Δ vs| ρ,φ,refls][τ0] = IdS : Γ,φ,us =_Δ vs + (tau0,leftInv0) <- case xs of + [] -> return (idS,raiseS 1) + xs -> do + let + loop [] = __IMPOSSIBLE__ + loop [x] = return $ fst x + loop (x:xs) = do + r <- loop xs + uncurry composeRetract x r + (_,_,tau,leftInv) <- loop xs + return (tau,leftInv) + -- Γ,φ,us =_Δ vs ⊢ τ0 : Γ', φ + -- leftInv0 : [wkS |φ,us =_Δ vs| ρ,1,refls][τ] = idS : Γ,φ,us =_Δ vs + let tau = tau0 `composeS` raiseS 1 + unview <- intervalUnview' + let replaceAt n x xs = xs0 ++ x:xs1 + where (xs0,_:xs1) = splitAt n xs + let max r s = unview $ IMax (argN r) (argN s) + neg r = unview $ INeg (argN r) + let phieq = neg (var 0) `max` var (size (eqTel s0) + 1) + -- I + us =_Δ vs -- inplaceS + let leftInv = termsS __IMPOSSIBLE__ $ replaceAt (size (varTel s0)) phieq $ map (lookupS leftInv0) $ downFrom (size (varTel s0) + 1 + size (eqTel s0)) + let working_tel = abstract (varTel s0) (ExtendTel __DUMMY_DOM__ $ Abs "phi0" $ (eqTel s0)) + reportSDoc "tc.lhs.unify.inv" 20 $ "=== before mod" + do + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0 :" <+> prettyTCM tau0 + addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__) + $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv0: " <+> prettyTCM leftInv0 + + reportSDoc "tc.lhs.unify.inv" 20 $ "=== after mod" + do + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau :" <+> prettyTCM tau + addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__) + $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv: " <+> prettyTCM leftInv + + return $ Right (tau,leftInv) + +type Retract = (Telescope, Substitution, Substitution, Substitution) + -- Γ (the problem, including equalities), + -- Δ ⊢ ρ : Γ + -- Γ ⊢ τ : Δ + -- Γ, i : I ⊢ leftInv : Γ, such that (λi. leftInv) : ρ[τ] = id_Γ + +--- Γ ⊢ us : Δ Γ ⊢ termsS e us : Δ +termsS :: DeBruijn a => Impossible -> [a] -> Substitution' a +termsS e xs = reverse xs ++# EmptyS e + +composeRetract :: (PureTCM tcm, MonadError TCErr tcm, MonadDebug tcm,HasBuiltins tcm, MonadAddContext tcm) => Retract -> Term -> Retract -> tcm Retract +composeRetract (prob0,rho0,tau0,leftInv0) phi0 (prob1,rho1,tau1,leftInv1) = do + reportSDoc "tc.lhs.unify.inv" 20 $ "=== composing" + reportSDoc "tc.lhs.unify.inv" 20 $ "Γ0 :" <+> prettyTCM prob0 + addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0 :" <+> prettyTCM tau0 + reportSDoc "tc.lhs.unify.inv" 20 $ "Γ1 :" <+> prettyTCM prob1 + addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau1 :" <+> prettyTCM tau1 + + + {- + Γ0 = prob0 + S0 ⊢ ρ0 : Γ0 + Γ0 ⊢ τ0 : S0 + Γ0 ⊢ leftInv0 : ρ0[τ0] = idΓ0 + Γ0 ⊢ φ0 + Γ0,φ0 ⊢ leftInv0 = refl + + Γ1 = prob1 + S1 ⊢ ρ1 : Γ1 + Γ1 ⊢ τ1 : S1 + Γ1 ⊢ leftInv1 : ρ1[τ1] = idΓ1 + Γ1 ⊢ φ1 = φ0[τ0] (**) + Γ1,φ1 ⊢ leftInv1 = refl + S0 = Γ1 + + (**) implies? + Γ0,φ0 ⊢ leftInv1[τ0] = refl (*) + + + S1 ⊢ ρ := ρ0[ρ1] : Γ0 + Γ0 ⊢ τ := τ1[τ0] : S1 + -} + + let prob = prob0 + let rho = rho1 `composeS` rho0 + let tau = tau0 `composeS` tau1 + + addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau :" <+> prettyTCM tau + + {- + Γ0 ⊢ leftInv : ρ[τ] = idΓ0 + Γ0 ⊢ leftInv : ρ0[ρ1[τ1]][τ0] = idΓ0 + Γ0 ⊢ step0 := ρ0[leftInv1[τ0]] : ρ0[ρ1[τ1]][τ0] = ρ0[τ0] + + Γ0,φ0 ⊢ step0 = refl by (*) + + + Γ0 ⊢ leftInv := step0 · leftInv0 : ρ0[ρ1[τ1]][τ0] = idΓ0 + + Γ0 ⊢ leftInv := tr (\ i → ρ0[ρ1[τ1]][τ0] = leftInv0[i]) φ0 step0 + Γ0,φ0 ⊢ leftInv = refl -- because it will become step0, which is refl when φ0 + + Γ0, i : I ⊢ hcomp {Γ0} (\ j → \ { (i = 0) -> ρ0[ρ1[τ1]][τ0] + ; (i = 1) -> leftInv0[j] + ; (φ0 = 1) -> γ0 + }) + (step0[i]) + + + + + -} + let step0 = liftS 1 tau0 `composeS` leftInv1 `composeS` rho0 + + addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv0 :" <+> prettyTCM leftInv0 + addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "rho0 :" <+> prettyTCM rho0 + addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0 :" <+> prettyTCM tau0 + addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "rhos0[tau0] :" <+> prettyTCM (tau0 `composeS` rho0) + + addContext prob1 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv1 :" <+> prettyTCM leftInv1 + addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "step0 :" <+> prettyTCM step0 + + interval <- primIntervalType + max <- primIMax + neg <- primINeg + Right leftInv <- fmap sequenceA $ addContext prob0 $ runNamesT (teleNames prob0) $ do + phi <- open phi0 + g0 <- open $ raise (size prob0) prob0 + step0 <- open $ Abs "i" $ step0 `applySubst` teleArgs prob0 + leftInv0 <- open $ Abs "i" $ map unArg $ leftInv0 `applySubst` teleArgs prob0 + bind "i" $ \ i -> addContext ("i" :: String, defaultDom interval) $ do + tel <- bind "_" $ \ (_ :: NamesT tcm Term) -> g0 + step0i <- lazyAbsApp <$> step0 <*> i + face <- pure max <@> (pure neg <@> i) <@> phi + leftInv0 <- leftInv0 + i <- i + -- this composition could be optimized further whenever step0i is actually constant in i. + lift $ (runExceptT $ map unArg <$> transpSysTel' True tel [(i, leftInv0)] face step0i) + addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ + reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv :" <+> prettyTCM (absBody leftInv) + addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ + reportSDoc "tc.lhs.unify.inv" 40 $ "leftInv :" <+> pretty (absBody leftInv) + addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ + reportSDoc "tc.lhs.unify.inv" 40 $ "leftInvSub :" <+> pretty (termsS __IMPOSSIBLE__ $ absBody $ leftInv) + return (prob, rho, tau , termsS __IMPOSSIBLE__ $ absBody $ leftInv) + +buildEquiv :: forall tcm. (PureTCM tcm, MonadError TCErr tcm) => UnifyLogEntry -> UnifyState -> tcm (Either NoLeftInv (Retract,Term)) +buildEquiv (UnificationStep st step@(Solution k ty fx tm side) output) next = runExceptT $ do + let + errorToUnsupported :: ExceptT a tcm b -> ExceptT NoLeftInv tcm b + errorToUnsupported m = withExceptT (\ _ -> UnsupportedYet step) m + reportSDoc "tc.lhs.unify.inv" 20 $ "step unifyState:" <+> prettyTCM st + reportSDoc "tc.lhs.unify.inv" 20 $ "step step:" <+> addContext (varTel st) (prettyTCM step) + unview <- intervalUnview' + cxt <- getContextTelescope + reportSDoc "tc.lhs.unify.inv" 20 $ "context:" <+> prettyTCM cxt + let + -- k counds in eqs from the left + m = varCount st + gamma = varTel st + eqs = eqTel st + u = eqLHS st !! k + v = eqRHS st !! k + x = flexVar fx + neqs = size eqs + phis = 1 -- neqs + interval <- lift $ primIntervalType + -- Γ, φs : I^phis + let gamma_phis = abstract gamma $ telFromList $ + map (defaultDom . (,interval) . ("phi" ++) . show) [0 .. phis - 1] + working_tel <- abstract gamma_phis <$> + errorToUnsupported (pathTelescope' (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st)) + reportSDoc "tc.lhs.unify.inv" 20 $ vcat + [ "working tel:" <+> prettyTCM (working_tel :: Telescope) + , addContext working_tel $ "working tel args:" <+> prettyTCM (teleArgs working_tel :: [Arg Term]) + ] + (tau,leftInv,phi) <- addContext working_tel $ runNamesT [] $ do + let raiseFrom tel x = raise (size working_tel - size tel) x + + [u,v] <- mapM (open . raiseFrom gamma . unArg) [u,v] + -- φ + let phi = raiseFrom gamma_phis $ var 0 + -- working_tel ⊢ γ₁,x,γ₂,φ,eqs + let all_args = teleArgs working_tel + -- Γ₁,x : A,Γ₂ +-- gamma <- open $ raiseFrom EmptyTel gamma + -- -- γ₁,x,γ₂,φ,eqs : W + -- working_tel <- open $ raiseFrom EmptyTel working_tel + + -- eq_tel <- open $ raiseFrom gamma (eqTel st) + + -- [lhs,rhs] <- mapM (open . raiseFrom gamma) [eqLHS st,eqRHS st] + let bindSplit (tel1,tel2) = (tel1,AbsN (teleNames tel1) tel2) + -- . ⊢ Γ₁ , γ₁. (x : A),Γ₂,φ : I,[lhs ≡ rhs] + let (gamma1, xxi) = bindSplit $ splitTelescopeAt (size gamma - x - 1) working_tel + let (gamma1_args,xxi_args) = splitAt (size gamma1) all_args + (_x_arg:xi_args) = xxi_args + (x_arg:xi0,k_arg:xi1) = splitAt ((size gamma - size gamma1) + phis + k) xxi_args + -- W ⊢ (x : A),Γ₂,φ : I,[lhs ≡ rhs] + let + xxi_here :: Telescope + xxi_here = absAppN xxi $ map unArg gamma1_args + -- x:A,Γ₂ φ + let (xpre,krest) = bindSplit $ splitTelescopeAt ((size gamma - size gamma1) + phis + k) xxi_here + k_arg <- open $ unArg k_arg + xpre <- open xpre + krest <- open krest + delta <- bindN ["x","eq"] $ \ [x,eq] -> do + let pre = apply1 <$> xpre <*> x + abstractN pre $ \ args -> + apply1 <$> applyN krest (x:args) <*> eq +-- let delta_zero = absAppN delta $ map unArg [x_arg,k_arg] + let d_zero_args = xi0 ++ xi1 + reportSDoc "tc.lhs.unify.inv" 20 $ "size delta:" <+> text (show $ size $ unAbsN delta) + reportSDoc "tc.lhs.unify.inv" 20 $ "size d0args:" <+> text (show $ size d_zero_args) + let appSide = case side of + Left{} -> id + Right{} -> unview . INeg . argN + let + -- csingl :: NamesT tcm Term -> NamesT tcm [Arg Term] + csingl i = mapM (fmap defaultArg) $ csingl' i + -- csingl' :: NamesT tcm Term -> [NamesT tcm Term] + csingl' i = [ k_arg <@@> (u, v, appSide <$> i) + , lam "j" $ \ j -> + let r i j = case side of + Left{} -> unview (IMax (argN j) (argN i)) + Right{} -> unview (IMin (argN j) (argN . unview $ INeg $ argN i)) + in k_arg <@@> (u, v, r <$> i <*> j) + ] + let replaceAt n x xs = xs0 ++ x:xs1 + where (xs0,_:xs1) = splitAt n xs + dropAt n xs = xs0 ++ xs1 + where (xs0,_:xs1) = splitAt n xs + delta <- open delta + d <- bind "i" $ \ i -> applyN delta (csingl' i) + + -- Andrea 06/06/2018 + -- We do not actually add a transp/fill if the family is + -- constant (TODO: postpone for metas) This is so variables + -- whose types do not depend on "x" are left alone, in + -- particular those the solution "t" depends on. + -- + -- We might want to instead use the info discovered by the + -- solver when checking if "t" depends on "x" to decide what + -- to transp and what not to. + let flag = True + {- φ -} + tau <- {-dropAt (size gamma - 1 + k) .-} (gamma1_args ++) <$> + lift (errorToUnsupported (transpTel' flag d phi d_zero_args)) + reportSDoc "tc.lhs.unify.inv" 20 $ "tau :" <+> prettyTCM (map (setHiding NotHidden) tau) + leftInv <- do + gamma1_args <- open gamma1_args + phi <- open phi + -- xxi_here <- open xxi_here + -- (xi_here_f :: Abs Telescope) <- bind "i" $ \ i -> apply <$> xxi_here <*> (take 1 `fmap` csingl i) + -- xi_here_f <- open xi_here_f + -- xi_args <- open xi_args + -- xif <- bind "i" $ \ i -> do + -- m <- (runExceptT <$> (trFillTel' flag <$> xi_here_f <*> phi <*> xi_args <*> i)) + -- either __IMPOSSIBLE__ id <$> lift m + -- xif <- open xif + + xi0 <- open xi0 + xi1 <- open xi1 + delta0 <- bind "i" $ \ i -> apply <$> xpre <*> (take 1 `fmap` csingl i) + delta0 <- open delta0 + xi0f <- bind "i" $ \ i -> do + m <- trFillTel' flag <$> delta0 <*> phi <*> xi0 <*> i + lift (errorToUnsupported m) + xi0f <- open xi0f + + delta1 <- bind "i" $ \ i -> do + + args <- mapM (open . unArg) =<< (lazyAbsApp <$> xi0f <*> i) + apply <$> applyN krest ((take 1 $ csingl' i) ++ args) <*> (drop 1 `fmap` csingl i) + delta1 <- open delta1 + xi1f <- bind "i" $ \ i -> do + m <- trFillTel' flag <$> delta1 <*> phi <*> xi1 <*> i + lift (errorToUnsupported m) + xi1f <- open xi1f + fmap absBody $ bind "i" $ \ i' -> do + let (+++) m = liftM2 (++) m + i = cl (lift primINeg) <@> i' +-- replaceAt (size gamma + k) <$> (fmap defaultArg $ cl primIMax <@> phi <@> i) <*> do + do + gamma1_args +++ (take 1 `fmap` csingl i +++ ((lazyAbsApp <$> xi0f <*> i) +++ (drop 1 `fmap` csingl i +++ (lazyAbsApp <$> xi1f <*> i)))) + return (tau,leftInv,phi) + iz <- lift $ primIZero + io <- lift $ primIOne + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau :" <+> prettyTCM (map (setHiding NotHidden) tau) + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tauS :" <+> prettyTCM (termsS __IMPOSSIBLE__ $ map unArg tau) + addContext working_tel $ addContext ("r" :: String, defaultDom interval) + $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv: " <+> prettyTCM (map (setHiding NotHidden) leftInv) + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv[0]:" <+> (prettyTCM =<< reduce (subst 0 iz $ map (setHiding NotHidden) leftInv)) + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv[1]:" <+> (prettyTCM =<< reduce (subst 0 io $ map (setHiding NotHidden) leftInv)) + addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "[rho]tau :" <+> + -- k φ + prettyTCM (applySubst (termsS __IMPOSSIBLE__ $ map unArg tau) $ fromPatternSubstitution + $ raise (size (eqTel st) - 1{-k-} + phis {-neqs{-φs-} - 1{-φ0-}-}) + $ unifySubst output) + reportSDoc "tc.lhs.unify.inv" 20 $ "." + let rho0 = fromPatternSubstitution $ unifySubst output + addContext (varTel next) $ addContext (eqTel next) $ reportSDoc "tc.lhs.unify.inv" 20 $ + "prf :" <+> prettyTCM (fromPatternSubstitution $ unifyProof output) + let c0 = Lam defaultArgInfo $ Abs "i" $ raise 1 $ lookupS (fromPatternSubstitution $ unifyProof output) (neqs - k - 1) + let c = liftS (size $ eqTel next) (raiseS 1) `applySubst` c0 + addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $ + reportSDoc "tc.lhs.unify.inv" 20 $ "c :" <+> prettyTCM c +-- let rho = liftS (neqs - k - 1) $ consS (raise (1 + k) c) $ liftS (1 + k) rho0 + let rho = singletonS (neqs - k - 1) c `composeS` liftS (1 + neqs) rho0 + reportSDoc "tc.lhs.unify.inv" 20 $ text "old_sizes: " <+> pretty (size $ varTel st, size $ eqTel st) + reportSDoc "tc.lhs.unify.inv" 20 $ text "new_sizes: " <+> pretty (size $ varTel next, size $ eqTel next) +-- addContext (abstract (varTel next) $ ExtendTel __DUMMY_DOM__ (Abs "φ" $ raise 1 $ eqTel next)) $ + addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $ + reportSDoc "tc.lhs.unify.inv" 20 $ "rho :" <+> prettyTCM rho + return $ ((working_tel + , rho + , termsS __IMPOSSIBLE__ $ map unArg tau + , termsS __IMPOSSIBLE__ $ map unArg leftInv) + , phi) +buildEquiv (UnificationStep st step@(EtaExpandVar fv _d _args) output) next = fmap Right $ do + reportSDoc "tc.lhs.unify.inv" 20 "buildEquiv EtaExpandVar" + let + gamma = varTel st + eqs = eqTel st + x = flexVar fv + neqs = size eqs + phis = 1 + interval <- primIntervalType + -- Γ, φs : I^phis + let gamma_phis = abstract gamma $ telFromList $ + map (defaultDom . (,interval) . ("phi"++) . show) [0 .. phis - 1] + working_tel <- abstract gamma_phis <$> + pathTelescope (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st) + let raiseFrom tel x = (size working_tel - size tel) + x + let phi = var $ raiseFrom gamma_phis 0 + + caseMaybeM (expandRecordVar (raiseFrom gamma x) working_tel) __IMPOSSIBLE__ $ \ (_,tau,rho,_) -> do + reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tau :" <+> prettyTCM tau + return $ ((working_tel,rho,tau,raiseS 1),phi) + +buildEquiv (UnificationStep st step output) _ = do + reportSDoc "tc.lhs.unify.inv" 20 $ "steps" + let illegal = return $ Left $ Illegal step + unsupported = return $ Left $ UnsupportedYet step + case step of + Deletion{} -> illegal + TypeConInjectivity{} -> illegal + -- These should end up in a NoUnify + Conflict{} -> __IMPOSSIBLE__ + LitConflict{} -> __IMPOSSIBLE__ + Cycle{} -> __IMPOSSIBLE__ + _ -> unsupported + +explainStep :: MonadPretty m => UnifyStep -> m Doc +explainStep Injectivity{injectConstructor = ch} = + "injectivity of the data constructor" <+> prettyTCM (conName ch) +explainStep TypeConInjectivity{} = "injectivity of type constructors" +explainStep Deletion{} = "the K rule" +explainStep Solution{} = "substitution in Setω" +-- Note: this is the actual reason that a Solution step can fail, rather +-- than the explanation for the actual step +explainStep Conflict{} = "the disjointness of data constructors" +explainStep LitConflict{} = "the disjointness of literal values" +explainStep Cycle{} = "the impossibility of cyclic values" +explainStep EtaExpandVar{} = "eta-expansion of variables" +explainStep EtaExpandEquation{} = "eta-expansion of equations" +explainStep StripSizeSuc{} = "the injectivity of size successors" +explainStep SkipIrrelevantEquation{} = "ignoring irrelevant equations" diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs b/src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs @@ -0,0 +1,510 @@ +module Agda.TypeChecking.Rules.LHS.Unify.Types where + +import Prelude hiding (null) + +import Control.Monad +import Control.Monad.State +import Control.Monad.Writer (WriterT(..), MonadWriter(..)) +import Control.Monad.Except + +import Data.Foldable (toList) +import Data.Semigroup hiding (Arg) +import Data.DList (DList) +import qualified Data.List as List +import qualified Data.IntSet as IntSet +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) + +import qualified Agda.Benchmarking as Bench + +import Agda.Interaction.Options (optInjectiveTypeConstructors, optCubical, optWithoutK) + +import Agda.Syntax.Common +import Agda.Syntax.Internal +import Agda.Syntax.Literal + +import Agda.TypeChecking.Monad +import qualified Agda.TypeChecking.Monad.Benchmark as Bench +import Agda.TypeChecking.Monad.Builtin -- (constructorForm, getTerm, builtinPathP) +import Agda.TypeChecking.Primitive hiding (Nat) +import Agda.TypeChecking.Primitive.Cubical +import Agda.TypeChecking.Names +import Agda.TypeChecking.Conversion -- equalTerm +import Agda.TypeChecking.Conversion.Pure +import Agda.TypeChecking.Constraints +import Agda.TypeChecking.Datatypes +import Agda.TypeChecking.Irrelevance +import Agda.TypeChecking.Level (reallyUnLevelView) +import Agda.TypeChecking.Reduce +import qualified Agda.TypeChecking.Patterns.Match as Match +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Substitute +import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Free +import Agda.TypeChecking.Free.Precompute +import Agda.TypeChecking.Free.Reduce +import Agda.TypeChecking.Records + +import Agda.TypeChecking.Rules.LHS.Problem + +import Agda.Utils.Empty +import Agda.Utils.Either +import Agda.Utils.Benchmark +import Agda.Utils.Either +import Agda.Utils.Function +import Agda.Utils.Functor +import Agda.Utils.Lens +import Agda.Utils.List +import Agda.Utils.ListT +import Agda.Utils.Maybe +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.PartialOrd +import Agda.Utils.Permutation +import Agda.Utils.Singleton +import Agda.Utils.Size +import Agda.Utils.WithDefault +import Agda.Utils.Tuple + +import Agda.Utils.Impossible + +---------------------------------------------------- +-- Equalities +---------------------------------------------------- + +data Equality = Equal + { _eqType :: Dom Type + , _eqLeft :: Term + , _eqRight :: Term + } + +-- Jesper, 2020-01-19: The type type lives in the context of the +-- variables+equations, while the lhs/rhs only depend on the +-- variables, so there is no way to give a correct Reduce instance. +-- WRONG: +-- instance Reduce Equality where +-- reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v + +eqConstructorForm :: HasBuiltins m => Equality -> m Equality +eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v + +eqUnLevel :: HasBuiltins m => Equality -> m Equality +eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v + where + unLevel (Level l) = reallyUnLevelView l + unLevel u = return u + +---------------------------------------------------- +-- Unify state +---------------------------------------------------- + +data UnifyState = UState + { varTel :: Telescope -- ^ Don't reduce! + , flexVars :: FlexibleVars + , eqTel :: Telescope -- ^ Can be reduced eagerly. + , eqLHS :: [Arg Term] -- ^ Ends up in dot patterns (should not be reduced eagerly). + , eqRHS :: [Arg Term] -- ^ Ends up in dot patterns (should not be reduced eagerly). + } deriving (Show) +-- Issues #3578 and #4125: avoid unnecessary reduction in unifier. + +lensVarTel :: Lens' Telescope UnifyState +lensVarTel f s = f (varTel s) <&> \ tel -> s { varTel = tel } +--UNUSED Liang-Ting Chen 2019-07-16 +--lensFlexVars :: Lens' FlexibleVars UnifyState +--lensFlexVars f s = f (flexVars s) <&> \ flex -> s { flexVars = flex } + +lensEqTel :: Lens' Telescope UnifyState +lensEqTel f s = f (eqTel s) <&> \ x -> s { eqTel = x } + +--UNUSED Liang-Ting Chen 2019-07-16 +--lensEqLHS :: Lens' Args UnifyState +--lensEqLHS f s = f (eqLHS s) <&> \ x -> s { eqLHS = x } + +--UNUSED Liang-Ting Chen 2019-07-16 +--lensEqRHS :: Lens' Args UnifyState +--lensEqRHS f s = f (eqRHS s) <&> \ x -> s { eqRHS = x } + +-- UNUSED Andreas, 2019-10-14 +-- instance Reduce UnifyState where +-- reduce' (UState var flex eq lhs rhs) = +-- UState <$> reduce' var +-- <*> pure flex +-- <*> reduce' eq +-- <*> reduce' lhs +-- <*> reduce' rhs + +-- Andreas, 2019-10-14, issues #3578 and #4125: +-- | Don't ever reduce the whole 'varTel', as it will destroy +-- readability of the context in interactive editing! +-- To make sure this insight is not lost, the following +-- dummy instance should prevent a proper 'Reduce' instance for 'UnifyState'. +instance Reduce UnifyState where + reduce' = __IMPOSSIBLE__ + +--UNUSED Liang-Ting Chen 2019-07-16 +--reduceEqTel :: UnifyState -> TCM UnifyState +--reduceEqTel = lensEqTel reduce + +-- UNUSED Andreas, 2019-10-14 +-- instance Normalise UnifyState where +-- normalise' (UState var flex eq lhs rhs) = +-- UState <$> normalise' var +-- <*> pure flex +-- <*> normalise' eq +-- <*> normalise' lhs +-- <*> normalise' rhs + +instance PrettyTCM UnifyState where + prettyTCM state = "UnifyState" $$ nest 2 (vcat $ + [ "variable tel: " <+> prettyTCM gamma + , "flexible vars: " <+> pshow (map flexVarF $ flexVars state) + , "equation tel: " <+> addContext gamma (prettyTCM delta) + , "equations: " <+> addContext gamma (prettyList_ (zipWith prettyEquality (eqLHS state) (eqRHS state))) + ]) + where + flexVarF fi = (flexVar fi, flexForced fi) + gamma = varTel state + delta = eqTel state + prettyEquality x y = prettyTCM x <+> "=?=" <+> prettyTCM y + +initUnifyState + :: PureTCM m + => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState +initUnifyState tel flex a lhs rhs = do + (tel, a, lhs, rhs) <- instantiateFull (tel, a, lhs, rhs) + let n = size lhs + unless (n == size rhs) __IMPOSSIBLE__ + TelV eqTel _ <- telView a + unless (n == size eqTel) __IMPOSSIBLE__ + return $ UState tel flex eqTel lhs rhs + -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce + -- reduce $ UState tel flex eqTel lhs rhs + +isUnifyStateSolved :: UnifyState -> Bool +isUnifyStateSolved = null . eqTel + +varCount :: UnifyState -> Int +varCount = size . varTel + +-- | Get the type of the i'th variable in the given state +getVarType :: Int -> UnifyState -> Dom Type +getVarType i s = indexWithDefault __IMPOSSIBLE__ (flattenTel $ varTel s) i + +getVarTypeUnraised :: Int -> UnifyState -> Dom Type +getVarTypeUnraised i s = snd <$> indexWithDefault __IMPOSSIBLE__ (telToList $ varTel s) i + +eqCount :: UnifyState -> Int +eqCount = size . eqTel + +-- | Get the k'th equality in the given state. The left- and right-hand sides +-- of the equality live in the varTel telescope, and the type of the equality +-- lives in the varTel++eqTel telescope +getEquality :: Int -> UnifyState -> Equality +getEquality k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } = + Equal (indexWithDefault __IMPOSSIBLE__ (flattenTel eqs) k) + (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k) + (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k) + +getReducedEquality + :: (MonadReduce m, MonadAddContext m) + => Int -> UnifyState -> m Equality +getReducedEquality k s = do + let Equal a u v = getEquality k s + addContext (varTel s) $ Equal + <$> addContext (eqTel s) (reduce a) + <*> reduce u + <*> reduce v + +-- | As getEquality, but with the unraised type +getEqualityUnraised :: Int -> UnifyState -> Equality +getEqualityUnraised k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } = + Equal (snd <$> indexWithDefault __IMPOSSIBLE__ (telToList eqs) k) + (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k) + (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k) + +getReducedEqualityUnraised + :: (MonadReduce m, MonadAddContext m) + => Int -> UnifyState -> m Equality +getReducedEqualityUnraised k s = do + let Equal a u v = getEqualityUnraised k s + addContext (varTel s) $ Equal + <$> addContext (telFromList $ take k $ telToList $ eqTel s) (reduce a) + <*> reduce u + <*> reduce v + +--UNUSED Liang-Ting Chen 2019-07-16 +--getEqInfo :: Int -> UnifyState -> ArgInfo +--getEqInfo k UState { eqTel = eqs } = +-- domInfo $ indexWithDefault __IMPOSSIBLE__ (telToList eqs) k +-- +---- | Add a list of equations to the front of the equation telescope +--addEqs :: Telescope -> [Arg Term] -> [Arg Term] -> UnifyState -> UnifyState +--addEqs tel us vs s = +-- s { eqTel = tel `abstract` eqTel s +-- , eqLHS = us ++ eqLHS s +-- , eqRHS = vs ++ eqRHS s +-- } +-- where k = size tel +-- +--addEq :: Type -> Arg Term -> Arg Term -> UnifyState -> UnifyState +--addEq a u v = addEqs (ExtendTel (defaultDom a) (Abs underscore EmptyTel)) [u] [v] + + + +-- | Instantiate the k'th variable with the given value. +-- Returns Nothing if there is a cycle. +solveVar :: Int -- ^ Index @k@ + -> DeBruijnPattern -- ^ Solution @u@ + -> UnifyState -> Maybe (UnifyState, PatternSubstitution) +solveVar k u s = case instantiateTelescope (varTel s) k u of + Nothing -> Nothing + Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState + { varTel = tel' + , flexVars = permuteFlex (reverseP rho) $ flexVars s + , eqTel = applyPatSubst sigma $ eqTel s + , eqLHS = applyPatSubst sigma $ eqLHS s + , eqRHS = applyPatSubst sigma $ eqRHS s + } + where + permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars + permuteFlex perm = + mapMaybe $ \(FlexibleVar ai fc k p x) -> + FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm) + +applyUnder :: Int -> Telescope -> Term -> Telescope +applyUnder k tel u + | k < 0 = __IMPOSSIBLE__ + | k == 0 = tel `apply1` u + | otherwise = case tel of + EmptyTel -> __IMPOSSIBLE__ + ExtendTel a tel' -> ExtendTel a $ + Abs (absName tel') $ applyUnder (k-1) (absBody tel') u + +dropAt :: Int -> [a] -> [a] +dropAt _ [] = __IMPOSSIBLE__ +dropAt k (x:xs) + | k < 0 = __IMPOSSIBLE__ + | k == 0 = xs + | otherwise = x : dropAt (k-1) xs + +-- | Solve the k'th equation with the given value, which can depend on +-- regular variables but not on other equation variables. +solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution) +solveEq k u s = (,sigma) $ s + { eqTel = applyUnder k (eqTel s) u' + , eqLHS = dropAt k $ eqLHS s + , eqRHS = dropAt k $ eqRHS s + } + where + u' = raise k u + n = eqCount s + sigma = liftS (n-k-1) $ consS (dotP u') idS + +--UNUSED Liang-Ting Chen 2019-07-16 +---- | Simplify the k'th equation with the given value (which can depend on other +---- equation variables). Returns Nothing if there is a cycle. +--simplifyEq :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution) +--simplifyEq k u s = case instantiateTelescope (eqTel s) k u of +-- Nothing -> Nothing +-- Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState +-- { varTel = varTel s +-- , flexVars = flexVars s +-- , eqTel = tel' +-- , eqLHS = permute rho $ eqLHS s +-- , eqRHS = permute rho $ eqRHS s +-- } +-- +---------------------------------------------------- +-- Unification strategies +---------------------------------------------------- + +data UnifyStep + = Deletion + { deleteAt :: Int + , deleteType :: Type + , deleteLeft :: Term + , deleteRight :: Term + } + | Solution + { solutionAt :: Int + , solutionType :: Dom Type + , solutionVar :: FlexibleVar Int + , solutionTerm :: Term + , solutionSide :: Either () () + -- ^ side of the equation where the variable is. + } + | Injectivity + { injectAt :: Int + , injectType :: Type + , injectDatatype :: QName + , injectParameters :: Args + , injectIndices :: Args + , injectConstructor :: ConHead + } + | Conflict + { conflictAt :: Int + , conflictType :: Type + , conflictDatatype :: QName + , conflictParameters :: Args + , conflictLeft :: Term + , conflictRight :: Term + } + | Cycle + { cycleAt :: Int + , cycleType :: Type + , cycleDatatype :: QName + , cycleParameters :: Args + , cycleVar :: Int + , cycleOccursIn :: Term + } + | EtaExpandVar + { expandVar :: FlexibleVar Int + , expandVarRecordType :: QName + , expandVarParameters :: Args + } + | EtaExpandEquation + { expandAt :: Int + , expandRecordType :: QName + , expandParameters :: Args + } + | LitConflict + { litConflictAt :: Int + , litType :: Type + , litConflictLeft :: Literal + , litConflictRight :: Literal + } + | StripSizeSuc + { stripAt :: Int + , stripArgLeft :: Term + , stripArgRight :: Term + } + | SkipIrrelevantEquation + { skipIrrelevantAt :: Int + } + | TypeConInjectivity + { typeConInjectAt :: Int + , typeConstructor :: QName + , typeConArgsLeft :: Args + , typeConArgsRight :: Args + } deriving (Show) + +instance PrettyTCM UnifyStep where + prettyTCM step = case step of + Deletion k a u v -> "Deletion" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "type: " <+> prettyTCM a + , "lhs: " <+> prettyTCM u + , "rhs: " <+> prettyTCM v + ]) + Solution k a i u s -> "Solution" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "type: " <+> prettyTCM a + , "variable: " <+> text (show (flexVar i, flexPos i, flexForced i, flexKind i)) + , "term: " <+> prettyTCM u + , "side: " <+> text (show s) + ]) + Injectivity k a d pars ixs c -> "Injectivity" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "type: " <+> prettyTCM a + , "datatype: " <+> prettyTCM d + , "parameters: " <+> prettyList_ (map prettyTCM pars) + , "indices: " <+> prettyList_ (map prettyTCM ixs) + , "constructor:" <+> prettyTCM c + ]) + Conflict k a d pars u v -> "Conflict" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "type: " <+> prettyTCM a + , "datatype: " <+> prettyTCM d + , "parameters: " <+> prettyList_ (map prettyTCM pars) + , "lhs: " <+> prettyTCM u + , "rhs: " <+> prettyTCM v + ]) + Cycle k a d pars i u -> "Cycle" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "type: " <+> prettyTCM a + , "datatype: " <+> prettyTCM d + , "parameters: " <+> prettyList_ (map prettyTCM pars) + , "variable: " <+> text (show i) + , "term: " <+> prettyTCM u + ]) + EtaExpandVar fi r pars -> "EtaExpandVar" $$ nest 2 (vcat $ + [ "variable: " <+> text (show fi) + , "record type:" <+> prettyTCM r + , "parameters: " <+> prettyTCM pars + ]) + EtaExpandEquation k r pars -> "EtaExpandEquation" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "record type:" <+> prettyTCM r + , "parameters: " <+> prettyTCM pars + ]) + LitConflict k a u v -> "LitConflict" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "type: " <+> prettyTCM a + , "lhs: " <+> prettyTCM u + , "rhs: " <+> prettyTCM v + ]) + StripSizeSuc k u v -> "StripSizeSuc" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "lhs: " <+> prettyTCM u + , "rhs: " <+> prettyTCM v + ]) + SkipIrrelevantEquation k -> "SkipIrrelevantEquation" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + ]) + TypeConInjectivity k d us vs -> "TypeConInjectivity" $$ nest 2 (vcat $ + [ "position: " <+> text (show k) + , "datatype: " <+> prettyTCM d + , "lhs: " <+> prettyList_ (map prettyTCM us) + , "rhs: " <+> prettyList_ (map prettyTCM vs) + ]) + + +---------------------------------------------------- +-- Unify Log and monad +---------------------------------------------------- + +data UnifyLogEntry + -- = UnificationDone UnifyState + = UnificationStep UnifyState UnifyStep UnifyOutput + +type UnifyLog = [(UnifyLogEntry,UnifyState)] + +-- | This variant of 'UnifyLog' is used to ensure that 'tell' is not +-- expensive. +type UnifyLog' = DList (UnifyLogEntry, UnifyState) + +-- Given varΓ ⊢ eqΓ, varΓ ⊢ us, vs : eqΓ +data UnifyOutput = UnifyOutput + { unifySubst :: PatternSubstitution -- varΓ' ⊢ σ : varΓ + , unifyProof :: PatternSubstitution -- varΓ',eqΓ' ⊢ ps : eqΓ[σ] + -- varΓ', us' =_eqΓ' vs' ⊢ ap(ps) : us[σ] =_{eqΓ[σ]} vs[σ] +-- , unifyLog :: UnifyLog + } + +instance Semigroup UnifyOutput where + x <> y = UnifyOutput + { unifySubst = unifySubst y `composeS` unifySubst x + , unifyProof = unifyProof y `composeS` unifyProof x +-- , unifyLog = unifyLog x ++ unifyLog y + } + +instance Monoid UnifyOutput where + mempty = UnifyOutput IdS IdS -- [] + mappend = (<>) + +type UnifyLogT m a = WriterT UnifyLog' m a + +type UnifyStepT m a = WriterT UnifyOutput m a + +tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m () +tellUnifySubst sub = tell $ UnifyOutput sub IdS + +tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m () +tellUnifyProof sub = tell $ UnifyOutput IdS sub + +writeUnifyLog :: + MonadWriter UnifyLog' m => (UnifyLogEntry, UnifyState) -> m () +writeUnifyLog x = tell (singleton x) -- UnifyOutput IdS IdS [x] + +runUnifyLogT :: Functor m => UnifyLogT m a -> m (a, UnifyLog) +runUnifyLogT m = mapSnd toList <$> runWriterT m 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 @@ -11,6 +11,7 @@ import Agda.Interaction.Options import qualified Agda.Syntax.Abstract as A +import qualified Agda.Syntax.Abstract.Views as A import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern @@ -31,11 +32,15 @@ import Agda.TypeChecking.CompiledClause (hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile -import Agda.TypeChecking.Rules.Data ( getGeneralizedParameters, bindGeneralizedParameters, bindParameters, fitsIn, forceSort, - defineCompData, defineTranspOrHCompForFields ) +import Agda.TypeChecking.Rules.Data + ( getGeneralizedParameters, bindGeneralizedParameters, bindParameters + , checkDataSort, fitsIn, forceSort + , defineCompData, defineKanOperationForFields + ) import Agda.TypeChecking.Rules.Term ( isType_ ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkDecl) +import Agda.Utils.List (headWithDefault) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null @@ -60,7 +65,7 @@ -- -- [@ps@] Record parameters. -- --- [@contel@] Approximate type of constructor (@fields@ -> Set). +-- [@contel@] Approximate type of constructor (@fields@ -> dummy). -- Does not include record parameters. -- -- [@fields@] List of field signatures. @@ -71,11 +76,19 @@ -> UniverseCheck -- ^ Check universes? -> A.RecordDirectives -- ^ (Co)Inductive, (No)Eta, (Co)Pattern, Constructor? -> A.DataDefParams -- ^ Record parameters. - -> A.Expr -- ^ Approximate type of constructor (@fields@ -> Set). + -> A.Expr -- ^ Approximate type of constructor (@fields@ -> dummy). -- Does not include record parameters. -> [A.Field] -- ^ Field signatures. -> TCM () -checkRecDef i name uc (RecordDirectives ind eta0 pat con) (A.DataDefParams gpars ps) contel fields = +checkRecDef i name uc (RecordDirectives ind eta0 pat con) (A.DataDefParams gpars ps) contel0 fields = do + + -- Andreas, 2022-10-06, issue #6165: + -- The target type of the constructor is a meaningless dummy expression which does not type-check. + -- We replace it by Set/Type (builtinSet) which is still incorrect but type-checks. + -- It will be fixed after type-checking. + aType <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet + let contel = A.unPiView . (\ (A.PiView tels _) -> A.PiView tels aType) . A.piView $ contel0 + traceCall (CheckRecDef (getRange name) name ps fields) $ do reportSDoc "tc.rec" 10 $ vcat [ "checking record def" <+> prettyTCM name @@ -226,6 +239,8 @@ -- in case the record turns out to be recursive. -- Determined by positivity checker: , recMutual = Nothing + -- Determined by the termination checker: + , recTerminates = Nothing , recComp = emptyCompKit -- filled in later } @@ -258,6 +273,10 @@ -- Check that the fields fit inside the sort _ <- fitsIn uc [] contype s + -- Check that the sort admits record declarations. + checkDataSort name s + + {- Andreas, 2011-04-27 WRONG because field types are checked again and then non-stricts should not yet be irrelevant @@ -298,11 +317,16 @@ let m = qnameToMName name -- Name of record module. + eraseRecordParameters <- optEraseRecordParameters <$> pragmaOptions + let maybeErase :: forall a. LensQuantity a => a -> a + maybeErase | eraseRecordParameters = setQuantity zeroQuantity + | otherwise = id + -- Andreas, 2016-02-09 setting all parameters hidden in the record -- section telescope changes the semantics, see e.g. -- test/Succeed/RecordInParModule. -- Ulf, 2016-03-02 but it's the right thing to do (#1759) - modifyContextInfo hideOrKeepInstance $ addRecordVar $ do + modifyContextInfo (hideOrKeepInstance . maybeErase) $ addRecordVar $ do -- Add the record section. @@ -321,17 +345,20 @@ -- Andreas, 2016-02-09, Issue 1815 (see also issue 1759). -- For checking the record declarations, hide the record parameters -- and the parameters of the parent modules. - modifyContextInfo hideOrKeepInstance $ addRecordVar $ do + modifyContextInfo (hideOrKeepInstance . maybeErase) $ do + params <- getContext -- Check the types of the fields and the other record declarations. - withCurrentModule m $ do + addRecordVar $ withCurrentModule m $ do -- Andreas, 2013-09-13, 2016-01-06. -- Argument telescope for the projections: all parameters are hidden. -- This means parameters of the parent modules and of the current -- record type. -- See test/Succeed/ProjectionsTakeModuleTelAsParameters.agda. - tel' <- getContextTelescope + tel' <- do + r <- headWithDefault __IMPOSSIBLE__ <$> getContext + return $ telFromList' nameToArgName $ reverse $ r : params setModuleCheckpoint m checkRecordProjections m name hasNamedCon con tel' ftel fields @@ -345,7 +372,6 @@ modifySignature $ updateDefinition conName $ \def -> def { defMatchable = Set.fromList $ map unDom fs } - return () where -- Andreas, 2020-04-19, issue #4560 -- If the user declared the record constructor as @pattern@, @@ -408,8 +434,8 @@ reportSDoc "tc.rec.cxt" 30 $ prettyTCM fsT reportSDoc "tc.rec.cxt" 30 $ pretty rect if not $ all isJust required then return $ emptyCompKit else do - transp <- whenDefined [builtinTrans] (defineTranspOrHCompR DoTransp name params fsT fns rect) - hcomp <- whenDefined [builtinTrans,builtinHComp] (defineTranspOrHCompR DoHComp name params fsT fns rect) + transp <- whenDefined [builtinTrans] (defineKanOperationR DoTransp name params fsT fns rect) + hcomp <- whenDefined [builtinTrans,builtinHComp] (defineKanOperationR DoHComp name params fsT fns rect) return $ CompKit { nameOfTransp = transp , nameOfHComp = hcomp @@ -420,17 +446,17 @@ if all isJust xs then m else return Nothing -defineTranspOrHCompR :: - TranspOrHComp +defineKanOperationR + :: Command -> QName -- ^ some name, e.g. record name -> Telescope -- ^ param types Δ -> Telescope -- ^ fields' types Δ ⊢ Φ -> [Arg QName] -- ^ fields' names -> Type -- ^ record type Δ ⊢ T -> TCM (Maybe QName) -defineTranspOrHCompR cmd name params fsT fns rect = do +defineKanOperationR cmd name params fsT fns rect = do let project = (\ t fn -> t `applyE` [Proj ProjSystem fn]) - stuff <- fmap fst <$> defineTranspOrHCompForFields cmd Nothing project name params fsT fns rect + stuff <- fmap fst <$> defineKanOperationForFields cmd Nothing project name params fsT fns rect caseMaybe stuff (return Nothing) $ \ (theName, gamma, rtype, clause_types, bodies) -> do -- phi = 1 clause @@ -474,36 +500,38 @@ (g0,_:g1) = splitAt (size gamma - 1 - ix) $ flattenTel gamma (ns0,_:ns1) = splitAt (size gamma - 1 - ix) $ teleNames gamma - c = Clause { clauseTel = gamma' - , clauseType = Just $ argN t - , namedClausePats = pats - , clauseFullRange = noRange + c = Clause { clauseFullRange = noRange , clauseLHSRange = noRange - , clauseCatchall = False + , clauseTel = gamma' + , namedClausePats = pats , clauseBody = Just $ rhs + , clauseType = Just $ argN t + , clauseCatchall = False , clauseExact = Just True , clauseRecursive = Just False -- definitely non-recursive! , clauseUnreachable = Just False - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } reportSDoc "trans.rec.face" 17 $ text $ show c return c cs <- forM (zip3 fns clause_types bodies) $ \ (fname, clause_ty, body) -> do let pats = teleNamedArgs gamma ++ [defaultNamedArg $ ProjP ProjSystem $ unArg fname] - c = Clause { clauseTel = gamma - , clauseType = Just $ argN (unDom clause_ty) - , namedClausePats = pats - , clauseFullRange = noRange + c = Clause { clauseFullRange = noRange , clauseLHSRange = noRange - , clauseCatchall = False + , clauseTel = gamma + , namedClausePats = pats , clauseBody = Just body + , clauseType = Just $ argN (unDom clause_ty) + , clauseCatchall = False , clauseExact = Just True , clauseRecursive = Nothing -- Andreas 2020-02-06 TODO -- Or: Just False; is it known to be non-recursive? , clauseUnreachable = Just False - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } reportSDoc "trans.rec" 17 $ text $ show c reportSDoc "trans.rec" 16 $ text "type =" <+> text (show (clauseType c)) @@ -680,7 +708,8 @@ , clauseExact = Just True , clauseRecursive = Just False , clauseUnreachable = Just False - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } let projection = Projection @@ -717,14 +746,14 @@ escapeContext impossible (size tel) $ do lang <- getLanguage addConstant projname $ - (defaultDefn ai projname (killRange finalt) lang - emptyFunction - { funClauses = [clause] - , funCompiled = Just cc - , funSplitTree = mst - , funProjection = Just projection - , funMutual = Just [] -- Projections are not mutually recursive with anything - , funTerminates = Just True + (defaultDefn ai projname (killRange finalt) lang $ FunctionDefn + emptyFunctionData + { _funClauses = [clause] + , _funCompiled = Just cc + , _funSplitTree = mst + , _funProjection = Right projection + , _funMutual = Just [] -- Projections are not mutually recursive with anything + , _funTerminates = Just True }) { defArgOccurrences = [StrictPos] , defCopatternLHS = hasProjectionPatterns cc 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 @@ -17,7 +17,7 @@ import Agda.Interaction.Options import Agda.Interaction.Highlighting.Generate (disambiguateRecordFields) -import Agda.Syntax.Abstract (Binder) +import Agda.Syntax.Abstract (Binder, TypedBindingInfo (tbTacticAttr)) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views as A import qualified Agda.Syntax.Info as A @@ -207,7 +207,7 @@ , prettyTCM x , text $ " for interaction point " ++ show ii ] - mv <- lookupMeta x + mv <- lookupLocalMeta x let s0 = jMetaType . mvJudgement $ mv -- Andreas, 2016-10-14, issue #2257 -- The meta was created in a context of length @n@. @@ -357,7 +357,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) tac + tac <- traverse (checkTacticAttribute lamOrPi) (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 @@ -415,14 +415,13 @@ expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit) checkExpr e expectedType -ifPath :: Type -> TCM a -> TCM a -> TCM a -ifPath ty fallback work = do - pv <- pathView ty - if isPathType pv then work else fallback - checkPath :: A.TypedBinding -> A.Expr -> Type -> TCM Term -checkPath b@(A.TBind _ _ (x':|[]) typ) body ty = do - let x = updateNamedArg (A.unBind . A.binderName) x' +checkPath b@(A.TBind _r _tac (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" + Nothing -> do + let x = updateNamedArg (A.unBind . A.binderName) xp info = getArgInfo x PathType s path level typ lhs rhs <- pathView ty interval <- primIntervalType @@ -434,11 +433,12 @@ rhs' = subst 0 iOne v let t = Lam info $ Abs (namedArgName x) v let btyp i = El s (unArg typ `apply` [argN i]) - locallyTC eRange (const noRange) $ blockTerm ty $ traceCall (SetRange $ getRange body) $ do + locallyTC eRange (const noRange) $ blockTerm ty $ setCurrentRange body $ do equalTerm (btyp iZero) lhs' (unArg lhs) equalTerm (btyp iOne) rhs' (unArg rhs) return t checkPath b body ty = __IMPOSSIBLE__ + --------------------------------------------------------------------------- -- * Lambda abstractions --------------------------------------------------------------------------- @@ -490,11 +490,11 @@ info = getArgInfo $ List1.head xs trySeeingIfPath = do - cubical <- optCubical <$> pragmaOptions + cubical <- isJust . optCubical <$> pragmaOptions reportSLn "tc.term.lambda" 60 $ "trySeeingIfPath for " ++ show xps - let postpone' = if isJust cubical then postpone else \ _ _ -> dontUseTargetType + let postpone' = if cubical then postpone else \ _ _ -> dontUseTargetType ifBlocked target postpone' $ \ _ t -> do - ifPath t dontUseTargetType $ if isJust cubical + ifNotM (isPathType <$> pathView t) dontUseTargetType {-else-} $ if cubical then checkPath b body t else genericError $ unwords [ "Option --cubical/--erased-cubical needed to build" @@ -595,15 +595,7 @@ | otherwise = do let rPi = getRelevance dom -- relevance of function type let rLam = getRelevance info -- relevance of lambda - -- Andreas, 2017-01-24, issue #2429 - -- we should report an error if we try to check a relevant function - -- against an irrelevant function type (subtyping violation) - unless (moreRelevant rPi rLam) $ do - -- @rLam == Relevant@ is impossible here - -- @rLam == Irrelevant@ is impossible here (least relevant) - -- this error can only happen if @rLam == NonStrict@ and @rPi == Irrelevant@ - unless (rLam == NonStrict) __IMPOSSIBLE__ -- separate tests for separate line nums - unless (rPi == Irrelevant) __IMPOSSIBLE__ + unless (sameRelevance rPi rLam) $ typeError WrongIrrelevanceInLambda return info @@ -754,8 +746,8 @@ (\ d -> (defaultDefn (setModality mod info') aux t' lang d) { defPolarity = [Nonvariant] , defArgOccurrences = [Unused] }) - $ emptyFunction - { funClauses = + $ FunctionDefn emptyFunctionData + { _funClauses = [ Clause { clauseLHSRange = getRange e , clauseFullRange = getRange e @@ -767,14 +759,15 @@ , clauseExact = Just False , clauseRecursive = Just False , clauseUnreachable = Just True -- absurd clauses are unreachable - , clauseEllipsis = NoEllipsis + , clauseEllipsis = NoEllipsis + , clauseWhereModule = Nothing } ] - , funCompiled = Just $ Fail [Arg info' "()"] - , funSplitTree = Just $ SplittingDone 0 - , funMutual = Just [] - , funTerminates = Just True - , funExtLam = Just $ ExtLamInfo top True empty + , _funCompiled = Just $ Fail [Arg info' "()"] + , _funSplitTree = Just $ SplittingDone 0 + , _funMutual = Just [] + , _funTerminates = Just True + , _funExtLam = Just $ ExtLamInfo top True empty } -- Andreas 2012-01-30: since aux is lifted to toplevel -- it needs to be applied to the current telescope (issue 557) @@ -894,7 +887,7 @@ -- There might be metas in the blocker not known in the reset state, as they could have been -- created somewhere on the way to the type error. blocker <- (`onBlockingMetasM` blocker) $ \ x -> - lookupMeta' x >>= \ case + lookupMeta x >>= \ case -- Case: we do not know the meta, so cannot unblock. Nothing -> return neverUnblock -- Case: we know the meta here. @@ -908,8 +901,10 @@ -- fact not very helpful. Yes there is no hope of solving the problem, but throwing a hard -- error means we rob the user of the tools needed to figure out why the meta has not been -- solved. Better to leave the constraint. - Just m | InstV{} <- mvInstantiation m -> return alwaysUnblock - | otherwise -> return $ unblockOnMeta x + Just Left{} -> return alwaysUnblock + Just (Right m) + | InstV{} <- mvInstantiation m -> return alwaysUnblock + | otherwise -> return $ unblockOnMeta x -- If it's not blocked or we can't ever unblock reraise the error. if blocker `elem` [neverUnblock, alwaysUnblock] then reraise else handle (err, blocker) @@ -993,6 +988,15 @@ , " con = " <> return (P.pretty con) ] + -- Record expressions corresponding to erased record + -- constructors can only be used in compile-time mode. + constructorQ <- getQuantity <$> getConstInfo (conName con) + currentQ <- viewTC eQuantity + unless (constructorQ `moreQuantity` currentQ) $ + typeError $ GenericError $ + "A record expression corresponding to an erased record " ++ + "constructor must only be used in erased settings" + -- 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. @@ -1245,8 +1249,6 @@ (dontCare <$> do applyRelevanceToContext Irrelevant $ checkExpr' cmp e t) (internalError "DontCare may only appear in irrelevant contexts") - A.ETel _ -> __IMPOSSIBLE__ - A.Dot{} -> genericError "Invalid dotted expression" -- Application @@ -1327,7 +1329,6 @@ A.Rec{} -> True A.RecUpdate{} -> True A.ScopedExpr{} -> __IMPOSSIBLE__ - A.ETel{} -> __IMPOSSIBLE__ _ -> False --------------------------------------------------------------------------- @@ -1362,10 +1363,10 @@ case ok of Left (BlockedOnMeta oldState blocker) -> do putTC oldState - let stripFreshMeta x = maybe neverUnblock (const $ unblockOnMeta x) <$> lookupMeta' x + let stripFreshMeta x = maybe neverUnblock (const $ unblockOnMeta x) <$> lookupLocalMeta' x blocker' <- onBlockingMetasM stripFreshMeta blocker r <- case Set.toList $ allBlockingMetas blocker' of - x : _ -> getRange <$> lookupMeta' x + x : _ -> getRange <$> lookupLocalMeta' x [] -> return noRange setCurrentRange r $ addConstraint blocker' (UnquoteTactic tac hole goal) @@ -1470,7 +1471,7 @@ -> TCM (Args, Type) -- ^ Remaining inferred arguments, remaining type. checkKnownArguments [] vs t = return (vs, t) checkKnownArguments (arg : args) vs t = do - (vs', t') <- traceCall (SetRange $ getRange arg) $ checkKnownArgument arg vs t + (vs', t') <- setCurrentRange arg $ checkKnownArgument arg vs t checkKnownArguments args vs' t' -- | Check an argument whose value we already know. @@ -1647,7 +1648,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) 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 @@ -36,19 +36,21 @@ import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader import Control.Monad.State.Strict +import Control.Monad.ST.Trans import Data.Array.IArray +import Data.Array.IO import Data.Word +import Data.Int (Int32) import Data.ByteString.Lazy ( ByteString ) import Data.ByteString.Builder ( byteString, toLazyByteString ) import qualified Data.ByteString.Lazy as L -import qualified Data.HashTable.IO as H import qualified Data.Map as Map import qualified Data.Binary as B import qualified Data.Binary.Get as B import qualified Data.Binary.Put as B import qualified Data.List as List -import Data.Function +import Data.Function (on) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup((<>)) #endif @@ -67,10 +69,11 @@ import Agda.TypeChecking.Monad -import Agda.Utils.FileName (canonicalizeAbsolutePath) import Agda.Utils.Hash +import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef import Agda.Utils.Null +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Impossible @@ -79,7 +82,7 @@ -- 32-bit machines). Word64 does not have these problems. currentInterfaceVersion :: Word64 -currentInterfaceVersion = 20220211 * 10 + 0 +currentInterfaceVersion = 20221119 * 10 + 0 -- | The result of 'encode' and 'encodeInterface'. @@ -96,18 +99,15 @@ encode :: EmbPrj a => a -> TCM Encoded encode a = do - collectStats <- hasVerbosity "profile.serialize" 20 - fileMod <- sourceToModule + collectStats <- hasProfileOption Profile.Serialize newD@(Dict nD ltD stD bD iD dD _tD _nameD _qnameD nC ltC stC bC iC dC tC nameC qnameC - stats _ _) <- liftIO $ emptyDict collectStats - root <- liftIO $ (`runReaderT` newD) $ do - icodeFileMod fileMod -- Only fills absPathD from fileMod - icode a + stats _) <- liftIO $ emptyDict collectStats + root <- liftIO $ (`runReaderT` newD) $ icode a nL <- benchSort $ l nD stL <- benchSort $ l stD ltL <- benchSort $ l ltD @@ -115,9 +115,9 @@ iL <- benchSort $ l iD dL <- benchSort $ l dD -- Record reuse statistics. - verboseS "profile.sharing" 10 $ do + whenProfile Profile.Sharing $ do statistics "pointers" tC - verboseS "profile.serialize" 10 $ do + whenProfile Profile.Serialize $ do statistics "Integer" iC statistics "Lazy Text" ltC statistics "Strict Text" stC @@ -167,13 +167,32 @@ -- (shared, total) <- readIORef stats -- return (B.encode currentInterfaceVersion <> -- G.compress (B.encode (root, nL, sL, iL, dL)), shared, total) --- verboseS "profile.sharing" 10 $ do +-- whenProfile Profile.Sharing $ do -- tickN "pointers (reused)" $ fromIntegral shared -- tickN "pointers" $ fromIntegral total -- return x -- where -- l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h +newtype ListLike a = ListLike { unListLike :: Array Int32 a } + +instance B.Binary a => B.Binary (ListLike a) where + put = __IMPOSSIBLE__ -- Will never serialise this + get = fmap ListLike $ runSTArray $ do + n <- lift (B.get :: B.Get Int) + arr <- newArray_ (0, fromIntegral n - 1) :: STT s B.Get (STArray s Int32 a) + + -- We'd like to use 'for_ [0..n-1]' here, but unfortunately GHC doesn't unfold + -- the list construction and so performs worse than the hand-written version. + let + getMany i = if i == n then return () else do + x <- lift B.get + unsafeWriteSTArray arr i x + getMany (i + 1) + () <- getMany 0 + + return arr + -- | Decodes an uncompressed bytestring (without extra hashes or magic -- numbers). The result depends on the include path. -- @@ -195,8 +214,9 @@ then noResult "Garbage at end." else do - st <- St (ar nL) (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL) - <$> liftIO H.new + let nL' = ar nL + st <- St nL' (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL) + <$> liftIO (newArray (bounds nL') mempty) <*> return mf <*> return incs (r, st) <- runStateT (runExceptT (value r)) st return (Just $ modFile st, r) @@ -224,7 +244,7 @@ return Nothing where - ar l = listArray (0, List.genericLength l - 1) l + ar = unListLike noResult s = return (Nothing, Left $ GenericError s) @@ -294,20 +314,3 @@ decodeFile :: FilePath -> TCM (Maybe Interface) decodeFile f = decodeInterface =<< liftIO (L.readFile f) - --- | Store a 'SourceToModule' (map from 'AbsolutePath' to 'TopLevelModuleName') --- as map from 'AbsolutePath' to 'Int32', in order to directly get the identifiers --- from absolute pathes rather than going through top level module names. -icodeFileMod - :: SourceToModule - -- ^ Maps file names to the corresponding module names. - -- Must contain a mapping for every file name that is later encountered. - -> S () -icodeFileMod fileMod = do - hmap <- asks absPathD - forM_ (Map.toList fileMod) $ \ (absolutePath, topLevelModuleName) -> do - -- Andreas, 2020-08-11, issue #4828. - -- Expand symlinks before storing in the dictonary. - absolutePath <- liftIO $ canonicalizeAbsolutePath absolutePath - i <- icod_ topLevelModuleName - liftIO $ H.insert hmap absolutePath i diff --git a/src/full/Agda/TypeChecking/Serialise/Base.hs b/src/full/Agda/TypeChecking/Serialise/Base.hs --- a/src/full/Agda/TypeChecking/Serialise/Base.hs +++ b/src/full/Agda/TypeChecking/Serialise/Base.hs @@ -16,9 +16,10 @@ import Data.Proxy import Data.Array.IArray +import Data.Array.IO +import qualified Data.HashMap.Strict as Hm import qualified Data.ByteString.Lazy as L import Data.Hashable -import qualified Data.HashTable.IO as H import Data.Int (Int32) import Data.Maybe import qualified Data.Binary as B @@ -32,6 +33,8 @@ import Agda.TypeChecking.Monad.Base (TypeError(GenericError), ModuleToSource) import Agda.Utils.FileName +import Agda.Utils.HashTable (HashTable) +import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef import Agda.Utils.Lens import Agda.Utils.Monad @@ -42,19 +45,6 @@ type Node = [Int32] --- | The type of hashtables used in this module. --- --- A very limited amount of testing indicates that 'H.CuckooHashTable' --- is somewhat slower than 'H.BasicHashTable', and that --- 'H.LinearHashTable' and the hashtables from "Data.Hashtable" are --- much slower. - -#if defined(mingw32_HOST_OS) && defined(x86_64_HOST_ARCH) -type HashTable k v = H.CuckooHashTable k v -#else -type HashTable k v = H.BasicHashTable k v -#endif - -- | Structure providing fresh identifiers for hash map -- and counting hash map hits (i.e. when no fresh identifier required). #ifdef DEBUG @@ -119,7 +109,6 @@ , collectStats :: Bool -- ^ If @True@ collect in @stats@ the quantities of -- calls to @icode@ for each @Typeable a@. - , absPathD :: !(HashTable AbsolutePath Int32) -- ^ Not written to interface file. } -- | Creates an empty dictionary. @@ -128,15 +117,15 @@ -- ^ Collect statistics for @icode@ calls? -> IO Dict emptyDict collectStats = Dict - <$> H.new - <*> H.new - <*> H.new - <*> H.new - <*> H.new - <*> H.new - <*> H.new - <*> H.new - <*> H.new + <$> H.empty + <*> H.empty + <*> H.empty + <*> H.empty + <*> H.empty + <*> H.empty + <*> H.empty + <*> H.empty + <*> H.empty <*> newIORef farEmpty <*> newIORef farEmpty <*> newIORef farEmpty @@ -146,15 +135,14 @@ <*> newIORef farEmpty <*> newIORef farEmpty <*> newIORef farEmpty - <*> H.new + <*> H.empty <*> pure collectStats - <*> H.new -- | Universal type, wraps everything. data U = forall a . Typeable a => U !a -- | Univeral memo structure, to introduce sharing during decoding -type Memo = HashTable (Int32, TypeRep) U -- (node index, type rep) +type Memo = IOArray Int32 (Hm.HashMap TypeRep U) -- node index -> (type rep -> value) -- | State of the decoder. data St = St @@ -380,14 +368,14 @@ let aTyp = typeRep (Proxy :: Proxy a) -- to introduce sharing, see if we have seen a thing -- represented by ix before - maybeU <- liftIO $ H.lookup memo (ix, aTyp) - case maybeU of + slot <- liftIO $ readArray memo ix + case Hm.lookup aTyp slot of -- yes, we have seen it before, use the version from memo Just (U u) -> maybe malformed return (cast u) -- no, it's new, so generate it via valu and insert it into memo Nothing -> do v <- valu . (! ix) =<< gets nodeE - liftIO $ H.insert memo (ix, aTyp) (U v) + liftIO $ writeArray memo ix (Hm.insert aTyp (U v) slot) return v -- | @icodeArgs proxy (a1, ..., an)@ maps @icode@ over @a1@, ..., @an@ diff --git a/src/full/Agda/TypeChecking/Serialise/Instances.hs b/src/full/Agda/TypeChecking/Serialise/Instances.hs --- a/src/full/Agda/TypeChecking/Serialise/Instances.hs +++ b/src/full/Agda/TypeChecking/Serialise/Instances.hs @@ -4,7 +4,7 @@ module Agda.TypeChecking.Serialise.Instances () where import Agda.Syntax.Position -import Agda.Syntax.Abstract.Name +import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Serialise.Base import Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..)) @@ -12,21 +12,24 @@ import Agda.TypeChecking.Serialise.Instances.Errors () import Agda.Utils.Hash -type RangedImportedModules = [(SerialisedRange, ModuleName, Hash)] +type RangedImportedModules = + [(SerialisedRange, TopLevelModuleName, Hash)] -fromImportedModules :: [(ModuleName, Hash)] -> RangedImportedModules +fromImportedModules :: + [(TopLevelModuleName, Hash)] -> RangedImportedModules fromImportedModules ms = [(SerialisedRange $ getRange x, x, hash) | (x, hash) <- ms] -toImportedModules :: RangedImportedModules -> [(ModuleName, Hash)] +toImportedModules :: + RangedImportedModules -> [(TopLevelModuleName, Hash)] toImportedModules ms = [(setRange (underlyingRange r) x, hash) | (r, x, hash) <- ms] instance EmbPrj Interface where - icod_ (Interface a b c d e f g h i j k l m n o p q r s t) = - icodeN' interface a b c (fromImportedModules d) e f g h i j k l m n o p q r s t + icod_ (Interface a b c d e f g h i j k l m n o p q r s t u v) = + icodeN' interface a b c (fromImportedModules d) e f g h i j k l m n o p q r s t u v where interface a b c = Interface a b c . toImportedModules value = vcase valu where - valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t] = - valuN interface a b c d e f g h i j k l m n o p q r s t + valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v] = + valuN interface a b c d e f g h i j k l m n o p q r s t u v where interface a b c = Interface a b c . toImportedModules 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 @@ -13,7 +13,6 @@ import Data.Word import qualified Data.Foldable as Fold import Data.Hashable -import qualified Data.HashTable.IO as H import Data.Int (Int32) import Data.Map (Map) @@ -21,8 +20,6 @@ import Data.Set (Set) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet) -import Data.List.NonEmpty (NonEmpty(..), nonEmpty) -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import Data.Sequence (Seq) import qualified Data.Sequence as Seq @@ -41,6 +38,7 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Position as P import Agda.Syntax.Literal +import Agda.Syntax.TopLevelModuleName import Agda.Interaction.FindFile import Agda.TypeChecking.Serialise.Base @@ -49,6 +47,9 @@ import qualified Agda.Utils.BiMap as BiMap import qualified Agda.Utils.Empty as Empty import Agda.Utils.FileName +import qualified Agda.Utils.HashTable as H +import Agda.Utils.List1 (List1) +import qualified Agda.Utils.List1 as List1 import Agda.Utils.List2 (List2(List2)) import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe @@ -194,36 +195,6 @@ [1, a] -> valuN Cubical a _ -> malformed -instance EmbPrj AbsolutePath where - icod_ file = do - d <- asks absPathD - -- Andreas, 2020-08-11, issue #4828 - -- AbsolutePath is no longer canonical (can contain symlinks). - -- The dictonary contains canonical pathes, though. - file <- liftIO $ canonicalizeAbsolutePath file - liftIO $ flip fromMaybeM (H.lookup d file) $ do - -- The path @file@ should be cached in the dictionary @d@. - -- This seems not to be the case, thus, crash here. - -- But leave some hints for the posterity why things could go so wrong. - -- reportSLn "impossible" 10 -- does not work here - putStrLn $ unlines $ - [ "Panic while serializing absolute path: " ++ show file - , "The path could not be found in the dictionary:" - ] - print =<< H.toList d - __IMPOSSIBLE__ - - value m = do - m :: TopLevelModuleName - <- value m - mf <- gets modFile - incs <- gets includes - (r, mf) <- liftIO $ findFile'' incs m mf - modify $ \s -> s { modFile = mf } - case r of - Left err -> throwError $ findErrorToTypeError m err - Right f -> return (srcFilePath f) - instance EmbPrj a => EmbPrj (Position' a) where icod_ (P.Pn file pos line col) = icodeN' P.Pn file pos line col @@ -240,7 +211,7 @@ _ -> malformed instance EmbPrj TopLevelModuleName where - icod_ (TopLevelModuleName a b) = icodeN' TopLevelModuleName a b + icod_ (TopLevelModuleName a b c) = icodeN' TopLevelModuleName a b c value = valueN TopLevelModuleName @@ -253,9 +224,9 @@ -- valu [x, xs] = valu2 (:) x xs -- valu _ = malformed -instance EmbPrj a => EmbPrj (NonEmpty a) where - icod_ = icod_ . NonEmpty.toList - value = maybe malformed return . nonEmpty <=< value +instance EmbPrj a => EmbPrj (List1 a) where + icod_ = icod_ . List1.toList + value = maybe malformed return . List1.nonEmpty <=< value instance EmbPrj a => EmbPrj (List2 a) where icod_ = icod_ . List2.toList @@ -266,9 +237,31 @@ icod_ m = icode (BiMap.toDistinctAscendingLists m) value m = BiMap.fromDistinctAscendingLists <$> value m + +-- | Encode a list of key-value pairs as a flat list. +mapPairsIcode :: (EmbPrj k, EmbPrj v) => [(k, v)] -> S Int32 +mapPairsIcode xs = icodeNode =<< convert [] xs where + -- As we need to call `convert' in the tail position, the resulting list is + -- written (and read) in reverse order, with the highest pair first in the + -- resulting list. + convert ys [] = return ys + convert ys ((start, entry):xs) = do + start <- icode start + entry <- icode entry + convert (start:entry:ys) xs + +mapPairsValue :: (EmbPrj k, EmbPrj v) => [Int32] -> R [(k, v)] +mapPairsValue = convert [] where + convert ys [] = return ys + convert ys (start:entry:xs) = do + start <- value start + entry <- value entry + convert ((start, entry):ys) xs + convert _ _ = malformed + instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where - icod_ m = icode (Map.toAscList m) - value m = Map.fromDistinctAscList <$> value m + icod_ m = mapPairsIcode (Map.toAscList m) + value = vcase (fmap Map.fromDistinctAscList . mapPairsValue) instance (Ord a, EmbPrj a) => EmbPrj (Set a) where icod_ s = icode (Set.toAscList s) @@ -292,6 +285,21 @@ value = valueN P.Interval +instance EmbPrj RangeFile where + icod_ (RangeFile _ Nothing) = __IMPOSSIBLE__ + icod_ (RangeFile _ (Just a)) = icode a + + value r = do + m :: TopLevelModuleName + <- value r + mf <- gets modFile + incs <- gets includes + (r, mf) <- liftIO $ findFile'' incs m mf + modify $ \s -> s { modFile = mf } + case r of + Left err -> throwError $ findErrorToTypeError m err + Right f -> return $ RangeFile (srcFilePath f) (Just m) + -- | Ranges are always deserialised as 'noRange'. instance EmbPrj Range where @@ -386,23 +394,29 @@ value = valueN (\ f n -> Fixity' f n noRange) -instance EmbPrj GenPart where - icod_ (BindHole a b) = icodeN 0 BindHole a b - icod_ (NormalHole a b) = icodeN 1 NormalHole a b - icod_ (WildHole a) = icodeN 2 WildHole a - icod_ (IdPart a) = icodeN' IdPart a +instance EmbPrj BoundVariablePosition where + icod_ (BoundVariablePosition a b) = icodeN' BoundVariablePosition a b + value = valueN BoundVariablePosition + +instance EmbPrj NotationPart where + icod_ (VarPart a b) = icodeN 0 VarPart a b + icod_ (HolePart a b) = icodeN 1 HolePart a b + icod_ (WildPart a) = icodeN 2 WildPart a + icod_ (IdPart a) = icodeN' IdPart a + value = vcase valu where - valu [0, a, b] = valuN BindHole a b - valu [1, a, b] = valuN NormalHole a b - valu [2, a] = valuN WildHole a + valu [0, a, b] = valuN VarPart a b + valu [1, a, b] = valuN HolePart a b + valu [2, a] = valuN WildPart a valu [a] = valuN IdPart a valu _ = malformed instance EmbPrj MetaId where - icod_ (MetaId n) = icod_ n - value i = MetaId <$> value i + icod_ (MetaId a b) = icode (a, b) + value m = uncurry MetaId <$> value m + instance EmbPrj A.QName where icod_ n@(A.QName a b) = icodeMemo qnameD qnameC (qnameId n) $ icodeN' A.QName a b @@ -453,8 +467,8 @@ value = valueN NameId instance (Eq k, Hashable k, EmbPrj k, EmbPrj v) => EmbPrj (HashMap k v) where - icod_ m = icode (HMap.toList m) - value m = HMap.fromList `fmap` value m + icod_ m = mapPairsIcode (HMap.toList m) + value = vcase (fmap HMap.fromList . mapPairsValue) instance EmbPrj a => EmbPrj (WithHiding a) where icod_ (WithHiding a b) = icodeN' WithHiding a b 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 @@ -16,6 +16,7 @@ import Agda.Interaction.Library.Base import Agda.Termination.CutOff import Agda.Utils.Pretty +import Agda.Utils.ProfileOptions import Agda.Utils.Impossible @@ -62,8 +63,8 @@ IllformedAsClause a -> icodeN 15 IllformedAsClause a WithoutKFlagPrimEraseEquality -> icodeN 16 WithoutKFlagPrimEraseEquality InstanceWithExplicitArg a -> icodeN 17 InstanceWithExplicitArg a - InfectiveImport a b -> icodeN 18 InfectiveImport a b - CoInfectiveImport a b -> icodeN 19 CoInfectiveImport a b + InfectiveImport a -> icodeN 18 InfectiveImport a + CoInfectiveImport a -> icodeN 19 CoInfectiveImport a InstanceNoOutputTypeName a -> icodeN 20 InstanceNoOutputTypeName a InstanceArgWithExplicitArg a -> icodeN 21 InstanceArgWithExplicitArg a WrongInstanceDeclaration -> icodeN 22 WrongInstanceDeclaration @@ -84,6 +85,8 @@ RewriteMissingRule a b c -> icodeN 37 RewriteMissingRule a b c ParseWarning a -> icodeN 38 ParseWarning a NoGuardednessFlag a -> icodeN 39 NoGuardednessFlag a + UnsupportedIndexedMatch f -> icodeN 40 UnsupportedIndexedMatch f + OptionWarning a -> icodeN 41 OptionWarning a value = vcase $ \ case [0, a, b] -> valuN UnreachableClauses a b @@ -104,8 +107,8 @@ [15, a] -> valuN IllformedAsClause a [16] -> valuN WithoutKFlagPrimEraseEquality [17, a] -> valuN InstanceWithExplicitArg a - [18, a, b] -> valuN InfectiveImport a b - [19, a, b] -> valuN CoInfectiveImport a b + [18, a] -> valuN InfectiveImport a + [19, a] -> valuN CoInfectiveImport a [20, a] -> valuN InstanceNoOutputTypeName a [21, a] -> valuN InstanceArgWithExplicitArg a [22] -> valuN WrongInstanceDeclaration @@ -126,8 +129,18 @@ [37, a, b, c] -> valuN RewriteMissingRule a b c [38, a] -> valuN ParseWarning a [39, a] -> valuN NoGuardednessFlag a + [40, a] -> valuN UnsupportedIndexedMatch a + [41, a] -> valuN OptionWarning a _ -> malformed +instance EmbPrj OptionWarning where + icod_ = \case + OptionRenamed a b -> icodeN' OptionRenamed a b + + value = vcase $ \case + [a, b] -> valuN OptionRenamed a b + _ -> malformed + instance EmbPrj ParseWarning where icod_ = \case OverlappingTokensWarning a -> icodeN 0 OverlappingTokensWarning a @@ -191,6 +204,7 @@ InvalidConstructor a -> icodeN 30 InvalidConstructor a InvalidConstructorBlock a -> icodeN 31 InvalidConstructorBlock a MissingDeclarations a -> icodeN 32 MissingDeclarations a + HiddenGeneralize r -> icodeN 33 HiddenGeneralize r value = vcase $ \case [0, a] -> valuN UnknownNamesInFixityDecl a @@ -226,6 +240,7 @@ [30,r] -> valuN InvalidConstructor r [31,r] -> valuN InvalidConstructorBlock r [32,r] -> valuN MissingDeclarations r + [33,r] -> valuN HiddenGeneralize r _ -> malformed instance EmbPrj LibWarning where @@ -265,16 +280,36 @@ value = valueN text +instance EmbPrj InfectiveCoinfective where + icod_ Infective = icodeN' Infective + icod_ Coinfective = icodeN 0 Coinfective + + value = vcase valu where + valu [] = valuN Infective + valu [0] = valuN Coinfective + valu _ = malformed + instance EmbPrj PragmaOptions where icod_ = \case - 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 -> - 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 + 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 -> + 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 value = vcase $ \case - [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] -> - valuN 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 + [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] -> + valuN 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 _ -> malformed +instance EmbPrj ProfileOptions where + icod_ opts = icode (profileOptionsToList opts) + value = fmap profileOptionsFromList . value + +instance EmbPrj ProfileOption where + icod_ = icode . fromEnum + value = value >=> \ n -> if lo <= n && n <= hi then pure (toEnum n) else malformed + where + lo = fromEnum (minBound :: ProfileOption) + hi = fromEnum (maxBound :: ProfileOption) + instance EmbPrj UnicodeOrAscii instance EmbPrj ConfluenceCheck where @@ -295,9 +330,202 @@ _ -> malformed instance EmbPrj WarningName where - icod_ x = icod_ (warningName2String x) + icod_ = return . \case + OverlappingTokensWarning_ -> 0 + UnsupportedAttribute_ -> 1 + MultipleAttributes_ -> 2 + LibUnknownField_ -> 3 + EmptyAbstract_ -> 4 + EmptyConstructor_ -> 5 + EmptyField_ -> 6 + EmptyGeneralize_ -> 7 + EmptyInstance_ -> 8 + EmptyMacro_ -> 9 + EmptyMutual_ -> 10 + EmptyPostulate_ -> 11 + EmptyPrimitive_ -> 12 + EmptyPrivate_ -> 13 + EmptyRewritePragma_ -> 14 + EmptyWhere_ -> 15 + HiddenGeneralize_ -> 16 + InvalidCatchallPragma_ -> 17 + InvalidConstructor_ -> 18 + InvalidConstructorBlock_ -> 19 + InvalidCoverageCheckPragma_ -> 20 + InvalidNoPositivityCheckPragma_ -> 21 + InvalidNoUniverseCheckPragma_ -> 22 + InvalidRecordDirective_ -> 23 + InvalidTerminationCheckPragma_ -> 24 + MissingDeclarations_ -> 25 + MissingDefinitions_ -> 26 + NotAllowedInMutual_ -> 27 + OpenPublicAbstract_ -> 28 + OpenPublicPrivate_ -> 29 + PolarityPragmasButNotPostulates_ -> 30 + PragmaCompiled_ -> 31 + PragmaNoTerminationCheck_ -> 32 + ShadowingInTelescope_ -> 33 + UnknownFixityInMixfixDecl_ -> 34 + UnknownNamesInFixityDecl_ -> 35 + UnknownNamesInPolarityPragmas_ -> 36 + UselessAbstract_ -> 37 + UselessInstance_ -> 38 + UselessPrivate_ -> 39 + AbsurdPatternRequiresNoRHS_ -> 40 + AsPatternShadowsConstructorOrPatternSynonym_ -> 41 + CantGeneralizeOverSorts_ -> 42 + ClashesViaRenaming_ -> 43 + CoverageIssue_ -> 44 + CoverageNoExactSplit_ -> 45 + DeprecationWarning_ -> 46 + DuplicateUsing_ -> 47 + FixityInRenamingModule_ -> 48 + GenericNonFatalError_ -> 49 + GenericUseless_ -> 50 + GenericWarning_ -> 51 + IllformedAsClause_ -> 52 + InstanceArgWithExplicitArg_ -> 53 + InstanceWithExplicitArg_ -> 54 + InstanceNoOutputTypeName_ -> 55 + InversionDepthReached_ -> 56 + ModuleDoesntExport_ -> 57 + NoGuardednessFlag_ -> 58 + NotInScope_ -> 59 + NotStrictlyPositive_ -> 60 + UnsupportedIndexedMatch_ -> 61 + OldBuiltin_ -> 62 + PragmaCompileErased_ -> 63 + RewriteMaybeNonConfluent_ -> 64 + RewriteNonConfluent_ -> 65 + RewriteAmbiguousRules_ -> 66 + RewriteMissingRule_ -> 67 + SafeFlagEta_ -> 68 + SafeFlagInjective_ -> 69 + SafeFlagNoCoverageCheck_ -> 70 + SafeFlagNonTerminating_ -> 71 + SafeFlagNoPositivityCheck_ -> 72 + SafeFlagNoUniverseCheck_ -> 73 + SafeFlagPolarity_ -> 74 + SafeFlagPostulate_ -> 75 + SafeFlagPragma_ -> 76 + SafeFlagTerminating_ -> 77 + SafeFlagWithoutKFlagPrimEraseEquality_ -> 78 + TerminationIssue_ -> 79 + UnreachableClauses_ -> 80 + UnsolvedConstraints_ -> 81 + UnsolvedInteractionMetas_ -> 82 + UnsolvedMetaVariables_ -> 83 + UselessHiding_ -> 84 + UselessInline_ -> 85 + UselessPatternDeclarationForRecord_ -> 86 + UselessPublic_ -> 87 + UserWarning_ -> 88 + WithoutKFlagPrimEraseEquality_ -> 89 + WrongInstanceDeclaration_ -> 90 + CoInfectiveImport_ -> 91 + InfectiveImport_ -> 92 + DuplicateFieldsWarning_ -> 93 + TooManyFieldsWarning_ -> 94 + OptionRenamed_ -> 95 - value = (maybe malformed return . string2WarningName) <=< value + value = \case + 0 -> return OverlappingTokensWarning_ + 1 -> return UnsupportedAttribute_ + 2 -> return MultipleAttributes_ + 3 -> return LibUnknownField_ + 4 -> return EmptyAbstract_ + 5 -> return EmptyConstructor_ + 6 -> return EmptyField_ + 7 -> return EmptyGeneralize_ + 8 -> return EmptyInstance_ + 9 -> return EmptyMacro_ + 10 -> return EmptyMutual_ + 11 -> return EmptyPostulate_ + 12 -> return EmptyPrimitive_ + 13 -> return EmptyPrivate_ + 14 -> return EmptyRewritePragma_ + 15 -> return EmptyWhere_ + 16 -> return HiddenGeneralize_ + 17 -> return InvalidCatchallPragma_ + 18 -> return InvalidConstructor_ + 19 -> return InvalidConstructorBlock_ + 20 -> return InvalidCoverageCheckPragma_ + 21 -> return InvalidNoPositivityCheckPragma_ + 22 -> return InvalidNoUniverseCheckPragma_ + 23 -> return InvalidRecordDirective_ + 24 -> return InvalidTerminationCheckPragma_ + 25 -> return MissingDeclarations_ + 26 -> return MissingDefinitions_ + 27 -> return NotAllowedInMutual_ + 28 -> return OpenPublicAbstract_ + 29 -> return OpenPublicPrivate_ + 30 -> return PolarityPragmasButNotPostulates_ + 31 -> return PragmaCompiled_ + 32 -> return PragmaNoTerminationCheck_ + 33 -> return ShadowingInTelescope_ + 34 -> return UnknownFixityInMixfixDecl_ + 35 -> return UnknownNamesInFixityDecl_ + 36 -> return UnknownNamesInPolarityPragmas_ + 37 -> return UselessAbstract_ + 38 -> return UselessInstance_ + 39 -> return UselessPrivate_ + 40 -> return AbsurdPatternRequiresNoRHS_ + 41 -> return AsPatternShadowsConstructorOrPatternSynonym_ + 42 -> return CantGeneralizeOverSorts_ + 43 -> return ClashesViaRenaming_ + 44 -> return CoverageIssue_ + 45 -> return CoverageNoExactSplit_ + 46 -> return DeprecationWarning_ + 47 -> return DuplicateUsing_ + 48 -> return FixityInRenamingModule_ + 49 -> return GenericNonFatalError_ + 50 -> return GenericUseless_ + 51 -> return GenericWarning_ + 52 -> return IllformedAsClause_ + 53 -> return InstanceArgWithExplicitArg_ + 54 -> return InstanceWithExplicitArg_ + 55 -> return InstanceNoOutputTypeName_ + 56 -> return InversionDepthReached_ + 57 -> return ModuleDoesntExport_ + 58 -> return NoGuardednessFlag_ + 59 -> return NotInScope_ + 60 -> return NotStrictlyPositive_ + 61 -> return UnsupportedIndexedMatch_ + 62 -> return OldBuiltin_ + 63 -> return PragmaCompileErased_ + 64 -> return RewriteMaybeNonConfluent_ + 65 -> return RewriteNonConfluent_ + 66 -> return RewriteAmbiguousRules_ + 67 -> return RewriteMissingRule_ + 68 -> return SafeFlagEta_ + 69 -> return SafeFlagInjective_ + 70 -> return SafeFlagNoCoverageCheck_ + 71 -> return SafeFlagNonTerminating_ + 72 -> return SafeFlagNoPositivityCheck_ + 73 -> return SafeFlagNoUniverseCheck_ + 74 -> return SafeFlagPolarity_ + 75 -> return SafeFlagPostulate_ + 76 -> return SafeFlagPragma_ + 77 -> return SafeFlagTerminating_ + 78 -> return SafeFlagWithoutKFlagPrimEraseEquality_ + 79 -> return TerminationIssue_ + 80 -> return UnreachableClauses_ + 81 -> return UnsolvedConstraints_ + 82 -> return UnsolvedInteractionMetas_ + 83 -> return UnsolvedMetaVariables_ + 84 -> return UselessHiding_ + 85 -> return UselessInline_ + 86 -> return UselessPatternDeclarationForRecord_ + 87 -> return UselessPublic_ + 88 -> return UserWarning_ + 89 -> return WithoutKFlagPrimEraseEquality_ + 90 -> return WrongInstanceDeclaration_ + 91 -> return CoInfectiveImport_ + 92 -> return InfectiveImport_ + 93 -> return DuplicateFieldsWarning_ + 94 -> return TooManyFieldsWarning_ + 95 -> return OptionRenamed_ + _ -> malformed instance EmbPrj CutOff where diff --git a/src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs b/src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs --- a/src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs +++ b/src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs @@ -2,6 +2,9 @@ module Agda.TypeChecking.Serialise.Instances.Highlighting where +import qualified Data.Map.Strict as Map +import Data.Strict.Tuple (Pair(..)) + import qualified Agda.Interaction.Highlighting.Range as HR import qualified Agda.Interaction.Highlighting.Precise as HP import qualified Agda.Utils.RangeMap as RM @@ -115,15 +118,26 @@ value = valueN HP.DefinitionSite -instance EmbPrj a => EmbPrj (RM.PairInt a) where - icod_ (RM.PairInt a) = icodeN' RM.PairInt a - - value = valueN RM.PairInt - instance EmbPrj a => EmbPrj (RM.RangeMap a) where - icod_ (RM.RangeMap f) = icodeN' RM.RangeMap f + -- Write the RangeMap as flat list rather than a list of (Int, (Int, x)). Much + -- like Map, we need to call `convert' in the tail position and so the output + -- list is written (and read) in reverse order. + icod_ (RM.RangeMap f) = icodeNode =<< convert [] (Map.toAscList f) where + convert ys [] = return ys + convert ys ((start, RM.PairInt (end :!: entry)):xs) = do + start <- icode start + end <- icode end + entry <- icode entry + convert (start:end:entry:ys) xs - value = valueN RM.RangeMap + value = vcase (fmap (RM.RangeMap . Map.fromDistinctAscList) . convert []) where + convert ys [] = return ys + convert ys (start:end:entry:xs) = do + start <- value start + end <- value end + entry <- value entry + convert ((start, RM.PairInt (end :!: entry)):ys) xs + convert _ _ = malformed instance EmbPrj HP.TokenBased where icod_ HP.TokenBased = icodeN 0 () 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 @@ -21,7 +21,7 @@ import Agda.Utils.Impossible instance EmbPrj a => EmbPrj (Dom a) where - icod_ (Dom a b c d e) = icodeN' Dom a b c d e + icod_ (Dom a c d e f) = icodeN' Dom a c d e f value = valueN Dom @@ -102,13 +102,11 @@ icod_ (Def a b) = icodeN 3 Def a b icod_ (Con a b c) = icodeN 4 Con a b c icod_ (Pi a b) = icodeN 5 Pi a b + icod_ (MetaV a b) = icodeN 6 MetaV a b icod_ (Sort a ) = icodeN 7 Sort a - icod_ (MetaV a b) = __IMPOSSIBLE__ icod_ (DontCare a ) = icodeN 8 DontCare a icod_ (Level a ) = icodeN 9 Level a - icod_ (Dummy s _) = do - liftIO $ putStrLn $ "Dummy term in serialization: " ++ s - __IMPOSSIBLE__ + icod_ (Dummy a b) = icodeN 10 Dummy a b value = vcase valu where valu [a] = valuN var a @@ -118,9 +116,11 @@ valu [3, a, b] = valuN Def a b valu [4, a, b, c] = valuN Con a b c valu [5, a, b] = valuN Pi a b + valu [6, a, b] = valuN MetaV a b valu [7, a] = valuN Sort a valu [8, a] = valuN DontCare a valu [9, a] = valuN Level a + valu [10, a, b] = valuN Dummy a b valu _ = malformed instance EmbPrj Level where @@ -149,13 +149,12 @@ icod_ (PiSort a b c) = icodeN 4 PiSort a b c icod_ (FunSort a b) = icodeN 5 FunSort a b icod_ (UnivSort a) = icodeN 6 UnivSort a - icod_ (MetaS a b) = __IMPOSSIBLE__ icod_ (DefS a b) = icodeN 7 DefS a b icod_ (SSet a ) = icodeN 8 SSet a icod_ LockUniv = icodeN 9 LockUniv - icod_ (DummyS s) = do - liftIO $ putStrLn $ "Dummy sort in serialization: " ++ s - __IMPOSSIBLE__ + icod_ IntervalUniv = icodeN 10 IntervalUniv + icod_ (MetaS a b) = icodeN 11 MetaS a b + icod_ (DummyS s) = icodeN 12 DummyS s value = vcase valu where valu [0, a] = valuN Type a @@ -168,6 +167,9 @@ valu [7, a, b] = valuN DefS a b valu [8, a] = valuN SSet a valu [9] = valuN LockUniv + valu [10] = valuN IntervalUniv + valu [11, a, b] = valuN MetaS a b + valu [12, s] = valuN DummyS s valu _ = malformed instance EmbPrj DisplayForm where @@ -217,14 +219,14 @@ icod_ (StuckOn a) = icodeN 0 StuckOn a icod_ Underapplied = icodeN 1 Underapplied icod_ AbsurdMatch = icodeN 2 AbsurdMatch - icod_ MissingClauses = icodeN 3 MissingClauses + icod_ (MissingClauses a) = icodeN 3 MissingClauses a value = vcase valu where valu [] = valuN ReallyNotBlocked valu [0, a] = valuN StuckOn a valu [1] = valuN Underapplied valu [2] = valuN AbsurdMatch - valu [3] = valuN MissingClauses + valu [3, a] = valuN MissingClauses a valu _ = malformed instance EmbPrj Blocked_ where @@ -262,7 +264,9 @@ icod_ (PProp a) = icodeN 1 PProp a icod_ (PInf f a) = icodeN 2 PInf f a icod_ PSizeUniv = icodeN 3 PSizeUniv - icod_ PLockUniv = icodeN 4 PSizeUniv + icod_ PLockUniv = icodeN 4 PLockUniv + icod_ PIntervalUniv = icodeN 5 PIntervalUniv + icod_ (PSSet a) = icodeN 6 PSSet a value = vcase valu where valu [0, a] = valuN PType a @@ -270,6 +274,8 @@ valu [2, f, a] = valuN PInf f a valu [3] = valuN PSizeUniv valu [4] = valuN PLockUniv + valu [5] = valuN PIntervalUniv + valu [6, a] = valuN PSSet a valu _ = malformed instance EmbPrj RewriteRule where @@ -361,13 +367,13 @@ valu [1,a] = valuN Inferred a valu _ = malformed +instance EmbPrj ProjectionLikenessMissing + instance EmbPrj Defn where icod_ (Axiom a) = icodeN 0 Axiom a - icod_ (Function a b s t (_:_) c d e f g h i j k) = __IMPOSSIBLE__ - icod_ (Function a b s t [] c d e f g h i j k) = - icodeN 1 (\ a b s -> Function a b s t []) a b s c d e f g h i j k - icod_ (Datatype a b c d e f g h) = icodeN 2 Datatype a b c d e f g h - icod_ (Record a b c d e f g h i j k l) = icodeN 3 Record a b c d e f g h i j k l + icod_ (Function a b s t u c d e f g h i j k l) = icodeN 1 (\ a b s -> Function a b s t) a b s u c d e f g h i j k l + 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) = icodeN 4 Constructor a b c d e f g h i j icod_ (Primitive a b c d e) = icodeN 5 Primitive a b c d e icod_ (PrimitiveSort a b) = icodeN 6 PrimitiveSort a b @@ -376,15 +382,15 @@ icod_ DataOrRecSig{} = __IMPOSSIBLE__ value = vcase valu where - valu [0, a] = valuN Axiom a - valu [1, a, b, s, c, d, e, f, g, h, i, j, k] = valuN (\ a b s -> Function a b s Nothing []) a b s c d e f g h i j k - valu [2, a, b, c, d, e, f, g, h] = valuN Datatype a b c d e f g h - valu [3, a, b, c, d, e, f, g, h, i, j, k, l] = valuN Record a b c d e f g h i j k l - valu [4, a, b, c, d, e, f, g, h, i, j] = valuN Constructor a b c d e f g h i j - valu [5, a, b, c, d, e] = valuN Primitive a b c d e - valu [6, a, b] = valuN PrimitiveSort a b - valu [7] = valuN GeneralizableVar - valu _ = malformed + valu [0, a] = valuN Axiom a + valu [1, a, b, s, u, c, d, e, f, g, h, i, j, k, l] = valuN (\ a b s -> Function a b s Nothing) a b s u c d e f g h i j k l + 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] = valuN Constructor a b c d e f g h i j + valu [5, a, b, c, d, e] = valuN Primitive a b c d e + valu [6, a, b] = valuN PrimitiveSort a b + valu [7] = valuN GeneralizableVar + valu _ = malformed instance EmbPrj LazySplit where icod_ StrictSplit = icodeN' StrictSplit @@ -472,7 +478,7 @@ valu _ = malformed instance EmbPrj I.Clause where - icod_ (Clause a b c d e f g h i j k) = icodeN' Clause a b c d e f g h i j k + icod_ (Clause a b c d e f g h i j k l) = icodeN' Clause a b c d e f g h i j k l value = valueN Clause @@ -536,25 +542,55 @@ instance EmbPrj a => EmbPrj (Builtin a) where icod_ (Prim a) = icodeN' Prim a icod_ (Builtin a) = icodeN 1 Builtin a + icod_ (BuiltinRewriteRelations a) = icodeN 2 BuiltinRewriteRelations a value = vcase valu where valu [a] = valuN Prim a valu [1, a] = valuN Builtin a + valu [2, a] = valuN BuiltinRewriteRelations a valu _ = malformed instance EmbPrj a => EmbPrj (Substitution' a) where - icod_ IdS = icodeN' IdS - icod_ (EmptyS a) = icodeN 1 EmptyS a - icod_ (a :# b) = icodeN 2 (:#) a b - icod_ (Strengthen a b) = icodeN 3 Strengthen a b - icod_ (Wk a b) = icodeN 4 Wk a b - icod_ (Lift a b) = icodeN 5 Lift a b + icod_ IdS = icodeN' IdS + icod_ (EmptyS a) = icodeN' EmptyS a + icod_ (a :# b) = icodeN' (:#) a b + icod_ (Strengthen a b c) = icodeN 0 Strengthen a b c + icod_ (Wk a b) = icodeN 1 Wk a b + icod_ (Lift a b) = icodeN 2 Lift a b value = vcase valu where - valu [] = valuN IdS - valu [1, a] = valuN EmptyS a - valu [2, a, b] = valuN (:#) a b - valu [3, a, b] = valuN Strengthen a b - valu [4, a, b] = valuN Wk a b - valu [5, a, b] = valuN Lift a b + valu [] = valuN IdS + valu [a] = valuN EmptyS a + valu [a, b] = valuN (:#) a b + valu [0, a, b, c] = valuN Strengthen a b c + valu [1, a, b] = valuN Wk a b + valu [2, a, b] = valuN Lift a b + valu _ = malformed + +instance EmbPrj Instantiation where + icod_ (Instantiation a b) = icodeN' Instantiation a b + value = valueN Instantiation + +instance EmbPrj Comparison where + icod_ CmpEq = icodeN' CmpEq + icod_ CmpLeq = icodeN 0 CmpLeq + + value = vcase valu + where + valu [] = valuN CmpEq + valu [0] = valuN CmpLeq + valu _ = malformed + +instance EmbPrj a => EmbPrj (Judgement a) where + icod_ (HasType a b c) = icodeN' HasType a b c + icod_ (IsSort a b) = icodeN' IsSort a b + + value = vcase valu + where + valu [a, b, c] = valuN HasType a b c + valu [a, b] = valuN IsSort a b valu _ = malformed + +instance EmbPrj RemoteMetaVariable where + icod_ (RemoteMetaVariable a b c) = icodeN' RemoteMetaVariable a b c + value = valueN RemoteMetaVariable 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 @@ -4,13 +4,11 @@ import Prelude hiding (null) -import Control.Monad import Control.Monad.Except ( MonadError(..) ) import Control.Monad.Writer ( MonadWriter(..), WriterT(..), runWriterT ) import qualified Data.Foldable as Fold import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) @@ -32,10 +30,12 @@ import Agda.Utils.Functor import Agda.Utils.List as List +import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty (Pretty, prettyShow) +import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple @@ -316,6 +316,7 @@ nest 2 $ sep [ pretty u <+> prettyTCM cmp , pretty v ] + whenProfile Profile.Conversion $ tick "compare sizes" us <- sizeMaxView u vs <- sizeMaxView v compareMaxViews cmp us vs @@ -397,10 +398,11 @@ giveUp :: (MonadConversion m) => Comparison -> Type -> Term -> Term -> m () giveUp cmp size u v = ifM (asksTC envAssignMetas) - {-then-} (addConstraint unblock $ ValueCmp CmpLeq AsSizes u v) + {-then-} (do + -- TODO: compute proper blocker + unblock <- unblockOnAnyMetaIn <$> instantiateFull [u, v] + addConstraint unblock $ ValueCmp CmpLeq AsSizes u v) {-else-} (typeError $ UnequalTerms cmp u v AsSizes) - where - unblock = unblockOnAnyMetaIn [u, v] -- | Checked whether a size constraint is trivial (like @X <= X+1@). trivial :: (MonadConversion m) => Term -> Term -> m Bool @@ -464,7 +466,7 @@ getOpenMetas >>= do mapM $ \ m -> do let no = return Nothing - mi <- lookupMeta m + mi <- lookupLocalMeta m case mvJudgement mi of _ | BlockedConst{} <- mvInstantiation mi -> no -- Blocked terms should not be touched (#2637, #2881) HasType _ cmp a -> do @@ -517,7 +519,7 @@ deriving (Eq, Show) instance Pretty OldSizeExpr where - pretty (SizeMeta m _) = P.text $ "X" ++ show (fromIntegral m :: Int) + pretty (SizeMeta m _) = P.text "X" <> P.pretty m pretty (Rigid i) = P.text $ "c" ++ show i -- | Size constraints we can solve. @@ -629,109 +631,3 @@ return $ Leq (SizeMeta m xs') n (SizeMeta l [0..size ys-1]) -- give up | otherwise -> Nothing - --- | Main function. --- Uses the old solver for size constraints using "Agda.Utils.Warshall". --- This solver does not smartly use size hypotheses @j : Size< i@. --- It only checks that its computed solution is compatible -oldSolveSizeConstraints :: TCM () -oldSolveSizeConstraints = whenM haveSizedTypes $ do - reportSLn "tc.size.solve" 70 $ "Considering to solve size constraints" - cs0 <- getSizeConstraints (== CmpLeq) - cs <- oldComputeSizeConstraints cs0 - ms <- getSizeMetas True -- get all size metas, also interaction metas - - when (not (null cs) || not (null ms)) $ do - reportSLn "tc.size.solve" 10 $ "Solving size constraints " ++ show cs - - cs <- return $ mapMaybe oldCanonicalizeSizeConstraint cs - reportSLn "tc.size.solve" 10 $ "Canonicalized constraints: " ++ show cs - - let -- Error for giving up - cannotSolve = typeError . GenericDocError =<< - vcat ("Cannot solve size constraints" : map prettyTCM cs0) - - -- Size metas in constraints. - metas0 :: [(MetaId, Int)] -- meta id + arity - metas0 = List.nubOn id $ map (mapSnd length) $ concatMap flexibleVariables cs - - -- Unconstrained size metas that do not occur in constraints. - metas1 :: [(MetaId, Int)] - metas1 = forMaybe ms $ \ (m, _, tel) -> - maybe (Just (m, size tel)) (const Nothing) $ - lookup m metas0 - - -- All size metas - metas = metas0 ++ metas1 - - reportSLn "tc.size.solve" 15 $ "Metas: " ++ show metas0 ++ ", " ++ show metas1 - - verboseS "tc.size.solve" 20 $ - -- debug print the type of all size metas - forM_ metas $ \ (m, _) -> - reportSDoc "tc.size.solve" 20 $ prettyTCM =<< mvJudgement <$> lookupMeta m - - -- Run the solver. - unlessM (oldSolver metas cs) cannotSolve - - -- Double-checking the solution. - - -- Andreas, 2012-09-19 - -- The returned solution might not be consistent with - -- the hypotheses on rigid vars (j : Size< i). - -- Thus, we double check that all size constraints - -- have been solved correctly. - flip catchError (const cannotSolve) $ - noConstraints $ - forM_ cs0 $ withConstraint solveConstraint - - --- | Old solver for size constraints using "Agda.Utils.Warshall". --- This solver does not smartly use size hypotheses @j : Size< i@. -oldSolver - :: [(MetaId, Int)] -- ^ Size metas and their arity. - -> [OldSizeConstraint] -- ^ Size constraints (in preprocessed form). - -> TCM Bool -- ^ Returns @False@ if solver fails. -oldSolver metas cs = do - let cannotSolve = return False - mkFlex (m, ar) = W.NewFlex (fromIntegral m) $ \ i -> fromIntegral i < ar - mkConstr (Leq a n b) = W.Arc (mkNode a) n (mkNode b) - mkNode (Rigid i) = W.Rigid $ W.RVar i - mkNode (SizeMeta m _) = W.Flex $ fromIntegral m - - -- run the Warshall solver - case W.solve $ map mkFlex metas ++ map mkConstr cs of - Nothing -> cannotSolve - Just sol -> do - reportSLn "tc.size.solve" 10 $ "Solved constraints: " ++ prettyShow sol - suc <- primSizeSuc - infty <- primSizeInf - let plus v 0 = v - plus v n = suc `apply1` plus v (n - 1) - - inst (i, e) = do - - let m = fromIntegral i -- meta variable identifier - ar = fromMaybe __IMPOSSIBLE__ $ lookup m metas -- meta var arity - - term (W.SizeConst W.Infinite) = infty - term (W.SizeVar j n) | j < ar = plus (var $ ar - j - 1) n - term _ = __IMPOSSIBLE__ - - tel = replicate ar $ defaultArg "s" - -- convert size expression to term - v = term e - - reportSDoc "tc.size.solve" 20 $ sep - [ pretty m <+> ":=" - , nest 2 $ prettyTCM v - ] - - -- Andreas, 2012-09-25: do not assign interaction metas to \infty - let isInf (W.SizeConst W.Infinite) = True - isInf _ = False - unlessM (((isInf e &&) . isJust <$> isInteractionMeta m) `or2M` isFrozen m) $ - assignTerm m tel v - - mapM_ inst $ Map.toList sol - return True 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 @@ -57,7 +57,8 @@ import Data.Either import Data.Foldable (forM_) import qualified Data.Foldable as Fold -import Data.Function +import Data.Function (on) +import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Monoid import qualified Data.Map as Map @@ -137,7 +138,7 @@ -- @allMetas@ does not reduce or instantiate; -- this is why we require the size constraints to be normalised. - return (cl, map metaId . Set.toList $ + return (cl, Set.toList $ sizeMetaSet `Set.intersection` allMetas singleton c) -- Now, some constraints may have no metas (clcs), the others have at least one (othercs). @@ -303,7 +304,10 @@ where raiseMaybe n c = do -- Fine if we have to weaken or strengthening is safe. - guard $ n >= 0 || List.all (>= -n) (VarSet.toList $ allFreeVars c) + guard $ + n >= 0 || + -- Are all free variables at least -n? + IntSet.null (fst $ IntSet.split (-n) $ allFreeVars c) return $ raise n c @@ -368,7 +372,7 @@ -- 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 (metaId . sizeMetaId) $ Set.toList $ flexs c + fmap (p,) $ nonEmpty $ map sizeMetaId $ Set.toList $ flexs c -- @css@ are the clusters of constraints. css :: [List1 (CC,HypSizeConstraint)] css = cluster' csMs @@ -390,7 +394,7 @@ let err reason = typeError . GenericDocError =<< do vcat $ [ text $ "Cannot solve size constraints" ] ++ prettyCs ++ - [ text $ "Reason: " ++ reason ] + [ "Reason:" <+> reason ] reportSDoc "tc.size.solve" 20 $ vcat $ "Solving constraint cluster" : prettyCs -- Find the super context of all contexts. @@ -465,11 +469,11 @@ -- Convert size metas to flexible vars. let metas :: [SizeMeta] metas = concatMap (foldMap (:[])) csC - csF :: [Size.Constraint' NamedRigid Int] - csF = map (fmap (metaId . sizeMetaId)) csC + csF :: [Size.Constraint' NamedRigid MetaId] + csF = map (fmap sizeMetaId) csC -- Construct the hypotheses graph. - let hyps = map (fmap (metaId . sizeMetaId)) hs + let hyps = map (fmap sizeMetaId) hs -- There cannot be negative cycles in hypotheses graph due to scoping. let hg = either __IMPOSSIBLE__ id $ hypGraph (rigids csF) hyps @@ -487,7 +491,7 @@ -- Andreas, 2016-07-13, issue 2096. -- Running the solver once might result in unsolvable left-over constraints. -- We need to iterate the solver to detect this. - sol :: Solution NamedRigid Int <- either err return $ + sol :: Solution NamedRigid MetaId <- either err return $ iterateSolver Map.empty hg csF emptySolution -- Convert solution to meta instantiation. @@ -495,29 +499,28 @@ unless (validOffset a) __IMPOSSIBLE__ -- Solution does not contain metas u <- unSizeExpr $ fmap __IMPOSSIBLE__ a - let x = MetaId m let SizeMeta _ xs = fromMaybe __IMPOSSIBLE__ $ - List.find ((m==) . metaId . sizeMetaId) metas + List.find ((m==) . sizeMetaId) metas -- Check that solution is well-scoped let ys = rigidIndex <$> Set.toList (rigids a) ok = all (`elem` xs) ys -- TODO: more efficient -- unless ok $ err "ill-scoped solution for size meta variable" u <- if ok then return u else primSizeInf - t <- getMetaType x + t <- getMetaType m reportSDoc "tc.size.solve" 20 $ unsafeModifyContext (const gamma) $ do let args = map (Apply . defaultArg . var) xs - "solution " <+> prettyTCM (MetaV x args) <+> " := " <+> prettyTCM u + "solution " <+> prettyTCM (MetaV m args) <+> " := " <+> prettyTCM u reportSDoc "tc.size.solve" 60 $ vcat [ text $ " xs = " ++ show xs , text $ " u = " ++ show u ] - ifM (isFrozen x `or2M` (not <$> asksTC envAssignMetas)) (return Set.empty) $ do - assignMeta n x t xs u - return $ Set.singleton x + ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (return Set.empty) $ do + assignMeta n m t xs u + return $ Set.singleton m -- WRONG: -- let partialSubst = List.sort $ zip xs $ map var $ downFrom n - -- assignMeta' n x t (length xs) partialSubst u - -- WRONG: assign DirEq x (map (defaultArg . var) xs) u + -- assignMeta' n m t (length xs) partialSubst u + -- WRONG: assign DirEq m (map (defaultArg . var) xs) u -- Possibly set remaining size metas to ∞ (issue 1862) -- unless we have an interaction meta in the cluster (issue 2095). 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 @@ -11,6 +11,8 @@ 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.TypeChecking.SizedTypes.Utils import Agda.Utils.Functor @@ -58,6 +60,9 @@ 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@. @@ -170,14 +175,19 @@ 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 String [Constraint' r f] +type CTrans r f = Constraint' r f -> Either Error [Constraint' r f] -- | Returns an error message if we have a contradictory constraint. simplify1 :: (Pretty f, Pretty r, Eq r) => CTrans r f -> CTrans r f simplify1 test c = do - let err = Left $ "size constraint " ++ prettyShow c ++ " is inconsistent" + let err = Left $ "size constraint" P.<+> P.pretty c P.<+> + "is inconsistent" case c of -- rhs is Infty Constraint a Le Infty -> return [] 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 @@ -14,6 +14,8 @@ import Data.Map (Map) import qualified Data.Map as Map +import Agda.TypeChecking.Pretty (PrettyTCM) +import qualified Agda.TypeChecking.Pretty as P import Agda.TypeChecking.SizedTypes.Syntax import Agda.TypeChecking.SizedTypes.Utils @@ -428,7 +430,7 @@ type HypGraph r f = Graph r f Label hypGraph :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => - Set rigid -> [Hyp' rigid flex] -> Either String (HypGraph rigid flex) + Set rigid -> [Hyp' rigid flex] -> Either Error (HypGraph rigid flex) hypGraph is hyps0 = do -- get a list of hypothesis from a list of constraints hyps <- concat <$> mapM (simplify1 $ \ c -> return [c]) hyps0 @@ -446,8 +448,10 @@ | Just l <- lookupEdge hg n1 n2 = l | otherwise = top -simplifyWithHypotheses :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => - HypGraph rigid flex -> [Constraint' rigid flex] -> Either String [Constraint' rigid flex] +simplifyWithHypotheses :: + (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => + HypGraph rigid flex -> [Constraint' rigid flex] -> + Either Error [Constraint' rigid flex] simplifyWithHypotheses hg cons = concat <$> mapM (simplify1 test) cons where -- Test whether a constraint is compatible with the hypotheses: @@ -458,7 +462,8 @@ l' = hypConn hg n1 n2 -- l' <- lookupEdge hg n1 n2 unless (l' <= l) $ Left $ - "size constraint " ++ prettyShow c ++ " not consistent with size hypotheses" + "size constraint" P.<+> P.pretty c P.<+> + "not consistent with size hypotheses" return [c] -- if (l' <= l) then Just [c] else Nothing @@ -467,7 +472,9 @@ type ConGraph r f = Graph r f Label -constraintGraph :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either String (ConGraph r f) +constraintGraph :: + (Ord r, Ord f, Pretty r, Pretty f) => + [Constraint' r f] -> HypGraph r f -> Either Error (ConGraph r f) constraintGraph cons0 hg = do traceM $ "original constraints cons0 = " ++ prettyShow cons0 -- Simplify constraints, ensure they are locally consistent with @@ -487,7 +494,9 @@ type ConGraphs r f = Graphs r f Label -constraintGraphs :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either String ([f], ConGraphs r f) +constraintGraphs :: + (Ord r, Ord f, Pretty r, Pretty f) => + [Constraint' r f] -> HypGraph r f -> Either Error ([f], ConGraphs r f) constraintGraphs cons0 hg = do traceM $ "original constraints cons0 = " ++ prettyShow cons0 -- Simplify constraints, ensure they are locally consistent with @@ -858,11 +867,11 @@ solveGraph - :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) + :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraph r f - -> Either String (Solution r f) + -> Either Error (Solution r f) solveGraph pols hg g = do let (Bounds lbs ubs fs) = bounds g -- flexibles to solve for @@ -881,8 +890,9 @@ [] -> return $ Nothing (a:as) -> do case foldM (lub hg) a as of - Nothing -> Left $ "inconsistent lower bound for " ++ prettyShow x Just l -> return $ Just $ truncateOffset l + Nothing -> Left $ + "inconsistent lower bound for" P.<+> P.prettyTCM x -- compute minimum of upper bounds ub <- do case ux of @@ -891,7 +901,8 @@ case foldM (glb hg) a as of Just l | validOffset l -> return $ Just l | Just l' <- findRigidBelow hg l -> return $ Just l' - _ -> Left $ "inconsistent upper bound for " ++ prettyShow x + _ -> Left $ + "inconsistent upper bound for" P.<+> P.prettyTCM x case (lb, ub) of (Just l, Nothing) -> return $ Just l -- solve x = lower bound (Nothing, Just u) -> return $ Just u -- solve x = upper bound @@ -907,11 +918,11 @@ -- | Solve a forest of constraint graphs relative to a hypotheses graph. -- Concatenate individual solutions. solveGraphs - :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) + :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraphs r f - -> Either String (Solution r f) + -> Either Error (Solution r f) solveGraphs pols hg gs = Solution . Map.unions <$> mapM (theSolution <.> solveGraph pols hg) gs @@ -924,7 +935,7 @@ => HypGraph r f -> [Constraint' r f] -> Solution r f - -> Either String () + -> Either Error () verifySolution hg cs sol = do cs <- return $ subst sol cs traceM $ "substituted constraints " ++ prettyShow cs @@ -949,7 +960,7 @@ -- which would otherwise go unnoticed. iterateSolver - :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) + :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) => Polarities f -- ^ Meta variable polarities (prefer lower or upper solution?). -> HypGraph r f @@ -958,7 +969,7 @@ -- ^ Constraints to solve. -> Solution r f -- ^ Previous substitution (already applied to constraints). - -> Either String (Solution r f) + -> Either Error (Solution r f) -- ^ Accumulated substition. iterateSolver pols hg cs sol0 = do diff --git a/src/full/Agda/TypeChecking/Sort.hs b/src/full/Agda/TypeChecking/Sort.hs --- a/src/full/Agda/TypeChecking/Sort.hs +++ b/src/full/Agda/TypeChecking/Sort.hs @@ -64,8 +64,8 @@ inferUnivSort s = do s <- reduce s case univSort' s of - Just s' -> return s' - Nothing -> do + Right s' -> return s' + Left _ -> do -- Jesper, 2020-04-19: With the addition of Setωᵢ and the PTS -- rule SizeUniv : Setω, every sort (with no metas) now has a -- bigger sort, so we do not need to add a constraint. @@ -165,7 +165,7 @@ :: forall m. (PureTCM m, MonadBlock m) => Term -> m Sort sortOf t = do - reportSDoc "tc.sort" 40 $ "sortOf" <+> prettyTCM t + reportSDoc "tc.sort" 60 $ "sortOf" <+> prettyTCM t sortOfT =<< elimView EvenLone t where @@ -175,7 +175,7 @@ let a = unEl $ unDom adom sa <- sortOf a sb <- mapAbstraction adom (sortOf . unEl) b - return $ piSort (unEl <$> adom) sa sb + inferPiSort (adom $> El sa a) sb Sort s -> return $ univSort s Var i es -> do a <- typeOfBV i 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 @@ -19,15 +19,17 @@ import Control.Arrow (first, second) import Control.Monad (guard) +import Control.Monad.Except (throwError) + import Data.Coerce -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Map (Map) +import qualified Data.Map.Strict as MapS import Data.Maybe import Data.HashMap.Strict (HashMap) import Debug.Trace (trace) -import Language.Haskell.TH.Syntax (thenCmp) -- lexicographic combination of Ordering import Agda.Interaction.Options @@ -46,6 +48,7 @@ import Agda.TypeChecking.Substitute.Class import Agda.TypeChecking.Substitute.DeBruijn +import Agda.Utils.Either import Agda.Utils.Empty import Agda.Utils.Functor import Agda.Utils.List @@ -79,7 +82,7 @@ case es of Apply a : es0 -> lazyAbsApp (coerce b :: Abs t) (coerce $ unArg a) `app` es0 IApply _ _ a : es0 -> lazyAbsApp (coerce b :: Abs t) (coerce a) `app` es0 - _ -> err __IMPOSSIBLE__ + _ -> err __IMPOSSIBLE__ MetaV x es' -> MetaV x (es' ++ es) Lit{} -> err __IMPOSSIBLE__ Level{} -> err __IMPOSSIBLE__ @@ -89,8 +92,8 @@ DontCare mv -> dontCare $ mv `app` es -- Andreas, 2011-10-02 -- need to go under DontCare, since "with" might resurrect irrelevant term where - app :: Coercible t x => x -> Elims -> Term - app t es = coerce $ (coerce t :: t) `applyE` es + app :: Coercible t a => a -> Elims -> Term + app u es = coerce $ (coerce u :: t) `applyE` es err e = err' e (coerce m) es instance Apply Term where @@ -99,12 +102,14 @@ instance Apply BraveTerm where applyE = applyTermE (\ _ t es -> Dummy "applyE" (Apply (defaultArg t) : es)) --- | If $v$ is a record value, @canProject f v@ +-- | If @v@ is a record or constructed value, @canProject f v@ -- returns its field @f@. canProject :: QName -> Term -> Maybe (Arg Term) canProject f v = case v of - (Con (ConHead _ IsRecord{} _ fs) _ vs) -> do + -- Andreas, 2022-06-10, issue #5922: also unfold data projections + -- (not just record projections). + (Con (ConHead _ _ _ fs) _ vs) -> do (fld, i) <- findWithIndex ((f==) . unArg) fs -- Jesper, 2019-10-17: dont unfold irrelevant projections guard $ not $ isIrrelevant fld @@ -115,10 +120,10 @@ -- | Eliminate a constructed term. conApp :: forall t. (Coercible t Term, Apply t) => (Empty -> Term -> Elims -> Term) -> ConHead -> ConInfo -> Elims -> Elims -> Term -conApp fk ch ci args [] = Con ch ci args -conApp fk ch ci args (a@Apply{} : es) = conApp @t fk ch ci (args ++ [a]) es -conApp fk ch ci args (a@IApply{} : es) = conApp @t fk ch ci (args ++ [a]) es -conApp fk ch@(ConHead c _ _ fs) ci args ees@(Proj o f : es) = +conApp fallback ch ci args [] = Con ch ci args +conApp fallback ch ci args (a@Apply{} : es) = conApp @t fallback ch ci (args ++ [a]) es +conApp fallback ch ci args (a@IApply{} : es) = conApp @t fallback ch ci (args ++ [a]) es +conApp fallback ch@(ConHead c _ _ fs) ci args ees@(Proj o f : es) = let failure :: forall a. a -> a failure err = flip trace err $ concat [ "conApp: constructor ", prettyShow c @@ -127,7 +132,7 @@ , " projected by ", prettyShow f ] isApply e = fromMaybe (failure __IMPOSSIBLE__) $ isApplyElim e - stuck err = fk err (Con ch ci args) [Proj o f] + stuck err = fallback err (Con ch ci args) [Proj o f] -- Recurse using the instance for 't', see @applyTermE@ app :: Term -> Elims -> Term app v es = coerce $ applyE (coerce v :: t) es @@ -303,7 +308,7 @@ AbstractDefn d -> AbstractDefn $ apply d args Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv , funExtLam = extLam - , funProjection = Nothing } -> + , funProjection = Left _ } -> d { funClauses = apply cs args , funCompiled = apply cc args , funCovering = apply cov args @@ -313,19 +318,19 @@ Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv , funExtLam = extLam - , funProjection = Just p0} -> + , funProjection = Right p0 } -> case p0 `apply` args of p@Projection{ projIndex = n } | n < 0 -> d { funProjection = __IMPOSSIBLE__ } -- TODO (#3123): we actually get here! -- case: applied only to parameters - | n > 0 -> d { funProjection = Just p } + | n > 0 -> d { funProjection = Right p } -- case: applied also to record value (n == 0) | otherwise -> d { funClauses = apply cs args' , funCompiled = apply cc args' , funCovering = apply cov args' , funInv = apply inv args' - , funProjection = if isVar0 then Just p{ projIndex = 0 } else Nothing + , funProjection = if isVar0 then Right p{ projIndex = 0 } else Left MaybeProjection , funExtLam = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam } where @@ -360,7 +365,7 @@ -- It is assumed that we only apply a clause to "parameters", i.e. -- arguments introduced by lambda lifting. The problem is that these aren't -- necessarily the first elements of the clause telescope. - apply cls@(Clause rl rf tel ps b t catchall exact recursive unreachable ell) args + apply cls@(Clause rl rf tel ps b t catchall exact recursive unreachable ell wm) args | length args > length ps = __IMPOSSIBLE__ | otherwise = Clause rl rf @@ -373,6 +378,7 @@ recursive unreachable ell + wm where -- We have -- Γ ⊢ args, for some outer context Γ @@ -443,13 +449,19 @@ IApplyP _ _ _ (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs newTel _ tel _ _ = __IMPOSSIBLE__ + projections :: ConHead -> Term -> [Term] projections c v = [ relToDontCare ai $ -- #4528: We might have bogus terms here when printing a clause that -- cannot be taken. To mitigate the problem we use a Def instead -- a Proj elim for data constructors, which at least stops conApp -- from crashing. See #4989 for not printing bogus terms at all. case conDataRecord c of - IsData -> Def f [Apply (Arg ai v)] + IsData -> defApp f [] [Apply (Arg ai v)] + -- Andreas, 2022-06-10, issue #5922. + -- This was @Def f [Apply (Arg ai v)]@, but are we sure + -- that @v@ isn't a matching @Con@? The testcase for + -- #5922 does not require this precaution, + -- but I sleep better this way... IsRecord{} -> applyE v [Proj ProjSystem f] | Arg ai f <- conFields c ] @@ -655,7 +667,7 @@ AbstractDefn d -> AbstractDefn $ abstract tel d Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv , funExtLam = extLam - , funProjection = Nothing } -> + , funProjection = Left _ } -> d { funClauses = abstract tel cs , funCompiled = abstract tel cc , funCovering = abstract tel cov @@ -664,19 +676,22 @@ } Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv , funExtLam = extLam - , funProjection = Just p } -> + , funProjection = Right p } -> -- Andreas, 2015-05-11 if projection was applied to Var 0 -- then abstract over last element of tel (the others are params). - if projIndex p > 0 then d' else - d' { funClauses = map (abstractClause tel1) cs - , funCompiled = abstract tel1 cc - , funCovering = abstract tel1 cov - , funInv = abstract tel1 inv - , funExtLam = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam - } + if projIndex p > 0 then + d { funProjection = Right $ abstract tel p + , funClauses = map (abstractClause EmptyTel) cs + } + else + d { funProjection = Right $ abstract tel p + , funClauses = map (abstractClause tel1) cs + , funCompiled = abstract tel1 cc + , funCovering = abstract tel1 cov + , funInv = abstract tel1 inv + , funExtLam = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam + } where - d' = d { funProjection = Just $ abstract tel p - , funClauses = map (abstractClause EmptyTel) cs } tel1 = telFromList $ drop (size tel - 1) $ telToList tel -- #5128: clause telescopes should be abstracted over the full telescope, regardless of -- projection shenanigans. @@ -702,7 +717,7 @@ where n = size tel instance Abstract Clause where - abstract tel (Clause rl rf tel' ps b t catchall exact recursive unreachable ell) = + abstract tel (Clause rl rf tel' ps b t catchall exact recursive unreachable ell wm) = Clause rl rf (abstract tel tel') (namedTelVars m tel ++ ps) b @@ -712,6 +727,7 @@ recursive unreachable ell + wm where m = size tel + size tel' instance Abstract CompiledClauses where @@ -777,8 +793,28 @@ -- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renamingR π) : Term Δ -> Term Γ@ renamingR :: DeBruijn a => Permutation -> Substitution' a -renamingR p@(Perm n _) = permute (reverseP p) (map deBruijnVar [0..]) ++# raiseS n +renamingR p@(Perm n is) = xs ++# raiseS n + where + xs = map (\i -> deBruijnVar (n - 1 - i)) (reverse is) + -- The list xs used to be defined in the following way: + -- + -- permute (reverseP p) (map deBruijnVar [0..]) + -- + -- We have that + -- + -- permute (reverseP p) (map deBruijnVar [0..]) + -- = permute (Perm n $ map ((n - 1) -) $ reverse is) + -- (map deBruijnVar [0..]) + -- = map (map deBruijnVar [0..] !!) + -- (map ((n - 1) -) $ reverse is) + -- = map deBruijnVar (map ((n - 1) -) $ reverse is) + -- = map (\i -> deBruijnVar (n - 1 - i)) (reverse is). + -- + -- The latter code is linear in the length of is (if deBruijnVar + -- takes constant time), while the time complexity of the former + -- code depends on the value of the largest index in is. + -- | The permutation should permute the corresponding context. (right-to-left list) renameP :: Subst a => Impossible -> Permutation -> a -> a renameP err p = applySubst (renaming err p) @@ -832,6 +868,7 @@ SSet n -> SSet $ sub n SizeUniv -> SizeUniv LockUniv -> LockUniv + IntervalUniv -> IntervalUniv PiSort a s1 s2 -> coerce $ piSort (coerce $ sub a) (coerce $ sub s1) (coerce $ sub s2) FunSort s1 s2 -> coerce $ funSort (coerce $ sub s1) (coerce $ sub s2) UnivSort s -> coerce $ univSort $ coerce $ sub s @@ -937,9 +974,11 @@ applySubst rho = \case PType l -> PType $ applySubst rho l PProp l -> PProp $ applySubst rho l + PSSet l -> PSSet $ applySubst rho l PInf f n -> PInf f n PSizeUniv -> PSizeUniv PLockUniv -> PLockUniv + PIntervalUniv -> PIntervalUniv instance Subst RewriteRule where type SubstArg RewriteRule = NLPat @@ -992,9 +1031,10 @@ HasPTSRule a s -> HasPTSRule (rf a) (rf s) CheckLockedVars a b c d -> CheckLockedVars (rf a) (rf b) (rf c) (rf d) UnquoteTactic t h g -> UnquoteTactic (rf t) (rf h) (rf g) + CheckDataSort q s -> CheckDataSort q (rf s) CheckMetaInst m -> CheckMetaInst m CheckType t -> CheckType (rf t) - UsableAtModality mod m -> UsableAtModality mod (rf m) + UsableAtModality cc ms mod m -> UsableAtModality cc (rf ms) mod (rf m) where rf :: forall a. TermSubst a => a -> a rf x = applySubst rho x @@ -1072,11 +1112,14 @@ instance Subst EqualityView where type SubstArg EqualityView = Term - applySubst rho (OtherType t) = OtherType - (applySubst rho t) - applySubst rho (IdiomType t) = IdiomType - (applySubst rho t) - applySubst rho (EqualityType s eq l t a b) = EqualityType + applySubst rho = \case + OtherType t -> OtherType $ applySubst rho t + IdiomType t -> IdiomType $ applySubst rho t + EqualityViewType eqt -> EqualityViewType $ applySubst rho eqt + +instance Subst EqualityTypeData where + type SubstArg EqualityTypeData = Term + applySubst rho (EqualityTypeData s eq l t a b) = EqualityTypeData (applySubst rho s) eq (map (applySubst rho) l) @@ -1198,10 +1241,12 @@ telView'UpTo n t = case unEl t of Pi a b -> absV a (absName b) $ telView'UpTo (n - 1) (absBody b) _ -> TelV EmptyTel t - where - absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t +-- | Add given binding to the front of the telescope. +absV :: Dom a -> ArgName -> TelV a -> TelV a +absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t + -- ** Creating telescopes from lists of types -- | Turn a typed binding @(x1 .. xn : A)@ into a telescope. @@ -1403,7 +1448,8 @@ _ == _ = False instance Ord Term where - Var a b `compare` Var x y = compare x a `thenCmp` compare b y -- sort de Bruijn indices down (#2765) + Var a b `compare` Var x y = compare (x, b) (a, y) + -- sort de Bruijn indices down (#2765) Var{} `compare` _ = LT _ `compare` Var{} = GT Def a b `compare` Def x y = compare (a, b) (x, y) @@ -1492,17 +1538,23 @@ -- known (i.e. it is not just @UnivSort s@). -- -- Precondition: @s@ is reduced -univSort' :: Sort -> Maybe Sort -univSort' (Type l) = Just $ Type $ levelSuc l -univSort' (Prop l) = Just $ Type $ levelSuc l -univSort' (Inf f n) = Just $ Inf f $ 1 + n -univSort' (SSet l) = Just $ SSet $ levelSuc l -univSort' SizeUniv = Just $ Inf IsFibrant 0 -univSort' LockUniv = Just $ Inf IsFibrant 0 -- lock polymorphism is not actually supported -univSort' s = Nothing +univSort' :: Sort -> Either Blocker Sort +univSort' (Type l) = Right $ Type $ levelSuc l +univSort' (Prop l) = Right $ Type $ levelSuc l +univSort' (Inf f n) = Right $ Inf f $ 1 + n +univSort' (SSet l) = Right $ SSet $ levelSuc l +univSort' SizeUniv = Right $ Inf IsFibrant 0 +univSort' LockUniv = Right $ Inf IsFibrant 0 -- lock polymorphism is not actually supported +univSort' IntervalUniv = Right $ SSet $ ClosedLevel 1 +univSort' (MetaS m _) = Left neverUnblock +univSort' FunSort{} = Left neverUnblock +univSort' PiSort{} = Left neverUnblock +univSort' UnivSort{} = Left neverUnblock +univSort' DefS{} = Left neverUnblock +univSort' DummyS{} = Left neverUnblock univSort :: Sort -> Sort -univSort s = fromMaybe (UnivSort s) $ univSort' s +univSort s = fromRight (const $ UnivSort s) $ univSort' s sort :: Sort -> Type sort s = El (univSort s) $ Sort s @@ -1510,24 +1562,34 @@ ssort :: Level -> Type ssort l = sort (SSet l) --- | Returns @Nothing@ for unknown (meta) sorts, and otherwise returns --- @Just (b,f)@ where @b@ indicates smallness and @f@ fibrancy. --- I.e., @b@ is @True@ for (relatively) small sorts like @Set l@ and --- @Prop l@, and instead @b@ is @False@ for large sorts such as @Setω@. -isSmallSort :: Sort -> Maybe (Bool,IsFibrant) -isSmallSort Type{} = Just (True,IsFibrant) -isSmallSort Prop{} = Just (True,IsFibrant) -isSmallSort SizeUniv = Just (True,IsFibrant) -isSmallSort LockUniv = Just (True,IsFibrant) -isSmallSort (Inf f _) = Just (False,f) -isSmallSort SSet{} = Just (True,IsStrict) -isSmallSort MetaS{} = Nothing -isSmallSort FunSort{} = Nothing -isSmallSort PiSort{} = Nothing -isSmallSort UnivSort{} = Nothing -isSmallSort DefS{} = Nothing -isSmallSort DummyS{} = Nothing +-- | A sort can either be small (Set l, Prop l, Size, ...) or large +-- (Setω n). +data SizeOfSort + = SmallSort IsFibrant + | LargeSort IsFibrant Integer +-- | Returns @Left blocker@ for unknown (blocked) sorts, and otherwise +-- returns @Right s@ where @s@ indicates the size and fibrancy. +sizeOfSort :: Sort -> Either Blocker SizeOfSort +sizeOfSort Type{} = Right $ SmallSort IsFibrant +sizeOfSort Prop{} = Right $ SmallSort IsFibrant +sizeOfSort SizeUniv = Right $ SmallSort IsFibrant +sizeOfSort LockUniv = Right $ SmallSort IsFibrant +sizeOfSort IntervalUniv = Right $ SmallSort IsStrict +sizeOfSort (Inf f n) = Right $ LargeSort f n +sizeOfSort SSet{} = Right $ SmallSort IsStrict +sizeOfSort (MetaS m _) = Left $ unblockOnMeta m +sizeOfSort FunSort{} = Left neverUnblock +sizeOfSort PiSort{} = Left neverUnblock +sizeOfSort UnivSort{} = Left neverUnblock +sizeOfSort DefS{} = Left neverUnblock +sizeOfSort DummyS{} = Left neverUnblock + +isSmallSort :: Sort -> Bool +isSmallSort s = case sizeOfSort s of + Right SmallSort{} -> True + _ -> False + fibrantLub :: IsFibrant -> IsFibrant -> IsFibrant fibrantLub IsStrict a = IsStrict fibrantLub a IsStrict = IsStrict @@ -1535,41 +1597,71 @@ -- | Compute the sort of a function type from the sorts of its -- domain and codomain. -funSort' :: Sort -> Sort -> Maybe Sort +funSort' :: Sort -> Sort -> Either Blocker Sort funSort' a b = case (a, b) of - (Inf af m , Inf bf n ) -> Just $ Inf (fibrantLub af bf) $ max m n - (Inf af m , b ) | Just (True,bf) <- isSmallSort b -> Just $ Inf (fibrantLub af bf) m - (a , Inf bf n ) | Just (True,af) <- isSmallSort a -> Just $ Inf (fibrantLub af bf) n - (Type a , Type b ) -> Just $ Type $ levelLub a b - (LockUniv , b ) -> Just b + (Type a , Type b ) -> Right $ Type $ levelLub a b + (Prop a , Type b ) -> Right $ Type $ levelLub a b + (Type a , Prop b ) -> Right $ Prop $ levelLub a b + (Prop a , Prop b ) -> Right $ Prop $ levelLub a b + (SSet a , SSet b ) -> Right $ SSet $ levelLub a b + (Type a , SSet b ) -> Right $ SSet $ levelLub a b + (SSet a , Type b ) -> Right $ SSet $ levelLub a b + (SSet a , Prop b ) -> Right $ SSet $ levelLub a b + (Prop a , SSet b ) -> Right $ SSet $ levelLub a b + (Inf af m , b ) -> sizeOfSort b >>= \case + SmallSort bf -> Right $ Inf (fibrantLub af bf) m + LargeSort bf n -> Right $ Inf (fibrantLub af bf) $ max m n + (a , Inf bf n ) -> sizeOfSort a >>= \case + SmallSort af -> Right $ Inf (fibrantLub af bf) n + LargeSort af m -> Right $ Inf (fibrantLub af bf) $ max m n + (LockUniv , b ) -> Right b -- No functions into lock types - (a , LockUniv ) -> Nothing - (SizeUniv , b ) -> Just b - (a , SizeUniv ) | Just (True,_) <- isSmallSort a -> Just SizeUniv - (Prop a , Type b ) -> Just $ Type $ levelLub a b - (Type a , Prop b ) -> Just $ Prop $ levelLub a b - (Prop a , Prop b ) -> Just $ Prop $ levelLub a b - (SSet a , SSet b ) -> Just $ SSet $ levelLub a b - (Type a , SSet b ) -> Just $ SSet $ levelLub a b - (SSet a , Type b ) -> Just $ SSet $ levelLub a b - (a , b ) -> Nothing + (a , LockUniv ) -> Left neverUnblock + -- @IntervalUniv@ behaves like @SSet@, but functions into @Type@ land in @Type@ + (IntervalUniv , IntervalUniv ) -> Right $ SSet $ ClosedLevel 0 + (IntervalUniv , SSet b ) -> Right $ SSet $ b + (IntervalUniv , Type b ) -> Right $ Type $ b + (IntervalUniv , _ ) -> Left neverUnblock + (Type a , IntervalUniv ) -> Right $ SSet $ a + (SSet a , IntervalUniv ) -> Right $ SSet $ a + (_ , IntervalUniv ) -> Left neverUnblock + (SizeUniv , b ) -> Right b + (a , SizeUniv ) -> sizeOfSort a >>= \case + SmallSort{} -> Right SizeUniv + LargeSort{} -> Left neverUnblock + (MetaS m _ , _ ) -> Left $ unblockOnMeta m + (_ , MetaS m _ ) -> Left $ unblockOnMeta m + (FunSort{} , _ ) -> Left neverUnblock + (_ , FunSort{} ) -> Left neverUnblock + (PiSort{} , _ ) -> Left neverUnblock + (_ , PiSort{} ) -> Left neverUnblock + (UnivSort{} , _ ) -> Left neverUnblock + (_ , UnivSort{} ) -> Left neverUnblock + (DefS{} , _ ) -> Left neverUnblock + (_ , DefS{} ) -> Left neverUnblock + (DummyS{} , _ ) -> Left neverUnblock + (_ , DummyS{} ) -> Left neverUnblock funSort :: Sort -> Sort -> Sort -funSort a b = fromMaybe (FunSort a b) $ funSort' a b +funSort a b = fromRight (const $ FunSort a b) $ funSort' a b -- | Compute the sort of a pi type from the sorts of its domain -- and codomain. -piSort' :: Dom Term -> Sort -> Abs Sort -> Maybe Sort -piSort' a s1 (NoAbs _ s2) = Just $ FunSort s1 s2 +piSort' :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort +piSort' a s1 (NoAbs _ s2) = Right $ FunSort s1 s2 piSort' a s1 s2Abs@(Abs _ s2) = case flexRigOccurrenceIn 0 s2 of - Nothing -> Just $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs - Just o | Just (True, f1) <- isSmallSort s1, Just (True, f2) <- isSmallSort s2 -> case o of - StronglyRigid -> Just $ Inf (fibrantLub f1 f2) 0 - Unguarded -> Just $ Inf (fibrantLub f1 f2) 0 - WeaklyRigid -> Just $ Inf (fibrantLub f1 f2) 0 - Flexible _ -> Nothing - Just o | Inf f1 n <- s1 , Just (True, f2) <- isSmallSort s2 -> Just $ Inf (fibrantLub f1 f2) n - Just _ -> Nothing + Nothing -> Right $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs + Just o -> case (sizeOfSort s1 , sizeOfSort s2) of + (Right (SmallSort f1) , Right (SmallSort f2)) -> case o of + StronglyRigid -> Right $ Inf (fibrantLub f1 f2) 0 + Unguarded -> Right $ Inf (fibrantLub f1 f2) 0 + WeaklyRigid -> Right $ Inf (fibrantLub f1 f2) 0 + Flexible ms -> Left $ metaSetToBlocker ms + (Right (LargeSort f1 n) , Right (SmallSort f2)) -> Right $ Inf (fibrantLub f1 f2) n + (_ , Right LargeSort{} ) -> __IMPOSSIBLE__ -- large sorts cannot depend on variables + (Left blocker , Right _ ) -> Left blocker + (Right _ , Left blocker ) -> Left blocker + (Left blocker1 , Left blocker2 ) -> Left $ unblockOnBoth blocker1 blocker2 -- Andreas, 2019-06-20 -- KEEP the following commented out code for the sake of the discussion on irrelevance. @@ -1601,9 +1693,7 @@ -- Flexible _ -> Nothing piSort :: Dom Term -> Sort -> Abs Sort -> Sort -piSort a s1 s2 = case piSort' a s1 s2 of - Just s -> s - Nothing -> PiSort a s1 s2 +piSort a s1 s2 = fromRight (const $ PiSort a s1 s2) $ piSort' a s1 s2 --------------------------------------------------------------------------- -- * Level stuff @@ -1611,15 +1701,13 @@ -- ^ Computes @n0 ⊔ a₁ ⊔ a₂ ⊔ ... ⊔ aₙ@ and return its canonical form. levelMax :: Integer -> [PlusLevel] -> Level -levelMax n0 as0 = Max n as +levelMax !n0 as0 = Max n as where -- step 1: flatten nested @Level@ expressions in @PlusLevel@s Max n1 as1 = expandLevel $ Max n0 as0 - -- step 2: remove subsumed @PlusLevel@s - as2 = removeSubsumed as1 - -- step 3: sort remaining @PlusLevel@s - as = List.sort as2 - -- step 4: set constant to 0 if it is subsumed by one of the @PlusLevel@s + -- step 2: remove subsumed @PlusLevel@s and sort what remains + as = removeSubsumed as1 + -- step 3: set constant to 0 if it is subsumed by one of the @PlusLevel@s greatestB = Prelude.maximum $ 0 : [ n | Plus n _ <- as ] n | n1 > greatestB = n1 | otherwise = 0 @@ -1637,12 +1725,11 @@ expandTm (Level l) = expandLevel l expandTm l = atomicLevel l - removeSubsumed [] = [] - removeSubsumed (Plus n a : bs) - | not $ null ns = removeSubsumed bs - | otherwise = Plus n a : removeSubsumed [ b | b@(Plus _ a') <- bs, a /= a' ] - where - ns = [ m | Plus m a' <- bs, a == a', m > n ] + removeSubsumed = + map (\(a, n) -> Plus n a) . + MapS.toAscList . + MapS.fromListWith max . + map (\(Plus n a) -> (a, n)) -- | Given two levels @a@ and @b@, compute @a ⊔ b@ and return its -- canonical form. 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 @@ -89,7 +89,7 @@ subst i u = applySubst $ singletonS i u strengthen :: Subst a => Impossible -> a -> a -strengthen err = applySubst (compactS err [Nothing]) +strengthen err = applySubst (strengthenS err 1) -- | Replace what is now de Bruijn index 0, but go under n binders. -- @substUnder n u == subst n (raise n u)@. @@ -162,10 +162,15 @@ dropS n IdS = raiseS n dropS n (Wk m rho) = wkS m (dropS n rho) dropS n (u :# rho) = dropS (n - 1) rho -dropS n (Strengthen _ rho) = dropS (n - 1) rho -dropS n (Lift 0 rho) = __IMPOSSIBLE__ -dropS n (Lift m rho) = wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho dropS n (EmptyS err) = throwImpossible err +dropS n (Lift m rho) + -- dropS n (Lift m rho) = + -- wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho + | n > m = wkS m $ dropS (n - m) rho + | otherwise = wkS n $ liftS (m - n) rho +dropS n (Strengthen err m rho) + | n < m = Strengthen err (m - n) rho + | otherwise = dropS (n - m) rho -- | @applySubst (ρ `composeS` σ) v == applySubst ρ (applySubst σ v)@ composeS :: EndoSubst a => Substitution' a -> Substitution' a -> Substitution' a @@ -174,7 +179,7 @@ composeS rho (EmptyS err) = EmptyS err composeS rho (Wk n sgm) = composeS (dropS n rho) sgm composeS rho (u :# sgm) = applySubst rho u :# composeS rho sgm -composeS rho (Strengthen err sgm) = Strengthen err (composeS rho sgm) +composeS rho (Strengthen err n sgm) = Strengthen err n (composeS rho sgm) composeS rho (Lift 0 sgm) = __IMPOSSIBLE__ composeS (u :# rho) (Lift n sgm) = u :# composeS rho (liftS (n - 1) sgm) composeS rho (Lift n sgm) = lookupS rho 0 :# composeS rho (wkS 1 (liftS (n - 1) sgm)) @@ -183,14 +188,23 @@ -- Γ ⊢ σ : Δ -- Γ ⊢ δ : Θσ splitS :: Int -> Substitution' a -> (Substitution' a, Substitution' a) -splitS 0 rho = (rho, EmptyS impossible) -splitS n (u :# rho) = second (u :#) $ splitS (n - 1) rho -splitS n (Strengthen err rho) = second (Strengthen err) $ splitS (n - 1) rho -splitS n (Lift 0 _) = __IMPOSSIBLE__ -splitS n (Wk m rho) = wkS m *** wkS m $ splitS n rho -splitS n IdS = (raiseS n, liftS n $ EmptyS impossible) -splitS n (Lift m rho) = wkS 1 *** liftS 1 $ splitS (n - 1) (liftS (m - 1) rho) -splitS n (EmptyS err) = __IMPOSSIBLE__ +splitS 0 rho = (rho, EmptyS impossible) +splitS n (u :# rho) = second (u :#) $ splitS (n - 1) rho +splitS n (Lift 0 _) = __IMPOSSIBLE__ +splitS n (Wk m rho) = wkS m *** wkS m $ splitS n rho +splitS n IdS = ( raiseS n + , liftS n $ EmptyS impossible + ) +splitS n (Lift m rho) = wkS 1 *** liftS 1 $ + splitS (n - 1) (liftS (m - 1) rho) +splitS n (EmptyS err) = __IMPOSSIBLE__ +splitS n (Strengthen err m rho) + -- splitS n (Strengthen err 1 rho) = + -- second (Strengthen err) $ splitS (n - 1) rho + | n > m = second (Strengthen err m) $ + splitS (n - m) rho + | otherwise = second (Strengthen err n) $ + splitS 0 (Strengthen err (m - n) rho) infixr 4 ++# @@ -203,21 +217,47 @@ -- Γ ⊢ prependS vs ρ : Δ, Θ -- @ prependS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a -> Substitution' a -prependS err us rho = foldr f rho us +prependS err us rho = go 0 us where - f Nothing rho = Strengthen err rho - f (Just u) rho = consS u rho + -- The function strengthenS' is not used here, to avoid replacing + -- the "error message" of a potential outermost Strengthen + -- constructor in rho. + str 0 = id + str n = Strengthen err n + go !n (Just u : us) = str n (consS u (go 0 us)) + go n (Nothing : us) = go (1 + n) us + go n [] = str n rho + +-- | @ +-- Γ ⊢ reverse vs : Δ +-- ----------------------------- +-- Γ ⊢ parallelS vs ρ : Γ, Δ +-- @ +-- +-- Note the @Γ@ in @Γ, Δ@. parallelS :: DeBruijn a => [a] -> Substitution' a parallelS us = us ++# idS -compactS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a -compactS err us = prependS err us idS - -- | Γ ⊢ (strengthenS ⊥ |Δ|) : Γ,Δ strengthenS :: Impossible -> Int -> Substitution' a -strengthenS err = indexWithDefault __IMPOSSIBLE__ $ iterate (Strengthen err) idS +strengthenS err n = case compare n 0 of + LT -> __IMPOSSIBLE__ + EQ -> idS + GT -> Strengthen err n idS +-- | A \"smart\" variant of 'Strengthen'. If 'strengthenS' is applied +-- to a substitution with an outermost 'Strengthen' constructor, then +-- the \"error message\" of that constructor is discarded in favour of +-- the 'Impossible' argument of this function. +strengthenS' :: Impossible -> Int -> Substitution' a -> Substitution' a +strengthenS' err m rho = case compare m 0 of + LT -> __IMPOSSIBLE__ + EQ -> rho + GT -> case rho of + Strengthen _ n rho -> Strengthen err (m + n) rho + _ -> Strengthen err m rho + lookupS :: EndoSubst a => Substitution' a -> Nat -> a lookupS rho i = case rho of IdS -> deBruijnVar i @@ -227,10 +267,10 @@ u :# rho | i == 0 -> u | i < 0 -> __IMPOSSIBLE__ | otherwise -> lookupS rho (i - 1) - Strengthen err rho - | i == 0 -> throwImpossible err + Strengthen err n rho | i < 0 -> __IMPOSSIBLE__ - | otherwise -> lookupS rho (i - 1) + | i < n -> throwImpossible err + | otherwise -> lookupS rho (i - n) Lift n rho | i < n -> deBruijnVar i | otherwise -> raise n $ lookupS rho (i - n) EmptyS err -> throwImpossible err diff --git a/src/full/Agda/TypeChecking/Substitute/DeBruijn.hs b/src/full/Agda/TypeChecking/Substitute/DeBruijn.hs --- a/src/full/Agda/TypeChecking/Substitute/DeBruijn.hs +++ b/src/full/Agda/TypeChecking/Substitute/DeBruijn.hs @@ -47,3 +47,7 @@ debruijnNamedVar = DBPatVar deBruijnView = Just . dbPatVarIndex + +instance DeBruijn a => DeBruijn (Named_ a) where + debruijnNamedVar nm i = unnamed $ debruijnNamedVar nm i + deBruijnView = deBruijnView . namedThing diff --git a/src/full/Agda/TypeChecking/SyntacticEquality.hs b/src/full/Agda/TypeChecking/SyntacticEquality.hs --- a/src/full/Agda/TypeChecking/SyntacticEquality.hs +++ b/src/full/Agda/TypeChecking/SyntacticEquality.hs @@ -7,7 +7,13 @@ -- by a more efficient routine which only traverses and instantiates the terms -- as long as they are equal. -module Agda.TypeChecking.SyntacticEquality (SynEq, checkSyntacticEquality) where +module Agda.TypeChecking.SyntacticEquality + ( SynEq + , checkSyntacticEquality + , checkSyntacticEquality' + , syntacticEqualityFuelRemains + ) + where import Control.Arrow ( (***) ) import Control.Monad ( zipWithM ) @@ -19,33 +25,95 @@ import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.TypeChecking.Monad (ReduceM, MonadReduce(..), pragmaOptions, isInstantiatedMeta) +import Agda.TypeChecking.Monad + (ReduceM, MonadReduce(..), TCEnv(..), MonadTCEnv(..), pragmaOptions, + isInstantiatedMeta) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import Agda.Utils.Monad (ifM) - +import qualified Agda.Utils.Maybe.Strict as Strict +import Agda.Utils.Monad (ifM, and2M) --- | Syntactic equality check for terms. +-- | Syntactic equality check for terms. If syntactic equality +-- checking has fuel left, then 'checkSyntacticEquality' behaves as if +-- it were implemented in the following way (which does not match the +-- given type signature), only that @v@ and @v'@ are only fully +-- instantiated to the depth where they are equal (and the amount of +-- fuel is reduced by one unit in the failure branch): -- @ --- checkSyntacticEquality v v' = do +-- checkSyntacticEquality v v' s f = do -- (v, v') <- instantiateFull (v, v') --- return ((v, v'), v==v') +-- if v == v' then s v v' else f v v' -- @ --- only that @v, v'@ are only fully instantiated to the depth --- where they are equal. +-- If syntactic equality checking does not have fuel left, then +-- 'checkSyntacticEquality' instantiates the two terms and takes the +-- failure branch. -- --- This means in particular that the returned @v,v'@ cannot be @MetaV@s --- that are instantiated. +-- Note that in either case the returned values @v@ and @v'@ cannot be +-- @MetaV@s that are instantiated. -{-# SPECIALIZE checkSyntacticEquality :: Term -> Term -> ReduceM ((Term, Term), Bool) #-} -{-# SPECIALIZE checkSyntacticEquality :: Type -> Type -> ReduceM ((Type, Type), Bool) #-} -checkSyntacticEquality :: (Instantiate a, SynEq a, MonadReduce m) => a -> a -> m ((a, a), Bool) -checkSyntacticEquality v v' = liftReduce $ do - ifM (optSyntacticEquality <$> pragmaOptions) - {-then-} (synEq v v' `runStateT` True) - {-else-} ((,False) <$> instantiate (v,v')) +{-# SPECIALIZE checkSyntacticEquality :: + Term -> Term -> + (Term -> Term -> ReduceM a) -> + (Term -> Term -> ReduceM a) -> + ReduceM a #-} +{-# SPECIALIZE checkSyntacticEquality :: + Type -> Type -> + (Type -> Type -> ReduceM a) -> + (Type -> Type -> ReduceM a) -> + ReduceM a #-} +checkSyntacticEquality + :: (Instantiate a, SynEq a, MonadReduce m) + => a + -> a + -> (a -> a -> m b) -- ^ Continuation used upon success. + -> (a -> a -> m b) -- ^ Continuation used upon failure, or if + -- syntactic equality checking has been turned + -- off. + -> m b +checkSyntacticEquality u v s f = + ifM syntacticEqualityFuelRemains + {-then-} (checkSyntacticEquality' u v s (\u v -> localTC decreaseFuel (f u v))) + {-else-} (uncurry f =<< instantiate (u, v)) + where + decreaseFuel env = + case envSyntacticEqualityFuel env of + Strict.Nothing -> env + Strict.Just n -> + env { envSyntacticEqualityFuel = Strict.Just (pred n) } +-- | Syntactic equality check for terms without checking remaining fuel. + +{-# SPECIALIZE checkSyntacticEquality' :: + Term -> Term -> + (Term -> Term -> ReduceM a) -> + (Term -> Term -> ReduceM a) -> + ReduceM a #-} +{-# SPECIALIZE checkSyntacticEquality' :: + Type -> Type -> + (Type -> Type -> ReduceM a) -> + (Type -> Type -> ReduceM a) -> + ReduceM a #-} +checkSyntacticEquality' + :: (Instantiate a, SynEq a, MonadReduce m) + => a + -> a + -> (a -> a -> m b) -- ^ Continuation used upon success. + -> (a -> a -> m b) -- ^ Continuation used upon failure. + -> m b +checkSyntacticEquality' u v s f = do + ((u, v), equal) <- liftReduce $ synEq u v `runStateT` True + if equal then s u v else f u v + +-- | Does the syntactic equality check have any remaining fuel? + +syntacticEqualityFuelRemains :: MonadReduce m => m Bool +syntacticEqualityFuelRemains = do + fuel <- envSyntacticEqualityFuel <$> askTC + return $ case fuel of + Strict.Nothing -> True + Strict.Just n -> n > 0 + -- | Monad for checking syntactic equality type SynEqM = StateT Bool ReduceM @@ -122,6 +190,7 @@ (UnivSort a, UnivSort a') -> UnivSort <$$> synEq a a' (SizeUniv, SizeUniv ) -> pure2 s (LockUniv, LockUniv ) -> pure2 s + (IntervalUniv, IntervalUniv) -> pure2 s (Prop l , Prop l' ) -> Prop <$$> synEq l l' (Inf f m , Inf f' n) | f == f', m == n -> pure2 s (SSet l , SSet l' ) -> SSet <$$> synEq l l' @@ -165,8 +234,8 @@ -- Ignore the tactic. instance SynEq a => SynEq (Dom a) where - synEq d@(Dom ai b x t a) d'@(Dom ai' b' x' _ a') - | x == x' = Dom <$$> synEq ai ai' <**> synEq b b' <**> pure2 x <**> pure2 t <**> synEq a a' + synEq d@(Dom ai x f t a) d'@(Dom ai' x' f' _ a') + | x == x' = Dom <$$> synEq ai ai' <**> pure2 x <**> synEq f f' <**> pure2 t <**> synEq a a' | otherwise = inequal (d, d') instance SynEq ArgInfo where 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} module Agda.TypeChecking.Telescope where @@ -5,6 +6,7 @@ import Control.Monad +import Data.Bifunctor (first) import Data.Foldable (find) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -61,14 +63,21 @@ -- | Unflatten: turns a flattened telescope into a proper telescope. Must be -- properly ordered. unflattenTel :: [ArgName] -> [Dom Type] -> Telescope -unflattenTel [] [] = EmptyTel -unflattenTel (x : xs) (a : tel) = ExtendTel a' (Abs x tel') - where - tel' = unflattenTel xs tel +unflattenTel xs tel = unflattenTel' (size tel) xs tel + +-- | A variant of 'unflattenTel' which takes the size of the last +-- argument as an argument. +unflattenTel' :: Int -> [ArgName] -> [Dom Type] -> Telescope +unflattenTel' !n xs tel = case (xs, tel) of + ([], []) -> EmptyTel + (x : xs, a : tel) -> ExtendTel a' (Abs x tel') + where + tel' = unflattenTel' (n - 1) xs tel a' = applySubst rho a - rho = parallelS (replicate (size tel + 1) (withCallerCallStack impossibleTerm)) -unflattenTel [] (_ : _) = __IMPOSSIBLE__ -unflattenTel (_ : _) [] = __IMPOSSIBLE__ + rho = parallelS $ + replicate n (withCallerCallStack impossibleTerm) + ([], _ : _) -> __IMPOSSIBLE__ + (_ : _, []) -> __IMPOSSIBLE__ -- | Rename the variables in the telescope to the given names -- Precondition: @size xs == size tel@. @@ -100,7 +109,7 @@ -- | (x, Dom {domInfo = info, unDom = (name,_)}) <- zip xs l ] -- where l = telToList tel -teleNamedArgs :: (DeBruijn a) => Telescope -> [NamedArg a] +teleNamedArgs :: (DeBruijn a) => Tele (Dom t) -> [NamedArg a] teleNamedArgs = map namedArgFromDom . teleDoms -- | A variant of `teleNamedArgs` which takes the argument names (and the argument info) @@ -374,28 +383,29 @@ telViewUpTo' n p t = do t <- reduce t case unEl t of - Pi a b | p a -> absV a (absName b) <$> do - underAbstractionAbs a b $ \b -> telViewUpTo' (n - 1) p b - _ -> return $ TelV EmptyTel t - where - absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t + Pi a b | p a -> + -- Force the name to avoid retaining the rest of b. + let !bn = absName b in + absV a bn <$> do + underAbstractionAbs a b $ \b -> telViewUpTo' (n - 1) p b + _ -> return $ TelV EmptyTel t telViewPath :: PureTCM m => Type -> m TelView telViewPath = telViewUpToPath (-1) -- | @telViewUpToPath n t@ takes off $t$ -- the first @n@ (or arbitrary many if @n < 0@) function domains or Path types. +-- +-- @telViewUpToPath n t = fst <$> telViewUpToPathBoundary'n t@ telViewUpToPath :: PureTCM m => Int -> Type -> m TelView -telViewUpToPath 0 t = return $ TelV EmptyTel t -telViewUpToPath n t = do - vt <- pathViewAsPi $ t - case vt of - Left (a,b) -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) - Right (El _ t) | Pi a b <- t - -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) - Right t -> return $ TelV EmptyTel t +telViewUpToPath n t = if n == 0 then done t else do + pathViewAsPi t >>= \case + Left (a, b) -> recurse a b + Right (El _ (Pi a b)) -> recurse a b + Right t -> done t where - absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t + done t = return $ TelV EmptyTel t + recurse a b = absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) -- | [[ (i,(x,y)) ]] = [(i=0) -> x, (i=1) -> y] type Boundary = Boundary' (Term,Term) @@ -405,20 +415,18 @@ -- by the Path types encountered. The boundary terms live in the -- telescope given by the @TelView@. -- Each point of the boundary has the type of the codomain of the Path type it got taken from, see @fullBoundary@. -telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView,Boundary) -telViewUpToPathBoundary' 0 t = return $ (TelV EmptyTel t,[]) -telViewUpToPathBoundary' n t = do - vt <- pathViewAsPi' $ t - case vt of - Left ((a,b),xy) -> addEndPoints xy . absV a (absName b) <$> telViewUpToPathBoundary' (n - 1) (absBody b) - Right (El _ t) | Pi a b <- t - -> absV a (absName b) <$> telViewUpToPathBoundary' (n - 1) (absBody b) - Right t -> return $ (TelV EmptyTel t,[]) +telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView, Boundary) +telViewUpToPathBoundary' n t = if n == 0 then done t else do + pathViewAsPi' t >>= \case + Left ((a, b), xy) -> addEndPoints xy <$> recurse a b + Right (El _ (Pi a b)) -> recurse a b + Right t -> done t where - absV a x (TelV tel t, cs) = (TelV (ExtendTel a (Abs x tel)) t, cs) - addEndPoints xy (telv@(TelV tel _),cs) = (telv, (var $ size tel - 1, xyInTel):cs) - where - xyInTel = raise (size tel) xy + done t = return (TelV EmptyTel t, []) + recurse a b = first (absV a (absName b)) <$> do + underAbstractionAbs a b $ \b -> telViewUpToPathBoundary' (n - 1) b + addEndPoints xy (telv@(TelV tel _), cs) = + (telv, (var $ size tel - 1, raise (size tel) xy) : cs) fullBoundary :: Telescope -> Boundary -> Boundary @@ -478,10 +486,12 @@ Just i | Just (t,u) <- matchVar i -> IApply t u p _ -> Apply a +-- | Reduces 'Type'. pathViewAsPi :: PureTCM m => Type -> m (Either (Dom Type, Abs Type) Type) pathViewAsPi t = either (Left . fst) Right <$> pathViewAsPi' t +-- | Reduces 'Type'. pathViewAsPi' :: PureTCM m => Type -> m (Either ((Dom Type, Abs Type), (Term,Term)) Type) pathViewAsPi' t = do @@ -492,45 +502,43 @@ => m (Type -> Either ((Dom Type, Abs Type), (Term,Term)) Type) pathViewAsPi'whnf = do view <- pathView' - minterval <- getBuiltin' builtinInterval - return $ \ t -> case view t of - PathType s l p a x y | Just interval <- minterval -> + minterval <- getTerm' builtinInterval + return $ \case + (view -> PathType s l p a x y) | Just interval <- minterval -> let name | Lam _ (Abs n _) <- unArg a = n | otherwise = "i" - i = El (SSet $ ClosedLevel 0) interval in - Left $ ((defaultDom $ i, Abs name $ El (raise 1 s) $ raise 1 (unArg a) `apply` [defaultArg $ var 0]), (unArg x, unArg y)) + Left ( ( defaultDom $ El intervalSort interval + , Abs name $ El (raise 1 s) $ raise 1 (unArg a) `apply` [defaultArg $ var 0] + ) + , (unArg x, unArg y) + ) - _ -> Right t + t -> Right t --- | returns Left (a,b) in case the type is @Pi a b@ or @PathP b _ _@ --- assumes the type is in whnf. +-- | Returns @Left (a,b)@ in case the type is @Pi a b@ or @PathP b _ _@. +-- Assumes the 'Type' is in whnf. piOrPath :: HasBuiltins m => Type -> m (Either (Dom Type, Abs Type) Type) piOrPath t = do - t <- pathViewAsPi'whnf <*> pure t - case t of - Left (p,_) -> return $ Left p - Right (El _ (Pi a b)) -> return $ Left (a,b) - Right t -> return $ Right t + (pathViewAsPi'whnf <*> pure t) <&> \case + Left (p, _) -> Left p + Right (El _ (Pi a b)) -> Left (a,b) + Right _ -> Right t +-- | Assumes 'Type' is in whnf. telView'UpToPath :: Int -> Type -> TCM TelView -telView'UpToPath 0 t = return $ TelV EmptyTel t -telView'UpToPath n t = do - vt <- pathViewAsPi'whnf <*> pure t - case vt of - Left ((a,b),_) -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) - Right (El _ t) | Pi a b <- t - -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) - Right t -> return $ TelV EmptyTel t +telView'UpToPath n t = if n == 0 then done else do + piOrPath t >>= \case + Left (a, b) -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b) + Right _ -> done where - absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t + done = return $ TelV EmptyTel t telView'Path :: Type -> TCM TelView telView'Path = telView'UpToPath (-1) -isPath - :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type)) -isPath t = either Just (const Nothing) <$> pathViewAsPi t +isPath :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type)) +isPath = either Just (const Nothing) <.> pathViewAsPi telePatterns :: DeBruijn a => Telescope -> Boundary -> [NamedArg (Pattern' a)] telePatterns = telePatterns' teleNamedArgs diff --git a/src/full/Agda/TypeChecking/Telescope/Path.hs b/src/full/Agda/TypeChecking/Telescope/Path.hs --- a/src/full/Agda/TypeChecking/Telescope/Path.hs +++ b/src/full/Agda/TypeChecking/Telescope/Path.hs @@ -17,6 +17,7 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Size @@ -91,27 +92,34 @@ -- Does not reduce the type. arityPiPath :: Type -> TCM Int arityPiPath t = do - t' <- piOrPath t - case t' of - Left (_ , u) -> (+1) <$> arityPiPath (unAbs u) - Right _ -> return 0 + piOrPath t >>= \case + Left (_, u) -> (+1) <$> arityPiPath (unAbs u) + Right _ -> return 0 -iApplyVars :: DeBruijn a => [NamedArg (Pattern' a)] -> [Int] -iApplyVars ps = flip concatMap (map namedArg ps) $ \case - IApplyP _ t u x -> - [fromMaybe __IMPOSSIBLE__ (deBruijnView x)] - VarP{} -> [] - ProjP{}-> [] - LitP{} -> [] - DotP{} -> [] - DefP _ _ ps -> iApplyVars ps - ConP _ _ ps -> iApplyVars ps +-- | Collect the interval copattern variables as list of de Bruijn indices. +class IApplyVars p where + iApplyVars :: p -> [Int] +instance DeBruijn a => IApplyVars (Pattern' a) where + iApplyVars = \case + IApplyP _ t u x -> [ fromMaybe __IMPOSSIBLE__ $ deBruijnView x ] + VarP{} -> [] + ProjP{} -> [] + LitP{} -> [] + DotP{} -> [] + DefP _ _ ps -> iApplyVars ps + ConP _ _ ps -> iApplyVars ps + +instance IApplyVars p => IApplyVars (NamedArg p) where + iApplyVars = iApplyVars . namedArg + +instance IApplyVars p => IApplyVars [p] where + iApplyVars = concatMap iApplyVars + +-- | Check whether a type is the built-in interval type. isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool isInterval t = liftTCM $ do - mi <- getName' builtinInterval - caseMaybe mi (return False) $ \ i -> do - t <- reduce $ unEl t - case t of - Def q [] -> return $ q == i - _ -> return $ False + caseMaybeM (getName' builtinInterval) (return False) $ \ i -> do + reduce (unEl t) <&> \case + Def q [] -> q == i + _ -> False 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 @@ -2,10 +2,10 @@ module Agda.TypeChecking.Unquote where import Control.Arrow ( first, second, (&&&) ) -import Control.Monad ( (<=<) ) +import Control.Monad ( (<=<), liftM2 ) import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.Reader ( ReaderT(..), runReaderT ) +import Control.Monad.Reader ( ReaderT(..), runReaderT, ask ) import Control.Monad.State ( gets, modify, StateT(..), runStateT ) import Control.Monad.Writer ( MonadWriter(..), WriterT(..), runWriterT ) import Control.Monad.Trans ( lift ) @@ -28,10 +28,13 @@ import Agda.Syntax.Internal as I import qualified Agda.Syntax.Reflected as R import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Abstract.Views +import Agda.Syntax.Translation.InternalToAbstract import Agda.Syntax.Literal import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Translation.ReflectedToAbstract +import Agda.Syntax.Scope.Base (KindOfName(ConName, DataName)) import Agda.Interaction.Library ( ExeName ) import Agda.Interaction.Options ( optTrustedExecutables, optAllowExec ) @@ -39,6 +42,7 @@ import Agda.TypeChecking.Constraints import Agda.TypeChecking.Monad import Agda.TypeChecking.Free +import Agda.TypeChecking.Irrelevance ( workOnTypes ) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute @@ -49,9 +53,12 @@ import Agda.TypeChecking.Primitive import Agda.TypeChecking.ReconstructParameters import Agda.TypeChecking.CheckInternal +import Agda.TypeChecking.InstanceArguments ( getInstanceCandidates ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Rules.Def +import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl +import Agda.TypeChecking.Rules.Data import Agda.Utils.Either import Agda.Utils.Lens @@ -62,6 +69,7 @@ import qualified Agda.Interaction.Options.Lenses as Lens import Agda.Utils.Impossible +import Agda.Syntax.Abstract (TypedBindingInfo(tbTacticAttr)) agdaTermType :: TCM Type agdaTermType = El (mkType 0) <$> primAgdaTerm @@ -112,8 +120,9 @@ inOriginalContext :: UnquoteM a -> UnquoteM a inOriginalContext m = - packUnquoteM $ \ cxt s -> - unsafeModifyContext (const cxt) $ unpackUnquoteM m cxt s + packUnquoteM $ \ cxt s -> do + n <- getContextSize + escapeContext __IMPOSSIBLE__ (n - length cxt) $ unpackUnquoteM m cxt s isCon :: ConHead -> TCM Term -> UnquoteM Bool isCon con tm = do t <- liftTCM tm @@ -282,11 +291,12 @@ unquoteNString :: Arg Term -> UnquoteM Text unquoteNString = unquoteN -data ErrorPart = StrPart String | TermPart A.Expr | NamePart QName +data ErrorPart = StrPart String | TermPart A.Expr | PattPart A.Pattern | NamePart QName instance PrettyTCM ErrorPart where - prettyTCM (StrPart s) = text s + prettyTCM (StrPart s) = text s prettyTCM (TermPart t) = prettyTCM t + prettyTCM (PattPart p) = prettyTCM p prettyTCM (NamePart x) = prettyTCM x -- | We do a little bit of work here to make it possible to generate nice @@ -302,6 +312,7 @@ (s0, "") -> consLine (StrPart s0) (splitLines ss) _ -> __IMPOSSIBLE__ splitLines (p@TermPart{} : ss) = consLine p (splitLines ss) + splitLines (p@PattPart{} : ss) = consLine p (splitLines ss) splitLines (p@NamePart{} : ss) = consLine p (splitLines ss) consLine l [] = [[l]] @@ -315,6 +326,7 @@ 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) ] __IMPOSSIBLE__ _ -> throwError $ NonCanonical "error part" t @@ -407,13 +419,12 @@ unquote t = do t <- reduceQuotedTerm t case t of - Lit (LitMeta f x) -> liftTCM $ do - live <- (f ==) <$> getCurrentPath - unless live $ do - m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f + Lit (LitMeta m x) -> liftTCM $ do + live <- (Just m ==) <$> currentTopLevelModule + unless live $ typeError . GenericDocError =<< sep [ "Can't unquote stale metavariable" - , pretty m <> "." <> pretty x ] + , pretty m <> "._" <> pretty (metaId x) ] return x _ -> throwError $ NonCanonical "meta variable" t @@ -451,7 +462,11 @@ , (c `isCon` primAgdaLitChar, LitChar <$> unquoteN x) , (c `isCon` primAgdaLitString, LitString <$> unquoteNString x) , (c `isCon` primAgdaLitQName, LitQName <$> unquoteN x) - , (c `isCon` primAgdaLitMeta, LitMeta <$> getCurrentPath <*> unquoteN x) ] + , (c `isCon` primAgdaLitMeta, + LitMeta + <$> (fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule) + <*> unquoteN x) + ] __IMPOSSIBLE__ Con c _ _ -> __IMPOSSIBLE__ _ -> throwError $ NonCanonical "literal" t @@ -480,7 +495,7 @@ , (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.fromList <$> unquoteN x) <*> unquoteN y) + , (c `isCon` primAgdaTermExtLam, R.ExtLam <$> (List1.fromListSafe __IMPOSSIBLE__ <$> unquoteN x) <*> unquoteN y) ] __IMPOSSIBLE__ where @@ -559,8 +574,10 @@ , (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) ] failEval I.Def f [u, v] -> @@ -568,19 +585,21 @@ , (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 (unElim v)) + , (f `isDef` primAgdaTCMQuoteOmegaTerm, tcQuoteTerm (sort $ Inf IsFibrant 0) (unElim v)) ] failEval I.Def f [l, a, u] -> choice [ (f `isDef` primAgdaTCMReturn, return (unElim u)) , (f `isDef` primAgdaTCMTypeError, tcFun1 tcTypeError u) - , (f `isDef` primAgdaTCMQuoteTerm, tcQuoteTerm (unElim u)) + , (f `isDef` primAgdaTCMQuoteTerm, tcQuoteTerm (mkT (unElim l) (unElim a)) (unElim u)) , (f `isDef` primAgdaTCMUnquoteTerm, tcFun1 (tcUnquoteTerm (mkT (unElim l) (unElim a))) u) , (f `isDef` primAgdaTCMBlockOnMeta, uqFun1 tcBlockOnMeta u) , (f `isDef` primAgdaTCMDebugPrint, tcFun3 tcDebugPrint l a u) , (f `isDef` primAgdaTCMNoConstraints, tcNoConstraints (unElim u)) , (f `isDef` primAgdaTCMWithReconsParams, tcWithReconsParams (unElim u)) + , (f `isDef` primAgdaTCMDeclareData, uqFun3 tcDeclareData l a u) , (f `isDef` primAgdaTCMRunSpeculative, tcRunSpeculative (unElim u)) , (f `isDef` primAgdaTCMExec, tcFun3 tcExec l a u) ] @@ -588,12 +607,15 @@ I.Def f [_, _, u, v] -> choice [ (f `isDef` primAgdaTCMCatchError, tcCatchError (unElim u) (unElim v)) , (f `isDef` primAgdaTCMWithNormalisation, tcWithNormalisation (unElim u) (unElim v)) - , (f `isDef` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v)) , (f `isDef` primAgdaTCMInContext, tcInContext (unElim u) (unElim v)) , (f `isDef` primAgdaTCMOnlyReduceDefs, tcOnlyReduceDefs (unElim u) (unElim v)) , (f `isDef` primAgdaTCMDontReduceDefs, tcDontReduceDefs (unElim u) (unElim v)) ] failEval + I.Def f [_, _, u, v, w] -> + choice [ (f `isDef` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v) (unElim w)) + ] + failEval I.Def f [_, _, _, _, m, k] -> choice [ (f `isDef` primAgdaTCMBind, tcBind (unElim m) (unElim k)) ] failEval @@ -688,6 +710,9 @@ modify (second $ const s) liftTCM primUnitUnit + tcFormatErrorParts :: [ErrorPart] -> TCM Term + tcFormatErrorParts msg = quoteString . prettyShow <$> prettyErrorParts msg + tcTypeError :: [ErrorPart] -> TCM a tcTypeError err = typeError . GenericDocError =<< prettyErrorParts err @@ -715,18 +740,25 @@ tcCheckType :: R.Term -> R.Type -> TCM Term tcCheckType v a = do r <- isReconstructed - a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a + a <- workOnTypes $ locallyReduceAllDefs $ isType_ =<< toAbstract_ a e <- toAbstract_ v v <- checkExpr e a if r then do v <- process v - v <- locallyReduceAllDefs $ reconstructParameters' defaultAction a v + v <- locallyReduceAllDefs $ reconstructParameters a v locallyReconstructed (quoteTerm v) else quoteTerm =<< process v - tcQuoteTerm :: Term -> UnquoteM Term - tcQuoteTerm v = liftTCM $ quoteTerm =<< process v + tcQuoteTerm :: Type -> Term -> UnquoteM Term + tcQuoteTerm a v = liftTCM $ do + r <- isReconstructed + if r then do + v <- process v + v <- locallyReduceAllDefs $ reconstructParameters a v + locallyReconstructed (quoteTerm v) + else + quoteTerm =<< process v tcUnquoteTerm :: Type -> R.Term -> TCM Term tcUnquoteTerm a v = do @@ -762,32 +794,36 @@ tcGetContext :: UnquoteM Term tcGetContext = liftTCM $ do r <- isReconstructed - as <- map (fmap snd) <$> getContext + as <- map (nameToArgName . fst . unDom &&& fmap snd) <$> getContext as <- etaContract =<< process as if r then do - as <- recons (reverse as) - let as' = reverse as - locallyReconstructed $ buildList <*> mapM quoteDom as' + as <- recons (reverse as) + let as' = reverse as + locallyReconstructed $ buildList <*> mapM quoteDomWithName as' else - buildList <*> mapM quoteDom as + buildList <*> mapM quoteDomWithName as where - recons :: [Dom Type] -> TCM [Dom Type] - recons [] = return [] - recons (d@Dom {unDom=t} : ds) = do - t <- locallyReduceAllDefs $ reconstructParametersInType t - let d' = d{unDom=t} - ds' <- addContext d' $ recons ds - return $ d' : ds' + recons :: [(ArgName, Dom Type)] -> TCM [(ArgName, Dom Type)] + recons [] = return [] + recons ((s, d@Dom {unDom=t}):ds) = do + t <- locallyReduceAllDefs $ reconstructParametersInType t + let d' = d{unDom=t} + ds' <- addContext (s, d') $ recons ds + return $ (s, d'):ds' - extendCxt :: Arg R.Type -> UnquoteM a -> UnquoteM a - extendCxt a m = do - a <- locallyReduceAllDefs $ liftTCM $ traverse (isType_ <=< toAbstract_) a - liftU1 (addContext ("x" :: String, domFromArg a :: Dom Type)) m + quoteDomWithName :: (ArgName, Dom Type) -> TCM Term + quoteDomWithName (x, t) = toTerm <*> pure (T.pack x, t) - tcExtendContext :: Term -> Term -> UnquoteM Term - tcExtendContext a m = do + extendCxt :: Text -> Arg R.Type -> UnquoteM a -> UnquoteM a + extendCxt s a m = do + a <- workOnTypes $ locallyReduceAllDefs $ liftTCM $ traverse (isType_ <=< toAbstract_) a + liftU1 (addContext (s, domFromArg a :: Dom Type)) m + + tcExtendContext :: Term -> Term -> Term -> UnquoteM Term + tcExtendContext s a m = do + s <- unquote s a <- unquote a - fmap (strengthen impossible) $ extendCxt a $ do + fmap (strengthen impossible) $ extendCxt s a $ do v <- evalTCM $ raise 1 m when (freeIn 0 v) $ liftTCM $ genericDocError =<< hcat ["Local variable '", prettyTCM (var 0), "' escaping in result of extendContext:"] @@ -797,11 +833,11 @@ tcInContext :: Term -> Term -> UnquoteM Term tcInContext c m = do c <- unquote c - liftU1 unsafeInTopContext $ go c (evalTCM m) + inOriginalContext $ go c (evalTCM m) where - go :: [Arg R.Type] -> UnquoteM Term -> UnquoteM Term - go [] m = m - go (a : as) m = go as (extendCxt a m) + go :: [(Text , Arg R.Type)] -> UnquoteM Term -> UnquoteM Term + go [] m = m + go ((s , a) : as) m = go as (extendCxt s a m) constInfo :: QName -> TCM Definition constInfo x = either err return =<< getConstInfo' x @@ -810,7 +846,7 @@ tcGetType :: QName -> TCM Term tcGetType x = do r <- isReconstructed - ci <- constInfo x + ci <- constInfo x >>= instantiateDef let t = defType ci if r then do t <- locallyReduceAllDefs $ reconstructParametersInType t @@ -833,11 +869,11 @@ if r then tcGetDefinitionRecons x else - quoteDefn =<< constInfo x + quoteDefn =<< instantiateDef =<< constInfo x tcGetDefinitionRecons :: QName -> TCM Term tcGetDefinitionRecons x = do - ci@(Defn {theDef=d}) <- constInfo x + ci@(Defn {theDef=d}) <- constInfo x >>= instantiateDef case d of f@(Function {funClauses=cs}) -> do cs' <- mapM reconsClause cs @@ -913,6 +949,86 @@ when (isInstance i) $ addTypedInstance x a primUnitUnit + -- A datatype is expected to be declared with a function type. + -- The second argument indicates how many preceding types are parameters. + tcDeclareData :: QName -> Integer -> R.Type -> UnquoteM Term + tcDeclareData x npars t = inOriginalContext $ do + setDirty + tell [x] + liftTCM $ do + reportSDoc "tc.unquote.decl" 10 $ sep + [ "declare Data" <+> prettyTCM x <+> ":" + , nest 2 $ prettyR t + ] + alreadyDefined <- isRight <$> getConstInfo' x + when alreadyDefined $ genericError $ "Multiple declarations of " ++ prettyShow x + e <- toAbstract_ t + -- The type to be checked with @checkSig@ is without parameters. + let (tel, e') = splitPars (fromInteger npars) e + ac <- asksTC (^. lensIsAbstract) + let defIn = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ac noRange + checkSig DataName defIn x (A.GeneralizeTel Map.empty tel) e' + primUnitUnit + + tcDefineData :: QName -> [(QName, R.Type)] -> UnquoteM Term + tcDefineData x cs = inOriginalContext $ (setDirty >>) $ liftTCM $ do + caseEitherM (getConstInfo' x) + (const $ genericError $ "Missing declaration for " ++ prettyShow x) $ \def -> do + npars <- case theDef def of + DataOrRecSig n -> return n + _ -> genericError $ prettyShow x ++ + " is not declared as a datatype or record, or it already has a definition." + + -- 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 + reportSDoc "tc.unquote.def" 10 $ vcat $ + [ "declaring constructors of" <+> prettyTCM x <+> ":" ] ++ map prettyA es + + -- Translate parameters from internal definitions back to abstract syntax. + t <- instantiateFull . defType =<< instantiateDef def + tel <- reify =<< theTel <$> telViewUpTo npars t + + es' <- case mapM (uncurry (substNames' tel) . splitPars npars) es of + Nothing -> genericError $ "Number of parameters doesn't match!" + Just es -> return es + + 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' + lams = map (\case {A.TBind _ tac (b :| []) _ -> A.DomainFree (tbTacticAttr tac) b + ;_ -> __IMPOSSIBLE__ }) tel + reportSDoc "tc.unquote.def" 10 $ vcat $ + [ "checking datatype: " <+> prettyTCM x <+> " with constructors:" + , nest 2 (vcat (map prettyTCM conNames)) + ] + checkDataDef i x YesUniverseCheck (A.DataDefParams Set.empty lams) as + primUnitUnit + where + addDummy :: Int -> R.Type -> R.Type + addDummy 0 t = t + addDummy n t = R.Pi (defaultDom (R.Sort $ R.LitS 0)) (R.Abs "dummy" $ addDummy (n - 1) t) + + substNames' :: [A.TypedBinding] -> [A.TypedBinding] -> A.Expr -> Maybe A.Expr + substNames' (a : as) (b : bs) e = do + let (A.TBind _ _ (na :| _) expra) = a + (A.TBind _ _ (nb :| _) exprb) = b + getName n = A.unBind . A.binderName $ namedArg n + e' <- substNames' as bs e + return $ mapExpr (substName (getName na) (getName nb)) e' + where + -- Substitute @Var x@ for @Var y@ in an @Expr@. + substName :: Name -> Name -> (A.Expr -> A.Expr) + substName x y e@(A.Var n) + | y == n = A.Var x + | otherwise = e + substName _ _ e = e + substNames' [] [] e = return e + substNames' _ _ _ = Nothing + tcDefineFun :: QName -> [R.Clause] -> UnquoteM Term tcDefineFun x cs = inOriginalContext $ (setDirty >>) $ liftTCM $ do whenM (isLeft <$> getConstInfo' x) $ @@ -936,7 +1052,18 @@ _ -> liftTCM $ typeError . GenericDocError =<< "Should be a pair: " <+> prettyTCM u + tcGetInstances :: MetaId -> UnquoteM Term + tcGetInstances m = liftTCM (getInstanceCandidates m) >>= \case + Left unblock -> do + s <- gets snd + throwError (BlockedOnMeta s unblock) + Right cands -> liftTCM $ + buildList <*> mapM (quoteTerm . candidateTerm) cands + splitPars :: Int -> A.Expr -> ([A.TypedBinding], A.Expr) + splitPars 0 e = ([] , e) + splitPars npars (A.Pi _ (n :| _) e) = first (n :) (splitPars (npars - 1) e) + splitPars npars e = __IMPOSSIBLE__ ------------------------------------------------------------------------ -- * Trusted executables ------------------------------------------------------------------------ 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 @@ -17,10 +17,10 @@ ) where import Control.Monad ( forM, unless ) -import Control.Monad.Except +import Control.Monad.Except ( MonadError(..) ) import Control.Monad.Reader ( ReaderT ) import Control.Monad.State ( StateT ) -import Control.Monad.Trans ( lift ) +import Control.Monad.Trans ( MonadTrans, lift ) import qualified Data.List as List import qualified Data.Map as Map diff --git a/src/full/Agda/TypeChecking/With.hs b/src/full/Agda/TypeChecking/With.hs --- a/src/full/Agda/TypeChecking/With.hs +++ b/src/full/Agda/TypeChecking/With.hs @@ -2,6 +2,8 @@ module Agda.TypeChecking.With where +import Prelude hiding ((!!)) + import Control.Monad import Control.Monad.Writer (WriterT, runWriterT, tell) diff --git a/src/full/Agda/Utils/AssocList.hs b/src/full/Agda/Utils/AssocList.hs --- a/src/full/Agda/Utils/AssocList.hs +++ b/src/full/Agda/Utils/AssocList.hs @@ -8,7 +8,7 @@ import Prelude hiding (lookup) -import Data.Function +import Data.Function (on) import Data.List (lookup) import qualified Data.List as List import qualified Data.Map as Map diff --git a/src/full/Agda/Utils/Benchmark.hs b/src/full/Agda/Utils/Benchmark.hs --- a/src/full/Agda/Utils/Benchmark.hs +++ b/src/full/Agda/Utils/Benchmark.hs @@ -15,7 +15,7 @@ import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Monoid import Data.Maybe 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 @@ -12,7 +12,7 @@ import Control.Monad.Identity import Control.Monad.State -import Data.Function +import Data.Function (on) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -58,8 +58,8 @@ -- Every value of this type must satisfy 'biMapInvariant'. data BiMap k v = BiMap - { biMapThere :: Map k v - , biMapBack :: Map (Tag v) k + { biMapThere :: !(Map k v) + , biMapBack :: !(Map (Tag v) k) } deriving Generic @@ -81,6 +81,16 @@ instance Null (BiMap k v) where empty = BiMap Map.empty Map.empty null = null . biMapThere + +-- | Is the value a source key? O(log n). + +source :: Ord k => k -> BiMap k v -> Bool +source k = Map.member k . biMapThere + +-- | Is the value a target key? O(log n). + +target :: Ord (Tag v) => Tag v -> BiMap k v -> Bool +target k = Map.member k . biMapBack -- | Lookup. O(log n). diff --git a/src/full/Agda/Utils/BoolSet.hs b/src/full/Agda/Utils/BoolSet.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/BoolSet.hs @@ -0,0 +1,182 @@ +-- | Representation of @'Set' 'Bool'@ as a 4-element enum type. +-- +-- All operations in constant time and space. +-- +-- Mimics the interface of 'Data.Set'. +-- +-- Import as: +-- @ +-- import qualified Agda.Utils.BoolSet as BoolSet +-- import Agda.Utils.BoolSet (BoolSet) +-- @ + +module Agda.Utils.BoolSet + ( BoolSet + , (\\) + , complement + , delete + , difference + , elems + , empty + , fromList, fromAscList, fromDistinctAscList + , insert + , intersection + , isSubsetOf + , lookupMin + , member + , notMember + , null + , singleton + , size + , toList, toAscList + , toSingleton + , total + , union + ) where + +import Prelude hiding (null) + +import Agda.Utils.Impossible + +-- | Isomorphic to @'Set' 'Bool'@. +data BoolSet = SetEmpty | SetTrue | SetFalse | SetBoth + deriving (Eq, Ord, Show, Enum, Bounded) + +-- * Query + +null :: BoolSet -> Bool +null = (SetEmpty ==) + +size :: BoolSet -> Int +size = \case + SetEmpty -> 0 + SetTrue -> 1 + SetFalse -> 1 + SetBoth -> 2 + +member :: Bool -> BoolSet -> Bool +member b = \case + SetEmpty -> False + SetBoth -> True + SetTrue -> b + SetFalse -> not b + +-- | @not . member b@. +notMember :: Bool -> BoolSet -> Bool +notMember b = not . member b + +isSubsetOf :: BoolSet -> BoolSet -> Bool +isSubsetOf = curry $ \case + (SetEmpty , _ ) -> True + (_ , SetBoth ) -> True + (SetTrue , SetTrue ) -> True + (SetFalse , SetFalse ) -> True + _ -> False + +lookupMin :: BoolSet -> Maybe Bool +lookupMin = \case + SetEmpty -> Nothing + SetTrue -> Just True + _ -> Just False + +-- | @toSingleton s == Just b@ iff @s == singleton b@. +toSingleton :: BoolSet -> Maybe Bool +toSingleton = \case + SetTrue -> Just True + SetFalse -> Just False + _ -> Nothing + +-- * Construction + +-- | The empty set. +empty :: BoolSet +empty = SetEmpty + +-- | The full set. +total :: BoolSet +total = SetBoth + +-- | A singleton set. +singleton :: Bool -> BoolSet +singleton = \case + True -> SetTrue + False -> SetFalse + +insert :: Bool -> BoolSet -> BoolSet +insert b = \case + SetBoth -> SetBoth + SetEmpty -> singleton b + SetTrue -> if b then SetTrue else SetBoth + SetFalse -> if b then SetBoth else SetFalse + +delete :: Bool -> BoolSet -> BoolSet +delete b = \case + SetEmpty -> SetEmpty + SetTrue -> if b then SetEmpty else SetTrue + SetFalse -> if b then SetFalse else SetEmpty + SetBoth -> if b then SetFalse else SetTrue + +-- * Combine + +complement :: BoolSet -> BoolSet +complement = \case + SetEmpty -> SetBoth + SetBoth -> SetEmpty + SetTrue -> SetFalse + SetFalse -> SetTrue + +difference, (\\) :: BoolSet -> BoolSet -> BoolSet +difference = curry $ \case + (SetEmpty , _ ) -> SetEmpty + (_ , SetBoth ) -> SetEmpty + (s , SetEmpty ) -> s + (SetBoth , SetTrue ) -> SetFalse + (SetBoth , SetFalse ) -> SetTrue + (SetTrue , SetTrue ) -> SetEmpty + (SetTrue , SetFalse ) -> SetTrue + (SetFalse , SetTrue ) -> SetFalse + (SetFalse , SetFalse ) -> SetEmpty +(\\) = difference + +intersection :: BoolSet -> BoolSet -> BoolSet +intersection = curry $ \case + (SetEmpty , _ ) -> SetEmpty + (_ , SetEmpty ) -> SetEmpty + (SetBoth , s ) -> s + (s , SetBoth ) -> s + (SetTrue , SetTrue ) -> SetTrue + (SetFalse , SetTrue ) -> SetEmpty + (SetTrue , SetFalse ) -> SetEmpty + (SetFalse , SetFalse ) -> SetFalse + +union :: BoolSet -> BoolSet -> BoolSet +union = curry $ \case + (SetBoth , _ ) -> SetBoth + (_ , SetBoth ) -> SetBoth + (SetEmpty , s ) -> s + (s , SetEmpty ) -> s + (SetTrue , SetTrue ) -> SetTrue + (SetFalse , SetTrue ) -> SetBoth + (SetTrue , SetFalse ) -> SetBoth + (SetFalse , SetFalse ) -> SetFalse + +-- * Conversion + +elems, toList, toAscList :: BoolSet -> [Bool] +elems = \case + SetEmpty -> [] + SetTrue -> [True] + SetFalse -> [False] + SetBoth -> [False, True] +toList = elems +toAscList = elems + +fromList, fromAscList, fromDistinctAscList :: [Bool] -> BoolSet +fromList = foldr insert SetEmpty +fromAscList = fromList +fromDistinctAscList = \case + [] -> SetEmpty + [False] -> SetFalse + [True] -> SetTrue + [False, True] -> SetBoth + _ -> __IMPOSSIBLE__ diff --git a/src/full/Agda/Utils/Cluster.hs b/src/full/Agda/Utils/Cluster.hs --- a/src/full/Agda/Utils/Cluster.hs +++ b/src/full/Agda/Utils/Cluster.hs @@ -3,8 +3,7 @@ -- | Create clusters of non-overlapping things. module Agda.Utils.Cluster - ( C - , cluster + ( cluster , cluster' ) where @@ -14,7 +13,7 @@ import Data.Equivalence.Monad (runEquivT, equateAll, classDesc) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.IntMap as IntMap +import qualified Data.Map.Strict as MapS #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif @@ -23,27 +22,24 @@ import Agda.Utils.Singleton import Agda.Utils.Fail --- | Characteristic identifiers. -type C = Int - --- | Given a function @f :: a -> NonEmpty C@ which returns a non-empty list of --- characteristics @C@ of @a@, partition a list of @a@s into groups --- such that each element in a group shares at least one characteristic +-- | Given a function @f :: a -> NonEmpty c@ which returns a non-empty list of +-- characteristics of @a@, partition a list of @a@s into groups such +-- that each element in a group shares at least one characteristic -- with at least one other element of the group. -cluster :: (a -> NonEmpty C) -> [a] -> [NonEmpty a] +cluster :: Ord c => (a -> NonEmpty c) -> [a] -> [NonEmpty a] cluster f as = cluster' $ map (\ a -> (a, f a)) as -- | Partition a list of @a@s paired with a non-empty list of --- characteristics @C@ into groups --- such that each element in a group shares at least one characteristic --- with at least one other element of the group. -cluster' :: [(a, NonEmpty C)] -> [NonEmpty a] +-- characteristics into groups such that each element in a group +-- shares at least one characteristic with at least one other +-- element of the group. +cluster' :: Ord c => [(a, NonEmpty c)] -> [NonEmpty a] cluster' acs = runFail_ $ runEquivT id const $ do -- Construct the equivalence classes of characteristics. forM_ acs $ \ (_, c :| cs) -> equateAll $ c:cs -- Pair each element with its class. - cas <- forM acs $ \ (a, c :| _) -> classDesc c <&> \ k -> IntMap.singleton k (singleton a) + cas <- forM acs $ \ (a, c :| _) -> classDesc c <&> \ k -> MapS.singleton k (singleton a) -- Create a map from class to elements. - let m = IntMap.unionsWith (<>) cas + let m = MapS.unionsWith (<>) cas -- Return the values of the map - return $ IntMap.elems m + return $ MapS.elems m diff --git a/src/full/Agda/Utils/Empty.hs b/src/full/Agda/Utils/Empty.hs --- a/src/full/Agda/Utils/Empty.hs +++ b/src/full/Agda/Utils/Empty.hs @@ -4,14 +4,10 @@ import Control.DeepSeq import Control.Exception (evaluate) -import Data.Data (Data) - import Agda.Utils.Impossible data Empty - -deriving instance Data Empty -- | Values of type 'Empty' are not forced, because 'Empty' is used as -- a constructor argument in 'Agda.Syntax.Internal.Substitution''. diff --git a/src/full/Agda/Utils/FileName.hs b/src/full/Agda/Utils/FileName.hs --- a/src/full/Agda/Utils/FileName.hs +++ b/src/full/Agda/Utils/FileName.hs @@ -10,6 +10,7 @@ , sameFile , doesFileExistCaseSensitive , isNewerThan + , relativizeAbsolutePath ) where import System.Directory @@ -22,8 +23,7 @@ import System.Win32 ( findFirstFile, findClose, getFindDataFileName ) #endif -import Data.Data ( Data ) -import Data.Function +import Data.Function (on) import Data.Hashable ( Hashable ) import Data.Text ( Text ) import qualified Data.Text as Text @@ -39,7 +39,7 @@ -- paths point to the same files or directories. newtype AbsolutePath = AbsolutePath { textPath :: Text } - deriving (Show, Eq, Ord, Data, Hashable, NFData) + deriving (Show, Eq, Ord, Hashable, NFData) -- | Extract the 'AbsolutePath' to be used as 'FilePath'. filePath :: AbsolutePath -> FilePath @@ -91,7 +91,7 @@ AbsolutePath . Text.pack <$> canonicalizePath (Text.unpack f) -- | Tries to establish if the two file paths point to the same file --- (or directory). +-- (or directory). False negatives may be returned. sameFile :: AbsolutePath -> AbsolutePath -> IO Bool sameFile = liftA2 equalFilePath `on` (canonicalizePath . filePath) @@ -125,3 +125,28 @@ newT <- getModificationTime new oldT <- getModificationTime old return $ newT >= oldT + +-- | A partial version of 'System.FilePath.makeRelative' with flipped arguments, +-- returning 'Nothing' if the given path cannot be relativized to the given @root@. +relativizeAbsolutePath :: + AbsolutePath + -- ^ The absolute path we see to relativize. + -> AbsolutePath + -- ^ The root for relativization. + -> Maybe FilePath + -- ^ The relative path, if any. +relativizeAbsolutePath apath aroot + | rest /= path = Just rest + | otherwise = Nothing + where + path = filePath apath + root = filePath aroot + rest = makeRelative root path + -- Andreas, 2022-10-10 + -- See https://gitlab.haskell.org/haskell/filepath/-/issues/130. + -- 'System.FilePath.makeRelative' is strangely enough a total function, + -- and it returns the original @path@ if it could not be relativized to + -- the @root@, or if the @root@ was ".". + -- In our case, the @root@ is absolute, so we should expect @rest@ to + -- always be different from @path@ if @path@ is relative to @root@. + -- In the extreme case, @root = "/"@ and @path == "/" ++ rest@. diff --git a/src/full/Agda/Utils/Float.hs b/src/full/Agda/Utils/Float.hs --- a/src/full/Agda/Utils/Float.hs +++ b/src/full/Agda/Utils/Float.hs @@ -221,8 +221,10 @@ | isNaN x = nan | otherwise = x -doubleToWord64 :: Double -> Word64 -doubleToWord64 = castDoubleToWord64 . normaliseNaN +doubleToWord64 :: Double -> Maybe Word64 +doubleToWord64 x + | isNaN x = Nothing + | otherwise = Just (castDoubleToWord64 x) -- |Denotational equality for floating point numbers, checks bitwise equality. -- 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 @@ -79,7 +79,7 @@ import qualified Data.Array.IArray as Array import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Function +import Data.Function (on) import qualified Data.Graph as Graph import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap diff --git a/src/full/Agda/Utils/Graph/TopSort.hs b/src/full/Agda/Utils/Graph/TopSort.hs --- a/src/full/Agda/Utils/Graph/TopSort.hs +++ b/src/full/Agda/Utils/Graph/TopSort.hs @@ -3,6 +3,7 @@ ( topSort ) where +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G @@ -21,14 +22,17 @@ -- Note: should be stable to preserve order of generalizable variables. Algorithm due to Richard -- Eisenberg, and works by walking over the list left-to-right and moving each node the minimum -- distance left to guarantee topological ordering. -topSort :: Ord n => [n] -> [(n, n)] -> Maybe [n] -topSort nodes edges = go [] nodes +topSort :: Ord n => Set n -> [(n, n)] -> Maybe [n] +topSort nodes edges = go [] (Set.toList nodes) where -- #4253: The input edges do not necessarily include transitive dependencies, so take transitive -- closure before sorting. w = Just () -- () is not a good edge label since it counts as a "zero" edge and will be ignored - g = G.transitiveClosure $ G.fromNodes nodes `G.union` G.fromEdges [G.Edge a b w | (a, b) <- edges] - deps a = Map.keysSet $ G.graph g Map.! a + g = G.transitiveClosure $ + G.fromNodeSet nodes `G.union` + G.fromEdges [G.Edge a b w | (a, b) <- edges] + -- Only the keys of these maps are used. + deps a = G.graph g Map.! a -- acc: Already sorted nodes in reverse order paired with accumulated set of nodes that must -- come before it @@ -38,10 +42,9 @@ insert a [] = Just [(a, deps a)] insert a bs0@((b, before_b) : bs) | before && after = Nothing - | before = ((b, Set.union before_a before_b) :) <$> insert a bs -- a must come before b - | otherwise = Just $ (a, Set.union before_a before_b) : bs0 + | before = ((b, Map.union before_a before_b) :) <$> insert a bs -- a must come before b + | otherwise = Just $ (a, Map.union before_a before_b) : bs0 where before_a = deps a - before = Set.member a before_b - after = Set.member b before_a - + before = Map.member a before_b + after = Map.member b before_a diff --git a/src/full/Agda/Utils/HashTable.hs b/src/full/Agda/Utils/HashTable.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/HashTable.hs @@ -0,0 +1,57 @@ +------------------------------------------------------------------------ +-- | Hash tables. +------------------------------------------------------------------------ + +module Agda.Utils.HashTable + ( HashTable + , empty + , insert + , lookup + , toList + ) where + +import Prelude hiding (lookup) + +import Data.Hashable +import qualified Data.Vector.Hashtables as H +import qualified Data.Vector.Mutable as VM + +-- | Hash tables. + +-- A very limited amount of (possibly outdated) testing indicates +-- that, for the use in Agda's serialiser/deserialiser, +-- Data.HashTable.IO.CuckooHashTable is somewhat slower than +-- Data.HashTable.IO.BasicHashTable, and that +-- Data.HashTable.IO.LinearHashTable and the hashtables from +-- Data.Hashtable are much slower. However, other (also possibly +-- outdated) testing suggests that Data.HashTable.IO.CuckooHashTable +-- is quite a bit faster than Data.HashTable.IO.BasicHashTable for +-- 64-bit Windows. Some more recent, also limited, testing suggests +-- that the following hash table implementation from +-- Data.Vector.Hashtables is quite a bit faster than +-- Data.HashTable.IO.BasicHashTable (see issue #5966). + +newtype HashTable k v = + HashTable (H.Dictionary (H.PrimState IO) VM.MVector k VM.MVector v) + +-- | An empty hash table. + +empty :: IO (HashTable k v) +empty = HashTable <$> H.initialize 0 + +-- | Inserts the key and the corresponding value into the hash table. + +insert :: (Eq k, Hashable k) => HashTable k v -> k -> v -> IO () +insert (HashTable h) = H.insert h + +-- | Tries to find a value corresponding to the key in the hash table. + +lookup :: (Eq k, Hashable k) => HashTable k v -> k -> IO (Maybe v) +lookup (HashTable h) = H.lookup h + +-- | Converts the hash table to a list. +-- +-- The order of the elements in the list is unspecified. + +toList :: (Eq k, Hashable k) => HashTable k v -> IO [(k, v)] +toList (HashTable h) = H.toList h 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,25 +1,31 @@ -- | Text IO using the UTF8 character encoding. module Agda.Utils.IO.UTF8 - ( readTextFile + ( ReadException + , readTextFile , Agda.Utils.IO.UTF8.readFile , Agda.Utils.IO.UTF8.writeFile , writeTextToFile ) where +import Control.Exception import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T import qualified Data.Text.Lazy.IO as T +import qualified Data.ByteString.Lazy as B import qualified System.IO as IO +import qualified System.IO.Error as E -- | Converts many character sequences which may be interpreted as -- line or paragraph separators into '\n'. --- --- Note that '\r\n' is assumed to have already been converted to '\n'. convertLineEndings :: Text -> Text -convertLineEndings = T.map convert +convertLineEndings = T.map convert . convertCRLF where + -- Replaces CR LF with LF. + convertCRLF = T.replace "\x000D\n" "\n" + -- ASCII: convert '\x000D' = '\n' -- CR (Carriage return) convert '\x000C' = '\n' -- FF (Form feed) @@ -30,21 +36,36 @@ -- Not a line ending (or '\x000A'): convert c = c +-- | A kind of exception that can be thrown by 'readTextFile' and +-- 'readFile'. +newtype ReadException + = DecodingError FilePath + -- ^ Decoding failed for the given file. + deriving Show + +instance Exception ReadException where + displayException (DecodingError file) = + "Failed to read " ++ file ++ ".\n" ++ + "Please ensure that this file uses the UTF-8 character encoding." + -- | Reads a UTF8-encoded text file and converts many character -- sequences which may be interpreted as line or paragraph separators -- into '\n'. +-- +-- If the file cannot be decoded, then a 'ReadException' is raised. readTextFile :: FilePath -> IO Text -readTextFile file = convertLineEndings <$> do - h <- IO.openFile file IO.ReadMode - IO.hSetNewlineMode h $ - IO.NewlineMode { IO.inputNL = IO.CRLF, IO.outputNL = IO.LF } - IO.hSetEncoding h IO.utf8 - T.hGetContents h +readTextFile file = do + s <- T.decodeUtf8' <$> B.readFile file + case s of + Right s -> return $ convertLineEndings s + Left _ -> throw $ DecodingError file -- | Reads a UTF8-encoded text file and converts many character -- sequences which may be interpreted as line or paragraph separators -- into '\n'. +-- +-- If the file cannot be decoded, then a 'ReadException' is raised. readFile :: FilePath -> IO String readFile f = do 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 @@ -7,15 +7,18 @@ import Data.Array (Array, array, listArray) import qualified Data.Array as Array import Data.Bifunctor -import Data.Function +import Data.Function (on) +import Data.Hashable import qualified Data.List as List import qualified Data.List.NonEmpty as List1 import Data.List.NonEmpty (pattern (:|), (<|)) import Data.Maybe import qualified Data.Map as Map +import qualified Data.HashMap.Strict as HMap import qualified Data.Set as Set import qualified Agda.Utils.Bag as Bag +import Agda.Utils.CallStack.Base import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor ((<.>)) import Agda.Utils.Tuple @@ -151,13 +154,27 @@ -- * Lookup and indexing --------------------------------------------------------------------------- --- | Lookup function (partially safe). +-- | Lookup function (safe). -- O(min n index). (!!!) :: [a] -> Int -> Maybe a -[] !!! _ = Nothing -(x : _) !!! 0 = Just x -(_ : xs) !!! n = xs !!! (n - 1) +xs !!! (!i) + | i < 0 = Nothing + | otherwise = index xs i + where + index [] !i = Nothing + index (x : xs) 0 = Just x + index (x : xs) i = index xs (i - 1) +-- | A variant of 'Prelude.!!' that might provide more informative +-- error messages if the index is out of bounds. +-- +-- Precondition: The index should not be out of bounds. + +(!!) :: HasCallStack => [a] -> Int -> a +xs !! i = case xs !!! i of + Just x -> x + Nothing -> __IMPOSSIBLE__ + -- | Lookup function with default value for index out of range. -- O(min n index). -- @@ -420,14 +437,43 @@ | SSSStrip (ReversedSuffix a) -- ^ "Negative string" to remove from end. List may be empty. | SSSResult [a] -- ^ "Positive string" (result). Non-empty list. +-- | Returns a list with one boolean for each non-empty suffix of the +-- list, starting with the longest suffix (the entire list). Each +-- boolean is 'True' exactly when every element in the corresponding +-- suffix satisfies the predicate. +-- +-- An example: +-- @ +-- 'suffixesSatisfying' 'Data.Char.isLower' "AbCde" = +-- [False, False, False, True, True] +-- @ +-- +-- For total predicates @p@ and finite and total lists @xs@ the +-- following holds: +-- @ +-- 'suffixesSatisfying' p xs = 'map' ('all' p) ('List.init' ('List.tails' xs)) +-- @ +suffixesSatisfying :: (a -> Bool) -> [a] -> [Bool] +suffixesSatisfying p = + snd . + foldr (\x (b, bs) -> let !b' = p x && b in (b', b' : bs)) + (True, []) + -- ** Finding overlap --- | Find out whether the first string @xs@ --- has a suffix that is a prefix of the second string @ys@. +-- | Find the longest suffix of the first string @xs@ +-- that is a prefix of the second string @ys@. -- So, basically, find the overlap where the strings can be glued together. -- Returns the index where the overlap starts and the length of the overlap. -- The length of the overlap plus the index is the length of the first string. -- Note that in the worst case, the empty overlap @(length xs,0)@ is returned. +-- +-- Worst-case time complexity is quadratic: @O(min(n,m)²)@ +-- where @n = length xs@ and @m = length ys@. +-- +-- There might be asymptotically better implementations following +-- Knuth-Morris-Pratt (KMP), but for rather short lists this is good enough. +-- findOverlap :: forall a. Eq a => [a] -> [a] -> (Int, Int) findOverlap xs ys = headWithDefault __IMPOSSIBLE__ $ mapMaybe maybePrefix $ zip [0..] (List.tails xs) @@ -460,21 +506,6 @@ [] -> [] ((_, z) : zs) -> grp z zs --- | Split a list into sublists. Generalisation of the prelude function --- @words@. --- O(n). --- --- > words xs == wordsBy isSpace xs -wordsBy :: (a -> Bool) -> [a] -> [[a]] -wordsBy p xs = yesP xs - where - yesP xs = noP (dropWhile p xs) - - noP [] = [] - noP xs = ys : yesP zs - where - (ys,zs) = break p xs - -- | Chop up a list in chunks of a given length. -- O(n). chop :: Int -> [a] -> [[a]] @@ -592,6 +623,38 @@ | b `Set.member` s = loop s as | otherwise = a : loop (Set.insert b s) as where b = f a + +-- | A variant of 'nubOn' that is parametrised by a function that is +-- used to select which element from a group of equal elements that is +-- returned. The returned elements keep the order that they had in the +-- input list. +-- +-- Precondition: The length of the input list must be at most +-- @'maxBound' :: 'Int'@. + +nubFavouriteOn + :: forall a b c. (Ord b, Eq c, Hashable c) + => (a -> b) + -- ^ The values returned by this function are used to determine + -- which element from a group of equal elements that is returned: + -- the smallest one is chosen (and if two elements are equally + -- small, then the first one is chosen). + -> (a -> c) + -- ^ Two elements are treated as equal if this function returns + -- the same value for both elements. + -> [a] -> [a] +nubFavouriteOn fav f = go 0 HMap.empty + where + go :: Int -> HMap.HashMap c ((b, Int), a) -> [a] -> [a] + go !pos !acc (x : xs) = + go (1 + pos) + (HMap.insertWith + (\new old -> if fst new < fst old then new else old) + (f x) ((fav x, pos), x) acc) + xs + go _ acc [] = + map snd $ List.sortBy (compare `on` snd . fst) $ + HMap.elems acc -- -- | Efficient variant of 'nubBy' for finite lists (using sorting). -- -- O(n log 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 @@ -22,6 +22,7 @@ module Agda.Utils.List1 ( module Agda.Utils.List1 , module List1 + , module IsList ) where import Prelude hiding (filter) @@ -35,15 +36,27 @@ import qualified Data.Maybe as Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty as List1 hiding (NonEmpty) +import Data.List.NonEmpty as List1 hiding (fromList, toList) +import qualified Data.List.NonEmpty as List1 (toList) +import GHC.Exts as IsList ( IsList(..) ) + import Agda.Utils.Functor ((<.>)) import Agda.Utils.Null (Null(..)) import qualified Agda.Utils.List as List -type List1 = Data.List.NonEmpty.NonEmpty +type List1 = NonEmpty +type String1 = List1 Char +-- | Safe version of 'Data.List.NonEmpty.fromList'. + +fromListSafe + :: List1 a -- ^ Default value if convertee is empty. + -> [a] -- ^ List to convert, supposedly non-empty. + -> List1 a -- ^ Converted list. +fromListSafe err [] = err +fromListSafe _ (x:xs) = x :| xs + -- | Return the last element and the rest. initLast :: List1 a -> ([a], a) @@ -66,7 +79,7 @@ -- | Prepend a list to a non-empty list. prependList :: [a] -> List1 a -> List1 a -prependList as bs = foldr (<|) bs as +prependList as bs = Prelude.foldr (<|) bs as #endif -- | More precise type for @snoc@. @@ -90,6 +103,20 @@ [] -> [] ((_false, z) : zs) -> grp z zs +-- | Split a list into sublists. Generalisation of the prelude function +-- @words@. +-- Same as 'Data.List.Split.wordsBy' and 'Data.List.Extra.wordsBy', +-- but with the non-emptyness guarantee on the chunks. +-- O(n). +-- +-- > words xs == wordsBy isSpace xs +wordsBy :: (a -> Bool) -> [a] -> [List1 a] +wordsBy p = loop + where + loop as = case List.dropWhile p as of + [] -> [] + x:xs -> (x :| ys) : loop zs where (ys, zs) = List.break p xs + -- | Breaks a list just /after/ an element satisfying the predicate is -- found. -- @@ -171,3 +198,11 @@ zipWithM_ :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m () zipWithM_ f (a :| as) (b :| bs) = f a b *> List.zipWithM_ f as bs + +-- | List 'Data.List.foldr' but with a base case for the singleton list. + +foldr :: (a -> b -> b) -> (a -> b) -> List1 a -> b +foldr f g (x :| xs) = loop x xs + where + loop x [] = g x + loop x (y : ys) = f x $ loop y ys diff --git a/src/full/Agda/Utils/List2.hs b/src/full/Agda/Utils/List2.hs --- a/src/full/Agda/Utils/List2.hs +++ b/src/full/Agda/Utils/List2.hs @@ -15,7 +15,6 @@ import Control.DeepSeq import Control.Monad ( (<=<) ) -import Data.Data ( Data ) import qualified Data.List as List import GHC.Exts ( IsList(..) ) @@ -28,21 +27,32 @@ -- | Lists of length ≥2. data List2 a = List2 a a [a] - deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) --- | Safe. O(1). -head :: List2 a -> a -head (List2 a _ _) = a +-- * Conversion from and to other list types. --- | Safe. O(1). -tail :: List2 a -> List1 a -tail (List2 a b cs) = b :| cs +-- | 'fromList' is unsafe. +instance IsList (List2 a) where + type Item (List2 a) = a --- | Safe. O(n). -init :: List2 a -> List1 a -init (List2 a b cs) = a :| List1.init (b :| cs) + -- Unsafe! O(1). + fromList :: [a] -> List2 a + fromList (a : b : cs) = List2 a b cs + fromList _ = __IMPOSSIBLE__ + toList :: List2 a -> [a] + toList (List2 a b cs) = a : b : cs + +-- | Unsafe! O(1). +fromList1 :: List1 a -> List2 a +fromList1 (a :| b : cs) = List2 a b cs +fromList1 _ = __IMPOSSIBLE__ + -- | Safe. O(1). +toList1 :: List2 a -> List1 a +toList1 (List2 a b cs) = a :| b : cs + +-- | Safe. O(1). fromListMaybe :: [a] -> Maybe (List2 a) fromListMaybe = fromList1Maybe <=< List1.nonEmpty @@ -52,25 +62,47 @@ (a :| b : cs) -> Just (List2 a b cs) _ -> Nothing -instance IsList (List2 a) where - type Item (List2 a) = a +-- | Any 'List1' is either a singleton or a 'List2'. O(1). +fromList1Either :: List1 a -> Either a (List2 a) +fromList1Either (a :| as) = case as of + [] -> Left a + b:bs -> Right (List2 a b bs) - -- Unsafe! O(1). - fromList :: [a] -> List2 a - fromList (a : b : cs) = List2 a b cs - fromList _ = __IMPOSSIBLE__ +-- | Inverse of 'fromList1Either'. O(1). +toList1Either :: Either a (List2 a) -> List1 a +toList1Either = \case + Left a -> a :| [] + Right (List2 a b bs) -> a :| b : bs - toList :: List2 a -> [a] - toList (List2 a b cs) = a : b : cs +-- * Construction +-- | O(1). +cons :: a -> List1 a -> List2 a +cons x (y :| ys) = List2 x y ys + +-- | O(length first list). +append :: List1 a -> List1 a -> List2 a +append (x :| xs) ys = cons x $ List1.prependList xs ys + +-- | O(length first list). +appendList :: List2 a -> [a] -> List2 a +appendList (List2 x y ys) zs = List2 x y $ mappend ys zs + +-- * Destruction + -- | Safe. O(1). -toList1 :: List2 a -> List1 a -toList1 (List2 a b cs) = a :| b : cs +head :: List2 a -> a +head (List2 a _ _) = a --- | Unsafe! -fromList1 :: List1 a -> List2 a -fromList1 (a :| b : cs) = List2 a b cs -fromList1 _ = __IMPOSSIBLE__ +-- | Safe. O(1). +tail :: List2 a -> List1 a +tail (List2 a b cs) = b :| cs + +-- | Safe. O(n). +init :: List2 a -> List1 a +init (List2 a b cs) = a :| List1.init (b :| cs) + +-- * Partition break :: (a -> Bool) -> List2 a -> ([a],[a]) break p = List.break p . toList diff --git a/src/full/Agda/Utils/Maybe/Strict.hs b/src/full/Agda/Utils/Maybe/Strict.hs --- a/src/full/Agda/Utils/Maybe/Strict.hs +++ b/src/full/Agda/Utils/Maybe/Strict.hs @@ -1,14 +1,3 @@ --- Liang-Ting Chen (2019-07-04): --- Consider using Data.Maybe.Strict instead --- Andreas Abel (2019-07-05)@GitHub: --- The dependencies of strict-base-types are too heavy, --- especially since it depends on lens which we consciously ruled out. - -{-# LANGUAGE CPP #-} - - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -- | A strict version of the 'Maybe' type. -- -- Import qualified, as in @@ -24,62 +13,17 @@ module Agda.Utils.Maybe.Strict ( module Data.Strict.Maybe + , module Data.Strict.Classes , module Agda.Utils.Maybe.Strict ) where --- The following code is copied from --- http://hackage.haskell.org/package/strict-base-types-0.3.0/docs/src/Data-Maybe-Strict.html - -import Prelude hiding (Maybe (..), maybe, null) -import qualified Prelude as Lazy +import Prelude hiding (Maybe(..), maybe) -import Control.DeepSeq (NFData (..)) -import Data.Binary (Binary (..)) -import Data.Data (Data (..)) -import Data.Semigroup (Semigroup, (<>)) -import Data.Strict.Maybe (Maybe (Nothing, Just), fromJust, - fromMaybe, isJust, isNothing, maybe) -import GHC.Generics (Generic (..)) +import Data.Strict.Classes +import Data.Strict.Maybe import Agda.Utils.Null -toStrict :: Lazy.Maybe a -> Maybe a -toStrict Lazy.Nothing = Nothing -toStrict (Lazy.Just x) = Just x - -toLazy :: Maybe a -> Lazy.Maybe a -toLazy Nothing = Lazy.Nothing -toLazy (Just x) = Lazy.Just x - -#if !(MIN_VERSION_strict(0,4,0)) -deriving instance Data a => Data (Maybe a) -deriving instance Generic (Maybe a) - --- The monoid instance was fixed in strict-base-types 0.5.0. See --- Issue 1805. -instance Semigroup a => Semigroup (Maybe a) where - (<>) = unionMaybeWith (<>) - -instance Semigroup a => Monoid (Maybe a) where - mempty = Nothing - mappend = (<>) - -instance Foldable Maybe where - foldMap _ Nothing = mempty - foldMap f (Just x) = f x - -instance Traversable Maybe where - traverse _ Nothing = pure Nothing - traverse f (Just x) = Just <$> f x - -instance NFData a => NFData (Maybe a) where - rnf = rnf . toLazy - -instance Binary a => Binary (Maybe a) where - put = put . toLazy - get = toStrict <$> get -#endif - -- | Note that strict Maybe is an 'Applicative' only modulo strictness. -- The laws only hold in the strict semantics. -- Eg. @pure f <*> pure _|_ = _|_@, but according to the laws for @@ -94,31 +38,6 @@ instance Null (Maybe a) where empty = Nothing null = isNothing - --- | Analogous to 'Lazy.listToMaybe' in "Data.Maybe". -listToMaybe :: [a] -> Maybe a -listToMaybe [] = Nothing -listToMaybe (a:_) = Just a - --- | Analogous to 'Lazy.maybeToList' in "Data.Maybe". -maybeToList :: Maybe a -> [a] -maybeToList Nothing = [] -maybeToList (Just x) = [x] - --- | Analogous to 'Lazy.catMaybes' in "Data.Maybe". -catMaybes :: [Maybe a] -> [a] -catMaybes ls = [x | Just x <- ls] - --- | Analogous to 'Lazy.mapMaybe' in "Data.Maybe". -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe _ [] = [] -mapMaybe f (x:xs) = case f x of - Nothing -> rs - Just r -> r:rs - where - rs = mapMaybe f xs - --- The remaining code is a copy of Agda.Utils.Maybe -- * Collection operations. 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 @@ -7,11 +7,15 @@ ) where -import Control.Applicative ( liftA2 ) -import Control.Monad ( MonadPlus(..), guard, unless, when ) -import Control.Monad.Except ( MonadError(catchError, throwError) ) -import Control.Monad.State ( MonadState(get, put) ) +import Control.Applicative ( liftA2 ) +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) ) +import Control.Monad.Writer ( MonadWriter(tell), Writer, WriterT, mapWriterT ) +import Data.Bifunctor ( first, second ) +import Data.Bool ( bool ) import Data.Traversable as Trav hiding (for, sequence) import Data.Foldable as Fold import Data.Maybe @@ -19,7 +23,8 @@ import Agda.Utils.Applicative import Agda.Utils.Either -import Agda.Utils.Null (ifNotNullM) +import Agda.Utils.Null (empty, ifNotNullM) +import Agda.Utils.Singleton import Agda.Utils.Impossible @@ -54,20 +59,20 @@ and2M ma mb = ifM ma mb (return False) andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool -andM = Fold.foldl and2M (return True) +andM = Fold.foldl' and2M (return True) -allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool -allM xs f = andM $ fmap f xs +allM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool +allM xs f = Fold.foldl' (\b -> and2M b . f) (return True) xs -- | Lazy monadic disjunction. or2M :: Monad m => m Bool -> m Bool -> m Bool or2M ma = ifM ma (return True) orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool -orM = Fold.foldl or2M (return False) +orM = Fold.foldl' or2M (return False) -anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool -anyM xs f = orM $ fmap f xs +anyM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool +anyM xs f = Fold.foldl' (\b -> or2M b . f) (return False) xs -- | Lazy monadic disjunction with @Either@ truth values. -- Returns the last error message if all fail. @@ -164,11 +169,9 @@ -- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a]) partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a]) -partitionM f xs = - foldr - (\x -> (<*>) ((\b (l, r) -> if b then (x : l, r) else (l, x : r)) <$> f x)) - (pure ([], [])) - xs +partitionM f = + foldr (\ x mlr -> bool (first (x:)) (second (x:)) <$> f x <*> mlr) + (pure empty) -- MonadPlus ----------------------------------------------------------------- @@ -231,3 +234,12 @@ -- | Restore state after computation. localState :: MonadState s m => m a -> m a localState = bracket_ get put + +-- Writer monad ----------------------------------------------------------- + +embedWriter :: (Monoid w, Monad m) => Writer w a -> WriterT w m a +embedWriter = mapWriterT (pure . runIdentity) + +-- | Output a single value. +tell1 :: (Monoid ws, Singleton w ws, MonadWriter ws m) => w -> m () +tell1 = tell . singleton 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 @@ -8,8 +8,12 @@ import Prelude hiding (null) import Control.Monad -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad.Except ( ExceptT ) +import Control.Monad.Identity ( Identity(..) ) +import Control.Monad.Reader ( ReaderT ) +import Control.Monad.State ( StateT ) +import Control.Monad.Writer ( WriterT ) +import Control.Monad.Trans ( lift ) import qualified Data.ByteString.Char8 as ByteStringChar8 import qualified Data.ByteString.Lazy as ByteStringLazy @@ -122,11 +126,27 @@ empty = mempty null = isEmpty +instance Null a => Null (Identity a) where + empty = return empty + null = null . runIdentity + +instance Null a => Null (IO a) where + empty = return empty + null = __IMPOSSIBLE__ + +instance (Null (m a), Monad m) => Null (ExceptT e m a) where + empty = lift empty + null = __IMPOSSIBLE__ + instance (Null (m a), Monad m) => Null (ReaderT r m a) where empty = lift empty null = __IMPOSSIBLE__ -instance (Null (m a), Monad m) => Null (StateT r m a) where +instance (Null (m a), Monad m) => Null (StateT s m a) where + empty = lift empty + null = __IMPOSSIBLE__ + +instance (Null (m a), Monad m, Monoid w) => Null (WriterT w m a) where empty = lift empty null = __IMPOSSIBLE__ diff --git a/src/full/Agda/Utils/Permutation.hs b/src/full/Agda/Utils/Permutation.hs --- a/src/full/Agda/Utils/Permutation.hs +++ b/src/full/Agda/Utils/Permutation.hs @@ -6,19 +6,18 @@ import Control.DeepSeq import Control.Monad (filterM) +import Data.Array.Unboxed import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import qualified Data.IntMap.Strict as IntMapS +import qualified Data.IntSet as IntSet import Data.Functor.Identity import qualified Data.List as List import Data.Maybe -import Data.Array -import Data.Data (Data) - import GHC.Generics (Generic) import Agda.Utils.Functor -import Agda.Utils.List ((!!!)) import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Tuple @@ -37,7 +36,7 @@ -- @Perm : {m : Nat}(n : Nat) -> Vec (Fin n) m -> Permutation@ -- @m@ is the 'size' of the permutation. data Permutation = Perm { permRange :: Int, permPicks :: [Int] } - deriving (Eq, Data, Generic) + deriving (Eq, Generic) instance Show Permutation where show (Perm n xs) = showx [0..n - 1] ++ " -> " ++ showx xs @@ -63,15 +62,45 @@ -- -- Agda typing: -- @permute (Perm {m} n is) : Vec A m -> Vec A n@ +-- +-- Precondition for @'permute' ('Perm' _ is) xs@: Every index in @is@ +-- must be non-negative and, if @xs@ is finite, then every index must +-- also be smaller than the length of @xs@. +-- +-- The implementation is supposed to be extensionally equal to the +-- following one (if different exceptions are identified), but in some +-- cases more efficient: +-- @ +-- permute ('Perm' _ is) xs = 'map' (xs 'Agda.Utils.List.!!') is +-- @ permute :: Permutation -> [a] -> [a] -permute p xs = map (fromMaybe __IMPOSSIBLE__) (safePermute p xs) - -safePermute :: Permutation -> [a] -> [Maybe a] -safePermute (Perm _ is) xs = map (xs !!!!) is +permute (Perm _ is) xs = go mempty 0 xs is where - xs !!!! n | n < 0 = Nothing - | otherwise = xs !!! n + -- Computes the list of permuted elements. + go :: IntMap a -- A map from positions to elements that have + -- already been seen. + -> Int -- The number of elements that have been seen (the + -- size of the map). + -> [a] -- Elements that have not yet been seen. + -> [Int] -- Indices to process. + -> [a] + go seen !n xs [] = [] + go seen n xs (i : is) + | i < n = fromMaybe __IMPOSSIBLE__ + (IntMap.lookup i seen) : + go seen n xs is + | otherwise = scan seen n xs (i - n) is + -- Finds the element at the given position and continues. + scan :: IntMap a -> Int -> [a] -> Int -> [Int] -> [a] + scan seen !n (x : xs) !i is + | i == 0 = x : (go $! seen') n' xs is + | i > 0 = (scan $! seen') n' xs (i - 1) is + where + seen' = IntMap.insert n x seen + n' = n + 1 + scan seen n xs !_ is = __IMPOSSIBLE__ : go seen n xs is + -- | Invert a Permutation on a partial finite int map. -- @inversePermute perm f = f'@ -- such that @permute perm f' = f@ @@ -100,7 +129,10 @@ where tabulate m = for [0..n-1] $ \ i -> IntMap.lookup i m instance InversePermute (Int -> a) [Maybe a] where - inversePermute (Perm n xs) f = for [0..n-1] $ \ x -> f <$> List.elemIndex x xs + inversePermute (Perm n xs) f = + for [0..n-1] $ \i -> f <$> IntMap.lookup i m + where + m = IntMapS.fromListWith (flip const) $ zip xs [0..] -- | Identity permutation. idP :: Int -> Permutation @@ -112,7 +144,11 @@ -- | Pick the elements that are not picked by the permutation. droppedP :: Permutation -> Permutation -droppedP (Perm n xs) = Perm n $ [0..n-1] List.\\ xs +droppedP (Perm n xs) = Perm n $ filter (notInXs !) [0 .. n - 1] + where + notInXs :: UArray Int Bool + notInXs = + accumArray (flip const) True (0, n - 1) (zip xs (repeat False)) -- | @liftP k@ takes a @Perm {m} n@ to a @Perm {m+k} (n+k)@. -- Analogous to 'Agda.TypeChecking.Substitution.liftS', @@ -141,16 +177,19 @@ -- @composeP p (invertP err p) == p@ invertP :: Int -> Permutation -> Permutation invertP err p@(Perm n xs) = Perm (size xs) $ elems tmpArray - where tmpArray = accumArray (const id) err (0, n-1) $ zip xs [0..] + where + -- This array cannot be unboxed, because it should be possible to + -- instantiate err with __IMPOSSIBLE__. + tmpArray :: Array Int Int + tmpArray = accumArray (const id) err (0, n-1) $ zip xs [0..] -- | Turn a possible non-surjective permutation into a surjective permutation. compactP :: Permutation -> Permutation -compactP (Perm n xs) = Perm m $ map adjust xs +compactP p@(Perm _ xs) = Perm (length xs) $ map adjust xs where - m = List.genericLength xs - missing = [0..n - 1] List.\\ xs - holesBelow k = List.genericLength $ filter (< k) missing - adjust k = k - holesBelow k + missing = IntSet.fromList $ permPicks $ droppedP p + holesBelow k = IntSet.size $ fst $ IntSet.split k missing + adjust k = k - holesBelow k -- | @permute (reverseP p) xs == -- reverse $ permute p $ reverse xs@ @@ -225,7 +264,7 @@ { dropN :: Int -- ^ Non-negative number of things to drop. , dropFrom :: a -- ^ Where to drop from. } - deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) -- | Things that support delayed dropping. class DoDrop a where diff --git a/src/full/Agda/Utils/Pointer.hs b/src/full/Agda/Utils/Pointer.hs --- a/src/full/Agda/Utils/Pointer.hs +++ b/src/full/Agda/Utils/Pointer.hs @@ -7,26 +7,16 @@ import Control.DeepSeq import Control.Concurrent.MVar -import Data.Function +import Data.Function (on) import Data.Hashable import Data.IORef import System.IO.Unsafe -import Data.Data (Data (..)) -import Data.Typeable (Typeable) - import Agda.Utils.Impossible data Ptr a = Ptr { ptrTag :: !Integer , ptrRef :: !(IORef a) } - deriving Data - --- cheating because you shouldn't be digging this far anyway -instance Typeable a => Data (IORef a) where - gunfold _ _ _ = __IMPOSSIBLE__ - toConstr = __IMPOSSIBLE__ - dataTypeOf = __IMPOSSIBLE__ {-# NOINLINE freshVar #-} freshVar :: MVar Integer diff --git a/src/full/Agda/Utils/Pretty.hs b/src/full/Agda/Utils/Pretty.hs --- a/src/full/Agda/Utils/Pretty.hs +++ b/src/full/Agda/Utils/Pretty.hs @@ -10,7 +10,6 @@ import Prelude hiding (null) -import Data.Data (Data(..)) import qualified Data.Foldable as Fold import Data.Int (Int32) import Data.IntSet (IntSet) @@ -174,12 +173,6 @@ -- | Handles strings with newlines properly (preserving indentation) multiLineText :: String -> Doc multiLineText = vcat . map text . lines - --- cheating because you shouldn't be digging this far anyway -instance Data Doc where - gunfold _ _ _ = __IMPOSSIBLE__ - toConstr = __IMPOSSIBLE__ - dataTypeOf = __IMPOSSIBLE__ infixl 6 -- | @a b = hang a 2 b@ diff --git a/src/full/Agda/Utils/ProfileOptions.hs b/src/full/Agda/Utils/ProfileOptions.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/ProfileOptions.hs @@ -0,0 +1,107 @@ + +module Agda.Utils.ProfileOptions + ( ProfileOption(..) + , ProfileOptions + , noProfileOptions + , addProfileOption + , containsProfileOption + , profileOptionsToList + , profileOptionsFromList + , validProfileOptionStrings + ) where + +import Control.DeepSeq +import Control.Monad +import Data.List (intercalate) +import Data.Char (toLower) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import GHC.Generics (Generic) +import Text.EditDistance (restrictedDamerauLevenshteinDistance, defaultEditCosts) + +-- | Various things that can be measured when checking an Agda development. Turned on with +-- the `--profile` flag, for instance `--profile=sharing` to turn on the 'Sharing' option. +-- 'Internal', 'Modules', and 'Definitions' are mutually exclusive. +-- +-- NOTE: Changing this data type requires bumping the interface version number in +-- 'Agda.TypeChecking.Serialise.currentInterfaceVersion'. +data ProfileOption = Internal -- ^ Measure time taken by various parts of the system (type checking, serialization, etc) + | Modules -- ^ Measure time spent on individual (Agda) modules + | Definitions -- ^ Measure time spent on individual (Agda) definitions + | Sharing -- ^ Measure things related to sharing + | Serialize -- ^ Collect detailed statistics about serialization + | Constraints -- ^ Collect statistics about constraint solving + | Metas -- ^ Count number of created metavariables + | Interactive -- ^ Measure time of interactive commands + | Conversion -- ^ Collect statistics about conversion checking + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance NFData ProfileOption + +-- | A set of 'ProfileOption's +newtype ProfileOptions = ProfileOpts { unProfileOpts :: Set ProfileOption } + deriving (Show, Eq, NFData) + +-- | The empty set of profiling options. +noProfileOptions :: ProfileOptions +noProfileOptions = ProfileOpts Set.empty + +addAllProfileOptions :: ProfileOptions -> ProfileOptions +addAllProfileOptions (ProfileOpts opts) = ProfileOpts $ foldl ins opts [minBound..maxBound] + where + ins os o | any (incompatible o) os = os + | otherwise = Set.insert o os + +-- | Strings accepted by 'addProfileOption' +validProfileOptionStrings :: [String] +validProfileOptionStrings = "all" : map optName [minBound .. maxBound :: ProfileOption] + +parseOpt :: String -> Either String ProfileOption +parseOpt = \ s -> case Map.lookup s names of + Nothing -> Left $ err s + Just o -> Right o + where + names = Map.fromList [ (optName o, o) | o <- [minBound .. maxBound] ] + + close s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t <= 3 + err s = concat ["Not a valid profiling option: '", s, "'. ", hint s] + hint s = case filter (close s) (Map.keys names) of + [] -> concat [ "Valid options are ", intercalate ", " $ Map.keys names, ", or all." ] + ss -> concat [ "Did you mean ", intercalate " or " ss, "?" ] + +optName :: ProfileOption -> String +optName = map toLower . show + +incompatible :: ProfileOption -> ProfileOption -> Bool +incompatible o1 o2 + | o1 == o2 = False + | otherwise = any (\ set -> elem o1 set && elem o2 set) sets + where + sets = [[Internal, Modules, Definitions]] + +-- | Parse and add a profiling option to a set of profiling options. Returns `Left` with a helpful +-- error message if the option doesn't parse or if it's incompatible with existing options. +-- The special string "all" adds all options compatible with the given set and prefering the first +-- of incompatible options. So `--profile=all` sets 'Internal' over 'Modules' and 'Definitions', +-- but `--profile=modules --profile=all` sets 'Modules' and not 'Internal'. +addProfileOption :: String -> ProfileOptions -> Either String ProfileOptions +addProfileOption "all" opts = pure $ addAllProfileOptions opts +addProfileOption s (ProfileOpts opts) = do + o <- parseOpt s + let conflicts = filter (incompatible o) (Set.toList opts) + unless (null conflicts) $ Left $ concat ["Cannot use profiling option '", s, "' with '", optName $ head $ conflicts, "'"] + return $ ProfileOpts $ Set.insert o opts + +-- | Check if a given profiling option is present in a set of profiling options. +containsProfileOption :: ProfileOption -> ProfileOptions -> Bool +containsProfileOption o (ProfileOpts opts) = Set.member o opts + +-- | Use only for serialization. +profileOptionsToList :: ProfileOptions -> [ProfileOption] +profileOptionsToList (ProfileOpts opts) = Set.toList opts + +-- | Use only for serialization. +profileOptionsFromList :: [ProfileOption] -> ProfileOptions +profileOptionsFromList opts = ProfileOpts $ Set.fromList opts diff --git a/src/full/Agda/Utils/Singleton.hs b/src/full/Agda/Utils/Singleton.hs --- a/src/full/Agda/Utils/Singleton.hs +++ b/src/full/Agda/Utils/Singleton.hs @@ -6,6 +6,8 @@ import Data.Semigroup (Semigroup(..)) import Data.Monoid (Endo(..)) +import Data.DList (DList) +import qualified Data.DList as DL import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -36,6 +38,7 @@ instance Collection a [a] where fromList = id instance Collection a ([a] -> [a]) where fromList = (++) instance Collection a (Endo [a]) where fromList = Endo . fromList +instance Collection a (DList a) where fromList = DL.fromList instance Collection a (Seq a) where fromList = Seq.fromList instance Collection Int IntSet where fromList = IntSet.fromList instance Collection (Int,a) (IntMap a) where fromList = IntMap.fromList @@ -61,6 +64,7 @@ instance Singleton a [a] where singleton = (:[]) instance Singleton a ([a] -> [a]) where singleton = (:) instance Singleton a (Endo [a]) where singleton = Endo . (:) +instance Singleton a (DList a) where singleton = DL.singleton instance Singleton a (NonEmpty a) where singleton = (:| []) instance Singleton a (Seq a) where singleton = Seq.singleton 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 @@ -25,7 +25,7 @@ , insert , intersection , isSubsetOf - , mapMemberShip + , mapMembership , member , notMember , null @@ -33,7 +33,7 @@ , toList, toAscList , total , union - , zipMemberShipWith + , zipMembershipWith ) where import Prelude hiding (null) @@ -42,14 +42,20 @@ import Data.Array.IArray (Ix, Array) import qualified Data.Array.IArray as Array -import Data.Data (Data) -- Note: we might want to use unboxed arrays, but they have no Data instance +-- +-- Update: There is currently no need for a Data instance. An attempt +-- was made to replace Array with Data.Array.Unboxed.UArray. Limited +-- testing suggested that this does not make much of a difference in +-- practice (at least not when it comes to type-checking the standard +-- library up to and including Data.Nat, with Agda compiled without +-- -foptimise-heavily). -- | Let @n@ be the size of type @a@. type SmallSetElement a = (Bounded a, Ix a) newtype SmallSet a = SmallSet { theSmallSet :: Array a Bool } - deriving (Eq, Ord, Show, Data, NFData) + deriving (Eq, Ord, Show, NFData) -- * Query @@ -96,28 +102,28 @@ -- | Time O(n). complement :: SmallSetElement a => SmallSet a -> SmallSet a -complement = mapMemberShip not +complement = mapMembership not -- | Time O(n). difference, (\\) :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a -difference = zipMemberShipWith $ \ b c -> b && not c +difference = zipMembershipWith $ \ b c -> b && not c (\\) = difference -- | Time O(n). intersection :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a -intersection = zipMemberShipWith (&&) +intersection = zipMembershipWith (&&) -- | Time O(n). union :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a -union = zipMemberShipWith (||) +union = zipMembershipWith (||) -- | Time O(n). -mapMemberShip :: SmallSetElement a => (Bool -> Bool) -> SmallSet a -> SmallSet a -mapMemberShip f = SmallSet . Array.amap f . theSmallSet +mapMembership :: SmallSetElement a => (Bool -> Bool) -> SmallSet a -> SmallSet a +mapMembership f = SmallSet . Array.amap f . theSmallSet -- | Time O(n). -zipMemberShipWith :: SmallSetElement a => (Bool -> Bool -> Bool) -> SmallSet a -> SmallSet a -> SmallSet a -zipMemberShipWith f s t = fromBoolList $ toBoolListZipWith f s t +zipMembershipWith :: SmallSetElement a => (Bool -> Bool -> Bool) -> SmallSet a -> SmallSet a -> SmallSet a +zipMembershipWith f s t = fromBoolList $ toBoolListZipWith f s t -- * Conversion diff --git a/src/full/Agda/Utils/Trie.hs b/src/full/Agda/Utils/Trie.hs --- a/src/full/Agda/Utils/Trie.hs +++ b/src/full/Agda/Utils/Trie.hs @@ -14,7 +14,7 @@ import Control.DeepSeq -import Data.Function +import Data.Function (on) import qualified Data.Maybe as Lazy import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map diff --git a/src/full/Agda/Utils/Warshall.hs b/src/full/Agda/Utils/Warshall.hs --- a/src/full/Agda/Utils/Warshall.hs +++ b/src/full/Agda/Utils/Warshall.hs @@ -11,6 +11,8 @@ -} module Agda.Utils.Warshall where +import Prelude hiding ((!!)) + import Control.Monad.State import Data.Maybe @@ -20,7 +22,7 @@ import qualified Data.Map as Map import Agda.Utils.SemiRing -import Agda.Utils.List (nubOn) +import Agda.Utils.List ((!!), nubOn) import Agda.Utils.Pretty as P import Agda.Utils.Impossible diff --git a/src/full/Agda/Version.hs b/src/full/Agda/Version.hs --- a/src/full/Agda/Version.hs +++ b/src/full/Agda/Version.hs @@ -1,6 +1,7 @@ module Agda.Version ( version , package + , docsUrl ) where import GHC.Generics ( Generic, Rep, packageName ) @@ -21,5 +22,10 @@ package :: String package = packageName (undefined :: Rep AnArbitrarySymbolInThisPackage p) + +-- | Returns a URL corresponding to the given section in the documentation for +-- the current version. +docsUrl :: String -> String +docsUrl section = "https://agda.readthedocs.io/en/v" ++ version ++ "/" ++ section data AnArbitrarySymbolInThisPackage deriving Generic diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,27 +3,41 @@ compiler-check: match-exact extra-deps: -- QuickCheck-2.14.2 +- Cabal-3.6.3.0 - ansi-terminal-0.10.3 - ansi-wl-pprint-0.6.9 +- assoc-1.0.2 - async-2.2.1 +- base-orphans-0.8.7 +- bifunctors-5.5.13 - binary-0.8.3.0 +- cabal-doctest-1.0.9 +- comonad-5.0.8 - cpphs-1.20.9 - containers-0.5.11.0 +- happy-1.20.0 +- hashable-1.2.7.0 +- indexed-traversable-0.1.2 - optparse-applicative-0.15.1.0 - parallel-3.2.2.0 +- parsec-3.1.15.1 +- primitive-0.7.2.0 +- profunctors-5.2.2 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 +- scientific-0.3.6.2 - splitmix-0.1.0.3 -- tasty-1.1.0.4 -- tasty-silver-3.1.13 -- tasty-quickcheck-0.10.1.1 +- strict-0.4.0.1 +- tagged-0.8.6.1 - text-1.2.3.1 +- th-abstraction-0.4.5.0 +- these-1.1.1.1 - uuid-types-1.0.3 +- vector-0.12.3.1 +- vector-hashtables-0.1.1.1 - wcwidth-0.0.2 -- text-icu-0.7.1.0 +- text-icu-0.8.0.2 -# Local packages, usually specified by relative directory name -packages: -- '.' +# instead of time-1.9, we add time-compat +- time-compat-1.9.2.2 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 @@ -1,7 +1,7 @@ -resolver: lts-18.22 +resolver: lts-18.28 compiler: ghc-8.10.7 compiler-check: match-exact -# Local packages, usually specified by relative directory name -packages: -- '.' +extra-deps: +- text-icu-0.8.0.2 +- vector-hashtables-0.1.1.1 diff --git a/stack-8.2.2.yaml b/stack-8.2.2.yaml --- a/stack-8.2.2.yaml +++ b/stack-8.2.2.yaml @@ -3,22 +3,39 @@ compiler-check: match-exact extra-deps: -- QuickCheck-2.14.2 +- OneTuple-0.3 +- StateVar-1.2.2 +- aeson-1.5.6.0 +- assoc-1.0.2 - async-2.2.1 +- base-compat-0.12.2 +- base-compat-batteries-0.12.2 +- base-orphans-0.8.7 +- bifunctors-5.5.13 - binary-0.8.3.0 - cpphs-1.20.9 +- comonad-5.0.8 - containers-0.5.11.0 +- contravariant-1.5.5 +- data-fix-0.3.2 +- generic-deriving-1.14.2 +- indexed-traversable-0.1.2 +- primitive-0.7.4.0 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - splitmix-0.1.0.3 -- tasty-1.1.0.4 -- tasty-silver-3.1.13 +- strict-0.4.0.1 +- tagged-0.8.6.1 - text-1.2.3.1 +- th-abstraction-0.4.5.0 +- these-1.1.1.1 +- unordered-containers-0.2.19.1 - uuid-types-1.0.3 +- vector-0.12.3.1 +- vector-hashtables-0.1.1.1 - wcwidth-0.0.2 -- text-icu-0.7.1.0 +- text-icu-0.8.0.2 -# Local packages, usually specified by relative directory name -packages: -- '.' +# instead of time-1.9, we add time-compat +- time-compat-1.9.5 diff --git a/stack-8.4.4.yaml b/stack-8.4.4.yaml --- a/stack-8.4.4.yaml +++ b/stack-8.4.4.yaml @@ -3,16 +3,28 @@ compiler-check: match-exact extra-deps: -- QuickCheck-2.14.2 +- aeson-1.5.6.0 +- assoc-1.0.2 +- base-orphans-0.8.7 +- bifunctors-5.5.13 +- comonad-5.0.8 - cpphs-1.20.9 +- data-fix-0.3.2 +- generic-deriving-1.14.2 +- indexed-traversable-0.1.2 +- primitive-0.7.4.0 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - splitmix-0.1.0.3 -- tasty-silver-3.1.13 - uuid-types-1.0.3 -- text-icu-0.7.1.0 +- strict-0.4.0.1 +- tagged-0.8.6.1 +- text-icu-0.8.0.2 +- th-abstraction-0.4.5.0 +- these-1.1.1.1 +- unordered-containers-0.2.19.1 +- vector-hashtables-0.1.1.1 -# Local packages, usually specified by relative directory name -packages: -- '.' +# instead of time-1.9, we add time-compat +- time-compat-1.9.5 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -3,19 +3,18 @@ compiler-check: match-exact extra-deps: -- QuickCheck-2.14.2 - STMonadTrans-0.4.3 - cpphs-1.20.9 - data-hash-0.2.0.1 - equivalence-0.3.4 - geniplate-mirror-0.7.6 +- primitive-0.7.4.0 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - splitmix-0.1.0.3 +- strict-0.4.0.1 +- these-1.1.1.1 - uuid-types-1.0.3 -- text-icu-0.7.1.0 - -# Local packages, usually specified by relative directory name -packages: -- '.' +- 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,11 +3,9 @@ compiler-check: match-exact extra-deps: -- QuickCheck-2.14.2 +- primitive-0.7.4.0 - random-1.2.0 - splitmix-0.1.0.3 -- text-icu-0.7.1.0 - -# Local packages, usually specified by relative directory name -packages: - - '.' +- strict-0.4.0.1 +- text-icu-0.8.0.2 +- vector-hashtables-0.1.1.1 diff --git a/stack-9.0.1.yaml b/stack-9.0.1.yaml deleted file mode 100644 --- a/stack-9.0.1.yaml +++ /dev/null @@ -1,25 +0,0 @@ -resolver: nightly-2022-01-06 -compiler: ghc-9.0.1 -compiler-check: match-exact - -extra-deps: -# Andreas, 2021-11-13 -# happy-1.21.0 is deprecated, but currently in nightly -# (commercialhaskell/stackage#6294) -- happy-1.20.0 -# Andreas, 2022-02-07 -# On Windows, we install the latest ICU (v69), which is only supported from text-icu >= 0.8 -- text-icu-0.8.0 - -flags: - transformers-compat: - five-three: true - # Andreas, 2021-11-14 - # Work around problem in nightly-2021-11-12 - # (commercialhaskell/stackage#6304 and RyanGlScott/mintty#4): - mintty: - Win32-2-13-1: false - -# Local packages, usually specified by relative directory name -packages: -- '.' 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 @@ -1,7 +1,7 @@ -resolver: lts-19.0 +resolver: lts-19.33 compiler: ghc-9.0.2 compiler-check: match-exact -# Local packages, usually specified by relative directory name -packages: -- '.' +extra-deps: +- text-icu-0.8.0.2 +- vector-hashtables-0.1.1.1 diff --git a/stack-9.2.1.yaml b/stack-9.2.1.yaml deleted file mode 100644 --- a/stack-9.2.1.yaml +++ /dev/null @@ -1,136 +0,0 @@ -resolver: ghc-9.2.1 -compiler: ghc-9.2.1 -compiler-check: match-exact - -extra-deps: -- Diff-0.4.0 -- HUnit-1.6.2.0 -- ListLike-4.7.6 -- OneTuple-0.3.1 -- QuickCheck-2.14.2 -- StateVar-1.2.2 -- STMonadTrans-0.4.6 -- aeson-2.0.2.0 -- alex-3.2.6 -- ansi-terminal-0.11 -- ansi-wl-pprint-0.6.9 -- assoc-1.0.2 -- async-2.2.4 -- attoparsec-0.14.2 -- base-compat-0.12.1 -- base-compat-batteries-0.12.1 -- base-orphans-0.8.6 -- bifunctors-5.5.11 -- blaze-builder-0.4.2.2 -- blaze-html-0.9.1.2 -- blaze-markup-0.8.2.8 -- boxes-0.1.5 -- call-stack-0.4.0 -- case-insensitive-1.2.1.0 -- clock-0.8.2 -- cmdargs-0.10.21 -- colour-2.3.6 -- comonad-5.0.8 -- contravariant-1.5.5 -- cpphs-1.20.9.1 -- data-default-0.7.1.1 -- data-default-class-0.1.2.0 -- data-default-instances-containers-0.0.1 -- data-default-instances-dlist-0.0.1 -- data-default-instances-old-locale-0.0.1 -- data-fix-0.3.2 -- data-hash-0.2.0.1 -- distributive-0.6.2.1 -- dlist-1.0 -- edit-distance-0.2.2.1 -- equivalence-0.3.5 -- extensible-exceptions-0.1.1.4 -- fail-4.9.0.0 -- filemanip-0.3.6.3 -- fmlist-0.9.4 -- generic-deriving-1.14.1 -- gitrev-1.3.1 -- happy-1.20.0 -- hashable-1.3.5.0 -- hashtables-1.2.4.2 -- haskell-lexer-1.1 -- hostname-1.0 -- indexed-traversable-0.1.2 -- indexed-traversable-instances-0.1.1 -- integer-logarithms-1.0.3.1 -- mintty-0.1.2 -- monad-control-1.0.3.1 -- murmur-hash-0.1.0.10 -- network-uri-2.6.4.1 -- old-locale-1.0.0.7 -- optparse-applicative-0.16.1.0 -- parallel-3.2.2.0 -- polyparse-1.13 -- pretty-show-1.10 -- primitive-0.7.3.0 -- process-extras-0.7.4 -- random-1.2.1 -- regex-base-0.94.0.1 -- regex-posix-0.96.0.1 -- regex-tdfa-1.3.1.1 -- safe-0.3.19 -- scientific-0.3.7.0 -- semialign-1.2.0.1 -- semigroupoids-5.3.6 -- silently-1.2.5.2 -- split-0.2.3.4 -- splitmix-0.1.0.4 -- strict-0.4.0.1 -- tagged-0.8.6.1 -- tasty-1.4.2 -- tasty-hunit-0.10.0.3 -- tasty-quickcheck-0.10.1.2 -- tasty-silver-3.3.1 -- temporary-1.3 -- test-framework-0.8.2.0 -- test-framework-hunit-0.3.0.2 -- text-icu-0.8.0.1 -- text-short-0.1.4 -- th-abstraction-0.4.3.0 -- th-compat-0.1.3 -- these-1.1.1.1 -- time-compat-1.9.6.1 -- transformers-base-0.4.6 -- transformers-compat-0.7.1 -- unbounded-delays-0.1.1.1 -- unix-compat-0.5.3 -- unordered-containers-0.2.15.0 -- uri-encode-1.5.0.7 -- utf8-string-1.0.2 -- uuid-types-1.0.5 -- vector-0.12.3.1 -- wcwidth-0.0.2 -- witherable-0.4.2 -- xml-1.3.14 -- zlib-0.6.2.3 - -# Andreas, 2021-11-13: -# Windows needs this instead of time-1.11.*, via unix-compat -- time-1.9.3 - -# Andreas, 2021-11-13: unix-compat (0.5.3) needs Win32 < 2.12 -# See https://github.com/jacobstanley/unix-compat/issues/48 -# Andreas, 2021-11-14: haskeline (0.8.2) needs Win32 < 2.10 || >= 2.12 -- Win32-2.9.0.0 - -# Fixup: -- Cabal-3.6.2.0 -# "this GHC boot package has been pruned (issue #4510);" -- directory-1.3.7.0 -- haskeline-0.8.2 -- process-1.6.13.2 -- unix-2.7.2.2 - - -flags: - transformers-compat: - five-three: true - -# Local packages, usually specified by relative directory name -packages: -- '.' diff --git a/stack-9.2.2.yaml b/stack-9.2.2.yaml deleted file mode 100644 --- a/stack-9.2.2.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: nightly-2022-03-26 -compiler: ghc-9.2.2 -compiler-check: match-exact - -packages: -- '.' diff --git a/stack-9.2.5.yaml b/stack-9.2.5.yaml new file mode 100644 --- /dev/null +++ b/stack-9.2.5.yaml @@ -0,0 +1,6 @@ +resolver: lts-20.9 +compiler: ghc-9.2.5 +compiler-check: match-exact + +extra-deps: +- vector-hashtables-0.1.1.1 diff --git a/stack-9.4.4.yaml b/stack-9.4.4.yaml new file mode 100644 --- /dev/null +++ b/stack-9.4.4.yaml @@ -0,0 +1,10 @@ +resolver: nightly-2023-01-29 +compiler: ghc-9.4.4 +compiler-check: match-exact + +flags: + mintty: + win32-2-13-1: false + +extra-deps: +- vector-hashtables-0.1.1.1