[Pkg-haskell-commits] [agda] 02/10: Imported Upstream version 2.4.2.2
Iain Lane
laney at moszumanska.debian.org
Wed May 20 11:51:58 UTC 2015
This is an automated email from the git hooks/post-receive script.
laney pushed a commit to branch master
in repository agda.
commit daa6a3eae84eb9e50a4463afe4f30ac26c8fb7aa
Author: Iain Lane <laney at debian.org>
Date: Wed May 20 10:45:09 2015 +0100
Imported Upstream version 2.4.2.2
---
Agda.cabal | 150 +-
CHANGELOG | 216 +++
dist/build/Agda/Syntax/Parser/Lexer.hs | 172 +-
dist/build/Agda/Syntax/Parser/Parser.hs | 1831 ++++++++++----------
src/data/agda.sty | 25 +-
src/data/emacs-mode/agda2-highlight.el | 112 +-
src/data/emacs-mode/agda2-mode.el | 18 +-
src/full/Agda/Auto/Auto.hs | 710 ++++----
src/full/Agda/Auto/CaseSplit.hs | 36 +-
src/full/Agda/Auto/Convert.hs | 110 +-
src/full/Agda/Auto/NarrowingSearch.hs | 16 +-
src/full/Agda/Auto/SearchControl.hs | 54 +-
src/full/Agda/Auto/Syntax.hs | 7 +-
src/full/Agda/Auto/Typecheck.hs | 32 +-
src/full/Agda/Compiler/CallCompiler.hs | 2 +-
src/full/Agda/Compiler/Epic/AuxAST.hs | 28 +-
src/full/Agda/Compiler/Epic/CompileState.hs | 51 +-
src/full/Agda/Compiler/Epic/Compiler.hs | 55 +-
src/full/Agda/Compiler/Epic/Epic.hs | 2 +-
src/full/Agda/Compiler/Epic/Erasure.hs | 34 +-
src/full/Agda/Compiler/Epic/ForceConstrs.hs | 4 +-
src/full/Agda/Compiler/Epic/Forcing.hs | 18 +-
src/full/Agda/Compiler/Epic/FromAgda.hs | 14 +-
src/full/Agda/Compiler/Epic/Injection.hs | 87 +-
src/full/Agda/Compiler/Epic/Interface.hs | 3 +-
src/full/Agda/Compiler/Epic/NatDetection.hs | 7 +-
src/full/Agda/Compiler/Epic/Primitive.hs | 28 +-
src/full/Agda/Compiler/Epic/Smashing.hs | 20 +-
src/full/Agda/Compiler/Epic/Static.hs | 26 +-
src/full/Agda/Compiler/HaskellTypes.hs | 5 +-
src/full/Agda/Compiler/JS/Case.hs | 2 +-
src/full/Agda/Compiler/JS/Compiler.hs | 18 +-
src/full/Agda/Compiler/JS/Syntax.hs | 1 +
src/full/Agda/Compiler/MAlonzo/Compiler.hs | 121 +-
src/full/Agda/Compiler/MAlonzo/Encode.hs | 3 +
src/full/Agda/Compiler/MAlonzo/Misc.hs | 43 +-
src/full/Agda/Compiler/MAlonzo/Pretty.hs | 10 +-
src/full/Agda/Compiler/MAlonzo/Primitives.hs | 34 +-
src/full/Agda/ImpossibleTest.hs | 1 +
src/full/Agda/Interaction/BasicOps.hs | 104 +-
.../Agda/Interaction/CommandLine/CommandLine.hs | 208 +--
src/full/Agda/Interaction/EmacsCommand.hs | 8 +-
src/full/Agda/Interaction/EmacsTop.hs | 2 -
src/full/Agda/Interaction/Exceptions.hs | 3 +-
src/full/Agda/Interaction/FindFile.hs | 5 +-
src/full/Agda/Interaction/Highlighting/Dot.hs | 4 +-
src/full/Agda/Interaction/Highlighting/Emacs.hs | 16 +-
src/full/Agda/Interaction/Highlighting/Generate.hs | 254 ++-
src/full/Agda/Interaction/Highlighting/HTML.hs | 14 +-
src/full/Agda/Interaction/Highlighting/LaTeX.hs | 62 +-
src/full/Agda/Interaction/Highlighting/Precise.hs | 113 +-
src/full/Agda/Interaction/Highlighting/Range.hs | 10 +-
src/full/Agda/Interaction/Highlighting/Vim.hs | 60 +-
src/full/Agda/Interaction/Imports.hs | 188 +-
src/full/Agda/Interaction/InteractionTop.hs | 81 +-
src/full/Agda/Interaction/MakeCase.hs | 85 +-
src/full/Agda/Interaction/Monad.hs | 9 +-
src/full/Agda/Interaction/Options.hs | 410 +++--
src/full/Agda/Interaction/Options/Lenses.hs | 8 +-
src/full/Agda/Interaction/Response.hs | 10 +-
src/full/Agda/Main.hs | 36 +-
src/full/Agda/Syntax/Abstract.hs | 638 ++++---
src/full/Agda/Syntax/Abstract/Copatterns.hs | 19 +-
src/full/Agda/Syntax/Abstract/Name.hs | 130 +-
src/full/Agda/Syntax/Abstract/Pretty.hs | 1 +
src/full/Agda/Syntax/Abstract/Views.hs | 97 +-
src/full/Agda/Syntax/Common.hs | 44 +-
src/full/Agda/Syntax/Concrete.hs | 698 ++++----
src/full/Agda/Syntax/Concrete/Definitions.hs | 454 +++--
src/full/Agda/Syntax/Concrete/Generic.hs | 10 +-
src/full/Agda/Syntax/Concrete/Name.hs | 40 +-
src/full/Agda/Syntax/Concrete/Operators.hs | 173 +-
src/full/Agda/Syntax/Concrete/Operators/Parser.hs | 62 +-
src/full/Agda/Syntax/Concrete/Pretty.hs | 438 ++---
src/full/Agda/Syntax/Fixity.hs | 153 +-
src/full/Agda/Syntax/Info.hs | 106 +-
src/full/Agda/Syntax/Internal.hs | 154 +-
src/full/Agda/Syntax/Internal/Defs.hs | 6 +-
src/full/Agda/Syntax/Internal/Generic.hs | 6 +-
src/full/Agda/Syntax/Internal/Pattern.hs | 116 +-
src/full/Agda/Syntax/Literal.hs | 15 +-
src/full/Agda/Syntax/Notation.hs | 164 +-
src/full/Agda/Syntax/Parser.hs | 12 +-
src/full/Agda/Syntax/Parser/Alex.hs | 43 +-
src/full/Agda/Syntax/Parser/Comments.hs | 28 +-
src/full/Agda/Syntax/Parser/Layout.hs | 76 +-
src/full/Agda/Syntax/Parser/LexActions.hs | 124 +-
src/full/Agda/Syntax/Parser/Lexer.x | 170 +-
src/full/Agda/Syntax/Parser/LookAhead.hs | 63 +-
src/full/Agda/Syntax/Parser/Monad.hs | 173 +-
src/full/Agda/Syntax/Parser/Parser.y | 551 +++---
src/full/Agda/Syntax/Parser/StringLiterals.hs | 137 +-
src/full/Agda/Syntax/Parser/Tokens.hs | 71 +-
src/full/Agda/Syntax/Position.hs | 210 ++-
src/full/Agda/Syntax/Scope/Base.hs | 319 ++--
src/full/Agda/Syntax/Scope/Monad.hs | 226 ++-
.../Agda/Syntax/Translation/AbstractToConcrete.hs | 42 +-
.../Agda/Syntax/Translation/ConcreteToAbstract.hs | 389 +++--
.../Agda/Syntax/Translation/InternalToAbstract.hs | 35 +-
src/full/Agda/Termination/CallGraph.hs | 34 +-
src/full/Agda/Termination/CallMatrix.hs | 18 +-
src/full/Agda/Termination/Inlining.hs | 6 +-
src/full/Agda/Termination/Monad.hs | 78 +-
src/full/Agda/Termination/Order.hs | 18 +-
src/full/Agda/Termination/RecCheck.hs | 4 +-
src/full/Agda/Termination/Semiring.hs | 3 +
src/full/Agda/Termination/SparseMatrix.hs | 31 +-
src/full/Agda/Termination/TermCheck.hs | 215 ++-
src/full/Agda/Termination/Termination.hs | 2 +-
src/full/Agda/Tests.hs | 21 +-
src/full/Agda/TheTypeChecker.hs | 1 -
src/full/Agda/TypeChecking/Abstract.hs | 10 +-
src/full/Agda/TypeChecking/CheckInternal.hs | 21 +-
src/full/Agda/TypeChecking/CompiledClause.hs | 62 +-
.../Agda/TypeChecking/CompiledClause/Compile.hs | 7 +-
src/full/Agda/TypeChecking/CompiledClause/Match.hs | 4 +-
src/full/Agda/TypeChecking/Constraints.hs | 13 +-
src/full/Agda/TypeChecking/Conversion.hs | 111 +-
src/full/Agda/TypeChecking/Coverage.hs | 238 +--
src/full/Agda/TypeChecking/Coverage/Match.hs | 6 +-
src/full/Agda/TypeChecking/Coverage/SplitTree.hs | 3 +-
src/full/Agda/TypeChecking/Datatypes.hs | 10 +-
src/full/Agda/TypeChecking/DisplayForm.hs | 19 +-
src/full/Agda/TypeChecking/DropArgs.hs | 6 +-
src/full/Agda/TypeChecking/Errors.hs | 688 ++++----
src/full/Agda/TypeChecking/EtaContract.hs | 8 +-
src/full/Agda/TypeChecking/Forcing.hs | 2 +-
src/full/Agda/TypeChecking/Free.hs | 285 ++-
src/full/Agda/TypeChecking/Implicit.hs | 10 +-
src/full/Agda/TypeChecking/Injectivity.hs | 46 +-
src/full/Agda/TypeChecking/InstanceArguments.hs | 42 +-
src/full/Agda/TypeChecking/Level.hs | 6 +-
src/full/Agda/TypeChecking/LevelConstraints.hs | 2 +-
src/full/Agda/TypeChecking/MetaVars.hs | 132 +-
src/full/Agda/TypeChecking/MetaVars.hs-boot | 8 +-
src/full/Agda/TypeChecking/MetaVars/Mention.hs | 7 +-
src/full/Agda/TypeChecking/MetaVars/Occurs.hs | 40 +-
src/full/Agda/TypeChecking/Monad/Base.hs | 1013 +++++++----
src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs | 11 +-
src/full/Agda/TypeChecking/Monad/Base/KillRange.hs | 8 +-
src/full/Agda/TypeChecking/Monad/Benchmark.hs | 2 +-
src/full/Agda/TypeChecking/Monad/Builtin.hs | 206 ++-
src/full/Agda/TypeChecking/Monad/Closure.hs | 1 -
src/full/Agda/TypeChecking/Monad/Constraints.hs | 20 +-
src/full/Agda/TypeChecking/Monad/Context.hs | 24 +-
src/full/Agda/TypeChecking/Monad/Debug.hs | 1 -
src/full/Agda/TypeChecking/Monad/Env.hs | 27 +-
src/full/Agda/TypeChecking/Monad/Exception.hs | 9 +-
src/full/Agda/TypeChecking/Monad/Imports.hs | 43 +-
src/full/Agda/TypeChecking/Monad/MetaVars.hs | 60 +-
src/full/Agda/TypeChecking/Monad/Mutual.hs | 14 +-
src/full/Agda/TypeChecking/Monad/Open.hs | 13 +-
src/full/Agda/TypeChecking/Monad/Options.hs | 33 +-
src/full/Agda/TypeChecking/Monad/Sharing.hs | 2 +-
src/full/Agda/TypeChecking/Monad/Signature.hs | 107 +-
src/full/Agda/TypeChecking/Monad/SizedTypes.hs | 21 +-
src/full/Agda/TypeChecking/Monad/State.hs | 91 +-
src/full/Agda/TypeChecking/Monad/Statistics.hs | 33 +-
src/full/Agda/TypeChecking/Monad/Trace.hs | 9 +-
src/full/Agda/TypeChecking/Patterns/Abstract.hs | 48 +-
src/full/Agda/TypeChecking/Patterns/Match.hs | 60 +-
src/full/Agda/TypeChecking/Polarity.hs | 10 +-
src/full/Agda/TypeChecking/Positivity.hs | 22 +-
src/full/Agda/TypeChecking/Pretty.hs | 132 +-
src/full/Agda/TypeChecking/Pretty.hs-boot | 4 +-
src/full/Agda/TypeChecking/Primitive.hs | 243 +--
src/full/Agda/TypeChecking/ProjectionLike.hs | 8 +-
src/full/Agda/TypeChecking/Quote.hs | 461 +----
src/full/Agda/TypeChecking/RecordPatterns.hs | 12 +-
src/full/Agda/TypeChecking/Records.hs | 8 +-
src/full/Agda/TypeChecking/Reduce.hs | 289 ++-
src/full/Agda/TypeChecking/Reduce/Monad.hs | 34 +-
src/full/Agda/TypeChecking/Rewriting.hs | 2 +-
src/full/Agda/TypeChecking/Rules/Builtin.hs | 12 +-
.../Agda/TypeChecking/Rules/Builtin/Coinduction.hs | 9 +-
src/full/Agda/TypeChecking/Rules/Data.hs | 140 +-
src/full/Agda/TypeChecking/Rules/Decl.hs | 199 ++-
src/full/Agda/TypeChecking/Rules/Def.hs | 215 +--
src/full/Agda/TypeChecking/Rules/Def.hs-boot | 6 +-
src/full/Agda/TypeChecking/Rules/LHS.hs | 731 ++++----
src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs | 22 +-
.../Agda/TypeChecking/Rules/LHS/Instantiate.hs | 32 +-
src/full/Agda/TypeChecking/Rules/LHS/Problem.hs | 75 +-
.../Agda/TypeChecking/Rules/LHS/ProblemRest.hs | 4 +-
src/full/Agda/TypeChecking/Rules/LHS/Split.hs | 369 ++--
src/full/Agda/TypeChecking/Rules/LHS/Unify.hs | 184 +-
src/full/Agda/TypeChecking/Rules/Record.hs | 117 +-
src/full/Agda/TypeChecking/Rules/Term.hs | 347 ++--
src/full/Agda/TypeChecking/Rules/Term.hs-boot | 4 +-
src/full/Agda/TypeChecking/Serialise.hs | 1155 ++++++++----
src/full/Agda/TypeChecking/SizedTypes.hs | 21 +-
src/full/Agda/TypeChecking/SizedTypes/Solve.hs | 18 +-
src/full/Agda/TypeChecking/SizedTypes/Syntax.hs | 18 +-
src/full/Agda/TypeChecking/SizedTypes/Tests.hs | 94 +-
src/full/Agda/TypeChecking/SizedTypes/Utils.hs | 10 +-
.../Agda/TypeChecking/SizedTypes/WarshallSolver.hs | 43 +-
src/full/Agda/TypeChecking/Substitute.hs | 194 ++-
src/full/Agda/TypeChecking/SyntacticEquality.hs | 12 +-
src/full/Agda/TypeChecking/Telescope.hs | 42 +-
src/full/Agda/TypeChecking/Test/Generators.hs | 192 +-
src/full/Agda/TypeChecking/Tests.hs | 17 +-
src/full/Agda/TypeChecking/Unquote.hs | 403 +++++
src/full/Agda/TypeChecking/With.hs | 8 +-
src/full/Agda/Utils/AssocList.hs | 79 +
src/full/Agda/Utils/Bag.hs | 217 +++
src/full/Agda/Utils/BiMap.hs | 15 +-
src/full/Agda/Utils/Char.hs | 46 +-
src/full/Agda/Utils/Cluster.hs | 91 +-
src/full/Agda/Utils/Either.hs | 59 +-
src/full/Agda/Utils/Empty.hs | 24 +
src/full/Agda/Utils/Except.hs | 62 +
src/full/Agda/Utils/Favorites.hs | 13 +-
src/full/Agda/Utils/FileName.hs | 11 +-
src/full/Agda/Utils/Fresh.hs | 23 -
src/full/Agda/Utils/Function.hs | 47 +-
src/full/Agda/Utils/Functor.hs | 13 +
src/full/Agda/Utils/Geniplate.hs | 5 +
src/full/Agda/Utils/Graph/AdjacencyMap.hs | 6 +-
.../Utils/Graph/AdjacencyMap/Unidirectional.hs | 29 +-
src/full/Agda/Utils/HashMap.hs | 1 -
src/full/Agda/Utils/IO/UTF8.hs | 17 +-
src/full/Agda/Utils/IORef.hs | 29 +
src/full/Agda/Utils/Lens.hs | 68 +
src/full/Agda/Utils/Lens/Examples.hs | 18 +
src/full/Agda/Utils/List.hs | 88 +-
src/full/Agda/Utils/Map.hs | 22 +-
src/full/Agda/Utils/Maybe.hs | 2 +-
src/full/Agda/Utils/Maybe/Strict.hs | 4 +-
src/full/Agda/Utils/Monad.hs | 58 +-
src/full/Agda/Utils/Null.hs | 20 +
src/full/Agda/Utils/PartialOrd.hs | 41 +-
src/full/Agda/Utils/Permutation.hs | 84 +-
src/full/Agda/Utils/Permutation/Tests.hs | 117 ++
src/full/Agda/Utils/Pointer.hs | 1 +
src/full/Agda/Utils/Pretty.hs | 49 +-
src/full/Agda/Utils/ReadP.hs | 17 +-
src/full/Agda/Utils/SemiRing.hs | 1 -
src/full/Agda/Utils/Size.hs | 56 +-
src/full/Agda/Utils/String.hs | 5 +-
src/full/Agda/Utils/Suffix.hs | 32 +-
src/full/Agda/Utils/Time.hs | 26 +-
src/full/Agda/Utils/Trie.hs | 13 +-
src/full/Agda/Utils/Tuple.hs | 6 +-
src/full/Agda/Utils/Unicode.hs | 26 -
src/full/Agda/Utils/Update.hs | 1 +
src/full/Agda/Utils/VarSet.hs | 19 +-
src/full/Agda/Utils/Warshall.hs | 28 +-
src/full/Agda/Version.hs | 1 -
src/full/{Agda => }/undefined.h | 0
249 files changed, 13467 insertions(+), 10103 deletions(-)
diff --git a/Agda.cabal b/Agda.cabal
index 7499eef..56c6023 100644
--- a/Agda.cabal
+++ b/Agda.cabal
@@ -1,5 +1,5 @@
name: Agda
-version: 2.4.2
+version: 2.4.2.2
cabal-version: >= 1.8
build-type: Custom
license: OtherLicense
@@ -32,11 +32,11 @@ description:
Note that the Agda library does not follow the package versioning
policy, because it is not intended to be used by third-party
packages.
-tested-with: GHC == 7.2.2
+tested-with: GHC == 7.0.4
GHC == 7.4.2
GHC == 7.6.3
GHC == 7.8.3
-extra-source-files: src/full/Agda/undefined.h
+extra-source-files: src/full/undefined.h
README.md
CHANGELOG
data-dir: src/data
@@ -56,7 +56,12 @@ source-repository head
source-repository this
type: git
location: https://github.com/agda/agda
- tag: 2.4.2
+ tag: 2.4.2.2
+
+flag cpphs
+ default: True
+ manual: True
+ description: Use cpphs instead of cpp.
flag epic
default: False
@@ -66,55 +71,67 @@ flag epic
library
hs-source-dirs: src/full
+ include-dirs: src/full
if flag(epic)
build-depends: epic >= 0.1.13 && < 0.10
if os(windows)
build-depends: Win32 >= 2.2 && < 2.4
- build-depends: base >= 4.2 && < 4.8,
- transformers == 0.3.*,
- -- mtl-2.1 contains a severe bug
- mtl >= 2.1.1 && < 2.2,
- QuickCheck >= 2.7.5 && < 2.8,
- haskell-src-exts >= 1.9.6 && < 1.16,
- containers >= 0.1 && < 0.6,
- unordered-containers == 0.2.*,
- pretty >= 1.0 && < 1.2,
- bytestring >= 0.9.0.1 && < 0.11,
- array >= 0.1 && < 0.6,
- binary >= 0.6 && < 0.8,
- zlib >= 0.4.0.1 && < 0.6,
- filepath >= 1.1 && < 1.4,
- process >= 1.0.1.0 && < 1.3,
- haskeline >= 0.7 && < 0.8,
- data-hash == 0.2.0.0,
- xhtml == 3000.2.*,
- -- hashable 1.2.0.10 makes library-test 10x
- -- slower. The issue was fixed in hashable 1.2.1.0.
- -- https://github.com/tibbe/hashable/issues/57.
- hashable >= 1.1.2.3 && < 1.2 || >= 1.2.1.0 && < 1.3,
- hashtables >= 1.0 && < 1.2,
- geniplate >= 0.6.0.3 && < 0.7,
- -- parsec >= 3.1 && < 3.2, -- only for Agda.TypeChecking.SizedTypes.Parser, which is not included
- parallel < 3.3,
- deepseq == 1.3.*,
- strict >= 0.3.2 && < 0.4,
- STMonadTrans >= 0.3.2 && < 0.4,
- equivalence >= 0.2.4 && < 0.3,
- boxes >= 0.1.3 && < 0.2,
- text >= 0.11 && < 1.2
+ build-depends:
+ array >= 0.1 && < 0.6
+ , base >= 4.2 && < 4.8
+ , binary >= 0.6 && < 0.8
+ , boxes >= 0.1.3 && < 0.2
+ -- NFData ByteString is only available from bytestring >= 0.10
+ -- but bytestring-0.10 is not accepted by travis build for ghc <= 7.4
+ -- as it breaks the accompanying haskell-platform
+ -- even though it builds with older ghcs.
+ , bytestring >= 0.9.0.1 && < 0.11
+ , containers >= 0.1 && < 0.6
+ , data-hash == 0.2.0.0
+ , deepseq == 1.3.*
+ , equivalence >= 0.2.5 && < 0.3
+ , filepath >= 1.1 && < 1.4
+ , geniplate >= 0.6.0.3 && < 0.7
+ -- hashable 1.2.0.10 makes library-test 10x slower. The issue was
+ -- fixed in hashable 1.2.1.0.
+ -- https://github.com/tibbe/hashable/issues/57.
+ , hashable >= 1.1.2.3 && < 1.2 || >= 1.2.1.0 && < 1.3
+ , hashtables >= 1.0 && < 1.2
+ , haskeline >= 0.7 && < 0.8
+ , haskell-src-exts >= 1.9.6 && < 1.17
+ -- mtl-2.1 contains a severe bug.
+ --
+ -- mtl >= 2.2 && < 2.2.1 doesn't export Control.Monad.Except.
+ , mtl >= 2.1.1 && <= 2.1.3.1 || >= 2.2.1 && < 2.3
+ , parallel < 3.3
+ -- , parsec >= 3.1 && < 3.2, -- only for Agda.TypeChecking.SizedTypes.Parser, which is not included
+ , pretty >= 1.0 && < 1.2
+ , process >= 1.0.1.0 && < 1.3
+ , QuickCheck >= 2.7.5 && < 2.8
+ , STMonadTrans >= 0.3.2 && < 0.4
+ , strict >= 0.3.2 && < 0.4
+ , template-haskell >= 2.5 && < 2.10
+ , text >= 0.11 && < 1.3
+ -- tranformers 0.4.0.0 was deprecated.
+ , transformers >= 0.3 && < 0.4 || >= 0.4.1.0 && < 0.5
+ , unordered-containers == 0.2.*
+ , xhtml == 3000.2.*
+ , zlib >= 0.4.0.1 && < 0.6
if impl(ghc < 7.6)
- build-depends: old-time >= 1.0 && < 1.2,
- directory >= 1.0 && < 1.2
+ build-depends:
+ directory >= 1.0 && < 1.2
+ , old-time >= 1.0 && < 1.2
else
- build-depends: time == 1.4.*,
- directory == 1.2.*
+ build-depends:
+ directory == 1.2.*
+ , time == 1.4.*
- build-tools: happy >= 1.19.3 && < 2,
- alex >= 3.1.0 && < 3.2,
- cpphs >= 1.18.5 && < 1.19
+ build-tools:
+ alex >= 3.1.0 && < 3.2
+ , happy >= 1.19.3 && < 2
exposed-modules: Agda.Main
Agda.ImpossibleTest
@@ -313,14 +330,18 @@ library
Agda.TypeChecking.Test.Generators
Agda.TypeChecking.Tests
-- Agda.TypeChecking.UniversePolymorphism -- RETIRED
+ Agda.TypeChecking.Unquote
Agda.TypeChecking.With
+ Agda.Utils.AssocList
+ Agda.Utils.Bag
Agda.Utils.BiMap
Agda.Utils.Char
Agda.Utils.Cluster
+ Agda.Utils.Empty
+ Agda.Utils.Except
Agda.Utils.Either
Agda.Utils.Favorites
Agda.Utils.FileName
- Agda.Utils.Fresh
Agda.Utils.Functor
Agda.Utils.Function
Agda.Utils.Geniplate
@@ -331,6 +352,9 @@ library
Agda.Utils.Impossible
Agda.Utils.IO.Binary
Agda.Utils.IO.UTF8
+ Agda.Utils.IORef
+ Agda.Utils.Lens
+ Agda.Utils.Lens.Examples
Agda.Utils.List
Agda.Utils.Map
Agda.Utils.Maybe
@@ -339,6 +363,7 @@ library
Agda.Utils.Null
Agda.Utils.PartialOrd
Agda.Utils.Permutation
+ Agda.Utils.Permutation.Tests
Agda.Utils.Pointer
Agda.Utils.Pointed
Agda.Utils.Pretty
@@ -352,7 +377,6 @@ library
Agda.Utils.Time
Agda.Utils.Trie
Agda.Utils.Tuple
- Agda.Utils.Unicode
Agda.Utils.Update
Agda.Utils.VarSet
Agda.Utils.Warshall
@@ -376,20 +400,27 @@ library
-fwarn-incomplete-patterns
-fwarn-missing-fields
-fwarn-missing-methods
+ -fwarn-missing-signatures
-fwarn-monomorphism-restriction
+ -fwarn-tabs
-fwarn-overlapping-patterns
-fwarn-unrecognised-pragmas
-fwarn-warnings-deprecations
- -- Using cpphs as the C preprocessor.
- -pgmPcpphs -optP--cpp
+
+ if flag(cpphs)
+ build-tools: cpphs >= 1.18.6 && < 1.19
+ ghc-options: -pgmPcpphs -optP--cpp
-- The Cabal-generated module Paths_Agda triggers a warning under
-- GHC 7.2.1/7.2.2 (at least when certain versions of Cabal are
-- used).
- -- Issue 1103: Termination.SparseMatrix triggers a warning under GHC 7.0.4.
- -- -Werror is for developers only, who are assumed to use a recent GHC.
+ --
+ -- Issue 1103: Some files (e.g. Syntax.Scope.Monad,
+ -- Termination.SparseMatrix and Utils.Cluster) trigger a warning
+ -- under GHC 7.0.4. -Werror is for developers only, who are assumed
+ -- to use a recent GHC.
-- if impl(ghc > 7.2.2)
- -- ghc-options: -Werror
+ -- ghc-options: -Werror
if impl(ghc >= 6.12)
ghc-options: -fwarn-dodgy-exports
-fwarn-wrong-do-bind
@@ -410,10 +441,11 @@ library
executable agda
hs-source-dirs: src/main
main-is: Main.hs
- build-depends: Agda == 2.4.2,
- -- Nothing is used from the following package, except
- -- for the prelude.
- base >= 3 && < 6
+ build-depends:
+ Agda == 2.4.2.2
+ -- Nothing is used from the following package, except for the
+ -- prelude.
+ , base >= 3 && < 6
if impl(ghc >= 7)
-- If someone installs Agda with the setuid bit set, then the
-- presence of +RTS may be a security problem (see GHC bug #3910).
@@ -426,7 +458,9 @@ executable agda-mode
hs-source-dirs: src/agda-mode
main-is: Main.hs
other-modules: Paths_Agda
- build-depends: base >= 4.2 && < 4.8,
- filepath >= 1.1 && < 1.4,
- process >= 1.0.1.0 && < 1.3,
- directory >= 1.0 && < 1.3
+ build-depends:
+ base >= 4.2 && < 4.8
+ , directory >= 1.0 && < 1.3
+ , filepath >= 1.1 && < 1.4
+ , process >= 1.0.1.0 && < 1.3
+
diff --git a/CHANGELOG b/CHANGELOG
index 309096d..6378f89 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,220 @@
------------------------------------------------------------------------
+-- Release notes for Agda version 2.4.2.2
+------------------------------------------------------------------------
+
+Important changes since 2.4.2.1:
+
+Bug fixes
+=========
+
+* Compilation on Windows fixed.
+
+* Other issues fixed ( see https://code.google.com/p/agda/issues )
+ 1332
+ 1353
+ 1360
+ 1366
+ 1369
+
+------------------------------------------------------------------------
+-- Release notes for Agda version 2.4.2.1
+------------------------------------------------------------------------
+
+Important changes since 2.4.2:
+
+Pragmas and options
+===================
+
+* New pragma {-# TERMINATING #-} replacing {-# NO_TERMINATION_CHECK #-}
+
+ Complements the existing pragma {-# NON_TERMINATING #-}.
+ Skips termination check for the associated definitions and marks
+ them as terminating. Thus, it is a replacement for
+ {-# NO_TERMINATION_CHECK #-} with the same semantics.
+
+ You can no longer use pragma {-# NO_TERMINATION_CHECK #-} to skip
+ the termination check, but must label your definitions as either
+ {-# TERMINATING #-} or {-# NON_TERMINATING #-} instead.
+
+ Note: {-# OPTION --no-termination-check #-} labels all your
+ definitions as {-# TERMINATING #-}, putting you in the danger zone
+ of a loop in the type checker.
+
+Language
+========
+
+* Referring to a local variable shadowed by module opening is now
+ an error. Previous behavior was preferring the local over the
+ imported definitions. [Issue 1266]
+
+ Note that module parameters are locals as well as variables bound by
+ λ, dependent function type, patterns, and let.
+
+ Example:
+
+ module M where
+ A = Set1
+
+ test : (A : Set) → let open M in A
+
+ The last A produces an error, since it could refer to the local
+ variable A or to the definition imported from module M.
+
+* `with` on a variable bound by a module telescope or a pattern of a
+ parent function is now forbidden. [Issue 1342]
+
+ data Unit : Set where
+ unit : Unit
+
+ id : (A : Set) → A → A
+ id A a = a
+
+ module M (x : Unit) where
+
+ dx : Unit → Unit
+ dx unit = x
+
+ g : ∀ u → x ≡ dx u
+ g with x
+ g | unit = id (∀ u → unit ≡ dx u) ?
+
+ Even though this code looks right, Agda complains about the type
+ expression `∀ u → unit ≡ dx u`. If you ask Agda what should go
+ there instead, it happily tells you that it wants
+ `∀ u → unit ≡ dx u`. In fact what you do not see and Agda
+ will never show you is that the two expressions actually differ in
+ the invisible first argument to `dx`, which is visible only outside
+ module `M`. What Agda wants is an invisible `unit` after `dx`, but all
+ you can write is an invisible `x` (which is inserted behind the
+ scenes).
+
+ To avoid those kinds of paradoxes, `with` is now outlawed on module
+ parameters. This should ensure that the invisible arguments are
+ always exactly the module parameters.
+
+ Since a `where` block is desugared as module with pattern variables
+ of the parent clause as module parameters, the same strikes you for
+ uses of `with` on pattern variables of the parent function.
+
+ f : Unit → Unit
+ f x = unit
+ where
+ dx : Unit → Unit
+ dx unit = x
+
+ g : ∀ u → x ≡ dx u
+ g with x
+ g | unit = id ((u : Unit) → unit ≡ dx u) ?
+
+ The `with` on pattern variable `x` of the parent clause `f x = unit`
+ is outlawed now.
+
+Type checking
+=============
+
+* Termination check failure is now a proper error.
+
+ We no longer continue type checking after termination check failures.
+ Use pragmas {-# NON_TERMINATING #-} and {-# NO_TERMINATION_CHECK #-}
+ near the offending definitions if you want to do so.
+ Or switch off the termination checker altogether with
+ {-# OPTIONS --no-termination-check #-} (at your own risk!).
+
+* (Since Agda 2.4.2:) Termination checking --without-K restricts
+ structural descent to arguments ending in data types or `Size`.
+ Likewise, guardedness is only tracked when result type is data or
+ record type.
+
+ mutual
+ data WOne : Set where wrap : FOne → WOne
+ FOne = ⊥ → WOne
+
+ noo : (X : Set) → (WOne ≡ X) → X → ⊥
+ noo .WOne refl (wrap f) = noo FOne iso f
+
+ `noo` is rejected since at type `X` the structural descent
+ `f < wrap f` is discounted --without-K.
+
+ data Pandora : Set where
+ C : ∞ ⊥ → Pandora
+
+ loop : (A : Set) → A ≡ Pandora → A
+ loop .Pandora refl = C (♯ (loop ⊥ foo))
+
+ `loop` is rejected since guardedness is not tracked at type `A`
+ --without-K.
+
+ See issues 1023, 1264, 1292.
+
+Termination checking
+====================
+
+* The termination checker can now recognize simple subterms in dot
+ patterns.
+
+ data Subst : (d : Nat) → Set where
+ c₁ : ∀ {d} → Subst d → Subst d
+ c₂ : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (suc d₁ + d₂)
+
+ postulate
+ comp : ∀ {d₁ d₂} → Subst d₁ → Subst d₂ → Subst (d₁ + d₂)
+
+ lookup : ∀ d → Nat → Subst d → Set₁
+ lookup d zero (c₁ ρ) = Set
+ lookup d (suc v) (c₁ ρ) = lookup d v ρ
+ lookup .(suc d₁ + d₂) v (c₂ {d₁} {d₂} ρ σ) = lookup (d₁ + d₂) v (comp ρ σ)
+
+ The dot pattern here is actually normalized, so it is
+
+ suc (d₁ + d₂)
+
+ and the corresponding recursive call argument is (d₁ + d₂).
+ In such simple cases, Agda can now recognize that the pattern is
+ constructor applied to call argument, which is valid descent.
+
+ Note however, that Agda only looks for syntactic equality when
+ identifying subterms, since it is not allowed to normalize terms on
+ the rhs during termination checking.
+
+ Actually writing the dot pattern has no effect, this works as well,
+ and looks pretty magical... ;-)
+
+ hidden : ∀{d} → Nat → Subst d → Set₁
+ hidden zero (c₁ ρ) = Set
+ hidden (suc v) (c₁ ρ) = hidden v ρ
+ hidden v (c₂ ρ σ) = hidden v (comp ρ σ)
+
+Tools
+=====
+
+LaTeX-backend
+-------------
+
+* Fixed the issue of identifiers containing operators being typeset with
+ excessive math spacing.
+
+Bug fixes
+=========
+
+* Issue 1194
+
+* Issue 836: Fields and constructors can be qualified by the
+ record/data *type* as well as by their record/data module.
+ This now works also for record/data type imported from
+ parametrized modules:
+
+ module M (_ : Set₁) where
+
+ record R : Set₁ where
+ field
+ X : Set
+
+ open M Set using (R) -- rather than using (module R)
+
+ X : R → Set
+ X = R.X
+
+------------------------------------------------------------------------
-- Release notes for Agda version 2.4.2
------------------------------------------------------------------------
diff --git a/dist/build/Agda/Syntax/Parser/Lexer.hs b/dist/build/Agda/Syntax/Parser/Lexer.hs
index a5ad87d..1b7cd64 100644
--- a/dist/build/Agda/Syntax/Parser/Lexer.hs
+++ b/dist/build/Agda/Syntax/Parser/Lexer.hs
@@ -1,9 +1,13 @@
{-# LANGUAGE CPP,MagicHash #-}
{-# LINE 1 "src/full/Agda/Syntax/Parser/Lexer.x" #-}
-{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
{-# LANGUAGE BangPatterns #-}
+
{-| The lexer is generated by Alex (<http://www.haskell.org/alex>) and is an
adaptation of GHC's lexer. The main lexing function 'lexer' is called by
the "Agda.Syntax.Parser.Parser" to get the next token from the input.
@@ -51,19 +55,19 @@ import GHC.Exts
import GlaExts
#endif
alex_base :: AlexAddr
-alex_base = AlexA# "\xf7\xff\xff\xff\x6c\x00\x00\x00\xe1\x00\x00\x00\x55\x01\x00\x00\xca\x01\x00\x00\x3f\x02\x00\x00\xb5\x02\x00\x00\xab\x03\x00\x00\x88\xff\xff\xff\xd9\xff\xff\xff\x8a\x04\x00\x00\xe8\x04\x00\x00\x46\x05\x00\x00\xb6\x02\x00\x00\xa2\x05\x00\x00\x9d\x03\x00\x00\xfe\x05\x00\x00\xfd\x05\x00\x00\x7d\x06\x00\x00\xa2\xff\xff\xff\xfd\x06\x00\x00\xdc\x07\x00\x00\xdb\x07\x00\x00\x5b\x08\x00\x00\xdb\x08\x00\x00\x5b\x09\x00\x00\x3a\x0a\x00\x00\x96\x0a\x00\x00\xf2\x0a\x00\x00\xf1\x0a [...]
+alex_base = AlexA# "\xf7\xff\xff\xff\x6c\x00\x00\x00\xe1\x00\x00\x00\x55\x01\x00\x00\xca\x01\x00\x00\x3f\x02\x00\x00\xb5\x02\x00\x00\xab\x03\x00\x00\x88\xff\xff\xff\xd9\xff\xff\xff\x8a\x04\x00\x00\xe8\x04\x00\x00\x46\x05\x00\x00\xb6\x02\x00\x00\xa2\x05\x00\x00\x9d\x03\x00\x00\xfe\x05\x00\x00\xfd\x05\x00\x00\x7d\x06\x00\x00\xa2\xff\xff\xff\xfd\x06\x00\x00\xdc\x07\x00\x00\xdb\x07\x00\x00\x5b\x08\x00\x00\xdb\x08\x00\x00\x5b\x09\x00\x00\x3a\x0a\x00\x00\x96\x0a\x00\x00\xf2\x0a\x00\x00\xf1\x0a [...]
alex_table :: AlexAddr
-alex_table = AlexA# "\x00\x00\xde\x00\x54\x00\x54\x00\x54\x00\x53\x00\xd1\x00\x08\x00\x27\x00\x1e\x00\x1f\x00\x22\x00\x20\x00\x13\x00\x43\x00\x56\x00\x0e\x01\x0f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x90\x01\x20\x01\x90\x01\x90\x01\x90\x01\x90\x01\x1f\x01\x17\x01\x18\x01\x90\x01\x90\x01\x90\x01\x32\x01\x10\x01\x90\x01\x25\x01\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x24\x01\x12\x01\x11\x01\x90\x01\x13\x01\x90\x01\x15\x01\x1b\x01\x90\x01\x90\x01\x90\x0 [...]
+alex_table = AlexA# "\x00\x00\xe9\x00\x54\x00\x54\x00\x54\x00\x53\x00\xdc\x00\x08\x00\x27\x00\x1e\x00\x1f\x00\x22\x00\x20\x00\x13\x00\x43\x00\x56\x00\x19\x01\x1a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x9b\x01\x2b\x01\x9b\x01\x9b\x01\x9b\x01\x9b\x01\x2a\x01\x22\x01\x23\x01\x9b\x01\x9b\x01\x9b\x01\x3d\x01\x1b\x01\x9b\x01\x30\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x2f\x01\x1d\x01\x1c\x01\x9b\x01\x1e\x01\x9b\x01\x20\x01\x26\x01\x9b\x01\x9b\x01\x9b\x0 [...]
alex_check :: AlexAddr
-alex_check = AlexA# "\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x2d\x00\x65\x00\x6f\x00\x63\x00\x7b\x00\x6e\x00\x64\x00\x64\x00\x0a\x00\x23\x00\x2e\x00\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x0 [...]
+alex_check = AlexA# "\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x2d\x00\x65\x00\x6f\x00\x63\x00\x7b\x00\x6e\x00\x64\x00\x64\x00\x0a\x00\x23\x00\x2e\x00\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x0 [...]
alex_deflt :: AlexAddr
-alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2c\x00\x2c\x00\x2e\x00\x2e\x00\xff\xff\x30\x00\x30\x00\x32\x00\x32\x00\x37\x00\x37\x00\x3a\x00\x3a\x00\x3d\x00\x3d\x00\x42\x00\x42\x00\xff\xff\xd7\x00\xd7\x00\xd7\x00\xa7\x00\xa7\x00\xa7\x0 [...]
+alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xae\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2c\x00\x2c\x00\x2e\x00\x2e\x00\xff\xff\x30\x00\x30\x00\x32\x00\x32\x00\x37\x00\x37\x00\x3a\x00\x3a\x00\x3d\x00\x3d\x00\x42\x00\x42\x00\xff\xff\xe2\x00\xe2\x00\xe2\x00\xae\x00\xae\x00\xae\x0 [...]
-alex_accept = listArray (0::Int,486) [AlexAccNone,AlexAccPred (alex_action_36) ( not' eof )(AlexAccNone),AlexAccNone,AlexAcc (alex_action_39),AlexAccNone,AlexAcc (alex_action_38),AlexAccNone,AlexAccPred (alex_action_4) ( eof )(AlexAccNone),AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNon [...]
-{-# LINE 228 "src/full/Agda/Syntax/Parser/Lexer.x" #-}
+alex_accept = listArray (0::Int,497) [AlexAccNone,AlexAccPred (alex_action_37) ( not' eof )(AlexAccNone),AlexAccNone,AlexAcc (alex_action_40),AlexAccNone,AlexAcc (alex_action_39),AlexAccNone,AlexAccPred (alex_action_4) ( eof )(AlexAccNone),AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNon [...]
+{-# LINE 236 "src/full/Agda/Syntax/Parser/Lexer.x" #-}
-- | This is the initial state for parsing a literate file. Code blocks
@@ -169,84 +173,86 @@ alex_action_22 = keyword KwIMPOSSIBLE
alex_action_23 = keyword KwETA
alex_action_24 = keyword KwNO_TERMINATION_CHECK
alex_action_25 = keyword KwNON_TERMINATING
-alex_action_26 = keyword KwMEASURE
-alex_action_27 = keyword KwLINE
-alex_action_28 = withInterval $ TokString
-alex_action_29 = nestedComment
-alex_action_30 = symbol SymEndComment
+alex_action_26 = keyword KwTERMINATING
+alex_action_27 = keyword KwMEASURE
+alex_action_28 = keyword KwLINE
+alex_action_29 = withInterval $ TokString
+alex_action_30 = nestedComment
alex_action_31 = symbol SymEndComment
-alex_action_32 = withInterval TokComment
-alex_action_34 = begin bol_
-alex_action_36 = offsideRule
-alex_action_38 = endWith newLayoutContext
-alex_action_39 = emptyLayout
-alex_action_40 = keyword KwLet
-alex_action_41 = keyword KwIn
-alex_action_42 = keyword KwWhere
-alex_action_43 = keyword KwField
-alex_action_44 = keyword KwWith
-alex_action_45 = keyword KwRewrite
-alex_action_46 = keyword KwPostulate
-alex_action_47 = keyword KwPrimitive
-alex_action_48 = keyword KwOpen
-alex_action_49 = keyword KwImport
-alex_action_50 = keyword KwModule
-alex_action_51 = keyword KwData
-alex_action_52 = keyword KwCoData
-alex_action_53 = keyword KwRecord
-alex_action_54 = keyword KwConstructor
-alex_action_55 = keyword KwInductive
-alex_action_56 = keyword KwCoInductive
-alex_action_57 = keyword KwInfix
-alex_action_58 = keyword KwInfixL
-alex_action_59 = keyword KwInfixR
-alex_action_60 = keyword KwMutual
-alex_action_61 = keyword KwAbstract
-alex_action_62 = keyword KwPrivate
-alex_action_63 = keyword KwInstance
-alex_action_64 = keyword KwSet
-alex_action_65 = keyword KwProp
-alex_action_66 = keyword KwForall
-alex_action_67 = withInterval' (read . drop 3) TokSetN
-alex_action_68 = keyword KwQuoteGoal
-alex_action_69 = keyword KwQuoteContext
-alex_action_70 = keyword KwQuote
-alex_action_71 = keyword KwQuoteTerm
-alex_action_72 = keyword KwUnquote
-alex_action_73 = keyword KwUnquoteDecl
-alex_action_74 = keyword KwTactic
-alex_action_75 = keyword KwSyntax
-alex_action_76 = keyword KwPatternSyn
-alex_action_77 = keyword KwUsing
-alex_action_78 = keyword KwHiding
-alex_action_79 = keyword KwRenaming
-alex_action_80 = endWith $ keyword KwTo
-alex_action_81 = keyword KwPublic
-alex_action_82 = hole
-alex_action_83 = symbol SymEllipsis
-alex_action_84 = symbol SymDotDot
-alex_action_85 = symbol SymDot
-alex_action_86 = symbol SymSemi
-alex_action_87 = symbol SymColon
-alex_action_88 = symbol SymEqual
-alex_action_89 = symbol SymUnderscore
-alex_action_90 = symbol SymQuestionMark
-alex_action_91 = symbol SymBar
-alex_action_92 = symbol SymOpenParen
-alex_action_93 = symbol SymCloseParen
-alex_action_94 = symbol SymArrow
-alex_action_95 = symbol SymLambda
-alex_action_96 = symbol SymAs
-alex_action_97 = symbol SymDoubleOpenBrace
-alex_action_98 = symbol SymOpenBrace
-alex_action_99 = symbol SymCloseBrace
-alex_action_100 = litChar
-alex_action_101 = litString
-alex_action_102 = literal LitInt
-alex_action_103 = literal LitFloat
-alex_action_104 = identifier
+alex_action_32 = symbol SymEndComment
+alex_action_33 = withInterval TokComment
+alex_action_35 = begin bol_
+alex_action_37 = offsideRule
+alex_action_39 = endWith newLayoutContext
+alex_action_40 = emptyLayout
+alex_action_41 = keyword KwLet
+alex_action_42 = keyword KwIn
+alex_action_43 = keyword KwWhere
+alex_action_44 = keyword KwField
+alex_action_45 = keyword KwWith
+alex_action_46 = keyword KwRewrite
+alex_action_47 = keyword KwPostulate
+alex_action_48 = keyword KwPrimitive
+alex_action_49 = keyword KwOpen
+alex_action_50 = keyword KwImport
+alex_action_51 = keyword KwModule
+alex_action_52 = keyword KwData
+alex_action_53 = keyword KwCoData
+alex_action_54 = keyword KwRecord
+alex_action_55 = keyword KwConstructor
+alex_action_56 = keyword KwInductive
+alex_action_57 = keyword KwCoInductive
+alex_action_58 = keyword KwInfix
+alex_action_59 = keyword KwInfixL
+alex_action_60 = keyword KwInfixR
+alex_action_61 = keyword KwMutual
+alex_action_62 = keyword KwAbstract
+alex_action_63 = keyword KwPrivate
+alex_action_64 = keyword KwInstance
+alex_action_65 = keyword KwSet
+alex_action_66 = keyword KwProp
+alex_action_67 = keyword KwForall
+alex_action_68 = withInterval' (read . drop 3) TokSetN
+alex_action_69 = keyword KwQuoteGoal
+alex_action_70 = keyword KwQuoteContext
+alex_action_71 = keyword KwQuote
+alex_action_72 = keyword KwQuoteTerm
+alex_action_73 = keyword KwUnquote
+alex_action_74 = keyword KwUnquoteDecl
+alex_action_75 = keyword KwTactic
+alex_action_76 = keyword KwSyntax
+alex_action_77 = keyword KwPatternSyn
+alex_action_78 = keyword KwUsing
+alex_action_79 = keyword KwHiding
+alex_action_80 = keyword KwRenaming
+alex_action_81 = endWith $ keyword KwTo
+alex_action_82 = keyword KwPublic
+alex_action_83 = hole
+alex_action_84 = symbol SymEllipsis
+alex_action_85 = symbol SymDotDot
+alex_action_86 = symbol SymDot
+alex_action_87 = symbol SymSemi
+alex_action_88 = symbol SymColon
+alex_action_89 = symbol SymEqual
+alex_action_90 = symbol SymUnderscore
+alex_action_91 = symbol SymQuestionMark
+alex_action_92 = symbol SymBar
+alex_action_93 = symbol SymOpenParen
+alex_action_94 = symbol SymCloseParen
+alex_action_95 = symbol SymArrow
+alex_action_96 = symbol SymLambda
+alex_action_97 = symbol SymAs
+alex_action_98 = symbol SymDoubleOpenBrace
+alex_action_99 = symbol SymOpenBrace
+alex_action_100 = symbol SymCloseBrace
+alex_action_101 = litChar
+alex_action_102 = litString
+alex_action_103 = literal LitInt
+alex_action_104 = literal LitFloat
+alex_action_105 = identifier
{-# LINE 1 "templates/GenericTemplate.hs" #-}
{-# LINE 1 "templates/GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
{-# LINE 1 "<command-line>" #-}
{-# LINE 1 "templates/GenericTemplate.hs" #-}
-- -----------------------------------------------------------------------------
diff --git a/dist/build/Agda/Syntax/Parser/Parser.hs b/dist/build/Agda/Syntax/Parser/Parser.hs
index 5cca40d..cb83147 100644
--- a/dist/build/Agda/Syntax/Parser/Parser.hs
+++ b/dist/build/Agda/Syntax/Parser/Parser.hs
@@ -814,10 +814,10 @@ happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x
happyOut131 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma)
happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut131 #-}
-happyIn132 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn132 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyIn132 #-}
-happyOut132 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypeSignature])
+happyOut132 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma)
happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut132 #-}
happyIn133 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
@@ -826,10 +826,10 @@ happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x
happyOut133 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypeSignature])
happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut133 #-}
-happyIn134 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn134 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyIn134 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyIn134 #-}
-happyOut134 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg TypeSignature])
+happyOut134 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypeSignature])
happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut134 #-}
happyIn135 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
@@ -838,28 +838,28 @@ happyIn135 x = Happy_GHC_Exts.unsafeCoerce# x
happyOut135 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg TypeSignature])
happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut135 #-}
-happyIn136 :: ([Constructor]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn136 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyIn136 #-}
-happyOut136 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Constructor])
+happyOut136 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg TypeSignature])
happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut136 #-}
-happyIn137 :: ((Maybe (Ranged Induction), Maybe Name, [Declaration])) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn137 :: ([Constructor]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyIn137 #-}
-happyOut137 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((Maybe (Ranged Induction), Maybe Name, [Declaration]))
+happyOut137 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Constructor])
happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut137 #-}
-happyIn138 :: (Ranged Induction) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn138 :: ((Maybe (Ranged Induction), Maybe Name, [Declaration])) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyIn138 #-}
-happyOut138 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Ranged Induction)
+happyOut138 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((Maybe (Ranged Induction), Maybe Name, [Declaration]))
happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut138 #-}
-happyIn139 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn139 :: (Ranged Induction) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyIn139 #-}
-happyOut139 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration])
+happyOut139 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Ranged Induction)
happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut139 #-}
happyIn140 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
@@ -880,6 +880,12 @@ happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x
happyOut142 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration])
happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyOut142 #-}
+happyIn143 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
+happyIn143 x = Happy_GHC_Exts.unsafeCoerce# x
+{-# INLINE happyIn143 #-}
+happyOut143 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration])
+happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x
+{-# INLINE happyOut143 #-}
happyInTok :: (Token) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72)
happyInTok x = Happy_GHC_Exts.unsafeCoerce# x
{-# INLINE happyInTok #-}
@@ -889,21 +895,21 @@ happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x
happyActOffsets :: HappyAddr
-happyActOffsets = HappyA# "\x00\x00\x05\x09\xb7\x05\x00\x00\xdd\x04\xc0\x05\x85\x04\xc2\x05\x00\x00\xbf\x05\xc3\x05\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\xd5\x08\xac\x08\xb2\x05\x00\x00\x1d\x03\xb1\x05\x0a\x0b\x00\x00\x00\x00\x38\x0f\xa8\x05\xa8\x05\x00\x00\x00\x00\xe3\x0a\x00\x00\x00\x00\xd3\x02\xbc\x0a\x00\x00\x00\x00\x28\x0f\x6a\x06\x2b\x06\x6e\x07\x00\x00\x00\x00\x00\x00\x9d\x05\xae\x05\x00\x00\xa6\x05\xba\x01\xa4\x05\x00\x00\x00\x00\x9a\x02\x9a\x02\x00\x00\xa0\x05\ [...]
+happyActOffsets = HappyA# "\x00\x00\x4b\x09\xd7\x05\x00\x00\xe7\x04\xdb\x05\x8e\x04\xde\x05\x00\x00\xcc\x05\xd4\x05\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x01\x00\x00\x00\x00\x1a\x09\xf0\x08\xce\x05\x00\x00\xbe\x01\xc3\x05\x6b\x0b\x00\x00\x00\x00\x6f\x0f\xb9\x05\xb9\x05\x00\x00\x00\x00\x43\x0b\x00\x00\x00\x00\x0e\x02\x20\x0b\x00\x00\x00\x00\x42\x0b\x7a\x06\x3a\x06\x83\x07\x00\x00\x00\x00\x00\x00\xa9\x05\xbe\x05\x00\x00\xbb\x05\xa9\x02\xb6\x05\x00\x00\x00\x00\x9a\x02\x9a\x02\x00\x00\xb4\x05\ [...]
happyGotoOffsets :: HappyAddr
-happyGotoOffsets = HappyA# "\x37\x04\xe3\x0e\x8c\x04\x8d\x04\x87\x04\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x02\xc8\x0e\x00\x00\x00\x00\x0d\x04\xff\x03\xf1\x00\x00\x00\x00\x00\x66\x01\x79\x04\x78\x04\x00\x00\x00\x00\xc3\x02\x00\x00\x00\x00\x00\x00\xd8\x02\x00\x00\x00\x00\xf2\x00\xa8\x03\x33\x06\xb3\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x04\x72\x04\x00\x00\x00\x00 [...]
+happyGotoOffsets = HappyA# "\x83\x03\x81\x0f\x7a\x04\x79\x04\x76\x04\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x08\x66\x0f\x00\x00\x00\x00\x58\x03\xe0\x03\x9f\x00\x00\x00\x00\x00\xda\x01\x6e\x04\x5e\x04\x00\x00\x00\x00\x8d\x05\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x69\x01\xb0\x03\x42\x06\xe3\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x04\x5d\x04\x00\x00\x00\x00 [...]
happyDefActions :: HappyAddr
-happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\xa7\xfe\x80\xff\x5b\xff\x00\x00\x6f\xff\x6e\xff\x6c\xff\x6b\xff\x68\xff\x00\x00\x49\xff\x48\xff\x66\xff\x00\x00\x00\x00\x41\xff\x3f\xff\x00\x00\x00\x00\x57\xff\x56\xff\x00\x00\x00\x00\x00\x00\x55\xff\x54\xff\x00\x00\x53\xff\x52\xff\x00\x00\x00\x00\x58\xff\x59\xff\x00\x00\xa7\xfe\x00\x00\x00\x00\x98\xff\x81\xff\x5a\xff\x00\x00\x00\x00\x7a\xff\x00\x00\x79\xff\x00\x00\x5c\xff\x4e\xff\x00\x00\x00\x00\x95\xff\x00\x00\ [...]
+happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\xa6\xfe\x7f\xff\x5a\xff\x00\x00\x6e\xff\x6d\xff\x6b\xff\x6a\xff\x67\xff\x00\x00\x48\xff\x47\xff\x65\xff\x00\x00\x00\x00\x40\xff\x3e\xff\x00\x00\x00\x00\x56\xff\x55\xff\x00\x00\x00\x00\x00\x00\x54\xff\x53\xff\x00\x00\x52\xff\x51\xff\x00\x00\x00\x00\x57\xff\x58\xff\x00\x00\xa6\xfe\x00\x00\x00\x00\x97\xff\x80\xff\x59\xff\x00\x00\x00\x00\x79\xff\x00\x00\x78\xff\x00\x00\x5b\xff\x4d\xff\x00\x00\x00\x00\x94\xff\x00\x00\ [...]
happyCheck :: HappyAddr
-happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x05\x00\x09\x00\x0f\x00\x00\x00\x25\x00\x0f\x00\x10\x00\x09\x00\x43\x00\x11\x00\x0c\x00\x0d\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x3f\x00\x09\x00\x09\x00\x54\x00\x55\x00\x0c\x00\x09\x00\x0e\x00\x09\x00\x0a\x00\x09\x00\x29\x00\x0f\x00\x10\x00\x09\x00\x2d\x00\x0f\x00\x10\x00\x03\x00\x46\x00\x0f\x00\x54\x00\x00\x00\x05\x00\x36\x00\x37\x00\x09\x00\x0f\x [...]
+happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x09\x00\x0f\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x03\x00\x09\x00\x0f\x00\x00\x00\x40\x00\x0f\x00\x10\x00\x7f\x00\x09\x00\x11\x00\x02\x00\x83\x00\x0f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x09\x00\x03\x00\x09\x00\x55\x00\x44\x00\x0c\x00\x09\x00\x0e\x00\x09\x00\x0a\x00\x09\x00\x29\x00\x0f\x00\x10\x00\x00\x00\x2d\x00\x0f\x00\x10\x00\x42\x00\x7f\x00\x47\x00\x55\x00\x56\x00\x83\x00\x36\x00\x37\x00\x09\x00\x40\x [...]
happyTable :: HappyAddr
-happyTable = HappyA# "\x00\x00\x8b\x02\x94\x02\xb3\x01\xb4\x01\x07\x00\xb3\x01\xb4\x01\x32\x01\xd3\x02\x41\x00\x08\x00\xa9\x01\xee\x01\x33\x01\x58\x02\xc3\x01\x37\x01\x42\x00\x0e\x02\x6c\x02\x51\x01\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x11\x02\x37\x02\xc3\x01\x2c\x00\x2d\x00\xc4\x01\x32\x01\xc5\x01\xb3\x01\xb4\x01\x32\x01\x73\x01\x33\x01\x34\x01\x07\x00\xd8\x01\x33\x01\x58\x02\xb1\x01\x08\x02\x08\x00\x2c\x00\xa9\x01\xce\x02\x75\x01\x63\x00\x41\x00\x9f\x [...]
+happyTable = HappyA# "\x00\x00\x8f\x02\x98\x02\x9e\x02\xa9\x02\x07\x00\xb6\x01\xb7\x01\x35\x01\xb4\x01\x41\x00\x08\x00\xac\x01\x15\x02\x36\x01\x5c\x02\x60\x02\xd0\x02\x42\x00\x54\x01\xb8\x02\xb5\x01\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x3b\x02\x21\x02\xc6\x01\x2c\x00\x3a\x01\xc7\x01\x35\x01\xc8\x01\xb6\x01\xb7\x01\x35\x01\x76\x01\x36\x01\x37\x01\xac\x01\xdb\x01\x36\x01\x5c\x02\x8a\x01\x60\x02\x0c\x02\x2c\x00\x2d\x00\xb9\x02\x78\x01\x63\x00\xd1\x02\x9f\x [...]
-happyReduceArr = Happy_Data_Array.array (3, 416) [
+happyReduceArr = Happy_Data_Array.array (3, 419) [
(3 , happyReduce_3),
(4 , happyReduce_4),
(5 , happyReduce_5),
@@ -1317,11 +1323,14 @@ happyReduceArr = Happy_Data_Array.array (3, 416) [
(413 , happyReduce_413),
(414 , happyReduce_414),
(415 , happyReduce_415),
- (416 , happyReduce_416)
+ (416 , happyReduce_416),
+ (417 , happyReduce_417),
+ (418 , happyReduce_418),
+ (419 , happyReduce_419)
]
-happy_n_terms = 89 :: Int
-happy_n_nonterms = 137 :: Int
+happy_n_terms = 90 :: Int
+happy_n_nonterms = 138 :: Int
happyReduce_3 = happySpecReduce_1 0# happyReduction_3
happyReduction_3 happy_x_1
@@ -1689,272 +1698,279 @@ happyReduction_54 happy_x_1
happyReduce_55 = happySpecReduce_1 2# happyReduction_55
happyReduction_55 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwMEASURE happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwTERMINATING happy_var_1) ->
happyIn8
- (TokKeyword KwMEASURE happy_var_1
+ (TokKeyword KwTERMINATING happy_var_1
)}
happyReduce_56 = happySpecReduce_1 2# happyReduction_56
happyReduction_56 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwMEASURE happy_var_1) ->
happyIn8
- (TokKeyword KwQuoteGoal happy_var_1
+ (TokKeyword KwMEASURE happy_var_1
)}
happyReduce_57 = happySpecReduce_1 2# happyReduction_57
happyReduction_57 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) ->
happyIn8
- (TokKeyword KwQuoteContext happy_var_1
+ (TokKeyword KwQuoteGoal happy_var_1
)}
happyReduce_58 = happySpecReduce_1 2# happyReduction_58
happyReduction_58 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) ->
happyIn8
- (TokKeyword KwQuote happy_var_1
+ (TokKeyword KwQuoteContext happy_var_1
)}
happyReduce_59 = happySpecReduce_1 2# happyReduction_59
happyReduction_59 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) ->
happyIn8
- (TokKeyword KwQuoteTerm happy_var_1
+ (TokKeyword KwQuote happy_var_1
)}
happyReduce_60 = happySpecReduce_1 2# happyReduction_60
happyReduction_60 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) ->
happyIn8
- (TokKeyword KwTactic happy_var_1
+ (TokKeyword KwQuoteTerm happy_var_1
)}
happyReduce_61 = happySpecReduce_1 2# happyReduction_61
happyReduction_61 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) ->
happyIn8
- (TokKeyword KwUnquote happy_var_1
+ (TokKeyword KwTactic happy_var_1
)}
happyReduce_62 = happySpecReduce_1 2# happyReduction_62
happyReduction_62 happy_x_1
- = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) ->
happyIn8
- (TokKeyword KwUnquoteDecl happy_var_1
+ (TokKeyword KwUnquote happy_var_1
)}
happyReduce_63 = happySpecReduce_1 2# happyReduction_63
happyReduction_63 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSetN happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) ->
happyIn8
- (TokSetN happy_var_1
+ (TokKeyword KwUnquoteDecl happy_var_1
)}
happyReduce_64 = happySpecReduce_1 2# happyReduction_64
happyReduction_64 happy_x_1
- = case happyOutTok happy_x_1 of { (TokTeX happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSetN happy_var_1) ->
happyIn8
- (TokTeX happy_var_1
+ (TokSetN happy_var_1
)}
happyReduce_65 = happySpecReduce_1 2# happyReduction_65
happyReduction_65 happy_x_1
- = case happyOutTok happy_x_1 of { (TokComment happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokTeX happy_var_1) ->
happyIn8
- (TokComment happy_var_1
+ (TokTeX happy_var_1
)}
happyReduce_66 = happySpecReduce_1 2# happyReduction_66
happyReduction_66 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokComment happy_var_1) ->
happyIn8
- (TokSymbol SymEllipsis happy_var_1
+ (TokComment happy_var_1
)}
happyReduce_67 = happySpecReduce_1 2# happyReduction_67
happyReduction_67 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymDotDot happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) ->
happyIn8
- (TokSymbol SymDotDot happy_var_1
+ (TokSymbol SymEllipsis happy_var_1
)}
happyReduce_68 = happySpecReduce_1 2# happyReduction_68
happyReduction_68 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymDotDot happy_var_1) ->
happyIn8
- (TokSymbol SymDot happy_var_1
+ (TokSymbol SymDotDot happy_var_1
)}
happyReduce_69 = happySpecReduce_1 2# happyReduction_69
happyReduction_69 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) ->
happyIn8
- (TokSymbol SymSemi happy_var_1
+ (TokSymbol SymDot happy_var_1
)}
happyReduce_70 = happySpecReduce_1 2# happyReduction_70
happyReduction_70 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymColon happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) ->
happyIn8
- (TokSymbol SymColon happy_var_1
+ (TokSymbol SymSemi happy_var_1
)}
happyReduce_71 = happySpecReduce_1 2# happyReduction_71
happyReduction_71 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymEqual happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymColon happy_var_1) ->
happyIn8
- (TokSymbol SymEqual happy_var_1
+ (TokSymbol SymColon happy_var_1
)}
happyReduce_72 = happySpecReduce_1 2# happyReduction_72
happyReduction_72 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymEqual happy_var_1) ->
happyIn8
- (TokSymbol SymUnderscore happy_var_1
+ (TokSymbol SymEqual happy_var_1
)}
happyReduce_73 = happySpecReduce_1 2# happyReduction_73
happyReduction_73 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) ->
happyIn8
- (TokSymbol SymQuestionMark happy_var_1
+ (TokSymbol SymUnderscore happy_var_1
)}
happyReduce_74 = happySpecReduce_1 2# happyReduction_74
happyReduction_74 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymArrow happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) ->
happyIn8
- (TokSymbol SymArrow happy_var_1
+ (TokSymbol SymQuestionMark happy_var_1
)}
happyReduce_75 = happySpecReduce_1 2# happyReduction_75
happyReduction_75 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymArrow happy_var_1) ->
happyIn8
- (TokSymbol SymLambda happy_var_1
+ (TokSymbol SymArrow happy_var_1
)}
happyReduce_76 = happySpecReduce_1 2# happyReduction_76
happyReduction_76 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymAs happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) ->
happyIn8
- (TokSymbol SymAs happy_var_1
+ (TokSymbol SymLambda happy_var_1
)}
happyReduce_77 = happySpecReduce_1 2# happyReduction_77
happyReduction_77 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymBar happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymAs happy_var_1) ->
happyIn8
- (TokSymbol SymBar happy_var_1
+ (TokSymbol SymAs happy_var_1
)}
happyReduce_78 = happySpecReduce_1 2# happyReduction_78
happyReduction_78 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymBar happy_var_1) ->
happyIn8
- (TokSymbol SymOpenParen happy_var_1
+ (TokSymbol SymBar happy_var_1
)}
happyReduce_79 = happySpecReduce_1 2# happyReduction_79
happyReduction_79 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymCloseParen happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
happyIn8
- (TokSymbol SymCloseParen happy_var_1
+ (TokSymbol SymOpenParen happy_var_1
)}
happyReduce_80 = happySpecReduce_1 2# happyReduction_80
happyReduction_80 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymCloseParen happy_var_1) ->
happyIn8
- (TokSymbol SymDoubleOpenBrace happy_var_1
+ (TokSymbol SymCloseParen happy_var_1
)}
happyReduce_81 = happySpecReduce_1 2# happyReduction_81
happyReduction_81 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) ->
happyIn8
- (TokSymbol SymDoubleCloseBrace happy_var_1
+ (TokSymbol SymDoubleOpenBrace happy_var_1
)}
happyReduce_82 = happySpecReduce_1 2# happyReduction_82
happyReduction_82 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) ->
happyIn8
- (TokSymbol SymOpenBrace happy_var_1
+ (TokSymbol SymDoubleCloseBrace happy_var_1
)}
happyReduce_83 = happySpecReduce_1 2# happyReduction_83
happyReduction_83 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) ->
happyIn8
- (TokSymbol SymCloseBrace happy_var_1
+ (TokSymbol SymOpenBrace happy_var_1
)}
happyReduce_84 = happySpecReduce_1 2# happyReduction_84
happyReduction_84 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymOpenVirtualBrace happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) ->
happyIn8
- (TokSymbol SymOpenVirtualBrace happy_var_1
+ (TokSymbol SymCloseBrace happy_var_1
)}
happyReduce_85 = happySpecReduce_1 2# happyReduction_85
happyReduction_85 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymCloseVirtualBrace happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymOpenVirtualBrace happy_var_1) ->
happyIn8
- (TokSymbol SymCloseVirtualBrace happy_var_1
+ (TokSymbol SymOpenVirtualBrace happy_var_1
)}
happyReduce_86 = happySpecReduce_1 2# happyReduction_86
happyReduction_86 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymCloseVirtualBrace happy_var_1) ->
happyIn8
- (TokSymbol SymVirtualSemi happy_var_1
+ (TokSymbol SymCloseVirtualBrace happy_var_1
)}
happyReduce_87 = happySpecReduce_1 2# happyReduction_87
happyReduction_87 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) ->
happyIn8
- (TokSymbol SymOpenPragma happy_var_1
+ (TokSymbol SymVirtualSemi happy_var_1
)}
happyReduce_88 = happySpecReduce_1 2# happyReduction_88
happyReduction_88 happy_x_1
- = case happyOutTok happy_x_1 of { (TokSymbol SymClosePragma happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) ->
happyIn8
- (TokSymbol SymClosePragma happy_var_1
+ (TokSymbol SymOpenPragma happy_var_1
)}
happyReduce_89 = happySpecReduce_1 2# happyReduction_89
happyReduction_89 happy_x_1
- = case happyOutTok happy_x_1 of { (TokId happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokSymbol SymClosePragma happy_var_1) ->
happyIn8
- (TokId happy_var_1
+ (TokSymbol SymClosePragma happy_var_1
)}
happyReduce_90 = happySpecReduce_1 2# happyReduction_90
happyReduction_90 happy_x_1
- = case happyOutTok happy_x_1 of { (TokQId happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokId happy_var_1) ->
happyIn8
- (TokQId happy_var_1
+ (TokId happy_var_1
)}
happyReduce_91 = happySpecReduce_1 2# happyReduction_91
happyReduction_91 happy_x_1
- = case happyOutTok happy_x_1 of { (TokString happy_var_1) ->
+ = case happyOutTok happy_x_1 of { (TokQId happy_var_1) ->
happyIn8
- (TokString happy_var_1
+ (TokQId happy_var_1
)}
happyReduce_92 = happySpecReduce_1 2# happyReduction_92
happyReduction_92 happy_x_1
+ = case happyOutTok happy_x_1 of { (TokString happy_var_1) ->
+ happyIn8
+ (TokString happy_var_1
+ )}
+
+happyReduce_93 = happySpecReduce_1 2# happyReduction_93
+happyReduction_93 happy_x_1
= case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) ->
happyIn8
(TokLiteral happy_var_1
)}
-happyReduce_93 = happySpecReduce_3 3# happyReduction_93
-happyReduction_93 happy_x_3
+happyReduce_94 = happySpecReduce_3 3# happyReduction_94
+happyReduction_94 happy_x_3
happy_x_2
happy_x_1
= case happyOut113 happy_x_2 of { happy_var_2 ->
@@ -1962,79 +1978,79 @@ happyReduction_93 happy_x_3
(takeOptionsPragmas happy_var_2
)}
-happyReduce_94 = happySpecReduce_0 4# happyReduction_94
-happyReduction_94 = happyIn10
+happyReduce_95 = happySpecReduce_0 4# happyReduction_95
+happyReduction_95 = happyIn10
(()
)
-happyReduce_95 = happySpecReduce_1 4# happyReduction_95
-happyReduction_95 happy_x_1
+happyReduce_96 = happySpecReduce_1 4# happyReduction_96
+happyReduction_96 happy_x_1
= happyIn10
(()
)
-happyReduce_96 = happySpecReduce_1 5# happyReduction_96
-happyReduction_96 happy_x_1
+happyReduce_97 = happySpecReduce_1 5# happyReduction_97
+happyReduction_97 happy_x_1
= happyIn11
(()
)
-happyReduce_97 = happyMonadReduce 1# 5# happyReduction_97
-happyReduction_97 (happy_x_1 `HappyStk`
+happyReduce_98 = happyMonadReduce 1# 5# happyReduction_98
+happyReduction_98 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (( popContext)
) (\r -> happyReturn (happyIn11 r))
-happyReduce_98 = happySpecReduce_1 6# happyReduction_98
-happyReduction_98 happy_x_1
+happyReduce_99 = happySpecReduce_1 6# happyReduction_99
+happyReduction_99 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) ->
happyIn12
(happy_var_1
)}
-happyReduce_99 = happySpecReduce_1 6# happyReduction_99
-happyReduction_99 happy_x_1
+happyReduce_100 = happySpecReduce_1 6# happyReduction_100
+happyReduction_100 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) ->
happyIn12
(happy_var_1
)}
-happyReduce_100 = happyMonadReduce 0# 7# happyReduction_100
-happyReduction_100 (happyRest) tk
+happyReduce_101 = happyMonadReduce 0# 7# happyReduction_101
+happyReduction_101 (happyRest) tk
= happyThen (( pushLexState imp_dir)
) (\r -> happyReturn (happyIn13 r))
-happyReduce_101 = happyMonadReduce 1# 8# happyReduction_101
-happyReduction_101 (happy_x_1 `HappyStk`
+happyReduce_102 = happyMonadReduce 1# 8# happyReduction_102
+happyReduction_102 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) ->
( case happy_var_1 of {
- LitInt _ i -> return i;
- _ -> fail $ "Expected integer"
- })}
+ LitInt _ i -> return i;
+ _ -> fail $ "Expected integer"
+ })}
) (\r -> happyReturn (happyIn14 r))
-happyReduce_102 = happyMonadReduce 1# 8# happyReduction_102
-happyReduction_102 (happy_x_1 `HappyStk`
+happyReduce_103 = happyMonadReduce 1# 8# happyReduction_103
+happyReduction_103 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) ->
( case happy_var_1 of {
(_, s) -> case readM s of {
Right i -> return i;
- Left (err :: String) -> fail $ "Expected integer"
- }
+ Left (err :: String) -> fail $ "Expected integer"
+ }
})}
) (\r -> happyReturn (happyIn14 r))
-happyReduce_103 = happyMonadReduce 1# 9# happyReduction_103
-happyReduction_103 (happy_x_1 `HappyStk`
+happyReduce_104 = happyMonadReduce 1# 9# happyReduction_104
+happyReduction_104 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) ->
( mkName happy_var_1)}
) (\r -> happyReturn (happyIn15 r))
-happyReduce_104 = happySpecReduce_2 10# happyReduction_104
-happyReduction_104 happy_x_2
+happyReduce_105 = happySpecReduce_2 10# happyReduction_105
+happyReduction_105 happy_x_2
happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
case happyOut16 happy_x_2 of { happy_var_2 ->
@@ -2042,51 +2058,51 @@ happyReduction_104 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_105 = happySpecReduce_1 10# happyReduction_105
-happyReduction_105 happy_x_1
+happyReduce_106 = happySpecReduce_1 10# happyReduction_106
+happyReduction_106 happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
happyIn16
([happy_var_1]
)}
-happyReduce_106 = happySpecReduce_1 11# happyReduction_106
-happyReduction_106 happy_x_1
+happyReduce_107 = happySpecReduce_1 11# happyReduction_107
+happyReduction_107 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) ->
happyIn17
(getRange happy_var_1
)}
-happyReduce_107 = happyMonadReduce 2# 11# happyReduction_107
-happyReduction_107 (happy_x_2 `HappyStk`
+happyReduce_108 = happyMonadReduce 2# 11# happyReduction_108
+happyReduction_108 (happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) ->
case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) ->
(
if posPos (fromJust (rEnd (getRange happy_var_2))) -
- posPos (fromJust (rStart (getRange happy_var_1))) > 2
+ posPos (fromJust (rStart (getRange happy_var_1))) > 2
then parseErrorAt (fromJust (rStart (getRange happy_var_2)))
- "Expecting '}}', found separated '}'s."
+ "Expecting '}}', found separated '}'s."
else return $ getRange (happy_var_1, happy_var_2))}}
) (\r -> happyReturn (happyIn17 r))
-happyReduce_108 = happySpecReduce_2 12# happyReduction_108
-happyReduction_108 happy_x_2
+happyReduce_109 = happySpecReduce_2 12# happyReduction_109
+happyReduction_109 happy_x_2
happy_x_1
= case happyOut15 happy_x_2 of { happy_var_2 ->
happyIn18
(setRelevance Irrelevant $ defaultArg happy_var_2
)}
-happyReduce_109 = happySpecReduce_1 12# happyReduction_109
-happyReduction_109 happy_x_1
+happyReduce_110 = happySpecReduce_1 12# happyReduction_110
+happyReduction_110 happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
happyIn18
(defaultArg happy_var_1
)}
-happyReduce_110 = happySpecReduce_2 13# happyReduction_110
-happyReduction_110 happy_x_2
+happyReduce_111 = happySpecReduce_2 13# happyReduction_111
+happyReduction_111 happy_x_2
happy_x_1
= case happyOut18 happy_x_1 of { happy_var_1 ->
case happyOut19 happy_x_2 of { happy_var_2 ->
@@ -2094,15 +2110,15 @@ happyReduction_110 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_111 = happySpecReduce_1 13# happyReduction_111
-happyReduction_111 happy_x_1
+happyReduce_112 = happySpecReduce_1 13# happyReduction_112
+happyReduction_112 happy_x_1
= case happyOut18 happy_x_1 of { happy_var_1 ->
happyIn19
([happy_var_1]
)}
-happyReduce_112 = happySpecReduce_2 14# happyReduction_112
-happyReduction_112 happy_x_2
+happyReduce_113 = happySpecReduce_2 14# happyReduction_113
+happyReduction_113 happy_x_2
happy_x_1
= case happyOut18 happy_x_1 of { happy_var_1 ->
case happyOut20 happy_x_2 of { happy_var_2 ->
@@ -2110,15 +2126,15 @@ happyReduction_112 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_113 = happySpecReduce_1 14# happyReduction_113
-happyReduction_113 happy_x_1
+happyReduce_114 = happySpecReduce_1 14# happyReduction_114
+happyReduction_114 happy_x_1
= case happyOut18 happy_x_1 of { happy_var_1 ->
happyIn20
([happy_var_1]
)}
-happyReduce_114 = happyReduce 4# 14# happyReduction_114
-happyReduction_114 (happy_x_4 `HappyStk`
+happyReduce_115 = happyReduce 4# 14# happyReduction_115
+happyReduction_115 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2129,8 +2145,8 @@ happyReduction_114 (happy_x_4 `HappyStk`
(map makeInstance happy_var_2 ++ happy_var_4
) `HappyStk` happyRest}}
-happyReduce_115 = happySpecReduce_3 14# happyReduction_115
-happyReduction_115 happy_x_3
+happyReduce_116 = happySpecReduce_3 14# happyReduction_116
+happyReduction_116 happy_x_3
happy_x_2
happy_x_1
= case happyOut19 happy_x_2 of { happy_var_2 ->
@@ -2138,8 +2154,8 @@ happyReduction_115 happy_x_3
(map makeInstance happy_var_2
)}
-happyReduce_116 = happyReduce 4# 14# happyReduction_116
-happyReduction_116 (happy_x_4 `HappyStk`
+happyReduce_117 = happyReduce 4# 14# happyReduction_117
+happyReduction_117 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2150,8 +2166,8 @@ happyReduction_116 (happy_x_4 `HappyStk`
(map hide happy_var_2 ++ happy_var_4
) `HappyStk` happyRest}}
-happyReduce_117 = happySpecReduce_3 14# happyReduction_117
-happyReduction_117 happy_x_3
+happyReduce_118 = happySpecReduce_3 14# happyReduction_118
+happyReduction_118 happy_x_3
happy_x_2
happy_x_1
= case happyOut19 happy_x_2 of { happy_var_2 ->
@@ -2159,8 +2175,8 @@ happyReduction_117 happy_x_3
(map hide happy_var_2
)}
-happyReduce_118 = happyReduce 5# 14# happyReduction_118
-happyReduction_118 (happy_x_5 `HappyStk`
+happyReduce_119 = happyReduce 5# 14# happyReduction_119
+happyReduction_119 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -2172,8 +2188,8 @@ happyReduction_118 (happy_x_5 `HappyStk`
(map (hide . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5
) `HappyStk` happyRest}}
-happyReduce_119 = happyReduce 4# 14# happyReduction_119
-happyReduction_119 (happy_x_4 `HappyStk`
+happyReduce_120 = happyReduce 4# 14# happyReduction_120
+happyReduction_120 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2183,8 +2199,8 @@ happyReduction_119 (happy_x_4 `HappyStk`
(map (hide . setRelevance Irrelevant . defaultArg) happy_var_3
) `HappyStk` happyRest}
-happyReduce_120 = happyReduce 5# 14# happyReduction_120
-happyReduction_120 (happy_x_5 `HappyStk`
+happyReduce_121 = happyReduce 5# 14# happyReduction_121
+happyReduction_121 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -2196,8 +2212,8 @@ happyReduction_120 (happy_x_5 `HappyStk`
(map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5
) `HappyStk` happyRest}}
-happyReduce_121 = happyReduce 4# 14# happyReduction_121
-happyReduction_121 (happy_x_4 `HappyStk`
+happyReduce_122 = happyReduce 4# 14# happyReduction_122
+happyReduction_122 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2207,8 +2223,8 @@ happyReduction_121 (happy_x_4 `HappyStk`
(map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3
) `HappyStk` happyRest}
-happyReduce_122 = happyReduce 5# 14# happyReduction_122
-happyReduction_122 (happy_x_5 `HappyStk`
+happyReduce_123 = happyReduce 5# 14# happyReduction_123
+happyReduction_123 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -2220,8 +2236,8 @@ happyReduction_122 (happy_x_5 `HappyStk`
(map (hide . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5
) `HappyStk` happyRest}}
-happyReduce_123 = happyReduce 4# 14# happyReduction_123
-happyReduction_123 (happy_x_4 `HappyStk`
+happyReduce_124 = happyReduce 4# 14# happyReduction_124
+happyReduction_124 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2231,8 +2247,8 @@ happyReduction_123 (happy_x_4 `HappyStk`
(map (hide . setRelevance NonStrict . defaultArg) happy_var_3
) `HappyStk` happyRest}
-happyReduce_124 = happyReduce 5# 14# happyReduction_124
-happyReduction_124 (happy_x_5 `HappyStk`
+happyReduce_125 = happyReduce 5# 14# happyReduction_125
+happyReduction_125 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -2244,8 +2260,8 @@ happyReduction_124 (happy_x_5 `HappyStk`
(map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5
) `HappyStk` happyRest}}
-happyReduce_125 = happyReduce 4# 14# happyReduction_125
-happyReduction_125 (happy_x_4 `HappyStk`
+happyReduce_126 = happyReduce 4# 14# happyReduction_126
+happyReduction_126 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2255,43 +2271,43 @@ happyReduction_125 (happy_x_4 `HappyStk`
(map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3
) `HappyStk` happyRest}
-happyReduce_126 = happyMonadReduce 1# 15# happyReduction_126
-happyReduction_126 (happy_x_1 `HappyStk`
+happyReduce_127 = happyMonadReduce 1# 15# happyReduction_127
+happyReduction_127 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokQId happy_var_1) ->
( mkQName happy_var_1)}
) (\r -> happyReturn (happyIn21 r))
-happyReduce_127 = happySpecReduce_1 15# happyReduction_127
-happyReduction_127 happy_x_1
+happyReduce_128 = happySpecReduce_1 15# happyReduction_128
+happyReduction_128 happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
happyIn21
(QName happy_var_1
)}
-happyReduce_128 = happySpecReduce_1 16# happyReduction_128
-happyReduction_128 happy_x_1
+happyReduce_129 = happySpecReduce_1 16# happyReduction_129
+happyReduction_129 happy_x_1
= case happyOut21 happy_x_1 of { happy_var_1 ->
happyIn22
(happy_var_1
)}
-happyReduce_129 = happySpecReduce_1 17# happyReduction_129
-happyReduction_129 happy_x_1
+happyReduce_130 = happySpecReduce_1 17# happyReduction_130
+happyReduction_130 happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
happyIn23
(happy_var_1
)}
-happyReduce_130 = happySpecReduce_1 17# happyReduction_130
-happyReduction_130 happy_x_1
+happyReduce_131 = happySpecReduce_1 17# happyReduction_131
+happyReduction_131 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) ->
happyIn23
(Name (getRange happy_var_1) [Hole]
)}
-happyReduce_131 = happySpecReduce_2 18# happyReduction_131
-happyReduction_131 happy_x_2
+happyReduce_132 = happySpecReduce_2 18# happyReduction_132
+happyReduction_132 happy_x_2
happy_x_1
= case happyOut23 happy_x_1 of { happy_var_1 ->
case happyOut24 happy_x_2 of { happy_var_2 ->
@@ -2299,15 +2315,15 @@ happyReduction_131 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_132 = happySpecReduce_1 18# happyReduction_132
-happyReduction_132 happy_x_1
+happyReduce_133 = happySpecReduce_1 18# happyReduction_133
+happyReduction_133 happy_x_1
= case happyOut23 happy_x_1 of { happy_var_1 ->
happyIn24
([happy_var_1]
)}
-happyReduce_133 = happySpecReduce_1 19# happyReduction_133
-happyReduction_133 happy_x_1
+happyReduce_134 = happySpecReduce_1 19# happyReduction_134
+happyReduction_134 happy_x_1
= case happyOut26 happy_x_1 of { happy_var_1 ->
happyIn25
(case happy_var_1 of
@@ -2315,14 +2331,14 @@ happyReduction_133 happy_x_1
Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern"
)}
-happyReduce_134 = happyMonadReduce 1# 20# happyReduction_134
-happyReduction_134 (happy_x_1 `HappyStk`
+happyReduce_135 = happyMonadReduce 1# 20# happyReduction_135
+happyReduction_135 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut34 happy_x_1 of { happy_var_1 ->
(
let getName (Ident (QName x)) = Just x
- getName (Underscore r _) = Just (Name r [Hole])
- getName _ = Nothing
+ getName (Underscore r _) = Just (Name r [Hole])
+ getName _ = Nothing
containsAbsurd (Absurd _) = True
containsAbsurd (HiddenArg _ (Named _ e)) = containsAbsurd e
@@ -2333,17 +2349,17 @@ happyReduction_134 (happy_x_1 `HappyStk`
in
if isJust $ find containsAbsurd happy_var_1 then return $ Right happy_var_1 else
case partition isJust $ map getName happy_var_1 of
- (good, []) -> return $ Left $ map fromJust good
- _ -> fail $ "expected sequence of bound identifiers")}
+ (good, []) -> return $ Left $ map fromJust good
+ _ -> fail $ "expected sequence of bound identifiers")}
) (\r -> happyReturn (happyIn26 r))
-happyReduce_135 = happySpecReduce_0 21# happyReduction_135
-happyReduction_135 = happyIn27
+happyReduce_136 = happySpecReduce_0 21# happyReduction_136
+happyReduction_136 = happyIn27
([]
)
-happyReduce_136 = happySpecReduce_2 21# happyReduction_136
-happyReduction_136 happy_x_2
+happyReduce_137 = happySpecReduce_2 21# happyReduction_137
+happyReduction_137 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokString happy_var_1) ->
case happyOut27 happy_x_2 of { happy_var_2 ->
@@ -2351,29 +2367,29 @@ happyReduction_136 happy_x_2
(snd happy_var_1 : happy_var_2
)}}
-happyReduce_137 = happySpecReduce_1 22# happyReduction_137
-happyReduction_137 happy_x_1
+happyReduce_138 = happySpecReduce_1 22# happyReduction_138
+happyReduction_138 happy_x_1
= case happyOutTok happy_x_1 of { (TokString happy_var_1) ->
happyIn28
(snd happy_var_1
)}
-happyReduce_138 = happyMonadReduce 1# 23# happyReduction_138
-happyReduction_138 (happy_x_1 `HappyStk`
+happyReduce_139 = happyMonadReduce 1# 23# happyReduction_139
+happyReduction_139 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) ->
( mkName happy_var_1)}
) (\r -> happyReturn (happyIn29 r))
-happyReduce_139 = happyMonadReduce 1# 24# happyReduction_139
-happyReduction_139 (happy_x_1 `HappyStk`
+happyReduce_140 = happyMonadReduce 1# 24# happyReduction_140
+happyReduction_140 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) ->
( fmap QName (mkName happy_var_1))}
) (\r -> happyReturn (happyIn30 r))
-happyReduce_140 = happySpecReduce_2 25# happyReduction_140
-happyReduction_140 happy_x_2
+happyReduce_141 = happySpecReduce_2 25# happyReduction_141
+happyReduction_141 happy_x_2
happy_x_1
= case happyOut44 happy_x_1 of { happy_var_1 ->
case happyOut31 happy_x_2 of { happy_var_2 ->
@@ -2381,8 +2397,8 @@ happyReduction_140 happy_x_2
(Pi happy_var_1 happy_var_2
)}}
-happyReduce_141 = happySpecReduce_3 25# happyReduction_141
-happyReduction_141 happy_x_3
+happyReduce_142 = happySpecReduce_3 25# happyReduction_142
+happyReduction_142 happy_x_3
happy_x_2
happy_x_1
= case happyOut57 happy_x_2 of { happy_var_2 ->
@@ -2391,8 +2407,8 @@ happyReduction_141 happy_x_3
(forallPi happy_var_2 happy_var_3
)}}
-happyReduce_142 = happySpecReduce_3 25# happyReduction_142
-happyReduction_142 happy_x_3
+happyReduce_143 = happySpecReduce_3 25# happyReduction_143
+happyReduction_143 happy_x_3
happy_x_2
happy_x_1
= case happyOut37 happy_x_1 of { happy_var_1 ->
@@ -2404,8 +2420,8 @@ happyReduction_142 happy_x_3
happy_var_3
)}}}
-happyReduce_143 = happySpecReduce_3 25# happyReduction_143
-happyReduction_143 happy_x_3
+happyReduce_144 = happySpecReduce_3 25# happyReduction_144
+happyReduction_144 happy_x_3
happy_x_2
happy_x_1
= case happyOut32 happy_x_1 of { happy_var_1 ->
@@ -2415,26 +2431,26 @@ happyReduction_143 happy_x_3
(Equal (getRange (happy_var_1, happy_var_2, happy_var_3)) happy_var_1 happy_var_3
)}}}
-happyReduce_144 = happySpecReduce_1 25# happyReduction_144
-happyReduction_144 happy_x_1
+happyReduce_145 = happySpecReduce_1 25# happyReduction_145
+happyReduction_145 happy_x_1
= case happyOut32 happy_x_1 of { happy_var_1 ->
happyIn31
(happy_var_1
)}
-happyReduce_145 = happyMonadReduce 1# 26# happyReduction_145
-happyReduction_145 (happy_x_1 `HappyStk`
+happyReduce_146 = happyMonadReduce 1# 26# happyReduction_146
+happyReduction_146 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut33 happy_x_1 of { happy_var_1 ->
( case happy_var_1 of
- { [e] -> return e
- ; e : es -> return $ WithApp (fuseRange e es) e es
- ; [] -> fail "impossible: empty with expressions"
- })}
+ { [e] -> return e
+ ; e : es -> return $ WithApp (fuseRange e es) e es
+ ; [] -> fail "impossible: empty with expressions"
+ })}
) (\r -> happyReturn (happyIn32 r))
-happyReduce_146 = happySpecReduce_3 27# happyReduction_146
-happyReduction_146 happy_x_3
+happyReduce_147 = happySpecReduce_3 27# happyReduction_147
+happyReduction_147 happy_x_3
happy_x_2
happy_x_1
= case happyOut37 happy_x_1 of { happy_var_1 ->
@@ -2443,22 +2459,22 @@ happyReduction_146 happy_x_3
(RawApp (getRange happy_var_1) happy_var_1 : happy_var_3
)}}
-happyReduce_147 = happySpecReduce_1 27# happyReduction_147
-happyReduction_147 happy_x_1
+happyReduce_148 = happySpecReduce_1 27# happyReduction_148
+happyReduction_148 happy_x_1
= case happyOut34 happy_x_1 of { happy_var_1 ->
happyIn33
([RawApp (getRange happy_var_1) happy_var_1]
)}
-happyReduce_148 = happySpecReduce_1 28# happyReduction_148
-happyReduction_148 happy_x_1
+happyReduce_149 = happySpecReduce_1 28# happyReduction_149
+happyReduction_149 happy_x_1
= case happyOut35 happy_x_1 of { happy_var_1 ->
happyIn34
([happy_var_1]
)}
-happyReduce_149 = happySpecReduce_2 28# happyReduction_149
-happyReduction_149 happy_x_2
+happyReduce_150 = happySpecReduce_2 28# happyReduction_150
+happyReduction_150 happy_x_2
happy_x_1
= case happyOut40 happy_x_1 of { happy_var_1 ->
case happyOut34 happy_x_2 of { happy_var_2 ->
@@ -2466,8 +2482,8 @@ happyReduction_149 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_150 = happySpecReduce_3 29# happyReduction_150
-happyReduction_150 happy_x_3
+happyReduce_151 = happySpecReduce_3 29# happyReduction_151
+happyReduction_151 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) ->
@@ -2477,36 +2493,36 @@ happyReduction_150 happy_x_3
(Lam (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 happy_var_3
)}}}
-happyReduce_151 = happySpecReduce_1 29# happyReduction_151
-happyReduction_151 happy_x_1
+happyReduce_152 = happySpecReduce_1 29# happyReduction_152
+happyReduction_152 happy_x_1
= case happyOut36 happy_x_1 of { happy_var_1 ->
happyIn35
(happy_var_1
)}
-happyReduce_152 = happyReduce 4# 29# happyReduction_152
-happyReduction_152 (happy_x_4 `HappyStk`
+happyReduce_153 = happyReduce 4# 29# happyReduction_153
+happyReduction_153 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) ->
- case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut140 happy_x_2 of { happy_var_2 ->
case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) ->
case happyOut31 happy_x_4 of { happy_var_4 ->
happyIn35
(Let (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4
) `HappyStk` happyRest}}}}
-happyReduce_153 = happySpecReduce_1 29# happyReduction_153
-happyReduction_153 happy_x_1
+happyReduce_154 = happySpecReduce_1 29# happyReduction_154
+happyReduction_154 happy_x_1
= case happyOut40 happy_x_1 of { happy_var_1 ->
happyIn35
(happy_var_1
)}
-happyReduce_154 = happyReduce 4# 29# happyReduction_154
-happyReduction_154 (happy_x_4 `HappyStk`
+happyReduce_155 = happyReduce 4# 29# happyReduction_155
+happyReduction_155 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2519,8 +2535,8 @@ happyReduction_154 (happy_x_4 `HappyStk`
(QuoteGoal (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4
) `HappyStk` happyRest}}}}
-happyReduce_155 = happyReduce 4# 29# happyReduction_155
-happyReduction_155 (happy_x_4 `HappyStk`
+happyReduce_156 = happyReduce 4# 29# happyReduction_156
+happyReduction_156 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2533,8 +2549,8 @@ happyReduction_155 (happy_x_4 `HappyStk`
(QuoteContext (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4
) `HappyStk` happyRest}}}}
-happyReduce_156 = happySpecReduce_2 29# happyReduction_156
-happyReduction_156 happy_x_2
+happyReduce_157 = happySpecReduce_2 29# happyReduction_157
+happyReduction_157 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) ->
case happyOut37 happy_x_2 of { happy_var_2 ->
@@ -2542,8 +2558,8 @@ happyReduction_156 happy_x_2
(Tactic (getRange (happy_var_1, happy_var_2)) (RawApp (getRange happy_var_2) happy_var_2) []
)}}
-happyReduce_157 = happyReduce 4# 29# happyReduction_157
-happyReduction_157 (happy_x_4 `HappyStk`
+happyReduce_158 = happyReduce 4# 29# happyReduction_158
+happyReduction_158 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2556,8 +2572,8 @@ happyReduction_157 (happy_x_4 `HappyStk`
(Tactic (getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4)) (RawApp (getRange happy_var_2) happy_var_2) happy_var_4
) `HappyStk` happyRest}}}}
-happyReduce_158 = happyReduce 4# 30# happyReduction_158
-happyReduction_158 (happy_x_4 `HappyStk`
+happyReduce_159 = happyReduce 4# 30# happyReduction_159
+happyReduction_159 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2570,8 +2586,8 @@ happyReduction_158 (happy_x_4 `HappyStk`
(ExtendedLam (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) (reverse happy_var_3)
) `HappyStk` happyRest}}}}
-happyReduce_159 = happyMonadReduce 2# 30# happyReduction_159
-happyReduction_159 (happy_x_2 `HappyStk`
+happyReduce_160 = happyMonadReduce 2# 30# happyReduction_160
+happyReduction_160 (happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) ->
@@ -2580,21 +2596,21 @@ happyReduction_159 (happy_x_2 `HappyStk`
Left (bs, h) -> if null bs then return $ AbsurdLam r h else
return $ Lam r bs (AbsurdLam r h)
where r = fuseRange happy_var_1 bs
- Right es -> do -- it is of the form @\ { p1 ... () }@
+ Right es -> do -- it is of the form @\ { p1 ... () }@
p <- exprToLHS (RawApp (getRange es) es);
return $ ExtendedLam (fuseRange happy_var_1 es)
[(p [] [], AbsurdRHS, NoWhere)])}}
) (\r -> happyReturn (happyIn36 r))
-happyReduce_160 = happySpecReduce_1 31# happyReduction_160
-happyReduction_160 happy_x_1
+happyReduce_161 = happySpecReduce_1 31# happyReduction_161
+happyReduction_161 happy_x_1
= case happyOut40 happy_x_1 of { happy_var_1 ->
happyIn37
([happy_var_1]
)}
-happyReduce_161 = happySpecReduce_2 31# happyReduction_161
-happyReduction_161 happy_x_2
+happyReduce_162 = happySpecReduce_2 31# happyReduction_162
+happyReduction_162 happy_x_2
happy_x_1
= case happyOut40 happy_x_1 of { happy_var_1 ->
case happyOut37 happy_x_2 of { happy_var_2 ->
@@ -2602,8 +2618,8 @@ happyReduction_161 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_162 = happySpecReduce_3 32# happyReduction_162
-happyReduction_162 happy_x_3
+happyReduce_163 = happySpecReduce_3 32# happyReduction_163
+happyReduction_163 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) ->
@@ -2613,8 +2629,8 @@ happyReduction_162 happy_x_3
(HiddenArg (getRange (happy_var_1,happy_var_2,happy_var_3)) (maybeNamed happy_var_2)
)}}}
-happyReduce_163 = happySpecReduce_2 32# happyReduction_163
-happyReduction_163 happy_x_2
+happyReduce_164 = happySpecReduce_2 32# happyReduction_164
+happyReduction_164 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) ->
case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) ->
@@ -2622,78 +2638,78 @@ happyReduction_163 happy_x_2
(let r = fuseRange happy_var_1 happy_var_2 in HiddenArg r $ unnamed $ Absurd r
)}}
-happyReduce_164 = happySpecReduce_1 33# happyReduction_164
-happyReduction_164 happy_x_1
+happyReduce_165 = happySpecReduce_1 33# happyReduction_165
+happyReduction_165 happy_x_1
= case happyOut21 happy_x_1 of { happy_var_1 ->
happyIn39
(Ident happy_var_1
)}
-happyReduce_165 = happySpecReduce_1 33# happyReduction_165
-happyReduction_165 happy_x_1
+happyReduce_166 = happySpecReduce_1 33# happyReduction_166
+happyReduction_166 happy_x_1
= case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) ->
happyIn39
(Lit happy_var_1
)}
-happyReduce_166 = happySpecReduce_1 33# happyReduction_166
-happyReduction_166 happy_x_1
+happyReduce_167 = happySpecReduce_1 33# happyReduction_167
+happyReduction_167 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) ->
happyIn39
(QuestionMark (getRange happy_var_1) Nothing
)}
-happyReduce_167 = happySpecReduce_1 33# happyReduction_167
-happyReduction_167 happy_x_1
+happyReduce_168 = happySpecReduce_1 33# happyReduction_168
+happyReduction_168 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) ->
happyIn39
(Underscore (getRange happy_var_1) Nothing
)}
-happyReduce_168 = happySpecReduce_1 33# happyReduction_168
-happyReduction_168 happy_x_1
+happyReduce_169 = happySpecReduce_1 33# happyReduction_169
+happyReduction_169 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) ->
happyIn39
(Prop (getRange happy_var_1)
)}
-happyReduce_169 = happySpecReduce_1 33# happyReduction_169
-happyReduction_169 happy_x_1
+happyReduce_170 = happySpecReduce_1 33# happyReduction_170
+happyReduction_170 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) ->
happyIn39
(Set (getRange happy_var_1)
)}
-happyReduce_170 = happySpecReduce_1 33# happyReduction_170
-happyReduction_170 happy_x_1
+happyReduce_171 = happySpecReduce_1 33# happyReduction_171
+happyReduction_171 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) ->
happyIn39
(Quote (getRange happy_var_1)
)}
-happyReduce_171 = happySpecReduce_1 33# happyReduction_171
-happyReduction_171 happy_x_1
+happyReduce_172 = happySpecReduce_1 33# happyReduction_172
+happyReduction_172 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) ->
happyIn39
(QuoteTerm (getRange happy_var_1)
)}
-happyReduce_172 = happySpecReduce_1 33# happyReduction_172
-happyReduction_172 happy_x_1
+happyReduce_173 = happySpecReduce_1 33# happyReduction_173
+happyReduction_173 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) ->
happyIn39
(Unquote (getRange happy_var_1)
)}
-happyReduce_173 = happySpecReduce_1 33# happyReduction_173
-happyReduction_173 happy_x_1
+happyReduce_174 = happySpecReduce_1 33# happyReduction_174
+happyReduction_174 happy_x_1
= case happyOutTok happy_x_1 of { (TokSetN happy_var_1) ->
happyIn39
(SetN (getRange (fst happy_var_1)) (snd happy_var_1)
)}
-happyReduce_174 = happySpecReduce_3 33# happyReduction_174
-happyReduction_174 happy_x_3
+happyReduce_175 = happySpecReduce_3 33# happyReduction_175
+happyReduction_175 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) ->
@@ -2704,8 +2720,8 @@ happyReduction_174 happy_x_3
(maybeNamed happy_var_2)
)}}}
-happyReduce_175 = happySpecReduce_3 33# happyReduction_175
-happyReduction_175 happy_x_3
+happyReduce_176 = happySpecReduce_3 33# happyReduction_176
+happyReduction_176 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
@@ -2715,8 +2731,8 @@ happyReduction_175 happy_x_3
(Paren (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2
)}}}
-happyReduce_176 = happySpecReduce_2 33# happyReduction_176
-happyReduction_176 happy_x_2
+happyReduce_177 = happySpecReduce_2 33# happyReduction_177
+happyReduction_177 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
case happyOutTok happy_x_2 of { (TokSymbol SymCloseParen happy_var_2) ->
@@ -2724,8 +2740,8 @@ happyReduction_176 happy_x_2
(Absurd (fuseRange happy_var_1 happy_var_2)
)}}
-happyReduce_177 = happySpecReduce_2 33# happyReduction_177
-happyReduction_177 happy_x_2
+happyReduce_178 = happySpecReduce_2 33# happyReduction_178
+happyReduction_178 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) ->
case happyOut17 happy_x_2 of { happy_var_2 ->
@@ -2733,8 +2749,8 @@ happyReduction_177 happy_x_2
(let r = fuseRange happy_var_1 happy_var_2 in InstanceArg r $ unnamed $ Absurd r
)}}
-happyReduce_178 = happySpecReduce_3 33# happyReduction_178
-happyReduction_178 happy_x_3
+happyReduce_179 = happySpecReduce_3 33# happyReduction_179
+happyReduction_179 happy_x_3
happy_x_2
happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
@@ -2744,8 +2760,8 @@ happyReduction_178 happy_x_3
(As (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_1 happy_var_3
)}}}
-happyReduce_179 = happySpecReduce_2 33# happyReduction_179
-happyReduction_179 happy_x_2
+happyReduce_180 = happySpecReduce_2 33# happyReduction_180
+happyReduction_180 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) ->
case happyOut40 happy_x_2 of { happy_var_2 ->
@@ -2753,8 +2769,8 @@ happyReduction_179 happy_x_2
(Dot (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_180 = happyReduce 4# 33# happyReduction_180
-happyReduction_180 (happy_x_4 `HappyStk`
+happyReduce_181 = happyReduce 4# 33# happyReduction_181
+happyReduction_181 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2767,8 +2783,8 @@ happyReduction_180 (happy_x_4 `HappyStk`
(Rec (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3
) `HappyStk` happyRest}}}}
-happyReduce_181 = happyReduce 5# 33# happyReduction_181
-happyReduction_181 (happy_x_5 `HappyStk`
+happyReduce_182 = happyReduce 5# 33# happyReduction_182
+happyReduction_182 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -2783,41 +2799,41 @@ happyReduction_181 (happy_x_5 `HappyStk`
(RecUpdate (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_4
) `HappyStk` happyRest}}}}}
-happyReduce_182 = happySpecReduce_1 34# happyReduction_182
-happyReduction_182 happy_x_1
+happyReduce_183 = happySpecReduce_1 34# happyReduction_183
+happyReduction_183 happy_x_1
= case happyOut38 happy_x_1 of { happy_var_1 ->
happyIn40
(happy_var_1
)}
-happyReduce_183 = happySpecReduce_1 34# happyReduction_183
-happyReduction_183 happy_x_1
+happyReduce_184 = happySpecReduce_1 34# happyReduction_184
+happyReduction_184 happy_x_1
= case happyOut39 happy_x_1 of { happy_var_1 ->
happyIn40
(happy_var_1
)}
-happyReduce_184 = happySpecReduce_0 35# happyReduction_184
-happyReduction_184 = happyIn41
+happyReduce_185 = happySpecReduce_0 35# happyReduction_185
+happyReduction_185 = happyIn41
([]
)
-happyReduce_185 = happySpecReduce_1 35# happyReduction_185
-happyReduction_185 happy_x_1
+happyReduce_186 = happySpecReduce_1 35# happyReduction_186
+happyReduction_186 happy_x_1
= case happyOut42 happy_x_1 of { happy_var_1 ->
happyIn41
(happy_var_1
)}
-happyReduce_186 = happySpecReduce_1 36# happyReduction_186
-happyReduction_186 happy_x_1
+happyReduce_187 = happySpecReduce_1 36# happyReduction_187
+happyReduction_187 happy_x_1
= case happyOut43 happy_x_1 of { happy_var_1 ->
happyIn42
([happy_var_1]
)}
-happyReduce_187 = happySpecReduce_3 36# happyReduction_187
-happyReduction_187 happy_x_3
+happyReduce_188 = happySpecReduce_3 36# happyReduction_188
+happyReduction_188 happy_x_3
happy_x_2
happy_x_1
= case happyOut43 happy_x_1 of { happy_var_1 ->
@@ -2826,8 +2842,8 @@ happyReduction_187 happy_x_3
(happy_var_1 : happy_var_3
)}}
-happyReduce_188 = happySpecReduce_3 37# happyReduction_188
-happyReduction_188 happy_x_3
+happyReduce_189 = happySpecReduce_3 37# happyReduction_189
+happyReduction_189 happy_x_3
happy_x_2
happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
@@ -2836,23 +2852,23 @@ happyReduction_188 happy_x_3
((happy_var_1, happy_var_3)
)}}
-happyReduce_189 = happySpecReduce_2 38# happyReduction_189
-happyReduction_189 happy_x_2
+happyReduce_190 = happySpecReduce_2 38# happyReduction_190
+happyReduction_190 happy_x_2
happy_x_1
= case happyOut45 happy_x_1 of { happy_var_1 ->
happyIn44
(happy_var_1
)}
-happyReduce_190 = happySpecReduce_1 39# happyReduction_190
-happyReduction_190 happy_x_1
+happyReduce_191 = happySpecReduce_1 39# happyReduction_191
+happyReduction_191 happy_x_1
= case happyOut46 happy_x_1 of { happy_var_1 ->
happyIn45
({-TeleBind-} happy_var_1
)}
-happyReduce_191 = happySpecReduce_2 40# happyReduction_191
-happyReduction_191 happy_x_2
+happyReduce_192 = happySpecReduce_2 40# happyReduction_192
+happyReduction_192 happy_x_2
happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
case happyOut46 happy_x_2 of { happy_var_2 ->
@@ -2860,15 +2876,15 @@ happyReduction_191 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_192 = happySpecReduce_1 40# happyReduction_192
-happyReduction_192 happy_x_1
+happyReduce_193 = happySpecReduce_1 40# happyReduction_193
+happyReduction_193 happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
happyIn46
([happy_var_1]
)}
-happyReduce_193 = happyReduce 4# 41# happyReduction_193
-happyReduction_193 (happy_x_4 `HappyStk`
+happyReduce_194 = happyReduce 4# 41# happyReduction_194
+happyReduction_194 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2881,8 +2897,8 @@ happyReduction_193 (happy_x_4 `HappyStk`
(setRelevance Irrelevant $ defaultColoredArg happy_var_3)
) `HappyStk` happyRest}}}
-happyReduce_194 = happyReduce 4# 41# happyReduction_194
-happyReduction_194 (happy_x_4 `HappyStk`
+happyReduce_195 = happyReduce 4# 41# happyReduction_195
+happyReduction_195 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2895,8 +2911,8 @@ happyReduction_194 (happy_x_4 `HappyStk`
(hide $ setRelevance Irrelevant $ defaultColoredArg happy_var_3)
) `HappyStk` happyRest}}}
-happyReduce_195 = happyReduce 4# 41# happyReduction_195
-happyReduction_195 (happy_x_4 `HappyStk`
+happyReduce_196 = happyReduce 4# 41# happyReduction_196
+happyReduction_196 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2909,8 +2925,8 @@ happyReduction_195 (happy_x_4 `HappyStk`
(makeInstance $ setRelevance Irrelevant $ defaultColoredArg happy_var_3)
) `HappyStk` happyRest}}}
-happyReduce_196 = happyReduce 4# 41# happyReduction_196
-happyReduction_196 (happy_x_4 `HappyStk`
+happyReduce_197 = happyReduce 4# 41# happyReduction_197
+happyReduction_197 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2923,8 +2939,8 @@ happyReduction_196 (happy_x_4 `HappyStk`
(setRelevance NonStrict $ defaultColoredArg happy_var_3)
) `HappyStk` happyRest}}}
-happyReduce_197 = happyReduce 4# 41# happyReduction_197
-happyReduction_197 (happy_x_4 `HappyStk`
+happyReduce_198 = happyReduce 4# 41# happyReduction_198
+happyReduction_198 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2937,8 +2953,8 @@ happyReduction_197 (happy_x_4 `HappyStk`
(hide $ setRelevance NonStrict $ defaultColoredArg happy_var_3)
) `HappyStk` happyRest}}}
-happyReduce_198 = happyReduce 4# 41# happyReduction_198
-happyReduction_198 (happy_x_4 `HappyStk`
+happyReduce_199 = happyReduce 4# 41# happyReduction_199
+happyReduction_199 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -2951,8 +2967,8 @@ happyReduction_198 (happy_x_4 `HappyStk`
(makeInstance $ setRelevance NonStrict $ defaultColoredArg happy_var_3)
) `HappyStk` happyRest}}}
-happyReduce_199 = happySpecReduce_3 41# happyReduction_199
-happyReduction_199 happy_x_3
+happyReduce_200 = happySpecReduce_3 41# happyReduction_200
+happyReduction_200 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
@@ -2963,8 +2979,8 @@ happyReduction_199 happy_x_3
(defaultColoredArg happy_var_2)
)}}}
-happyReduce_200 = happySpecReduce_3 41# happyReduction_200
-happyReduction_200 happy_x_3
+happyReduce_201 = happySpecReduce_3 41# happyReduction_201
+happyReduction_201 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) ->
@@ -2975,8 +2991,8 @@ happyReduction_200 happy_x_3
(makeInstance $ defaultColoredArg happy_var_2)
)}}}
-happyReduce_201 = happySpecReduce_3 41# happyReduction_201
-happyReduction_201 happy_x_3
+happyReduce_202 = happySpecReduce_3 41# happyReduction_202
+happyReduction_202 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) ->
@@ -2987,8 +3003,8 @@ happyReduction_201 happy_x_3
(hide $ defaultColoredArg happy_var_2)
)}}}
-happyReduce_202 = happySpecReduce_3 41# happyReduction_202
-happyReduction_202 happy_x_3
+happyReduce_203 = happySpecReduce_3 41# happyReduction_203
+happyReduction_203 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
@@ -2998,21 +3014,21 @@ happyReduction_202 happy_x_3
(tLet (getRange (happy_var_1,happy_var_3)) happy_var_2
)}}}
-happyReduce_203 = happyReduce 4# 41# happyReduction_203
-happyReduction_203 (happy_x_4 `HappyStk`
+happyReduce_204 = happyReduce 4# 41# happyReduction_204
+happyReduction_204 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) ->
- case happyOut139 happy_x_3 of { happy_var_3 ->
+ case happyOut140 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) ->
happyIn47
(tLet (getRange (happy_var_1,happy_var_4)) happy_var_3
) `HappyStk` happyRest}}}
-happyReduce_204 = happySpecReduce_3 42# happyReduction_204
-happyReduction_204 happy_x_3
+happyReduce_205 = happySpecReduce_3 42# happyReduction_205
+happyReduction_205 happy_x_3
happy_x_2
happy_x_1
= case happyOut25 happy_x_1 of { happy_var_1 ->
@@ -3022,20 +3038,20 @@ happyReduction_204 happy_x_3
(( [], TBind (getRange (happy_var_1,happy_var_2,happy_var_3)) (map mkBoundName_ happy_var_1) happy_var_3 )
)}}}
-happyReduce_205 = happyMonadReduce 2# 43# happyReduction_205
-happyReduction_205 (happy_x_2 `HappyStk`
+happyReduce_206 = happyMonadReduce 2# 43# happyReduction_206
+happyReduction_206 (happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut51 happy_x_1 of { happy_var_1 ->
(
case reverse happy_var_1 of
Left _ : _ -> parseError "Absurd lambda cannot have a body."
- _ : _ -> return [ b | Right b <- happy_var_1 ]
+ _ : _ -> return [ b | Right b <- happy_var_1 ]
[] -> parsePanic "Empty LamBinds")}
) (\r -> happyReturn (happyIn49 r))
-happyReduce_206 = happyMonadReduce 1# 44# happyReduction_206
-happyReduction_206 (happy_x_1 `HappyStk`
+happyReduce_207 = happyMonadReduce 1# 44# happyReduction_207
+happyReduction_207 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut52 happy_x_1 of { happy_var_1 ->
(
@@ -3047,8 +3063,8 @@ happyReduction_206 (happy_x_1 `HappyStk`
Right es -> return $ Right es)}
) (\r -> happyReturn (happyIn50 r))
-happyReduce_207 = happySpecReduce_2 45# happyReduction_207
-happyReduction_207 happy_x_2
+happyReduce_208 = happySpecReduce_2 45# happyReduction_208
+happyReduction_208 happy_x_2
happy_x_1
= case happyOut60 happy_x_1 of { happy_var_1 ->
case happyOut51 happy_x_2 of { happy_var_2 ->
@@ -3056,8 +3072,8 @@ happyReduction_207 happy_x_2
(map Right happy_var_1 ++ happy_var_2
)}}
-happyReduce_208 = happySpecReduce_2 45# happyReduction_208
-happyReduction_208 happy_x_2
+happyReduce_209 = happySpecReduce_2 45# happyReduction_209
+happyReduction_209 happy_x_2
happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
case happyOut51 happy_x_2 of { happy_var_2 ->
@@ -3065,43 +3081,43 @@ happyReduction_208 happy_x_2
(Right (DomainFull happy_var_1) : happy_var_2
)}}
-happyReduce_209 = happySpecReduce_1 45# happyReduction_209
-happyReduction_209 happy_x_1
+happyReduce_210 = happySpecReduce_1 45# happyReduction_210
+happyReduction_210 happy_x_1
= case happyOut60 happy_x_1 of { happy_var_1 ->
happyIn51
(map Right happy_var_1
)}
-happyReduce_210 = happySpecReduce_1 45# happyReduction_210
-happyReduction_210 happy_x_1
+happyReduce_211 = happySpecReduce_1 45# happyReduction_211
+happyReduction_211 happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
happyIn51
([Right $ DomainFull happy_var_1]
)}
-happyReduce_211 = happySpecReduce_2 45# happyReduction_211
-happyReduction_211 happy_x_2
+happyReduce_212 = happySpecReduce_2 45# happyReduction_212
+happyReduction_212 happy_x_2
happy_x_1
= happyIn51
([Left NotHidden]
)
-happyReduce_212 = happySpecReduce_2 45# happyReduction_212
-happyReduction_212 happy_x_2
+happyReduce_213 = happySpecReduce_2 45# happyReduction_213
+happyReduction_213 happy_x_2
happy_x_1
= happyIn51
([Left Hidden]
)
-happyReduce_213 = happySpecReduce_2 45# happyReduction_213
-happyReduction_213 happy_x_2
+happyReduce_214 = happySpecReduce_2 45# happyReduction_214
+happyReduction_214 happy_x_2
happy_x_1
= happyIn51
([Left Instance]
)
-happyReduce_214 = happySpecReduce_2 46# happyReduction_214
-happyReduction_214 happy_x_2
+happyReduce_215 = happySpecReduce_2 46# happyReduction_215
+happyReduction_215 happy_x_2
happy_x_1
= case happyOut60 happy_x_1 of { happy_var_1 ->
case happyOut51 happy_x_2 of { happy_var_2 ->
@@ -3109,8 +3125,8 @@ happyReduction_214 happy_x_2
(Left $ map Right happy_var_1 ++ happy_var_2
)}}
-happyReduce_215 = happySpecReduce_2 46# happyReduction_215
-happyReduction_215 happy_x_2
+happyReduce_216 = happySpecReduce_2 46# happyReduction_216
+happyReduction_216 happy_x_2
happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
case happyOut51 happy_x_2 of { happy_var_2 ->
@@ -3118,8 +3134,8 @@ happyReduction_215 happy_x_2
(Left $ Right (DomainFull happy_var_1) : happy_var_2
)}}
-happyReduce_216 = happySpecReduce_1 46# happyReduction_216
-happyReduction_216 happy_x_1
+happyReduce_217 = happySpecReduce_1 46# happyReduction_217
+happyReduction_217 happy_x_1
= case happyOut61 happy_x_1 of { happy_var_1 ->
happyIn52
(case happy_var_1 of
@@ -3127,36 +3143,36 @@ happyReduction_216 happy_x_1
Right es -> Right es
)}
-happyReduce_217 = happySpecReduce_1 46# happyReduction_217
-happyReduction_217 happy_x_1
+happyReduce_218 = happySpecReduce_1 46# happyReduction_218
+happyReduction_218 happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
happyIn52
(Left [Right $ DomainFull happy_var_1]
)}
-happyReduce_218 = happySpecReduce_2 46# happyReduction_218
-happyReduction_218 happy_x_2
+happyReduce_219 = happySpecReduce_2 46# happyReduction_219
+happyReduction_219 happy_x_2
happy_x_1
= happyIn52
(Left [Left NotHidden]
)
-happyReduce_219 = happySpecReduce_2 46# happyReduction_219
-happyReduction_219 happy_x_2
+happyReduce_220 = happySpecReduce_2 46# happyReduction_220
+happyReduction_220 happy_x_2
happy_x_1
= happyIn52
(Left [Left Hidden]
)
-happyReduce_220 = happySpecReduce_2 46# happyReduction_220
-happyReduction_220 happy_x_2
+happyReduce_221 = happySpecReduce_2 46# happyReduction_221
+happyReduction_221 happy_x_2
happy_x_1
= happyIn52
(Left [Left Instance]
)
-happyReduce_221 = happyMonadReduce 3# 47# happyReduction_221
-happyReduction_221 (happy_x_3 `HappyStk`
+happyReduce_222 = happyMonadReduce 3# 47# happyReduction_222
+happyReduction_222 (happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
@@ -3167,8 +3183,8 @@ happyReduction_221 (happy_x_3 `HappyStk`
return (p [] [], RHS happy_var_3, NoWhere))}}
) (\r -> happyReturn (happyIn53 r))
-happyReduce_222 = happyMonadReduce 1# 48# happyReduction_222
-happyReduction_222 (happy_x_1 `HappyStk`
+happyReduce_223 = happyMonadReduce 1# 48# happyReduction_223
+happyReduction_223 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut34 happy_x_1 of { happy_var_1 ->
( do
@@ -3176,22 +3192,22 @@ happyReduction_222 (happy_x_1 `HappyStk`
return (p [] [], AbsurdRHS, NoWhere))}
) (\r -> happyReturn (happyIn54 r))
-happyReduce_223 = happySpecReduce_1 49# happyReduction_223
-happyReduction_223 happy_x_1
+happyReduce_224 = happySpecReduce_1 49# happyReduction_224
+happyReduction_224 happy_x_1
= case happyOut53 happy_x_1 of { happy_var_1 ->
happyIn55
(happy_var_1
)}
-happyReduce_224 = happySpecReduce_1 49# happyReduction_224
-happyReduction_224 happy_x_1
+happyReduce_225 = happySpecReduce_1 49# happyReduction_225
+happyReduction_225 happy_x_1
= case happyOut54 happy_x_1 of { happy_var_1 ->
happyIn55
(happy_var_1
)}
-happyReduce_225 = happySpecReduce_3 50# happyReduction_225
-happyReduction_225 happy_x_3
+happyReduce_226 = happySpecReduce_3 50# happyReduction_226
+happyReduction_226 happy_x_3
happy_x_2
happy_x_1
= case happyOut56 happy_x_1 of { happy_var_1 ->
@@ -3200,8 +3216,8 @@ happyReduction_225 happy_x_3
(happy_var_3 : happy_var_1
)}}
-happyReduce_226 = happySpecReduce_3 50# happyReduction_226
-happyReduction_226 happy_x_3
+happyReduce_227 = happySpecReduce_3 50# happyReduction_227
+happyReduction_227 happy_x_3
happy_x_2
happy_x_1
= case happyOut54 happy_x_1 of { happy_var_1 ->
@@ -3210,23 +3226,23 @@ happyReduction_226 happy_x_3
([happy_var_3, happy_var_1]
)}}
-happyReduce_227 = happySpecReduce_1 50# happyReduction_227
-happyReduction_227 happy_x_1
+happyReduce_228 = happySpecReduce_1 50# happyReduction_228
+happyReduction_228 happy_x_1
= case happyOut53 happy_x_1 of { happy_var_1 ->
happyIn56
([happy_var_1]
)}
-happyReduce_228 = happySpecReduce_2 51# happyReduction_228
-happyReduction_228 happy_x_2
+happyReduce_229 = happySpecReduce_2 51# happyReduction_229
+happyReduction_229 happy_x_2
happy_x_1
= case happyOut58 happy_x_1 of { happy_var_1 ->
happyIn57
(happy_var_1
)}
-happyReduce_229 = happySpecReduce_2 52# happyReduction_229
-happyReduction_229 happy_x_2
+happyReduce_230 = happySpecReduce_2 52# happyReduction_230
+happyReduction_230 happy_x_2
happy_x_1
= case happyOut60 happy_x_1 of { happy_var_1 ->
case happyOut58 happy_x_2 of { happy_var_2 ->
@@ -3234,8 +3250,8 @@ happyReduction_229 happy_x_2
(happy_var_1 ++ happy_var_2
)}}
-happyReduce_230 = happySpecReduce_2 52# happyReduction_230
-happyReduction_230 happy_x_2
+happyReduce_231 = happySpecReduce_2 52# happyReduction_231
+happyReduction_231 happy_x_2
happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
case happyOut58 happy_x_2 of { happy_var_2 ->
@@ -3243,22 +3259,22 @@ happyReduction_230 happy_x_2
(DomainFull happy_var_1 : happy_var_2
)}}
-happyReduce_231 = happySpecReduce_1 52# happyReduction_231
-happyReduction_231 happy_x_1
+happyReduce_232 = happySpecReduce_1 52# happyReduction_232
+happyReduction_232 happy_x_1
= case happyOut60 happy_x_1 of { happy_var_1 ->
happyIn58
(happy_var_1
)}
-happyReduce_232 = happySpecReduce_1 52# happyReduction_232
-happyReduction_232 happy_x_1
+happyReduce_233 = happySpecReduce_1 52# happyReduction_233
+happyReduction_233 happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
happyIn58
([DomainFull happy_var_1]
)}
-happyReduce_233 = happySpecReduce_2 53# happyReduction_233
-happyReduction_233 happy_x_2
+happyReduce_234 = happySpecReduce_2 53# happyReduction_234
+happyReduction_234 happy_x_2
happy_x_1
= case happyOut60 happy_x_1 of { happy_var_1 ->
case happyOut59 happy_x_2 of { happy_var_2 ->
@@ -3266,8 +3282,8 @@ happyReduction_233 happy_x_2
(happy_var_1 ++ happy_var_2
)}}
-happyReduce_234 = happySpecReduce_2 53# happyReduction_234
-happyReduction_234 happy_x_2
+happyReduce_235 = happySpecReduce_2 53# happyReduction_235
+happyReduction_235 happy_x_2
happy_x_1
= case happyOut47 happy_x_1 of { happy_var_1 ->
case happyOut59 happy_x_2 of { happy_var_2 ->
@@ -3275,13 +3291,13 @@ happyReduction_234 happy_x_2
(DomainFull happy_var_1 : happy_var_2
)}}
-happyReduce_235 = happySpecReduce_0 53# happyReduction_235
-happyReduction_235 = happyIn59
+happyReduce_236 = happySpecReduce_0 53# happyReduction_236
+happyReduction_236 = happyIn59
([]
)
-happyReduce_236 = happySpecReduce_1 54# happyReduction_236
-happyReduction_236 happy_x_1
+happyReduce_237 = happySpecReduce_1 54# happyReduction_237
+happyReduction_237 happy_x_1
= case happyOut61 happy_x_1 of { happy_var_1 ->
happyIn60
(case happy_var_1 of
@@ -3289,31 +3305,31 @@ happyReduction_236 happy_x_1
Right _ -> fail "expected sequence of bound identifiers, not absurd pattern"
)}
-happyReduce_237 = happySpecReduce_1 55# happyReduction_237
-happyReduction_237 happy_x_1
+happyReduce_238 = happySpecReduce_1 55# happyReduction_238
+happyReduction_238 happy_x_1
= case happyOut23 happy_x_1 of { happy_var_1 ->
happyIn61
(Left [DomainFree defaultArgInfo $ mkBoundName_ happy_var_1]
)}
-happyReduce_238 = happySpecReduce_2 55# happyReduction_238
-happyReduction_238 happy_x_2
+happyReduce_239 = happySpecReduce_2 55# happyReduction_239
+happyReduction_239 happy_x_2
happy_x_1
= case happyOut23 happy_x_2 of { happy_var_2 ->
happyIn61
(Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ happy_var_2]
)}
-happyReduce_239 = happySpecReduce_2 55# happyReduction_239
-happyReduction_239 happy_x_2
+happyReduce_240 = happySpecReduce_2 55# happyReduction_240
+happyReduction_240 happy_x_2
happy_x_1
= case happyOut23 happy_x_2 of { happy_var_2 ->
happyIn61
(Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ happy_var_2]
)}
-happyReduce_240 = happySpecReduce_3 55# happyReduction_240
-happyReduction_240 happy_x_3
+happyReduce_241 = happySpecReduce_3 55# happyReduction_241
+happyReduction_241 happy_x_3
happy_x_2
happy_x_1
= case happyOut26 happy_x_2 of { happy_var_2 ->
@@ -3321,8 +3337,8 @@ happyReduction_240 happy_x_3
(either (Left . map (DomainFree (setHiding Hidden $ defaultArgInfo) . mkBoundName_)) Right happy_var_2
)}
-happyReduce_241 = happySpecReduce_3 55# happyReduction_241
-happyReduction_241 happy_x_3
+happyReduce_242 = happySpecReduce_3 55# happyReduction_242
+happyReduction_242 happy_x_3
happy_x_2
happy_x_1
= case happyOut25 happy_x_2 of { happy_var_2 ->
@@ -3330,8 +3346,8 @@ happyReduction_241 happy_x_3
(Left $ map (DomainFree (setHiding Instance $ defaultArgInfo) . mkBoundName_) happy_var_2
)}
-happyReduce_242 = happyReduce 4# 55# happyReduction_242
-happyReduction_242 (happy_x_4 `HappyStk`
+happyReduce_243 = happyReduce 4# 55# happyReduction_243
+happyReduction_243 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3341,8 +3357,8 @@ happyReduction_242 (happy_x_4 `HappyStk`
(Left $ map (DomainFree (setHiding Hidden $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3
) `HappyStk` happyRest}
-happyReduce_243 = happyReduce 4# 55# happyReduction_243
-happyReduction_243 (happy_x_4 `HappyStk`
+happyReduce_244 = happyReduce 4# 55# happyReduction_244
+happyReduction_244 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3352,8 +3368,8 @@ happyReduction_243 (happy_x_4 `HappyStk`
(Left $ map (DomainFree (setHiding Instance $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3
) `HappyStk` happyRest}
-happyReduce_244 = happyReduce 4# 55# happyReduction_244
-happyReduction_244 (happy_x_4 `HappyStk`
+happyReduce_245 = happyReduce 4# 55# happyReduction_245
+happyReduction_245 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3363,8 +3379,8 @@ happyReduction_244 (happy_x_4 `HappyStk`
(Left $ map (DomainFree (setHiding Hidden $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3
) `HappyStk` happyRest}
-happyReduce_245 = happyReduce 4# 55# happyReduction_245
-happyReduction_245 (happy_x_4 `HappyStk`
+happyReduce_246 = happyReduce 4# 55# happyReduction_246
+happyReduction_246 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3374,15 +3390,15 @@ happyReduction_245 (happy_x_4 `HappyStk`
(Left $ map (DomainFree (setHiding Instance $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3
) `HappyStk` happyRest}
-happyReduce_246 = happyMonadReduce 1# 56# happyReduction_246
-happyReduction_246 (happy_x_1 `HappyStk`
+happyReduce_247 = happyMonadReduce 1# 56# happyReduction_247
+happyReduction_247 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut63 happy_x_1 of { happy_var_1 ->
( mergeImportDirectives happy_var_1)}
) (\r -> happyReturn (happyIn62 r))
-happyReduce_247 = happySpecReduce_2 57# happyReduction_247
-happyReduction_247 happy_x_2
+happyReduce_248 = happySpecReduce_2 57# happyReduction_248
+happyReduction_248 happy_x_2
happy_x_1
= case happyOut64 happy_x_1 of { happy_var_1 ->
case happyOut63 happy_x_2 of { happy_var_2 ->
@@ -3390,34 +3406,34 @@ happyReduction_247 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_248 = happySpecReduce_0 57# happyReduction_248
-happyReduction_248 = happyIn63
+happyReduce_249 = happySpecReduce_0 57# happyReduction_249
+happyReduction_249 = happyIn63
([]
)
-happyReduce_249 = happySpecReduce_1 58# happyReduction_249
-happyReduction_249 happy_x_1
+happyReduce_250 = happySpecReduce_1 58# happyReduction_250
+happyReduction_250 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) ->
happyIn64
(defaultImportDir { importDirRange = getRange happy_var_1, publicOpen = True }
)}
-happyReduce_250 = happySpecReduce_1 58# happyReduction_250
-happyReduction_250 happy_x_1
+happyReduce_251 = happySpecReduce_1 58# happyReduction_251
+happyReduction_251 happy_x_1
= case happyOut65 happy_x_1 of { happy_var_1 ->
happyIn64
(defaultImportDir { importDirRange = snd happy_var_1, usingOrHiding = fst happy_var_1 }
)}
-happyReduce_251 = happySpecReduce_1 58# happyReduction_251
-happyReduction_251 happy_x_1
+happyReduce_252 = happySpecReduce_1 58# happyReduction_252
+happyReduction_252 happy_x_1
= case happyOut66 happy_x_1 of { happy_var_1 ->
happyIn64
(defaultImportDir { importDirRange = snd happy_var_1, renaming = fst happy_var_1 }
)}
-happyReduce_252 = happyReduce 4# 59# happyReduction_252
-happyReduction_252 (happy_x_4 `HappyStk`
+happyReduce_253 = happyReduce 4# 59# happyReduction_253
+happyReduction_253 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3430,8 +3446,8 @@ happyReduction_252 (happy_x_4 `HappyStk`
((Using happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4))
) `HappyStk` happyRest}}}}
-happyReduce_253 = happyReduce 4# 59# happyReduction_253
-happyReduction_253 (happy_x_4 `HappyStk`
+happyReduce_254 = happyReduce 4# 59# happyReduction_254
+happyReduction_254 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3444,8 +3460,8 @@ happyReduction_253 (happy_x_4 `HappyStk`
((Hiding happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4))
) `HappyStk` happyRest}}}}
-happyReduce_254 = happyReduce 4# 60# happyReduction_254
-happyReduction_254 (happy_x_4 `HappyStk`
+happyReduce_255 = happyReduce 4# 60# happyReduction_255
+happyReduction_255 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3458,8 +3474,8 @@ happyReduction_254 (happy_x_4 `HappyStk`
((happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4))
) `HappyStk` happyRest}}}}
-happyReduce_255 = happySpecReduce_3 60# happyReduction_255
-happyReduction_255 happy_x_3
+happyReduce_256 = happySpecReduce_3 60# happyReduction_256
+happyReduction_256 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) ->
@@ -3469,8 +3485,8 @@ happyReduction_255 happy_x_3
(([] , getRange (happy_var_1,happy_var_2,happy_var_3))
)}}}
-happyReduce_256 = happySpecReduce_3 61# happyReduction_256
-happyReduction_256 happy_x_3
+happyReduce_257 = happySpecReduce_3 61# happyReduction_257
+happyReduction_257 happy_x_3
happy_x_2
happy_x_1
= case happyOut68 happy_x_1 of { happy_var_1 ->
@@ -3479,15 +3495,15 @@ happyReduction_256 happy_x_3
(happy_var_1 : happy_var_3
)}}
-happyReduce_257 = happySpecReduce_1 61# happyReduction_257
-happyReduction_257 happy_x_1
+happyReduce_258 = happySpecReduce_1 61# happyReduction_258
+happyReduction_258 happy_x_1
= case happyOut68 happy_x_1 of { happy_var_1 ->
happyIn67
([happy_var_1]
)}
-happyReduce_258 = happySpecReduce_3 62# happyReduction_258
-happyReduction_258 happy_x_3
+happyReduce_259 = happySpecReduce_3 62# happyReduction_259
+happyReduction_259 happy_x_3
happy_x_2
happy_x_1
= case happyOut69 happy_x_1 of { happy_var_1 ->
@@ -3497,16 +3513,16 @@ happyReduction_258 happy_x_3
(Renaming happy_var_1 happy_var_3 (getRange happy_var_2)
)}}}
-happyReduce_259 = happySpecReduce_2 63# happyReduction_259
-happyReduction_259 happy_x_2
+happyReduce_260 = happySpecReduce_2 63# happyReduction_260
+happyReduction_260 happy_x_2
happy_x_1
= case happyOut15 happy_x_2 of { happy_var_2 ->
happyIn69
(ImportedName happy_var_2
)}
-happyReduce_260 = happySpecReduce_3 63# happyReduction_260
-happyReduction_260 happy_x_3
+happyReduce_261 = happySpecReduce_3 63# happyReduction_261
+happyReduction_261 happy_x_3
happy_x_2
happy_x_1
= case happyOut15 happy_x_3 of { happy_var_3 ->
@@ -3514,42 +3530,42 @@ happyReduction_260 happy_x_3
(ImportedModule happy_var_3
)}
-happyReduce_261 = happySpecReduce_1 64# happyReduction_261
-happyReduction_261 happy_x_1
+happyReduce_262 = happySpecReduce_1 64# happyReduction_262
+happyReduction_262 happy_x_1
= case happyOut15 happy_x_1 of { happy_var_1 ->
happyIn70
(ImportedName happy_var_1
)}
-happyReduce_262 = happySpecReduce_2 64# happyReduction_262
-happyReduction_262 happy_x_2
+happyReduce_263 = happySpecReduce_2 64# happyReduction_263
+happyReduction_263 happy_x_2
happy_x_1
= case happyOut15 happy_x_2 of { happy_var_2 ->
happyIn70
(ImportedModule happy_var_2
)}
-happyReduce_263 = happySpecReduce_0 65# happyReduction_263
-happyReduction_263 = happyIn71
+happyReduce_264 = happySpecReduce_0 65# happyReduction_264
+happyReduction_264 = happyIn71
([]
)
-happyReduce_264 = happySpecReduce_1 65# happyReduction_264
-happyReduction_264 happy_x_1
+happyReduce_265 = happySpecReduce_1 65# happyReduction_265
+happyReduction_265 happy_x_1
= case happyOut72 happy_x_1 of { happy_var_1 ->
happyIn71
(happy_var_1
)}
-happyReduce_265 = happySpecReduce_1 66# happyReduction_265
-happyReduction_265 happy_x_1
+happyReduce_266 = happySpecReduce_1 66# happyReduction_266
+happyReduction_266 happy_x_1
= case happyOut70 happy_x_1 of { happy_var_1 ->
happyIn72
([happy_var_1]
)}
-happyReduce_266 = happySpecReduce_3 66# happyReduction_266
-happyReduction_266 happy_x_3
+happyReduce_267 = happySpecReduce_3 66# happyReduction_267
+happyReduction_267 happy_x_3
happy_x_2
happy_x_1
= case happyOut70 happy_x_1 of { happy_var_1 ->
@@ -3558,8 +3574,8 @@ happyReduction_266 happy_x_3
(happy_var_1 : happy_var_3
)}}
-happyReduce_267 = happyMonadReduce 3# 67# happyReduction_267
-happyReduction_267 (happy_x_3 `HappyStk`
+happyReduce_268 = happyMonadReduce 3# 67# happyReduction_268
+happyReduction_268 (happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
@@ -3569,8 +3585,8 @@ happyReduction_267 (happy_x_3 `HappyStk`
( exprToLHS happy_var_1 >>= \p -> return (p happy_var_2 happy_var_3))}}}
) (\r -> happyReturn (happyIn73 r))
-happyReduce_268 = happyReduce 4# 67# happyReduction_268
-happyReduction_268 (happy_x_4 `HappyStk`
+happyReduce_269 = happyReduce 4# 67# happyReduction_269
+happyReduction_269 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -3583,227 +3599,227 @@ happyReduction_268 (happy_x_4 `HappyStk`
(Ellipsis (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_3 happy_var_4
) `HappyStk` happyRest}}}}
-happyReduce_269 = happySpecReduce_0 68# happyReduction_269
-happyReduction_269 = happyIn74
+happyReduce_270 = happySpecReduce_0 68# happyReduction_270
+happyReduction_270 = happyIn74
([]
)
-happyReduce_270 = happyMonadReduce 3# 68# happyReduction_270
-happyReduction_270 (happy_x_3 `HappyStk`
+happyReduce_271 = happyMonadReduce 3# 68# happyReduction_271
+happyReduction_271 (happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut37 happy_x_2 of { happy_var_2 ->
case happyOut74 happy_x_3 of { happy_var_3 ->
( exprToPattern (RawApp (getRange happy_var_2) happy_var_2) >>= \p ->
- return (p : happy_var_3))}}
+ return (p : happy_var_3))}}
) (\r -> happyReturn (happyIn74 r))
-happyReduce_271 = happySpecReduce_0 69# happyReduction_271
-happyReduction_271 = happyIn75
+happyReduce_272 = happySpecReduce_0 69# happyReduction_272
+happyReduction_272 = happyIn75
([]
)
-happyReduce_272 = happySpecReduce_2 69# happyReduction_272
-happyReduction_272 happy_x_2
+happyReduce_273 = happySpecReduce_2 69# happyReduction_273
+happyReduction_273 happy_x_2
happy_x_1
= case happyOut31 happy_x_2 of { happy_var_2 ->
happyIn75
(case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] }
)}
-happyReduce_273 = happySpecReduce_0 70# happyReduction_273
-happyReduction_273 = happyIn76
+happyReduce_274 = happySpecReduce_0 70# happyReduction_274
+happyReduction_274 = happyIn76
([]
)
-happyReduce_274 = happySpecReduce_2 70# happyReduction_274
-happyReduction_274 happy_x_2
+happyReduce_275 = happySpecReduce_2 70# happyReduction_275
+happyReduction_275 happy_x_2
happy_x_1
= case happyOut32 happy_x_2 of { happy_var_2 ->
happyIn76
(case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] }
)}
-happyReduce_275 = happySpecReduce_0 71# happyReduction_275
-happyReduction_275 = happyIn77
+happyReduce_276 = happySpecReduce_0 71# happyReduction_276
+happyReduction_276 = happyIn77
(NoWhere
)
-happyReduce_276 = happySpecReduce_2 71# happyReduction_276
-happyReduction_276 happy_x_2
+happyReduce_277 = happySpecReduce_2 71# happyReduction_277
+happyReduction_277 happy_x_2
happy_x_1
- = case happyOut140 happy_x_2 of { happy_var_2 ->
+ = case happyOut141 happy_x_2 of { happy_var_2 ->
happyIn77
(AnyWhere happy_var_2
)}
-happyReduce_277 = happyReduce 4# 71# happyReduction_277
-happyReduction_277 (happy_x_4 `HappyStk`
+happyReduce_278 = happyReduce 4# 71# happyReduction_278
+happyReduction_278 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut15 happy_x_2 of { happy_var_2 ->
- case happyOut140 happy_x_4 of { happy_var_4 ->
+ case happyOut141 happy_x_4 of { happy_var_4 ->
happyIn77
(SomeWhere happy_var_2 happy_var_4
) `HappyStk` happyRest}}
-happyReduce_278 = happyReduce 4# 71# happyReduction_278
-happyReduction_278 (happy_x_4 `HappyStk`
+happyReduce_279 = happyReduce 4# 71# happyReduction_279
+happyReduction_279 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut112 happy_x_2 of { happy_var_2 ->
- case happyOut140 happy_x_4 of { happy_var_4 ->
+ case happyOut141 happy_x_4 of { happy_var_4 ->
happyIn77
(SomeWhere happy_var_2 happy_var_4
) `HappyStk` happyRest}}
-happyReduce_279 = happySpecReduce_1 72# happyReduction_279
-happyReduction_279 happy_x_1
- = case happyOut89 happy_x_1 of { happy_var_1 ->
- happyIn78
- (happy_var_1
- )}
-
happyReduce_280 = happySpecReduce_1 72# happyReduction_280
happyReduction_280 happy_x_1
- = case happyOut81 happy_x_1 of { happy_var_1 ->
+ = case happyOut89 happy_x_1 of { happy_var_1 ->
happyIn78
(happy_var_1
)}
happyReduce_281 = happySpecReduce_1 72# happyReduction_281
happyReduction_281 happy_x_1
- = case happyOut83 happy_x_1 of { happy_var_1 ->
+ = case happyOut81 happy_x_1 of { happy_var_1 ->
happyIn78
- ([happy_var_1]
+ (happy_var_1
)}
happyReduce_282 = happySpecReduce_1 72# happyReduction_282
happyReduction_282 happy_x_1
- = case happyOut84 happy_x_1 of { happy_var_1 ->
+ = case happyOut83 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_283 = happySpecReduce_1 72# happyReduction_283
happyReduction_283 happy_x_1
- = case happyOut85 happy_x_1 of { happy_var_1 ->
+ = case happyOut84 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_284 = happySpecReduce_1 72# happyReduction_284
happyReduction_284 happy_x_1
- = case happyOut86 happy_x_1 of { happy_var_1 ->
+ = case happyOut85 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_285 = happySpecReduce_1 72# happyReduction_285
happyReduction_285 happy_x_1
- = case happyOut88 happy_x_1 of { happy_var_1 ->
+ = case happyOut86 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_286 = happySpecReduce_1 72# happyReduction_286
happyReduction_286 happy_x_1
- = case happyOut90 happy_x_1 of { happy_var_1 ->
+ = case happyOut88 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_287 = happySpecReduce_1 72# happyReduction_287
happyReduction_287 happy_x_1
- = case happyOut91 happy_x_1 of { happy_var_1 ->
+ = case happyOut90 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_288 = happySpecReduce_1 72# happyReduction_288
happyReduction_288 happy_x_1
- = case happyOut92 happy_x_1 of { happy_var_1 ->
+ = case happyOut91 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_289 = happySpecReduce_1 72# happyReduction_289
happyReduction_289 happy_x_1
- = case happyOut93 happy_x_1 of { happy_var_1 ->
+ = case happyOut92 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_290 = happySpecReduce_1 72# happyReduction_290
happyReduction_290 happy_x_1
- = case happyOut94 happy_x_1 of { happy_var_1 ->
+ = case happyOut93 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_291 = happySpecReduce_1 72# happyReduction_291
happyReduction_291 happy_x_1
- = case happyOut95 happy_x_1 of { happy_var_1 ->
+ = case happyOut94 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_292 = happySpecReduce_1 72# happyReduction_292
happyReduction_292 happy_x_1
- = case happyOut107 happy_x_1 of { happy_var_1 ->
+ = case happyOut95 happy_x_1 of { happy_var_1 ->
happyIn78
- (happy_var_1
+ ([happy_var_1]
)}
happyReduce_293 = happySpecReduce_1 72# happyReduction_293
happyReduction_293 happy_x_1
- = case happyOut110 happy_x_1 of { happy_var_1 ->
+ = case happyOut107 happy_x_1 of { happy_var_1 ->
happyIn78
- ([happy_var_1]
+ (happy_var_1
)}
happyReduce_294 = happySpecReduce_1 72# happyReduction_294
happyReduction_294 happy_x_1
- = case happyOut111 happy_x_1 of { happy_var_1 ->
+ = case happyOut110 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_295 = happySpecReduce_1 72# happyReduction_295
happyReduction_295 happy_x_1
- = case happyOut114 happy_x_1 of { happy_var_1 ->
+ = case happyOut111 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_296 = happySpecReduce_1 72# happyReduction_296
happyReduction_296 happy_x_1
- = case happyOut97 happy_x_1 of { happy_var_1 ->
+ = case happyOut114 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_297 = happySpecReduce_1 72# happyReduction_297
happyReduction_297 happy_x_1
- = case happyOut98 happy_x_1 of { happy_var_1 ->
+ = case happyOut97 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
happyReduce_298 = happySpecReduce_1 72# happyReduction_298
happyReduction_298 happy_x_1
+ = case happyOut98 happy_x_1 of { happy_var_1 ->
+ happyIn78
+ ([happy_var_1]
+ )}
+
+happyReduce_299 = happySpecReduce_1 72# happyReduction_299
+happyReduction_299 happy_x_1
= case happyOut96 happy_x_1 of { happy_var_1 ->
happyIn78
([happy_var_1]
)}
-happyReduce_299 = happySpecReduce_3 73# happyReduction_299
-happyReduction_299 happy_x_3
+happyReduce_300 = happySpecReduce_3 73# happyReduction_300
+happyReduction_300 happy_x_3
happy_x_2
happy_x_1
= case happyOut16 happy_x_1 of { happy_var_1 ->
@@ -3812,8 +3828,8 @@ happyReduction_299 happy_x_3
(map (flip (TypeSig defaultArgInfo) happy_var_3) happy_var_1
)}}
-happyReduce_300 = happySpecReduce_3 74# happyReduction_300
-happyReduction_300 happy_x_3
+happyReduce_301 = happySpecReduce_3 74# happyReduction_301
+happyReduction_301 happy_x_3
happy_x_2
happy_x_1
= case happyOut20 happy_x_1 of { happy_var_1 ->
@@ -3822,8 +3838,8 @@ happyReduction_300 happy_x_3
(map (fmap (flip (TypeSig defaultArgInfo) happy_var_3)) happy_var_1
)}}
-happyReduce_301 = happyMonadReduce 3# 75# happyReduction_301
-happyReduction_301 (happy_x_3 `HappyStk`
+happyReduce_302 = happyMonadReduce 3# 75# happyReduction_302
+happyReduction_302 (happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest) tk
@@ -3833,29 +3849,29 @@ happyReduction_301 (happy_x_3 `HappyStk`
( funClauseOrTypeSigs happy_var_1 happy_var_2 happy_var_3)}}}
) (\r -> happyReturn (happyIn81 r))
-happyReduce_302 = happySpecReduce_2 76# happyReduction_302
-happyReduction_302 happy_x_2
+happyReduce_303 = happySpecReduce_2 76# happyReduction_303
+happyReduction_303 happy_x_2
happy_x_1
= case happyOut31 happy_x_2 of { happy_var_2 ->
happyIn82
(JustRHS (RHS happy_var_2)
)}
-happyReduce_303 = happySpecReduce_2 76# happyReduction_303
-happyReduction_303 happy_x_2
+happyReduce_304 = happySpecReduce_2 76# happyReduction_304
+happyReduction_304 happy_x_2
happy_x_1
= case happyOut31 happy_x_2 of { happy_var_2 ->
happyIn82
(TypeSigsRHS happy_var_2
)}
-happyReduce_304 = happySpecReduce_0 76# happyReduction_304
-happyReduction_304 = happyIn82
+happyReduce_305 = happySpecReduce_0 76# happyReduction_305
+happyReduction_305 = happyIn82
(JustRHS AbsurdRHS
)
-happyReduce_305 = happyReduce 7# 77# happyReduction_305
-happyReduction_305 (happy_x_7 `HappyStk`
+happyReduce_306 = happyReduce 7# 77# happyReduction_306
+happyReduction_306 (happy_x_7 `HappyStk`
happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
@@ -3869,13 +3885,13 @@ happyReduction_305 (happy_x_7 `HappyStk`
case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) ->
case happyOut31 happy_x_5 of { happy_var_5 ->
case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) ->
- case happyOut136 happy_x_7 of { happy_var_7 ->
+ case happyOut137 happy_x_7 of { happy_var_7 ->
happyIn83
(Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) Inductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7
) `HappyStk` happyRest}}}}}}}
-happyReduce_306 = happyReduce 7# 77# happyReduction_306
-happyReduction_306 (happy_x_7 `HappyStk`
+happyReduce_307 = happyReduce 7# 77# happyReduction_307
+happyReduction_307 (happy_x_7 `HappyStk`
happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
@@ -3889,13 +3905,13 @@ happyReduction_306 (happy_x_7 `HappyStk`
case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) ->
case happyOut31 happy_x_5 of { happy_var_5 ->
case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) ->
- case happyOut136 happy_x_7 of { happy_var_7 ->
+ case happyOut137 happy_x_7 of { happy_var_7 ->
happyIn83
(Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) CoInductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7
) `HappyStk` happyRest}}}}}}}
-happyReduce_307 = happyReduce 5# 77# happyReduction_307
-happyReduction_307 (happy_x_5 `HappyStk`
+happyReduce_308 = happyReduce 5# 77# happyReduction_308
+happyReduction_308 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -3905,13 +3921,13 @@ happyReduction_307 (happy_x_5 `HappyStk`
case happyOut15 happy_x_2 of { happy_var_2 ->
case happyOut59 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) ->
- case happyOut136 happy_x_5 of { happy_var_5 ->
+ case happyOut137 happy_x_5 of { happy_var_5 ->
happyIn83
(Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 Nothing happy_var_5
) `HappyStk` happyRest}}}}}
-happyReduce_308 = happyReduce 5# 77# happyReduction_308
-happyReduction_308 (happy_x_5 `HappyStk`
+happyReduce_309 = happyReduce 5# 77# happyReduction_309
+happyReduction_309 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -3921,13 +3937,13 @@ happyReduction_308 (happy_x_5 `HappyStk`
case happyOut15 happy_x_2 of { happy_var_2 ->
case happyOut59 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) ->
- case happyOut136 happy_x_5 of { happy_var_5 ->
+ case happyOut137 happy_x_5 of { happy_var_5 ->
happyIn83
(Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) CoInductive happy_var_2 happy_var_3 Nothing happy_var_5
) `HappyStk` happyRest}}}}}
-happyReduce_309 = happyReduce 5# 78# happyReduction_309
-happyReduction_309 (happy_x_5 `HappyStk`
+happyReduce_310 = happyReduce 5# 78# happyReduction_310
+happyReduction_310 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -3942,8 +3958,8 @@ happyReduction_309 (happy_x_5 `HappyStk`
(DataSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 happy_var_5
) `HappyStk` happyRest}}}}}
-happyReduce_310 = happyMonadReduce 7# 79# happyReduction_310
-happyReduction_310 (happy_x_7 `HappyStk`
+happyReduce_311 = happyMonadReduce 7# 79# happyReduction_311
+happyReduction_311 (happy_x_7 `HappyStk`
happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
@@ -3957,12 +3973,12 @@ happyReduction_310 (happy_x_7 `HappyStk`
case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) ->
case happyOut31 happy_x_5 of { happy_var_5 ->
case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) ->
- case happyOut137 happy_x_7 of { happy_var_7 ->
+ case happyOut138 happy_x_7 of { happy_var_7 ->
( exprToName happy_var_2 >>= \ n -> return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) n (fst3 happy_var_7) (snd3 happy_var_7) happy_var_3 (Just happy_var_5) (thd3 happy_var_7))}}}}}}}
) (\r -> happyReturn (happyIn85 r))
-happyReduce_311 = happyMonadReduce 5# 79# happyReduction_311
-happyReduction_311 (happy_x_5 `HappyStk`
+happyReduce_312 = happyMonadReduce 5# 79# happyReduction_312
+happyReduction_312 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -3972,12 +3988,12 @@ happyReduction_311 (happy_x_5 `HappyStk`
case happyOut39 happy_x_2 of { happy_var_2 ->
case happyOut59 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) ->
- case happyOut137 happy_x_5 of { happy_var_5 ->
+ case happyOut138 happy_x_5 of { happy_var_5 ->
( exprToName happy_var_2 >>= \ n -> return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n (fst3 happy_var_5) (snd3 happy_var_5) happy_var_3 Nothing (thd3 happy_var_5))}}}}}
) (\r -> happyReturn (happyIn85 r))
-happyReduce_312 = happyMonadReduce 5# 80# happyReduction_312
-happyReduction_312 (happy_x_5 `HappyStk`
+happyReduce_313 = happyMonadReduce 5# 80# happyReduction_313
+happyReduction_313 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -3991,16 +4007,16 @@ happyReduction_312 (happy_x_5 `HappyStk`
( exprToName happy_var_2 >>= \ n -> return $ RecordSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n happy_var_3 happy_var_5)}}}}}
) (\r -> happyReturn (happyIn86 r))
-happyReduce_313 = happySpecReduce_2 81# happyReduction_313
-happyReduction_313 happy_x_2
+happyReduce_314 = happySpecReduce_2 81# happyReduction_314
+happyReduction_314 happy_x_2
happy_x_1
= case happyOut15 happy_x_2 of { happy_var_2 ->
happyIn87
(happy_var_2
)}
-happyReduce_314 = happySpecReduce_3 82# happyReduction_314
-happyReduction_314 happy_x_3
+happyReduce_315 = happySpecReduce_3 82# happyReduction_315
+happyReduction_315 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) ->
@@ -4010,8 +4026,8 @@ happyReduction_314 happy_x_3
(Infix (NonAssoc (getRange (happy_var_1,happy_var_3)) happy_var_2) happy_var_3
)}}}
-happyReduce_315 = happySpecReduce_3 82# happyReduction_315
-happyReduction_315 happy_x_3
+happyReduce_316 = happySpecReduce_3 82# happyReduction_316
+happyReduction_316 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) ->
@@ -4021,8 +4037,8 @@ happyReduction_315 happy_x_3
(Infix (LeftAssoc (getRange (happy_var_1,happy_var_3)) happy_var_2) happy_var_3
)}}}
-happyReduce_316 = happySpecReduce_3 82# happyReduction_316
-happyReduction_316 happy_x_3
+happyReduce_317 = happySpecReduce_3 82# happyReduction_317
+happyReduction_317 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) ->
@@ -4032,70 +4048,70 @@ happyReduction_316 happy_x_3
(Infix (RightAssoc (getRange (happy_var_1,happy_var_3)) happy_var_2) happy_var_3
)}}}
-happyReduce_317 = happySpecReduce_2 83# happyReduction_317
-happyReduction_317 happy_x_2
+happyReduce_318 = happySpecReduce_2 83# happyReduction_318
+happyReduction_318 happy_x_2
happy_x_1
- = case happyOut134 happy_x_2 of { happy_var_2 ->
+ = case happyOut135 happy_x_2 of { happy_var_2 ->
happyIn89
(let toField (Common.Arg info (TypeSig _ x t)) = Field x (Common.Arg info t) in map toField happy_var_2
)}
-happyReduce_318 = happySpecReduce_2 84# happyReduction_318
-happyReduction_318 happy_x_2
+happyReduce_319 = happySpecReduce_2 84# happyReduction_319
+happyReduction_319 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) ->
- case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut140 happy_x_2 of { happy_var_2 ->
happyIn90
(Mutual (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_319 = happySpecReduce_2 85# happyReduction_319
-happyReduction_319 happy_x_2
+happyReduce_320 = happySpecReduce_2 85# happyReduction_320
+happyReduction_320 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) ->
- case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut140 happy_x_2 of { happy_var_2 ->
happyIn91
(Abstract (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_320 = happySpecReduce_2 86# happyReduction_320
-happyReduction_320 happy_x_2
+happyReduce_321 = happySpecReduce_2 86# happyReduction_321
+happyReduction_321 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) ->
- case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut140 happy_x_2 of { happy_var_2 ->
happyIn92
(Private (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_321 = happySpecReduce_2 87# happyReduction_321
-happyReduction_321 happy_x_2
+happyReduce_322 = happySpecReduce_2 87# happyReduction_322
+happyReduction_322 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) ->
- case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut140 happy_x_2 of { happy_var_2 ->
happyIn93
(InstanceB (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_322 = happySpecReduce_2 88# happyReduction_322
-happyReduction_322 happy_x_2
+happyReduce_323 = happySpecReduce_2 88# happyReduction_323
+happyReduction_323 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) ->
- case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut140 happy_x_2 of { happy_var_2 ->
happyIn94
(Postulate (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_323 = happySpecReduce_2 89# happyReduction_323
-happyReduction_323 happy_x_2
+happyReduce_324 = happySpecReduce_2 89# happyReduction_324
+happyReduction_324 happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) ->
- case happyOut132 happy_x_2 of { happy_var_2 ->
+ case happyOut133 happy_x_2 of { happy_var_2 ->
happyIn95
(Primitive (fuseRange happy_var_1 happy_var_2) happy_var_2
)}}
-happyReduce_324 = happyReduce 4# 90# happyReduction_324
-happyReduction_324 (happy_x_4 `HappyStk`
+happyReduce_325 = happyReduce 4# 90# happyReduction_325
+happyReduction_325 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4107,8 +4123,8 @@ happyReduction_324 (happy_x_4 `HappyStk`
(UnquoteDecl (fuseRange happy_var_1 happy_var_4) happy_var_2 happy_var_4
) `HappyStk` happyRest}}}
-happyReduce_325 = happyMonadReduce 5# 91# happyReduction_325
-happyReduction_325 (happy_x_5 `HappyStk`
+happyReduce_326 = happyMonadReduce 5# 91# happyReduction_326
+happyReduction_326 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4120,13 +4136,13 @@ happyReduction_325 (happy_x_5 `HappyStk`
(
case happy_var_2 of
Name _ [_] -> case mkNotation happy_var_3 (map rangedThing happy_var_5) of
- Left err -> parseError $ "malformed syntax declaration: " ++ err
+ Left err -> parseError $ "Malformed syntax declaration: " ++ err
Right n -> return $ Syntax happy_var_2 n
- _ -> parseError "syntax declarations are allowed only for simple names (without holes)")}}}
+ _ -> parseError "Syntax declarations are allowed only for simple names (without holes)")}}}
) (\r -> happyReturn (happyIn97 r))
-happyReduce_326 = happyMonadReduce 5# 92# happyReduction_326
-happyReduction_326 (happy_x_5 `HappyStk`
+happyReduce_327 = happyMonadReduce 5# 92# happyReduction_327
+happyReduction_327 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4142,27 +4158,27 @@ happyReduction_326 (happy_x_5 `HappyStk`
return (PatternSyn (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_3 p))}}}}}
) (\r -> happyReturn (happyIn98 r))
-happyReduce_327 = happySpecReduce_0 93# happyReduction_327
-happyReduction_327 = happyIn99
+happyReduce_328 = happySpecReduce_0 93# happyReduction_328
+happyReduction_328 = happyIn99
([]
)
-happyReduce_328 = happyMonadReduce 1# 93# happyReduction_328
-happyReduction_328 (happy_x_1 `HappyStk`
+happyReduce_329 = happyMonadReduce 1# 93# happyReduction_329
+happyReduction_329 (happy_x_1 `HappyStk`
happyRest) tk
= happyThen (case happyOut51 happy_x_1 of { happy_var_1 ->
( patternSynArgs happy_var_1)}
) (\r -> happyReturn (happyIn99 r))
-happyReduce_329 = happySpecReduce_1 94# happyReduction_329
-happyReduction_329 happy_x_1
+happyReduce_330 = happySpecReduce_1 94# happyReduction_330
+happyReduction_330 happy_x_1
= case happyOut105 happy_x_1 of { happy_var_1 ->
happyIn100
([happy_var_1]
)}
-happyReduce_330 = happySpecReduce_2 94# happyReduction_330
-happyReduction_330 happy_x_2
+happyReduce_331 = happySpecReduce_2 94# happyReduction_331
+happyReduction_331 happy_x_2
happy_x_1
= case happyOut100 happy_x_1 of { happy_var_1 ->
case happyOut105 happy_x_2 of { happy_var_2 ->
@@ -4170,15 +4186,15 @@ happyReduction_330 happy_x_2
(happy_var_1 ++ [happy_var_2]
)}}
-happyReduce_331 = happySpecReduce_1 95# happyReduction_331
-happyReduction_331 happy_x_1
+happyReduce_332 = happySpecReduce_1 95# happyReduction_332
+happyReduction_332 happy_x_1
= case happyOut102 happy_x_1 of { happy_var_1 ->
happyIn101
([happy_var_1]
)}
-happyReduce_332 = happySpecReduce_2 95# happyReduction_332
-happyReduction_332 happy_x_2
+happyReduce_333 = happySpecReduce_2 95# happyReduction_333
+happyReduction_333 happy_x_2
happy_x_1
= case happyOut101 happy_x_1 of { happy_var_1 ->
case happyOut102 happy_x_2 of { happy_var_2 ->
@@ -4186,15 +4202,15 @@ happyReduction_332 happy_x_2
(happy_var_1 ++ [happy_var_2]
)}}
-happyReduce_333 = happySpecReduce_1 96# happyReduction_333
-happyReduction_333 happy_x_1
+happyReduce_334 = happySpecReduce_1 96# happyReduction_334
+happyReduction_334 happy_x_1
= case happyOut103 happy_x_1 of { happy_var_1 ->
happyIn102
(defaultNamedArg happy_var_1
)}
-happyReduce_334 = happySpecReduce_3 96# happyReduction_334
-happyReduction_334 happy_x_3
+happyReduce_335 = happySpecReduce_3 96# happyReduction_335
+happyReduction_335 happy_x_3
happy_x_2
happy_x_1
= case happyOut104 happy_x_2 of { happy_var_2 ->
@@ -4202,8 +4218,8 @@ happyReduction_334 happy_x_3
(setHiding Hidden $ defaultNamedArg happy_var_2
)}
-happyReduce_335 = happySpecReduce_3 96# happyReduction_335
-happyReduction_335 happy_x_3
+happyReduce_336 = happySpecReduce_3 96# happyReduction_336
+happyReduction_336 happy_x_3
happy_x_2
happy_x_1
= case happyOut104 happy_x_2 of { happy_var_2 ->
@@ -4211,8 +4227,8 @@ happyReduction_335 happy_x_3
(setHiding Instance $ defaultNamedArg happy_var_2
)}
-happyReduce_336 = happyReduce 5# 96# happyReduction_336
-happyReduction_336 (happy_x_5 `HappyStk`
+happyReduce_337 = happyReduce 5# 96# happyReduction_337
+happyReduction_337 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4224,8 +4240,8 @@ happyReduction_336 (happy_x_5 `HappyStk`
(setHiding Hidden $ defaultArg $ named happy_var_2 happy_var_4
) `HappyStk` happyRest}}
-happyReduce_337 = happyReduce 5# 96# happyReduction_337
-happyReduction_337 (happy_x_5 `HappyStk`
+happyReduce_338 = happyReduce 5# 96# happyReduction_338
+happyReduction_338 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4237,15 +4253,15 @@ happyReduction_337 (happy_x_5 `HappyStk`
(setHiding Instance $ defaultArg $ named happy_var_2 happy_var_4
) `HappyStk` happyRest}}
-happyReduce_338 = happySpecReduce_1 97# happyReduction_338
-happyReduction_338 happy_x_1
+happyReduce_339 = happySpecReduce_1 97# happyReduction_339
+happyReduction_339 happy_x_1
= case happyOut105 happy_x_1 of { happy_var_1 ->
happyIn103
(ExprHole (rangedThing happy_var_1)
)}
-happyReduce_339 = happyReduce 6# 97# happyReduction_339
-happyReduction_339 (happy_x_6 `HappyStk`
+happyReduce_340 = happyReduce 6# 97# happyReduction_340
+happyReduction_340 (happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
@@ -4258,15 +4274,15 @@ happyReduction_339 (happy_x_6 `HappyStk`
(LambdaHole (rangedThing happy_var_3) (rangedThing happy_var_5)
) `HappyStk` happyRest}}
-happyReduce_340 = happySpecReduce_1 98# happyReduction_340
-happyReduction_340 happy_x_1
+happyReduce_341 = happySpecReduce_1 98# happyReduction_341
+happyReduction_341 happy_x_1
= case happyOut105 happy_x_1 of { happy_var_1 ->
happyIn104
(ExprHole (rangedThing happy_var_1)
)}
-happyReduce_341 = happyReduce 4# 98# happyReduction_341
-happyReduction_341 (happy_x_4 `HappyStk`
+happyReduce_342 = happyReduce 4# 98# happyReduction_342
+happyReduction_342 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4277,27 +4293,27 @@ happyReduction_341 (happy_x_4 `HappyStk`
(LambdaHole (rangedThing happy_var_2) (rangedThing happy_var_4)
) `HappyStk` happyRest}}
-happyReduce_342 = happySpecReduce_1 99# happyReduction_342
-happyReduction_342 happy_x_1
+happyReduce_343 = happySpecReduce_1 99# happyReduction_343
+happyReduction_343 happy_x_1
= case happyOutTok happy_x_1 of { (TokId happy_var_1) ->
happyIn105
(Ranged (getRange $ fst happy_var_1) (stringToRawName $ snd happy_var_1)
)}
-happyReduce_343 = happySpecReduce_1 100# happyReduction_343
-happyReduction_343 happy_x_1
+happyReduce_344 = happySpecReduce_1 100# happyReduction_344
+happyReduction_344 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) ->
happyIn106
(Just (getRange happy_var_1)
)}
-happyReduce_344 = happySpecReduce_0 100# happyReduction_344
-happyReduction_344 = happyIn106
+happyReduce_345 = happySpecReduce_0 100# happyReduction_345
+happyReduction_345 = happyIn106
(Nothing
)
-happyReduce_345 = happyMonadReduce 5# 101# happyReduction_345
-happyReduction_345 (happy_x_5 `HappyStk`
+happyReduce_346 = happyMonadReduce 5# 101# happyReduction_346
+happyReduction_346 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4355,8 +4371,8 @@ happyReduction_345 (happy_x_5 `HappyStk`
})}}}}}
) (\r -> happyReturn (happyIn107 r))
-happyReduce_346 = happyReduce 4# 101# happyReduction_346
-happyReduction_346 (happy_x_4 `HappyStk`
+happyReduce_347 = happyReduce 4# 101# happyReduction_347
+happyReduction_347 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4374,15 +4390,15 @@ happyReduction_346 (happy_x_4 `HappyStk`
[ case es of
{ [] -> Open r m dir
; _ -> Private r [ ModuleMacro r (noName $ beginningOf $ getRange m)
- (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))
- DoOpen dir
+ (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))
+ DoOpen dir
]
}
]
) `HappyStk` happyRest}}}
-happyReduce_347 = happyReduce 6# 101# happyReduction_347
-happyReduction_347 (happy_x_6 `HappyStk`
+happyReduce_348 = happyReduce 6# 101# happyReduction_348
+happyReduction_348 (happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
@@ -4394,18 +4410,18 @@ happyReduction_347 (happy_x_6 `HappyStk`
happyIn107
(let r = getRange happy_var_2 in
[ Private r [ ModuleMacro r (noName $ beginningOf $ getRange happy_var_2)
- (RecordModuleIFS r happy_var_2) DoOpen happy_var_6
+ (RecordModuleIFS r happy_var_2) DoOpen happy_var_6
]
]
) `HappyStk` happyRest}}
-happyReduce_348 = happySpecReduce_0 102# happyReduction_348
-happyReduction_348 = happyIn108
+happyReduce_349 = happySpecReduce_0 102# happyReduction_349
+happyReduction_349 = happyIn108
([]
)
-happyReduce_349 = happySpecReduce_2 102# happyReduction_349
-happyReduction_349 happy_x_2
+happyReduce_350 = happySpecReduce_2 102# happyReduction_350
+happyReduction_350 happy_x_2
happy_x_1
= case happyOut40 happy_x_1 of { happy_var_1 ->
case happyOut108 happy_x_2 of { happy_var_2 ->
@@ -4413,8 +4429,8 @@ happyReduction_349 happy_x_2
(happy_var_1 : happy_var_2
)}}
-happyReduce_350 = happyReduce 4# 103# happyReduction_350
-happyReduction_350 (happy_x_4 `HappyStk`
+happyReduce_351 = happyReduce 4# 103# happyReduction_351
+happyReduction_351 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4425,12 +4441,12 @@ happyReduction_350 (happy_x_4 `HappyStk`
case happyOut17 happy_x_4 of { happy_var_4 ->
happyIn109
((\ts ->
- if null ts then return $ RecordModuleIFS (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_1
- else parseError "No bindings allowed for record module with non-canonical implicits" )
+ if null ts then return $ RecordModuleIFS (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_1
+ else parseError "No bindings allowed for record module with non-canonical implicits" )
) `HappyStk` happyRest}}}}
-happyReduce_351 = happySpecReduce_2 103# happyReduction_351
-happyReduction_351 happy_x_2
+happyReduce_352 = happySpecReduce_2 103# happyReduction_352
+happyReduction_352 happy_x_2
happy_x_1
= case happyOut22 happy_x_1 of { happy_var_1 ->
case happyOut108 happy_x_2 of { happy_var_2 ->
@@ -4438,8 +4454,8 @@ happyReduction_351 happy_x_2
((\ts -> return $ SectionApp (getRange (happy_var_1, happy_var_2)) ts (RawApp (fuseRange happy_var_1 happy_var_2) (Ident happy_var_1 : happy_var_2)) )
)}}
-happyReduce_352 = happyMonadReduce 6# 104# happyReduction_352
-happyReduction_352 (happy_x_6 `HappyStk`
+happyReduce_353 = happyMonadReduce 6# 104# happyReduction_353
+happyReduction_353 (happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
@@ -4456,8 +4472,8 @@ happyReduction_352 (happy_x_6 `HappyStk`
; return $ ModuleMacro (getRange (happy_var_1, happy_var_2, ma, happy_var_6)) name ma DontOpen happy_var_6 })}}}}}
) (\r -> happyReturn (happyIn110 r))
-happyReduce_353 = happyMonadReduce 7# 104# happyReduction_353
-happyReduction_353 (happy_x_7 `HappyStk`
+happyReduce_354 = happyMonadReduce 7# 104# happyReduction_354
+happyReduction_354 (happy_x_7 `HappyStk`
happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
@@ -4474,8 +4490,8 @@ happyReduction_353 (happy_x_7 `HappyStk`
( do {ma <- happy_var_6 (map addType happy_var_4); return $ ModuleMacro (getRange (happy_var_1, happy_var_2, happy_var_3, ma, happy_var_7)) happy_var_3 ma DoOpen happy_var_7 })}}}}}}
) (\r -> happyReturn (happyIn110 r))
-happyReduce_354 = happyReduce 5# 105# happyReduction_354
-happyReduction_354 (happy_x_5 `HappyStk`
+happyReduce_355 = happyReduce 5# 105# happyReduction_355
+happyReduction_355 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4485,13 +4501,13 @@ happyReduction_354 (happy_x_5 `HappyStk`
case happyOut22 happy_x_2 of { happy_var_2 ->
case happyOut59 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) ->
- case happyOut140 happy_x_5 of { happy_var_5 ->
+ case happyOut141 happy_x_5 of { happy_var_5 ->
happyIn111
(Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 (map addType happy_var_3) happy_var_5
) `HappyStk` happyRest}}}}}
-happyReduce_355 = happyReduce 5# 105# happyReduction_355
-happyReduction_355 (happy_x_5 `HappyStk`
+happyReduce_356 = happyReduce 5# 105# happyReduction_356
+happyReduction_356 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4501,98 +4517,91 @@ happyReduction_355 (happy_x_5 `HappyStk`
case happyOut112 happy_x_2 of { happy_var_2 ->
case happyOut59 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) ->
- case happyOut140 happy_x_5 of { happy_var_5 ->
+ case happyOut141 happy_x_5 of { happy_var_5 ->
happyIn111
(Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) (QName happy_var_2) (map addType happy_var_3) happy_var_5
) `HappyStk` happyRest}}}}}
-happyReduce_356 = happySpecReduce_1 106# happyReduction_356
-happyReduction_356 happy_x_1
+happyReduce_357 = happySpecReduce_1 106# happyReduction_357
+happyReduction_357 happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) ->
happyIn112
(noName (getRange happy_var_1)
)}
-happyReduce_357 = happySpecReduce_1 107# happyReduction_357
-happyReduction_357 happy_x_1
- = case happyOut142 happy_x_1 of { happy_var_1 ->
+happyReduce_358 = happySpecReduce_1 107# happyReduction_358
+happyReduction_358 happy_x_1
+ = case happyOut143 happy_x_1 of { happy_var_1 ->
happyIn113
(figureOutTopLevelModule happy_var_1
)}
-happyReduce_358 = happySpecReduce_1 108# happyReduction_358
-happyReduction_358 happy_x_1
+happyReduce_359 = happySpecReduce_1 108# happyReduction_359
+happyReduction_359 happy_x_1
= case happyOut115 happy_x_1 of { happy_var_1 ->
happyIn114
(Pragma happy_var_1
)}
-happyReduce_359 = happySpecReduce_1 109# happyReduction_359
-happyReduction_359 happy_x_1
- = case happyOut117 happy_x_1 of { happy_var_1 ->
- happyIn115
- (happy_var_1
- )}
-
happyReduce_360 = happySpecReduce_1 109# happyReduction_360
happyReduction_360 happy_x_1
- = case happyOut118 happy_x_1 of { happy_var_1 ->
+ = case happyOut117 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_361 = happySpecReduce_1 109# happyReduction_361
happyReduction_361 happy_x_1
- = case happyOut119 happy_x_1 of { happy_var_1 ->
+ = case happyOut118 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_362 = happySpecReduce_1 109# happyReduction_362
happyReduction_362 happy_x_1
- = case happyOut120 happy_x_1 of { happy_var_1 ->
+ = case happyOut119 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_363 = happySpecReduce_1 109# happyReduction_363
happyReduction_363 happy_x_1
- = case happyOut122 happy_x_1 of { happy_var_1 ->
+ = case happyOut120 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_364 = happySpecReduce_1 109# happyReduction_364
happyReduction_364 happy_x_1
- = case happyOut121 happy_x_1 of { happy_var_1 ->
+ = case happyOut122 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_365 = happySpecReduce_1 109# happyReduction_365
happyReduction_365 happy_x_1
- = case happyOut123 happy_x_1 of { happy_var_1 ->
+ = case happyOut121 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_366 = happySpecReduce_1 109# happyReduction_366
happyReduction_366 happy_x_1
- = case happyOut124 happy_x_1 of { happy_var_1 ->
+ = case happyOut123 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_367 = happySpecReduce_1 109# happyReduction_367
happyReduction_367 happy_x_1
- = case happyOut125 happy_x_1 of { happy_var_1 ->
+ = case happyOut124 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_368 = happySpecReduce_1 109# happyReduction_368
happyReduction_368 happy_x_1
- = case happyOut130 happy_x_1 of { happy_var_1 ->
+ = case happyOut125 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
@@ -4606,41 +4615,55 @@ happyReduction_369 happy_x_1
happyReduce_370 = happySpecReduce_1 109# happyReduction_370
happyReduction_370 happy_x_1
- = case happyOut126 happy_x_1 of { happy_var_1 ->
+ = case happyOut132 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_371 = happySpecReduce_1 109# happyReduction_371
happyReduction_371 happy_x_1
- = case happyOut128 happy_x_1 of { happy_var_1 ->
+ = case happyOut126 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_372 = happySpecReduce_1 109# happyReduction_372
happyReduction_372 happy_x_1
- = case happyOut127 happy_x_1 of { happy_var_1 ->
+ = case happyOut129 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_373 = happySpecReduce_1 109# happyReduction_373
happyReduction_373 happy_x_1
- = case happyOut129 happy_x_1 of { happy_var_1 ->
+ = case happyOut128 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
happyReduce_374 = happySpecReduce_1 109# happyReduction_374
happyReduction_374 happy_x_1
+ = case happyOut127 happy_x_1 of { happy_var_1 ->
+ happyIn115
+ (happy_var_1
+ )}
+
+happyReduce_375 = happySpecReduce_1 109# happyReduction_375
+happyReduction_375 happy_x_1
+ = case happyOut130 happy_x_1 of { happy_var_1 ->
+ happyIn115
+ (happy_var_1
+ )}
+
+happyReduce_376 = happySpecReduce_1 109# happyReduction_376
+happyReduction_376 happy_x_1
= case happyOut116 happy_x_1 of { happy_var_1 ->
happyIn115
(happy_var_1
)}
-happyReduce_375 = happyReduce 4# 110# happyReduction_375
-happyReduction_375 (happy_x_4 `HappyStk`
+happyReduce_377 = happyReduce 4# 110# happyReduction_377
+happyReduction_377 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4653,8 +4676,8 @@ happyReduction_375 (happy_x_4 `HappyStk`
(OptionsPragma (getRange (happy_var_1,happy_var_2,happy_var_4)) happy_var_3
) `HappyStk` happyRest}}}}
-happyReduce_376 = happyReduce 5# 111# happyReduction_376
-happyReduction_376 (happy_x_5 `HappyStk`
+happyReduce_378 = happyReduce 5# 111# happyReduction_378
+happyReduction_378 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4669,8 +4692,8 @@ happyReduction_376 (happy_x_5 `HappyStk`
(BuiltinPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4,happy_var_5)) (snd happy_var_3) (Ident happy_var_4)
) `HappyStk` happyRest}}}}}
-happyReduce_377 = happyReduce 5# 111# happyReduction_377
-happyReduction_377 (happy_x_5 `HappyStk`
+happyReduce_379 = happyReduce 5# 111# happyReduction_379
+happyReduction_379 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4685,8 +4708,8 @@ happyReduction_377 (happy_x_5 `HappyStk`
(BuiltinPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) "REWRITE" (Ident happy_var_4)
) `HappyStk` happyRest}}}}}
-happyReduce_378 = happyReduce 4# 112# happyReduction_378
-happyReduction_378 (happy_x_4 `HappyStk`
+happyReduce_380 = happyReduce 4# 112# happyReduction_380
+happyReduction_380 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4699,8 +4722,8 @@ happyReduction_378 (happy_x_4 `HappyStk`
(RewritePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3
) `HappyStk` happyRest}}}}
-happyReduce_379 = happyReduce 5# 113# happyReduction_379
-happyReduction_379 (happy_x_5 `HappyStk`
+happyReduce_381 = happyReduce 5# 113# happyReduction_381
+happyReduction_381 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4715,8 +4738,8 @@ happyReduction_379 (happy_x_5 `HappyStk`
(CompiledPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)
) `HappyStk` happyRest}}}}}
-happyReduce_380 = happyReduce 5# 114# happyReduction_380
-happyReduction_380 (happy_x_5 `HappyStk`
+happyReduce_382 = happyReduce 5# 114# happyReduction_382
+happyReduction_382 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4731,8 +4754,8 @@ happyReduction_380 (happy_x_5 `HappyStk`
(CompiledExportPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 happy_var_4
) `HappyStk` happyRest}}}}}
-happyReduce_381 = happyReduce 5# 115# happyReduction_381
-happyReduction_381 (happy_x_5 `HappyStk`
+happyReduce_383 = happyReduce 5# 115# happyReduction_383
+happyReduction_383 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4747,8 +4770,8 @@ happyReduction_381 (happy_x_5 `HappyStk`
(CompiledTypePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)
) `HappyStk` happyRest}}}}}
-happyReduce_382 = happyReduce 6# 116# happyReduction_382
-happyReduction_382 (happy_x_6 `HappyStk`
+happyReduce_384 = happyReduce 6# 116# happyReduction_384
+happyReduction_384 (happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
@@ -4765,8 +4788,8 @@ happyReduction_382 (happy_x_6 `HappyStk`
(CompiledDataPragma (getRange (happy_var_1,happy_var_2,happy_var_3,fst happy_var_4,happy_var_6)) happy_var_3 (snd happy_var_4) happy_var_5
) `HappyStk` happyRest}}}}}}
-happyReduce_383 = happyReduce 5# 117# happyReduction_383
-happyReduction_383 (happy_x_5 `HappyStk`
+happyReduce_385 = happyReduce 5# 117# happyReduction_385
+happyReduction_385 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4781,8 +4804,8 @@ happyReduction_383 (happy_x_5 `HappyStk`
(CompiledEpicPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)
) `HappyStk` happyRest}}}}}
-happyReduce_384 = happyReduce 5# 118# happyReduction_384
-happyReduction_384 (happy_x_5 `HappyStk`
+happyReduce_386 = happyReduce 5# 118# happyReduction_386
+happyReduction_386 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
@@ -4797,8 +4820,8 @@ happyReduction_384 (happy_x_5 `HappyStk`
(CompiledJSPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4)
) `HappyStk` happyRest}}}}}
-happyReduce_385 = happyReduce 4# 119# happyReduction_385
-happyReduction_385 (happy_x_4 `HappyStk`
+happyReduce_387 = happyReduce 4# 119# happyReduction_387
+happyReduction_387 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4811,8 +4834,8 @@ happyReduction_385 (happy_x_4 `HappyStk`
(StaticPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3
) `HappyStk` happyRest}}}}
-happyReduce_386 = happyReduce 4# 120# happyReduction_386
-happyReduction_386 (happy_x_4 `HappyStk`
+happyReduce_388 = happyReduce 4# 120# happyReduction_388
+happyReduction_388 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4825,8 +4848,8 @@ happyReduction_386 (happy_x_4 `HappyStk`
(EtaPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3
) `HappyStk` happyRest}}}}
-happyReduce_387 = happySpecReduce_3 121# happyReduction_387
-happyReduction_387 happy_x_3
+happyReduce_389 = happySpecReduce_3 121# happyReduction_389
+happyReduction_389 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) ->
@@ -4836,8 +4859,8 @@ happyReduction_387 happy_x_3
(TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NoTerminationCheck
)}}}
-happyReduce_388 = happySpecReduce_3 122# happyReduction_388
-happyReduction_388 happy_x_3
+happyReduce_390 = happySpecReduce_3 122# happyReduction_390
+happyReduction_390 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) ->
@@ -4847,8 +4870,19 @@ happyReduction_388 happy_x_3
(TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NonTerminating
)}}}
-happyReduce_389 = happyReduce 4# 123# happyReduction_389
-happyReduction_389 (happy_x_4 `HappyStk`
+happyReduce_391 = happySpecReduce_3 123# happyReduction_391
+happyReduction_391 happy_x_3
+ happy_x_2
+ happy_x_1
+ = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) ->
+ case happyOutTok happy_x_2 of { (TokKeyword KwTERMINATING happy_var_2) ->
+ case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) ->
+ happyIn129
+ (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) Terminating
+ )}}}
+
+happyReduce_392 = happyReduce 4# 124# happyReduction_392
+happyReduction_392 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4857,13 +4891,13 @@ happyReduction_389 (happy_x_4 `HappyStk`
case happyOutTok happy_x_2 of { (TokKeyword KwMEASURE happy_var_2) ->
case happyOut29 happy_x_3 of { happy_var_3 ->
case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) ->
- happyIn129
+ happyIn130
(let r = getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4) in
TerminationCheckPragma r (TerminationMeasure r happy_var_3)
) `HappyStk` happyRest}}}}
-happyReduce_390 = happyMonadReduce 4# 124# happyReduction_390
-happyReduction_390 (happy_x_4 `HappyStk`
+happyReduce_393 = happyMonadReduce 4# 125# happyReduction_393
+happyReduction_393 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
@@ -4876,147 +4910,147 @@ happyReduction_390 (happy_x_4 `HappyStk`
if validHaskellModuleName s
then return $ ImportPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4)) s
else parseError $ "Malformed module name: " ++ s ++ ".")}}}}
- ) (\r -> happyReturn (happyIn130 r))
+ ) (\r -> happyReturn (happyIn131 r))
-happyReduce_391 = happySpecReduce_3 125# happyReduction_391
-happyReduction_391 happy_x_3
+happyReduce_394 = happySpecReduce_3 126# happyReduction_394
+happyReduction_394 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) ->
case happyOutTok happy_x_2 of { (TokKeyword KwIMPOSSIBLE happy_var_2) ->
case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) ->
- happyIn131
+ happyIn132
(ImpossiblePragma (getRange (happy_var_1,happy_var_2,happy_var_3))
)}}}
-happyReduce_392 = happySpecReduce_3 126# happyReduction_392
-happyReduction_392 happy_x_3
+happyReduce_395 = happySpecReduce_3 127# happyReduction_395
+happyReduction_395 happy_x_3
happy_x_2
happy_x_1
- = case happyOut133 happy_x_2 of { happy_var_2 ->
- happyIn132
+ = case happyOut134 happy_x_2 of { happy_var_2 ->
+ happyIn133
(reverse happy_var_2
)}
-happyReduce_393 = happySpecReduce_3 127# happyReduction_393
-happyReduction_393 happy_x_3
+happyReduce_396 = happySpecReduce_3 128# happyReduction_396
+happyReduction_396 happy_x_3
happy_x_2
happy_x_1
- = case happyOut133 happy_x_1 of { happy_var_1 ->
+ = case happyOut134 happy_x_1 of { happy_var_1 ->
case happyOut79 happy_x_3 of { happy_var_3 ->
- happyIn133
+ happyIn134
(reverse happy_var_3 ++ happy_var_1
)}}
-happyReduce_394 = happySpecReduce_1 127# happyReduction_394
-happyReduction_394 happy_x_1
+happyReduce_397 = happySpecReduce_1 128# happyReduction_397
+happyReduction_397 happy_x_1
= case happyOut79 happy_x_1 of { happy_var_1 ->
- happyIn133
+ happyIn134
(reverse happy_var_1
)}
-happyReduce_395 = happySpecReduce_3 128# happyReduction_395
-happyReduction_395 happy_x_3
+happyReduce_398 = happySpecReduce_3 129# happyReduction_398
+happyReduction_398 happy_x_3
happy_x_2
happy_x_1
- = case happyOut135 happy_x_2 of { happy_var_2 ->
- happyIn134
+ = case happyOut136 happy_x_2 of { happy_var_2 ->
+ happyIn135
(reverse happy_var_2
)}
-happyReduce_396 = happySpecReduce_3 129# happyReduction_396
-happyReduction_396 happy_x_3
+happyReduce_399 = happySpecReduce_3 130# happyReduction_399
+happyReduction_399 happy_x_3
happy_x_2
happy_x_1
- = case happyOut135 happy_x_1 of { happy_var_1 ->
+ = case happyOut136 happy_x_1 of { happy_var_1 ->
case happyOut80 happy_x_3 of { happy_var_3 ->
- happyIn135
+ happyIn136
(reverse happy_var_3 ++ happy_var_1
)}}
-happyReduce_397 = happySpecReduce_1 129# happyReduction_397
-happyReduction_397 happy_x_1
+happyReduce_400 = happySpecReduce_1 130# happyReduction_400
+happyReduction_400 happy_x_1
= case happyOut80 happy_x_1 of { happy_var_1 ->
- happyIn135
+ happyIn136
(reverse happy_var_1
)}
-happyReduce_398 = happySpecReduce_2 130# happyReduction_398
-happyReduction_398 happy_x_2
+happyReduce_401 = happySpecReduce_2 131# happyReduction_401
+happyReduction_401 happy_x_2
happy_x_1
- = happyIn136
+ = happyIn137
([]
)
-happyReduce_399 = happySpecReduce_1 130# happyReduction_399
-happyReduction_399 happy_x_1
- = case happyOut132 happy_x_1 of { happy_var_1 ->
- happyIn136
+happyReduce_402 = happySpecReduce_1 131# happyReduction_402
+happyReduction_402 happy_x_1
+ = case happyOut133 happy_x_1 of { happy_var_1 ->
+ happyIn137
(happy_var_1
)}
-happyReduce_400 = happySpecReduce_2 131# happyReduction_400
-happyReduction_400 happy_x_2
+happyReduce_403 = happySpecReduce_2 132# happyReduction_403
+happyReduction_403 happy_x_2
happy_x_1
- = happyIn137
+ = happyIn138
((Nothing, Nothing, [])
)
-happyReduce_401 = happySpecReduce_3 131# happyReduction_401
-happyReduction_401 happy_x_3
+happyReduce_404 = happySpecReduce_3 132# happyReduction_404
+happyReduction_404 happy_x_3
happy_x_2
happy_x_1
= case happyOut87 happy_x_2 of { happy_var_2 ->
- happyIn137
+ happyIn138
((Nothing, Just happy_var_2, [])
)}
-happyReduce_402 = happyReduce 5# 131# happyReduction_402
-happyReduction_402 (happy_x_5 `HappyStk`
+happyReduce_405 = happyReduce 5# 132# happyReduction_405
+happyReduction_405 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut87 happy_x_2 of { happy_var_2 ->
- case happyOut141 happy_x_4 of { happy_var_4 ->
- happyIn137
+ case happyOut142 happy_x_4 of { happy_var_4 ->
+ happyIn138
((Nothing, Just happy_var_2, happy_var_4)
) `HappyStk` happyRest}}
-happyReduce_403 = happySpecReduce_3 131# happyReduction_403
-happyReduction_403 happy_x_3
+happyReduce_406 = happySpecReduce_3 132# happyReduction_406
+happyReduction_406 happy_x_3
happy_x_2
happy_x_1
- = case happyOut141 happy_x_2 of { happy_var_2 ->
- happyIn137
+ = case happyOut142 happy_x_2 of { happy_var_2 ->
+ happyIn138
((Nothing, Nothing, happy_var_2)
)}
-happyReduce_404 = happySpecReduce_3 131# happyReduction_404
-happyReduction_404 happy_x_3
+happyReduce_407 = happySpecReduce_3 132# happyReduction_407
+happyReduction_407 happy_x_3
happy_x_2
happy_x_1
- = case happyOut138 happy_x_2 of { happy_var_2 ->
- happyIn137
+ = case happyOut139 happy_x_2 of { happy_var_2 ->
+ happyIn138
((Just happy_var_2, Nothing, [])
)}
-happyReduce_405 = happyReduce 5# 131# happyReduction_405
-happyReduction_405 (happy_x_5 `HappyStk`
+happyReduce_408 = happyReduce 5# 132# happyReduction_408
+happyReduction_408 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
- = case happyOut138 happy_x_2 of { happy_var_2 ->
+ = case happyOut139 happy_x_2 of { happy_var_2 ->
case happyOut87 happy_x_4 of { happy_var_4 ->
- happyIn137
+ happyIn138
((Just happy_var_2, Just happy_var_4, [])
) `HappyStk` happyRest}}
-happyReduce_406 = happyReduce 7# 131# happyReduction_406
-happyReduction_406 (happy_x_7 `HappyStk`
+happyReduce_409 = happyReduce 7# 132# happyReduction_409
+happyReduction_409 (happy_x_7 `HappyStk`
happy_x_6 `HappyStk`
happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
@@ -5024,89 +5058,89 @@ happyReduction_406 (happy_x_7 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
- = case happyOut138 happy_x_2 of { happy_var_2 ->
+ = case happyOut139 happy_x_2 of { happy_var_2 ->
case happyOut87 happy_x_4 of { happy_var_4 ->
- case happyOut141 happy_x_6 of { happy_var_6 ->
- happyIn137
+ case happyOut142 happy_x_6 of { happy_var_6 ->
+ happyIn138
((Just happy_var_2, Just happy_var_4, happy_var_6)
) `HappyStk` happyRest}}}
-happyReduce_407 = happyReduce 5# 131# happyReduction_407
-happyReduction_407 (happy_x_5 `HappyStk`
+happyReduce_410 = happyReduce 5# 132# happyReduction_410
+happyReduction_410 (happy_x_5 `HappyStk`
happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
- = case happyOut138 happy_x_2 of { happy_var_2 ->
- case happyOut141 happy_x_4 of { happy_var_4 ->
- happyIn137
+ = case happyOut139 happy_x_2 of { happy_var_2 ->
+ case happyOut142 happy_x_4 of { happy_var_4 ->
+ happyIn138
((Just happy_var_2, Nothing, happy_var_4)
) `HappyStk` happyRest}}
-happyReduce_408 = happySpecReduce_1 132# happyReduction_408
-happyReduction_408 happy_x_1
+happyReduce_411 = happySpecReduce_1 133# happyReduction_411
+happyReduction_411 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) ->
- happyIn138
+ happyIn139
(Ranged (getRange happy_var_1) Inductive
)}
-happyReduce_409 = happySpecReduce_1 132# happyReduction_409
-happyReduction_409 happy_x_1
+happyReduce_412 = happySpecReduce_1 133# happyReduction_412
+happyReduction_412 happy_x_1
= case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) ->
- happyIn138
+ happyIn139
(Ranged (getRange happy_var_1) CoInductive
)}
-happyReduce_410 = happySpecReduce_3 133# happyReduction_410
-happyReduction_410 happy_x_3
+happyReduce_413 = happySpecReduce_3 134# happyReduction_413
+happyReduction_413 happy_x_3
happy_x_2
happy_x_1
- = case happyOut141 happy_x_2 of { happy_var_2 ->
- happyIn139
+ = case happyOut142 happy_x_2 of { happy_var_2 ->
+ happyIn140
(happy_var_2
)}
-happyReduce_411 = happySpecReduce_2 134# happyReduction_411
-happyReduction_411 happy_x_2
+happyReduce_414 = happySpecReduce_2 135# happyReduction_414
+happyReduction_414 happy_x_2
happy_x_1
- = happyIn140
+ = happyIn141
([]
)
-happyReduce_412 = happySpecReduce_1 134# happyReduction_412
-happyReduction_412 happy_x_1
- = case happyOut139 happy_x_1 of { happy_var_1 ->
- happyIn140
+happyReduce_415 = happySpecReduce_1 135# happyReduction_415
+happyReduction_415 happy_x_1
+ = case happyOut140 happy_x_1 of { happy_var_1 ->
+ happyIn141
(happy_var_1
)}
-happyReduce_413 = happySpecReduce_3 135# happyReduction_413
-happyReduction_413 happy_x_3
+happyReduce_416 = happySpecReduce_3 136# happyReduction_416
+happyReduction_416 happy_x_3
happy_x_2
happy_x_1
= case happyOut78 happy_x_1 of { happy_var_1 ->
- case happyOut141 happy_x_3 of { happy_var_3 ->
- happyIn141
+ case happyOut142 happy_x_3 of { happy_var_3 ->
+ happyIn142
(happy_var_1 ++ happy_var_3
)}}
-happyReduce_414 = happySpecReduce_1 135# happyReduction_414
-happyReduction_414 happy_x_1
+happyReduce_417 = happySpecReduce_1 136# happyReduction_417
+happyReduction_417 happy_x_1
= case happyOut78 happy_x_1 of { happy_var_1 ->
- happyIn141
+ happyIn142
(happy_var_1
)}
-happyReduce_415 = happySpecReduce_0 136# happyReduction_415
-happyReduction_415 = happyIn142
+happyReduce_418 = happySpecReduce_0 137# happyReduction_418
+happyReduction_418 = happyIn143
([]
)
-happyReduce_416 = happySpecReduce_1 136# happyReduction_416
-happyReduction_416 happy_x_1
- = case happyOut141 happy_x_1 of { happy_var_1 ->
- happyIn142
+happyReduce_419 = happySpecReduce_1 137# happyReduction_419
+happyReduction_419 happy_x_1
+ = case happyOut142 happy_x_1 of { happy_var_1 ->
+ happyIn143
(happy_var_1
)}
@@ -5114,7 +5148,7 @@ happyNewToken action sts stk
= lexer(\tk ->
let cont i = happyDoAction i tk action sts stk in
case tk of {
- TokEOF -> happyDoAction 88# tk action sts stk;
+ TokEOF -> happyDoAction 89# tk action sts stk;
TokKeyword KwLet happy_dollar_dollar -> cont 1#;
TokKeyword KwIn happy_dollar_dollar -> cont 2#;
TokKeyword KwWhere happy_dollar_dollar -> cont 3#;
@@ -5157,55 +5191,56 @@ happyNewToken action sts stk
TokKeyword KwETA happy_dollar_dollar -> cont 40#;
TokKeyword KwNO_TERMINATION_CHECK happy_dollar_dollar -> cont 41#;
TokKeyword KwNON_TERMINATING happy_dollar_dollar -> cont 42#;
- TokKeyword KwMEASURE happy_dollar_dollar -> cont 43#;
- TokKeyword KwCOMPILED happy_dollar_dollar -> cont 44#;
- TokKeyword KwCOMPILED_EXPORT happy_dollar_dollar -> cont 45#;
- TokKeyword KwCOMPILED_DATA happy_dollar_dollar -> cont 46#;
- TokKeyword KwCOMPILED_TYPE happy_dollar_dollar -> cont 47#;
- TokKeyword KwCOMPILED_EPIC happy_dollar_dollar -> cont 48#;
- TokKeyword KwCOMPILED_JS happy_dollar_dollar -> cont 49#;
- TokKeyword KwSTATIC happy_dollar_dollar -> cont 50#;
- TokKeyword KwQuoteGoal happy_dollar_dollar -> cont 51#;
- TokKeyword KwQuoteContext happy_dollar_dollar -> cont 52#;
- TokKeyword KwQuote happy_dollar_dollar -> cont 53#;
- TokKeyword KwQuoteTerm happy_dollar_dollar -> cont 54#;
- TokKeyword KwTactic happy_dollar_dollar -> cont 55#;
- TokKeyword KwUnquote happy_dollar_dollar -> cont 56#;
- TokKeyword KwUnquoteDecl happy_dollar_dollar -> cont 57#;
- TokSetN happy_dollar_dollar -> cont 58#;
- TokTeX happy_dollar_dollar -> cont 59#;
- TokComment happy_dollar_dollar -> cont 60#;
- TokSymbol SymEllipsis happy_dollar_dollar -> cont 61#;
- TokSymbol SymDotDot happy_dollar_dollar -> cont 62#;
- TokSymbol SymDot happy_dollar_dollar -> cont 63#;
- TokSymbol SymSemi happy_dollar_dollar -> cont 64#;
- TokSymbol SymColon happy_dollar_dollar -> cont 65#;
- TokSymbol SymEqual happy_dollar_dollar -> cont 66#;
- TokSymbol SymUnderscore happy_dollar_dollar -> cont 67#;
- TokSymbol SymQuestionMark happy_dollar_dollar -> cont 68#;
- TokSymbol SymArrow happy_dollar_dollar -> cont 69#;
- TokSymbol SymLambda happy_dollar_dollar -> cont 70#;
- TokSymbol SymAs happy_dollar_dollar -> cont 71#;
- TokSymbol SymBar happy_dollar_dollar -> cont 72#;
- TokSymbol SymOpenParen happy_dollar_dollar -> cont 73#;
- TokSymbol SymCloseParen happy_dollar_dollar -> cont 74#;
- TokSymbol SymDoubleOpenBrace happy_dollar_dollar -> cont 75#;
- TokSymbol SymDoubleCloseBrace happy_dollar_dollar -> cont 76#;
- TokSymbol SymOpenBrace happy_dollar_dollar -> cont 77#;
- TokSymbol SymCloseBrace happy_dollar_dollar -> cont 78#;
- TokSymbol SymOpenVirtualBrace happy_dollar_dollar -> cont 79#;
- TokSymbol SymCloseVirtualBrace happy_dollar_dollar -> cont 80#;
- TokSymbol SymVirtualSemi happy_dollar_dollar -> cont 81#;
- TokSymbol SymOpenPragma happy_dollar_dollar -> cont 82#;
- TokSymbol SymClosePragma happy_dollar_dollar -> cont 83#;
- TokId happy_dollar_dollar -> cont 84#;
- TokQId happy_dollar_dollar -> cont 85#;
- TokString happy_dollar_dollar -> cont 86#;
- TokLiteral happy_dollar_dollar -> cont 87#;
+ TokKeyword KwTERMINATING happy_dollar_dollar -> cont 43#;
+ TokKeyword KwMEASURE happy_dollar_dollar -> cont 44#;
+ TokKeyword KwCOMPILED happy_dollar_dollar -> cont 45#;
+ TokKeyword KwCOMPILED_EXPORT happy_dollar_dollar -> cont 46#;
+ TokKeyword KwCOMPILED_DATA happy_dollar_dollar -> cont 47#;
+ TokKeyword KwCOMPILED_TYPE happy_dollar_dollar -> cont 48#;
+ TokKeyword KwCOMPILED_EPIC happy_dollar_dollar -> cont 49#;
+ TokKeyword KwCOMPILED_JS happy_dollar_dollar -> cont 50#;
+ TokKeyword KwSTATIC happy_dollar_dollar -> cont 51#;
+ TokKeyword KwQuoteGoal happy_dollar_dollar -> cont 52#;
+ TokKeyword KwQuoteContext happy_dollar_dollar -> cont 53#;
+ TokKeyword KwQuote happy_dollar_dollar -> cont 54#;
+ TokKeyword KwQuoteTerm happy_dollar_dollar -> cont 55#;
+ TokKeyword KwTactic happy_dollar_dollar -> cont 56#;
+ TokKeyword KwUnquote happy_dollar_dollar -> cont 57#;
+ TokKeyword KwUnquoteDecl happy_dollar_dollar -> cont 58#;
+ TokSetN happy_dollar_dollar -> cont 59#;
+ TokTeX happy_dollar_dollar -> cont 60#;
+ TokComment happy_dollar_dollar -> cont 61#;
+ TokSymbol SymEllipsis happy_dollar_dollar -> cont 62#;
+ TokSymbol SymDotDot happy_dollar_dollar -> cont 63#;
+ TokSymbol SymDot happy_dollar_dollar -> cont 64#;
+ TokSymbol SymSemi happy_dollar_dollar -> cont 65#;
+ TokSymbol SymColon happy_dollar_dollar -> cont 66#;
+ TokSymbol SymEqual happy_dollar_dollar -> cont 67#;
+ TokSymbol SymUnderscore happy_dollar_dollar -> cont 68#;
+ TokSymbol SymQuestionMark happy_dollar_dollar -> cont 69#;
+ TokSymbol SymArrow happy_dollar_dollar -> cont 70#;
+ TokSymbol SymLambda happy_dollar_dollar -> cont 71#;
+ TokSymbol SymAs happy_dollar_dollar -> cont 72#;
+ TokSymbol SymBar happy_dollar_dollar -> cont 73#;
+ TokSymbol SymOpenParen happy_dollar_dollar -> cont 74#;
+ TokSymbol SymCloseParen happy_dollar_dollar -> cont 75#;
+ TokSymbol SymDoubleOpenBrace happy_dollar_dollar -> cont 76#;
+ TokSymbol SymDoubleCloseBrace happy_dollar_dollar -> cont 77#;
+ TokSymbol SymOpenBrace happy_dollar_dollar -> cont 78#;
+ TokSymbol SymCloseBrace happy_dollar_dollar -> cont 79#;
+ TokSymbol SymOpenVirtualBrace happy_dollar_dollar -> cont 80#;
+ TokSymbol SymCloseVirtualBrace happy_dollar_dollar -> cont 81#;
+ TokSymbol SymVirtualSemi happy_dollar_dollar -> cont 82#;
+ TokSymbol SymOpenPragma happy_dollar_dollar -> cont 83#;
+ TokSymbol SymClosePragma happy_dollar_dollar -> cont 84#;
+ TokId happy_dollar_dollar -> cont 85#;
+ TokQId happy_dollar_dollar -> cont 86#;
+ TokString happy_dollar_dollar -> cont 87#;
+ TokLiteral happy_dollar_dollar -> cont 88#;
_ -> happyError' tk
})
-happyError_ 88# tk = happyError' tk
+happyError_ 89# tk = happyError' tk
happyError_ _ tk = happyError' tk
happyThen :: () => Parser a -> (a -> Parser b) -> Parser b
@@ -5286,17 +5321,17 @@ mkName (i, s) = do
unless (alternating xs) $ fail $ "a name cannot contain two consecutive underscores"
return $ Name (getRange i) xs
where
- isValidId Hole = return ()
- isValidId (Id y) = do
+ isValidId Hole = return ()
+ isValidId (Id y) = do
let x = rawNameToString y
case parse defaultParseFlags [0] (lexer return) x of
- ParseOk _ (TokId _) -> return ()
- _ -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"
+ ParseOk _ (TokId _) -> return ()
+ _ -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"
- -- we know that there are no two Ids in a row
- alternating (Hole : Hole : _) = False
- alternating (_ : xs) = alternating xs
- alternating [] = True
+ -- we know that there are no two Ids in a row
+ alternating (Hole : Hole : _) = False
+ alternating (_ : xs) = alternating xs
+ alternating [] = True
-- | Create a qualified name from a list of strings
mkQName :: [(Interval, String)] -> Parser QName
@@ -5311,8 +5346,8 @@ ensureUnqual q at Qual{} = parseError' (rStart $ getRange q) "Qualified name not a
-- | Match a particular name.
isName :: String -> (Interval, String) -> Parser ()
isName s (_,s')
- | s == s' = return ()
- | otherwise = fail $ "expected " ++ s ++ ", found " ++ s'
+ | s == s' = return ()
+ | otherwise = fail $ "expected " ++ s ++ ", found " ++ s'
-- | Build a forall pi (forall x y z -> ...)
forallPi :: [LamBinding] -> Expr -> Expr
@@ -5324,7 +5359,7 @@ tLet r = TypedBindings r . Common.Arg defaultArgInfo . TLet r
-- | Converts lambda bindings to typed bindings.
addType :: LamBinding -> TypedBindings
-addType (DomainFull b) = b
+addType (DomainFull b) = b
addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [x] $ Underscore r Nothing
where r = getRange x
@@ -5353,22 +5388,22 @@ mergeImportDirectives is = do
verifyImportDirective :: ImportDirective -> Parser ImportDirective
verifyImportDirective i =
case filter ((>1) . length)
- $ group
- $ sort xs
+ $ group
+ $ sort xs
of
- [] -> return i
- yss -> let Just pos = rStart $ getRange $ head $ concat yss in
+ [] -> return i
+ yss -> let Just pos = rStart $ getRange $ head $ concat yss in
parseErrorAt pos $
- "repeated name" ++ s ++ " in import directive: " ++
- concat (intersperse ", " $ map (show . head) yss)
- where
- s = case yss of
- [_] -> ""
- _ -> "s"
+ "Repeated name" ++ s ++ " in import directive: " ++
+ concat (intersperse ", " $ map (show . head) yss)
+ where
+ s = case yss of
+ [_] -> ""
+ _ -> "s"
where
- xs = names (usingOrHiding i) ++ map renFrom (renaming i)
- names (Using xs) = xs
- names (Hiding xs) = xs
+ xs = names (usingOrHiding i) ++ map renFrom (renaming i)
+ names (Using xs) = xs
+ names (Hiding xs) = xs
-- | Breaks up a string into substrings. Returns every maximal
-- subsequence of zero or more characters distinct from @'.'@.
@@ -5416,34 +5451,34 @@ validHaskellModuleName = all ok . splitOnDots
exprToLHS :: Expr -> Parser ([Expr] -> [Expr] -> LHS)
exprToLHS e = case e of
WithApp r e es -> LHS <$> exprToPattern e <*> mapM exprToPattern es
- _ -> LHS <$> exprToPattern e <*> return []
+ _ -> LHS <$> exprToPattern e <*> return []
-- | Turn an expression into a pattern. Fails if the expression is not a
-- valid pattern.
exprToPattern :: Expr -> Parser Pattern
exprToPattern e =
case e of
- Ident x -> return $ IdentP x
- App _ e1 e2 -> AppP <$> exprToPattern e1
- <*> T.mapM (T.mapM exprToPattern) e2
- Paren r e -> ParenP r
- <$> exprToPattern e
- Underscore r _ -> return $ WildP r
- Absurd r -> return $ AbsurdP r
- As r x e -> AsP r x <$> exprToPattern e
- Dot r (HiddenArg _ e) -> return $ HiddenP r $ fmap (DotP r) e
- Dot r e -> return $ DotP r e
- Lit l -> return $ LitP l
- HiddenArg r e -> HiddenP r <$> T.mapM exprToPattern e
- InstanceArg r e -> InstanceP r <$> T.mapM exprToPattern e
- RawApp r es -> RawAppP r <$> mapM exprToPattern es
+ Ident x -> return $ IdentP x
+ App _ e1 e2 -> AppP <$> exprToPattern e1
+ <*> T.mapM (T.mapM exprToPattern) e2
+ Paren r e -> ParenP r
+ <$> exprToPattern e
+ Underscore r _ -> return $ WildP r
+ Absurd r -> return $ AbsurdP r
+ As r x e -> AsP r x <$> exprToPattern e
+ Dot r (HiddenArg _ e) -> return $ HiddenP r $ fmap (DotP r) e
+ Dot r e -> return $ DotP r e
+ Lit l -> return $ LitP l
+ HiddenArg r e -> HiddenP r <$> T.mapM exprToPattern e
+ InstanceArg r e -> InstanceP r <$> T.mapM exprToPattern e
+ RawApp r es -> RawAppP r <$> mapM exprToPattern es
Quote r -> return $ QuoteP r
- _ ->
+ _ ->
let Just pos = rStart $ getRange e in
parseErrorAt pos $ "Not a valid pattern: " ++ show e
opAppExprToPattern :: OpApp Expr -> Parser Pattern
-opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "syntax binding lambda cannot appear in a pattern"
+opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern"
opAppExprToPattern (Ordinary e) = exprToPattern e
-- | Turn an expression into a name. Fails if the expression is not a
@@ -5489,6 +5524,7 @@ data RHSOrTypeSigs = JustRHS RHS
namesOfPattern :: Pattern -> Maybe [(C.ArgInfo, Name)]
namesOfPattern (IdentP (QName i)) = Just [(defaultArgInfo, i)]
+namesOfPattern (WildP r) = Just [(defaultArgInfo, C.noName r)]
namesOfPattern (DotP _ (Ident (QName i))) = Just [(setRelevance Irrelevant defaultArgInfo, i)]
namesOfPattern (RawAppP _ ps) = fmap concat $ mapM namesOfPattern ps
namesOfPattern _ = Nothing
@@ -5512,6 +5548,7 @@ tests = runTests "Agda.Syntax.Parser.Parser"
]
{-# LINE 1 "templates/GenericTemplate.hs" #-}
{-# LINE 1 "templates/GenericTemplate.hs" #-}
+{-# LINE 1 "<built-in>" #-}
{-# LINE 1 "<command-line>" #-}
{-# LINE 1 "templates/GenericTemplate.hs" #-}
-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
diff --git a/src/data/agda.sty b/src/data/agda.sty
index dd7fff4..be21d8f 100644
--- a/src/data/agda.sty
+++ b/src/data/agda.sty
@@ -286,28 +286,31 @@
\newcommand{\AgdaOperator} [1]{\AgdaFontStyle{\textcolor{AgdaOperator}{#1}}}
% NameKind commands.
+\newcommand{\AgdaNoSpaceMath}[1]
+ {\begingroup\thickmuskip=0mu\medmuskip=0mu#1\endgroup}
+
\newcommand{\AgdaBound}[1]
- {\AgdaBoundFontStyle{\textcolor{AgdaBound}{#1}}}
+ {\AgdaNoSpaceMath{\AgdaBoundFontStyle{\textcolor{AgdaBound}{#1}}}}
\newcommand{\AgdaInductiveConstructor}[1]
- {\AgdaFontStyle{\textcolor{AgdaInductiveConstructor}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaInductiveConstructor}{\AgdaLink{#1}}}}}
\newcommand{\AgdaCoinductiveConstructor}[1]
- {\AgdaFontStyle{\textcolor{AgdaCoinductiveConstructor}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaCoinductiveConstructor}{\AgdaLink{#1}}}}}
\newcommand{\AgdaDatatype}[1]
- {\AgdaFontStyle{\textcolor{AgdaDatatype}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaDatatype}{\AgdaLink{#1}}}}}
\newcommand{\AgdaField}[1]
- {\AgdaFontStyle{\textcolor{AgdaField}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaField}{\AgdaLink{#1}}}}}
\newcommand{\AgdaFunction}[1]
- {\AgdaFontStyle{\textcolor{AgdaFunction}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaFunction}{\AgdaLink{#1}}}}}
\newcommand{\AgdaModule}[1]
- {\AgdaFontStyle{\textcolor{AgdaModule}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaModule}{\AgdaLink{#1}}}}}
\newcommand{\AgdaPostulate}[1]
- {\AgdaFontStyle{\textcolor{AgdaPostulate}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaPostulate}{\AgdaLink{#1}}}}}
\newcommand{\AgdaPrimitive}[1]
- {\AgdaFontStyle{\textcolor{AgdaPrimitive}{#1}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaPrimitive}{#1}}}}
\newcommand{\AgdaRecord}[1]
- {\AgdaFontStyle{\textcolor{AgdaRecord}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaRecord}{\AgdaLink{#1}}}}}
\newcommand{\AgdaArgument}[1]
- {\AgdaFontStyle{\textcolor{AgdaArgument}{\AgdaLink{#1}}}}
+ {\AgdaNoSpaceMath{\AgdaFontStyle{\textcolor{AgdaArgument}{\AgdaLink{#1}}}}}
% Other aspect commands.
\newcommand{\AgdaDottedPattern} [1]{\textcolor{AgdaDottedPattern}{#1}}
diff --git a/src/data/emacs-mode/agda2-highlight.el b/src/data/emacs-mode/agda2-highlight.el
index 37dc105..2314530 100644
--- a/src/data/emacs-mode/agda2-highlight.el
+++ b/src/data/emacs-mode/agda2-highlight.el
@@ -59,8 +59,8 @@ If the face does not exist, then it is created first."
(defvar agda2-highlight-face-attributes-list
'(:family :width :height :weight :slant :foreground :background
- :inverse-video :stipple :underline :overline :strike-through
- :inherit :box :font)
+ :inverse-video :stipple :underline :overline :strike-through
+ :inherit :box :font)
"The attributes considered by `agda2-highlight-face-attributes'.")
(defun agda2-highlight-face-attributes (face)
@@ -133,61 +133,61 @@ Also sets the default value of VARIABLE to GROUP."
(agda2-highlight-typechecks-face
:foreground "black"
:background "light blue")))
- ((equal group 'default-faces)
+ ((equal group 'default-faces)
(list (cons 'agda2-highlight-keyword-face
- (agda2-highlight-face-attributes
- font-lock-keyword-face))
- (cons 'agda2-highlight-string-face
- (agda2-highlight-face-attributes
- font-lock-string-face))
- (cons 'agda2-highlight-number-face
- (agda2-highlight-face-attributes
- font-lock-constant-face))
- (cons 'agda2-highlight-symbol-face
- (agda2-highlight-face-attributes
- font-lock-keyword-face))
- (cons 'agda2-highlight-primitive-type-face
- (agda2-highlight-face-attributes
- font-lock-keyword-face))
- (cons 'agda2-highlight-bound-variable-face
- (agda2-highlight-face-attributes
- font-lock-variable-name-face))
- (cons 'agda2-highlight-inductive-constructor-face
- (agda2-highlight-face-attributes
- font-lock-type-face))
- (cons 'agda2-highlight-coinductive-constructor-face
- (agda2-highlight-face-attributes
- font-lock-type-face))
- (cons 'agda2-highlight-datatype-face
- (agda2-highlight-face-attributes
- font-lock-type-face))
- (cons 'agda2-highlight-field-face
- (agda2-highlight-face-attributes
- font-lock-variable-name-face))
- (cons 'agda2-highlight-function-face
- (agda2-highlight-face-attributes
- font-lock-function-name-face))
- (cons 'agda2-highlight-module-face
- (agda2-highlight-face-attributes
- font-lock-type-face))
- (cons 'agda2-highlight-postulate-face
- (agda2-highlight-face-attributes
- font-lock-type-face))
- (cons 'agda2-highlight-primitive-face
- (agda2-highlight-face-attributes
- font-lock-constant-face))
- (cons 'agda2-highlight-record-face
- (agda2-highlight-face-attributes
- font-lock-variable-name-face))
- (cons 'agda2-highlight-dotted-face
- (agda2-highlight-face-attributes
- font-lock-variable-name-face))
- (cons 'agda2-highlight-operator-face
- (agda2-highlight-face-attributes
- font-lock-function-name-face))
- (cons 'agda2-highlight-error-face
- (agda2-highlight-face-attributes
- font-lock-warning-face))
+ (agda2-highlight-face-attributes
+ font-lock-keyword-face))
+ (cons 'agda2-highlight-string-face
+ (agda2-highlight-face-attributes
+ font-lock-string-face))
+ (cons 'agda2-highlight-number-face
+ (agda2-highlight-face-attributes
+ font-lock-constant-face))
+ (cons 'agda2-highlight-symbol-face
+ (agda2-highlight-face-attributes
+ font-lock-keyword-face))
+ (cons 'agda2-highlight-primitive-type-face
+ (agda2-highlight-face-attributes
+ font-lock-keyword-face))
+ (cons 'agda2-highlight-bound-variable-face
+ (agda2-highlight-face-attributes
+ font-lock-variable-name-face))
+ (cons 'agda2-highlight-inductive-constructor-face
+ (agda2-highlight-face-attributes
+ font-lock-type-face))
+ (cons 'agda2-highlight-coinductive-constructor-face
+ (agda2-highlight-face-attributes
+ font-lock-type-face))
+ (cons 'agda2-highlight-datatype-face
+ (agda2-highlight-face-attributes
+ font-lock-type-face))
+ (cons 'agda2-highlight-field-face
+ (agda2-highlight-face-attributes
+ font-lock-variable-name-face))
+ (cons 'agda2-highlight-function-face
+ (agda2-highlight-face-attributes
+ font-lock-function-name-face))
+ (cons 'agda2-highlight-module-face
+ (agda2-highlight-face-attributes
+ font-lock-type-face))
+ (cons 'agda2-highlight-postulate-face
+ (agda2-highlight-face-attributes
+ font-lock-type-face))
+ (cons 'agda2-highlight-primitive-face
+ (agda2-highlight-face-attributes
+ font-lock-constant-face))
+ (cons 'agda2-highlight-record-face
+ (agda2-highlight-face-attributes
+ font-lock-variable-name-face))
+ (cons 'agda2-highlight-dotted-face
+ (agda2-highlight-face-attributes
+ font-lock-variable-name-face))
+ (cons 'agda2-highlight-operator-face
+ (agda2-highlight-face-attributes
+ font-lock-function-name-face))
+ (cons 'agda2-highlight-error-face
+ (agda2-highlight-face-attributes
+ font-lock-warning-face))
(cons 'agda2-highlight-typechecks-face
(agda2-highlight-face-attributes
font-lock-type-face))
diff --git a/src/data/emacs-mode/agda2-mode.el b/src/data/emacs-mode/agda2-mode.el
index 4f1c162..a9ac767 100644
--- a/src/data/emacs-mode/agda2-mode.el
+++ b/src/data/emacs-mode/agda2-mode.el
@@ -10,7 +10,7 @@
;;; Code:
-(defvar agda2-version "2.4.2"
+(defvar agda2-version "2.4.2.2"
"The version of the Agda mode.
Note that the same version of the Agda executable must be used.")
@@ -817,7 +817,7 @@ of new goals."
"Refine the pattern variables given in the goal.
Assumes that <clause> = {!<variables>!} is on one line."
(interactive)
- (agda2-goal-cmd "Cmd_make_case" "pattern variables to case"))
+ (agda2-goal-cmd "Cmd_make_case" "pattern variables to case (empty for split on result)"))
(defun agda2-make-case-action (newcls)
"Replace the line at point with new clauses NEWCLS and reload."
@@ -840,19 +840,19 @@ Assumes that <clause> = {!<variables>!} is on one line."
"Replace definition of extended lambda with new clauses NEWCLS and reload."
(agda2-forget-all-goals);; we reload later anyway.
(let* ((pmax (- (re-search-forward "\\([^!]}\\)\\|;") 1))
- (bracketCount 0)
- cl)
+ (bracketCount 0)
+ cl)
(re-search-backward "{!")
(while (and (not (equal (preceding-char) ?\;)) (>= bracketCount 0))
- (backward-char)
- (if (equal (preceding-char) ?}) (incf bracketCount))
- (if (equal (preceding-char) ?{) (decf bracketCount)))
+ (backward-char)
+ (if (equal (preceding-char) ?}) (incf bracketCount))
+ (if (equal (preceding-char) ?{) (decf bracketCount)))
(let ((p (point)))
(delete-region (point) pmax)
(insert " ")
(while (setq cl (pop newcls))
- (insert cl)
- (if newcls (insert " ; ")))
+ (insert cl)
+ (if newcls (insert " ; ")))
(insert " ")
(goto-char p)))
(agda2-load))
diff --git a/src/full/Agda/Auto/Auto.hs b/src/full/Agda/Auto/Auto.hs
index 2e15192..d18b0ff 100644
--- a/src/full/Agda/Auto/Auto.hs
+++ b/src/full/Agda/Auto/Auto.hs
@@ -1,16 +1,18 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Auto.Auto (auto) where
-import Control.Monad.Error
+import Prelude hiding (null)
+
import Control.Monad.State
-import Data.List
+import Data.List hiding (null)
import qualified Data.Map as Map
import Data.IORef
import qualified System.Timeout
-import Data.Maybe (catMaybes, isNothing)
-import Data.Tuple (swap)
+import Data.Maybe
import Data.Functor
+import qualified Data.Traversable as Trav
import Agda.Utils.Permutation (permute, takeP)
import Agda.TypeChecking.Monad.Base
@@ -28,10 +30,10 @@ import Agda.Syntax.Translation.AbstractToConcrete (abstractToConcreteEnv, abstra
import Agda.Interaction.BasicOps hiding (refine)
import Agda.TypeChecking.Reduce (normalise)
import Agda.Syntax.Common
-import qualified Agda.Syntax.Scope.Base
+import qualified Agda.Syntax.Scope.Base as Scope
import Agda.Syntax.Scope.Monad (withCurrentModule)
import qualified Agda.Syntax.Abstract.Name as AN
-import qualified Agda.TypeChecking.Monad.Base as MB
+import qualified Agda.TypeChecking.Monad.Base as TCM
import Agda.TypeChecking.EtaContract (etaContract)
import qualified Agda.Utils.HashMap as HMap
@@ -43,8 +45,15 @@ import Agda.Auto.Typecheck
import Agda.Auto.CaseSplit
-#include "../undefined.h"
+import Agda.Utils.Except ( runExceptT, MonadError(catchError) )
+import Agda.Utils.Functor
import Agda.Utils.Impossible
+import Agda.Utils.Lens
+import Agda.Utils.Maybe
+import Agda.Utils.Null
+import Agda.Utils.Tuple
+
+#include "undefined.h"
insertAbsurdPattern :: String -> String
insertAbsurdPattern [] = []
@@ -54,9 +63,14 @@ insertAbsurdPattern (c:s) = c : insertAbsurdPattern s
getName :: A.Expr -> Maybe (Bool, I.QName)
getName (A.ScopedExpr _ e) = getName e
getName (A.Def qname) = Just (False, qname)
+getName (A.Proj qname) = Just (False, qname)
getName (A.Con qname) = Just (True, head $ I.unAmbQ qname)
getName _ = Nothing
+dispmsg :: String ->
+ TCM (Either [(InteractionId, String)]
+ (Either [String] String)
+ , Maybe String)
dispmsg msg = return (Left [], Just msg)
-- | Entry point for Auto tactic (Agsy).
@@ -78,351 +92,353 @@ dispmsg msg = return (Left [], Just msg)
-- 3. @Right (Right s)@
-- A refinement for the interaction id @ii@ in which Auto was invoked.
-auto :: InteractionId -> Range -> String -> TCM (Either [(InteractionId, String)] (Either [String] String), Maybe String)
-auto ii rng argstr = liftTCM $ do
- let (hints, timeout, pick, mode, hintmode) = parseargs argstr
- ahints <- mapM (parseExprIn ii rng) (case mode of {MRefine{} -> []; _ -> hints})
-
- eqstuff <- liftM (maybe Nothing (mapM getName)) $
- catchError (liftM Just $ mapM (parseExprIn ii rng) ["_≡_", "begin_", "_≡⟨_⟩_", "_∎", "sym", "cong"]) (\_ -> return Nothing)
-
- case mapM getName ahints of
- Nothing -> dispmsg "Hints must be a list of constant names"
- Just ehints -> do
- mi <- lookupInteractionId ii
- --thisdefinfo <- catchError (liftM Just $ findClause mi) (\_ -> return Nothing)
- thisdefinfo <- findClauseDeep mi
- ehints <- liftM (ehints ++) $ autohints hintmode mi (case thisdefinfo of {Just (def, _, _) -> Just def; Nothing -> Nothing})
- mrectyp <- case thisdefinfo of
- Nothing -> return []
- Just (def, _, _) -> do
- recdef <- getConstInfo def
- let rectyp = MB.defType recdef
- rectyp <- normalise rectyp
- return [rectyp]
-
- let ehints' = ehints ++ maybe [] id eqstuff
-
-
- (myhints', mymrectyp, tccons, eqcons, cmap) <- tomy mi ehints' mrectyp
-
- let myhints = take (length myhints' - (length ehints' - length ehints)) myhints'
- meqr = case eqstuff of
- Nothing -> Nothing
- Just _ -> let [c1, c2, c3, c4, c5, c6] = drop (length myhints' - (length ehints' - length ehints)) myhints'
- in Just $ EqReasoningConsts c1 c2 c3 c4 c5 c6
-
-
- let tcSearchSC isdep ctx typ trm =
-
- (case meqr of
- Nothing -> id
- Just eqr -> mpret . Sidecondition (calcEqRState eqr trm)
- )
-
- (tcSearch isdep ctx typ trm)
- let (mainm, _, _, _) = tccons Map.! mi
- case mode of
- MNormal listmode disprove -> do
- sols <- liftIO $ newIORef ([] :: [[I.Term]])
- nsol <- liftIO $ newIORef (if listmode then (pick + 10) else (pick + 1))
- let hsol =
-
-
- if listmode then do
- nsol' <- readIORef nsol
- when (nsol' <= 10) $ runErrorT (mapM (\(m, _, _, _) -> frommy (Meta m)) (Map.elems tccons)) >>= \trms -> case trms of {Left{} -> writeIORef nsol $! nsol' + 1; Right trms -> modifyIORef sols (trms :)}
- else do
- nsol' <- readIORef nsol
- when (nsol' == 1) $ runErrorT (mapM (\(m, _, _, _) -> frommy (Meta m)) (Map.elems tccons)) >>= \trms -> case trms of {Left{} -> writeIORef nsol $! nsol' + 1; Right trms -> writeIORef sols [trms]}
- ticks <- liftIO $ newIORef 0
- let exsearch initprop recinfo defdfv = liftIO $ System.Timeout.timeout (timeout * 1000000) (
- let r d = do
- let rechint x = case recinfo of
- Nothing -> x
- Just (_, recdef) -> (recdef, HMRecCall) : x
- env = RIEnv {rieHints = rechint $ map (\x -> (x, HMNormal)) myhints,
- rieDefFreeVars = defdfv
-
- , rieEqReasoningConsts = meqr
-
- }
- depreached <- topSearch ticks nsol hsol env (initprop) d costIncrease
- nsol' <- readIORef nsol
- if nsol' /= 0 && depreached then
- r (d + costIncrease)
- else
- return depreached
- in r 0)
- let getsols sol = do
- exprs <- mapM (\(mi, e) -> do
- mv <- lookupMeta mi
- e <- etaContract e
- expr <- liftM modifyAbstractExpr $ withMetaInfo (getMetaInfo mv) $ reify e
- return (mi, expr)
- ) (zip (Map.keys tccons) sol)
- let r :: I.MetaId -> StateT [I.MetaId] TCM [(I.MetaId, A.Expr)]
- r midx = do
- let (m, _, _, deps) = tccons Map.! midx
- asolss <- mapM r deps
- dones <- get
- asols <- if (midx `notElem` dones) then do
- put (midx : dones)
- return [(midx, let Just e = lookup midx exprs in e)]
- else
- return []
- return $ concat asolss ++ asols
- (asols, _) <- runStateT (r mi) []
- return asols
- if disprove then
- case eqcons of
- [] -> case Map.elems tccons of
- (m, mytype, mylocalVars, _) : [] -> do
- defdfv <- case thisdefinfo of
- Just (def, _, _) -> getdfv mi def
- Nothing -> return 0
- ee <- liftIO $ newIORef $ ConstDef {cdname = "T", cdorigin = __IMPOSSIBLE__, cdtype = NotM $ Sort (Set 0), cdcont = Postulate, cddeffreevars = 0}
- let modargs = drop (length mylocalVars - defdfv) mylocalVars
- restargs = take (length mylocalVars - defdfv) mylocalVars
- mytype' = foldl (\x y -> NotM $ Pi Nothing Agda.Auto.Syntax.NotHidden (freeIn 0 y) y (Abs NoId x)) mytype restargs
- htyp = negtype ee mytype'
- sctx = (Id "h", closify htyp) : map (\x -> (NoId, closify x)) modargs
- ntt = closify (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil))
- res <- exsearch (tcSearchSC False sctx ntt (Meta m)) Nothing defdfv
- rsols <- liftM reverse $ liftIO $ readIORef sols
- if null rsols then do
- nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + (if listmode then 10 else 1) - nsol')
- else do
- aexprss <- mapM getsols rsols
- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss
- let ss = dropWhile (== ' ') . dropWhile (/= ' ') . show
- disp [(_, cexpr)] = ss cexpr
- disp cexprs = concat (map (\(mi, cexpr) -> ss cexpr ++ " ") cexprs)
- ticks <- liftIO $ readIORef ticks
- dispmsg $ "Listing disproof(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++
-
-
- "\n" ++ unlines (map (\(x, y) -> show y ++ " " ++ disp x) $ zip cexprss [pick..])
- _ -> dispmsg "Metavariable dependencies not allowed in disprove mode"
- _ -> dispmsg "Metavariable dependencies not allowed in disprove mode"
- else do
- (recinfo, defdfv) <-
- case thisdefinfo of
- Just (def, clause, _) -> do
- let [rectyp'] = mymrectyp
- defdfv <- getdfv mi def
- myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv}
- (_, pats) <- constructPats cmap mi clause
- defdfv <- getdfv mi def
- return $ if contains_constructor pats then
- (Just (pats, myrecdef), defdfv)
- else
- (Nothing, defdfv)
- Nothing -> return (Nothing, 0)
- let tc (m, mytype, mylocalVars) isdep = tcSearchSC isdep (map (\x -> (NoId, closify x)) mylocalVars) (closify mytype) (Meta m)
- initprop =
- foldl (\x (ineq, e, i) -> mpret $ And Nothing x (comp' ineq (closify e) (closify i)))
- (foldl (\x (m, mt, mlv, _) ->
- if hequalMetavar m mainm then
- case recinfo of
- Just (recpats, recdef) ->
- mpret $ Sidecondition (localTerminationSidecond (localTerminationEnv recpats) recdef (Meta m))
- (tc (m, mt, mlv) False)
- Nothing -> mpret $ And Nothing x (tc (m, mt, mlv) False)
- else
- mpret $ And Nothing x (tc (m, mt, mlv) True)
- )
- (mpret OK)
- (Map.elems tccons)
- ) eqcons
- res <- exsearch initprop recinfo defdfv
- riis <- map swap <$> getInteractionIdsAndMetas
- let timeoutString | isNothing res = " after timeout (" ++ show timeout ++ "s)"
- | otherwise = ""
- if listmode then do
- rsols <- liftM reverse $ liftIO $ readIORef sols
- if null rsols then do
- nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + 10 - nsol') ++ timeoutString
- else do
- aexprss <- mapM getsols rsols
- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss
- let disp [(_, cexpr)] = show cexpr
- disp cexprs = concat (map (\(mi, cexpr) -> case lookup mi riis of {Nothing -> show mi; Just ii -> show ii} ++ " := " ++ show cexpr ++ " ") cexprs)
- ticks <- liftIO $ readIORef ticks
- dispmsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++
- "\n" ++ unlines (map (\(x, y) -> show y ++ " " ++ disp x) $ zip cexprss [pick..])
- else
- case res of
- Nothing -> do
- nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + 1 - nsol') ++ timeoutString
- Just depthreached -> do
- ticks <- liftIO $ readIORef ticks
- rsols <- liftIO $ readIORef sols
- case rsols of
- [] -> do
- nsol' <- liftIO $ readIORef nsol
- dispmsg $ insuffsols (pick + 1 - nsol')
- (term : _) -> do
- exprs <- getsols term
- giveress <-
- mapM (\(mi, expr) ->
- case lookup mi riis of
- Nothing ->
- catchError
- (giveExpr mi expr >>= \_ -> return (Nothing, Nothing))
- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))
- Just ii' -> do ae <- give ii' Nothing expr
- mv <- lookupMeta mi
- let scope = getMetaScope mv
- ce <- abstractToConcreteEnv (makeEnv scope) ae
- let cmnt = if ii' == ii then agsyinfo ticks else ""
- return (Just (ii', show ce ++ cmnt), Nothing)
- ) exprs
- let msg = if length exprs == 1 then
- Nothing
- else
- Just $ "Also gave solution(s) for hole(s)" ++
- concatMap (\(mi', _) ->
- if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii})
- ) exprs
- let msgs = catMaybes $ msg : map snd giveress
- msg' = case msgs of
- [] -> Nothing
- _ -> Just $ unlines msgs
- return (Left $ catMaybes $ map fst giveress, msg')
-
- MCaseSplit -> do
- case thisdefinfo of
- Just (def, clause, True) ->
- case Map.elems tccons of
- ((m, mytype, mylocalVars, _) : []) | null eqcons -> do
-
-
- (ids, pats) <- constructPats cmap mi clause
- let ctx = map (\((hid, id), t) -> HI hid (id, t)) (zip ids mylocalVars)
- ticks <- liftIO $ newIORef 0
- let [rectyp'] = mymrectyp
- defdfv <- getdfv mi def
- myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv}
- sols <- liftIO $ System.Timeout.timeout (timeout * 1000000) (
- let r d = do
- sols <- liftIO $ caseSplitSearch ticks __IMPOSSIBLE__ myhints meqr __IMPOSSIBLE__ d myrecdef ctx mytype pats
- case sols of
- [] -> r (d + costIncrease)
- (_:_) -> return sols
- in r 0)
- case sols of
- Just (cls : _) -> withInteractionId ii $ do
- cls' <- liftIO $ runErrorT (mapM frommyClause cls)
- case cls' of
- Left{} -> dispmsg "No solution found"
- Right cls' -> do
- cls'' <- forM cls' $ \ (I.Clause _ tel perm ps body t) -> do
- withCurrentModule (AN.qnameModule def) $ do
- -- Normalise the dot patterns
- ps <- addCtxTel tel $ normalise ps
- body <- etaContractBody body
- liftM modifyAbstractClause $ inContext [] $ reify $ AN.QNamed def $ I.Clause noRange tel perm ps body t
- pcs <- withInteractionId ii $ mapM prettyA cls''
- ticks <- liftIO $ readIORef ticks
-
-
- return (Right $ Left (map (insertAbsurdPattern . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode })) pcs), Nothing)
-
- Just [] -> dispmsg "No solution found" -- case not possible at the moment because case split doesnt care about search exhaustiveness
- Nothing -> dispmsg $ "No solution found at time out (" ++ show timeout ++ "s)"
- _ -> dispmsg "Metavariable dependencies not allowed in case split mode"
- _ -> dispmsg "Metavariable is not at top level of clause RHS"
-
- MRefine listmode -> do
- mv <- lookupMeta mi
- let tt = jMetaType $ mvJudgement mv
- minfo = getMetaInfo mv
- targettyp <- withMetaInfo minfo $ do
- vs <- getContextArgs
- let targettype = tt `piApply` permute (takeP (length vs) $ mvPermutation mv) vs
- normalise targettype
- let tctx = length $ envContext $ clEnv minfo
-
- hits <- if elem "-a" hints then do
- st <- liftTCM $ join $ pureTCM $ \st _ -> return st
- let defs = sigDefinitions $ stSignature st
- idefs = sigDefinitions $ stImports st
- alldefs = HMap.keys defs ++ HMap.keys idefs
- liftM catMaybes $ mapM (\n ->
- case thisdefinfo of
- Just (def, _, _) | def == n -> return Nothing
- _ -> do
- cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n
- if head (show cn) == '.' then -- not in scope
- return Nothing
- else do
- c <- getConstInfo n
- ctyp <- normalise $ defType c
- cdfv <- withMetaInfo minfo $ getDefFreeVars n
- return $ case matchType cdfv tctx ctyp targettyp of
- Nothing -> Nothing
- Just score -> Just (show cn, score)
- ) alldefs
- else do
- let scopeinfo = clScope (getMetaInfo mv)
- namespace = Agda.Syntax.Scope.Base.everythingInScope scopeinfo
- names = Agda.Syntax.Scope.Base.nsNames namespace
- qnames = map (\(x, y) -> (x, Agda.Syntax.Scope.Base.anameName $ head y)) $ Map.toList names
- modnames = case thisdefinfo of
- Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames
- Nothing -> qnames
- liftM catMaybes $ mapM (\(cn, n) -> do
- c <- getConstInfo n
- ctyp <- normalise $ defType c
- cdfv <- withMetaInfo minfo $ getDefFreeVars n
- return $ case matchType cdfv tctx ctyp targettyp of
- Nothing -> Nothing
- Just score -> Just (show cn, score)
- ) modnames
-
- let sorthits = sortBy (\(_, (pa1, pb1)) (_, (pa2, pb2)) -> case compare pa2 pa1 of {EQ -> compare pb1 pb2; o -> o}) hits
- if listmode || pick == (-1) then
- let pick' = max 0 pick
- in if pick' >= length sorthits then
- dispmsg $ insuffcands $ length sorthits
- else
- let showhits = take 10 $ drop pick' sorthits
- in dispmsg $ "Listing candidate(s) " ++ show pick' ++ "-" ++ show (pick' + length showhits - 1) ++ " (found " ++ show (length sorthits) ++ " in total)\n" ++
- unlines (map (\(i, (cn, _)) -> show i ++ " " ++ cn) (zip [pick'..pick' + length showhits - 1] showhits))
- else
- if pick >= length sorthits then
- dispmsg $ insuffcands $ length sorthits
- else
- return (Right $ Right (fst $ sorthits !! pick), Nothing)
- where
-
-
- agsyinfo ticks = ""
+auto
+ :: InteractionId
+ -> Range
+ -> String
+ -> TCM ( Either [(InteractionId, String)]
+ (Either [String] String)
+ , Maybe String)
+auto ii rng argstr = do
+
+ -- Parse hints and other configuration.
+ let (hints, timeout, pick, mode, hintmode) = parseargs argstr
+ ahints <- case mode of
+ MRefine{} -> return []
+ _ -> mapM (parseExprIn ii rng) hints
+ let failHints = dispmsg "Hints must be a list of constant names"
+ caseMaybe (mapM getName ahints) failHints $ \ ehints -> do
+
+ -- Get names for equality reasoning.
+ -- @eqstuff == []@ if any of these names is not defined.
+ eqstuffExprs <- mapM (parseExprIn ii rng) ["_≡_", "begin_", "_≡⟨_⟩_", "_∎", "sym", "cong"]
+ `catchError`
+ (\_ -> return [])
+ let eqstuff = fromMaybe [] $ mapM getName eqstuffExprs
+
+ -- Get the meta variable for the interaction point we are trying to fill.
+ -- Add the @autohints@ for that meta to the hints collection.
+ mi <- lookupInteractionId ii
+ --thisdefinfo <- catchError (liftM Just $ findClause mi) (\_ -> return Nothing)
+ thisdefinfo <- findClauseDeep mi
+ ehints <- (ehints ++) <$> do autohints hintmode mi $ fmap fst3 thisdefinfo
+
+ -- If @thisdefinfo /= Nothing@ get the its type (normalized).
+ mrectyp <- maybeToList <$> do
+ Trav.forM thisdefinfo $ \ (def, _, _) -> do
+ normalise =<< do TCM.defType <$> getConstInfo def
+
+ (myhints', mymrectyp, tccons, eqcons, cmap) <- tomy mi (ehints ++ eqstuff) mrectyp
+
+ let (myhints, c1to6) = splitAt (length myhints' - length eqstuff) myhints'
+ meqr = ifNull eqstuff Nothing $ \ _ -> {- else -}
+ let [c1, c2, c3, c4, c5, c6] = c1to6
+ in Just $ EqReasoningConsts c1 c2 c3 c4 c5 c6
+
+
+ let tcSearchSC isdep ctx typ trm = caseMaybe meqr a $ \ eqr ->
+ mpret $ Sidecondition (calcEqRState eqr trm) a
+ where a = tcSearch isdep ctx typ trm
+
+ let (mainm, _, _, _) = tccons Map.! mi
+ case mode of
+ MNormal listmode disprove -> do
+ sols <- liftIO $ newIORef ([] :: [[I.Term]])
+ nsol <- liftIO $ newIORef $ if listmode then pick + 10 else pick + 1
+ let hsol = do
+ nsol' <- readIORef nsol
+ let cond = if listmode then nsol' <= 10 else nsol' == 1
+ when cond $ do
+ trms <- runExceptT $ mapM (\ (m, _, _, _) -> frommy (Meta m)) $ Map.elems tccons
+ case trms of
+ Left{} -> writeIORef nsol $! nsol' + 1
+ Right trms -> if listmode then modifyIORef sols (trms :)
+ else writeIORef sols [trms]
+ ticks <- liftIO $ newIORef 0
+
+ let exsearch initprop recinfo defdfv =
+ liftIO $ System.Timeout.timeout (timeout * 1000000) $ loop 0
+ where
+ loop d = do
+ let rechint x = case recinfo of
+ Nothing -> x
+ Just (_, recdef) -> (recdef, HMRecCall) : x
+ env = RIEnv { rieHints = rechint $ map (,HMNormal) myhints
+ , rieDefFreeVars = defdfv
+ , rieEqReasoningConsts = meqr
+ }
+ depreached <- topSearch ticks nsol hsol env (initprop) d costIncrease
+ nsol' <- readIORef nsol
+ if nsol' /= 0 && depreached then loop (d + costIncrease) else return depreached
+
+ let getsols sol = do
+ exprs <- forM (zip (Map.keys tccons) sol) $ \ (mi, e) -> do
+ mv <- lookupMeta mi
+ e <- etaContract e
+ expr <- modifyAbstractExpr <$> do withMetaInfo (getMetaInfo mv) $ reify e
+ return (mi, expr)
+
+ let loop :: I.MetaId -> StateT [I.MetaId] TCM [(I.MetaId, A.Expr)]
+ loop midx = do
+ let (m, _, _, deps) = tccons Map.! midx
+ asolss <- mapM loop deps
+ dones <- get
+ asols <- if midx `elem` dones then return [] else do
+ put (midx : dones)
+ return [(midx, fromMaybe __IMPOSSIBLE__ $ lookup midx exprs)]
+ return $ concat asolss ++ asols
+ (asols, _) <- runStateT (loop mi) []
+ return asols
+
+ if disprove then
+ case eqcons of
+ [] -> case Map.elems tccons of
+ (m, mytype, mylocalVars, _) : [] -> do
+ defdfv <- case thisdefinfo of
+ Just (def, _, _) -> getdfv mi def
+ Nothing -> return 0
+ ee <- liftIO $ newIORef $ ConstDef {cdname = "T", cdorigin = __IMPOSSIBLE__, cdtype = NotM $ Sort (Set 0), cdcont = Postulate, cddeffreevars = 0}
+ let (restargs, modargs) = splitAt (length mylocalVars - defdfv) mylocalVars
+ mytype' = foldl (\x y -> NotM $ Pi Nothing Agda.Auto.Syntax.NotHidden (freeIn 0 y) y (Abs NoId x)) mytype restargs
+ htyp = negtype ee mytype'
+ sctx = (Id "h", closify htyp) : map (\x -> (NoId, closify x)) modargs
+ ntt = closify (NotM $ App Nothing (NotM OKVal) (Const ee) (NotM ALNil))
+ res <- exsearch (tcSearchSC False sctx ntt (Meta m)) Nothing defdfv
+ rsols <- liftM reverse $ liftIO $ readIORef sols
+ if null rsols then do
+ nsol' <- liftIO $ readIORef nsol
+ dispmsg $ insuffsols (pick + (if listmode then 10 else 1) - nsol')
+ else do
+ aexprss <- mapM getsols rsols
+ cexprss <- forM aexprss $ mapM $ \(mi, e) -> do
+ mv <- lookupMeta mi
+ withMetaInfo (getMetaInfo mv) $ do
+ (mi,) <$> abstractToConcrete_ e
+ let ss = dropWhile (== ' ') . dropWhile (/= ' ') . show
+ disp [(_, cexpr)] = ss cexpr
+ disp cexprs = concat $ map (\ (mi, cexpr) -> ss cexpr ++ " ") cexprs
+ ticks <- liftIO $ readIORef ticks
+ dispmsg $ unlines $
+ ("Listing disproof(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1)) :
+ for (zip cexprss [pick..]) (\ (x, y) -> show y ++ " " ++ disp x)
+ _ -> dispmsg "Metavariable dependencies not allowed in disprove mode"
+ _ -> dispmsg "Metavariable dependencies not allowed in disprove mode"
+ else do
+ (recinfo, defdfv) <-
+ case thisdefinfo of
+ Just (def, clause, _) -> do
+ let [rectyp'] = mymrectyp
+ defdfv <- getdfv mi def
+ myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv}
+ (_, pats) <- constructPats cmap mi clause
+ defdfv <- getdfv mi def
+ return $ if contains_constructor pats then
+ (Just (pats, myrecdef), defdfv)
+ else
+ (Nothing, defdfv)
+ Nothing -> return (Nothing, 0)
+ let tc (m, mytype, mylocalVars) isdep = tcSearchSC isdep (map (\x -> (NoId, closify x)) mylocalVars) (closify mytype) (Meta m)
+ initprop =
+ foldl (\x (ineq, e, i) -> mpret $ And Nothing x (comp' ineq (closify e) (closify i)))
+ (foldl (\x (m, mt, mlv, _) ->
+ if hequalMetavar m mainm then
+ case recinfo of
+ Just (recpats, recdef) ->
+ mpret $ Sidecondition (localTerminationSidecond (localTerminationEnv recpats) recdef (Meta m))
+ (tc (m, mt, mlv) False)
+ Nothing -> mpret $ And Nothing x (tc (m, mt, mlv) False)
+ else
+ mpret $ And Nothing x (tc (m, mt, mlv) True)
+ )
+ (mpret OK)
+ (Map.elems tccons)
+ ) eqcons
+ res <- exsearch initprop recinfo defdfv
+ riis <- map swap <$> getInteractionIdsAndMetas
+ let timeoutString | isNothing res = " after timeout (" ++ show timeout ++ "s)"
+ | otherwise = ""
+ if listmode then do
+ rsols <- liftM reverse $ liftIO $ readIORef sols
+ if null rsols then do
+ nsol' <- liftIO $ readIORef nsol
+ dispmsg $ insuffsols (pick + 10 - nsol') ++ timeoutString
+ else do
+ aexprss <- mapM getsols rsols
+ cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss
+ let disp [(_, cexpr)] = show cexpr
+ disp cexprs = concat (map (\(mi, cexpr) -> case lookup mi riis of {Nothing -> show mi; Just ii -> show ii} ++ " := " ++ show cexpr ++ " ") cexprs)
+ ticks <- liftIO $ readIORef ticks
+ dispmsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++
+ "\n" ++ unlines (map (\(x, y) -> show y ++ " " ++ disp x) $ zip cexprss [pick..])
+ else
+ case res of
+ Nothing -> do
+ nsol' <- liftIO $ readIORef nsol
+ dispmsg $ insuffsols (pick + 1 - nsol') ++ timeoutString
+ Just depthreached -> do
+ ticks <- liftIO $ readIORef ticks
+ rsols <- liftIO $ readIORef sols
+ case rsols of
+ [] -> do
+ nsol' <- liftIO $ readIORef nsol
+ dispmsg $ insuffsols (pick + 1 - nsol')
+ (term : _) -> do
+ exprs <- getsols term
+ giveress <-
+ mapM (\(mi, expr) ->
+ case lookup mi riis of
+ Nothing ->
+ catchError
+ (giveExpr mi expr >>= \_ -> return (Nothing, Nothing))
+ (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))
+ Just ii' -> do ae <- give ii' Nothing expr
+ mv <- lookupMeta mi
+ let scope = getMetaScope mv
+ ce <- abstractToConcreteEnv (makeEnv scope) ae
+ let cmnt = if ii' == ii then agsyinfo ticks else ""
+ return (Just (ii', show ce ++ cmnt), Nothing)
+ ) exprs
+ let msg = if length exprs == 1 then
+ Nothing
+ else
+ Just $ "Also gave solution(s) for hole(s)" ++
+ concatMap (\(mi', _) ->
+ if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii})
+ ) exprs
+ let msgs = catMaybes $ msg : map snd giveress
+ msg' = case msgs of
+ [] -> Nothing
+ _ -> Just $ unlines msgs
+ return (Left $ catMaybes $ map fst giveress, msg')
+
+ MCaseSplit -> do
+ case thisdefinfo of
+ Just (def, clause, True) ->
+ case Map.elems tccons of
+ [(m, mytype, mylocalVars, _)] | null eqcons -> do
+ (ids, pats) <- constructPats cmap mi clause
+ let ctx = map (\((hid, id), t) -> HI hid (id, t)) (zip ids mylocalVars)
+ ticks <- liftIO $ newIORef 0
+ let [rectyp'] = mymrectyp
+ defdfv <- getdfv mi def
+ myrecdef <- liftIO $ newIORef $ ConstDef {cdname = "", cdorigin = (Nothing, def), cdtype = rectyp', cdcont = Postulate, cddeffreevars = defdfv}
+ sols <- liftIO $ System.Timeout.timeout (timeout * 1000000) (
+ let r d = do
+ sols <- liftIO $ caseSplitSearch ticks __IMPOSSIBLE__ myhints meqr __IMPOSSIBLE__ d myrecdef ctx mytype pats
+ case sols of
+ [] -> r (d + costIncrease)
+ (_:_) -> return sols
+ in r 0)
+ case sols of
+ Just (cls : _) -> withInteractionId ii $ do
+ cls' <- liftIO $ runExceptT (mapM frommyClause cls)
+ case cls' of
+ Left{} -> dispmsg "No solution found"
+ Right cls' -> do
+ cls'' <- forM cls' $ \ (I.Clause _ tel perm ps body t) -> do
+ withCurrentModule (AN.qnameModule def) $ do
+ -- Normalise the dot patterns
+ ps <- addCtxTel tel $ normalise ps
+ body <- etaContractBody body
+ liftM modifyAbstractClause $ inContext [] $ reify $ AN.QNamed def $ I.Clause noRange tel perm ps body t
+ pcs <- withInteractionId ii $ mapM prettyA cls''
+ ticks <- liftIO $ readIORef ticks
+
+
+ return (Right $ Left (map (insertAbsurdPattern . PP.renderStyle (PP.style { PP.mode = PP.OneLineMode })) pcs), Nothing)
+
+ Just [] -> dispmsg "No solution found" -- case not possible at the moment because case split doesnt care about search exhaustiveness
+ Nothing -> dispmsg $ "No solution found at time out (" ++ show timeout ++ "s)"
+ _ -> dispmsg "Metavariable dependencies not allowed in case split mode"
+ _ -> dispmsg "Metavariable is not at top level of clause RHS"
+
+ MRefine listmode -> do
+ mv <- lookupMeta mi
+ let tt = jMetaType $ mvJudgement mv
+ minfo = getMetaInfo mv
+ targettyp <- withMetaInfo minfo $ do
+ vs <- getContextArgs
+ let targettype = tt `piApply` permute (takeP (length vs) $ mvPermutation mv) vs
+ normalise targettype
+ let tctx = length $ envContext $ clEnv minfo
+
+ hits <- if elem "-a" hints then do
+ st <- liftTCM $ join $ pureTCM $ \st _ -> return st
+ let defs = sigDefinitions $ st^.stSignature
+ idefs = sigDefinitions $ st^.stImports
+ alldefs = HMap.keys defs ++ HMap.keys idefs
+ liftM catMaybes $ mapM (\n ->
+ case thisdefinfo of
+ Just (def, _, _) | def == n -> return Nothing
+ _ -> do
+ cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n
+ if head (show cn) == '.' then -- not in scope
+ return Nothing
+ else do
+ c <- getConstInfo n
+ ctyp <- normalise $ defType c
+ cdfv <- withMetaInfo minfo $ getDefFreeVars n
+ return $ case matchType cdfv tctx ctyp targettyp of
+ Nothing -> Nothing
+ Just score -> Just (show cn, score)
+ ) alldefs
+ else do
+ let scopeinfo = clScope (getMetaInfo mv)
+ namespace = Scope.everythingInScope scopeinfo
+ names = Scope.nsNames namespace
+ qnames = map (\(x, y) -> (x, Scope.anameName $ head y)) $ Map.toList names
+ modnames = case thisdefinfo of
+ Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames
+ Nothing -> qnames
+ liftM catMaybes $ mapM (\(cn, n) -> do
+ c <- getConstInfo n
+ ctyp <- normalise $ defType c
+ cdfv <- withMetaInfo minfo $ getDefFreeVars n
+ return $ case matchType cdfv tctx ctyp targettyp of
+ Nothing -> Nothing
+ Just score -> Just (show cn, score)
+ ) modnames
+
+ let sorthits = sortBy (\(_, (pa1, pb1)) (_, (pa2, pb2)) -> case compare pa2 pa1 of {EQ -> compare pb1 pb2; o -> o}) hits
+ if listmode || pick == (-1) then
+ let pick' = max 0 pick
+ in if pick' >= length sorthits then
+ dispmsg $ insuffcands $ length sorthits
+ else
+ let showhits = take 10 $ drop pick' sorthits
+ in dispmsg $ "Listing candidate(s) " ++ show pick' ++ "-" ++ show (pick' + length showhits - 1) ++ " (found " ++ show (length sorthits) ++ " in total)\n" ++
+ unlines (map (\(i, (cn, _)) -> show i ++ " " ++ cn) (zip [pick'..pick' + length showhits - 1] showhits))
+ else
+ if pick >= length sorthits then
+ dispmsg $ insuffcands $ length sorthits
+ else
+ return (Right $ Right (fst $ sorthits !! pick), Nothing)
+ where
+ agsyinfo ticks = ""
+
+-- Get the functions and axioms defined in the same module as @def at .
+autohints :: AutoHintMode -> I.MetaId -> Maybe AN.QName ->
+ TCM [(Bool, AN.QName)]
autohints AHMModule mi (Just def) = do
- mv <- lookupMeta mi
- let scopeinfo = clScope (getMetaInfo mv)
- namespace = Agda.Syntax.Scope.Base.everythingInScope scopeinfo
- names = Agda.Syntax.Scope.Base.nsNames namespace
- qnames = map (Agda.Syntax.Scope.Base.anameName . head) $ Map.elems names
- modnames = filter (\n -> AN.qnameModule n == AN.qnameModule def && n /= def) qnames
- modnames' <- filterM (\n -> do
- c <- getConstInfo n
- return (case theDef c of
- Axiom{} -> True
- Function{} -> True
- _ -> False
- )
- ) modnames
- return $ map (\x -> (False, x)) modnames'
+ scope <- clScope . getMetaInfo <$> lookupMeta mi
+ let names = Scope.nsNames $ Scope.everythingInScope scope
+ qnames = map (Scope.anameName . head) $ Map.elems names
+ modnames = filter (\n -> AN.qnameModule n == AN.qnameModule def && n /= def) qnames
+ map (False,) <$> do
+ (`filterM` modnames) $ \ n -> do
+ c <- getConstInfo n
+ case theDef c of
+ Axiom{} -> return True
+ Function{} -> return True
+ _ -> return False
+
autohints _ _ _ = return []
+insuffsols :: Int -> String
insuffsols 0 = "No solution found"
insuffsols n = "Only " ++ show n ++ " solution(s) found"
+insuffcands :: Int -> String
insuffcands 0 = "No candidate found"
insuffcands n = "Only " ++ show n ++ " candidate(s) found"
diff --git a/src/full/Agda/Auto/CaseSplit.hs b/src/full/Agda/Auto/CaseSplit.hs
index 085aca9..5720314 100644
--- a/src/full/Agda/Auto/CaseSplit.hs
+++ b/src/full/Agda/Auto/CaseSplit.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.CaseSplit where
@@ -14,21 +14,23 @@ import Agda.Auto.Syntax
import Agda.Auto.SearchControl
import Agda.Auto.Typecheck
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
abspatvarname :: String
abspatvarname = "\0absurdPattern"
+costCaseSplitVeryHigh, costCaseSplitHigh, costCaseSplitLow, costAddVarDepth
+ :: Nat
costCaseSplitVeryHigh = 10000
-costCaseSplitHigh = 5000
-costCaseSplitLow = 2000
-costAddVarDepth = 1000
-
+costCaseSplitHigh = 5000
+costCaseSplitLow = 2000
+costAddVarDepth = 1000
data HI a = HI FMode a
-drophid = map (\(HI _ x) -> x)
+drophid :: [HI a] -> [a]
+drophid = map (\(HI _ x) -> x)
type CSPat o = HI (CSPatI o)
type CSCtx o = [HI (MId, MExp o)]
@@ -195,6 +197,7 @@ caseSplitSearch' branchsearch depthinterval depth recdef ctx tt pats = do
return $ concat (map (\sol -> map (\sol2 -> sol ++ sol2) sols2) sols)
_ -> return [] -- split failed "scrut type is not datatype"
_ -> return [] -- split failed "scrut type is not datatype"
+
infertypevar :: CSCtx o -> Nat -> MExp o
infertypevar ctx v = snd $ (drophid ctx) !! v
replace :: Nat -> Nat -> MExp o -> MExp o -> MExp o
@@ -243,19 +246,17 @@ betareduce e args = case rm args of
ALProj{} -> __IMPOSSIBLE__
-
ALConPar as -> __IMPOSSIBLE__
-
+concatargs :: MM (ArgList o) (RefInfo o) -> MArgList o -> MArgList o
concatargs xs ys = case rm xs of
- ALNil -> ys
- ALCons hid x xs -> mm $ ALCons hid x (concatargs xs ys)
-
- ALProj{} -> __IMPOSSIBLE__
+ ALNil -> ys
+ ALCons hid x xs -> mm $ ALCons hid x (concatargs xs ys)
- ALConPar as -> mm $ ALConPar (concatargs xs ys)
+ ALProj{} -> __IMPOSSIBLE__
+ ALConPar as -> mm $ ALConPar (concatargs xs ys)
eqelr :: Elr o -> Elr o -> Bool
eqelr (Var v1) (Var v2) = v1 == v2
@@ -437,8 +438,8 @@ freevars = f 0
ALConPar es -> fs n es
-
-applyperm :: [Nat] -> CSCtx o -> MExp o -> [CSPat o] -> (CSCtx o, MExp o, [CSPat o])
+applyperm :: [Nat] -> CSCtx o -> MExp o -> [CSPat o] ->
+ (CSCtx o, MExp o, [CSPat o])
applyperm perm ctx tt pats =
let ctx1 = map (\(HI hid (id, t)) -> HI hid (id, rename (ren perm) t)) ctx
ctx2 = map (\i -> ctx1 !! i) perm
@@ -447,6 +448,7 @@ applyperm perm ctx tt pats =
pats' = map (renamep (ren perm)) pats
in (ctx3, tt', pats')
+ren :: [Nat] -> Nat -> Int
ren n i = let Just j = findIndex (== i) n in j
rename :: (Nat -> Nat) -> MExp o -> MExp o
diff --git a/src/full/Agda/Auto/Convert.hs b/src/full/Agda/Auto/Convert.hs
index e5beb90..a12e5dd 100644
--- a/src/full/Agda/Auto/Convert.hs
+++ b/src/full/Agda/Auto/Convert.hs
@@ -7,10 +7,9 @@ import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import Control.Monad.State
-import Control.Monad.Error
import qualified Agda.Syntax.Internal as I
-import qualified Agda.Syntax.Common as C
+import qualified Agda.Syntax.Common as Common
import qualified Agda.Syntax.Abstract.Name as AN
import qualified Agda.Syntax.Abstract as A
import qualified Agda.Syntax.Position as SP
@@ -37,8 +36,15 @@ import Agda.Auto.Syntax
import Agda.Auto.CaseSplit hiding (lift)
-#include "../undefined.h"
+import Agda.Utils.Except
+ ( Error(strMsg)
+ , ExceptT
+ , MonadError(catchError, throwError)
+ )
+
import Agda.Utils.Impossible
+#include "undefined.h"
+
norm :: Normalise t => t -> MB.TCM t
norm x = normalise x
@@ -50,7 +56,11 @@ data TMode = TMAll -- can be extended to distinguish between different modes (al
deriving Eq
type MapS a b = (Map a b, [a])
+
+initMapS :: MapS a b
initMapS = (Map.empty, [])
+
+popMapS :: (S -> (a, [b])) -> ((a, [b]) -> S -> S) -> TOM (Maybe b)
popMapS r w = do (m, xs) <- gets r
case xs of
[] -> return Nothing
@@ -98,7 +108,7 @@ tomy imi icns typs = do
cons2 <- mapM (\con -> getConst True con TMAll) cons
return (Datatype cons2 [], [])
MB.Record {MB.recFields = fields, MB.recTel = tel} -> do -- the value of recPars seems unreliable or don't know what it signifies
- let pars n (I.El _ (I.Pi it typ)) = C.Arg (C.domInfo it) (I.var n) :
+ let pars n (I.El _ (I.Pi it typ)) = Common.Arg (Common.domInfo it) (I.var n) :
pars (n - 1) (I.unAbs typ)
pars n (I.El s (I.Shared p)) = pars n (I.El s (I.derefPtr p))
pars _ (I.El _ _) = []
@@ -111,7 +121,7 @@ tomy imi icns typs = do
let Datatype [con] [] = cdcont cc
lift $ liftIO $ modifyIORef con (\cdef -> cdef {cdtype = contyp'})
- projfcns <- mapM (\name -> getConst False name TMAll) (map C.unArg fields)
+ projfcns <- mapM (\name -> getConst False name TMAll) (map Common.unArg fields)
return (Datatype [con] projfcns, []{-map snd fields-})
MB.Constructor {MB.conData = dt} -> do
@@ -148,7 +158,7 @@ tomy imi icns typs = do
modify $ \s -> s {sEqs = (Map.insert (Map.size (fst $ sEqs s)) (Just (False, Meta m, sol')) (fst $ sEqs s), snd $ sEqs s)}
let tt = MB.jMetaType $ mvJudgement mv
minfo = getMetaInfo mv
- localVars = map (snd . C.unDom . ctxEntry) . envContext . clEnv $ minfo
+ localVars = map (snd . Common.unDom . ctxEntry) . envContext . clEnv $ minfo
(targettype, localVars) <- lift $ withMetaInfo minfo $ do
vs <- getContextArgs
let targettype = tt `piApply` permute (takeP (length vs) $ mvPermutation mv) vs
@@ -230,6 +240,7 @@ getConst iscon name mode = do
modify (\s -> s {sConsts = (Map.insert name (mode, c) cmap, name : snd (sConsts s))})
return c
+getdfv :: I.MetaId -> A.QName -> MB.TCM Common.Nat
getdfv mainm name = do
mv <- lookupMeta mainm
withMetaInfo (getMetaInfo mv) $ getDefFreeVars name
@@ -269,6 +280,7 @@ copatternsNotImplemented :: MB.TCM a
copatternsNotImplemented = MB.typeError $ MB.NotImplemented $
"The Agda synthesizer (Agsy) does not support copatterns yet"
+tomyClauses :: [I.Clause] -> TOM [([Pat O], MExp O)]
tomyClauses [] = return []
tomyClauses (cl:cls) = do
cl' <- tomyClause cl
@@ -277,6 +289,7 @@ tomyClauses (cl:cls) = do
Just cl' -> cl' : cls'
Nothing -> cls'
+tomyClause :: I.Clause -> TOM (Maybe ([Pat O], MExp O))
tomyClause cl@(I.Clause {I.clausePerm = Perm n ps, I.clauseBody = body}) = do
let pats = I.clausePats cl
pats' <- mapM tomyPat pats
@@ -285,20 +298,23 @@ tomyClause cl@(I.Clause {I.clausePerm = Perm n ps, I.clauseBody = body}) = do
Just (body', _) -> Just (pats', body')
Nothing -> Nothing
-tomyPat p = case C.unArg p of
+
+tomyPat :: I.Arg I.Pattern -> TOM (Pat O)
+tomyPat p = case Common.unArg p of
I.ProjP _ -> lift $ copatternsNotImplemented
I.VarP n -> return $ PatVar (show n)
I.DotP _ -> return $ PatVar "_" -- because Agda includes these when referring to variables in the body
I.ConP con _ pats -> do
let n = I.conName con
c <- getConst True n TMAll
- pats' <- mapM (tomyPat . fmap C.namedThing) pats
+ pats' <- mapM (tomyPat . fmap Common.namedThing) pats
def <- lift $ getConstInfo n
cc <- lift $ liftIO $ readIORef c
let Just npar = fst $ cdorigin cc
return $ PatConApp c (replicate npar PatExp ++ pats')
I.LitP _ -> throwError $ strMsg "Auto: Literals in patterns are not supported"
+tomyBody :: I.ClauseBodyF I.Term -> TOM (Maybe (MExp O, Int))
tomyBody (I.Body t) = do
t <- lift $ norm t
t' <- tomyExp t
@@ -382,7 +398,7 @@ tomyExp v0 =
cc <- lift $ liftIO $ readIORef c
let Just npar = fst $ cdorigin cc
return $ NotM $ App Nothing (NotM OKVal) (Const c) (foldl (\x _ -> NotM $ ALConPar x) as' [1..npar])
- I.Pi (C.Dom info x) b -> do
+ I.Pi (Common.Dom info x) b -> do
let y = I.absBody b
name = I.absName b
x' <- tomyType x
@@ -408,12 +424,14 @@ tomyExp v0 =
I.Shared p -> tomyExp $ I.derefPtr p
I.ExtLam{} -> __IMPOSSIBLE__
+tomyExps :: I.Args -> TOM (MM (ArgList O) (RefInfo O))
tomyExps [] = return $ NotM ALNil
-tomyExps (C.Arg info a : as) = do
+tomyExps (Common.Arg info a : as) = do
a' <- tomyExp a
as' <- tomyExps as
return $ NotM $ ALCons (cnvh info) a' as'
+tomyIneq :: MB.Comparison -> Bool
tomyIneq MB.CmpEq = False
tomyIneq MB.CmpLeq = True
@@ -429,15 +447,16 @@ fmExp m (I.Lit _) = False
fmExp m (I.Level (I.Max as)) = any (fmLevel m) as
fmExp m (I.Def _ as) = fmExps m $ I.argsFromElims as
fmExp m (I.Con _ as) = fmExps m as
-fmExp m (I.Pi x y) = fmType m (C.unDom x) || fmType m (I.unAbs y)
+fmExp m (I.Pi x y) = fmType m (Common.unDom x) || fmType m (I.unAbs y)
fmExp m (I.Sort _) = False
fmExp m (I.MetaV mid _) = mid == m
fmExp m (I.DontCare _) = False
fmExp m (I.Shared p) = fmExp m $ I.derefPtr p
fmExp m I.ExtLam{} = __IMPOSSIBLE__
+fmExps :: I.MetaId -> I.Args -> Bool
fmExps m [] = False
-fmExps m (a : as) = fmExp m (C.unArg a) || fmExps m as
+fmExps m (a : as) = fmExp m (Common.unArg a) || fmExps m as
fmLevel :: I.MetaId -> I.PlusLevel -> Bool
fmLevel m I.ClosedLevel{} = False
@@ -449,27 +468,31 @@ fmLevel m (I.Plus _ l) = case l of
-- ---------------------------------------------
-cnvh info = case C.getHiding info of
- C.NotHidden -> NotHidden
- C.Instance -> Instance
- C.Hidden -> Hidden
-icnvh h = (C.setHiding h' C.defaultArgInfo)
+cnvh :: Common.LensHiding a => a -> FMode
+cnvh info = case Common.getHiding info of
+ Common.NotHidden -> NotHidden
+ Common.Instance -> Instance
+ Common.Hidden -> Hidden
+
+icnvh :: FMode -> I.ArgInfo
+icnvh h = (Common.setHiding h' Common.defaultArgInfo)
where
h' = case h of
- NotHidden -> C.NotHidden
- Instance -> C.Instance
- Hidden -> C.Hidden
+ NotHidden -> Common.NotHidden
+ Instance -> Common.Instance
+ Hidden -> Common.Hidden
-- ---------------------------------------------
+frommy :: MExp O -> ExceptT String IO I.Term
frommy = frommyExp
-frommyType :: MExp O -> ErrorT String IO I.Type
+frommyType :: MExp O -> ExceptT String IO I.Type
frommyType e = do
e' <- frommyExp e
return $ I.El (I.mkType 0) e' -- 0 is arbitrary, sort not read by Agda when reifying
-frommyExp :: MExp O -> ErrorT String IO I.Term
+frommyExp :: MExp O -> ExceptT String IO I.Term
frommyExp (Meta m) = do
bind <- lift $ readIORef $ mbind m
case bind of
@@ -489,7 +512,7 @@ frommyExp (NotM e) =
frommyExps n as v
-}
(ndrop, h) = case iscon of
- Just n -> (n, \ q -> I.Con (I.ConHead q [])) -- TODO: restore fields
+ Just n -> (n, \ q -> I.Con (I.ConHead q Common.Inductive [])) -- TODO: restore fields
Nothing -> (0, \ f vs -> I.Def f $ map I.Apply vs)
frommyExps ndrop as (h name [])
Lam hid (Abs mid t) -> do
@@ -498,8 +521,8 @@ frommyExp (NotM e) =
Pi _ hid _ x (Abs mid y) -> do
x' <- frommyType x
y' <- frommyType y
- return $ I.Pi (C.Dom (icnvh hid) x') (I.Abs (case mid of {NoId -> "x"; Id id -> id}) y')
- -- maybe have case for Pi where possdep is False which produces Fun (and has to unweaken y), return $ I.Fun (C.Arg (icnvh hid) x') y'
+ return $ I.Pi (Common.Dom (icnvh hid) x') (I.Abs (case mid of {NoId -> "x"; Id id -> id}) y')
+ -- maybe have case for Pi where possdep is False which produces Fun (and has to unweaken y), return $ I.Fun (Common.Arg (icnvh hid) x') y'
Sort (Set l) ->
return $ I.Sort (I.mkType (fromIntegral l))
Sort Type -> __IMPOSSIBLE__
@@ -509,7 +532,7 @@ frommyExp (NotM e) =
return $ I.Lam (icnvh hid) (I.Abs abslamvarname (I.Var 0 []))
-frommyExps :: Nat -> MArgList O -> I.Term -> ErrorT String IO I.Term
+frommyExps :: Nat -> MArgList O -> I.Term -> ExceptT String IO I.Term
frommyExps ndrop (Meta m) trm = do
bind <- lift $ readIORef $ mbind m
case bind of
@@ -521,7 +544,7 @@ frommyExps ndrop (NotM as) trm =
ALCons _ _ xs | ndrop > 0 -> frommyExps (ndrop - 1) xs trm
ALCons hid x xs -> do
x' <- frommyExp x
- frommyExps ndrop xs (addend (C.Arg (icnvh hid) x') trm)
+ frommyExps ndrop xs (addend (Common.Arg (icnvh hid) x') trm)
-- Andreas, 2013-10-19 TODO: restore postfix projections
ALProj eas idx hid xs -> do
@@ -532,7 +555,7 @@ frommyExps ndrop (NotM as) trm =
cdef <- lift $ readIORef c
let name = snd $ cdorigin cdef
trm2 <- frommyExps 0 eas (I.Def name [])
- frommyExps 0 xs (addend (C.Arg (icnvh hid) trm) trm2)
+ frommyExps 0 xs (addend (Common.Arg (icnvh hid) trm) trm2)
ALConPar xs | ndrop > 0 -> frommyExps (ndrop - 1) xs trm
ALConPar _ -> __IMPOSSIBLE__
@@ -545,15 +568,16 @@ frommyExps ndrop (NotM as) trm =
-- --------------------------------
+abslamvarname :: String
abslamvarname = "\0absurdlambda"
modifyAbstractExpr :: A.Expr -> A.Expr
modifyAbstractExpr = f
where
- f (A.App i e1 (C.Arg info (C.Named n e2))) =
- A.App i (f e1) (C.Arg info (C.Named n (f e2)))
- f (A.Lam i (A.DomainFree info n) _) | show n == abslamvarname =
- A.AbsurdLam i $ C.argInfoHiding info
+ f (A.App i e1 (Common.Arg info (Common.Named n e2))) =
+ A.App i (f e1) (Common.Arg info (Common.Named n (f e2)))
+ f (A.Lam i (A.DomainFree info n) _) | show (A.nameConcrete n) == abslamvarname =
+ A.AbsurdLam i $ Common.argInfoHiding info
f (A.Lam i b e) = A.Lam i b (f e)
f (A.Rec i xs) = A.Rec i (map (\(n, e) -> (n, f e)) xs)
f (A.RecUpdate i e xs) = A.RecUpdate i (f e) (map (\(n, e) -> (n, f e)) xs)
@@ -575,8 +599,8 @@ constructPats cmap mainm clause = do
(ns'', p') <- cnvp ns' p
return (ns'', p' : ps')
cnvp ns p =
- let hid = cnvh $ C.argInfo p
- in case C.namedArg p of
+ let hid = cnvh $ Common.argInfo p
+ in case Common.namedArg p of
I.VarP n -> return ((hid, Id n) : ns, HI hid (CSPatVar $ length ns))
I.ConP con _ ps -> do
let c = I.conName con
@@ -594,14 +618,14 @@ constructPats cmap mainm clause = do
return (reverse names, pats)
-frommyClause :: (CSCtx O, [CSPat O], Maybe (MExp O)) -> ErrorT String IO I.Clause
+frommyClause :: (CSCtx O, [CSPat O], Maybe (MExp O)) -> ExceptT String IO I.Clause
frommyClause (ids, pats, mrhs) = do
let ctel [] = return I.EmptyTel
ctel (HI hid (mid, t) : ctx) = do
let Id id = mid
tel <- ctel ctx
t' <- frommyType t
- return $ I.ExtendTel (C.Dom (icnvh hid) t') (I.Abs id tel)
+ return $ I.ExtendTel (Common.Dom (icnvh hid) t') (I.Abs id tel)
tel <- ctel $ reverse ids
let getperms 0 [] perm nv = return (perm, nv)
getperms n [] _ _ = __IMPOSSIBLE__
@@ -642,14 +666,14 @@ frommyClause (ids, pats, mrhs) = do
cdef <- lift $ readIORef c
let (Just ndrop, name) = cdorigin cdef
ps' <- cnvps ndrop ps
- let con = I.ConHead name [] -- TODO: restore record fields!
+ let con = I.ConHead name Common.Inductive [] -- TODO: restore record fields!
return (I.ConP con Nothing ps')
CSPatExp e -> do
e' <- frommyExp e {- renm e -} -- renaming before adding to clause below
return (I.DotP e')
CSAbsurd -> __IMPOSSIBLE__ -- CSAbsurd not used
_ -> __IMPOSSIBLE__
- return $ C.Arg (icnvh hid) $ C.unnamed p' -- TODO: recover names
+ return $ Common.Arg (icnvh hid) $ Common.unnamed p' -- TODO: recover names
ps <- cnvps 0 pats
body <- case mrhs of
Nothing -> return $ I.NoBody
@@ -747,13 +771,13 @@ findClauseDeep m = do
I.Level (I.Max as) -> any (fmLevel m) as
I.Def _ es -> findMetas $ I.argsFromElims es
I.Con _ as -> findMetas as
- I.Pi it ot -> findMetat (C.unDom it) || findMetat (I.unAbs ot)
+ I.Pi it ot -> findMetat (Common.unDom it) || findMetat (I.unAbs ot)
I.Sort{} -> False
I.MetaV m' _ -> m == m'
I.DontCare _ -> False
I.Shared{} -> __IMPOSSIBLE__
I.ExtLam{} -> __IMPOSSIBLE__
- findMetas = any (findMeta . C.unArg)
+ findMetas = any (findMeta . Common.unArg)
findMetat (I.El _ e) = findMeta e
toplevel e =
case I.ignoreSharing e of
@@ -793,15 +817,15 @@ matchType cdfv tctx ctyp ttyp = trmodps cdfv ctyp
(I.Lit lit1, I.Lit lit2) | lit1 == lit2 -> c (n + 1)
(I.Def n1 as1, I.Def n2 as2) | n1 == n2 -> fes nl (n + 1) c as1 as2
(I.Con n1 as1, I.Con n2 as2) | n1 == n2 -> fs nl (n + 1) c as1 as2
- (I.Pi (C.Dom info1 it1) ot1, I.Pi (C.Dom info2 it2) ot2) | C.argInfoHiding info1 == C.argInfoHiding info2 -> ft nl n (\n -> ft (nl + 1) n c (I.absBody ot1) (I.absBody ot2)) it1 it2
+ (I.Pi (Common.Dom info1 it1) ot1, I.Pi (Common.Dom info2 it2) ot2) | Common.argInfoHiding info1 == Common.argInfoHiding info2 -> ft nl n (\n -> ft (nl + 1) n c (I.absBody ot1) (I.absBody ot2)) it1 it2
(I.Sort{}, I.Sort{}) -> c n -- sloppy
_ -> Nothing
fs nl n c es1 es2 = case (es1, es2) of
([], []) -> c n
- (C.Arg info1 e1 : es1, C.Arg info2 e2 : es2) | C.argInfoHiding info1 == C.argInfoHiding info2 -> f nl n (\n -> fs nl n c es1 es2) e1 e2
+ (Common.Arg info1 e1 : es1, Common.Arg info2 e2 : es2) | Common.argInfoHiding info1 == Common.argInfoHiding info2 -> f nl n (\n -> fs nl n c es1 es2) e1 e2
_ -> Nothing
fes nl n c es1 es2 = case (es1, es2) of
([], []) -> c n
(I.Proj f : es1, I.Proj f' : es2) | f == f' -> fes nl n c es1 es2
- (I.Apply (C.Arg info1 e1) : es1, I.Apply (C.Arg info2 e2) : es2) | C.argInfoHiding info1 == C.argInfoHiding info2 -> f nl n (\n -> fes nl n c es1 es2) e1 e2
+ (I.Apply (Common.Arg info1 e1) : es1, I.Apply (Common.Arg info2 e2) : es2) | Common.argInfoHiding info1 == Common.argInfoHiding info2 -> f nl n (\n -> fes nl n c es1 es2) e1 e2
_ -> Nothing
diff --git a/src/full/Agda/Auto/NarrowingSearch.hs b/src/full/Agda/Auto/NarrowingSearch.hs
index d2cbc73..8e60324 100644
--- a/src/full/Agda/Auto/NarrowingSearch.hs
+++ b/src/full/Agda/Auto/NarrowingSearch.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
--- {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- {-# LANGUAGE UndecidableInstances #-}
module Agda.Auto.NarrowingSearch where
@@ -13,7 +13,7 @@ import Data.IORef hiding (writeIORef, modifyIORef)
import qualified Data.IORef as NoUndo (writeIORef, modifyIORef)
import Control.Monad.State
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
type Prio = Int
diff --git a/src/full/Agda/Auto/SearchControl.hs b/src/full/Agda/Auto/SearchControl.hs
index a4789d0..ad7d69d 100644
--- a/src/full/Agda/Auto/SearchControl.hs
+++ b/src/full/Agda/Auto/SearchControl.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.Auto.SearchControl where
@@ -14,7 +14,7 @@ import Data.Maybe (mapMaybe)
import Agda.Auto.NarrowingSearch
import Agda.Auto.Syntax
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
instance Refinable (ArgList o) (RefInfo o) where
@@ -53,12 +53,17 @@ data ExpRefInfo o = ExpRefInfo {eriMain :: Maybe (RefInfo o), eriUnifs :: [RefIn
}
-getinfo = f (ExpRefInfo {eriMain = Nothing, eriUnifs = [], eriInfTypeUnknown = False, eriIsEliminand = False, eriUsedVars = Nothing,
- eriIotaStep = Nothing, eriPickSubsVar = False
-
- , eriEqRState = Nothing
-
- })
+getinfo :: [RefInfo o] -> ExpRefInfo o
+getinfo = f (ExpRefInfo {eriMain = Nothing
+ , eriUnifs = []
+ , eriInfTypeUnknown = False
+ , eriIsEliminand = False
+ , eriUsedVars = Nothing
+ , eriIotaStep = Nothing
+ , eriPickSubsVar = False
+ , eriEqRState = Nothing
+ }
+ )
where
f i [] = i
f i (x at RIMainInfo{} : xs) = f (i {eriMain = Just x}) xs
@@ -259,7 +264,8 @@ instance Refinable (Exp o) (RefInfo o) where
HNSort _ -> generics
_ -> __IMPOSSIBLE__
-
+extraref :: UId o -> [Maybe (UId o)] -> ConstRef o ->
+ (Int, StateT (IORef [SubConstraints (RefInfo o)], Int) IO (Exp o))
extraref meta seenuids c = (costAppExtraRef, app (head seenuids) (Const c))
where
app muid elr = do p <- newPlaceholder
@@ -282,7 +288,14 @@ instance Refinable (ConstRef o) (RefInfo o) where
-- ---------------------------------
-costIotaStep, costAppExtraRef, costIncrease :: Int
+
+costIncrease, costUnificationOccurs, costUnification, costAppVar,
+ costAppVarUsed, costAppHint, costAppHintUsed, costAppRecCall,
+ costAppRecCallUsed, costAppConstructor, costAppConstructorSingle,
+ costAppExtraRef, costLam, costLamUnfold, costPi, costSort, costIotaStep,
+ costInferredTypeUnkown, costAbsurdLam
+ :: Int
+
costIncrease = 1000
costUnificationOccurs = 100 -- 1000001 -- 1 -- 100
costUnification = 0000
@@ -303,17 +316,19 @@ costIotaStep = 3000 -- 1000005 -- 2 -- 100
costInferredTypeUnkown = 1000006 -- 100
costAbsurdLam = 0
+costEqStep, costEqEnd, costEqSym, costEqCong :: Int
costEqStep = 2000
costEqEnd = 0
costEqSym = 0
costEqCong = 500
-
-prioNo, prioTypeUnknown, prioTypecheckArgList, prioInferredTypeUnknown, prioCompBeta, prioCompBetaStructured, prioCompareArgList, prioCompIota, prioCompChoice, prioCompUnif, prioCompCopy, prioNoIota, prioAbsurdLambda :: Int
+prioNo, prioTypeUnknown, prioTypecheckArgList, prioInferredTypeUnknown,
+ prioCompBeta, prioCompBetaStructured, prioCompareArgList, prioCompIota,
+ prioCompChoice, prioCompUnif, prioCompCopy, prioNoIota, prioAbsurdLambda,
+ prioProjIndex
+ :: Int
prioNo = (-1)
prioTypeUnknown = 0
-prioTypecheck False = 1000
-prioTypecheck True = 0
prioTypecheckArgList = 3000
prioInferredTypeUnknown = 4000
prioCompBeta = 4000
@@ -326,8 +341,11 @@ prioCompareArgList = 7000 -- 5 -- 2
prioNoIota = 500 -- 500
prioAbsurdLambda = 1000
-prioProjIndex = 3000 :: Int
+prioProjIndex = 3000
+prioTypecheck :: Bool -> Int
+prioTypecheck False = 1000
+prioTypecheck True = 0
-- ---------------------------------
diff --git a/src/full/Agda/Auto/Syntax.hs b/src/full/Agda/Auto/Syntax.hs
index 606b774..849c382 100644
--- a/src/full/Agda/Auto/Syntax.hs
+++ b/src/full/Agda/Auto/Syntax.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
module Agda.Auto.Syntax where
@@ -7,7 +7,7 @@ import Data.IORef
import Agda.Auto.NarrowingSearch
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Unique identifiers for variable occurrences in unification.
@@ -152,10 +152,9 @@ data Exp o
| AbsurdLambda FMode
-- ^ Absurd lambda with hiding information.
-
+dontCare :: Exp o
dontCare = Sort UnknownSort
-
-- | "Maybe expression": Expression or reference to meta variable.
type MExp o = MM (Exp o) (RefInfo o)
diff --git a/src/full/Agda/Auto/Typecheck.hs b/src/full/Agda/Auto/Typecheck.hs
index 945af09..f4284f0 100644
--- a/src/full/Agda/Auto/Typecheck.hs
+++ b/src/full/Agda/Auto/Typecheck.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.Typecheck where
@@ -12,7 +12,7 @@ import Agda.Auto.NarrowingSearch
import Agda.Auto.Syntax
import Agda.Auto.SearchControl
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- ---------------------------------
@@ -149,8 +149,8 @@ traversePi v t =
HNPi _ _ _ _ (Abs _ ot) -> traversePi (v - 1) (subi (NotM $ App Nothing (NotM OKVal) (Var v) (NotM ALNil)) ot)
_ -> mbret hnt
-
-tcargs :: Nat -> Bool -> Ctx o -> CExp o -> MArgList o -> MExp o -> Bool -> (CExp o -> MExp o -> EE (MyPB o)) -> EE (MyPB o)
+tcargs :: Nat -> Bool -> Ctx o -> CExp o -> MArgList o -> MExp o -> Bool ->
+ (CExp o -> MExp o -> EE (MyPB o)) -> EE (MyPB o)
tcargs ndfv isdep ctx ityp@(TrBr ityptrs iityp) args elimtrm isconstructor cont = mmpcase (True, prioTypecheckArgList, (Just $ RICheckElim $ isdep || isconstructor)) args $ \args' -> case args' of
ALNil -> cont ityp elimtrm
ALCons hid a as ->
@@ -193,23 +193,26 @@ tcargs ndfv isdep ctx ityp@(TrBr ityptrs iityp) args elimtrm isconstructor cont
where
t = TrBr ityptrs
-
+addend :: FMode -> MExp o -> MM (Exp o) blk -> MM (Exp o) blk
addend hid a (NotM (App uid okh elr as)) = NotM $ App uid okh elr (f as)
- where f (NotM ALNil) = NotM $ ALCons hid a (NotM $ ALNil)
- f (NotM (ALCons hid a as)) = NotM $ ALCons hid a (f as)
- f _ = __IMPOSSIBLE__
+ where
+ f (NotM ALNil) = NotM $ ALCons hid a (NotM $ ALNil)
+ f (NotM (ALCons hid a as)) = NotM $ ALCons hid a (f as)
+ f _ = __IMPOSSIBLE__
addend _ _ _ = __IMPOSSIBLE__
-copyarg _ = False
+copyarg :: MExp o -> Bool
+copyarg _ = False
-- ---------------------------------
-
type HNNBlks o = [HNExp o]
+noblks :: HNNBlks o
noblks = []
-addblk = (:)
+addblk :: HNExp o -> HNNBlks o -> HNNBlks o
+addblk = (:)
hnn :: ICExp o -> EE (MyMB (HNExp o) o)
hnn e = mbcase (hnn_blks e) $ \(hne, _) -> mbret hne
@@ -684,7 +687,8 @@ checkeliminand = f [] []
-- ---------------------------------
-
+maybeor :: Bool -> Int -> IO (PB (RefInfo o)) -> IO (PB (RefInfo o)) ->
+ IO (PB (RefInfo o))
maybeor _ _ mainalt _ = mainalt
iotapossmeta :: ICExp o -> ICArgList o -> EE Bool
diff --git a/src/full/Agda/Compiler/CallCompiler.hs b/src/full/Agda/Compiler/CallCompiler.hs
index ca485ba..6c3e441 100644
--- a/src/full/Agda/Compiler/CallCompiler.hs
+++ b/src/full/Agda/Compiler/CallCompiler.hs
@@ -15,7 +15,7 @@ import System.Process
import Agda.TypeChecking.Monad
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Calls a compiler:
diff --git a/src/full/Agda/Compiler/Epic/AuxAST.hs b/src/full/Agda/Compiler/Epic/AuxAST.hs
index 534207b..fd550d9 100644
--- a/src/full/Agda/Compiler/Epic/AuxAST.hs
+++ b/src/full/Agda/Compiler/Epic/AuxAST.hs
@@ -5,13 +5,13 @@
module Agda.Compiler.Epic.AuxAST where
import Data.Set (Set)
-import qualified Data.Set as S
+import qualified Data.Set as Set
import Agda.Syntax.Abstract.Name
import Agda.Compiler.Epic.Interface
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
type Comment = String
@@ -145,24 +145,24 @@ substBranch x e br = br { brExpr = subst x e (brExpr br) }
-- | Get the free variables in an expression
fv :: Expr -> [Var]
-fv = S.toList . fv'
+fv = Set.toList . fv'
where
fv' :: Expr -> Set Var
fv' expr = case expr of
- Var v -> S.singleton v
- Lit _ -> S.empty
- Lam v e1 -> S.delete v (fv' e1)
- Con _ _ es -> S.unions (map fv' es)
- App v es -> S.insert v $ S.unions (map fv' es)
- Case e brs -> fv' e `S.union` S.unions (map fvBr brs)
- If a b c -> S.unions (map fv' [a,b,c])
- Let v e e' -> fv' e `S.union` (S.delete v $ fv' e')
+ Var v -> Set.singleton v
+ Lit _ -> Set.empty
+ Lam v e1 -> Set.delete v (fv' e1)
+ Con _ _ es -> Set.unions (map fv' es)
+ App v es -> Set.insert v $ Set.unions (map fv' es)
+ Case e brs -> fv' e `Set.union` Set.unions (map fvBr brs)
+ If a b c -> Set.unions (map fv' [a,b,c])
+ Let v e e' -> fv' e `Set.union` (Set.delete v $ fv' e')
Lazy e -> fv' e
- UNIT -> S.empty
- IMPOSSIBLE -> S.empty
+ UNIT -> Set.empty
+ IMPOSSIBLE -> Set.empty
fvBr :: Branch -> Set Var
fvBr b = case b of
- Branch _ _ vs e -> fv' e S.\\ S.fromList vs
+ Branch _ _ vs e -> fv' e Set.\\ Set.fromList vs
BrInt _ e -> fv' e
Default e -> fv' e
diff --git a/src/full/Agda/Compiler/Epic/CompileState.hs b/src/full/Agda/Compiler/Epic/CompileState.hs
index 676e6fb..7f7bf69 100644
--- a/src/full/Agda/Compiler/Epic/CompileState.hs
+++ b/src/full/Agda/Compiler/Epic/CompileState.hs
@@ -7,12 +7,12 @@ module Agda.Compiler.Epic.CompileState where
import Control.Applicative
import Control.Monad.State
import Data.List
-import Data.Map(Map)
-import qualified Data.Map as M
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
-import Data.Set(Set)
-import qualified Data.Set as S
+import Data.Set (Set)
+import qualified Data.Set as Set
import Agda.Compiler.Epic.AuxAST as AuxAST
import Agda.Compiler.Epic.Interface
@@ -20,13 +20,14 @@ import Agda.Interaction.Options
import Agda.Syntax.Internal
import Agda.Syntax.Concrete(TopLevelModuleName)
import Agda.Syntax.Common
-import Agda.TypeChecking.Monad (TCM, internalError, defType, theDef, getConstInfo, sigDefinitions, stImports, stPersistentOptions, stPersistent)
+import Agda.TypeChecking.Monad (TCM, internalError, defType, theDef, getConstInfo, sigDefinitions, stImports, stPersistentOptions, stPersistentState)
import qualified Agda.TypeChecking.Monad as TM
import Agda.TypeChecking.Reduce
import qualified Agda.Utils.HashMap as HM
+import Agda.Utils.Lens
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Stuff we need in our compiler
@@ -42,7 +43,7 @@ data CompileState = CompileState
initCompileState :: CompileState
initCompileState = CompileState
{ nameSupply = map (('h':) . show) [0 :: Integer ..]
- , compiledModules = M.empty
+ , compiledModules = Map.empty
, curModule = mempty
, importedModules = mempty
, curFun = undefined
@@ -66,7 +67,7 @@ getsEI f = gets (f . curModule)
-- | Returns the type of a definition given its name
getType :: QName -> Compile TCM Type
getType q = do
- map <- lift (gets (sigDefinitions . stImports))
+ map <- lift (sigDefinitions <$> use stImports)
return $ maybe __IMPOSSIBLE__ defType (HM.lookup q map)
-- | Create a name which can be used in Epic code from a QName.
@@ -81,10 +82,10 @@ resetNameSupply :: Compile TCM ()
resetNameSupply = modify $ \s -> s {nameSupply = nameSupply initCompileState}
getDelayed :: QName -> Compile TCM Bool
-getDelayed q = lookInterface (M.lookup q . defDelayed) (return False)
+getDelayed q = lookInterface (Map.lookup q . defDelayed) (return False)
putDelayed :: QName -> Bool -> Compile TCM ()
-putDelayed q d = modifyEI $ \s -> s {defDelayed = M.insert q d (defDelayed s)}
+putDelayed q d = modifyEI $ \s -> s {defDelayed = Map.insert q d (defDelayed s)}
newName :: Compile TCM Var
newName = do
@@ -93,7 +94,7 @@ newName = do
return n
putConstrTag :: QName -> Tag -> Compile TCM ()
-putConstrTag q t = modifyEI $ \s -> s { constrTags = M.insert q t $ constrTags s }
+putConstrTag q t = modifyEI $ \s -> s { constrTags = Map.insert q t $ constrTags s }
assignConstrTag :: QName -> Compile TCM Tag
assignConstrTag constr = assignConstrTag' constr []
@@ -108,7 +109,7 @@ assignConstrTag' constr constrs = do
getConData :: QName -> Compile TCM QName
getConData con = do
- lmap <- lift (gets (TM.sigDefinitions . TM.stImports))
+ lmap <- lift (TM.sigDefinitions <$> use TM.stImports)
case HM.lookup con lmap of
Just def -> case theDef def of
c@(TM.Constructor{}) -> return $ TM.conData c
@@ -117,7 +118,7 @@ getConData con = do
getDataCon :: QName -> Compile TCM [QName]
getDataCon con = do
- lmap <- lift (gets (TM.sigDefinitions . TM.stImports))
+ lmap <- lift (TM.sigDefinitions <$> use TM.stImports)
case HM.lookup con lmap of
Just def -> case theDef def of
d@(TM.Datatype{}) -> return $ TM.dataCons d
@@ -126,30 +127,30 @@ getDataCon con = do
Nothing -> __IMPOSSIBLE__
getConstrTag :: QName -> Compile TCM Tag
-getConstrTag con = lookInterface (M.lookup con . constrTags)
+getConstrTag con = lookInterface (Map.lookup con . constrTags)
(assignConstrTag con)
getConstrTag' :: QName -> Compile TCM (Maybe Tag)
getConstrTag' con = do
cur <- gets curModule
- case M.lookup con (constrTags cur) of
+ case Map.lookup con (constrTags cur) of
Just x -> return (Just x)
Nothing -> do
imps <- gets importedModules
- return $ M.lookup con (constrTags imps)
+ return $ Map.lookup con (constrTags imps)
addDefName :: QName -> Compile TCM ()
addDefName q = do
- modifyEI $ \s -> s {definitions = S.insert (unqname q) $ definitions s }
+ modifyEI $ \s -> s {definitions = Set.insert (unqname q) $ definitions s }
topBindings :: Compile TCM (Set Var)
-topBindings = S.union <$> gets (definitions . importedModules) <*> gets (definitions . curModule)
+topBindings = Set.union <$> gets (definitions . importedModules) <*> gets (definitions . curModule)
getConArity :: QName -> Compile TCM Int
-getConArity n = lookInterface (M.lookup n . conArity) __IMPOSSIBLE__
+getConArity n = lookInterface (Map.lookup n . conArity) __IMPOSSIBLE__
putConArity :: QName -> Int -> Compile TCM ()
-putConArity n p = modifyEI $ \s -> s { conArity = M.insert n p (conArity s) }
+putConArity n p = modifyEI $ \s -> s { conArity = Map.insert n p (conArity s) }
putMain :: QName -> Compile TCM ()
putMain m = modifyEI $ \s -> s { mainName = Just m }
@@ -171,23 +172,23 @@ lookInterface f def = do
constrInScope :: QName -> Compile TCM Bool
constrInScope name = do
cur <- gets curModule
- case M.lookup name (constrTags cur) of
+ case Map.lookup name (constrTags cur) of
Just x -> return True
Nothing -> do
imps <- gets importedModules
- case M.lookup name (constrTags imps) of
+ case Map.lookup name (constrTags imps) of
Nothing -> return False
Just x -> return True
getForcedArgs :: QName -> Compile TCM ForcedArgs
-getForcedArgs q = lookInterface (M.lookup q . forcedArgs) __IMPOSSIBLE__
+getForcedArgs q = lookInterface (Map.lookup q . forcedArgs) __IMPOSSIBLE__
putForcedArgs :: QName -> ForcedArgs -> Compile TCM ()
putForcedArgs n f = do
- b <- lift $ gets (optForcing . stPersistentOptions . stPersistent)
+ b <- lift $ gets (optForcing . stPersistentOptions . stPersistentState)
let f' | b = f
| otherwise = replicate (length f) NotForced
- modifyEI $ \s -> s {forcedArgs = M.insert n f' $ forcedArgs s}
+ modifyEI $ \s -> s {forcedArgs = Map.insert n f' $ forcedArgs s}
replaceAt :: Int -- ^ replace at
-> [a] -- ^ to replace
diff --git a/src/full/Agda/Compiler/Epic/Compiler.hs b/src/full/Agda/Compiler/Epic/Compiler.hs
index 315118b..6af3220 100644
--- a/src/full/Agda/Compiler/Epic/Compiler.hs
+++ b/src/full/Agda/Compiler/Epic/Compiler.hs
@@ -7,12 +7,14 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
+
import qualified Data.ByteString.Lazy as BS
-import qualified Data.Map as M
-import Data.Set(Set)
-import qualified Data.Set as S
+import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as Set
+
import System.Directory ( canonicalizePath, createDirectoryIfMissing
, getCurrentDirectory, setCurrentDirectory
)
@@ -21,18 +23,20 @@ import System.FilePath hiding (normalise)
import System.Process hiding (env)
import Paths_Agda
-import Agda.Compiler.CallCompiler
+
import Agda.Interaction.FindFile
import Agda.Interaction.Options
import Agda.Interaction.Imports
+
import Agda.Syntax.Common (Delayed(..))
import qualified Agda.Syntax.Concrete.Name as CN
import Agda.Syntax.Internal hiding (Term(..))
+
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Serialise
-import Agda.Utils.FileName
-import qualified Agda.Utils.HashMap as HMap
+
+import Agda.Compiler.CallCompiler
import Agda.Compiler.Epic.CompileState
import qualified Agda.Compiler.Epic.CaseOpts as COpts
@@ -47,7 +51,12 @@ import qualified Agda.Compiler.Epic.NatDetection as ND
import qualified Agda.Compiler.Epic.Primitive as Prim
import qualified Agda.Compiler.Epic.Smashing as Smash
-#include "../../undefined.h"
+import Agda.Utils.FileName
+import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.List
+import Agda.Utils.Pretty ( prettyShow )
+
+#include "undefined.h"
import Agda.Utils.Impossible
compilePrelude :: Compile TCM ()
@@ -74,7 +83,7 @@ compilerMain inter = do
setEpicDir inter
(_, imports) <- compileModule inter
main <- getMain
- runEpicMain main (S.toList imports) (iModuleName inter)
+ runEpicMain main (Set.toList imports) (iModuleName inter)
ExitFailure _ -> internalError $ unlines
[ "Agda cannot find the Epic compiler."
@@ -101,14 +110,14 @@ compileModule i = do
cm <- gets compiledModules
let moduleName = toTopLevelModuleName $ iModuleName i
file <- outFile moduleName
- case M.lookup moduleName cm of
+ case Map.lookup moduleName cm of
Just eifs -> return eifs
Nothing -> do
imports <- map miInterface . catMaybes
<$> mapM (lift . getVisitedModule . toTopLevelModuleName . fst)
(iImportedModules i)
(ifaces, limps) <- mapAndUnzipM compileModule imports
- let imps = S.unions limps
+ let imps = Set.unions limps
modify $ \s -> s { importedModules = importedModules s `mappend` mconcat ifaces }
ifile <- maybe __IMPOSSIBLE__ filePath <$> lift (findInterfaceFile moduleName)
let eifFile = file <.> "aei"
@@ -116,28 +125,28 @@ compileModule i = do
(eif, imps') <- case uptodate of
True -> do
lift $ reportSLn "" 1 $
- show (iModuleName i) ++ " : no compilation is needed."
+ (prettyShow . iModuleName) i ++ " : no compilation is needed."
eif <- readEInterface eifFile
modify $ \s -> s { curModule = eif }
- return (eif, S.insert file imps)
+ return (eif, Set.insert file imps)
False -> do
lift $ reportSLn "" 1 $
- "Compiling: " ++ show (iModuleName i)
+ "Compiling: " ++ (prettyShow . iModuleName) i
resetNameSupply
initialAnalysis i
let defns = HMap.toList $ sigDefinitions $ iSignature i
-- Epic cannot parse files with no definitions
if (not $ null defns) then do
code <- compileDefns defns
- runEpic file (S.toList imps) code
+ runEpic file (Set.toList imps) code
eif <- gets curModule
lift $ do
bif <- encode eif
liftIO $ BS.writeFile eifFile bif
- return (eif, S.insert file imps)
+ return (eif, Set.insert file imps)
else
flip (,) imps <$> gets curModule
- modify $ \s -> s { compiledModules = (M.insert moduleName (eif, imps') (compiledModules s))}
+ modify $ \s -> s { compiledModules = (Map.insert moduleName (eif, imps') (compiledModules s))}
return (eif, imps')
-- | Before running the compiler, we need to store some things in the state,
@@ -162,7 +171,7 @@ initialAnalysis inter = do
putForcedArgs q . drop np . ForceC.makeForcedArgs $ defType def
putConArity q =<< lift (constructorArity q)
f@(Function{}) -> do
- when ("main" == show (qnameName q)) $ do
+ when ("main" == (prettyShow . qnameName) q) $ do
-- lift $ liftTCM $ checkTypeOfMain q (defType def)
putMain q
putDelayed q $ case funDelayed f of
@@ -174,6 +183,7 @@ initialAnalysis inter = do
_ -> return ()
_ -> return ()
+idPrint :: String -> (a -> Compile TCM b) -> a -> Compile TCM b
idPrint s m x = do
lift $ reportSLn "epic.phases" 10 s
m x
@@ -202,7 +212,7 @@ setEpicDir mainI = do
let tm = toTopLevelModuleName $ iModuleName mainI
f <- lift $ findFile tm
compileDir' <- lift $ gets (fromMaybe (filePath $ CN.projectRoot f tm) .
- optCompileDir . stPersistentOptions . stPersistent)
+ optCompileDir . stPersistentOptions . stPersistentState)
compileDir <- liftIO $ canonicalizePath compileDir'
liftIO $ setCurrentDirectory compileDir
liftIO $ createDirectoryIfMissing False "Epic"
@@ -232,12 +242,13 @@ runEpicMain mainName imports m = do
| imp <- imports'
] ++ "main() -> Unit = init() ; " ++ mainName ++ "(unit)"
liftIO $ writeFile ("main" <.> "e") code
- let outputName = case mnameToList m of
- [] -> __IMPOSSIBLE__
- ms -> last ms
+
+ let outputName :: CN.Name
+ outputName = maybe __IMPOSSIBLE__ nameConcrete $ lastMaybe $ mnameToList m
+
callEpic' $ \epic ->
[ "main" <.> "e"
- , "-o", ".." </> show outputName
+ , "-o", ".." </> prettyShow outputName
]
++ epic ++ map (<.> "o") imports'
diff --git a/src/full/Agda/Compiler/Epic/Epic.hs b/src/full/Agda/Compiler/Epic/Epic.hs
index 676580f..be9f8e3 100644
--- a/src/full/Agda/Compiler/Epic/Epic.hs
+++ b/src/full/Agda/Compiler/Epic/Epic.hs
@@ -15,7 +15,7 @@ import Agda.Compiler.Epic.AuxAST
import Agda.Compiler.Epic.CompileState
import Agda.Compiler.Epic.Interface
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- * Some auxilliary pretty-printer functions
diff --git a/src/full/Agda/Compiler/Epic/Erasure.hs b/src/full/Agda/Compiler/Epic/Erasure.hs
index 1445706..3759940 100644
--- a/src/full/Agda/Compiler/Epic/Erasure.hs
+++ b/src/full/Agda/Compiler/Epic/Erasure.hs
@@ -14,8 +14,8 @@ module Agda.Compiler.Epic.Erasure where
import Control.Applicative
import Control.Monad.State
-import Data.Map(Map)
-import qualified Data.Map as M
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Maybe
import Agda.Compiler.Epic.AuxAST
@@ -28,7 +28,7 @@ import qualified Agda.Syntax.Common as SC
import Agda.TypeChecking.Monad (reportSDoc)
import Agda.TypeChecking.Pretty as P
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
isIrr :: Relevance -> Bool
@@ -61,12 +61,12 @@ type Erasure = StateT ErasureState
erasure :: [Fun] -> Compile TCM [Fun]
erasure fs = do
orgRel <- gets (relevantArgs . importedModules)
- (rels, erasureState) <- flip runStateT (ErasureState orgRel M.empty) $ do
+ (rels, erasureState) <- flip runStateT (ErasureState orgRel Map.empty) $ do
mapM_ initiate fs
fu <- gets funs
- M.mapKeys (fromMaybe __IMPOSSIBLE__ . flip M.lookup fu) <$> step 1
- modifyEI $ \s -> s { relevantArgs = M.mapKeys funName rels }
- concat <$> mapM (\f -> map (rem (relevancies erasureState)) <$> check f (M.lookup f rels)) fs
+ Map.mapKeys (fromMaybe __IMPOSSIBLE__ . flip Map.lookup fu) <$> step 1
+ modifyEI $ \s -> s { relevantArgs = Map.mapKeys funName rels }
+ concat <$> mapM (\f -> map (rem (relevancies erasureState)) <$> check f (Map.lookup f rels)) fs
where
rem rels f at Fun{} = f { funExpr = removeUnused rels (funExpr f) }
@@ -104,7 +104,7 @@ removeUnused rels t = let rem = removeUnused rels
Lit _ -> t
Lam v e -> Lam v (rem e)
Con tag qn es -> Con tag qn (map rem es)
- App v es -> case M.lookup v rels of
+ App v es -> case Map.lookup v rels of
Just re -> App v $ zipWith (\r x -> if isIrr r then UNIT else rem x)
(re ++ repeat Rel) es
Nothing -> App v $ map rem es
@@ -119,16 +119,16 @@ removeUnused rels t = let rem = removeUnused rels
initiate :: Fun -> Erasure (Compile TCM) ()
initiate f@(Fun _ name mqname _ args _) = do
let rels = replicate (length args) Irr
- modify $ \s -> s { relevancies = M.insert name rels (relevancies s)
- , funs = M.insert name f (funs s)
+ modify $ \s -> s { relevancies = Map.insert name rels (relevancies s)
+ , funs = Map.insert name f (funs s)
}
initiate f@(EpicFun {funName = name, funQName = mqname}) = case mqname of
Just qn -> do
ty <- lift $ getType qn
let rels = initialRels ty Rel
return ()
- modify $ \s -> s { relevancies = M.insert name rels (relevancies s)
- , funs = M.insert name f (funs s)
+ modify $ \s -> s { relevancies = Map.insert name rels (relevancies s)
+ , funs = Map.insert name f (funs s)
}
Nothing -> return ()
@@ -159,7 +159,7 @@ relevant var expr = case expr of
App v es | v == var -> return Rel
| otherwise -> do
-- The variable is relevant if it is used in a relevant position
- mvrs <- gets (M.lookup v . relevancies)
+ mvrs <- gets (Map.lookup v . relevancies)
case mvrs of
Nothing -> relevants var es
Just vrs ->
@@ -195,8 +195,8 @@ relevant var expr = case expr of
step :: Integer -> Erasure (Compile TCM) (Map Var [Relevance])
step nrOfLoops = do
s <- get
- newRels <- (M.fromList <$>) $ forM (M.toList (funs s)) $ \(v, f) -> ((,) v <$>) $ do
- let funRels = fromMaybe __IMPOSSIBLE__ $ M.lookup v (relevancies s)
+ newRels <- (Map.fromList <$>) $ forM (Map.toList (funs s)) $ \(v, f) -> ((,) v <$>) $ do
+ let funRels = fromMaybe __IMPOSSIBLE__ $ Map.lookup v (relevancies s)
case f of
EpicFun{} -> return funRels
Fun{} -> do
@@ -205,7 +205,7 @@ step nrOfLoops = do
Irr -> do
lift $ lift $ reportSDoc "epic.erasure" 10 $ P.text "running erasure:" P.<+> (P.text . show) (funQName f)
relevant x (funExpr f)
- let relsm = newRels `M.union` relevancies s
+ let relsm = newRels `Map.union` relevancies s
if relevancies s == relsm
then return newRels
else do
@@ -213,4 +213,4 @@ step nrOfLoops = do
step (nrOfLoops + 1)
diff :: (Ord k, Eq a) => Map k a -> Map k a -> [(k,(a,a))]
-diff m1 m2 = catMaybes $ zipWith (\(k, x) (_, y) -> if x == y then Nothing else Just (k, (x, y))) (M.toList m1) (M.toList m2)
+diff m1 m2 = catMaybes $ zipWith (\(k, x) (_, y) -> if x == y then Nothing else Just (k, (x, y))) (Map.toList m1) (Map.toList m2)
diff --git a/src/full/Agda/Compiler/Epic/ForceConstrs.hs b/src/full/Agda/Compiler/Epic/ForceConstrs.hs
index 66be31d..b658ea3 100644
--- a/src/full/Agda/Compiler/Epic/ForceConstrs.hs
+++ b/src/full/Agda/Compiler/Epic/ForceConstrs.hs
@@ -1,6 +1,6 @@
--- | Remove forced arguments from constructors.
{-# LANGUAGE CPP #-}
+-- | Remove forced arguments from constructors.
module Agda.Compiler.Epic.ForceConstrs where
import Control.Applicative
@@ -13,7 +13,7 @@ import qualified Agda.Syntax.Common as S
import qualified Agda.Syntax.Internal as T
import Agda.TypeChecking.Monad (TCM)
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Check which arguments are forced
diff --git a/src/full/Agda/Compiler/Epic/Forcing.hs b/src/full/Agda/Compiler/Epic/Forcing.hs
index ee2d942..d7a2fad 100644
--- a/src/full/Agda/Compiler/Epic/Forcing.hs
+++ b/src/full/Agda/Compiler/Epic/Forcing.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Compiler.Epic.Forcing where
@@ -36,8 +36,9 @@ import Agda.Compiler.Epic.Epic
import Agda.Compiler.Epic.Interface
import qualified Agda.Compiler.Epic.FromAgda as FA
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+import Agda.Utils.Lens
-- | Returns how many parameters a datatype has
dataParameters :: QName -> Compile TCM Nat
@@ -46,7 +47,7 @@ dataParameters = lift . dataParametersTCM
-- | Returns how many parameters a datatype has
dataParametersTCM :: QName -> TCM Nat
dataParametersTCM name = do
- m <- (gets (sigDefinitions . stImports))
+ m <- (sigDefinitions <$> use stImports)
return $ maybe __IMPOSSIBLE__ (defnPars . theDef) (HM.lookup name m)
where
defnPars :: Defn -> Nat
@@ -54,8 +55,8 @@ dataParametersTCM name = do
defnPars (Record {recPars = p}) = p
defnPars d = 0 -- error (show d) -- __IMPOSSIBLE__ -- Not so sure about this.
-report n s = do
- lift $ reportSDoc "epic.forcing" n s
+report :: Int -> TCM P.Doc -> Compile TCM ()
+report n s = lift $ reportSDoc "epic.forcing" n s
piApplyM' :: Type -> Args -> TCM Type
piApplyM' t as = do
@@ -138,11 +139,14 @@ insertTele er n ins term (ExtendTel x xs) = do
return (ExtendTel x $ Abs (absName xs) xs' , typ)
-- TODO: restore fields in ConHead
-mkCon c n = I.Con (I.ConHead c []) [ defaultArg $ I.Var (fromIntegral i) [] | i <- [n - 1, n - 2 .. 0] ]
+mkCon :: QName -> Int -> Term
+mkCon c n = I.Con (I.ConHead c Inductive [])
+ [ defaultArg $ I.Var i [] | i <- [n - 1, n - 2 .. 0] ]
unifyI :: Telescope -> FlexibleVars -> Type -> Args -> Args -> Compile TCM [Maybe Term]
unifyI tele flex typ a1 a2 = lift $ addCtxTel tele $ unifyIndices_ flex typ a1 a2
+takeTele :: Int -> Telescope -> Telescope
takeTele 0 _ = EmptyTel
takeTele n (ExtendTel t ts) = ExtendTel t $ Abs (absName ts) $ takeTele (n-1) (unAbs ts)
takeTele _ _ = __IMPOSSIBLE__
@@ -150,7 +154,7 @@ takeTele _ _ = __IMPOSSIBLE__
-- | Main function for removing pattern matching on forced variables
remForced :: [Fun] -> Compile TCM [Fun]
remForced fs = do
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
forM fs $ \f -> case f of
Fun{} -> case funQName f >>= flip HM.lookup defs of
Nothing -> __IMPOSSIBLE__
diff --git a/src/full/Agda/Compiler/Epic/FromAgda.hs b/src/full/Agda/Compiler/Epic/FromAgda.hs
index f03c5d0..d54842e 100644
--- a/src/full/Agda/Compiler/Epic/FromAgda.hs
+++ b/src/full/Agda/Compiler/Epic/FromAgda.hs
@@ -7,7 +7,7 @@ import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Char
-import qualified Data.Map as M
+import qualified Data.Map as Map
import Data.Maybe
import Agda.Syntax.Common
@@ -28,7 +28,7 @@ import Agda.Compiler.Epic.Static
import Agda.Compiler.Epic.Epic
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Convert from Agda's internal representation to our auxiliary AST.
@@ -130,8 +130,8 @@ translateDefn msharp (n, defini) =
reverseCCBody :: Int -> CC.CompiledClauses -> CC.CompiledClauses
reverseCCBody c cc = case cc of
CC.Case n (CC.Branches cbr lbr cabr) -> CC.Case (c+n)
- $ CC.Branches (M.map (fmap $ reverseCCBody c) cbr)
- (M.map (reverseCCBody c) lbr)
+ $ CC.Branches (Map.map (fmap $ reverseCCBody c) cbr)
+ (Map.map (reverseCCBody c) lbr)
(fmap (reverseCCBody c) cabr)
CC.Done i t -> CC.Done i (S.applySubst
(S.parallelS $ map (flip T.Var []) $
@@ -196,16 +196,16 @@ compileClauses name nargs c = do
compileCase :: [Var] -> Maybe Var -> Int -> CC.Case CC.CompiledClauses
-> Compile TCM [Branch]
compileCase env omniDefault casedvar nc = do
- cb <- if M.null (CC.conBranches nc)
+ cb <- if Map.null (CC.conBranches nc)
-- Lit branch
- then forM (M.toList (CC.litBranches nc)) $ \(l, cc) -> do
+ then forM (Map.toList (CC.litBranches nc)) $ \(l, cc) -> do
cc' <- compileClauses' (replaceAt casedvar env []) omniDefault cc
case l of
TL.LitChar _ cha -> return $ BrInt (ord cha) cc'
-- TODO: Handle other literals
_ -> epicError $ "case on literal not supported: " ++ show l
-- Con branch
- else forM (M.toList (CC.conBranches nc)) $ \(b, CC.WithArity ar cc) -> do
+ else forM (Map.toList (CC.conBranches nc)) $ \(b, CC.WithArity ar cc) -> do
arit <- getConArity b -- Andreas, 2012-10-12: is the constructor arity @ar@ from Agda the same as the one from the Epic backen?
tag <- getConstrTag b
vars <- replicateM arit newName
diff --git a/src/full/Agda/Compiler/Epic/Injection.hs b/src/full/Agda/Compiler/Epic/Injection.hs
index 36f37fa..2ce0887 100644
--- a/src/full/Agda/Compiler/Epic/Injection.hs
+++ b/src/full/Agda/Compiler/Epic/Injection.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE OverlappingInstances #-}
@@ -10,12 +10,14 @@ module Agda.Compiler.Epic.Injection where
import Control.Monad.State
import Control.Monad.Reader
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import Data.List
-import Data.Map(Map)
-import qualified Data.Map as M
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Maybe
-import Data.Set(Set)
-import qualified Data.Set as S
+import Data.Set (Set)
+import qualified Data.Set as Set
import Agda.Syntax.Common
import Agda.Syntax.Internal as I
@@ -35,8 +37,9 @@ import qualified Agda.Utils.HashMap as HM
import Agda.Compiler.Epic.CompileState
import Agda.Compiler.Epic.Interface as Interface
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+import Agda.Utils.Lens
-- | Find potentially injective functions, solve constraints to fix some constructor
-- tags and make functions whose constraints are fulfilled injections
@@ -45,13 +48,13 @@ findInjection defs = do
funs <- forM defs $ \(name, def) -> case theDef def of
f@(Function{}) -> isInjective name (funClauses f)
_ -> return Nothing
- newNames <- M.keys <$> gets (Interface.conArity . curModule)
+ newNames <- Map.keys <$> gets (Interface.conArity . curModule)
injFuns <- solve newNames (catMaybes funs)
defs' <- forM defs $ \(q, def) -> case q `isIn` injFuns of
Nothing -> return (q, def)
Just inj@(InjectiveFun nvar arity) -> case theDef def of
f@(Function{}) -> do
- modifyEI $ \s -> s { injectiveFuns = M.insert q inj (injectiveFuns s) }
+ modifyEI $ \s -> s { injectiveFuns = Map.insert q inj (injectiveFuns s) }
let ns = replicate arity (defaultArg empty)
return $ (,) q $ def { theDef = f { funCompiled = Just $ Done ns $
var $ arity - nvar - 1 } }
@@ -65,11 +68,9 @@ findInjection defs = do
(_,x):_ -> Just x
replaceFunCC :: QName -> CompiledClauses -> Compile TCM ()
-replaceFunCC name cc = do
- lift $ modify $ \s ->
- s { stSignature = (stSignature s) { sigDefinitions = HM.adjust replaceDef name (sigDefinitions (stSignature s)) }
- , stImports = (stImports s) { sigDefinitions = HM.adjust replaceDef name (sigDefinitions (stImports s)) }
- }
+replaceFunCC name cc = lift $ do
+ stSignature %= \sig -> sig {sigDefinitions = HM.adjust replaceDef name (sigDefinitions sig)}
+ stImports %= \imp -> imp {sigDefinitions = HM.adjust replaceDef name (sigDefinitions imp)}
where
replaceDef :: Definition -> Definition
replaceDef def = case theDef def of
@@ -154,8 +155,8 @@ isInjectiveHere nam idx clause = do
lift $ reportSLn "epic.injection" 40 "reduced body"
injFs <- gets (injectiveFuns . importedModules)
lift $ reportSLn "epic.injection" 40 "calculated injFs"
- res <- (t' <: body') `runReaderT` (M.insert nam (InjectiveFun idx
- (length (clausePats clause))) injFs)
+ res <- (t' <: body') `runReaderT` (Map.insert nam (InjectiveFun idx
+ (length (clausePats clause))) injFs)
lift $ reportSDoc "epic.injection" 20 $ vcat
[ text "isInjective:" <+> text (show nam)
, text "at Index :" <+> text (show idx)
@@ -194,7 +195,7 @@ solve newNames xs = do
sep $ text "Epic.Injection.solve" : map prettyTCM newNames
-- Only primitive lists should be in the current module at this point,
-- but we still want them
- conGraph <- M.union <$> gets (constrTags . curModule) <*> gets (constrTags . importedModules)
+ conGraph <- Map.union <$> gets (constrTags . curModule) <*> gets (constrTags . importedModules)
(funs, mconstr) <- ($ xs) $ flip foldM ([] , Just $ initialTags conGraph newNames) $ \ (xs , prev) (fun , con) -> do
m <- foldM solvable prev con
return $ case m of
@@ -212,22 +213,22 @@ solve newNames xs = do
updateTags :: Tags -> Compile TCM ()
updateTags tags = do
- let (hasTags, eqs) = M.partition isTag (constrGroup tags)
+ let (hasTags, eqs) = Map.partition isTag (constrGroup tags)
isTag (IsTag _) = True
isTag _ = False
- forM (M.toList hasTags) $ \ (c, tagged) -> case tagged of
+ forM (Map.toList hasTags) $ \ (c, tagged) -> case tagged of
IsTag tag -> putCon c tag
_ -> __IMPOSSIBLE__
- case M.toList eqs of
+ case Map.toList eqs of
(c, Same n) : _ -> do
- let grp = eqGroups tags !!!! n
- tag <- assignConstrTag' c (S.toList grp)
+ let grp = fromMaybe __IMPOSSIBLE__ $ IntMap.lookup n $ eqGroups tags
+ tag <- assignConstrTag' c (Set.toList grp)
updateTags . fromMaybe __IMPOSSIBLE__ =<< setTag n tag tags { constrGroup = eqs }
_ -> return ()
putCon :: QName -> Tag -> Compile TCM ()
putCon con tag = do
m <- gets (constrTags . importedModules)
- case M.lookup con m of
+ case Map.lookup con m of
Nothing -> putConstrTag con tag
Just _ -> return () -- old
@@ -251,7 +252,7 @@ unionConstraints (Just c : cs) = do
-- Precondition: t1 is normalised, t2 is in WHNF
-- When reducing t2, it may become a literal, which makes this not work in some cases...
class Injectible a where
- (<:) :: a -> a -> ReaderT (QName :-> InjectiveFun) (Compile TCM) InjConstraints
+ (<:) :: a -> a -> ReaderT (Map QName InjectiveFun) (Compile TCM) InjConstraints
instance Injectible a => Injectible (I.Arg a) where
a1 <: a2 = unArg a1 <: unArg a2
@@ -286,7 +287,7 @@ instance Injectible Term where
(_, Lit l) | litInt l -> do
l' <- lift . lift $ litToCon l
t1 <: l'
- (_, Def n2 es2) | Just (InjectiveFun argn arit) <- M.lookup n2 injs -> do
+ (_, Def n2 es2) | Just (InjectiveFun argn arit) <- Map.lookup n2 injs -> do
if genericLength es2 /= arit
then return Nothing
else do
@@ -305,7 +306,7 @@ instance Injectible Term where
args1' <: args2'
_ -> return Nothing
{-
- (_, Def n2 args2) | Just (InjectiveFun argn arit) <- M.lookup n2 injs -> do
+ (_, Def n2 args2) | Just (InjectiveFun argn arit) <- Map.lookup n2 injs -> do
if genericLength args2 /= arit
then return Nothing
else do
@@ -335,14 +336,14 @@ data TagEq
deriving Eq
data Tags = Tags
- { eqGroups :: Int :-> Set QName
- , constrGroup :: QName :-> TagEq
+ { eqGroups :: IntMap (Set QName)
+ , constrGroup :: Map QName TagEq
}
initialTags :: Map QName Tag -> [QName] -> Tags
initialTags setTags newNames = Tags
- { eqGroups = M.fromList $ zip [0..] (map S.singleton newNames)
- , constrGroup = M.map IsTag setTags `M.union` M.fromList (zip newNames (map Same [0..]))
+ { eqGroups = IntMap.fromList $ zip [0..] (map Set.singleton newNames)
+ , constrGroup = Map.map IsTag setTags `Map.union` Map.fromList (zip newNames (map Same [0..]))
}
unify :: QName -> QName -> Tags -> Compile TCM (Maybe Tags)
@@ -359,20 +360,22 @@ unify c1 c2 ts = do
setTag :: Int -> Tag -> Tags -> Compile TCM (Maybe Tags)
setTag gid tag ts = return $ Just $ ts
- { constrGroup = foldr (\c -> M.insert c (IsTag tag)) (constrGroup ts) (S.toList $ eqGroups ts !!!! gid)}
+ { constrGroup = foldr (\ c -> Map.insert c (IsTag tag))
+ (constrGroup ts)
+ (Set.toList $ fromMaybe __IMPOSSIBLE__ $ IntMap.lookup gid $ eqGroups ts) }
mergeGroups :: Int -> Int -> Tags -> Compile TCM (Maybe Tags)
mergeGroups n1 n2 ts = do
- let g1s = eqGroups ts !!!! n1
- g2s = eqGroups ts !!!! n2
- gs = S.union g1s g2s
- g1l = S.toList g1s
- g2l = S.toList g2s
+ let g1s = fromMaybe __IMPOSSIBLE__ $ IntMap.lookup n1 $ eqGroups ts
+ g2s = fromMaybe __IMPOSSIBLE__ $ IntMap.lookup n2 $ eqGroups ts
+ gs = Set.union g1s g2s
+ g1l = Set.toList g1s
+ g2l = Set.toList g2s
ifNotM (andM $ zipWith unifiable g1l g2l)
(return Nothing) $
return $ Just $ ts
- { eqGroups = M.delete n2 $ M.insert n1 gs (eqGroups ts)
- , constrGroup = M.fromList [ (e2, Same n1) | e2 <- g2l ] `M.union` constrGroup ts
+ { eqGroups = IntMap.delete n2 $ IntMap.insert n1 gs (eqGroups ts)
+ , constrGroup = Map.fromList [ (e2, Same n1) | e2 <- g2l ] `Map.union` constrGroup ts
}
unifiable :: QName -> QName -> Compile TCM Bool
@@ -381,7 +384,7 @@ unifiable c1 c2 = do
d2 <- getConData c2
return $ d1 /= d2
-(!!!!) :: Ord k => k :-> v -> k -> v
-m !!!! k = case M.lookup k m of
+(!!!!) :: Ord k => Map k v -> k -> v
+m !!!! k = case Map.lookup k m of
Nothing -> __IMPOSSIBLE__
Just x -> x
diff --git a/src/full/Agda/Compiler/Epic/Interface.hs b/src/full/Agda/Compiler/Epic/Interface.hs
index 67455b3..876f7ce 100644
--- a/src/full/Agda/Compiler/Epic/Interface.hs
+++ b/src/full/Agda/Compiler/Epic/Interface.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+
-- | Epic interface data structure, which is serialisable and stored for each
-- compiled file
module Agda.Compiler.Epic.Interface where
@@ -8,7 +9,7 @@ import Control.Monad
import Data.Function
import Data.Map(Map)
import Data.Monoid
-import Data.Set(Set)
+import Data.Set (Set)
import Data.Typeable
import Agda.Syntax.Common (Nat)
diff --git a/src/full/Agda/Compiler/Epic/NatDetection.hs b/src/full/Agda/Compiler/Epic/NatDetection.hs
index 743ef04..705b007 100644
--- a/src/full/Agda/Compiler/Epic/NatDetection.hs
+++ b/src/full/Agda/Compiler/Epic/NatDetection.hs
@@ -23,14 +23,15 @@ import Agda.Compiler.Epic.Interface
import qualified Agda.Utils.HashMap as HM
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+import Agda.Utils.Lens
-- | Get a list of all the datatypes that look like nats. The [QName] is on the
-- form [zeroConstr, sucConstr]
getNatish :: Compile TCM [(ForcedArgs, [QName])]
getNatish = do
- sig <- lift (gets (sigDefinitions . stImports))
+ sig <- lift (sigDefinitions <$> use stImports)
let defs = HM.toList sig
fmap catMaybes $ forM defs $ \(q, def) ->
case theDef def of
@@ -48,7 +49,7 @@ isNatish q d = do -- A datatype ...
z <- zip constrs <$> mapM getForcedArgs constrs
case sortBy (compare `on` nrRel . snd) z of
[(cz,fz), (cs,fs)] -> do
- sig <- lift (gets (sigDefinitions . stImports))
+ sig <- lift (sigDefinitions <$> use stImports)
let ts = defType $ sig HM.! cs
nr = dataPars d
return $ do
diff --git a/src/full/Agda/Compiler/Epic/Primitive.hs b/src/full/Agda/Compiler/Epic/Primitive.hs
index a6c9a34..a470c59 100644
--- a/src/full/Agda/Compiler/Epic/Primitive.hs
+++ b/src/full/Agda/Compiler/Epic/Primitive.hs
@@ -7,8 +7,8 @@ module Agda.Compiler.Epic.Primitive where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
-import Data.Map(Map)
-import qualified Data.Map as M
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Maybe
import Agda.Syntax.Internal(QName)
@@ -22,9 +22,11 @@ import Agda.Compiler.Epic.CompileState
import Agda.Compiler.Epic.Interface
import Agda.Compiler.Epic.NatDetection
-#include "../../undefined.h"
+import Agda.Utils.List
import Agda.Utils.Impossible
+#include "undefined.h"
+
{- Stacken, Heapen -- Optimizern -}
data PrimTransform = PrimTF
@@ -97,31 +99,29 @@ getBuiltins =
if b then return $ Just (transf names) else return Nothing
else return Nothing
+defName :: T.Term -> QName
defName (T.Def q []) = q
defName (T.Con q []) = T.conName q
defName _ = __IMPOSSIBLE__
-head'' (x:xs) e = x
-head'' _ e = e
-
-- | Translation to primitive integer functions
natPrimTF :: ForcedArgs -> [QName] -> PrimTransform
natPrimTF filt [zero, suc] = PrimTF
- { mapCon = M.fromList [(zero, prZero), (suc, prSuc)]
+ { mapCon = Map.fromList [(zero, prZero), (suc, prSuc)]
, translateCase = \ce brs -> case brs of
-- Assuming only the first two branches are relevant when casing on Nats
(Branch _ n vs e:Branch _ _n' vs'' e'':_) ->
if n == zero
- then primNatCaseZS ce e (head'' vs'' __IMPOSSIBLE__) e''
- else primNatCaseZS ce e'' (head'' vs __IMPOSSIBLE__) e
+ then primNatCaseZS ce e (headWithDefault __IMPOSSIBLE__ vs'') e''
+ else primNatCaseZS ce e'' (headWithDefault __IMPOSSIBLE__ vs) e
(Branch _ n vs e:Default e'':_) ->
if n == zero
then primNatCaseZD ce e e'' -- zero
- else primNatCaseZS ce e'' (head'' vs __IMPOSSIBLE__) e -- suc
+ else primNatCaseZS ce e'' (headWithDefault __IMPOSSIBLE__ vs) e -- suc
[ Branch _ n vs e ] ->
if n == zero
then e
- else lett (head'' vs __IMPOSSIBLE__) (App prPred [ce]) e
+ else lett (headWithDefault __IMPOSSIBLE__ vs) (App prPred [ce]) e
_ -> __IMPOSSIBLE__
}
natPrimTF _ _ = __IMPOSSIBLE__
@@ -145,7 +145,7 @@ primNatCaseZD n zeroBr defBr = If (App prNatEquality [n, Var prZero]) zeroBr def
-- | Translation to primitive bool functions
boolPrimTF :: [QName] -> PrimTransform
boolPrimTF [true, false] = PrimTF
- { mapCon = M.fromList [(true, prTrue), (false, prFalse)]
+ { mapCon = Map.fromList [(true, prTrue), (false, prFalse)]
, translateCase = \ce brs ->
case brs of
(Branch _ n _vs e:b':_) ->
@@ -189,7 +189,7 @@ primExpr prim ex = case ex of
-- case, otherwise Nothing.
testCon :: [PrimTransform] -> QName -> Maybe Var
testCon [] _ = Nothing
- testCon (p : ps) k = M.lookup k (mapCon p) `mplus` testCon ps k
+ testCon (p : ps) k = Map.lookup k (mapCon p) `mplus` testCon ps k
-- | Test if we should transform the case, based on the branches. Returns
-- the (first) PrimTransform that is applicable.
@@ -201,7 +201,7 @@ primExpr prim ex = case ex of
-- Returns the PrimTransform in that case.
check :: PrimTransform -> Branch -> Maybe PrimTransform
check p br = case br of
- Branch _ n _ _ -> fmap (const p) $ M.lookup n (mapCon p)
+ Branch _ n _ _ -> fmap (const p) $ Map.lookup n (mapCon p)
BrInt _ _ -> Nothing
Default _ -> Nothing
diff --git a/src/full/Agda/Compiler/Epic/Smashing.hs b/src/full/Agda/Compiler/Epic/Smashing.hs
index b16f734..1d923b3 100644
--- a/src/full/Agda/Compiler/Epic/Smashing.hs
+++ b/src/full/Agda/Compiler/Epic/Smashing.hs
@@ -10,8 +10,8 @@ import Control.Monad.State
import Data.List
import Data.Maybe
-import qualified Data.Set as S
import Data.Set (Set)
+import qualified Data.Set as Set
import Agda.Syntax.Common
import Agda.Syntax.Internal as SI
@@ -25,11 +25,12 @@ import Agda.Compiler.Epic.AuxAST as AA
import Agda.Compiler.Epic.CompileState
import Agda.Compiler.Epic.Interface
+import Agda.Utils.Lens
import Agda.Utils.Monad
import Agda.Utils.Size
import qualified Agda.Utils.HashMap as HM
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
defnPars :: Integral n => Defn -> n
@@ -40,7 +41,7 @@ defnPars d = 0
-- | Main function, smash as much as possible
smash'em :: [Fun] -> Compile TCM [Fun]
smash'em funs = do
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
funs' <- forM funs $ \f -> case f of
AA.Fun{} -> case funQName f >>= flip HM.lookup defs of
Nothing -> do
@@ -71,10 +72,10 @@ xs +++ ys = unflattenTel names $ map (raise (size ys)) (flattenTel xs) ++ flatte
-- | Can a datatype be inferred? If so, return the only possible value.
inferable :: Set QName -> QName -> [SI.Arg Term] -> Compile TCM (Maybe Expr)
-inferable visited dat args | dat `S.member` visited = return Nothing
+inferable visited dat args | dat `Set.member` visited = return Nothing
inferable visited dat args = do
lift $ reportSLn "epic.smashing" 10 $ " inferring:" ++ (show dat)
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
let def = fromMaybe __IMPOSSIBLE__ $ HM.lookup dat defs
case theDef def of
d at Datatype{} -> do
@@ -90,7 +91,7 @@ inferable visited dat args = do
return Nothing
where
inferableArgs c pars = do
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
let def = fromMaybe __IMPOSSIBLE__ $ HM.lookup c defs
forc <- getForcedArgs c
TelV tel _ <- lift $ telView (defType def `apply` genericTake pars args)
@@ -101,8 +102,9 @@ inferable visited dat args = do
, text "constr:" <+> prettyTCM c
]
(AA.Con tag c <$>) <$> sequence <$> forM (notForced forc $ flattenTel tel) (inferableTerm visited' . unEl . unDom)
- visited' = S.insert dat visited
+ visited' = Set.insert dat visited
+inferableTerm :: Set QName -> Term -> Compile TCM (Maybe Expr)
inferableTerm visited t = do
case t of
Def q es ->
@@ -118,11 +120,11 @@ inferableTerm visited t = do
-- | Find the only possible value for a certain type. If we fail return Nothing
smashable :: Int -> Type -> Compile TCM (Maybe Expr)
smashable origArity typ = do
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
TelV tele retType <- lift $ telView typ
retType' <- return retType -- lift $ reduce retType
- inf <- inferableTerm S.empty (unEl retType')
+ inf <- inferableTerm Set.empty (unEl retType')
lift $ reportSDoc "epic.smashing" 10 $ nest 2 $ vcat
[ text "Result is"
, text "inf: " <+> (text . show) inf
diff --git a/src/full/Agda/Compiler/Epic/Static.hs b/src/full/Agda/Compiler/Epic/Static.hs
index 22747c7..bb91fe7 100644
--- a/src/full/Agda/Compiler/Epic/Static.hs
+++ b/src/full/Agda/Compiler/Epic/Static.hs
@@ -1,17 +1,16 @@
--- | Find the places where the builtin static is used and do some normalisation
--- there.
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
+-- | Find the places where the builtin static is used and do some normalisation
+-- there.
module Agda.Compiler.Epic.Static where
import Control.Applicative
import Control.Monad
import Control.Monad.State
-import qualified Data.Map as M
+import qualified Data.Map as Map
import Data.Traversable (traverse)
import Agda.Syntax.Common
@@ -30,8 +29,9 @@ import qualified Agda.Utils.HashMap as HM
import Agda.Compiler.Epic.CompileState
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+import Agda.Utils.Lens
normaliseStatic :: CompiledClauses -> Compile TCM CompiledClauses
normaliseStatic = evaluateCC
@@ -39,14 +39,14 @@ normaliseStatic = evaluateCC
evaluateCC :: CompiledClauses -> Compile TCM CompiledClauses
evaluateCC ccs = case ccs of
Case n brs -> do
- cbrs <- forM (M.toList $ conBranches brs) $ \(c, WithArity n cc) -> (,) c <$> (WithArity n <$> evaluateCC cc)
- lbrs <- forM (M.toList $ litBranches brs) $ \(l, cc) -> (,) l <$> evaluateCC cc
+ cbrs <- forM (Map.toList $ conBranches brs) $ \(c, WithArity n cc) -> (,) c <$> (WithArity n <$> evaluateCC cc)
+ lbrs <- forM (Map.toList $ litBranches brs) $ \(l, cc) -> (,) l <$> evaluateCC cc
cab <- case catchAllBranch brs of
Nothing -> return Nothing
Just cc -> Just <$> evaluateCC cc
return $ Case n Branches
- { conBranches = M.fromList cbrs
- , litBranches = M.fromList lbrs
+ { conBranches = Map.fromList cbrs
+ , litBranches = Map.fromList lbrs
, catchAllBranch = cab
}
Done n t -> Done n <$> evaluate t
@@ -54,7 +54,7 @@ evaluateCC ccs = case ccs of
etaExpand :: Term -> Compile TCM Term
etaExpand def@(Def n ts) = do
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
let f = maybe __IMPOSSIBLE__ theDef (HM.lookup n defs)
len = length . clausePats . head . funClauses $ f
toEta :: Num a => a
@@ -115,7 +115,7 @@ instance Evaluate Term where
-}
isStatic :: QName -> Compile TCM Bool
isStatic q = do
- defs <- lift (gets (sigDefinitions . stImports))
+ defs <- lift (sigDefinitions <$> use stImports)
return $ case fmap theDef $ HM.lookup q defs of
Nothing -> False
Just (f at Function{}) -> funStatic f
diff --git a/src/full/Agda/Compiler/HaskellTypes.hs b/src/full/Agda/Compiler/HaskellTypes.hs
index 924c613..ca0a5a1 100644
--- a/src/full/Agda/Compiler/HaskellTypes.hs
+++ b/src/full/Agda/Compiler/HaskellTypes.hs
@@ -6,7 +6,6 @@
module Agda.Compiler.HaskellTypes where
import Control.Applicative
-import Control.Monad.Error
import Data.Maybe (fromMaybe)
import Agda.Syntax.Common
@@ -18,9 +17,11 @@ import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Free
-#include "../undefined.h"
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Impossible
+#include "undefined.h"
+
type HaskellKind = String
hsStar :: HaskellKind
diff --git a/src/full/Agda/Compiler/JS/Case.hs b/src/full/Agda/Compiler/JS/Case.hs
index f758f4a..22e708c 100644
--- a/src/full/Agda/Compiler/JS/Case.hs
+++ b/src/full/Agda/Compiler/JS/Case.hs
@@ -14,7 +14,7 @@ import Agda.Compiler.JS.Syntax
LocalId(LocalId), MemberId )
import Agda.Compiler.JS.Substitution ( shiftFrom )
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible ( Impossible(Impossible), throwImpossible )
-- ECMAScript doesn't support pattern-mathching case, so
diff --git a/src/full/Agda/Compiler/JS/Compiler.hs b/src/full/Agda/Compiler/JS/Compiler.hs
index c4531c4..7a758a1 100644
--- a/src/full/Agda/Compiler/JS/Compiler.hs
+++ b/src/full/Agda/Compiler/JS/Compiler.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module Agda.Compiler.JS.Compiler where
@@ -21,10 +21,11 @@ import Agda.Syntax.Common ( Nat, unArg, namedArg )
import Agda.Syntax.Concrete.Name ( projectRoot )
import Agda.Syntax.Abstract.Name
( ModuleName(MName), QName,
+ mnameToConcrete,
mnameToList, qnameName, qnameModule, isInModule, nameId )
import Agda.Syntax.Internal
( Name, Args, Type,
- Clause, Pattern(VarP,DotP,LitP,ConP,ProjP),
+ Clause, Pattern, Pattern'(VarP,DotP,LitP,ConP,ProjP),
ClauseBodyF(Body,NoBody,Bind),ClauseBody,
Term(Var,Lam,Lit,Level,Def,Con,Pi,Sort,MetaV,DontCare,Shared,ExtLam),
unSpine, allApplyElims,
@@ -52,6 +53,7 @@ import Agda.TypeChecking.Reduce ( instantiateFull, normalise )
import Agda.Utils.FileName ( filePath )
import Agda.Utils.Function ( iterate' )
import Agda.Utils.Monad ( (<$>), (<*>), ifM )
+import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.IO.UTF8 ( writeFile )
import qualified Agda.Utils.HashMap as HMap
import Agda.Compiler.MAlonzo.Misc ( curDefs, curIF, curMName, setInterface )
@@ -66,7 +68,7 @@ import Agda.Compiler.JS.Substitution
import Agda.Compiler.JS.Case ( Tag(Tag), Case(Case), Patt(VarPatt,Tagged), lambda )
import Agda.Compiler.JS.Pretty ( pretty )
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible ( Impossible(Impossible), throwImpossible )
--------------------------------------------------
@@ -96,21 +98,23 @@ compilerMain mainI =
compile :: Interface -> TCM ()
compile i = do
setInterface i
- ifM uptodate noComp $ (yesComp >>) $ do
+ ifM uptodate noComp $ do
+ yesComp
writeModule =<< curModule
where
uptodate = liftIO =<< (isNewerThan <$> outFile_ <*> ifile)
ifile = maybe __IMPOSSIBLE__ filePath <$>
(findInterfaceFile . toTopLevelModuleName =<< curMName)
- noComp = reportSLn "" 1 . (++ " : no compilation is needed.").show =<< curMName
+ noComp = reportSLn "" 1 . (++ " : no compilation is needed.") . prettyShow =<< curMName
yesComp = reportSLn "" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<
- sequence [show <$> curMName, ifile, outFile_] :: TCM ()
+ sequence [prettyShow <$> curMName, ifile, outFile_] :: TCM ()
--------------------------------------------------
-- Naming
--------------------------------------------------
-prefix = "jAgda"
+prefix :: [Char]
+prefix = "jAgda"
jsMod :: ModuleName -> GlobalId
jsMod m = GlobalId (prefix : map show (mnameToList m))
diff --git a/src/full/Agda/Compiler/JS/Syntax.hs b/src/full/Agda/Compiler/JS/Syntax.hs
index f361e89..bcbaf7c 100644
--- a/src/full/Agda/Compiler/JS/Syntax.hs
+++ b/src/full/Agda/Compiler/JS/Syntax.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+
module Agda.Compiler.JS.Syntax where
import Data.Typeable ( Typeable )
diff --git a/src/full/Agda/Compiler/MAlonzo/Compiler.hs b/src/full/Agda/Compiler/MAlonzo/Compiler.hs
index 06598f4..335499b 100644
--- a/src/full/Agda/Compiler/MAlonzo/Compiler.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Compiler.hs
@@ -1,17 +1,23 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.MAlonzo.Compiler where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.State
-import Data.List as L
-import Data.Map as M
-import Data.Set as S
+
+import Data.Generics.Geniplate
+import Data.List as List
+import Data.Map as Map
+import Data.Set as Set
+
import qualified Language.Haskell.Exts.Extension as HS
import qualified Language.Haskell.Exts.Parser as HS
+import qualified Language.Haskell.Exts.Pretty as HS
import qualified Language.Haskell.Exts.Syntax as HS
+
import System.Directory (createDirectoryIfMissing)
import System.FilePath hiding (normalise)
@@ -19,13 +25,17 @@ import Agda.Compiler.CallCompiler
import Agda.Compiler.MAlonzo.Misc
import Agda.Compiler.MAlonzo.Pretty
import Agda.Compiler.MAlonzo.Primitives
+
import Agda.Interaction.FindFile
import Agda.Interaction.Imports
import Agda.Interaction.Options
+
import Agda.Syntax.Common
-import qualified Agda.Syntax.Concrete.Name as CN
+import qualified Agda.Syntax.Abstract.Name as A
+import qualified Agda.Syntax.Concrete.Name as C
import Agda.Syntax.Internal as I
import Agda.Syntax.Literal
+
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Reduce
@@ -33,12 +43,15 @@ import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Level (reallyUnLevelView)
+
import Agda.Utils.FileName
+import Agda.Utils.Lens
import Agda.Utils.Monad
+import Agda.Utils.Pretty (prettyShow)
import qualified Agda.Utils.IO.UTF8 as UTF8
import qualified Agda.Utils.HashMap as HMap
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
compilerMain :: Bool -> Interface -> TCM ()
@@ -56,28 +69,29 @@ compilerMain modIsMain mainI =
-- The default output directory is the project root.
let tm = toTopLevelModuleName $ iModuleName mainI
f <- findFile tm
- return $ filePath $ CN.projectRoot f tm
+ return $ filePath $ C.projectRoot f tm
setCommandLineOptions $
opts { optCompileDir = Just compileDir }
ignoreAbstractMode $ do
- mapM_ (compile . miInterface) =<< (M.elems <$> getVisitedModules)
+ mapM_ (compile . miInterface) =<< (Map.elems <$> getVisitedModules)
writeModule rteModule
callGHC modIsMain mainI
compile :: Interface -> TCM ()
compile i = do
setInterface i
- ifM uptodate noComp $ (yesComp >>) $ do
+ ifM uptodate noComp $ {- else -} do
+ yesComp
writeModule =<< decl <$> curHsMod <*> (definitions =<< curDefs) <*> imports
where
decl mn ds imp = HS.Module dummy mn [] Nothing Nothing imp ds
uptodate = liftIO =<< (isNewerThan <$> outFile_ <*> ifile)
ifile = maybe __IMPOSSIBLE__ filePath <$>
(findInterfaceFile . toTopLevelModuleName =<< curMName)
- noComp = reportSLn "" 1 . (++ " : no compilation is needed.").show =<< curMName
+ noComp = reportSLn "" 1 . (++ " : no compilation is needed.") . show . A.mnameToConcrete =<< curMName
yesComp = reportSLn "" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<
- sequence [show <$> curMName, ifile, outFile_] :: TCM ()
+ sequence [show . A.mnameToConcrete <$> curMName, ifile, outFile_] :: TCM ()
--------------------------------------------------
-- imported modules
@@ -87,15 +101,27 @@ compile i = do
imports :: TCM [HS.ImportDecl]
imports = (++) <$> hsImps <*> imps where
- hsImps = (L.map decl . S.toList .
- S.insert mazRTE . S.map HS.ModuleName) <$>
+ hsImps :: TCM [HS.ImportDecl]
+ hsImps = (List.map decl . Set.toList .
+ Set.insert mazRTE . Set.map HS.ModuleName) <$>
getHaskellImports
- imps = L.map decl . uniq <$>
- ((++) <$> importsForPrim <*> (L.map mazMod <$> mnames))
+
+ imps :: TCM [HS.ImportDecl]
+ imps = List.map decl . uniq <$>
+ ((++) <$> importsForPrim <*> (List.map mazMod <$> mnames))
+
+ decl :: HS.ModuleName -> HS.ImportDecl
+#if MIN_VERSION_haskell_src_exts(1,16,0)
+ decl m = HS.ImportDecl dummy m True False False Nothing Nothing Nothing
+#else
decl m = HS.ImportDecl dummy m True False Nothing Nothing Nothing
- mnames = (++) <$> (S.elems <$> gets stImportedModules)
- <*> (L.map fst . iImportedModules <$> curIF)
- uniq = L.map head . group . L.sort
+#endif
+ mnames :: TCM [ModuleName]
+ mnames = (++) <$> (Set.elems <$> use stImportedModules)
+ <*> (List.map fst . iImportedModules <$> curIF)
+
+ uniq :: [HS.ModuleName] -> [HS.ModuleName]
+ uniq = List.map head . group . List.sort
--------------------------------------------------
-- Main compiling clauses
@@ -150,10 +176,10 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
b = ihname "a" 1
vars = [a, b]
return [ HS.TypeDecl dummy infT
- (L.map HS.UnkindedVar vars)
+ (List.map HS.UnkindedVar vars)
(HS.TyVar b)
, HS.FunBind [HS.Match dummy infV
- (L.map HS.PVar vars) Nothing
+ (List.map HS.PVar vars) Nothing
(HS.UnGuardedRhs HS.unit_con)
(HS.BDecls [])]
]
@@ -239,7 +265,7 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
(HS.UnGuardedRhs $ e) (HS.BDecls [])]]
axiomErr :: HS.Exp
- axiomErr = rtmError $ "postulate evaluated: " ++ show q
+ axiomErr = rtmError $ "postulate evaluated: " ++ show (A.qnameToConcrete q)
checkConstructorType :: QName -> TCM [HS.Decl]
checkConstructorType q = do
@@ -256,7 +282,11 @@ checkCover q ty n cs = do
(a, _) <- conArityAndPars c
Just (HsDefn _ hsc) <- compiledHaskell . defCompiledRep <$> getConstInfo c
let pat = HS.PApp (HS.UnQual $ HS.Ident hsc) $ genericReplicate a HS.PWildCard
+#if MIN_VERSION_haskell_src_exts(1,16,0)
+ return $ HS.Alt dummy pat (HS.UnGuardedRhs $ HS.unit_con) (HS.BDecls [])
+#else
return $ HS.Alt dummy pat (HS.UnGuardedAlt $ HS.unit_con) (HS.BDecls [])
+#endif
cs <- mapM makeClause cs
let rhs = case cs of
[] -> fakeExp "()" -- There is no empty case statement in Haskell
@@ -280,11 +310,11 @@ clause :: QName -> Maybe String -> (Nat, Bool, Clause) -> TCM HS.Decl
clause q maybeName (i, isLast, Clause{ namedClausePats = ps, clauseBody = b }) =
HS.FunBind . (: cont) <$> main where
main = match <$> argpatts ps (bvars b (0::Nat)) <*> clausebody b
- cont | isLast && any isCon ps = [match (L.map HS.PVar cvs) failrhs]
+ cont | isLast && any isCon ps = [match (List.map HS.PVar cvs) failrhs]
| isLast = []
- | otherwise = [match (L.map HS.PVar cvs) crhs]
- cvs = L.map (ihname "v") [0 .. genericLength ps - 1]
- crhs = hsCast$ L.foldl HS.App (hsVarUQ $ dsubname q (i + 1)) (L.map hsVarUQ cvs)
+ | otherwise = [match (List.map HS.PVar cvs) crhs]
+ cvs = List.map (ihname "v") [0 .. genericLength ps - 1]
+ crhs = hsCast$ List.foldl HS.App (hsVarUQ $ dsubname q (i + 1)) (List.map hsVarUQ cvs)
failrhs = rtmIncompleteMatch q -- Andreas, 2011-11-16 call to RTE instead of inlined error
-- failrhs = rtmError $ "incomplete pattern matching: " ++ show q
match hps rhs = HS.Match dummy (maybe (dsubname q i) HS.Ident maybeName) hps Nothing
@@ -302,16 +332,22 @@ clause q maybeName (i, isLast, Clause{ namedClausePats = ps, clauseBody = b }) =
argpatts :: [I.NamedArg Pattern] -> [HS.Pat] -> TCM [HS.Pat]
argpatts ps0 bvs = evalStateT (mapM pat' ps0) bvs
where
+ pat :: Pattern -> StateT [HS.Pat] TCM HS.Pat
pat (ProjP _ ) = lift $ typeError $ NotImplemented $ "Compilation of copatterns"
pat (VarP _ ) = do v <- gets head; modify tail; return v
pat (DotP _ ) = pat (VarP dummy) -- WHY NOT: return HS.PWildCard -- SEE ABOVE
+#if MIN_VERSION_haskell_src_exts(1,16,0)
+ pat (LitP l ) = return $ HS.PLit HS.Signless $ hslit l
+#else
pat (LitP l ) = return $ HS.PLit $ hslit l
+#endif
pat p@(ConP c _ ps) = do
-- Note that irr is applied once for every subpattern, so in the
-- worst case it is quadratic in the size of the pattern. I
-- suspect that this will not be a problem in practice, though.
irrefutable <- lift $ irr p
- let tilde = if tildesEnabled && irrefutable
+ let tilde :: HS.Pat -> HS.Pat
+ tilde = if tildesEnabled && irrefutable
then HS.PParen . HS.PIrrPat
else id
(tilde . HS.PParen) <$>
@@ -326,6 +362,7 @@ argpatts ps0 bvs = evalStateT (mapM pat' ps0) bvs
-- do not match against irrelevant stuff
pat' a | isIrrelevant a = return $ HS.PWildCard
-}
+ pat' :: I.NamedArg Pattern -> StateT [HS.Pat] TCM HS.Pat
pat' a = pat $ namedArg a
tildesEnabled = False
@@ -338,9 +375,10 @@ argpatts ps0 bvs = evalStateT (mapM pat' ps0) bvs
irr (LitP {}) = return False
irr (ConP c _ ps) =
(&&) <$> singleConstructorType (conName c)
- <*> (andM $ L.map irr' ps)
+ <*> (andM $ List.map irr' ps)
-- | Irrelevant patterns are naturally irrefutable.
+ irr' :: I.NamedArg Pattern -> TCM Bool
irr' a | isIrrelevant a = return $ True
irr' a = irr $ namedArg a
@@ -422,7 +460,11 @@ condecl q = do
cdecl :: QName -> Nat -> HS.ConDecl
cdecl q n = HS.ConDecl (unqhname "C" q)
- [ HS.UnBangedTy $ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1]]
+#if MIN_VERSION_haskell_src_exts(1,16,0)
+ [ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ]
+#else
+ [ HS.UnBangedTy $ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ]
+#endif
tvaldecl :: QName
-> Induction
@@ -432,7 +474,7 @@ tvaldecl q ind ntv npar cds cl =
HS.FunBind [HS.Match dummy vn pvs Nothing
(HS.UnGuardedRhs HS.unit_con) (HS.BDecls [])] :
maybe [HS.DataDecl dummy kind [] tn tvs
- (L.map (HS.QualConDecl dummy [] []) cds) []]
+ (List.map (HS.QualConDecl dummy [] []) cds) []]
(const []) cl
where
(tn, vn) = (unqhname "T" q, unqhname "d" q)
@@ -447,7 +489,7 @@ tvaldecl q ind ntv npar cds cl =
_ -> HS.DataType
infodecl :: QName -> HS.Decl
-infodecl q = fakeD (unqhname "name" q) $ show (show q)
+infodecl q = fakeD (unqhname "name" q) $ show $ prettyShow q
--------------------------------------------------
-- Inserting unsafeCoerce
@@ -465,15 +507,17 @@ hsCast = addcast . go where
-}
hsCast e = mazCoerce `HS.App` hsCast' e
+
+hsCast' :: HS.Exp -> HS.Exp
hsCast' (HS.App e1 e2) = hsCast' e1 `HS.App` (hsCoerce $ hsCast' e2)
hsCast' (HS.Lambda _ ps e) = HS.Lambda dummy ps $ hsCast' e
hsCast' e = e
-- No coercion for literal integers
+hsCoerce :: HS.Exp -> HS.Exp
hsCoerce e@(HS.ExpTypeSig _ (HS.Lit (HS.Int{})) _) = e
hsCoerce e = HS.App mazCoerce e
-
--------------------------------------------------
-- Writing out a haskell module
--------------------------------------------------
@@ -485,7 +529,7 @@ writeModule (HS.Module l m ps w ex imp ds) = do
liftIO $ UTF8.writeFile out $ prettyPrint $
HS.Module l m (p : ps) w ex imp ds
where
- p = HS.LanguagePragma dummy $ L.map HS.Ident $
+ p = HS.LanguagePragma dummy $ List.map HS.Ident $
[ "EmptyDataDecls"
, "ExistentialQuantification"
, "ScopedTypeVariables"
@@ -512,8 +556,11 @@ rteModule = ok $ parse $ unlines
, "mazIncompleteMatch s = error (\"MAlonzo Runtime Error: incomplete pattern matching: \" ++ s)"
]
where
- parse = HS.parseWithMode
+ parse :: String -> HS.ParseResult HS.Module
+ parse = HS.parseModuleWithMode
HS.defaultParseMode{HS.extensions = [explicitForAll]}
+
+ ok :: HS.ParseResult HS.Module -> HS.Module
ok (HS.ParseOk d) = d
ok HS.ParseFailed{} = __IMPOSSIBLE__
@@ -536,6 +583,8 @@ compileDir = do
Just dir -> return dir
Nothing -> __IMPOSSIBLE__
+outFile' :: (HS.Pretty a, TransformBi HS.ModuleName (Wrap a)) =>
+ a -> TCM (FilePath, FilePath)
outFile' m = do
mdir <- compileDir
let (fdir, fn) = splitFileName $ repldot pathSeparator $
@@ -545,7 +594,7 @@ outFile' m = do
liftIO $ createDirectoryIfMissing True dir
return (mdir, fp)
where
- repldot c = L.map (\c' -> if c' == '.' then c else c')
+ repldot c = List.map $ \ c' -> if c' == '.' then c else c'
outFile :: HS.ModuleName -> TCM FilePath
outFile m = snd <$> outFile' m
@@ -567,7 +616,7 @@ callGHC modIsMain i = do
let overridableArgs =
[ "-O"] ++
- (if modIsMain then ["-o", mdir </> show outputName] else []) ++
+ (if modIsMain then ["-o", mdir </> show (nameConcrete outputName)] else []) ++
[ "-Werror"]
otherArgs =
[ "-i" ++ mdir] ++
diff --git a/src/full/Agda/Compiler/MAlonzo/Encode.hs b/src/full/Agda/Compiler/MAlonzo/Encode.hs
index 3d5b9b3..1ae89cf 100644
--- a/src/full/Agda/Compiler/MAlonzo/Encode.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Encode.hs
@@ -67,6 +67,7 @@ encodeModuleName (HS.ModuleName s) = HS.ModuleName $ case splitUp s of
-- Note: This injectivity test is quite weak. A better, dedicated
-- generator could strengthen it.
+prop_encodeModuleName_injective :: M -> M -> Bool
prop_encodeModuleName_injective (M s1) (M s2) =
if encodeModuleName (HS.ModuleName s1) ==
encodeModuleName (HS.ModuleName s2) then
@@ -74,6 +75,7 @@ prop_encodeModuleName_injective (M s1) (M s2) =
else
True
+prop_encodeModuleName_OK :: M -> Bool
prop_encodeModuleName_OK (M s') =
s ~= unM (encodeModuleName (HS.ModuleName s))
where
@@ -88,6 +90,7 @@ prop_encodeModuleName_OK (M s') =
unM (HS.ModuleName s) = s
+prop_encodeModuleName_preserved :: M -> Property
prop_encodeModuleName_preserved (M m) =
shouldBePreserved m ==>
encodeModuleName (HS.ModuleName m) == HS.ModuleName m
diff --git a/src/full/Agda/Compiler/MAlonzo/Misc.hs b/src/full/Agda/Compiler/MAlonzo/Misc.hs
index 0d3256e..dfd22ee 100644
--- a/src/full/Agda/Compiler/MAlonzo/Misc.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Misc.hs
@@ -3,21 +3,25 @@
module Agda.Compiler.MAlonzo.Misc where
import Control.Monad.State
+
import Data.List as List
import Data.Map as Map
import Data.Set as Set
import Data.Function
+
import qualified Language.Haskell.Exts.Syntax as HS
import Agda.Syntax.Common
--- import Agda.Syntax.Abstract.Name (isAnonymousModuleName)
import Agda.Syntax.Internal
+
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
--- import Agda.TypeChecking.Pretty
+
+import Agda.Utils.Lens
import Agda.Utils.Monad
+import Agda.Utils.Pretty
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
--------------------------------------------------
@@ -25,14 +29,13 @@ import Agda.Utils.Impossible
--------------------------------------------------
setInterface :: Interface -> TCM ()
-setInterface i = modify $ \s -> s
- { stImportedModules = Set.empty
- , stCurrentModule = Just $ iModuleName i
- }
+setInterface i = do
+ stImportedModules .= Set.empty
+ stCurrentModule .= Just (iModuleName i)
curIF :: TCM Interface
curIF = do
- mName <- stCurrentModule <$> get
+ mName <- use stCurrentModule
case mName of
Nothing -> __IMPOSSIBLE__
Just name -> do
@@ -148,12 +151,22 @@ hsVarUQ = HS.Var . HS.UnQual
-- Hard coded module names
--------------------------------------------------
-mazstr = "MAlonzo.Code"
+mazstr :: String
+mazstr = "MAlonzo.Code"
+
+mazName :: Name
mazName = mkName_ dummy mazstr
+
+mazMod' :: String -> HS.ModuleName
mazMod' s = HS.ModuleName $ mazstr ++ "." ++ s
+
mazMod :: ModuleName -> HS.ModuleName
-mazMod = mazMod' . show
+mazMod = mazMod' . prettyShow
+
+mazerror :: String -> a
mazerror msg = error $ mazstr ++ ": " ++ msg
+
+mazCoerce :: HS.Exp
-- mazCoerce = HS.Var $ HS.Qual unsafeCoerceMod (HS.Ident "unsafeCoerce")
mazCoerce = HS.Var $ HS.Qual mazRTE $ HS.Ident "mazCoerce"
@@ -168,12 +181,20 @@ mazRTE :: HS.ModuleName
mazRTE = HS.ModuleName "MAlonzo.RTE"
-- for Runtime module: Not really used (Runtime modules has been abolished).
-rtmMod = mazMod' "Runtime"
+rtmMod :: HS.ModuleName
+rtmMod = mazMod' "Runtime"
+
+rtmQual :: String -> HS.QName
rtmQual = HS.UnQual . HS.Ident
+
+rtmVar :: String -> HS.Exp
rtmVar = HS.Var . rtmQual
+
+rtmError :: String -> HS.Exp
rtmError s = rtmVar "error" `HS.App`
(HS.Lit $ HS.String $ "MAlonzo Runtime Error: " ++ s)
+unsafeCoerceMod :: HS.ModuleName
unsafeCoerceMod = HS.ModuleName "Unsafe.Coerce"
--------------------------------------------------
diff --git a/src/full/Agda/Compiler/MAlonzo/Pretty.hs b/src/full/Agda/Compiler/MAlonzo/Pretty.hs
index 118900c..db08a8d 100644
--- a/src/full/Agda/Compiler/MAlonzo/Pretty.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Pretty.hs
@@ -1,12 +1,12 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+
------------------------------------------------------------------------
-- Pretty-printing of Haskell modules
------------------------------------------------------------------------
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-
module Agda.Compiler.MAlonzo.Pretty where
import Data.Generics.Geniplate
diff --git a/src/full/Agda/Compiler/MAlonzo/Primitives.hs b/src/full/Agda/Compiler/MAlonzo/Primitives.hs
index aa7a280..5cfb6be 100644
--- a/src/full/Agda/Compiler/MAlonzo/Primitives.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Primitives.hs
@@ -21,7 +21,7 @@ import Agda.TypeChecking.Pretty
import Agda.Utils.Monad
import qualified Agda.Utils.HashMap as HMap
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{- OLD
@@ -44,7 +44,7 @@ checkTypeOfMain q ty
-- | Check that the main function has type IO a, for some a.
checkTypeOfMain :: QName -> Type -> TCM [HS.Decl] -> TCM [HS.Decl]
checkTypeOfMain q ty ret
- | show (qnameName q) /= "main" = ret
+ | show (nameConcrete $ qnameName q) /= "main" = ret
| otherwise = do
Def io _ <- ignoreSharing <$> primIO
ty <- normalise ty
@@ -131,6 +131,10 @@ declsForPrim = xForPrim $
do cs' <- mapM pconName cs
return $ zipWith (\ n -> fakeDS n . repl cs') [n1, n2] [b1, b2]
+mazNatToInteger, mazIntegerToNat, mazNatToInt, mazIntToNat, mazCharToInteger,
+ mazListToHList, mazHListToList, mazListToString, mazStringToList,
+ mazBoolToHBool, mazHBoolToBool :: String
+
mazNatToInteger = "mazNatToInteger"
mazIntegerToNat = "mazIntegerToNat"
mazNatToInt = "mazNatToInt"
@@ -192,19 +196,19 @@ primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $
-- Floating point functions
, "primIntegerToFloat" |-> return "(fromIntegral :: Integer -> Double)"
- , "primFloatPlus" |-> return "((+) :: Double -> Double -> Double)"
- , "primFloatMinus" |-> return "((-) :: Double -> Double -> Double)"
- , "primFloatTimes" |-> return "((*) :: Double -> Double -> Double)"
- , "primFloatDiv" |-> return "((/) :: Double -> Double -> Double)"
+ , "primFloatPlus" |-> return "((+) :: Double -> Double -> Double)"
+ , "primFloatMinus" |-> return "((-) :: Double -> Double -> Double)"
+ , "primFloatTimes" |-> return "((*) :: Double -> Double -> Double)"
+ , "primFloatDiv" |-> return "((/) :: Double -> Double -> Double)"
, "primFloatEquality" |-> rel "(==)" "Double"
, "primFloatLess" |-> rel "(<)" "Double"
- , "primRound" |-> return "(round :: Double -> Integer)"
- , "primFloor" |-> return "(floor :: Double -> Integer)"
- , "primCeiling" |-> return "(ceiling :: Double -> Integer)"
- , "primExp" |-> return "(exp :: Double -> Double)"
- , "primLog" |-> return "(log :: Double -> Double)" -- partial
- , "primSin" |-> return "(sin :: Double -> Double)"
- , "primShowFloat" |-> return "(show :: Double -> String)"
+ , "primRound" |-> return "(round :: Double -> Integer)"
+ , "primFloor" |-> return "(floor :: Double -> Integer)"
+ , "primCeiling" |-> return "(ceiling :: Double -> Integer)"
+ , "primExp" |-> return "(exp :: Double -> Double)"
+ , "primLog" |-> return "(log :: Double -> Double)" -- partial
+ , "primSin" |-> return "(sin :: Double -> Double)"
+ , "primShowFloat" |-> return "(show :: Double -> String)"
, "primRound" |-> return "(round :: Double -> Integer)"
-- Character functions
@@ -270,9 +274,9 @@ primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $
lam x t = Lam (setHiding Hidden defaultArgInfo) (Abs x t)
-
----------------------
+repl :: [String] -> String -> String
repl subs = go where
go ('<':'<':c:'>':'>':s) | 0 <= i && i < length subs = subs !! i ++ go s
where i = ord c - ord '0'
@@ -296,5 +300,5 @@ hasCompiledData (s:_) = toB =<< getBuiltin s where
toB _ = return False
hasCompiledData _ = return False
-
+bltQual' :: String -> String -> TCM String
bltQual' b s = prettyPrint <$> bltQual b s
diff --git a/src/full/Agda/ImpossibleTest.hs b/src/full/Agda/ImpossibleTest.hs
index 1f0b874..9cbf91b 100644
--- a/src/full/Agda/ImpossibleTest.hs
+++ b/src/full/Agda/ImpossibleTest.hs
@@ -5,4 +5,5 @@ module Agda.ImpossibleTest where
#include "undefined.h"
import Agda.Utils.Impossible
+impossibleTest :: a
impossibleTest = __IMPOSSIBLE__
diff --git a/src/full/Agda/Interaction/BasicOps.hs b/src/full/Agda/Interaction/BasicOps.hs
index 5ad70e9..03296ff 100644
--- a/src/full/Agda/Interaction/BasicOps.hs
+++ b/src/full/Agda/Interaction/BasicOps.hs
@@ -1,15 +1,14 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.Interaction.BasicOps where
import Control.Arrow ((***), first, second)
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Identity
@@ -50,7 +49,9 @@ import Agda.TypeChecking.Pretty (prettyTCM)
import Agda.TypeChecking.Free
import qualified Agda.TypeChecking.Pretty as TP
+import Agda.Utils.Except ( Error(strMsg), MonadError(catchError, throwError) )
import Agda.Utils.Functor
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
@@ -58,7 +59,7 @@ import Agda.Utils.Pretty
import Agda.Utils.Permutation
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Parses an expression.
@@ -93,13 +94,30 @@ giveExpr mi e = do
-- Thus, we can safely apply its type to the context variables.
ctx <- getContextArgs
let t' = t `piApply` permute (takeP (length ctx) $ mvPermutation mv) ctx
+ traceCall (CheckExprCall e t') $ do
reportSDoc "interaction.give" 20 $
TP.text "give: instantiated meta type =" TP.<+> prettyTCM t'
- v <- checkExpr e t'
+ v <- checkExpr e t'
case mvInstantiation mv of
- InstV v' -> unlessM ((Irrelevant ==) <$> asks envRelevance) $
- equalTerm t' v (v' `apply` ctx)
- _ -> updateMeta mi v
+ InstV xs v' -> unlessM ((Irrelevant ==) <$> asks envRelevance) $ do
+ reportSDoc "interaction.give" 20 $ TP.sep
+ [ TP.text "meta was already set to value v' = " TP.<+> prettyTCM v'
+ TP.<+> TP.text " with free variables " TP.<+> return (fsep $ map pretty xs)
+ , TP.text "now comparing it to given value v = " TP.<+> prettyTCM v
+ , TP.text "in context " TP.<+> inTopContext (prettyTCM ctx)
+ ]
+ -- The number of free variables should be at least the size of the context
+ -- (Ideally, if we implemented contextual type theory, it should be the same.)
+ when (length xs < size ctx) __IMPOSSIBLE__
+ -- if there are more free variables than the context has
+ -- we need to abstract over the additional ones (xs2)
+ let (_xs1, xs2) = splitAt (size ctx) xs
+ v' <- return $ foldr (\ (Arg ai x) -> I.Lam ai . I.Abs x) v' xs2
+ reportSDoc "interaction.give" 20 $ TP.sep
+ [ TP.text "in meta context, v' = " TP.<+> prettyTCM v'
+ ]
+ equalTerm t' v v' -- Note: v' now lives in context of meta
+ _ -> updateMeta mi v
reify v
-- | Try to fill hole by expression.
@@ -120,7 +138,7 @@ give ii mr e = liftTCM $ do
-- Try to give mi := e
giveExpr mi e `catchError` \ err -> case err of
-- Turn PatternErr into proper error:
- PatternErr _ -> do
+ PatternErr{} -> do
err <- withInteractionId ii $ TP.text "Failed to give" TP.<+> prettyTCM e
typeError $ GenericError $ show err
_ -> throwError err
@@ -153,7 +171,7 @@ refine ii mr e = do
tryRefine nrOfMetas r scope e = try nrOfMetas e
where
try :: Int -> Expr -> TCM Expr
- try 0 e = throwError (strMsg "Can not refine")
+ try 0 e = throwError $ strMsg "Cannot refine"
try n e = give ii (Just r) e `catchError` (\_ -> try (n-1) =<< appMeta e)
-- Apply A.Expr to a new meta
@@ -177,23 +195,23 @@ refine ii mr e = do
evalInCurrent :: Expr -> TCM Expr
evalInCurrent e =
do (v, t) <- inferExpr e
- v' <- {- etaContract =<< -} normalise v
- reify v'
+ v' <- {- etaContract =<< -} normalise v
+ reify v'
evalInMeta :: InteractionId -> Expr -> TCM Expr
evalInMeta ii e =
- do m <- lookupInteractionId ii
- mi <- getMetaInfo <$> lookupMeta m
- withMetaInfo mi $
- evalInCurrent e
+ do m <- lookupInteractionId ii
+ mi <- getMetaInfo <$> lookupMeta m
+ withMetaInfo mi $
+ evalInCurrent e
data Rewrite = AsIs | Instantiated | HeadNormal | Simplified | Normalised
deriving (Read)
---normalForm :: Rewrite -> Term -> TCM Term
-normalForm AsIs t = return t
+normalForm :: Rewrite -> Type -> TCM Type
+normalForm AsIs t = return t
normalForm Instantiated t = return t -- reify does instantiation
normalForm HeadNormal t = {- etaContract =<< -} reduce t
normalForm Simplified t = {- etaContract =<< -} simplify t
@@ -255,8 +273,8 @@ instance Reify Constraint (OutputConstraint Expr Expr) where
reify (TelCmp a b cmp t t') = CmpTeles cmp <$> (ETel <$> reify t) <*> (ETel <$> reify t')
reify (SortCmp cmp s s') = CmpSorts cmp <$> reify s <*> reify s'
reify (Guarded c pid) = do
- o <- reify c
- return $ Guard o pid
+ o <- reify c
+ return $ Guard o pid
reify (UnBlock m) = do
mi <- mvInstantiation <$> lookupMeta m
case mi of
@@ -366,11 +384,7 @@ instance (ToConcrete a c, ToConcrete b d) =>
--ToDo: Move somewhere else
instance ToConcrete InteractionId C.Expr where
toConcrete (InteractionId i) = return $ C.QuestionMark noRange (Just i)
-{- UNUSED
-instance ToConcrete MetaId C.Expr where
- toConcrete x@(MetaId i) = do
- return $ C.Underscore noRange (Just $ "_" ++ show i)
--}
+
instance ToConcrete NamedMeta C.Expr where
toConcrete i = do
return $ C.Underscore noRange (Just $ show i)
@@ -428,9 +442,11 @@ getSolvedInteractionPoints all = concat <$> do
typeOfMetaMI :: Rewrite -> MetaId -> TCM (OutputConstraint Expr NamedMeta)
typeOfMetaMI norm mi =
do mv <- lookupMeta mi
- withMetaInfo (getMetaInfo mv) $
- rewriteJudg mv (mvJudgement mv)
+ withMetaInfo (getMetaInfo mv) $
+ rewriteJudg mv (mvJudgement mv)
where
+ rewriteJudg :: MetaVariable -> Judgement Type MetaId ->
+ TCM (OutputConstraint Expr NamedMeta)
rewriteJudg mv (HasType i t) = do
ms <- getMetaNameSuggestion i
t <- normalForm norm t
@@ -491,7 +507,7 @@ metaHelperType norm ii rng s = case words s of
a' = renameP (reverseP perm) a
(vs, as) <- do
let -- We know that as does not depend on Δ₂
- rho = parallelS (replicate (size delta2) __IMPOSSIBLE__)
+ rho = compactS __IMPOSSIBLE__ (replicate (size delta2) Nothing)
return $ applySubst rho $ renameP (reverseP perm) (vs, as)
a <- local (\e -> e { envPrintDomainFreePi = True }) $ do
reify =<< cleanupType arity args =<< normalForm norm =<< withFunctionType delta1 vs as delta2 a'
@@ -518,7 +534,7 @@ metaHelperType norm ii rng s = case words s of
b | absName b == "w" -> I.Pi a b
NoAbs _ b -> unEl b
Abs s b | 0 `freeIn` b -> I.Pi (hide a) (Abs s b)
- | otherwise -> subst __IMPOSSIBLE__ (unEl b)
+ | otherwise -> strengthen __IMPOSSIBLE__ (unEl b)
_ -> v -- todo: handle if goal type is a Pi
-- renameVars = onNames (stringToArgName <.> renameVar . argNameToString)
@@ -569,7 +585,7 @@ metaHelperType norm ii rng s = case words s of
arg : args <- get
put args
return $ case arg of
- Arg _ (Named _ (A.Var x)) -> show x
+ Arg _ (Named _ (A.Var x)) -> show $ A.nameConcrete x
Arg _ (Named (Just x) _) -> argNameToString $ rangedThing x
_ -> "w"
@@ -585,9 +601,9 @@ contextOfMeta ii norm = do
withMetaInfo info $ gfilter visible <$> reifyContext (length letVars)
(letVars ++ localVars)
where gfilter p = catMaybes . map p
- visible (OfType x y) | show x /= "_" = Just (OfType' x y)
- | otherwise = Nothing
- visible _ = __IMPOSSIBLE__
+ visible (OfType x y) | not (isNoName x) = Just (OfType' x y)
+ | otherwise = Nothing
+ visible _ = __IMPOSSIBLE__
reifyContext skip xs =
reverse <$> zipWithM out
-- don't escape context for letvars
@@ -604,7 +620,7 @@ contextOfMeta ii norm = do
-- invoke that command in an irrelevant context.
typeInCurrent :: Rewrite -> Expr -> TCM Expr
typeInCurrent norm e =
- do (_,t) <- wakeIrrelevantVars $ inferExpr e
+ do (_,t) <- wakeIrrelevantVars $ inferExpr e
v <- normalForm norm t
reify v
@@ -612,10 +628,10 @@ typeInCurrent norm e =
typeInMeta :: InteractionId -> Rewrite -> Expr -> TCM Expr
typeInMeta ii norm e =
- do m <- lookupInteractionId ii
- mi <- getMetaInfo <$> lookupMeta m
- withMetaInfo mi $
- typeInCurrent norm e
+ do m <- lookupInteractionId ii
+ mi <- getMetaInfo <$> lookupMeta m
+ withMetaInfo mi $
+ typeInCurrent norm e
withInteractionId :: InteractionId -> TCM a -> TCM a
withInteractionId i ret = do
@@ -723,14 +739,14 @@ introTactic pmLambda ii = do
atTopLevel :: TCM a -> TCM a
atTopLevel m = inConcreteMode $ do
let err = typeError $ GenericError "The file has not been loaded yet."
- caseMaybeM (gets stCurrentModule) err $ \ current -> do
+ caseMaybeM (use stCurrentModule) err $ \ current -> do
caseMaybeM (getVisitedModule $ toTopLevelModuleName current) __IMPOSSIBLE__ $ \ mi -> do
let scope = iInsideScope $ miInterface mi
tel <- lookupSection current
-- Get the names of the local variables from @scope@
-- and put them into the context.
let names :: [A.Name]
- names = reverse $ map snd $ scopeLocals scope
+ names = reverse $ map snd $ notShadowedLocals $ scopeLocals scope
types :: [I.Dom I.Type]
types = map (snd <$>) $ telToList tel
gamma :: ListTel' A.Name
@@ -776,7 +792,7 @@ moduleContents norm rng s = do
Map.toList names)
return (Map.keys modules, types)
-whyInScope :: String -> TCM (Maybe A.Name, [AbstractName], [AbstractModule])
+whyInScope :: String -> TCM (Maybe LocalVar, [AbstractName], [AbstractModule])
whyInScope s = do
x <- parseName noRange s
scope <- getScope
diff --git a/src/full/Agda/Interaction/CommandLine/CommandLine.hs b/src/full/Agda/Interaction/CommandLine/CommandLine.hs
index 9f44f13..37c9a30 100644
--- a/src/full/Agda/Interaction/CommandLine/CommandLine.hs
+++ b/src/full/Agda/Interaction/CommandLine/CommandLine.hs
@@ -2,7 +2,6 @@
module Agda.Interaction.CommandLine.CommandLine where
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Applicative
@@ -30,9 +29,10 @@ import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Errors
import Agda.TypeChecking.Substitute
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
data ExitCode a = Continue | ContinueIn TCEnv | Return a
@@ -42,45 +42,45 @@ type Command a = (String, [String] -> TCM (ExitCode a))
matchCommand :: String -> [Command a] -> Either [String] ([String] -> TCM (ExitCode a))
matchCommand x cmds =
case List.filter (isPrefixOf x . fst) cmds of
- [(_,m)] -> Right m
- xs -> Left $ List.map fst xs
+ [(_,m)] -> Right m
+ xs -> Left $ List.map fst xs
interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> IM a
interaction prompt cmds eval = loop
where
- go (Return x) = return x
- go Continue = loop
- go (ContinueIn env) = local (const env) loop
-
- loop =
- do ms <- readline prompt
- case fmap words ms of
- Nothing -> return $ error "** EOF **"
- Just [] -> loop
- Just ((':':cmd):args) ->
- do case matchCommand cmd cmds of
- Right c -> go =<< liftTCM (c args)
- Left [] ->
- do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "'"
- loop
- Left xs ->
- do liftIO $ putStrLn $ "More than one command match: " ++ concat (intersperse ", " xs)
- loop
- Just _ ->
- do go =<< liftTCM (eval $ fromJust ms)
- `catchError` \e ->
- do s <- liftTCM $ prettyError e
- liftIO $ putStrLn s
- loop
+ go (Return x) = return x
+ go Continue = loop
+ go (ContinueIn env) = local (const env) loop
+
+ loop =
+ do ms <- readline prompt
+ case fmap words ms of
+ Nothing -> return $ error "** EOF **"
+ Just [] -> loop
+ Just ((':':cmd):args) ->
+ do case matchCommand cmd cmds of
+ Right c -> go =<< liftTCM (c args)
+ Left [] ->
+ do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "'"
+ loop
+ Left xs ->
+ do liftIO $ putStrLn $ "More than one command match: " ++ concat (intersperse ", " xs)
+ loop
+ Just _ ->
+ do go =<< liftTCM (eval $ fromJust ms)
+ `catchError` \e ->
+ do s <- liftTCM $ prettyError e
+ liftIO $ putStrLn s
+ loop
-- | The interaction loop.
interactionLoop :: TCM (Maybe Interface) -> IM ()
-interactionLoop typeCheck =
+interactionLoop doTypeCheck =
do liftTCM reload
- interaction "Main> " commands evalTerm
+ interaction "Main> " commands evalTerm
where
- reload = do
- mi <- typeCheck
+ reload = do
+ mi <- doTypeCheck
-- Note that mi is Nothing if (1) there is no input file or
-- (2) the file type checked with unsolved metas and
-- --allow-unsolved-metas was used. In the latter case the
@@ -90,79 +90,79 @@ interactionLoop typeCheck =
setScope $ case mi of
Just i -> iInsideScope i
Nothing -> emptyScopeInfo
- `catchError` \e -> do
- s <- prettyError e
- liftIO $ putStrLn s
- liftIO $ putStrLn "Failed."
-
- commands =
- [ "quit" |> \_ -> return $ Return ()
- , "?" |> \_ -> continueAfter $ liftIO $ help commands
- , "reload" |> \_ -> do reload
- ContinueIn <$> ask
- , "constraints" |> \args -> continueAfter $ showConstraints args
- , "Context" |> \args -> continueAfter $ showContext args
- , "give" |> \args -> continueAfter $ giveMeta args
- , "Refine" |> \args -> continueAfter $ refineMeta args
- , "metas" |> \args -> continueAfter $ showMetas args
- , "load" |> \args -> continueAfter $ loadFile reload args
- , "eval" |> \args -> continueAfter $ evalIn args
+ `catchError` \e -> do
+ s <- prettyError e
+ liftIO $ putStrLn s
+ liftIO $ putStrLn "Failed."
+
+ commands =
+ [ "quit" |> \_ -> return $ Return ()
+ , "?" |> \_ -> continueAfter $ liftIO $ help commands
+ , "reload" |> \_ -> do reload
+ ContinueIn <$> ask
+ , "constraints" |> \args -> continueAfter $ showConstraints args
+ , "Context" |> \args -> continueAfter $ showContext args
+ , "give" |> \args -> continueAfter $ giveMeta args
+ , "Refine" |> \args -> continueAfter $ refineMeta args
+ , "metas" |> \args -> continueAfter $ showMetas args
+ , "load" |> \args -> continueAfter $ loadFile reload args
+ , "eval" |> \args -> continueAfter $ evalIn args
, "typeOf" |> \args -> continueAfter $ typeOf args
, "typeIn" |> \args -> continueAfter $ typeIn args
- , "wakeup" |> \_ -> continueAfter $ retryConstraints
- , "scope" |> \_ -> continueAfter $ showScope
- ]
- where
- (|>) = (,)
+ , "wakeup" |> \_ -> continueAfter $ retryConstraints
+ , "scope" |> \_ -> continueAfter $ showScope
+ ]
+ where
+ (|>) = (,)
continueAfter :: TCM a -> TCM (ExitCode b)
continueAfter m = m >> return Continue
loadFile :: TCM () -> [String] -> TCM ()
loadFile reload [file] =
- do setInputFile file
- reload
+ do setInputFile file
+ reload
loadFile _ _ = liftIO $ putStrLn ":load file"
showConstraints :: [String] -> TCM ()
showConstraints [] =
- do cs <- BasicOps.getConstraints
- liftIO $ putStrLn $ unlines (List.map show cs)
+ do cs <- BasicOps.getConstraints
+ liftIO $ putStrLn $ unlines (List.map show cs)
showConstraints _ = liftIO $ putStrLn ":constraints [cid]"
showMetas :: [String] -> TCM ()
showMetas [m] =
- do i <- InteractionId <$> readM m
- withInteractionId i $ do
- s <- typeOfMeta AsIs i
- r <- getInteractionRange i
- d <- showA s
- liftIO $ putStrLn $ d ++ " " ++ show r
+ do i <- InteractionId <$> readM m
+ withInteractionId i $ do
+ s <- typeOfMeta AsIs i
+ r <- getInteractionRange i
+ d <- showA s
+ liftIO $ putStrLn $ d ++ " " ++ show r
showMetas [m,"normal"] =
- do i <- InteractionId <$> readM m
- withInteractionId i $ do
- s <- showA =<< typeOfMeta Normalised i
- r <- getInteractionRange i
- liftIO $ putStrLn $ s ++ " " ++ show r
+ do i <- InteractionId <$> readM m
+ withInteractionId i $ do
+ s <- showA =<< typeOfMeta Normalised i
+ r <- getInteractionRange i
+ liftIO $ putStrLn $ s ++ " " ++ show r
showMetas [] =
do interactionMetas <- typesOfVisibleMetas AsIs
hiddenMetas <- typesOfHiddenMetas AsIs
mapM_ (liftIO . putStrLn) =<< mapM showII interactionMetas
- mapM_ print' hiddenMetas
+ mapM_ print' hiddenMetas
where
- showII o = withInteractionId (outputFormId $ OutputForm noRange 0 o) $ showA o
- showM o = withMetaId (nmid $ outputFormId $ OutputForm noRange 0 o) $ showA o
-
- metaId (OfType i _) = i
- metaId (JustType i) = i
- metaId (JustSort i) = i
- metaId (Assign i e) = i
- metaId _ = __IMPOSSIBLE__
- print' x = do
- r <- getMetaRange $ nmid $ metaId x
- d <- showM x
- liftIO $ putStrLn $ d ++ " [ at " ++ show r ++ " ]"
+ showII o = withInteractionId (outputFormId $ OutputForm noRange 0 o) $ showA o
+ showM o = withMetaId (nmid $ outputFormId $ OutputForm noRange 0 o) $ showA o
+
+ metaId (OfType i _) = i
+ metaId (JustType i) = i
+ metaId (JustSort i) = i
+ metaId (Assign i e) = i
+ metaId _ = __IMPOSSIBLE__
+ print' x = do
+ r <- getMetaRange $ nmid $ metaId x
+ d <- showM x
+ liftIO $ putStrLn $ d ++ " [ at " ++ show r ++ " ]"
showMetas _ = liftIO $ putStrLn $ ":meta [metaid]"
@@ -173,15 +173,15 @@ showScope = do
metaParseExpr :: InteractionId -> String -> TCM A.Expr
metaParseExpr ii s =
- do m <- lookupInteractionId ii
+ do m <- lookupInteractionId ii
scope <- getMetaScope <$> lookupMeta m
r <- getRange <$> lookupMeta m
--liftIO $ putStrLn $ show scope
let pos = case rStart r of
Nothing -> __IMPOSSIBLE__
Just pos -> pos
- e <- liftIO $ parsePosString exprParser pos s
- concreteToAbstract scope e
+ e <- liftIO $ parsePosString exprParser pos s
+ concreteToAbstract scope e
actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a
actOnMeta (is:es) f =
@@ -214,7 +214,7 @@ retryConstraints = liftTCM wakeupConstraints_
evalIn :: [String] -> TCM ()
evalIn s | length s >= 2 =
- do d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent e
+ do d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent e
liftIO $ print d
evalIn _ = liftIO $ putStrLn ":eval metaid expr"
@@ -225,16 +225,16 @@ parseExpr s = do
evalTerm :: String -> TCM (ExitCode a)
evalTerm s =
- do e <- parseExpr s
+ do e <- parseExpr s
v <- evalInCurrent e
- e <- prettyTCM v
- liftIO $ putStrLn $ show e
- return Continue
+ e <- prettyTCM v
+ liftIO $ putStrLn $ show e
+ return Continue
where
- evalInCurrent e = do
- (v,t) <- inferExpr e
- v' <- normalise v
- return v'
+ evalInCurrent e = do
+ (v,t) <- inferExpr e
+ v' <- normalise v
+ return v'
typeOf :: [String] -> TCM ()
@@ -242,14 +242,14 @@ typeOf s =
do e <- parseExpr (unwords s)
e0 <- typeInCurrent Normalised e
e1 <- typeInCurrent AsIs e
- liftIO . putStrLn =<< showA e1
+ liftIO . putStrLn =<< showA e1
typeIn :: [String] -> TCM ()
typeIn s@(_:_:_) =
actOnMeta s $ \i e ->
- do e1 <- typeInMeta i Normalised e
+ do e1 <- typeInMeta i Normalised e
e2 <- typeInMeta i AsIs e
- liftIO . putStrLn =<< showA e1
+ liftIO . putStrLn =<< showA e1
typeIn _ = liftIO $ putStrLn ":typeIn meta expr"
showContext :: [String] -> TCM ()
@@ -260,12 +260,12 @@ showContext (meta:args) = do
ctx <- List.map unDom . telToList <$> getContextTelescope
zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx
where
- display (x, t) n = do
- t <- case args of
- ["normal"] -> normalise $ raise n t
- _ -> return $ raise n t
- d <- prettyTCM t
- liftIO $ print $ text (I.argNameToString x) <+> text ":" <+> d
+ display (x, t) n = do
+ t <- case args of
+ ["normal"] -> normalise $ raise n t
+ _ -> return $ raise n t
+ d <- prettyTCM t
+ liftIO $ print $ text (I.argNameToString x) <+> text ":" <+> d
showContext _ = liftIO $ putStrLn ":Context meta"
-- | The logo that prints when Agda is started in interactive mode.
@@ -290,4 +290,4 @@ help cs = putStr $ unlines $
[ "Command overview" ] ++ List.map explain cs ++
[ "<exp> Infer type of expression <exp> and evaluate it." ]
where
- explain (x,_) = ":" ++ x
+ explain (x,_) = ":" ++ x
diff --git a/src/full/Agda/Interaction/EmacsCommand.hs b/src/full/Agda/Interaction/EmacsCommand.hs
index 46e3164..0f6bd67 100644
--- a/src/full/Agda/Interaction/EmacsCommand.hs
+++ b/src/full/Agda/Interaction/EmacsCommand.hs
@@ -1,9 +1,10 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
------------------------------------------------------------------------
-- | Code for instructing Emacs to do things
------------------------------------------------------------------------
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-
module Agda.Interaction.EmacsCommand
( Lisp(..)
, response
@@ -34,9 +35,6 @@ instance Pretty a => Pretty (Lisp a) where
pretty (L xs) = parens (hsep (map pretty xs))
pretty (Q x) = text "'" <> pretty x
-instance Pretty String where
- pretty = text
-
instance Pretty a => Show (Lisp a) where
show = show . pretty
diff --git a/src/full/Agda/Interaction/EmacsTop.hs b/src/full/Agda/Interaction/EmacsTop.hs
index e5a1d04..9f559fe 100644
--- a/src/full/Agda/Interaction/EmacsTop.hs
+++ b/src/full/Agda/Interaction/EmacsTop.hs
@@ -1,12 +1,10 @@
-- {-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Interaction.EmacsTop
( mimicGHCi
) where
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.State
import Data.Char
diff --git a/src/full/Agda/Interaction/Exceptions.hs b/src/full/Agda/Interaction/Exceptions.hs
index 2912067..8b6e37f 100644
--- a/src/full/Agda/Interaction/Exceptions.hs
+++ b/src/full/Agda/Interaction/Exceptions.hs
@@ -1,4 +1,3 @@
-
{-| This module defines the exception handler.
-}
module Agda.Interaction.Exceptions where
@@ -17,4 +16,4 @@ handleParseException crash e = crash e
failOnException :: (Range -> String -> IO a) -> IO a -> IO a
failOnException h m = m `E.catch` handleParseException handler
where
- handler x = h (getRange x) (show x)
+ handler x = h (getRange x) (show x)
diff --git a/src/full/Agda/Interaction/FindFile.hs b/src/full/Agda/Interaction/FindFile.hs
index 880a563..48ed17f 100644
--- a/src/full/Agda/Interaction/FindFile.hs
+++ b/src/full/Agda/Interaction/FindFile.hs
@@ -32,6 +32,7 @@ import Agda.TypeChecking.Monad.Benchmark (billTo)
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import {-# SOURCE #-} Agda.TypeChecking.Monad.Options (getIncludeDirs)
import Agda.Utils.FileName
+import Agda.Utils.Lens
-- | Converts an Agda file name to the corresponding interface file
-- name.
@@ -80,9 +81,9 @@ findFile m = do
findFile' :: TopLevelModuleName -> TCM (Either FindError AbsolutePath)
findFile' m = do
dirs <- getIncludeDirs
- modFile <- stModuleToSource <$> get
+ modFile <- use stModuleToSource
(r, modFile) <- liftIO $ findFile'' dirs m modFile
- modify $ \s -> s { stModuleToSource = modFile }
+ stModuleToSource .= modFile
return r
-- | A variant of 'findFile'' which does not require 'TCM'.
diff --git a/src/full/Agda/Interaction/Highlighting/Dot.hs b/src/full/Agda/Interaction/Highlighting/Dot.hs
index f4bb770..7c23770 100644
--- a/src/full/Agda/Interaction/Highlighting/Dot.hs
+++ b/src/full/Agda/Interaction/Highlighting/Dot.hs
@@ -19,7 +19,7 @@ import Agda.Interaction.Options
import Agda.Syntax.Abstract
import Agda.TypeChecking.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Internal module identifiers for construction of dependency graph.
@@ -93,7 +93,7 @@ generateDot inter = do
mkDot :: DotState -> String
mkDot st = unlines $
[ "digraph dependencies {"
- ] ++ [" " ++ repr ++ "[label=\"" ++ show modulename ++ "\"];"
+ ] ++ [" " ++ repr ++ "[label=\"" ++ show (mnameToConcrete modulename) ++ "\"];"
| (modulename, repr) <- M.toList (dsModules st)]
++ [" " ++ r1 ++ " -> " ++ r2 ++ ";"
| (r1 , r2) <- S.toList (dsConnection st) ]
diff --git a/src/full/Agda/Interaction/Highlighting/Emacs.hs b/src/full/Agda/Interaction/Highlighting/Emacs.hs
index a1fae1f..b8baf8b 100644
--- a/src/full/Agda/Interaction/Highlighting/Emacs.hs
+++ b/src/full/Agda/Interaction/Highlighting/Emacs.hs
@@ -29,7 +29,7 @@ import Data.Monoid
import qualified System.Directory as D
import qualified System.IO as IO
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -38,7 +38,7 @@ import Agda.Utils.Impossible
-- | Converts the 'aspect' and 'otherAspects' fields to atoms readable
-- by the Emacs interface.
-toAtoms :: MetaInfo -> [String]
+toAtoms :: Aspects -> [String]
toAtoms m = map toAtom (otherAspects m) ++ toAtoms' (aspect m)
where
toAtom x = map toLower (show x)
@@ -57,11 +57,11 @@ toAtoms m = map toAtom (otherAspects m) ++ toAtoms' (aspect m)
-- | Shows meta information in such a way that it can easily be read
-- by Emacs.
-showMetaInfo :: ModuleToSource
- -- ^ Must contain a mapping for the definition site's
- -- module, if any.
- -> (Range, MetaInfo) -> Lisp String
-showMetaInfo modFile (r, m) =
+showAspects
+ :: ModuleToSource
+ -- ^ Must contain a mapping for the definition site's module, if any.
+ -> (Range, Aspects) -> Lisp String
+showAspects modFile (r, m) =
L $ ((map (A . show) [from r, to r])
++
[L $ map A $ toAtoms m]
@@ -92,7 +92,7 @@ lispifyHighlightingInfo h modFile = do
mi == mempty -> direct
_ -> indirect
where
- info = map (showMetaInfo modFile) (ranges h)
+ info = map (showAspects modFile) (ranges h)
direct = return $ L (A "agda2-highlight-add-annotations" :
map Q info)
diff --git a/src/full/Agda/Interaction/Highlighting/Generate.hs b/src/full/Agda/Interaction/Highlighting/Generate.hs
index 39eabdc..e073421 100644
--- a/src/full/Agda/Interaction/Highlighting/Generate.hs
+++ b/src/full/Agda/Interaction/Highlighting/Generate.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RelaxedPolyRec #-}
+{-# LANGUAGE RelaxedPolyRec #-}
-- | Generates data used for precise syntax highlighting.
@@ -14,9 +14,12 @@ module Agda.Interaction.Highlighting.Generate
, highlightAsTypeChecked
, computeUnsolvedMetaWarnings
, computeUnsolvedConstraints
+ , storeDisambiguatedName
, Agda.Interaction.Highlighting.Generate.tests
) where
+import Prelude hiding (null)
+
import Agda.Interaction.FindFile
import Agda.Interaction.Response (Response(Resp_HighlightingInfo))
import Agda.Interaction.Highlighting.Precise hiding (tests)
@@ -38,6 +41,7 @@ import qualified Agda.Syntax.Literal as L
import qualified Agda.Syntax.Parser as Pa
import qualified Agda.Syntax.Parser.Tokens as T
import qualified Agda.Syntax.Position as P
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.TestHelpers
import Agda.Utils.HashMap (HashMap)
@@ -47,7 +51,7 @@ import Control.Monad.Trans
import Control.Monad.State
import Control.Monad.Reader
import Control.Applicative
-import Control.Arrow ((***))
+import Control.Arrow ((***), first, second)
import Data.Monoid
import Data.Generics.Geniplate
import Agda.Utils.FileName
@@ -57,12 +61,18 @@ import qualified Data.Map as Map
import Data.Maybe
import Data.List ((\\), isPrefixOf)
import qualified Data.Foldable as Fold (toList, fold, foldMap)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+
+import Agda.Utils.Functor
+import Agda.Utils.Maybe
+import Agda.Utils.Null
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | @highlightAsTypeChecked rPre r m@ runs @m@ and returns its
--- result. Some code may additionally be highlighted:
+-- result. Additionally, some code may be highlighted:
--
-- * If @r@ is non-empty and not a sub-range of @rPre@ (after
-- 'P.continuousPerLine' has been applied to both): @r@ is
@@ -101,7 +111,7 @@ highlightAsTypeChecked rPre r m
printHighlightingInfo :: MonadTCM tcm => HighlightingInfo -> tcm ()
printHighlightingInfo x = do
- modToSrc <- gets stModuleToSource
+ modToSrc <- use stModuleToSource
liftTCM $ reportSLn "highlighting" 50 $
"Printing highlighting info:\n" ++ show x ++ "\n" ++
" modToSrc = " ++ show modToSrc
@@ -112,27 +122,22 @@ printHighlightingInfo x = do
-- | Highlighting levels.
data Level
- = Full [TerminationError]
+ = Full
-- ^ Full highlighting. Should only be used after typechecking has
- -- completed successfully.
- --
- -- The list of termination problems is also highlighted.
- --
- -- Precondition: The termination problems must be located in the
- -- module that is highlighted.
+ -- completed successfully.
| Partial
-- ^ Highlighting without disambiguation of overloaded
- -- constructors.
+ -- constructors.
-- | Generate syntax highlighting information for the given
-- declaration, and (if appropriate) print it. If the
--- 'HighlightingLevel' is @'Full' something@, then the state is
+-- 'HighlightingLevel' is @'Full'@, then the state is
-- additionally updated with the new highlighting info (in case of a
-- conflict new info takes precedence over old info).
--
-- The procedure makes use of some of the token highlighting info in
-- 'stTokens' (that corresponding to the interval covered by the
--- declaration). If the 'HighlightingLevel' is @'Full' something@,
+-- declaration). If the 'HighlightingLevel' is @'Full'@,
-- then this token highlighting info is additionally removed from
-- 'stTokens'.
@@ -157,15 +162,15 @@ generateAndPrintSyntaxInfo decl hlLevel = do
-- Constructors are only highlighted after type checking, since they
-- can be overloaded.
constructorInfo <- case hlLevel of
- Full _ -> generateConstructorInfo modMap file kinds decl
+ Full{} -> generateConstructorInfo modMap file kinds decl
_ -> return mempty
let (from, to) = case P.rangeToInterval (P.getRange decl) of
Nothing -> __IMPOSSIBLE__
- Just i -> let conv = toInteger . P.posPos in
- (conv $ P.iStart i, conv $ P.iEnd i)
+ Just i -> ( fromIntegral $ P.posPos $ P.iStart i
+ , fromIntegral $ P.posPos $ P.iEnd i)
(prevTokens, (curTokens, postTokens)) <-
- (id *** splitAtC to) . splitAtC from . stTokens <$> get
+ (second (splitAtC to)) . splitAtC from <$> use stTokens
-- theRest needs to be placed before nameInfo here since record
-- field declarations contain QNames. constructorInfo also needs
@@ -176,32 +181,18 @@ generateAndPrintSyntaxInfo decl hlLevel = do
let syntaxInfo = compress (mconcat [ constructorInfo
, theRest modMap file
, nameInfo
- , termInfo
])
`mappend`
curTokens
case hlLevel of
- Full _ -> modify (\st ->
- st { stSyntaxInfo = syntaxInfo `mappend` stSyntaxInfo st
- , stTokens = prevTokens `mappend` postTokens
- })
+ Full{} -> do stSyntaxInfo %= mappend syntaxInfo
+ stTokens .= prevTokens `mappend` postTokens
_ -> return ()
ifTopLevelAndHighlightingLevelIs NonInteractive $
printHighlightingInfo syntaxInfo
where
- -- Highlighting of termination problems.
- termInfo = case hlLevel of
- Full termErrs -> functionDefs `mappend` callSites
- where
- m = mempty { otherAspects = [TerminationProblem] }
- functionDefs = Fold.foldMap (\x -> singleton (rToR $ bindingSite x) m) $
- concatMap M.termErrFunctions termErrs
- callSites = Fold.foldMap (\r -> singleton (rToR r) m) $
- concatMap (map M.callInfoRange . M.termErrCalls) termErrs
- _ -> mempty
-
-- All names mentioned in the syntax tree (not bound variables).
names :: [A.AmbiguousQName]
names =
@@ -211,7 +202,7 @@ generateAndPrintSyntaxInfo decl hlLevel = do
universeBi decl
where
extendedLambda :: A.QName -> Bool
- extendedLambda n = extendlambdaname `isPrefixOf` show (A.qnameName n)
+ extendedLambda = (extendedLambdaName `isPrefixOf`) . show . A.nameConcrete . A.qnameName
-- Bound variables, dotted patterns, record fields, module names,
-- the "as" and "to" symbols.
@@ -373,15 +364,15 @@ type NameKinds = A.QName -> Maybe NameKind
-- | Builds a 'NameKinds' function.
nameKinds :: Level
- -- ^ This should only be @'Full' something@ if
+ -- ^ This should only be @'Full'@ if
-- type-checking completed successfully (without any
-- errors).
-> A.Declaration
-> TCM NameKinds
nameKinds hlLevel decl = do
- imported <- fix . stImports <$> get
+ imported <- fix <$> use stImports
local <- case hlLevel of
- Full _ -> fix . stSignature <$> get
+ Full{} -> fix <$> use stSignature
_ -> return HMap.empty
-- Traverses the syntax tree and constructs a map from qualified
-- names to name kinds. TODO: Handle open public.
@@ -454,115 +445,64 @@ generateConstructorInfo
-> A.Declaration
-> TCM File
generateConstructorInfo modMap file kinds decl = do
- -- Extract all defined names from the declaration.
- let names = Fold.toList (A.allNames decl)
-
- -- Look up the corresponding declarations in the internal syntax.
- defMap <- M.sigDefinitions <$> M.getSignature
- let defs = catMaybes $ map (flip HMap.lookup defMap) names
-
- -- Instantiate meta variables.
- clauses <- R.instantiateFull $ concatMap M.defClauses defs
- types <- R.instantiateFull $ map defType defs
- let -- Find all patterns and terms.
- patterns = universeBi (types, clauses)
- terms = universeBi (types, clauses)
+ -- Get boundaries of current declaration.
+ -- @noRange@ should be impossible, but in case of @noRange@
+ -- it makes sense to return the empty File.
+ ifNull (P.getRange decl) (return mempty) $ \ (P.Range is) -> do
+ let start = fromIntegral $ P.posPos $ P.iStart $ head is
+ end = fromIntegral $ P.posPos $ P.iEnd $ last is
- -- Find all constructors in the patterns and terms.
- constrs = filter ((/= P.noRange) . P.getRange) $
- concatMap getConstructorP patterns ++
- concatMap getConstructor terms
-
- -- Find all constructors in right-hand sides of delayed definitions.
- delayed <- evalStateT (getDelayed terms) HSet.empty
+ -- Get all disambiguated names that fall within the range of decl.
+ m0 <- use stDisambiguatedNames
+ let (_, m1) = IntMap.split (pred start) m0
+ (m2, _) = IntMap.split end m1
+ constrs = IntMap.elems m2
-- Return suitable syntax highlighting information.
- return $ Fold.fold $ fmap (generate modMap file kinds . mkAmb)
- (delayed ++ constrs)
- where
- mkAmb q = A.AmbQ [q]
-
- -- Finds names corresponding to delayed definitions occurring at the
- -- top of the given terms, as well as in the found definition's
- -- right-hand sides. Only definitions from the current file are
- -- considered.
- --
- -- Constructors occurring in the delayed definitions' right-hand
- -- sides are returned.
- --
- -- The set is used to avoid inspecting the same definition multiple
- -- times.
-
- getDelayed :: [I.Term] -> StateT (HashSet A.QName) TCM [A.QName]
- getDelayed ts = concat <$> mapM getT ts
- where
- getT t = do
- lift $ reportSDoc "highlighting.delayed" 50 $
- text "Inspecting sub-term:" <+> prettyTCM t
-
- seen <- get
- case t of
- I.Def q _ | not (q `HSet.member` seen)
- &&
- fmap P.srcFile (P.rStart (P.getRange q)) ==
- Just (Just file)
- -> getQ q
- _ -> return []
-
- getQ q = do
- lift $ reportSDoc "highlighting.delayed" 30 $
- text "Inspecting name:" <+> prettyTCM q
-
- def <- lift $ getConstInfo q
- case defDelayed def of
- NotDelayed -> return []
- Delayed -> do
- lift $ reportSDoc "highlighting.delayed" 10 $
- text "Found delayed definition:" <+> prettyTCM q
-
- -- Mark the definition as seen.
- modify (HSet.insert q)
-
- -- All sub-terms in the delayed definition's right-hand
- -- sides.
- terms <- universeBi . concat . map (getRHS . I.clauseBody) <$>
- lift (R.instantiateFull $ defClauses def)
-
- -- Find the constructors and continue the search.
- (concatMap getConstructor terms ++) <$> getDelayed terms
-
- getRHS (I.Body v) = [v]
- getRHS I.NoBody = []
- getRHS (I.Bind b) = getRHS (I.unAbs b)
-
- getConstructorP :: I.Pattern -> [A.QName]
- getConstructorP (I.ConP c _ _) = [I.conName c]
- getConstructorP _ = []
-
- getConstructor :: I.Term -> [A.QName]
- getConstructor (I.Con q _) = [I.conName q]
- getConstructor _ = []
+ let files = for constrs $ \ q -> generate modMap file kinds $ A.AmbQ [q]
+ return $ Fold.fold files
+
-- | Prints syntax highlighting info for an error.
printErrorInfo :: TCErr -> TCM ()
-printErrorInfo e = do
- -- Erase previous highlighting.
- printHighlightingInfo $ singletonC (rToR $ P.continuousPerLine $ P.getRange e) mempty
+printErrorInfo e = printHighlightingInfo . compress =<< errorHighlighting e
- -- Print new highlighting.
- printHighlightingInfo . compress =<< errorHighlighting e
+-- | Generate highlighting for error.
+-- Does something special for termination errors.
errorHighlighting :: TCErr -> TCM File
+
+errorHighlighting (TypeError s cl@(Closure sig env scope (TerminationCheckFailed termErrs))) =
+ -- For termination errors, we keep the previous highlighting,
+ -- just additionally mark the bad calls.
+ return $ terminationErrorHighlighting termErrs
+
errorHighlighting e = do
+
+ -- Erase previous highlighting.
+ let r = P.getRange e
+ erase = singleton (rToR $ P.continuousPerLine r) mempty
+
+ -- Print new highlighting.
s <- E.prettyError e
- return $ singleton (rToR r)
+ let error = singleton (rToR r)
$ mempty { otherAspects = [Error]
, note = Just s
}
+ return $ mconcat [ erase, error ]
+
+-- | Generate syntax highlighting for termination errors.
+
+terminationErrorHighlighting :: [TerminationError] -> File
+terminationErrorHighlighting termErrs = functionDefs `mappend` callSites
where
- r = P.getRange e
+ m = mempty { otherAspects = [TerminationProblem] }
+ functionDefs = Fold.foldMap (\x -> singleton (rToR $ bindingSite x) m) $
+ concatMap M.termErrFunctions termErrs
+ callSites = Fold.foldMap (\r -> singleton (rToR r) m) $
+ concatMap (map M.callInfoRange . M.termErrCalls) termErrs
-- | Generates and prints syntax highlighting information for unsolved
-- meta-variables and certain unsolved constraints.
@@ -642,7 +582,7 @@ nameToFile :: SourceToModule
-- ^ The name qualifier (may be empty).
-> C.Name
-- ^ The base name.
- -> (Bool -> MetaInfo)
+ -> (Bool -> Aspects)
-- ^ Meta information to be associated with the name.
-- The argument is 'True' iff the name is an operator.
-> Maybe P.Range
@@ -664,23 +604,24 @@ nameToFile modMap file xs x m mR =
r <- mR
P.Pn { P.srcFile = Just f, P.posPos = p } <- P.rStart r
mod <- Map.lookup f modMap
- return (mod, toInteger p)
+ return (mod, fromIntegral p)
-- | A variant of 'nameToFile' for qualified abstract names.
-nameToFileA :: SourceToModule
- -- ^ Maps source file paths to module names.
- -> AbsolutePath
- -- ^ The file name of the current module. Used for
- -- consistency checking.
- -> A.QName
- -- ^ The name.
- -> Bool
- -- ^ Should the binding site be included in the file?
- -> (Bool -> MetaInfo)
- -- ^ Meta information to be associated with the name.
- -- ^ The argument is 'True' iff the name is an operator.
- -> File
+nameToFileA
+ :: SourceToModule
+ -- ^ Maps source file paths to module names.
+ -> AbsolutePath
+ -- ^ The file name of the current module. Used for
+ -- consistency checking.
+ -> A.QName
+ -- ^ The name.
+ -> Bool
+ -- ^ Should the binding site be included in the file?
+ -> (Bool -> Aspects)
+ -- ^ Meta information to be associated with the name.
+ -- ^ The argument is 'True' iff the name is an operator.
+ -> File
nameToFileA modMap file x include m =
nameToFile modMap
file
@@ -689,9 +630,24 @@ nameToFileA modMap file x include m =
m
(if include then Just $ bindingSite x else Nothing)
-concreteBase = A.nameConcrete . A.qnameName
+concreteBase :: I.QName -> C.Name
+concreteBase = A.nameConcrete . A.qnameName
+
+concreteQualifier :: I.QName -> [C.Name]
concreteQualifier = map A.nameConcrete . A.mnameToList . A.qnameModule
-bindingSite = A.nameBindingSite . A.qnameName
+
+bindingSite :: I.QName -> P.Range
+bindingSite = A.nameBindingSite . A.qnameName
+
+-- | Remember a name disambiguation (during type checking).
+-- To be used later during syntax highlighting.
+storeDisambiguatedName :: A.QName -> TCM ()
+storeDisambiguatedName q = whenJust (start $ P.getRange q) $ \ i ->
+ stDisambiguatedNames %= IntMap.insert i q
+ where
+ start (P.Range []) = Nothing
+ start (P.Range (i:_)) = Just $ fromIntegral $ P.posPos $ P.iStart i
+ -- TODO: Move start to Agda.Syntax.Position
------------------------------------------------------------------------
-- All tests
diff --git a/src/full/Agda/Interaction/Highlighting/HTML.hs b/src/full/Agda/Interaction/Highlighting/HTML.hs
index 385bfc0..3c33264 100644
--- a/src/full/Agda/Interaction/Highlighting/HTML.hs
+++ b/src/full/Agda/Interaction/Highlighting/HTML.hs
@@ -15,8 +15,9 @@ import Control.Monad.State.Class
import Data.Function
import Data.Monoid
import Data.Maybe
-import qualified Data.Map as Map
-import qualified Data.List as List
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import qualified Data.List as List
import System.FilePath
import System.Directory
@@ -36,11 +37,12 @@ import Agda.TypeChecking.Monad (TCM)
import qualified Agda.TypeChecking.Monad as TCM
import Agda.Utils.FileName (filePath)
+import Agda.Utils.Lens
import qualified Agda.Utils.IO.UTF8 as UTF8
import Agda.Utils.Pretty
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | The name of the default CSS file.
@@ -94,7 +96,7 @@ generatePage
-> HighlightingInfo -- ^ Syntax highlighting info for the module.
-> TCM ()
generatePage dir mod highlighting = do
- mf <- Map.lookup mod . TCM.stModuleToSource <$> get
+ mf <- Map.lookup mod <$> use TCM.stModuleToSource
case mf of
Nothing -> __IMPOSSIBLE__
Just f -> do
@@ -146,12 +148,12 @@ code contents info =
(pos, map (snd . snd) cs, maybe mempty id mi)
[] -> __IMPOSSIBLE__) $
List.groupBy ((==) `on` fst) $
- map (\(pos, c) -> (Map.lookup pos infoMap, (pos, c))) $
+ map (\(pos, c) -> (IntMap.lookup pos infoMap, (pos, c))) $
zip [1..] contents
where
infoMap = toMap (decompress info)
- annotate :: Integer -> MetaInfo -> Html -> Html
+ annotate :: Int -> Aspects -> Html -> Html
annotate pos mi = anchor ! attributes
where
attributes =
diff --git a/src/full/Agda/Interaction/Highlighting/LaTeX.hs b/src/full/Agda/Interaction/Highlighting/LaTeX.hs
index 97717cc..0363fdd 100644
--- a/src/full/Agda/Interaction/Highlighting/LaTeX.hs
+++ b/src/full/Agda/Interaction/Highlighting/LaTeX.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
-- | Function for generating highlighted and aligned LaTeX from literate
@@ -13,7 +13,6 @@ import Data.Char
import Data.Maybe
import Data.Function
import Control.Monad.RWS
-import Control.Monad.Error
import System.Directory
import System.FilePath
import Data.Text (Text)
@@ -22,8 +21,9 @@ import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E
import qualified Data.ByteString as BS
-import qualified Data.List as List
-import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified Data.List as List
+import qualified Data.Map as Map
import Paths_Agda
@@ -39,18 +39,20 @@ import qualified Agda.Utils.IO.UTF8 as UTF8
import Agda.Utils.FileName (filePath)
import Agda.Utils.Pretty (pretty, render)
-#include "../../undefined.h"
+import Agda.Utils.Except ( ExceptT, MonadError(throwError), runExceptT )
+
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
-- * Datatypes.
--- | The @LaTeX@ monad is a combination of @ErrorT@, @RWST@ and
+-- | The @LaTeX@ monad is a combination of @ExceptT@, @RWST@ and
-- @IO at . The error part is just used to keep track whether we finished
-- or not, the reader part isn't used, the writer is where the output
-- goes and the state is for keeping track of the tokens and some other
-- useful info, and the I/O part is used for printing debugging info.
-type LaTeX = ErrorT String (RWST () Text State IO)
+type LaTeX = ExceptT String (RWST () Text State IO)
data State = State
{ tokens :: Tokens
@@ -66,8 +68,8 @@ type Tokens = [Token]
data Token = Token
{ text :: Text
- , info :: MetaInfo
- , position :: Integer -- ^ Is not used currently, but could
+ , info :: Aspects
+ , position :: Int -- ^ Is not used currently, but could
-- potentially be used for hyperlinks as in
-- the HTML output?
}
@@ -78,7 +80,7 @@ data Debug = MoveColumn | NonCode | Code | Spaces | Output
-- | Run function for the @LaTeX@ monad.
runLaTeX :: LaTeX a -> () -> State -> IO (Either String a, State, Text)
-runLaTeX = runRWST . runErrorT
+runLaTeX = runRWST . runExceptT
emptyState :: State
emptyState = State
@@ -93,6 +95,7 @@ emptyState = State
------------------------------------------------------------------------
-- * Some helpers.
+(<+>) :: Text -> Text -> Text
(<+>) = T.append
isInfixOf' :: Text -> Text -> Maybe (Text, Text)
@@ -246,24 +249,40 @@ output text = do
-- Polytable, http://www.ctan.org/pkg/polytable, is used for code
-- alignment, similar to lhs2TeX's approach.
+nl, beginCode, endCode :: Text
nl = T.pack "%\n"
beginCode = T.pack "\\begin{code}"
endCode = T.pack "\\end{code}"
-ptOpen = T.pack "\\>"
-ptOpen' i = ptOpen <+> T.pack ("[" ++ show i ++ "]")
-ptClose = T.pack "\\<"
+ptOpen :: Text
+ptOpen = T.pack "\\>"
+
+ptOpen' :: Show a => a -> Text
+ptOpen' i = ptOpen <+> T.pack ("[" ++ show i ++ "]")
+
+ptClose :: Text
+ptClose = T.pack "\\<"
+
+ptClose' :: Show a => a -> Text
ptClose' i = ptClose <+> T.pack ("[" ++ show i ++ "]")
-ptNL = nl <+> T.pack "\\\\\n"
-cmdPrefix = T.pack "\\Agda"
-cmdArg x = T.singleton '{' <+> x <+> T.singleton '}'
+ptNL :: Text
+ptNL = nl <+> T.pack "\\\\\n"
+
+cmdPrefix :: Text
+cmdPrefix = T.pack "\\Agda"
+
+cmdArg :: Text -> Text
+cmdArg x = T.singleton '{' <+> x <+> T.singleton '}'
+
+cmdIndent :: Show a => a -> Text
cmdIndent i = cmdPrefix <+> T.pack "Indent" <+>
cmdArg (T.pack (show i)) <+> cmdArg T.empty
-infixl' = T.pack "infixl"
-infix' = T.pack "infix"
-infixr' = T.pack "infixr"
+infixl', infix', infixr' :: Text
+infixl' = T.pack "infixl"
+infix' = T.pack "infix"
+infixr' = T.pack "infixr"
------------------------------------------------------------------------
-- * Automaton.
@@ -474,6 +493,7 @@ spaces (_ : ss) = __IMPOSSIBLE__
------------------------------------------------------------------------
-- * Main.
+defaultStyFile :: String
defaultStyFile = "agda.sty"
-- | The only exported function. It's (only) called in @Main.hs at .
@@ -529,7 +549,7 @@ toLaTeX source hi
. map (\xs -> case xs of
(mi, (pos, _)) : _ ->
Token { text = T.pack $ map (\(_, (_, c)) -> c) xs
- , info = maybe mempty id mi
+ , info = fromMaybe mempty mi
, position = pos
}
[] -> __IMPOSSIBLE__)
@@ -540,7 +560,7 @@ toLaTeX source hi
-- Look up the meta info at each position in the highlighting info.
. map (\(pos, char) ->
- (Map.lookup pos infoMap, (pos, char)))
+ (IntMap.lookup pos infoMap, (pos, char)))
-- Add position in file to each character.
. zip [1..]
diff --git a/src/full/Agda/Interaction/Highlighting/Precise.hs b/src/full/Agda/Interaction/Highlighting/Precise.hs
index 2c90106..932dafa 100644
--- a/src/full/Agda/Interaction/Highlighting/Precise.hs
+++ b/src/full/Agda/Interaction/Highlighting/Precise.hs
@@ -7,7 +7,7 @@ module Agda.Interaction.Highlighting.Precise
Aspect(..)
, NameKind(..)
, OtherAspect(..)
- , MetaInfo(..)
+ , Aspects(..)
, File
, HighlightingInfo
-- ** Creation
@@ -41,6 +41,8 @@ import Data.Monoid
import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Agda.Utils.QuickCheck
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Typeable (Typeable)
@@ -53,8 +55,9 @@ import Agda.Interaction.Highlighting.Range
------------------------------------------------------------------------
-- Files
--- | Various more or less syntactic aspects of the code. (These cannot
--- overlap.)
+-- | Syntactic aspects of the code. (These cannot overlap.)
+-- They can be obtained from the lexed tokens already,
+-- except for the 'NameKind'.
data Aspect
= Comment
@@ -66,6 +69,8 @@ data Aspect
| Name (Maybe NameKind) Bool -- ^ Is the name an operator part?
deriving (Eq, Show, Typeable)
+-- | @NameKind at s are figured our during scope checking.
+
data NameKind
= Bound -- ^ Bound variable.
| Constructor C.Induction -- ^ Inductive or coinductive constructor.
@@ -79,8 +84,8 @@ data NameKind
| Argument -- ^ Named argument, like x in {x = v}
deriving (Eq, Show, Typeable)
--- | Other aspects. (These can overlap with each other and with
--- 'Aspect's.)
+-- | Other aspects, generated by type checking.
+-- (These can overlap with each other and with 'Aspect's.)
data OtherAspect
= Error
@@ -100,7 +105,7 @@ data OtherAspect
-- | Meta information which can be associated with a
-- character\/character range.
-data MetaInfo = MetaInfo
+data Aspects = Aspects
{ aspect :: Maybe Aspect
, otherAspects :: [OtherAspect]
, note :: Maybe String
@@ -108,7 +113,7 @@ data MetaInfo = MetaInfo
-- something like that. It should contain useful information about
-- the range (like the module containing a certain identifier, or
-- the fixity of an operator).
- , definitionSite :: Maybe (SC.TopLevelModuleName, Integer)
+ , definitionSite :: Maybe (SC.TopLevelModuleName, Int)
-- ^ The definition site of the annotated thing, if applicable and
-- known. File positions are counted from 1.
}
@@ -118,7 +123,7 @@ data MetaInfo = MetaInfo
--
-- The first position in the file has number 1.
-newtype File = File { mapping :: Map Integer MetaInfo }
+newtype File = File { mapping :: IntMap Aspects }
deriving (Eq, Show, Typeable)
-- | Syntax highlighting information.
@@ -131,13 +136,13 @@ type HighlightingInfo = CompressedFile
-- | @'singleton' rs m@ is a file whose positions are those in @rs@,
-- and in which every position is associated with @m at .
-singleton :: Ranges -> MetaInfo -> File
+singleton :: Ranges -> Aspects -> File
singleton rs m = File {
- mapping = Map.fromAscList [ (p, m) | p <- rangesToPositions rs ] }
+ mapping = IntMap.fromAscList [ (p, m) | p <- rangesToPositions rs ] }
-- | Like 'singleton', but with several 'Ranges' instead of only one.
-several :: [Ranges] -> MetaInfo -> File
+several :: [Ranges] -> Aspects -> File
several rs m = mconcat $ map (\r -> singleton r m) rs
------------------------------------------------------------------------
@@ -145,36 +150,38 @@ several rs m = mconcat $ map (\r -> singleton r m) rs
-- | Merges meta information.
-mergeMetaInfo :: MetaInfo -> MetaInfo -> MetaInfo
-mergeMetaInfo m1 m2 = MetaInfo
+mergeAspects :: Aspects -> Aspects -> Aspects
+mergeAspects m1 m2 = Aspects
{ aspect = (mplus `on` aspect) m1 m2
, otherAspects = nub $ ((++) `on` otherAspects) m1 m2
, note = case (note m1, note m2) of
(Just n1, Just n2) -> Just $
- if n1 == n2 then n1
- else addFinalNewLine n1 ++ "----\n" ++ n2
+ if n1 == n2
+ then n1
+ else addFinalNewLine n1 ++ "----\n" ++ n2
(Just n1, Nothing) -> Just n1
(Nothing, Just n2) -> Just n2
(Nothing, Nothing) -> Nothing
, definitionSite = (mplus `on` definitionSite) m1 m2
}
-instance Monoid MetaInfo where
- mempty = MetaInfo { aspect = Nothing
- , otherAspects = []
- , note = Nothing
- , definitionSite = Nothing
- }
- mappend = mergeMetaInfo
+instance Monoid Aspects where
+ mempty = Aspects
+ { aspect = Nothing
+ , otherAspects = []
+ , note = Nothing
+ , definitionSite = Nothing
+ }
+ mappend = mergeAspects
-- | Merges files.
merge :: File -> File -> File
merge f1 f2 =
- File { mapping = (Map.unionWith mappend `on` mapping) f1 f2 }
+ File { mapping = (IntMap.unionWith mappend `on` mapping) f1 f2 }
instance Monoid File where
- mempty = File { mapping = Map.empty }
+ mempty = File { mapping = IntMap.empty }
mappend = merge
------------------------------------------------------------------------
@@ -182,30 +189,30 @@ instance Monoid File where
-- | Returns the smallest position, if any, in the 'File'.
-smallestPos :: File -> Maybe Integer
-smallestPos = fmap (fst . fst) . Map.minViewWithKey . mapping
+smallestPos :: File -> Maybe Int
+smallestPos = fmap (fst . fst) . IntMap.minViewWithKey . mapping
-- | Convert the 'File' to a map from file positions (counting from 1)
-- to meta information.
-toMap :: File -> Map Integer MetaInfo
+toMap :: File -> IntMap Aspects
toMap = mapping
------------------------------------------------------------------------
-- Compressed files
-- | A compressed 'File', in which consecutive positions with the same
--- 'MetaInfo' are stored together.
+-- 'Aspects' are stored together.
newtype CompressedFile =
- CompressedFile { ranges :: [(Range, MetaInfo)] }
+ CompressedFile { ranges :: [(Range, Aspects)] }
deriving (Eq, Show, Typeable)
-- | Invariant for compressed files.
--
-- Note that these files are not required to be /maximally/
-- compressed, because ranges are allowed to be empty, and the
--- 'MetaInfo's in adjacent ranges are allowed to be equal.
+-- 'Aspects's in adjacent ranges are allowed to be equal.
compressedFileInvariant :: CompressedFile -> Bool
compressedFileInvariant (CompressedFile []) = True
@@ -220,7 +227,7 @@ compressedFileInvariant (CompressedFile f) =
compress :: File -> CompressedFile
compress f =
- CompressedFile $ map join $ groupBy' p (Map.toAscList $ mapping f)
+ CompressedFile $ map join $ groupBy' p (IntMap.toAscList $ mapping f)
where
p (pos1, m1) (pos2, m2) = pos2 == pos1 + 1 && m1 == m2
join pms = ( Range { from = head ps, to = last ps + 1 }
@@ -233,11 +240,12 @@ compress f =
decompress :: CompressedFile -> File
decompress =
File .
- Map.fromList .
+ IntMap.fromList .
concat .
map (\(r, m) -> [ (p, m) | p <- rangeToPositions r ]) .
ranges
+prop_compress :: File -> Bool
prop_compress f =
compressedFileInvariant c
&&
@@ -261,18 +269,20 @@ noHighlightingInRange rs (CompressedFile hs) =
-- | @'singletonC' rs m@ is a file whose positions are those in @rs@,
-- and in which every position is associated with @m at .
-singletonC :: Ranges -> MetaInfo -> CompressedFile
+singletonC :: Ranges -> Aspects -> CompressedFile
singletonC (Ranges rs) m =
CompressedFile [(r, m) | r <- rs, not (empty r)]
+prop_singleton :: Ranges -> Aspects -> Bool
prop_singleton rs m = singleton rs m == decompress (singletonC rs m)
-- | Like 'singletonR', but with a list of 'Ranges' instead of a
-- single one.
-severalC :: [Ranges] -> MetaInfo -> CompressedFile
+severalC :: [Ranges] -> Aspects -> CompressedFile
severalC rss m = mconcat $ map (\rs -> singletonC rs m) rss
+prop_several :: [Ranges] -> Aspects -> Bool
prop_several rss m = several rss m == decompress (severalC rss m)
-- | Merges compressed files.
@@ -293,7 +303,7 @@ mergeC (CompressedFile f1) (CompressedFile f2) =
-- Precondition: The ranges are overlapping.
fuse (i1, m1) (i2, m2) =
( fix [ (Range { from = a, to = b }, ma)
- , (Range { from = b, to = c }, mergeMetaInfo m1 m2)
+ , (Range { from = b, to = c }, mergeAspects m1 m2)
]
, fix [ (Range { from = c, to = d }, md)
]
@@ -304,6 +314,7 @@ mergeC (CompressedFile f1) (CompressedFile f2) =
[(from i1, m1), (to i1, m1), (from i2, m2), (to i2, m2)]
fix = filter (not . empty . fst)
+prop_merge :: File -> File -> Bool
prop_merge f1 f2 =
merge f1 f2 == decompress (mergeC (compress f1) (compress f2))
@@ -315,7 +326,7 @@ instance Monoid CompressedFile where
-- where all the positions in @f1@ are @< p@, and all the positions
-- in @f2@ are @>= p at .
-splitAtC :: Integer -> CompressedFile ->
+splitAtC :: Int -> CompressedFile ->
(CompressedFile, CompressedFile)
splitAtC p f = (CompressedFile f1, CompressedFile f2)
where
@@ -330,6 +341,7 @@ splitAtC p f = (CompressedFile f1, CompressedFile f2)
toP = Range { from = from r, to = p }
fromP = Range { from = p, to = to r }
+prop_splitAtC :: Int -> CompressedFile -> Bool
prop_splitAtC p f =
all (< p) (positions f1) &&
all (>= p) (positions f2) &&
@@ -337,14 +349,15 @@ prop_splitAtC p f =
where
(f1, f2) = splitAtC p f
- positions = Map.keys . toMap . decompress
+ positions = IntMap.keys . toMap . decompress
-- | Returns the smallest position, if any, in the 'CompressedFile'.
-smallestPosC :: CompressedFile -> Maybe Integer
+smallestPosC :: CompressedFile -> Maybe Int
smallestPosC (CompressedFile []) = Nothing
smallestPosC (CompressedFile ((r, _) : _)) = Just (from r)
+prop_smallestPos :: CompressedFile -> Bool
prop_smallestPos f = smallestPos (decompress f) == smallestPosC f
------------------------------------------------------------------------
@@ -403,35 +416,35 @@ instance Arbitrary OtherAspect where
instance CoArbitrary OtherAspect where
coarbitrary = coarbitrary . fromEnum
-instance Arbitrary MetaInfo where
+instance Arbitrary Aspects where
arbitrary = do
aspect <- arbitrary
other <- arbitrary
note <- maybeGen string
defSite <- arbitrary
- return (MetaInfo { aspect = aspect, otherAspects = other
+ return (Aspects { aspect = aspect, otherAspects = other
, note = note, definitionSite = defSite })
where string = listOfElements "abcdefABCDEF/\\.\"'@()åäö\n"
- shrink (MetaInfo a o n d) =
- [ MetaInfo a o n d | a <- shrink a ] ++
- [ MetaInfo a o n d | o <- shrink o ] ++
- [ MetaInfo a o n d | n <- shrink n ] ++
- [ MetaInfo a o n d | d <- shrink d ]
+ shrink (Aspects a o n d) =
+ [ Aspects a o n d | a <- shrink a ] ++
+ [ Aspects a o n d | o <- shrink o ] ++
+ [ Aspects a o n d | n <- shrink n ] ++
+ [ Aspects a o n d | d <- shrink d ]
-instance CoArbitrary MetaInfo where
- coarbitrary (MetaInfo aspect otherAspects note defSite) =
+instance CoArbitrary Aspects where
+ coarbitrary (Aspects aspect otherAspects note defSite) =
coarbitrary aspect .
coarbitrary otherAspects .
coarbitrary note .
coarbitrary defSite
instance Arbitrary File where
- arbitrary = fmap (File . Map.fromList) $ listOf arbitrary
- shrink = map (File . Map.fromList) . shrink . Map.toList . toMap
+ arbitrary = fmap (File . IntMap.fromList) $ listOf arbitrary
+ shrink = map (File . IntMap.fromList) . shrink . IntMap.toList . toMap
instance CoArbitrary File where
- coarbitrary (File rs) = coarbitrary (Map.toAscList rs)
+ coarbitrary (File rs) = coarbitrary (IntMap.toAscList rs)
instance Arbitrary CompressedFile where
arbitrary = do
diff --git a/src/full/Agda/Interaction/Highlighting/Range.hs b/src/full/Agda/Interaction/Highlighting/Range.hs
index 991ebed..f859a86 100644
--- a/src/full/Agda/Interaction/Highlighting/Range.hs
+++ b/src/full/Agda/Interaction/Highlighting/Range.hs
@@ -31,7 +31,7 @@ import Agda.Utils.QuickCheck
--
-- Invariant: @'from' '<=' 'to'@.
-data Range = Range { from, to :: Integer }
+data Range = Range { from, to :: Int }
deriving (Eq, Ord, Show, Typeable)
-- | The 'Range' invariant.
@@ -72,14 +72,15 @@ empty r = to r <= from r
-- | Converts a range to a list of positions.
-rangeToPositions :: Range -> [Integer]
+rangeToPositions :: Range -> [Int]
rangeToPositions r = [from r .. to r - 1]
-- | Converts several ranges to a list of positions.
-rangesToPositions :: Ranges -> [Integer]
+rangesToPositions :: Ranges -> [Int]
rangesToPositions (Ranges rs) = concatMap rangeToPositions rs
+prop_rangesToPositions :: Ranges -> Bool
prop_rangesToPositions rs = sorted (rangesToPositions rs)
-- | Converts a 'P.Range' to a 'Ranges'.
@@ -90,7 +91,7 @@ rToR (P.Range is) = Ranges (map iToR is)
iToR (P.Interval { P.iStart = P.Pn { P.posPos = pos1 }
, P.iEnd = P.Pn { P.posPos = pos2 }
}) =
- Range { from = toInteger pos1, to = toInteger pos2 }
+ Range { from = fromIntegral pos1, to = fromIntegral pos2 }
------------------------------------------------------------------------
-- Operations
@@ -115,6 +116,7 @@ minus (Ranges rs1) (Ranges rs2) = Ranges (m rs1 rs2)
| to y < to x = m (Range { from = to y, to = to x } : xs) ys
| otherwise = m xs (y:ys)
+prop_minus :: Ranges -> Ranges -> Bool
prop_minus xs ys =
rangesToPositions (xs `minus` ys) ==
rangesToPositions xs \\ rangesToPositions ys
diff --git a/src/full/Agda/Interaction/Highlighting/Vim.hs b/src/full/Agda/Interaction/Highlighting/Vim.hs
index 04185b8..d559e84 100644
--- a/src/full/Agda/Interaction/Highlighting/Vim.hs
+++ b/src/full/Agda/Interaction/Highlighting/Vim.hs
@@ -22,26 +22,26 @@ import Agda.Utils.Tuple
vimFile :: FilePath -> FilePath
vimFile file =
case splitFileName file of
- (path, name) -> path </> "" <.> name <.> "vim"
+ (path, name) -> path </> "" <.> name <.> "vim"
escape :: String -> String
escape = concatMap esc
where
- escchars = "$\\^.*~[]"
- esc c | c `elem` escchars = ['\\',c]
- | otherwise = [c]
+ escchars = "$\\^.*~[]"
+ esc c | c `elem` escchars = ['\\',c]
+ | otherwise = [c]
wordBounded :: String -> String
wordBounded s0 = concat ["\\<", s0, "\\>"]
keyword :: String -> [String] -> String
keyword _ [] = ""
-keyword cat ws = "syn keyword " ++ unwords (cat : ws)
+keyword cat ws = "syn keyword " ++ unwords (cat : ws)
match :: String -> [String] -> String
match _ [] = ""
-match cat ws = "syn match " ++ cat ++ " \"" ++
- concat (List.intersperse "\\|" $ map (wordBounded . escape) ws) ++ "\""
+match cat ws = "syn match " ++ cat ++ " \"" ++
+ concat (List.intersperse "\\|" $ map (wordBounded . escape) ws) ++ "\""
matches :: [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String]
matches cons icons defs idefs flds iflds =
@@ -49,41 +49,41 @@ matches cons icons defs idefs flds iflds =
$ List.sortBy (compare `on` fst)
$ cons' ++ defs' ++ icons' ++ idefs'
where
- cons' = foo "agdaConstructor" $ classify length cons
- icons' = foo "agdaInfixConstructor" $ classify length icons
- defs' = foo "agdaFunction" $ classify length defs
- idefs' = foo "agdaInfixFunction" $ classify length idefs
- flds' = foo "agdaProjection" $ classify length flds
- iflds' = foo "agdaInfixProjection" $ classify length iflds
+ cons' = foo "agdaConstructor" $ classify length cons
+ icons' = foo "agdaInfixConstructor" $ classify length icons
+ defs' = foo "agdaFunction" $ classify length defs
+ idefs' = foo "agdaInfixFunction" $ classify length idefs
+ flds' = foo "agdaProjection" $ classify length flds
+ iflds' = foo "agdaInfixProjection" $ classify length iflds
- classify f = List.groupBy ((==) `on` f)
- . List.sortBy (compare `on` f)
+ classify f = List.groupBy ((==) `on` f)
+ . List.sortBy (compare `on` f)
- foo :: String -> [[String]] -> [(Int, String)]
- foo cat = map (length . head /\ match cat)
+ foo :: String -> [[String]] -> [(Int, String)]
+ foo cat = map (length . head /\ match cat)
toVim :: NamesInScope -> String
toVim ns = unlines $ matches mcons micons mdefs midefs mflds miflds
where
- cons = [ x | (x, def:_) <- Map.toList ns, anameKind def == ConName ]
- defs = [ x | (x, def:_) <- Map.toList ns, anameKind def == DefName ]
- flds = [ x | (x, fld:_) <- Map.toList ns, anameKind fld == FldName ]
+ cons = [ x | (x, def:_) <- Map.toList ns, anameKind def == ConName ]
+ defs = [ x | (x, def:_) <- Map.toList ns, anameKind def == DefName ]
+ flds = [ x | (x, fld:_) <- Map.toList ns, anameKind fld == FldName ]
- mcons = map show cons
- mdefs = map show defs
- mflds = map show flds
+ mcons = map show cons
+ mdefs = map show defs
+ mflds = map show flds
- micons = concatMap parts cons
- midefs = concatMap parts defs
- miflds = concatMap parts flds
+ micons = concatMap parts cons
+ midefs = concatMap parts defs
+ miflds = concatMap parts flds
- parts (NoName _ _) = []
- parts (Name _ [_]) = []
- parts (Name _ ps) = [ rawNameToString x | Id x <- ps ]
+ parts (NoName _ _) = []
+ parts (Name _ [_]) = []
+ parts (Name _ ps) = [ rawNameToString x | Id x <- ps ]
generateVimFile :: FilePath -> TCM ()
generateVimFile file = do
scope <- getScope
liftIO $ UTF8.writeFile (vimFile file) $ toVim $ names scope
where
- names = nsNames . everythingInScope
+ names = nsNames . everythingInScope
diff --git a/src/full/Agda/Interaction/Imports.hs b/src/full/Agda/Interaction/Imports.hs
index d8d2809..e193baa 100644
--- a/src/full/Agda/Interaction/Imports.hs
+++ b/src/full/Agda/Interaction/Imports.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-| This module deals with finding imported modules and loading their
@@ -8,7 +8,6 @@ module Agda.Interaction.Imports where
import Prelude
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import qualified Control.Exception as E
@@ -23,9 +22,12 @@ import Data.Maybe
import Data.Monoid (mempty, mappend)
import Data.Map (Map)
import Data.Set (Set)
+
import System.Directory (doesFileExist, getModificationTime, removeFile)
import System.FilePath ((</>))
+import qualified Text.PrettyPrint.Boxes as Boxes
+
import Paths_Agda (getDataFileName)
import qualified Agda.Syntax.Abstract as A
@@ -40,7 +42,7 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Errors
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Monad
--- import Agda.TypeChecking.Monad.Base.KillRange -- killRange for Signature
+import Agda.TypeChecking.Monad.Base.KillRange -- killRange for Signature
import Agda.TypeChecking.Serialise
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Primitive
@@ -56,25 +58,34 @@ import Agda.Interaction.Highlighting.Precise (HighlightingInfo)
import Agda.Interaction.Highlighting.Generate
import Agda.Interaction.Highlighting.Vim
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.FileName
+import Agda.Utils.Lens
import Agda.Utils.Monad
+import Agda.Utils.Null (unlessNullM)
import Agda.Utils.IO.Binary
import Agda.Utils.Pretty
-import Agda.Utils.Fresh
import Agda.Utils.Time
import Agda.Utils.Hash
import qualified Agda.Utils.Trie as Trie
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+-- | Are we loading the interface for the user-loaded file
+-- or for an import?
+data MainInterface
+ = MainInterface -- ^ Interface for main file.
+ | NotMainInterface -- ^ Interface for imported file.
+ deriving (Eq, Show)
+
-- | Merge an interface into the current proof state.
mergeInterface :: Interface -> TCM ()
mergeInterface i = do
- let sig = iSignature i
- builtin = Map.toList $ iBuiltin i
- prim = [ x | (_,Prim x) <- builtin ]
- bi = Map.fromList [ (x,Builtin t) | (x,Builtin t) <- builtin ]
+ let sig = iSignature i
+ builtin = Map.toList $ iBuiltin i
+ prim = [ x | (_,Prim x) <- builtin ]
+ bi = Map.fromList [ (x,Builtin t) | (x,Builtin t) <- builtin ]
bs <- gets stBuiltinThings
reportSLn "import.iface.merge" 10 $ "Merging interface"
reportSLn "import.iface.merge" 20 $
@@ -93,22 +104,19 @@ mergeInterface i = do
reportSLn "import.iface.merge" 20 $
" Rebinding primitives " ++ show prim
prim <- Map.fromList <$> mapM rebind prim
- modify $ \st -> st { stImportedBuiltins = stImportedBuiltins st `Map.union` prim
- }
+ stImportedBuiltins %= (`Map.union` prim)
where
- rebind (x, q) = do
- PrimImpl _ pf <- lookupPrimitiveFunction x
- return (x, Prim $ pf { primFunName = q })
+ rebind (x, q) = do
+ PrimImpl _ pf <- lookupPrimitiveFunction x
+ return (x, Prim $ pf { primFunName = q })
addImportedThings ::
Signature -> BuiltinThings PrimFun -> Set String -> A.PatternSynDefns -> TCM ()
addImportedThings isig ibuiltin hsImports patsyns = do
- modify $ \st -> st
- { stImports = unionSignatures [stImports st, isig]
- , stImportedBuiltins = Map.union (stImportedBuiltins st) ibuiltin
- , stHaskellImports = Set.union (stHaskellImports st) hsImports
- , stPatternSynImports = Map.union (stPatternSynImports st) patsyns
- }
+ stImports %= \imp -> unionSignatures [imp, isig]
+ stImportedBuiltins %= \imp -> Map.union imp ibuiltin
+ stHaskellImports %= \imp -> Set.union imp hsImports
+ stPatternSynImports %= \imp -> Map.union imp patsyns
addSignatureInstances isig
-- | Scope checks the given module. A proper version of the module
@@ -146,10 +154,10 @@ alreadyVisited x getIface = do
case mm of
-- A module with warnings should never be allowed to be
-- imported from another module.
- Just mi | not (miWarnings mi) -> do
+ Just mi | not (miWarnings mi) -> do
reportSLn "import.visit" 10 $ " Already visited " ++ render (pretty x)
return (miInterface mi, NoWarnings)
- _ -> do
+ _ -> do
reportSLn "import.visit" 5 $ " Getting interface for " ++ render (pretty x)
r@(i, wt) <- getIface
reportSLn "import.visit" 5 $ " Now we've looked at " ++ render (pretty x)
@@ -164,7 +172,7 @@ alreadyVisited x getIface = do
-- or the file passed on the command line.
--
-- First, the primitive modules are imported.
--- Then, 'typeCheck' is called to do the main work.
+-- Then, @getInterface'@ is called to do the main work.
typeCheckMain :: AbsolutePath -> TCM (Interface, MaybeWarnings)
typeCheckMain f = do
@@ -188,28 +196,27 @@ typeCheckMain f = do
moduleName $ mkAbsolute $
libpath </> "prim" </> "Agda" </> "Primitive.agda"
reportSLn "import.main" 10 $ "Done importing the primitive modules."
- typeCheck f
-
--- | Type checks the given module (if necessary).
---
--- Called recursively for imported modules.
-typeCheck :: AbsolutePath -> TCM (Interface, MaybeWarnings)
-typeCheck f = do
+ -- Now do the type checking via getInterface.
m <- moduleName f
- getInterface' m True
+ getInterface' m MainInterface
--- | Tries to return the interface associated to the given module. The
--- time stamp of the relevant interface file is also returned. May
--- type check the module. An error is raised if a warning is
--- encountered.
+-- | Tries to return the interface associated to the given (imported) module.
+-- The time stamp of the relevant interface file is also returned.
+-- Calls itself recursively for the imports of the given module.
+-- May type check the module.
+-- An error is raised if a warning is encountered.
+--
+-- Do not use this for the main file, use 'typeCheckMain' instead.
getInterface :: ModuleName -> TCM Interface
getInterface = getInterface_ . toTopLevelModuleName
+-- | See 'getInterface'.
+
getInterface_ :: C.TopLevelModuleName -> TCM Interface
getInterface_ x = do
- (i, wt) <- getInterface' x False
+ (i, wt) <- getInterface' x NotMainInterface
case wt of
SomeWarnings w -> warningsToError w
NoWarnings -> return i
@@ -218,18 +225,19 @@ getInterface_ x = do
-- encountered then they are returned instead of being turned into
-- errors.
-getInterface' :: C.TopLevelModuleName
- -> Bool -- ^ If type checking is necessary, should all
- -- state changes inflicted by 'createInterface'
- -- be preserved?
- -> TCM (Interface, MaybeWarnings)
-getInterface' x includeStateChanges =
- withIncreasedModuleNestingLevel $
+getInterface'
+ :: C.TopLevelModuleName
+ -> MainInterface
+ -- ^ If type checking is necessary,
+ -- should all state changes inflicted by 'createInterface' be preserved?
+ -> TCM (Interface, MaybeWarnings)
+getInterface' x isMain = do
+ withIncreasedModuleNestingLevel $ do
-- Preserve the pragma options unless includeStateChanges is True.
- bracket_ (stPragmaOptions <$> get)
+ bracket_ (use stPragmaOptions)
(unless includeStateChanges . setPragmaOptions) $ do
-- Forget the pragma options (locally).
- setCommandLineOptions . stPersistentOptions . stPersistent =<< get
+ setCommandLineOptions . stPersistentOptions . stPersistentState =<< get
alreadyVisited x $ addImportCycleCheck x $ do
file <- findFile x -- requires source to exist
@@ -253,8 +261,11 @@ getInterface' x includeStateChanges =
" " ++ render (pretty x) ++ " is " ++
(if uptodate then "" else "not ") ++ "up-to-date."
+ -- Andreas, 2014-10-20 AIM XX:
+ -- Always retype-check the main file to get the iInsideScope
+ -- which is no longer serialized.
(stateChangesIncluded, (i, wt)) <-
- if uptodate then skip file else typeCheckThe file
+ if uptodate && isMain == NotMainInterface then skip file else typeCheckThe file
-- Ensure that the given module name matches the one in the file.
let topLevelName = toTopLevelModuleName $ iModuleName i
@@ -272,7 +283,7 @@ getInterface' x includeStateChanges =
ifTopLevelAndHighlightingLevelIs NonInteractive $
highlightFromInterface i file
- modify (\s -> s { stCurrentModule = Just $ iModuleName i })
+ stCurrentModule .= Just (iModuleName i)
-- Interfaces are only stored if no warnings were encountered.
case wt of
@@ -282,6 +293,8 @@ getInterface' x includeStateChanges =
return (i, wt)
where
+ includeStateChanges = isMain == MainInterface
+
isCached file = do
let ifile = filePath $ toIFile file
exist <- liftIO $ doesFileExistCaseSensitive ifile
@@ -327,10 +340,10 @@ getInterface' x includeStateChanges =
-- Check that it's the right version
case mi of
- Nothing -> do
+ Nothing -> do
reportSLn "import.iface" 5 $ " bad interface, re-type checking"
typeCheckThe file
- Just i -> do
+ Just i -> do
reportSLn "import.iface" 5 $ " imports: " ++ show (iImportedModules i)
@@ -339,7 +352,7 @@ getInterface' x includeStateChanges =
-- If any of the imports are newer we need to retype check
if hs /= map snd (iImportedModules i)
then do
- -- liftIO close -- Close the interface file. See above.
+ -- liftIO close -- Close the interface file. See above.
typeCheckThe file
else do
unless cached $ chaseMsg "Skipping" (Just ifile)
@@ -373,12 +386,12 @@ getInterface' x includeStateChanges =
nesting <- asks envModuleNestingLevel
range <- asks envRange
call <- asks envCall
- mf <- gets stModuleToSource
+ mf <- use stModuleToSource
vs <- getVisitedModules
ds <- getDecodedModules
- opts <- stPersistentOptions . stPersistent <$> get
+ opts <- stPersistentOptions . stPersistentState <$> get
isig <- getImportedSignature
- ibuiltin <- gets stImportedBuiltins
+ ibuiltin <- use stImportedBuiltins
ipatsyns <- getPatternSynImports
ho <- getInteractionOutputCallback
-- Every interface is treated in isolation. Note: Changes
@@ -400,16 +413,15 @@ getInterface' x includeStateChanges =
setDecodedModules ds
setCommandLineOptions opts
setInteractionOutputCallback ho
- modify $ \s -> s { stModuleToSource = mf
- }
+ stModuleToSource .= mf
setVisitedModules vs
addImportedThings isig ibuiltin Set.empty ipatsyns
r <- withMsgs $ createInterface file x
- mf <- stModuleToSource <$> get
+ mf <- use stModuleToSource
ds <- getDecodedModules
return (r, do
- modify $ \s -> s { stModuleToSource = mf }
+ stModuleToSource .= mf
setDecodedModules ds
case r of
(i, NoWarnings) -> storeDecodedModule i
@@ -477,6 +489,11 @@ readInterface file = do
writeInterface :: FilePath -> Interface -> TCM ()
writeInterface file i = do
reportSLn "import.iface.write" 5 $ "Writing interface file " ++ file ++ "."
+ -- Andreas, Makoto, 2014-10-18 AIM XX:
+ -- iInsideScope is bloating the interface files, so we do not serialize it?
+ i <- return $
+ i { iInsideScope = emptyScopeInfo
+ }
encodeFile file i
reportSLn "import.iface.write" 5 $ "Wrote interface file."
reportSLn "import.iface.write" 50 $ " hash = " ++ show (iFullHash i) ++ ""
@@ -500,9 +517,9 @@ createInterface
-> TCM (Interface, MaybeWarnings)
createInterface file mname =
local (\e -> e { envCurrentPath = file }) $ do
- modFile <- stModuleToSource <$> get
+ modFile <- use stModuleToSource
fileTokenInfo <- billTop Bench.Highlighting $ generateTokenInfo file
- modify $ \st -> st { stTokens = fileTokenInfo }
+ stTokens .= fileTokenInfo
reportSLn "import.iface.create" 5 $
"Creating interface for " ++ render (pretty mname) ++ "."
@@ -559,12 +576,10 @@ createInterface file mname =
billTop Bench.Highlighting $ do
-- Move any remaining token highlighting to stSyntaxInfo.
- ifTopLevelAndHighlightingLevelIs NonInteractive $
- printHighlightingInfo . stTokens =<< get
- modify $ \st ->
- st { stTokens = mempty
- , stSyntaxInfo = stSyntaxInfo st `mappend` stTokens st
- }
+ toks <- use stTokens
+ ifTopLevelAndHighlightingLevelIs NonInteractive $ printHighlightingInfo toks
+ stTokens .= mempty
+ stSyntaxInfo %= \inf -> inf `mappend` toks
whenM (optGenerateVimFile <$> commandLineOptions) $
-- Generate Vim file.
@@ -575,14 +590,13 @@ createInterface file mname =
reportSLn "scope.top" 50 $ "SCOPE " ++ show (insideScope topLevel)
-- Serialization.
- syntaxInfo <- stSyntaxInfo <$> get
+ syntaxInfo <- use stSyntaxInfo
i <- billTop Bench.Serialization $ do
buildInterface file topLevel syntaxInfo previousHsImports options
-- TODO: It would be nice if unsolved things were highlighted
-- after every mutual block.
- termErrs <- Fold.toList <$> stTermErrs <$> get
unsolvedMetas <- List.nub <$> (mapM getMetaRange =<< getOpenMetas)
unsolvedConstraints <- getAllConstraints
interactionPoints <- getInteractionPoints
@@ -590,7 +604,7 @@ createInterface file mname =
ifTopLevelAndHighlightingLevelIs NonInteractive $
printUnsolvedInfo
- r <- if and [ null termErrs, null unsolvedMetas, null unsolvedConstraints, null interactionPoints ]
+ r <- if and [ null unsolvedMetas, null unsolvedConstraints, null interactionPoints ]
then billTop Bench.Serialization $ do
-- The file was successfully type-checked (and no warnings were
-- encountered), so the interface should be written out.
@@ -598,19 +612,17 @@ createInterface file mname =
writeInterface ifile i
return (i, NoWarnings)
else do
- termErr <- if null termErrs then return Nothing else Just <$> do
- typeError_ $ TerminationCheckFailed termErrs
- return (i, SomeWarnings $ Warnings termErr unsolvedMetas unsolvedConstraints)
+ return (i, SomeWarnings $ Warnings unsolvedMetas unsolvedConstraints)
-- Profiling: Print statistics.
+ printStatistics 30 (Just mname) =<< getStatistics
+
+ -- Get the statistics of the current module
+ -- and add it to the accumulated statistics.
+ localStatistics <- getStatistics
+ lensAccumStatistics %= Map.unionWith (+) localStatistics
verboseS "profile" 1 $ do
- stats <- Map.toList <$> getStatistics
- case stats of
- [] -> return ()
- _ -> reportS "profile" 1 $ unlines $
- [ "Ticks for " ++ show (pretty mname) ] ++
- [ " " ++ s ++ " = " ++ show n
- | (s, n) <- sortBy (compare `on` snd) stats ]
+ reportSLn "import.iface" 5 $ "Accumulated statistics."
return r
@@ -635,15 +647,17 @@ buildInterface file topLevel syntaxInfo previousHsImports pragmas = do
let scope = scope' { scopeCurrent = m }
-- Andreas, 2014-05-03: killRange did not result in significant reduction
-- of .agdai file size, and lost a few seconds performance on library-test.
- -- sig <- killRange <$> getSignature
- sig <- getSignature
- builtin <- gets stLocalBuiltins
+ -- Andreas, Makoto, 2014-10-18 AIM XX: repeating the experiment
+ -- with discarding also the nameBindingSite in QName:
+ -- Saves 10% on serialization time (and file size)!
+ sig <- killRange <$> getSignature
+ builtin <- use stLocalBuiltins
ms <- getImports
mhs <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms
hsImps <- getHaskellImports
patsyns <- getPatternSyns
h <- liftIO $ hashFile file
- let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin
+ let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin
reportSLn "import.iface" 7 " instantiating all meta variables"
i <- instantiateFull $ Interface
{ iSourceHash = h
@@ -687,8 +701,8 @@ isNewerThan new old = do
newExist <- doesFileExist new
oldExist <- doesFileExist old
if not (newExist && oldExist)
- then return newExist
- else do
- newT <- getModificationTime new
- oldT <- getModificationTime old
- return $ newT >= oldT
+ then return newExist
+ else do
+ newT <- getModificationTime new
+ oldT <- getModificationTime old
+ return $ newT >= oldT
diff --git a/src/full/Agda/Interaction/InteractionTop.hs b/src/full/Agda/Interaction/InteractionTop.hs
index b559605..c956729 100644
--- a/src/full/Agda/Interaction/InteractionTop.hs
+++ b/src/full/Agda/Interaction/InteractionTop.hs
@@ -1,13 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS -fno-cse #-}
@@ -19,10 +19,10 @@ module Agda.Interaction.InteractionTop
import Control.Applicative hiding (empty)
import qualified Control.Exception as E
import Control.Monad.Identity
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
+import qualified Data.Char as Char
import Data.Foldable (Foldable)
import Data.Function
import Data.List as List
@@ -73,15 +73,23 @@ import qualified Agda.Compiler.JS.Compiler as JS
import qualified Agda.Auto.Auto as Auto
+import Agda.Utils.Except
+ ( ExceptT
+ , mkExceptT
+ , MonadError(catchError, throwError)
+ , runExceptT
+ )
+
import Agda.Utils.FileName
import Agda.Utils.Hash
import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Lens
import Agda.Utils.Monad
import Agda.Utils.Pretty
import Agda.Utils.String
import Agda.Utils.Time
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------
@@ -248,12 +256,12 @@ runInteraction (IOTCM current highlighting highlightingMethod cmd)
meta <- lift $ computeUnsolvedMetaWarnings
constr <- lift $ computeUnsolvedConstraints
err <- lift $ errorHighlighting e
- modFile <- lift $ gets stModuleToSource
+ modFile <- lift $ use stModuleToSource
let info = compress $ mconcat
-- Errors take precedence over unsolved things.
[err, meta, constr]
s <- lift $ prettyError e
- x <- lift . gets $ optShowImplicit . stPragmaOptions
+ x <- lift $ optShowImplicit <$> use stPragmaOptions
mapM_ putResponse $
[ Resp_DisplayInfo $ Info_Error s ] ++
tellEmacsToJumpToError (getRange e) ++
@@ -406,7 +414,7 @@ data IOTCM' range
-- | The 'Parse' monad.
-- 'StateT' state holds the remaining input.
-type Parse a = ErrorT String (StateT String Identity) a
+type Parse a = ExceptT String (StateT String Identity) a
-- | Converter from the type of 'reads' to 'Parse'
-- The first paramter is part of the error message
@@ -422,7 +430,7 @@ readsToParse s f = do
return a
parseToReadsPrec :: Parse a -> Int -> String -> [(a, String)]
-parseToReadsPrec p i s = case runIdentity . flip runStateT s . runErrorT $ parens' p of
+parseToReadsPrec p i s = case runIdentity . flip runStateT s . runExceptT $ parens' p of
(Right a, s) -> [(a,s)]
_ -> []
@@ -592,7 +600,7 @@ interpret (Cmd_load_highlighting_info source) = do
sourceH <- liftIO $ hashFile absSource
if sourceH == iSourceHash (miInterface mi)
then do
- modFile <- gets stModuleToSource
+ modFile <- use stModuleToSource
return $ Just (iHighlighting $ miInterface mi, modFile)
else
return Nothing
@@ -609,14 +617,14 @@ interpret (Cmd_highlight ii rng s) = withCurrentFile $ do
lift $ printHighlightingInfo =<< generateTokenInfoFromString rng s
lift $ highlightExpr e
where
- handle :: ErrorT String TCM () -> CommandM ()
+ handle :: ExceptT String TCM () -> CommandM ()
handle m = do
- res <- lift $ runErrorT m
+ res <- lift $ runExceptT m
case res of
Left s -> display_info $ Info_Error s
Right _ -> return ()
- try :: String -> TCM a -> ErrorT String TCM a
- try err m = ErrorT $ do
+ try :: String -> TCM a -> ExceptT String TCM a
+ try err m = mkExceptT $ do
(Right <$> m) `catchError` \ _ -> return (Left err)
interpret (Cmd_give ii rng s) = give_gen ii rng s Give
@@ -692,9 +700,14 @@ interpret (Cmd_goal_type_context norm ii rng s) =
cmd_goal_type_context_and empty norm ii rng s
interpret (Cmd_goal_type_context_infer norm ii rng s) = do
- typ <- lift $ B.withInteractionId ii $
- prettyATop =<< B.typeInMeta ii norm =<< B.parseExprIn ii rng s
- cmd_goal_type_context_and (text "Have:" <+> typ) norm ii rng s
+ -- In case of the empty expression to type, don't fail with
+ -- a stupid parse error, but just fall back to
+ -- Cmd_goal_type_context.
+ have <- if all Char.isSpace s then return empty else do
+ typ <- lift $ B.withInteractionId ii $
+ prettyATop =<< B.typeInMeta ii norm =<< B.parseExprIn ii rng s
+ return $ text "Have:" <+> typ
+ cmd_goal_type_context_and have norm ii rng s
interpret (Cmd_show_module_contents norm ii rng s) =
liftCommandMT (B.withInteractionId ii) $ showModuleContents norm rng s
@@ -756,7 +769,7 @@ type GoalCommand = InteractionId -> Range -> String -> Interaction
--
-- If type checking completes without any exceptions having been
-- encountered then the command @cmd r@ is executed, where @r@ is the
--- result of 'Imp.typeCheck'.
+-- result of 'Imp.typeCheckMain'.
cmd_load' :: FilePath -> [FilePath]
-> Bool -- ^ Allow unsolved meta-variables?
@@ -904,7 +917,7 @@ highlightExpr e =
local (\e -> e { envModuleNestingLevel = 0
, envHighlightingLevel = NonInteractive
, envHighlightingMethod = Direct }) $
- generateAndPrintSyntaxInfo decl (Full [])
+ generateAndPrintSyntaxInfo decl Full
where
dummy = mkName_ (NameId 0 0) "dummy"
info = mkDefInfo (nameConcrete dummy) defaultFixity' PublicAccess ConcreteDef (getRange e)
@@ -950,6 +963,8 @@ cmd_helper_function norm ii r s = B.withInteractionId ii $ inTopContext $
-- | Displays the current goal, the given document, and the current
-- context.
+cmd_goal_type_context_and :: Doc -> B.Rewrite -> InteractionId -> Range ->
+ String -> StateT CommandState (TCMT IO) ()
cmd_goal_type_context_and doc norm ii _ _ = do
goal <- lift $ B.withInteractionId ii $ prettyTypeOfMeta norm ii
ctx <- lift $ prettyContext norm True ii
@@ -1000,13 +1015,16 @@ whyInScope s = do
variable (Just x) xs
| null xs = asVar
| otherwise = TCP.vcat
- [ TCP.sep [ asVar, TCP.nest 2 $ TCP.text "shadowing"]
+ [ TCP.sep [ asVar, TCP.nest 2 $ shadowing x]
, TCP.nest 2 $ names xs
]
where
asVar :: TCM Doc
asVar = do
- TCP.text "* a variable bound at" TCP.<+> prettyTCM (nameBindingSite x)
+ TCP.text "* a variable bound at" TCP.<+> prettyTCM (nameBindingSite $ localVar x)
+ shadowing :: LocalVar -> TCM Doc
+ shadowing LocalVar{} = TCP.text "shadowing"
+ shadowing ShadowedVar{} = TCP.text "in conflict with"
names xs = TCP.vcat $ map pName xs
modules ms = TCP.vcat $ map pMod ms
@@ -1020,13 +1038,13 @@ whyInScope s = do
pName a = TCP.sep
[ TCP.text "* a"
TCP.<+> pKind (anameKind a)
- TCP.<+> TCP.text (show $ anameName a)
+ TCP.<+> TCP.text (prettyShow $ anameName a)
, TCP.nest 2 $ TCP.text "brought into scope by"
] TCP.$$
TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))
pMod :: AbstractModule -> TCM Doc
pMod a = TCP.sep
- [ TCP.text "* a module" TCP.<+> TCP.text (show $ amodName a)
+ [ TCP.text "* a module" TCP.<+> TCP.text (prettyShow $ amodName a)
, TCP.nest 2 $ TCP.text "brought into scope by"
] TCP.$$
TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))
@@ -1104,7 +1122,7 @@ display_info info = do
-- xss <- sequence [ List.map (fst . unDom) <$> getContext
-- , Map.keys <$> asks envLetBindings
-- , List.map qnameName . HMap.keys . sigDefinitions <$> getSignature
--- ]
+-- ]
-- return $ concat [ parts $ nameConcrete x | x <- concat xss]
-- where
-- parts x = [ s | Id s <- nameParts x ]
@@ -1115,6 +1133,7 @@ refreshStr taken s = go nameModifiers where
if s' `elem` taken then go mods else (s':taken, s')
go _ = __IMPOSSIBLE__
+nameModifiers :: [String]
nameModifiers = "" : "'" : "''" : [show i | i <-[3..]]
@@ -1154,7 +1173,7 @@ parseAndDoAtToplevel cmd title s = do
let work = lift (B.atTopLevel $ prettyA =<< cmd =<< concreteToAbstract_ e)
res <- if not doTime then work else do
(r, time) <- measureTime work
- return $ text ("Time: " ++ showThousandSep (div time 1000000000) ++ "ms") $$ r
+ return $ text "Time:" <+> pretty time $$ r
display_info (title res)
-- | Tell to highlight the code using the given highlighting
diff --git a/src/full/Agda/Interaction/MakeCase.hs b/src/full/Agda/Interaction/MakeCase.hs
index b9e334d..2e6775c 100644
--- a/src/full/Agda/Interaction/MakeCase.hs
+++ b/src/full/Agda/Interaction/MakeCase.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Interaction.MakeCase where
@@ -12,9 +12,12 @@ import Data.Traversable
import Agda.Syntax.Common
import Agda.Syntax.Position
+import qualified Agda.Syntax.Concrete as C
import qualified Agda.Syntax.Abstract as A
import qualified Agda.Syntax.Info as A
import Agda.Syntax.Internal
+import Agda.Syntax.Scope.Monad (resolveName, ResolvedName(..))
+import Agda.Syntax.Translation.ConcreteToAbstract
import Agda.Syntax.Translation.InternalToAbstract
import Agda.TypeChecking.Monad
@@ -27,17 +30,21 @@ import Agda.TheTypeChecker
import Agda.Interaction.BasicOps
+import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Monad
import qualified Agda.Utils.Pretty as P
import Agda.Utils.Size
import qualified Agda.Utils.HashMap as HMap
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-data CaseContext = FunctionDef | ExtendedLambda Int Int
- deriving (Eq)
+data CaseContext
+ = FunctionDef
+ | ExtendedLambda Int Int
+ deriving (Eq)
+
-- | Find the clause whose right hand side is the given meta
-- BY SEARCHING THE WHOLE SIGNATURE. Returns
-- the original clause, before record patterns have been translated
@@ -82,21 +89,62 @@ findClause m = do
MetaV m' _ -> m == m'
_ -> False
+
-- | Parse variables (visible or hidden), returning their de Bruijn indices.
-- Used in 'makeCase'.
+
parseVariables :: InteractionId -> Range -> [String] -> TCM [Int]
parseVariables ii rng ss = do
+
+ -- Get into the context of the meta.
mId <- lookupInteractionId ii
updateMetaVarRange mId rng
mi <- getMetaInfo <$> lookupMeta mId
- enterClosure mi $ \ _r -> do
- n <- getContextSize
- xs <- forM (downFrom n) $ \ i -> do
- (,i) . P.render <$> prettyTCM (var i)
- forM ss $ \ s -> do
- case lookup s xs of
- Nothing -> typeError $ GenericError $ "Unbound variable " ++ s
- Just i -> return i
+ enterClosure mi $ \ r -> do
+
+ -- Get printed representation of variables in context.
+ n <- getContextSize
+ xs <- forM (downFrom n) $ \ i -> do
+ (,i) . P.render <$> prettyTCM (var i)
+
+ -- Get number of module parameters. These cannot be split on.
+ fv <- getModuleFreeVars =<< currentModule
+ let numSplittableVars = n - fv
+
+ -- Resolve each string to a variable.
+ forM ss $ \ s -> do
+ let failNotVar = typeError $ GenericError $ "Not a (splittable) variable: " ++ s
+ done i
+ | i < numSplittableVars = return i
+ | otherwise = failNotVar
+
+ -- Note: the range in the concrete name is only approximate.
+ resName <- resolveName $ C.QName $ C.Name r $ C.stringNameParts s
+ case resName of
+
+ -- Fail if s is a name, but not of a variable.
+ DefinedName{} -> failNotVar
+ FieldName{} -> failNotVar
+ ConstructorName{} -> failNotVar
+ PatternSynResName{} -> failNotVar
+
+ -- If s is a variable name in scope, get its de Bruijn index
+ -- via the type checker.
+ VarName x -> do
+ (v, _) <- getVarInfo x
+ case ignoreSharing v of
+ Var i [] -> done i
+ _ -> failNotVar
+
+ -- If s is not a name, compare it to the printed variable representation.
+ -- This fallback is to enable splitting on hidden variables.
+ UnknownName -> do
+ case filter ((s ==) . fst) xs of
+ [] -> typeError $ GenericError $ "Unbound variable " ++ s
+ [(_,i)] -> done i
+ -- Issue 1325: Variable names in context can be ambiguous.
+ _ -> typeError $ GenericError $ "Ambiguous variable " ++ s
+
-- | Entry point for case splitting tactic.
makeCase :: InteractionId -> Range -> String -> TCM (CaseContext , [A.Clause])
@@ -116,10 +164,13 @@ makeCase hole rng s = withInteractionId hole $ do
let vars = words s
if null vars then do
-- split result
- res <- splitResult f =<< fixTarget (clauseToSplitClause clause)
- case res of
- Nothing -> typeError $ GenericError $ "Cannot split on result here"
- Just cov -> (casectxt,) <$> do mapM (makeAbstractClause f) $ splitClauses cov
+ (newPats, sc) <- fixTarget (clauseToSplitClause clause)
+ res <- splitResult f sc
+ scs <- case res of
+ Nothing -> if newPats then return [sc] else
+ typeError $ GenericError $ "Cannot split on result here"
+ Just cov -> mapM (snd <.> fixTarget) $ splitClauses cov
+ (casectxt,) <$> mapM (makeAbstractClause f) scs
else do
-- split on variables
vars <- parseVariables hole rng vars
diff --git a/src/full/Agda/Interaction/Monad.hs b/src/full/Agda/Interaction/Monad.hs
index c91e86e..089fc92 100644
--- a/src/full/Agda/Interaction/Monad.hs
+++ b/src/full/Agda/Interaction/Monad.hs
@@ -1,13 +1,16 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
- MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
module Agda.Interaction.Monad where
import Agda.TypeChecking.Monad
import Control.Monad.Trans
-import Control.Monad.Error
import System.Console.Haskeline
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
+
-- | Interaction monad.
type IM = TCMT (InputT IO)
diff --git a/src/full/Agda/Interaction/Options.hs b/src/full/Agda/Interaction/Options.hs
index 50f453d..3249c26 100644
--- a/src/full/Agda/Interaction/Options.hs
+++ b/src/full/Agda/Interaction/Options.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ <= 706
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
#endif
@@ -29,24 +29,25 @@ module Agda.Interaction.Options
) where
import Control.Monad ( when )
-import Control.Monad.Error ( MonadError(..) )
import Data.Maybe ( isJust )
-import Data.List ( isSuffixOf , intercalate )
-import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(ReturnInOrder)
- , OptDescr(..), ArgDescr(..)
- )
+import Data.List ( isSuffixOf , intercalate )
+import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(ReturnInOrder)
+ , OptDescr(..), ArgDescr(..)
+ )
import Agda.Termination.CutOff ( CutOff(..) )
import Agda.Utils.TestHelpers ( runTests )
import Agda.Utils.QuickCheck ( quickCheck' )
import Agda.Utils.FileName ( AbsolutePath )
-import Agda.Utils.Monad ( readM )
+import Agda.Utils.Monad ( readM )
import Agda.Utils.List ( wordsBy )
import Agda.Utils.String ( indent )
import Agda.Utils.Trie ( Trie )
import qualified Agda.Utils.Trie as Trie
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
+
-- | This should probably go somewhere else.
isLiterate :: FilePath -> Bool
isLiterate file = ".lagda" `isSuffixOf` file
@@ -67,36 +68,36 @@ type IncludeDirs = Either [FilePath] [AbsolutePath]
-- interpreted as @["."]@ (see
-- 'Agda.TypeChecking.Monad.Options.makeIncludeDirsAbsolute').
-data CommandLineOptions =
- Options { optProgramName :: String
- , optInputFile :: Maybe FilePath
- , optIncludeDirs :: IncludeDirs
- , optShowVersion :: Bool
- , optShowHelp :: Bool
- , optInteractive :: Bool
- , optRunTests :: Bool
- , optGHCiInteraction :: Bool
- , optCompile :: Bool
- , optCompileNoMain :: Bool
- , optEpicCompile :: Bool
- , optJSCompile :: Bool
- , optCompileDir :: Maybe FilePath
- -- ^ In the absence of a path the project root is used.
- , optGenerateVimFile :: Bool
- , optGenerateLaTeX :: Bool
- , optGenerateHTML :: Bool
- , optDependencyGraph :: Maybe FilePath
- , optLaTeXDir :: FilePath
- , optHTMLDir :: FilePath
- , optCSSFile :: Maybe FilePath
- , optIgnoreInterfaces :: Bool
- , optForcing :: Bool
- , optGhcFlags :: [String]
- , optPragmaOptions :: PragmaOptions
- , optEpicFlags :: [String]
- , optSafe :: Bool
- }
- deriving Show
+data CommandLineOptions = Options
+ { optProgramName :: String
+ , optInputFile :: Maybe FilePath
+ , optIncludeDirs :: IncludeDirs
+ , optShowVersion :: Bool
+ , optShowHelp :: Bool
+ , optInteractive :: Bool
+ , optRunTests :: Bool
+ , optGHCiInteraction :: Bool
+ , optCompile :: Bool
+ , optCompileNoMain :: Bool
+ , optEpicCompile :: Bool
+ , optJSCompile :: Bool
+ , optCompileDir :: Maybe FilePath
+ -- ^ In the absence of a path the project root is used.
+ , optGenerateVimFile :: Bool
+ , optGenerateLaTeX :: Bool
+ , optGenerateHTML :: Bool
+ , optDependencyGraph :: Maybe FilePath
+ , optLaTeXDir :: FilePath
+ , optHTMLDir :: FilePath
+ , optCSSFile :: Maybe FilePath
+ , optIgnoreInterfaces :: Bool
+ , optForcing :: Bool
+ , optGhcFlags :: [String]
+ , optPragmaOptions :: PragmaOptions
+ , optEpicFlags :: [String]
+ , optSafe :: Bool
+ }
+ deriving Show
-- | Options which can be set in a pragma.
@@ -143,34 +144,34 @@ defaultInteractionOptions :: PragmaOptions
defaultInteractionOptions = defaultPragmaOptions
defaultOptions :: CommandLineOptions
-defaultOptions =
- Options { optProgramName = "agda"
- , optInputFile = Nothing
- , optIncludeDirs = Left []
- , optShowVersion = False
- , optShowHelp = False
- , optInteractive = False
- , optRunTests = False
- , optGHCiInteraction = False
- , optCompile = False
- , optCompileNoMain = False
- , optEpicCompile = False
- , optJSCompile = False
- , optCompileDir = Nothing
- , optGenerateVimFile = False
- , optGenerateLaTeX = False
- , optGenerateHTML = False
- , optDependencyGraph = Nothing
- , optLaTeXDir = defaultLaTeXDir
- , optHTMLDir = defaultHTMLDir
- , optCSSFile = Nothing
- , optIgnoreInterfaces = False
- , optForcing = True
- , optGhcFlags = []
- , optPragmaOptions = defaultPragmaOptions
- , optEpicFlags = []
- , optSafe = False
- }
+defaultOptions = Options
+ { optProgramName = "agda"
+ , optInputFile = Nothing
+ , optIncludeDirs = Left []
+ , optShowVersion = False
+ , optShowHelp = False
+ , optInteractive = False
+ , optRunTests = False
+ , optGHCiInteraction = False
+ , optCompile = False
+ , optCompileNoMain = False
+ , optEpicCompile = False
+ , optJSCompile = False
+ , optCompileDir = Nothing
+ , optGenerateVimFile = False
+ , optGenerateLaTeX = False
+ , optGenerateHTML = False
+ , optDependencyGraph = Nothing
+ , optLaTeXDir = defaultLaTeXDir
+ , optHTMLDir = defaultHTMLDir
+ , optCSSFile = Nothing
+ , optIgnoreInterfaces = False
+ , optForcing = True
+ , optGhcFlags = []
+ , optPragmaOptions = defaultPragmaOptions
+ , optEpicFlags = []
+ , optSafe = False
+ }
defaultPragmaOptions :: PragmaOptions
defaultPragmaOptions = PragmaOptions
@@ -197,16 +198,20 @@ defaultPragmaOptions = PragmaOptions
-- | The default termination depth.
+defaultCutOff :: CutOff
defaultCutOff = CutOff 0 -- minimum value
-- | The default output directory for LaTeX.
+defaultLaTeXDir :: String
defaultLaTeXDir = "latex"
-- | The default output directory for HTML.
+defaultHTMLDir :: String
defaultHTMLDir = "html"
+prop_defaultOptions :: Bool
prop_defaultOptions = case checkOpts defaultOptions of
Left _ -> False
Right _ -> True
@@ -281,58 +286,144 @@ inputFlag f o =
Nothing -> return $ o { optInputFile = Just f }
Just _ -> throwError "only one input file allowed"
-versionFlag o = return $ o { optShowVersion = True }
-helpFlag o = return $ o { optShowHelp = True }
-safeFlag o = return $ o { optSafe = True }
-proofIrrelevanceFlag o = return $ o { optProofIrrelevance = True }
-experimentalIrrelevanceFlag o = return $ o { optExperimentalIrrelevance = True }
-noIrrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = False }
-ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }
-allowUnsolvedFlag o = return $ o { optAllowUnsolved = True }
-showImplicitFlag o = return $ o { optShowImplicit = True }
-showIrrelevantFlag o = return $ o { optShowIrrelevant = True }
-runTestsFlag o = return $ o { optRunTests = True }
-ghciInteractionFlag o = return $ o { optGHCiInteraction = True }
-vimFlag o = return $ o { optGenerateVimFile = True }
-latexFlag o = return $ o { optGenerateLaTeX = True }
-latexDirFlag d o = return $ o { optLaTeXDir = d }
-noPositivityFlag o = return $ o { optDisablePositivity = True }
-dontTerminationCheckFlag o = return $ o { optTerminationCheck = False }
-dontCompletenessCheckFlag o = return $ o { optCompletenessCheck = False }
-dontUniverseCheckFlag o = return $ o { optUniverseCheck = False
- , optUniversePolymorphism = False }
-sizedTypes o = return $ o { optSizedTypes = True }
-noSizedTypes o = return $ o { optSizedTypes = False }
-injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True }
-guardingTypeConstructorFlag o = return $ o { optGuardingTypeConstructors = True }
-universePolymorphismFlag o = return $ o { optUniversePolymorphism = True }
-noUniversePolymorphismFlag o = return $ o { optUniversePolymorphism = False }
-noForcingFlag o = return $ o { optForcing = False }
-withKFlag o = return $ o { optWithoutK = False }
-withoutKFlag o = return $ o { optWithoutK = True }
-copatternsFlag o = return $ o { optCopatterns = True }
-noPatternMatchingFlag o = return $ o { optPatternMatching = False }
+versionFlag :: Flag CommandLineOptions
+versionFlag o = return $ o { optShowVersion = True }
+
+helpFlag :: Flag CommandLineOptions
+helpFlag o = return $ o { optShowHelp = True }
+
+safeFlag :: Flag CommandLineOptions
+safeFlag o = return $ o { optSafe = True }
+
+proofIrrelevanceFlag :: Flag PragmaOptions
+proofIrrelevanceFlag o = return $ o { optProofIrrelevance = True }
+
+experimentalIrrelevanceFlag :: Flag PragmaOptions
+experimentalIrrelevanceFlag o = return $ o { optExperimentalIrrelevance = True }
+
+noIrrelevantProjectionsFlag :: Flag PragmaOptions
+noIrrelevantProjectionsFlag o = return $ o { optIrrelevantProjections = False }
+
+ignoreInterfacesFlag :: Flag CommandLineOptions
+ignoreInterfacesFlag o = return $ o { optIgnoreInterfaces = True }
+
+allowUnsolvedFlag :: Flag PragmaOptions
+allowUnsolvedFlag o = return $ o { optAllowUnsolved = True }
+
+showImplicitFlag :: Flag PragmaOptions
+showImplicitFlag o = return $ o { optShowImplicit = True }
+
+showIrrelevantFlag :: Flag PragmaOptions
+showIrrelevantFlag o = return $ o { optShowIrrelevant = True }
+
+runTestsFlag :: Flag CommandLineOptions
+runTestsFlag o = return $ o { optRunTests = True }
+
+ghciInteractionFlag :: Flag CommandLineOptions
+ghciInteractionFlag o = return $ o { optGHCiInteraction = True }
+
+vimFlag :: Flag CommandLineOptions
+vimFlag o = return $ o { optGenerateVimFile = True }
+
+latexFlag :: Flag CommandLineOptions
+latexFlag o = return $ o { optGenerateLaTeX = True }
+
+latexDirFlag :: FilePath -> Flag CommandLineOptions
+latexDirFlag d o = return $ o { optLaTeXDir = d }
+
+noPositivityFlag :: Flag PragmaOptions
+noPositivityFlag o = return $ o { optDisablePositivity = True }
+
+dontTerminationCheckFlag :: Flag PragmaOptions
+dontTerminationCheckFlag o = return $ o { optTerminationCheck = False }
+
+dontCompletenessCheckFlag :: Flag PragmaOptions
+dontCompletenessCheckFlag o = return $ o { optCompletenessCheck = False }
+
+dontUniverseCheckFlag :: Flag PragmaOptions
+dontUniverseCheckFlag o = return $ o { optUniverseCheck = False
+ , optUniversePolymorphism = False
+ }
+sizedTypes :: Flag PragmaOptions
+sizedTypes o = return $ o { optSizedTypes = True }
+
+noSizedTypes :: Flag PragmaOptions
+noSizedTypes o = return $ o { optSizedTypes = False }
+
+injectiveTypeConstructorFlag :: Flag PragmaOptions
+injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True }
+
+guardingTypeConstructorFlag :: Flag PragmaOptions
+guardingTypeConstructorFlag o = return $ o { optGuardingTypeConstructors = True }
+
+universePolymorphismFlag :: Flag PragmaOptions
+universePolymorphismFlag o = return $ o { optUniversePolymorphism = True }
+
+noUniversePolymorphismFlag :: Flag PragmaOptions
+noUniversePolymorphismFlag o = return $ o { optUniversePolymorphism = False }
+
+noForcingFlag :: Flag CommandLineOptions
+noForcingFlag o = return $ o { optForcing = False }
+
+withKFlag :: Flag PragmaOptions
+withKFlag o = return $ o { optWithoutK = False }
+
+withoutKFlag :: Flag PragmaOptions
+withoutKFlag o = return $ o { optWithoutK = True }
+
+copatternsFlag :: Flag PragmaOptions
+copatternsFlag o = return $ o { optCopatterns = True }
+
+noPatternMatchingFlag :: Flag PragmaOptions
+noPatternMatchingFlag o = return $ o { optPatternMatching = False }
+
+interactiveFlag :: Flag CommandLineOptions
interactiveFlag o = return $ o { optInteractive = True
, optPragmaOptions = (optPragmaOptions o)
- { optAllowUnsolved = True }
+ { optAllowUnsolved = True }
}
-compileFlag o = return $ o { optCompile = True }
-compileFlagNoMain o = return $ o { optCompileNoMain = True }
-compileEpicFlag o = return $ o { optEpicCompile = True}
-compileJSFlag o = return $ o { optJSCompile = True}
-compileDirFlag f o = return $ o { optCompileDir = Just f }
-ghcFlag f o = return $ o { optGhcFlags = optGhcFlags o ++ [f] } -- NOTE: Quadratic in number of flags.
-epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] } -- NOTE: Quadratic in number of flags.
-
-htmlFlag o = return $ o { optGenerateHTML = True }
-dependencyGraphFlag f o = return $ o { optDependencyGraph = Just f }
-htmlDirFlag d o = return $ o { optHTMLDir = d }
-cssFlag f o = return $ o { optCSSFile = Just f }
+compileFlag :: Flag CommandLineOptions
+compileFlag o = return $ o { optCompile = True }
+
+compileFlagNoMain :: Flag CommandLineOptions
+compileFlagNoMain o = return $ o { optCompileNoMain = True }
+
+compileEpicFlag :: Flag CommandLineOptions
+compileEpicFlag o = return $ o { optEpicCompile = True}
+
+compileJSFlag :: Flag CommandLineOptions
+compileJSFlag o = return $ o { optJSCompile = True }
+
+compileDirFlag :: FilePath -> Flag CommandLineOptions
+compileDirFlag f o = return $ o { optCompileDir = Just f }
+
+-- NOTE: Quadratic in number of flags.
+ghcFlag :: String -> Flag CommandLineOptions
+ghcFlag f o = return $ o { optGhcFlags = optGhcFlags o ++ [f] }
+
+-- NOTE: Quadratic in number of flags.
+epicFlagsFlag :: String -> Flag CommandLineOptions
+epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] }
+
+htmlFlag :: Flag CommandLineOptions
+htmlFlag o = return $ o { optGenerateHTML = True }
+
+dependencyGraphFlag :: FilePath -> Flag CommandLineOptions
+dependencyGraphFlag f o = return $ o { optDependencyGraph = Just f }
+
+htmlDirFlag :: FilePath -> Flag CommandLineOptions
+htmlDirFlag d o = return $ o { optHTMLDir = d }
+
+cssFlag :: FilePath -> Flag CommandLineOptions
+cssFlag f o = return $ o { optCSSFile = Just f }
+
+includeFlag :: FilePath -> Flag CommandLineOptions
includeFlag d o = return $ o { optIncludeDirs = Left (d : ds) }
where ds = either id (const []) $ optIncludeDirs o
+verboseFlag :: String -> Flag PragmaOptions
verboseFlag s o =
do (k,n) <- parseVerbose s
return $ o { optVerbose = Trie.insert k n $ optVerbose o }
@@ -344,6 +435,7 @@ verboseFlag s o =
return (init ss, n)
usage = throwError "argument to verbose should be on the form x.y.z:N or N"
+terminationDepthFlag :: String -> Flag PragmaOptions
terminationDepthFlag s o =
do k <- readM s `catchError` \_ -> usage
when (k < 1) $ usage -- or: turn termination checking off for 0
@@ -370,33 +462,33 @@ standardOptions =
, Option [] ["epic"] (NoArg compileEpicFlag) "compile program using the Epic backend"
, Option [] ["js"] (NoArg compileJSFlag) "compile program using the JS backend"
, Option [] ["compile-dir"] (ReqArg compileDirFlag "DIR")
- ("directory for compiler output (default: the project root)")
+ ("directory for compiler output (default: the project root)")
, Option [] ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG")
"give the flag GHC-FLAG to GHC when compiling using MAlonzo"
, Option [] ["epic-flag"] (ReqArg epicFlagsFlag "EPIC-FLAG")
"give the flag EPIC-FLAG to Epic when compiling using Epic"
- , Option [] ["test"] (NoArg runTestsFlag)
- "run internal test suite"
- , Option [] ["vim"] (NoArg vimFlag)
- "generate Vim highlighting files"
- , Option [] ["latex"] (NoArg latexFlag)
+ , Option [] ["test"] (NoArg runTestsFlag)
+ "run internal test suite"
+ , Option [] ["vim"] (NoArg vimFlag)
+ "generate Vim highlighting files"
+ , Option [] ["latex"] (NoArg latexFlag)
"generate LaTeX with highlighted source code"
- , Option [] ["latex-dir"] (ReqArg latexDirFlag "DIR")
+ , Option [] ["latex-dir"] (ReqArg latexDirFlag "DIR")
("directory in which LaTeX files are placed (default: " ++
defaultLaTeXDir ++ ")")
- , Option [] ["html"] (NoArg htmlFlag)
- "generate HTML files with highlighted source code"
- , Option [] ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")
- "generate a Dot file with a module dependency graph"
- , Option [] ["html-dir"] (ReqArg htmlDirFlag "DIR")
+ , Option [] ["html"] (NoArg htmlFlag)
+ "generate HTML files with highlighted source code"
+ , Option [] ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")
+ "generate a Dot file with a module dependency graph"
+ , Option [] ["html-dir"] (ReqArg htmlDirFlag "DIR")
("directory in which HTML files are placed (default: " ++
defaultHTMLDir ++ ")")
- , Option [] ["css"] (ReqArg cssFlag "URL")
- "the CSS file used by the HTML files (can be relative)"
- , Option [] ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)
- "ignore interface files (re-type check everything)"
+ , Option [] ["css"] (ReqArg cssFlag "URL")
+ "the CSS file used by the HTML files (can be relative)"
+ , Option [] ["ignore-interfaces"] (NoArg ignoreInterfacesFlag)
+ "ignore interface files (re-type check everything)"
, Option ['i'] ["include-path"] (ReqArg includeFlag "DIR")
- "look for imports in DIR"
+ "look for imports in DIR"
, Option [] ["no-forcing"] (NoArg noForcingFlag)
"disable the forcing optimisation"
, Option [] ["safe"] (NoArg safeFlag)
@@ -410,26 +502,26 @@ standardOptions =
pragmaOptions :: [OptDescr (Flag PragmaOptions)]
pragmaOptions =
- [ Option [] ["show-implicit"] (NoArg showImplicitFlag)
- "show implicit arguments when printing"
- , Option [] ["show-irrelevant"] (NoArg showIrrelevantFlag)
- "show irrelevant arguments when printing"
- , Option ['v'] ["verbose"] (ReqArg verboseFlag "N")
+ [ Option [] ["show-implicit"] (NoArg showImplicitFlag)
+ "show implicit arguments when printing"
+ , Option [] ["show-irrelevant"] (NoArg showIrrelevantFlag)
+ "show irrelevant arguments when printing"
+ , Option ['v'] ["verbose"] (ReqArg verboseFlag "N")
"set verbosity level to N"
- -- , Option [] ["proof-irrelevance"] (NoArg proofIrrelevanceFlag)
- -- "enable proof irrelevance (experimental feature)"
- , Option [] ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)
- "allow unsolved meta variables (only needed in batch mode)"
- , Option [] ["no-positivity-check"] (NoArg noPositivityFlag)
- "do not warn about not strictly positive data types"
- , Option [] ["no-termination-check"] (NoArg dontTerminationCheckFlag)
- "do not warn about possibly nonterminating code"
- , Option [] ["termination-depth"] (ReqArg terminationDepthFlag "N")
- "allow termination checker to count decrease/increase upto N (default N=1)"
- , Option [] ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)
- "do not warn about possibly incomplete pattern matches"
- , Option [] ["type-in-type"] (NoArg dontUniverseCheckFlag)
- "ignore universe levels (this makes Agda inconsistent)"
+ -- , Option [] ["proof-irrelevance"] (NoArg proofIrrelevanceFlag)
+ -- "enable proof irrelevance (experimental feature)"
+ , Option [] ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)
+ "allow unsolved meta variables (only needed in batch mode)"
+ , Option [] ["no-positivity-check"] (NoArg noPositivityFlag)
+ "do not warn about not strictly positive data types"
+ , Option [] ["no-termination-check"] (NoArg dontTerminationCheckFlag)
+ "do not warn about possibly nonterminating code"
+ , Option [] ["termination-depth"] (ReqArg terminationDepthFlag "N")
+ "allow termination checker to count decrease/increase upto N (default N=1)"
+ , Option [] ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)
+ "do not warn about possibly incomplete pattern matches"
+ , Option [] ["type-in-type"] (NoArg dontUniverseCheckFlag)
+ "ignore universe levels (this makes Agda inconsistent)"
, Option [] ["sized-types"] (NoArg sizedTypes)
"use sized types (default, inconsistent with `musical' coinduction)"
, Option [] ["no-sized-types"] (NoArg noSizedTypes)
@@ -465,8 +557,8 @@ parseOptions' ::
[String] -> [OptDescr (Flag opts)] -> (String -> Flag opts) -> Flag opts
parseOptions' argv opts fileArg = \defaults ->
case getOpt (ReturnInOrder fileArg) opts argv of
- (o,_,[]) -> foldl (>>=) (return defaults) o
- (_,_,errs) -> throwError $ concat errs
+ (o,_,[]) -> foldl (>>=) (return defaults) o
+ (_,_,errs) -> throwError $ concat errs
-- | Parse the standard options.
parseStandardOptions :: [String] -> Either String CommandLineOptions
@@ -499,27 +591,27 @@ parsePluginOptions argv opts =
-- agda).
usage :: [OptDescr ()] -> [(String, String, [String], [OptDescr ()])] -> String -> String
usage options pluginInfos progName =
- usageInfo (header progName) options ++
- "\nPlugins:\n" ++
+ usageInfo (header progName) options ++
+ "\nPlugins:\n" ++
indent 2 (concatMap pluginMsg pluginInfos)
where
- header progName = unlines [ "Agda"
- , ""
- , "Usage: " ++ progName ++ " [OPTIONS...] [FILE]"
- ]
+ header progName = unlines [ "Agda"
+ , ""
+ , "Usage: " ++ progName ++ " [OPTIONS...] [FILE]"
+ ]
pluginMsg (name, help, inherited, opts)
| null opts && null inherited = optHeader
| otherwise = usageInfo (optHeader ++
" Plugin-specific options:" ++
- inheritedOptions inherited
- ) opts
+ inheritedOptions inherited
+ ) opts
where
- optHeader = "\n" ++ name ++ "-plugin:\n" ++ indent 2 help
- inheritedOptions [] = ""
- inheritedOptions pls =
- "\n Inherits options from: " ++ unwords pls
+ optHeader = "\n" ++ name ++ "-plugin:\n" ++ indent 2 help
+ inheritedOptions [] = ""
+ inheritedOptions pls =
+ "\n Inherits options from: " ++ unwords pls
------------------------------------------------------------------------
-- All tests
diff --git a/src/full/Agda/Interaction/Options/Lenses.hs b/src/full/Agda/Interaction/Options/Lenses.hs
index ade731e..8cb95a5 100644
--- a/src/full/Agda/Interaction/Options/Lenses.hs
+++ b/src/full/Agda/Interaction/Options/Lenses.hs
@@ -12,6 +12,8 @@ import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.State
import Agda.Interaction.Options
+import Agda.Utils.Lens
+
---------------------------------------------------------------------------
-- * Pragma options
---------------------------------------------------------------------------
@@ -30,8 +32,8 @@ instance LensPragmaOptions CommandLineOptions where
setPragmaOptions opts st = st { optPragmaOptions = opts }
instance LensPragmaOptions TCState where
- getPragmaOptions = stPragmaOptions
- setPragmaOptions opts st = st { stPragmaOptions = opts }
+ getPragmaOptions = (^.stPragmaOptions)
+ setPragmaOptions = set stPragmaOptions
modifyPragmaOptions :: (PragmaOptions -> PragmaOptions) -> TCM ()
modifyPragmaOptions = modify . mapPragmaOptions
@@ -81,7 +83,7 @@ instance LensCommandLineOptions PersistentTCState where
setCommandLineOptions opts st = st { stPersistentOptions = opts }
instance LensCommandLineOptions TCState where
- getCommandLineOptions = getCommandLineOptions . stPersistent
+ getCommandLineOptions = getCommandLineOptions . stPersistentState
mapCommandLineOptions = updatePersistentState . mapCommandLineOptions
modifyCommandLineOptions :: (CommandLineOptions -> CommandLineOptions) -> TCM ()
diff --git a/src/full/Agda/Interaction/Response.hs b/src/full/Agda/Interaction/Response.hs
index 67f69b4..f620452 100644
--- a/src/full/Agda/Interaction/Response.hs
+++ b/src/full/Agda/Interaction/Response.hs
@@ -1,11 +1,11 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
------------------------------------------------------------------------
-- | Data type for all interactive responses
------------------------------------------------------------------------
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
module Agda.Interaction.Response
( Response (..)
, MakeCaseVariant (..)
@@ -26,7 +26,7 @@ import Control.Monad.Trans
import Data.Int
import System.IO
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Responses for any interactive interface
diff --git a/src/full/Agda/Main.hs b/src/full/Agda/Main.hs
index 902662e..f5f1c79 100644
--- a/src/full/Agda/Main.hs
+++ b/src/full/Agda/Main.hs
@@ -5,7 +5,6 @@
module Agda.Main where
import Control.Monad.State
-import Control.Monad.Error
import Control.Applicative
import qualified Data.List as List
@@ -38,16 +37,20 @@ import Agda.Compiler.MAlonzo.Compiler as MAlonzo
import Agda.Compiler.Epic.Compiler as Epic
import Agda.Compiler.JS.Compiler as JS
+import Agda.Utils.Lens
import Agda.Utils.Monad
+import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.String
import qualified Agda.Utils.Trie as Trie
import Agda.Tests
import Agda.Version
-#include "undefined.h"
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.Impossible
+#include "undefined.h"
+
-- | The main function
runAgda :: TCM ()
runAgda = do
@@ -83,12 +86,15 @@ runAgda = do
map (Boxes.text . showAccount) $
accounts
-- Second column is times.
- -- CPU times are in pico seconds, convert to milliseconds.
col2 = Boxes.vcat Boxes.right $
- map (Boxes.text . (++ " ms") . showThousandSep . (`div` 1000000000)) $
+ map (Boxes.text . prettyShow) $
times
table = Boxes.hsep 1 Boxes.left [col1, col2]
reportBenchmarkingLn $ Boxes.render table
+
+ -- Print accumulated statistics.
+ printStatistics 20 Nothing =<< use lensAccumStatistics
+
where
checkFile :: TCM ()
checkFile = do
@@ -129,20 +135,20 @@ runAgda = do
unsolvedOK <- optAllowUnsolved <$> pragmaOptions
+ -- Reported unsolved problems as error unless unsolvedOK.
+ -- An interface is only generated if NoWarnings.
result <- case mw of
- -- we get here if there are unfilled interaction
- -- points that have been solved by unification
- SomeWarnings (Warnings Nothing [] []) -> return Nothing
-- Unsolved metas.
- SomeWarnings (Warnings _ w@(_:_) _)
- | not unsolvedOK -> typeError $ UnsolvedMetas w
+ SomeWarnings (Warnings w@(_:_) _)
+ | not unsolvedOK -> typeError $ UnsolvedMetas w
-- Unsolved constraints.
- SomeWarnings (Warnings _ _ w@(_:_))
- | not unsolvedOK -> typeError $ UnsolvedConstraints w
- -- Termination errors.
- SomeWarnings (Warnings (Just w) _ _) -> throwError w
- SomeWarnings _ -> return Nothing
- NoWarnings -> return $ Just i
+ SomeWarnings (Warnings _ w@(_:_))
+ | not unsolvedOK -> typeError $ UnsolvedConstraints w
+ -- Unsolved metas, unsolved constraints, or
+ -- interaction points left whose metas have been solved
+ -- automatically. (See Issue 1296).
+ SomeWarnings (Warnings _ _) -> return Nothing
+ NoWarnings -> return $ Just i
whenM (optGenerateHTML <$> commandLineOptions) $
generateHTML
diff --git a/src/full/Agda/Syntax/Abstract.hs b/src/full/Agda/Syntax/Abstract.hs
index 612ddd5..406e8f9 100644
--- a/src/full/Agda/Syntax/Abstract.hs
+++ b/src/full/Agda/Syntax/Abstract.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{-| The abstract syntax. This is what you get after desugaring and scope
analysis of the concrete syntax. The type checker works on abstract syntax,
@@ -23,6 +23,7 @@ import Control.Applicative
import Data.Foldable as Fold
import Data.Map (Map)
+import Data.Maybe
import Data.Sequence (Seq, (<|), (><))
import qualified Data.Sequence as Seq
import Data.Traversable
@@ -43,7 +44,7 @@ import Agda.Syntax.Scope.Base
import Agda.Utils.Geniplate
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
type Color = Expr
@@ -65,41 +66,43 @@ instance Ord Color where
-- TODO guilhem:
_ <= _ = __IMPOSSIBLE__
+-- | Expressions after scope checking (operators parsed, names resolved).
data Expr
- = Var Name -- ^ Bound variables
- | Def QName -- ^ Constants (i.e. axioms, functions, projections, and datatypes)
- | Con AmbiguousQName -- ^ Constructors
- | Lit Literal -- ^ Literals
- | QuestionMark MetaInfo InteractionId
- -- ^ Meta variable for interaction.
- -- The 'InteractionId' is usually identical with the
- -- 'metaNumber' of 'MetaInfo'.
- -- However, if you want to print an interaction meta as
- -- just @?@ instead of @?n@, you should set the
- -- 'metaNumber' to 'Nothing' while keeping the 'InteractionId'.
- | Underscore MetaInfo
- -- ^ Meta variable for hidden argument (must be inferred locally).
- | App ExprInfo Expr (NamedArg Expr) -- ^
- | WithApp ExprInfo Expr [Expr] -- ^ with application
- | Lam ExprInfo LamBinding Expr -- ^
- | AbsurdLam ExprInfo Hiding
- | ExtendedLam ExprInfo DefInfo QName [Clause]
- | Pi ExprInfo Telescope Expr -- ^
- | Fun ExprInfo (Arg Expr) Expr -- ^ independent function space
- | Set ExprInfo Integer -- ^ Set, Set1, Set2, ...
- | Prop ExprInfo -- ^
- | Let ExprInfo [LetBinding] Expr -- ^
- | ETel Telescope -- ^ only used when printing telescopes
- | Rec ExprInfo Assigns -- ^ record construction
- | RecUpdate ExprInfo Expr Assigns -- ^ record update
- | ScopedExpr ScopeInfo Expr -- ^ scope annotation
- | QuoteGoal ExprInfo Name Expr -- ^ binds @Name@ to current type in @Expr@
- | QuoteContext ExprInfo Name Expr -- ^ binds @Name@ to current context in @Expr@
- | Quote ExprInfo -- ^ Quote an identifier 'QName'.
- | QuoteTerm ExprInfo -- ^ Quote a term.
- | Unquote ExprInfo -- ^ The splicing construct: unquote ...
- | DontCare Expr -- ^ for printing DontCare from Syntax.Internal
- | PatternSyn QName
+ = Var Name -- ^ Bound variable.
+ | Def QName -- ^ Constant: axiom, function, data or record type.
+ | Proj QName -- ^ Projection.
+ | Con AmbiguousQName -- ^ Constructor.
+ | PatternSyn QName -- ^ Pattern synonym.
+ | Lit Literal -- ^ Literal.
+ | QuestionMark MetaInfo InteractionId
+ -- ^ Meta variable for interaction.
+ -- The 'InteractionId' is usually identical with the
+ -- 'metaNumber' of 'MetaInfo'.
+ -- However, if you want to print an interaction meta as
+ -- just @?@ instead of @?n@, you should set the
+ -- 'metaNumber' to 'Nothing' while keeping the 'InteractionId'.
+ | Underscore MetaInfo
+ -- ^ Meta variable for hidden argument (must be inferred locally).
+ | App ExprInfo Expr (NamedArg Expr) -- ^ Ordinary (binary) application.
+ | WithApp ExprInfo Expr [Expr] -- ^ With application.
+ | Lam ExprInfo LamBinding Expr -- ^ @λ bs → e at .
+ | AbsurdLam ExprInfo Hiding -- ^ @λ()@ or @λ{}@.
+ | ExtendedLam ExprInfo DefInfo QName [Clause]
+ | Pi ExprInfo Telescope Expr -- ^ Dependent function space @Γ → A at .
+ | Fun ExprInfo (Arg Expr) Expr -- ^ Non-dependent function space.
+ | Set ExprInfo Integer -- ^ @Set@, @Set1@, @Set2@, ...
+ | Prop ExprInfo -- ^ @Prop@ (no longer supported, used as dummy type).
+ | Let ExprInfo [LetBinding] Expr -- ^ @let bs in e at .
+ | ETel Telescope -- ^ Only used when printing telescopes.
+ | Rec ExprInfo Assigns -- ^ Record construction.
+ | RecUpdate ExprInfo Expr Assigns -- ^ Record update.
+ | ScopedExpr ScopeInfo Expr -- ^ Scope annotation.
+ | QuoteGoal ExprInfo Name Expr -- ^ Binds @Name@ to current type in @Expr at .
+ | QuoteContext ExprInfo Name Expr -- ^ Binds @Name@ to current context in @Expr at .
+ | Quote ExprInfo -- ^ Quote an identifier 'QName'.
+ | QuoteTerm ExprInfo -- ^ Quote a term.
+ | Unquote ExprInfo -- ^ The splicing construct: unquote ...
+ | DontCare Expr -- ^ For printing @DontCare@ from @Syntax.Internal at .
deriving (Typeable, Show)
-- | Record field assignment @f = e at .
@@ -113,33 +116,34 @@ data Axiom
-- or another (e.g. data/record) type signature (internally).
deriving (Typeable, Eq, Ord, Show)
+-- | Renaming (generic).
type Ren a = Map a a
data Declaration
- = Axiom Axiom DefInfo ArgInfo QName Expr -- ^ type signature (can be irrelevant and colored, but not hidden)
- | Field DefInfo QName (Arg Expr) -- ^ record field
- | Primitive DefInfo QName Expr -- ^ primitive function
- | Mutual MutualInfo [Declaration] -- ^ a bunch of mutually recursive definitions
- | Section ModuleInfo ModuleName [TypedBindings] [Declaration]
- | Apply ModuleInfo ModuleName ModuleApplication (Ren QName) (Ren ModuleName)
- | Import ModuleInfo ModuleName
- | Pragma Range Pragma
- | Open ModuleInfo ModuleName
- -- ^ only retained for highlighting purposes
- | FunDef DefInfo QName Delayed [Clause] -- ^ sequence of function clauses
- | DataSig DefInfo QName Telescope Expr -- ^ lone data signature
- -- ^ the 'LamBinding's are 'DomainFree' and binds the parameters of the datatype.
- | DataDef DefInfo QName [LamBinding] [Constructor]
- -- ^ the 'LamBinding's are 'DomainFree' and binds the parameters of the datatype.
- | RecSig DefInfo QName Telescope Expr -- ^ lone record signature
- | RecDef DefInfo QName (Maybe (Ranged Induction)) (Maybe QName) [LamBinding] Expr [Declaration]
- -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,
- -- and the optional name is the constructor's name.
- | PatternSynDef QName [Arg Name] Pattern
- -- ^ Only for highlighting purposes
- | UnquoteDecl MutualInfo DefInfo QName Expr
- | ScopedDecl ScopeInfo [Declaration] -- ^ scope annotation
- deriving (Typeable, Show)
+ = Axiom Axiom DefInfo ArgInfo QName Expr -- ^ type signature (can be irrelevant and colored, but not hidden)
+ | Field DefInfo QName (Arg Expr) -- ^ record field
+ | Primitive DefInfo QName Expr -- ^ primitive function
+ | Mutual MutualInfo [Declaration] -- ^ a bunch of mutually recursive definitions
+ | Section ModuleInfo ModuleName [TypedBindings] [Declaration]
+ | Apply ModuleInfo ModuleName ModuleApplication (Ren QName) (Ren ModuleName)
+ | Import ModuleInfo ModuleName
+ | Pragma Range Pragma
+ | Open ModuleInfo ModuleName
+ -- ^ only retained for highlighting purposes
+ | FunDef DefInfo QName Delayed [Clause] -- ^ sequence of function clauses
+ | DataSig DefInfo QName Telescope Expr -- ^ lone data signature
+ -- ^ the 'LamBinding's are 'DomainFree' and binds the parameters of the datatype.
+ | DataDef DefInfo QName [LamBinding] [Constructor]
+ -- ^ the 'LamBinding's are 'DomainFree' and binds the parameters of the datatype.
+ | RecSig DefInfo QName Telescope Expr -- ^ lone record signature
+ | RecDef DefInfo QName (Maybe (Ranged Induction)) (Maybe QName) [LamBinding] Expr [Declaration]
+ -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,
+ -- and the optional name is the constructor's name.
+ | PatternSynDef QName [Arg Name] Pattern
+ -- ^ Only for highlighting purposes
+ | UnquoteDecl MutualInfo DefInfo QName Expr
+ | ScopedDecl ScopeInfo [Declaration] -- ^ scope annotation
+ deriving (Typeable, Show)
class GetDefInfo a where
getDefInfo :: a -> Maybe DefInfo
@@ -163,17 +167,18 @@ data ModuleApplication
-- ^ @M {{...}}@
deriving (Typeable, Show)
-data Pragma = OptionsPragma [String]
- | BuiltinPragma String Expr
- | RewritePragma QName
- | CompiledPragma QName String
- | CompiledExportPragma QName String
- | CompiledTypePragma QName String
- | CompiledDataPragma QName String [String]
- | CompiledEpicPragma QName String
- | CompiledJSPragma QName String
- | StaticPragma QName
- | EtaPragma QName
+data Pragma
+ = OptionsPragma [String]
+ | BuiltinPragma String Expr
+ | RewritePragma QName
+ | CompiledPragma QName String
+ | CompiledExportPragma QName String
+ | CompiledTypePragma QName String
+ | CompiledDataPragma QName String [String]
+ | CompiledEpicPragma QName String
+ | CompiledJSPragma QName String
+ | StaticPragma QName
+ | EtaPragma QName
deriving (Typeable, Show)
-- | Bindings that are valid in a @let at .
@@ -195,13 +200,13 @@ type Field = TypeSignature
-- | A lambda binding is either domain free or typed.
data LamBinding
- = DomainFree ArgInfo Name -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@
- | DomainFull TypedBindings -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@
+ = DomainFree ArgInfo Name -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@
+ | DomainFull TypedBindings -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@
deriving (Typeable, Show)
-- | Typed bindings with hiding information.
data TypedBindings = TypedBindings Range (Arg TypedBinding)
- -- ^ . @(xs : e)@ or @{xs : e}@
+ -- ^ . @(xs : e)@ or @{xs : e}@
deriving (Typeable, Show)
-- | A typed binding. Appears in dependent function spaces, typed lambdas, and
@@ -214,13 +219,13 @@ data TypedBindings = TypedBindings Range (Arg TypedBinding)
-- (Andreas, 2013-12-10: The more serious problem would that the translation
-- from @(x y : ?)@ to @(x : ?) (y : ?)@ duplicates the hole @?@.
data TypedBinding
- = TBind Range [Name] Expr
- -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B at .
- | TLet Range [LetBinding]
- -- ^
+ = TBind Range [Name] Expr
+ -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B at .
+ | TLet Range [LetBinding]
+ -- ^
deriving (Typeable, Show)
-type Telescope = [TypedBindings]
+type Telescope = [TypedBindings]
-- | We could throw away @where@ clauses at this point and translate them to
-- @let at . It's not obvious how to remember that the @let@ was really a
@@ -234,13 +239,15 @@ data Clause' lhs = Clause
type Clause = Clause' LHS
type SpineClause = Clause' SpineLHS
-data RHS = RHS Expr
- | AbsurdRHS
- | WithRHS QName [Expr] [Clause] -- ^ The 'QName' is the name of the with function.
- | RewriteRHS [QName] [Expr] RHS [Declaration]
- -- ^ The 'QName's are the names of the generated with functions.
- -- One for each 'Expr'.
- -- The RHS shouldn't be another RewriteRHS
+data RHS
+ = RHS Expr
+ | AbsurdRHS
+ | WithRHS QName [Expr] [Clause]
+ -- ^ The 'QName' is the name of the with function.
+ | RewriteRHS [QName] [Expr] RHS [Declaration]
+ -- ^ The 'QName's are the names of the generated with functions.
+ -- One for each 'Expr'.
+ -- The RHS shouldn't be another @RewriteRHS at .
deriving (Typeable, Show)
-- | The lhs of a clause in spine view (inside-out).
@@ -290,42 +297,6 @@ class LHSToSpine a b where
lhsToSpine :: a -> b
spineToLhs :: b -> a
-{-
--- | Pattern instance.
--- instance LHSToSpine (LHSCore' e) (A.QNamed [NamedArg (Pattern' e)]) where
-instance LHSToSpine (LHSCore' e) (A.QNamed [Common.NamedArg Expr (Pattern' e)]) where
- lhsToSpine (LHSHead f ps) = QNamed f ps
- lhsToSpine (LHSProj d ps1 h ps2) = (++ (p : ps2)) <$> lhsToSpine (namedArg h)
- where p = updateNamedArg (const $ DefP patNoRange d ps1) h
-
-instance SpineToLHS (LHSCore' e) (A.QNamed [Common.NamedArg Expr (Pattern' e)]) where
- spineToLhs (QNamed f ps) = lhsCoreAddSpine (LHSHead f []) ps
- where
- -- | Add applicative patterns (non-projection patterns) to the right.
- -- lhsCoreApp :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
- lhsCoreApp (LHSHead f ps) ps' = LHSHead f $ ps ++ ps'
- lhsCoreApp (LHSProj d ps1 h ps2) ps' = LHSProj d ps1 h $ ps2 ++ ps'
-
- -- | Add projection and applicative patterns to the right.
- -- lhsCoreAddSpine :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
- lhsCoreAddSpine core ps = case ps2 of
- [] -> lhsCoreApp core ps
- (Common.Arg info (Named n (DefP i d ps0)) : ps2') ->
- LHSProj d ps0 (Common.Arg info $ Named n $ lhsCoreApp core ps1) []
- `lhsCoreAddSpine` ps2'
- _ -> __IMPOSSIBLE__
- where
- (ps1, ps2) = break (isDefP . namedArg) ps
- isDefP DefP{} = True
- isDefP _ = False
--}
-
--- | LHS instance.
-instance LHSToSpine LHS SpineLHS where
- lhsToSpine (LHS i core wps) = SpineLHS i f ps wps
- where QNamed f ps = lhsCoreToSpine core
- spineToLhs (SpineLHS i f ps wps) = LHS i (spineToLhsCore $ QNamed f ps) wps
-
-- | Clause instance.
instance LHSToSpine Clause SpineClause where
lhsToSpine = fmap lhsToSpine
@@ -336,17 +307,11 @@ instance LHSToSpine a b => LHSToSpine [a] [b] where
lhsToSpine = map lhsToSpine
spineToLhs = map spineToLhs
-
-{-
--- | Convert a focused lhs to spine view.
-lhsToSpine :: LHS -> SpineLHS
-lhsToSpine (LHS i core wps) = SpineLHS i f ps wps
- where QNamed f ps = lhsCoreToSpine core
-
--- | Convert a lhs from spine view into focused view.
-spineToLhs :: SpineLHS -> LHS
-spineToLhs (SpineLHS i f ps wps) = LHS i (spineToLhsCore $ QNamed f ps) wps
--}
+-- | LHS instance.
+instance LHSToSpine LHS SpineLHS where
+ lhsToSpine (LHS i core wps) = SpineLHS i f ps wps
+ where QNamed f ps = lhsCoreToSpine core
+ spineToLhs (SpineLHS i f ps wps) = LHS i (spineToLhsCore $ QNamed f ps) wps
lhsCoreToSpine :: LHSCore' e -> A.QNamed [NamedArg (Pattern' e)]
lhsCoreToSpine (LHSHead f ps) = QNamed f ps
@@ -364,27 +329,19 @@ lhsCoreApp (LHSProj d ps1 h ps2) ps' = LHSProj d ps1 h $ ps2 ++ ps'
-- | Add projection and applicative patterns to the right.
lhsCoreAddSpine :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
lhsCoreAddSpine core ps = case ps2 of
- [] -> lhsCoreApp core ps
(Common.Arg info (Named n (DefP i d ps0)) : ps2') ->
LHSProj d ps0 (Common.Arg info $ Named n $ lhsCoreApp core ps1) []
`lhsCoreAddSpine` ps2'
+ [] -> lhsCoreApp core ps
_ -> __IMPOSSIBLE__
where
(ps1, ps2) = break (isDefP . namedArg) ps
isDefP DefP{} = True
isDefP _ = False
-
-- | Used for checking pattern linearity.
lhsCoreAllPatterns :: LHSCore' e -> [Pattern' e]
lhsCoreAllPatterns = map namedArg . qnamed . lhsCoreToSpine
-{- OLD code, dumps projection patterns, superfluous
-lhsCoreAllPatterns (LHSHead f ps) = map namedArg ps
-lhsCoreAllPatterns (LHSProj d ps1 l ps2) =
- map namedArg ps1 ++
- lhsCoreAllPatterns (namedArg l) ++
- map namedArg ps2
--}
-- | Used in AbstractToConcrete.
lhsCoreToPattern :: LHSCore -> Pattern
@@ -400,14 +357,6 @@ mapLHSHead f (LHSHead x ps) = f x ps
mapLHSHead f (LHSProj d ps1 l ps2) =
LHSProj d ps1 (fmap (fmap (mapLHSHead f)) l) ps2
-{- UNUSED
-mapLHSHeadM :: (Monad m) => (QName -> [NamedArg Pattern] -> m LHSCore) -> LHSCore -> m LHSCore
-mapLHSHeadM f (LHSHead x ps) = f x ps
-mapLHSHeadM f (LHSProj d ps1 l ps2) = do
- l <- mapLHSHead f l
- return $ LHSProj d ps1 l ps2
--}
-
---------------------------------------------------------------------------
-- * Patterns
---------------------------------------------------------------------------
@@ -462,31 +411,32 @@ instance HasRange TypedBinding where
getRange (TLet r _) = r
instance HasRange Expr where
- getRange (Var x) = getRange x
- getRange (Def x) = getRange x
- getRange (Con x) = getRange x
- getRange (Lit l) = getRange l
- getRange (QuestionMark i _) = getRange i
- getRange (Underscore i) = getRange i
- getRange (App i _ _) = getRange i
- getRange (WithApp i _ _) = getRange i
- getRange (Lam i _ _) = getRange i
+ getRange (Var x) = getRange x
+ getRange (Def x) = getRange x
+ getRange (Proj x) = getRange x
+ getRange (Con x) = getRange x
+ getRange (Lit l) = getRange l
+ getRange (QuestionMark i _) = getRange i
+ getRange (Underscore i) = getRange i
+ getRange (App i _ _) = getRange i
+ getRange (WithApp i _ _) = getRange i
+ getRange (Lam i _ _) = getRange i
getRange (AbsurdLam i _) = getRange i
getRange (ExtendedLam i _ _ _) = getRange i
- getRange (Pi i _ _) = getRange i
- getRange (Fun i _ _) = getRange i
- getRange (Set i _) = getRange i
- getRange (Prop i) = getRange i
- getRange (Let i _ _) = getRange i
- getRange (Rec i _) = getRange i
+ getRange (Pi i _ _) = getRange i
+ getRange (Fun i _ _) = getRange i
+ getRange (Set i _) = getRange i
+ getRange (Prop i) = getRange i
+ getRange (Let i _ _) = getRange i
+ getRange (Rec i _) = getRange i
getRange (RecUpdate i _ _) = getRange i
getRange (ETel tel) = getRange tel
- getRange (ScopedExpr _ e) = getRange e
- getRange (QuoteGoal _ _ e) = getRange e
+ getRange (ScopedExpr _ e) = getRange e
+ getRange (QuoteGoal _ _ e) = getRange e
getRange (QuoteContext _ _ e) = getRange e
- getRange (Quote i) = getRange i
- getRange (QuoteTerm i) = getRange i
- getRange (Unquote i) = getRange i
+ getRange (Quote i) = getRange i
+ getRange (QuoteTerm i) = getRange i
+ getRange (Unquote i) = getRange i
getRange (DontCare{}) = noRange
getRange (PatternSyn x) = getRange x
@@ -495,12 +445,12 @@ instance HasRange Declaration where
getRange (Field i _ _ ) = getRange i
getRange (Mutual i _ ) = getRange i
getRange (Section i _ _ _ ) = getRange i
- getRange (Apply i _ _ _ _ ) = getRange i
- getRange (Import i _ ) = getRange i
- getRange (Primitive i _ _ ) = getRange i
- getRange (Pragma i _ ) = getRange i
+ getRange (Apply i _ _ _ _ ) = getRange i
+ getRange (Import i _ ) = getRange i
+ getRange (Primitive i _ _ ) = getRange i
+ getRange (Pragma i _ ) = getRange i
getRange (Open i _ ) = getRange i
- getRange (ScopedDecl _ d ) = getRange d
+ getRange (ScopedDecl _ d ) = getRange d
getRange (FunDef i _ _ _ ) = getRange i
getRange (DataSig i _ _ _ ) = getRange i
getRange (DataDef i _ _ _ ) = getRange i
@@ -510,15 +460,15 @@ instance HasRange Declaration where
getRange (UnquoteDecl _ i _ _) = getRange i
instance HasRange (Pattern' e) where
- getRange (VarP x) = getRange x
+ getRange (VarP x) = getRange x
getRange (ConP i _ _) = getRange i
getRange (DefP i _ _) = getRange i
- getRange (WildP i) = getRange i
+ getRange (WildP i) = getRange i
getRange (ImplicitP i) = getRange i
getRange (AsP i _ _) = getRange i
getRange (DotP i _) = getRange i
getRange (AbsurdP i) = getRange i
- getRange (LitP l) = getRange l
+ getRange (LitP l) = getRange l
getRange (PatternSynP i _ _) = getRange i
instance HasRange SpineLHS where
@@ -573,6 +523,7 @@ instance KillRange TypedBinding where
instance KillRange Expr where
killRange (Var x) = killRange1 Var x
killRange (Def x) = killRange1 Def x
+ killRange (Proj x) = killRange1 Proj x
killRange (Con x) = killRange1 Con x
killRange (Lit l) = killRange1 Lit l
killRange (QuestionMark i ii) = killRange2 QuestionMark i ii
@@ -687,91 +638,105 @@ instanceUniverseBiT' [] [t| (Declaration, RString) |]
-- include local modules, where clauses and the names of extended
-- lambdas.
-allNames :: Declaration -> Seq QName
-allNames (Axiom _ _ _ q _) = Seq.singleton q
-allNames (Field _ q _) = Seq.singleton q
-allNames (Primitive _ q _) = Seq.singleton q
-allNames (Mutual _ defs) = Fold.foldMap allNames defs
-allNames (DataSig _ q _ _) = Seq.singleton q
-allNames (DataDef _ q _ decls) = q <| Fold.foldMap allNames decls
-allNames (RecSig _ q _ _) = Seq.singleton q
-allNames (RecDef _ q _ c _ _ decls) =
- q <| foldMap Seq.singleton c >< Fold.foldMap allNames decls
-allNames (PatternSynDef q _ _) = Seq.singleton q
-allNames (UnquoteDecl _ _ q _) = Seq.singleton q
-allNames (FunDef _ q _ cls) = q <| Fold.foldMap allNamesC cls
- where
- allNamesC :: Clause -> Seq QName
- allNamesC (Clause _ rhs decls) = allNamesR rhs ><
- Fold.foldMap allNames decls
-
- allNamesR :: RHS -> Seq QName
- allNamesR (RHS e) = allNamesE e
- allNamesR AbsurdRHS {} = Seq.empty
- allNamesR (WithRHS q _ cls) = q <| Fold.foldMap allNamesC cls
- allNamesR (RewriteRHS qs _ rhs cls) =
- Seq.fromList qs >< allNamesR rhs
- >< Fold.foldMap allNames cls
-
- allNamesE :: Expr -> Seq QName
- allNamesE Var {} = Seq.empty
- allNamesE Def {} = Seq.empty
- allNamesE Con {} = Seq.empty
- allNamesE Lit {} = Seq.empty
- allNamesE QuestionMark {} = Seq.empty
- allNamesE Underscore {} = Seq.empty
- allNamesE (App _ e1 e2) = Fold.foldMap allNamesE [e1, namedThing (unArg e2)]
- allNamesE (WithApp _ e es) = Fold.foldMap allNamesE (e : es)
- allNamesE (Lam _ b e) = allNamesLam b >< allNamesE e
- allNamesE AbsurdLam {} = Seq.empty
- allNamesE (ExtendedLam _ _ q cls) = q <| Fold.foldMap allNamesC cls
- allNamesE (Pi _ tel e) = Fold.foldMap allNamesBinds tel ><
- allNamesE e
- allNamesE (Fun _ (Common.Arg _ e1) e2) = Fold.foldMap allNamesE [e1, e2]
- allNamesE Set {} = Seq.empty
- allNamesE Prop {} = Seq.empty
- allNamesE (Let _ lbs e) = Fold.foldMap allNamesLet lbs ><
- allNamesE e
- allNamesE ETel {} = __IMPOSSIBLE__
- allNamesE (Rec _ fields) = Fold.foldMap allNamesE (map snd fields)
- allNamesE (RecUpdate _ e fs) = allNamesE e >< Fold.foldMap allNamesE (map snd fs)
- allNamesE (ScopedExpr _ e) = allNamesE e
- allNamesE (QuoteGoal _ _ e) = allNamesE e
- allNamesE (QuoteContext _ _ e) = allNamesE e
- allNamesE Quote {} = Seq.empty
- allNamesE QuoteTerm {} = Seq.empty
- allNamesE Unquote {} = Seq.empty
- allNamesE DontCare {} = Seq.empty
- allNamesE (PatternSyn x) = Seq.empty
-
- allNamesLam :: LamBinding -> Seq QName
- allNamesLam DomainFree {} = Seq.empty
- allNamesLam (DomainFull binds) = allNamesBinds binds
-
- allNamesBinds :: TypedBindings -> Seq QName
- allNamesBinds (TypedBindings _ (Common.Arg _ (TBind _ _ e))) = allNamesE e
- allNamesBinds (TypedBindings _ (Common.Arg _ (TLet _ lbs))) = allNamesLets lbs
-
- allNamesLets :: [LetBinding] -> Seq QName
- allNamesLets = Fold.foldMap allNamesLet
-
- allNamesLet :: LetBinding -> Seq QName
- allNamesLet (LetBind _ _ _ e1 e2) = Fold.foldMap allNamesE [e1, e2]
- allNamesLet (LetPatBind _ _ e) = allNamesE e
- allNamesLet (LetApply _ _ app _ _) = allNamesApp app
- allNamesLet LetOpen {} = Seq.empty
-
- allNamesApp :: ModuleApplication -> Seq QName
- allNamesApp (SectionApp bindss _ es) = Fold.foldMap allNamesBinds bindss ><
- Fold.foldMap allNamesE (map namedArg es)
- allNamesApp RecordModuleIFS {} = Seq.empty
-
-allNames (Section _ _ _ decls) = Fold.foldMap allNames decls
-allNames Apply {} = Seq.empty
-allNames Import {} = Seq.empty
-allNames Pragma {} = Seq.empty
-allNames Open {} = Seq.empty
-allNames (ScopedDecl _ decls) = Fold.foldMap allNames decls
+class AllNames a where
+ allNames :: a -> Seq QName
+
+instance AllNames a => AllNames [a] where
+ allNames = Fold.foldMap allNames
+
+instance AllNames a => AllNames (Maybe a) where
+ allNames = Fold.foldMap allNames
+
+instance AllNames a => AllNames (Arg a) where
+ allNames = Fold.foldMap allNames
+
+instance AllNames a => AllNames (Named name a) where
+ allNames = Fold.foldMap allNames
+
+instance (AllNames a, AllNames b) => AllNames (a,b) where
+ allNames (a,b) = allNames a >< allNames b
+
+instance AllNames QName where
+ allNames q = Seq.singleton q
+
+instance AllNames Declaration where
+ allNames (Axiom _ _ _ q _) = Seq.singleton q
+ allNames (Field _ q _) = Seq.singleton q
+ allNames (Primitive _ q _) = Seq.singleton q
+ allNames (Mutual _ defs) = allNames defs
+ allNames (DataSig _ q _ _) = Seq.singleton q
+ allNames (DataDef _ q _ decls) = q <| allNames decls
+ allNames (RecSig _ q _ _) = Seq.singleton q
+ allNames (RecDef _ q _ c _ _ decls) = q <| allNames c >< allNames decls
+ allNames (PatternSynDef q _ _) = Seq.singleton q
+ allNames (UnquoteDecl _ _ q _) = Seq.singleton q
+ allNames (FunDef _ q _ cls) = q <| allNames cls
+ allNames (Section _ _ _ decls) = allNames decls
+ allNames Apply{} = Seq.empty
+ allNames Import{} = Seq.empty
+ allNames Pragma{} = Seq.empty
+ allNames Open{} = Seq.empty
+ allNames (ScopedDecl _ decls) = allNames decls
+
+instance AllNames Clause where
+ allNames (Clause _ rhs decls) = allNames rhs >< allNames decls
+
+instance AllNames RHS where
+ allNames (RHS e) = allNames e
+ allNames AbsurdRHS{} = Seq.empty
+ allNames (WithRHS q _ cls) = q <| allNames cls
+ allNames (RewriteRHS qs _ rhs cls) = Seq.fromList qs >< allNames rhs >< allNames cls
+
+instance AllNames Expr where
+ allNames Var{} = Seq.empty
+ allNames Def{} = Seq.empty
+ allNames Proj{} = Seq.empty
+ allNames Con{} = Seq.empty
+ allNames Lit{} = Seq.empty
+ allNames QuestionMark{} = Seq.empty
+ allNames Underscore{} = Seq.empty
+ allNames (App _ e1 e2) = allNames e1 >< allNames e2
+ allNames (WithApp _ e es) = allNames e >< allNames es
+ allNames (Lam _ b e) = allNames b >< allNames e
+ allNames AbsurdLam{} = Seq.empty
+ allNames (ExtendedLam _ _ q cls) = q <| allNames cls
+ allNames (Pi _ tel e) = allNames tel >< allNames e
+ allNames (Fun _ e1 e2) = allNames e1 >< allNames e2
+ allNames Set{} = Seq.empty
+ allNames Prop{} = Seq.empty
+ allNames (Let _ lbs e) = allNames lbs >< allNames e
+ allNames ETel{} = __IMPOSSIBLE__
+ allNames (Rec _ fields) = allNames $ map snd fields
+ allNames (RecUpdate _ e fs) = allNames e >< allNames (map snd fs)
+ allNames (ScopedExpr _ e) = allNames e
+ allNames (QuoteGoal _ _ e) = allNames e
+ allNames (QuoteContext _ _ e) = allNames e
+ allNames Quote{} = Seq.empty
+ allNames QuoteTerm{} = Seq.empty
+ allNames Unquote{} = Seq.empty
+ allNames DontCare{} = Seq.empty
+ allNames (PatternSyn x) = Seq.empty
+
+instance AllNames LamBinding where
+ allNames DomainFree{} = Seq.empty
+ allNames (DomainFull binds) = allNames binds
+
+instance AllNames TypedBindings where
+ allNames (TypedBindings _ bs) = allNames bs
+
+instance AllNames TypedBinding where
+ allNames (TBind _ _ e) = allNames e
+ allNames (TLet _ lbs) = allNames lbs
+
+instance AllNames LetBinding where
+ allNames (LetBind _ _ _ e1 e2) = allNames e1 >< allNames e2
+ allNames (LetPatBind _ _ e) = allNames e
+ allNames (LetApply _ _ app _ _) = allNames app
+ allNames LetOpen{} = Seq.empty
+
+instance AllNames ModuleApplication where
+ allNames (SectionApp bindss _ es) = allNames bindss >< allNames es
+ allNames RecordModuleIFS{} = Seq.empty
-- | The name defined by the given axiom.
--
@@ -804,14 +769,15 @@ instance AnyAbstract Declaration where
anyAbstract (RecSig i _ _ _) = defAbstract i == AbstractDef
anyAbstract _ = __IMPOSSIBLE__
-app = foldl (App (ExprRange noRange))
+app :: Expr -> [NamedArg Expr] -> Expr
+app = foldl (App (ExprRange noRange))
patternToExpr :: Pattern -> Expr
patternToExpr (VarP x) = Var x
patternToExpr (ConP _ c ps) =
- Con c `app` map (fmap (fmap patternToExpr)) ps
+ Con c `app` map (fmap (fmap patternToExpr)) ps
patternToExpr (DefP _ f ps) =
- Def f `app` map (fmap (fmap patternToExpr)) ps
+ Def f `app` map (fmap (fmap patternToExpr)) ps
patternToExpr (WildP _) = Underscore emptyMetaInfo
patternToExpr (AsP _ _ p) = patternToExpr p
patternToExpr (DotP _ e) = e
@@ -825,15 +791,12 @@ type PatternSynDefns = Map QName PatternSynDefn
lambdaLiftExpr :: [Name] -> Expr -> Expr
lambdaLiftExpr [] e = e
-lambdaLiftExpr (n:ns) e = Lam (ExprRange noRange)
- (DomainFree defaultArgInfo n) $
+lambdaLiftExpr (n:ns) e = Lam (ExprRange noRange) (DomainFree defaultArgInfo n) $
lambdaLiftExpr ns e
substPattern :: [(Name, Pattern)] -> Pattern -> Pattern
substPattern s p = case p of
- VarP z -> case lookup z s of
- Nothing -> p
- Just x -> x
+ VarP z -> fromMaybe p (lookup z s)
ConP i q ps -> ConP i q (fmap (fmap (fmap (substPattern s))) ps)
WildP i -> p
DotP i e -> DotP i (substExpr (map (fmap patternToExpr) s) e)
@@ -843,62 +806,69 @@ substPattern s p = case p of
-- pattern synonyms (already gone), and
-- @-patterns (not supported anyways).
-substExpr :: [(Name, Expr)] -> Expr -> Expr
-substExpr s e = case e of
- Var n -> case lookup n s of
- Nothing -> e
- Just z -> z
- Def _ -> e
- Con _ -> e
- Lit _ -> e
- QuestionMark{} -> e
- Underscore _ -> e
- App i e e' -> App i (substExpr s e)
- (fmap (fmap (substExpr s)) e')
- WithApp i e es -> WithApp i (substExpr s e)
- (fmap (substExpr s) es)
- Lam i lb e -> Lam i lb (substExpr s e)
- AbsurdLam i h -> e
- ExtendedLam i di n cs -> __IMPOSSIBLE__ -- Maybe later...
- Pi i t e -> Pi i (fmap (substTypedBindings s) t)
- (substExpr s e)
- Fun i ae e -> Fun i (fmap (substExpr s) ae)
- (substExpr s e)
- Set i n -> e
- Prop i -> e
- Let i ls e -> Let i (substLetBindings s ls)
- (substExpr s e)
- ETel t -> e
- Rec i nes -> Rec i (fmap (fmap (substExpr s)) nes)
- RecUpdate i e nes -> RecUpdate i (substExpr s e)
- (fmap (fmap (substExpr s)) nes)
- -- XXX: Do we need to do more with ScopedExprs?
- ScopedExpr si e -> ScopedExpr si (substExpr s e)
- QuoteGoal i n e -> QuoteGoal i n (substExpr s e)
- QuoteContext i n e -> QuoteContext i n (substExpr s e)
- Quote i -> e
- QuoteTerm i -> e
- Unquote i -> e
- DontCare e -> DontCare (substExpr s e)
- PatternSyn x -> e
-
-substLetBindings :: [(Name, Expr)] -> [LetBinding] -> [LetBinding]
-substLetBindings s = fmap (substLetBinding s)
-
-substLetBinding :: [(Name, Expr)] -> LetBinding -> LetBinding
-substLetBinding s lb = case lb of
- LetBind i r n e e' -> LetBind i r n (substExpr s e) (substExpr s e')
- LetPatBind i p e -> LetPatBind i p (substExpr s e) -- Andreas, 2012-06-04: what about the pattern p
- _ -> lb -- Nicolas, 2013-11-11: what about "LetApply" there is experessions in there
-
-substTypedBindings :: [(Name, Expr)] -> TypedBindings -> TypedBindings
-substTypedBindings s (TypedBindings r atb) = TypedBindings r
- (fmap (substTypedBinding s) atb)
-
-substTypedBinding :: [(Name, Expr)] -> TypedBinding -> TypedBinding
-substTypedBinding s tb = case tb of
- TBind r ns e -> TBind r ns $ substExpr s e
- TLet r lbs -> TLet r $ substLetBindings s lbs
+class SubstExpr a where
+ substExpr :: [(Name, Expr)] -> a -> a
+
+instance SubstExpr a => SubstExpr [a] where
+ substExpr = fmap . substExpr
+
+instance SubstExpr a => SubstExpr (Arg a) where
+ substExpr = fmap . substExpr
+
+instance SubstExpr a => SubstExpr (Common.Named name a) where
+ substExpr = fmap . substExpr
+
+instance (SubstExpr a, SubstExpr b) => SubstExpr (a, b) where
+ substExpr s (x, y) = (substExpr s x, substExpr s y)
+
+instance SubstExpr C.Name where
+ substExpr _ = id
+
+instance SubstExpr Expr where
+ substExpr s e = case e of
+ Var n -> fromMaybe e (lookup n s)
+ Def _ -> e
+ Proj{} -> e
+ Con _ -> e
+ Lit _ -> e
+ QuestionMark{} -> e
+ Underscore _ -> e
+ App i e e' -> App i (substExpr s e) (substExpr s e')
+ WithApp i e es -> WithApp i (substExpr s e) (substExpr s es)
+ Lam i lb e -> Lam i lb (substExpr s e)
+ AbsurdLam i h -> e
+ ExtendedLam i di n cs -> __IMPOSSIBLE__ -- Maybe later...
+ Pi i t e -> Pi i (substExpr s t) (substExpr s e)
+ Fun i ae e -> Fun i (substExpr s ae) (substExpr s e)
+ Set i n -> e
+ Prop i -> e
+ Let i ls e -> Let i (substExpr s ls) (substExpr s e)
+ ETel t -> e
+ Rec i nes -> Rec i (substExpr s nes)
+ RecUpdate i e nes -> RecUpdate i (substExpr s e) (substExpr s nes)
+ -- XXX: Do we need to do more with ScopedExprs?
+ ScopedExpr si e -> ScopedExpr si (substExpr s e)
+ QuoteGoal i n e -> QuoteGoal i n (substExpr s e)
+ QuoteContext i n e -> QuoteContext i n (substExpr s e)
+ Quote i -> e
+ QuoteTerm i -> e
+ Unquote i -> e
+ DontCare e -> DontCare (substExpr s e)
+ PatternSyn x -> e
+
+instance SubstExpr LetBinding where
+ substExpr s lb = case lb of
+ LetBind i r n e e' -> LetBind i r n (substExpr s e) (substExpr s e')
+ LetPatBind i p e -> LetPatBind i p (substExpr s e) -- Andreas, 2012-06-04: what about the pattern p
+ _ -> lb -- Nicolas, 2013-11-11: what about "LetApply" there is experessions in there
+
+instance SubstExpr TypedBindings where
+ substExpr s (TypedBindings r atb) = TypedBindings r (substExpr s atb)
+
+instance SubstExpr TypedBinding where
+ substExpr s tb = case tb of
+ TBind r ns e -> TBind r ns $ substExpr s e
+ TLet r lbs -> TLet r $ substExpr s lbs
-- TODO: more informative failure
insertImplicitPatSynArgs :: HasRange a => (Range -> a) -> Range -> [Arg Name] -> [NamedArg a] ->
diff --git a/src/full/Agda/Syntax/Abstract/Copatterns.hs b/src/full/Agda/Syntax/Abstract/Copatterns.hs
index 3cfd697..5220c0c 100644
--- a/src/full/Agda/Syntax/Abstract/Copatterns.hs
+++ b/src/full/Agda/Syntax/Abstract/Copatterns.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.Syntax.Abstract.Copatterns (translateCopatternClauses) where
@@ -33,7 +33,7 @@ import Agda.Syntax.Scope.Monad
import Agda.TypeChecking.Monad.Base (TypeError(..), typeError)
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{- Andreas 2012-04-07, 2012-05-08
@@ -268,6 +268,7 @@ instance Rename Expr where
case e of
Var x -> Var $ maybe x id (rho x)
Def f -> e
+ Proj f -> e
Con c -> e
Lit l -> e
QuestionMark{} -> e
diff --git a/src/full/Agda/Syntax/Abstract/Name.hs b/src/full/Agda/Syntax/Abstract/Name.hs
index 3c0263a..1e29f4e 100644
--- a/src/full/Agda/Syntax/Abstract/Name.hs
+++ b/src/full/Agda/Syntax/Abstract/Name.hs
@@ -1,11 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{-| Abstract names carry unique identifiers and stuff.
-}
@@ -29,21 +30,22 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Concrete.Name (IsNoName(..))
import qualified Agda.Syntax.Concrete.Name as C
-import Agda.Utils.Fresh
+-- import Agda.Utils.Function
+import Agda.Utils.Pretty
import Agda.Utils.Size
import Agda.Utils.Suffix
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | A name is a unique identifier and a suggestion for a concrete name. The
-- concrete name contains the source location (if any) of the name. The
-- source location of the binding site is also recorded.
-data Name = Name { nameId :: NameId
- , nameConcrete :: C.Name
- , nameBindingSite :: Range
- , nameFixity :: Fixity'
- }
+data Name = Name { nameId :: NameId
+ , nameConcrete :: C.Name
+ , nameBindingSite :: Range
+ , nameFixity :: Fixity'
+ }
deriving (Typeable)
-- | Qualified names are non-empty lists of names. Equality on qualified names
@@ -53,8 +55,8 @@ data Name = Name { nameId :: NameId
-- The 'SetRange' instance for qualified names sets all individual
-- ranges (including those of the module prefix) to the given one.
data QName = QName { qnameModule :: ModuleName
- , qnameName :: Name
- }
+ , qnameName :: Name
+ }
deriving (Typeable)
-- | Something preceeded by a qualified name.
@@ -74,9 +76,9 @@ newtype ModuleName = MName { mnameToList :: [Name] }
-- | Ambiguous qualified names. Used for overloaded constructors.
--
-- Invariant: All the names in the list must have the same concrete,
--- unqualified name.
+-- unqualified name. (This implies that they all have the same 'Range').
newtype AmbiguousQName = AmbQ { unAmbQ :: [QName] }
- deriving (Typeable, HasRange, Show)
+ deriving (Typeable, Show)
-- | A module is anonymous if the qualification path ends in an underscore.
isAnonymousModuleName :: ModuleName -> Bool
@@ -171,7 +173,7 @@ mnameToConcrete (MName xs) = foldr C.Qual (C.QName $ last cs) $ init cs
toTopLevelModuleName :: ModuleName -> C.TopLevelModuleName
toTopLevelModuleName (MName []) = __IMPOSSIBLE__
-toTopLevelModuleName (MName ms) = C.TopLevelModuleName (map show ms)
+toTopLevelModuleName (MName ms) = C.TopLevelModuleName $ map (C.nameToRawName . nameConcrete) ms
qualifyM :: ModuleName -> ModuleName -> ModuleName
qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2
@@ -180,7 +182,11 @@ qualifyQ :: ModuleName -> QName -> QName
qualifyQ m x = qnameFromList $ mnameToList m ++ qnameToList x
qualify :: ModuleName -> Name -> QName
-qualify m x = qualifyQ m (qnameFromList [x])
+qualify = QName
+
+-- | Convert a 'Name' to a 'QName' (add no module name).
+qualify_ :: Name -> QName
+qualify_ = qualify noModuleName
-- | Is the name an operator?
@@ -196,48 +202,19 @@ isSubModuleOf x y = xs /= ys && isPrefixOf ys xs
isInModule :: QName -> ModuleName -> Bool
isInModule q m = mnameToList m `isPrefixOf` qnameToList q
-freshName :: (MonadState s m, HasFresh NameId s) => Range -> String -> m Name
-freshName r s = do
- i <- fresh
- return $ mkName r i s
-
-freshNoName :: (MonadState s m, HasFresh NameId s) => Range -> m Name
-freshNoName r =
- do i <- fresh
- return $ Name i (C.NoName noRange i) r defaultFixity'
-
-freshNoName_ :: (MonadState s m, HasFresh NameId s) => m Name
-freshNoName_ = freshNoName noRange
-
--- | Create a fresh name from @a at .
-class FreshName a where
- freshName_ :: (MonadState s m, HasFresh NameId s) => 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_
-
-- | Get the next version of the concrete name. For instance, @nextName "x" = "x₁"@.
-- The name must not be a 'NoName'.
nextName :: Name -> Name
nextName x = x { nameConcrete = C.Name noRange $ nextSuf ps }
where
- C.Name _ ps = nameConcrete x
- -- NoName cannot appear here
- nextSuf [C.Id s] = [C.Id $ nextStr s]
- nextSuf [C.Id s, C.Hole] = [C.Id $ nextStr s, C.Hole]
- nextSuf (p : ps) = p : nextSuf ps
- nextSuf [] = __IMPOSSIBLE__
- nextStr s = case suffixView s of
- (s0, suf) -> addSuffix s0 (nextSuffix suf)
+ C.Name _ ps = nameConcrete x
+ -- NoName cannot appear here
+ nextSuf [C.Id s] = [C.Id $ nextStr s]
+ nextSuf [C.Id s, C.Hole] = [C.Id $ nextStr s, C.Hole]
+ nextSuf (p : ps) = p : nextSuf ps
+ nextSuf [] = __IMPOSSIBLE__
+ nextStr s = case suffixView s of
+ (s0, suf) -> addSuffix s0 (nextSuffix suf)
------------------------------------------------------------------------
-- * Important instances: Eq, Ord, Hashable
@@ -277,16 +254,41 @@ instance IsNoName Name where
-- * Show instances
------------------------------------------------------------------------
+-- | Only use this @show@ function in debugging! To convert an
+-- abstract 'Name' into a string use @prettyShow at .
instance Show Name where
- show x = show (nameConcrete x) -- ++ "|" ++ show (nameId x)
-
+ -- Andreas, 2014-10-02: Reverted to nice printing.
+ -- Reason: I do not have time just now to properly fix the
+ -- use of Show Name for pretty printing everywhere, e.g. in
+ -- the Epic backend. But I want to push the fix for Issue 836 now.
+ show n = show (nameConcrete n)
+ -- show n = show (nameConcrete n) ++ "^" ++ show (nameId n)
+ -- show n = applyWhen (isNoName n) (++ show (nameId n)) $ show (nameConcrete n)
+
+-- | Only use this @show@ function in debugging! To convert an
+-- abstract 'ModuleName' into a string use @prettyShow at .
instance Show ModuleName where
show m = concat $ intersperse "." $ map show $ mnameToList m
+-- | Only use this @show@ function in debugging! To convert an
+-- abstract 'QName' into a string use @prettyShow at .
instance Show QName where
show q = concat $ intersperse "." $ map show $ qnameToList q
------------------------------------------------------------------------
+-- * Pretty instances
+------------------------------------------------------------------------
+
+instance Pretty Name where
+ pretty = pretty . nameConcrete
+
+instance Pretty ModuleName where
+ pretty = hcat . punctuate (text ".") . map pretty . mnameToList
+
+instance Pretty QName where
+ pretty = hcat . punctuate (text ".") . map pretty . qnameToList
+
+------------------------------------------------------------------------
-- * Range instances
------------------------------------------------------------------------
@@ -302,6 +304,12 @@ instance HasRange ModuleName where
instance HasRange QName where
getRange q = getRange (qnameModule q, qnameName q)
+-- | The range of an @AmbiguousQName@ is the range of any of its
+-- disambiguations (they are the same concrete name).
+instance HasRange AmbiguousQName where
+ getRange (AmbQ []) = noRange
+ getRange (AmbQ (c:_)) = getRange c
+
-- ** SetRange
instance SetRange Name where
@@ -323,7 +331,9 @@ instance KillRange Name where
-- An experiment: what happens if we preserve
-- the range of the binding site, but kill all
-- other ranges before serialization?
- -- , nameBindingSite = noRange
+ -- Andreas, Makoto, 2014-10-18 AIM XX
+ -- Kill all ranges in signature, including nameBindingSite.
+ , nameBindingSite = noRange
}
instance KillRange ModuleName where
diff --git a/src/full/Agda/Syntax/Abstract/Pretty.hs b/src/full/Agda/Syntax/Abstract/Pretty.hs
index 6f66275..cedacae 100644
--- a/src/full/Agda/Syntax/Abstract/Pretty.hs
+++ b/src/full/Agda/Syntax/Abstract/Pretty.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+
module Agda.Syntax.Abstract.Pretty where
import Control.Applicative
diff --git a/src/full/Agda/Syntax/Abstract/Views.hs b/src/full/Agda/Syntax/Abstract/Views.hs
index 4739049..f5a8b55 100644
--- a/src/full/Agda/Syntax/Abstract/Views.hs
+++ b/src/full/Agda/Syntax/Abstract/Views.hs
@@ -1,10 +1,15 @@
-{-# LANGUAGE TupleSections, PatternGuards #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Syntax.Abstract.Views where
import Control.Applicative
import Control.Arrow (first)
import Control.Monad.Identity
+
+import Data.Foldable (foldMap)
+import Data.Monoid
import Data.Traversable
import Agda.Syntax.Position
@@ -33,7 +38,7 @@ unAppView (Application h es) =
-- | Gather top-level 'AsP'atterns to expose underlying pattern.
asView :: A.Pattern -> ([Name], A.Pattern)
asView (A.AsP _ x p) = first (x :) $ asView p
-asView p = ([], p)
+asView p = ([], p)
-- | Check whether we are dealing with a universe.
isSet :: Expr -> Bool
@@ -56,16 +61,52 @@ deepUnScope = mapExpr unScope
-- | Apply an expression rewriting to every subexpression, inside-out.
-- See 'Agda.Syntax.Internal.Generic'
class ExprLike a where
+ foldExpr :: Monoid m => (Expr -> m) -> a -> m
traverseExpr :: (Monad m, Applicative m) => (Expr -> m Expr) -> a -> m a
mapExpr :: (Expr -> Expr) -> (a -> a)
mapExpr f e = runIdentity $ traverseExpr (Identity . f) e
instance ExprLike Expr where
+ foldExpr f e =
+ case e of
+ Var{} -> m
+ Def{} -> m
+ Proj{} -> m
+ Con{} -> m
+ PatternSyn{} -> m
+ Lit{} -> m
+ QuestionMark{} -> m
+ Underscore{} -> m
+ App _ e e' -> m `mappend` fold e `mappend` fold e'
+ WithApp _ e es -> m `mappend` fold e `mappend` fold es
+ Lam _ b e -> m `mappend` fold b `mappend` fold e
+ AbsurdLam{} -> m
+ ExtendedLam _ _ _ cs -> m `mappend` fold cs
+ Pi _ tel e -> m `mappend` fold tel `mappend` fold e
+ Fun _ e e' -> m `mappend` fold e `mappend` fold e'
+ Set{} -> m
+ Prop{} -> m
+ Let _ bs e -> m `mappend` fold bs `mappend` fold e
+ ETel tel -> m `mappend` fold tel
+ Rec _ as -> m `mappend` fold as
+ RecUpdate _ e as -> m `mappend` fold e `mappend` fold as
+ ScopedExpr _ e -> m `mappend` fold e
+ QuoteGoal _ _ e -> m `mappend` fold e
+ QuoteContext _ _ e -> m `mappend` fold e
+ Quote{} -> m
+ QuoteTerm{} -> m
+ Unquote{} -> m
+ DontCare e -> m `mappend` fold e
+ where
+ m = f e
+ fold = foldExpr f
+
traverseExpr f e = do
let trav e = traverseExpr f e
case e of
Var{} -> f e
Def{} -> f e
+ Proj{} -> f e
Con{} -> f e
Lit{} -> f e
QuestionMark{} -> f e
@@ -94,33 +135,54 @@ instance ExprLike Expr where
-- | TODO: currently does not go into colors.
instance ExprLike a => ExprLike (Common.Arg c a) where
+ foldExpr = foldMap . foldExpr
traverseExpr = traverse . traverseExpr
instance ExprLike a => ExprLike (Named x a) where
+ foldExpr = foldMap . foldExpr
traverseExpr = traverse . traverseExpr
instance ExprLike a => ExprLike [a] where
+ foldExpr = foldMap . foldExpr
traverseExpr = traverse . traverseExpr
instance ExprLike a => ExprLike (x, a) where
+ foldExpr f (x, e) = foldExpr f e
traverseExpr f (x, e) = (x,) <$> traverseExpr f e
instance ExprLike LamBinding where
+ foldExpr f e =
+ case e of
+ DomainFree{} -> mempty
+ DomainFull bs -> foldExpr f bs
traverseExpr f e =
case e of
DomainFree{} -> return e
DomainFull bs -> DomainFull <$> traverseExpr f bs
instance ExprLike TypedBindings where
+ foldExpr f (TypedBindings r b) = foldExpr f b
traverseExpr f (TypedBindings r b) = TypedBindings r <$> traverseExpr f b
instance ExprLike TypedBinding where
+ foldExpr f e =
+ case e of
+ TBind _ _ e -> foldExpr f e
+ TLet _ ds -> foldExpr f ds
traverseExpr f e =
case e of
TBind r xs e -> TBind r xs <$> traverseExpr f e
TLet r ds -> TLet r <$> traverseExpr f ds
instance ExprLike LetBinding where
+ foldExpr f e =
+ case e of
+ LetBind _ _ _ e e' -> fold e `mappend` fold e'
+ LetPatBind _ p e -> fold p `mappend` fold e
+ LetApply{} -> mempty
+ LetOpen{} -> mempty
+ where fold e = foldExpr f e
+
traverseExpr f e = do
let trav e = traverseExpr f e
case e of
@@ -131,8 +193,39 @@ instance ExprLike LetBinding where
-- | TODO: currently does not go into patterns.
instance ExprLike (Pattern' a) where
+ foldExpr f _ = mempty
traverseExpr f e = return e
-- | TODO: currently does not go into clauses.
instance ExprLike (Clause' a) where
+ foldExpr f _ = mempty
traverseExpr f e = return e
+
+{- TODO: finish
+instance ExprLike (Clause' a) where
+ foldExpr f (Clause _ rhs ds) = fold rhs `mappend` fold ds
+ where fold e = foldExpr f e
+ traverseExpr f (Clause lhs rhs ds) = Clause lhs <$> trav rhs <*> trav ds
+ where trav e = traverseExpr f e
+
+instance ExprLike RHS where
+ foldExpr f rhs =
+ case rhs of
+ RHS e -> fold e
+ AbsurdRHS{} -> mempty
+ WithRHS _ es cs -> fold es `mappend` fold cs
+ RewriteRHS _ es rhs ds -> fold es `mappend` fold rhs `mappend` fold ds
+ where fold e = foldExpr f e
+
+ traverseExpr f rhs =
+ case rhs of
+ RHS e -> RHS <$> trav e
+ AbsurdRHS{} -> pure rhs
+ WithRHS x es cs -> WithRHS x <$> trav es <*> trav cs
+ RewriteRHS xs es rhs ds -> RewriteRHS xs <$> trav es <*> trav rhs <*> trav ds
+ where trav e = traverseExpr f e
+
+instance ExprLike Declaration where
+ foldExpr f d =
+ case d of
+-}
diff --git a/src/full/Agda/Syntax/Common.hs b/src/full/Agda/Syntax/Common.hs
index 225a836..381b300 100644
--- a/src/full/Agda/Syntax/Common.hs
+++ b/src/full/Agda/Syntax/Common.hs
@@ -1,10 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{-| Some common syntactic entities are defined in this module.
-}
@@ -27,10 +28,9 @@ import Agda.Utils.Functor
import Agda.Utils.Pretty
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-
---------------------------------------------------------------------------
-- * Delayed
---------------------------------------------------------------------------
@@ -314,7 +314,8 @@ isHiddenArg arg = argHiding arg /= NotHidden
mapArgInfo :: (ArgInfo c -> ArgInfo c') -> Arg c a -> Arg c' a
mapArgInfo f arg = arg { argInfo = f $ argInfo arg }
-argColors = argInfoColors . argInfo
+argColors :: Arg c a -> [c]
+argColors = argInfoColors . argInfo
mapArgColors :: ([c] -> [c']) -> Arg c a -> Arg c' a
mapArgColors = mapArgInfo . mapArgInfoColors
@@ -329,10 +330,10 @@ defaultColoredArg :: ([c],a) -> Arg c a
defaultColoredArg (cs,a) = setArgColors cs $ defaultArg a
noColorArg :: Hiding -> Relevance -> a -> Arg c a
-noColorArg h r = Arg $ ArgInfo { argInfoHiding = h
- , argInfoRelevance = r
- , argInfoColors = []
- }
+noColorArg h r = Arg ArgInfo { argInfoHiding = h
+ , argInfoRelevance = r
+ , argInfoColors = []
+ }
-- | @xs \`withArgsFrom\` args@ translates @xs@ into a list of 'Arg's,
-- using the elements in @args@ to fill in the non-'unArg' fields.
@@ -408,7 +409,8 @@ instance LensRelevance (Dom c e) where
mapDomInfo :: (ArgInfo c -> ArgInfo c') -> Dom c a -> Dom c' a
mapDomInfo f arg = arg { domInfo = f $ domInfo arg }
-domColors = argInfoColors . domInfo
+domColors :: Dom c a -> [c]
+domColors = argInfoColors . domInfo
argFromDom :: Dom c a -> Arg c a
argFromDom (Dom i a) = Arg i a
@@ -426,8 +428,8 @@ defaultDom = Dom defaultArgInfo
-- | Something potentially carrying a name.
data Named name a =
Named { nameOf :: Maybe name
- , namedThing :: a
- }
+ , namedThing :: a
+ }
deriving (Eq, Ord, Typeable, Functor, Foldable, Traversable)
-- | Standard naming.
@@ -557,9 +559,9 @@ instance Show NameId where
show (NameId x i) = show x ++ "@" ++ show i
instance Enum NameId where
- succ (NameId n m) = NameId (n + 1) m
- pred (NameId n m) = NameId (n - 1) m
- toEnum n = __IMPOSSIBLE__ -- should not be used
+ succ (NameId n m) = NameId (n + 1) m
+ pred (NameId n m) = NameId (n - 1) m
+ toEnum n = __IMPOSSIBLE__ -- should not be used
fromEnum (NameId n _) = fromIntegral n
instance Hashable NameId where
@@ -592,9 +594,11 @@ data TerminationCheck m
-- ^ Skip termination checking (unsafe).
| NonTerminating
-- ^ Treat as non-terminating.
+ | Terminating
+ -- ^ Treat as terminating (unsafe). Same effect as 'NoTerminationCheck'.
| TerminationMeasure !Range m
-- ^ Skip termination checking but use measure instead.
- deriving (Typeable, Show, Eq)
+ deriving (Typeable, Show, Eq, Functor)
instance KillRange m => KillRange (TerminationCheck m) where
killRange (TerminationMeasure _ m) = TerminationMeasure noRange (killRange m)
diff --git a/src/full/Agda/Syntax/Concrete.hs b/src/full/Agda/Syntax/Concrete.hs
index 39509d4..1ba4fa2 100644
--- a/src/full/Agda/Syntax/Concrete.hs
+++ b/src/full/Agda/Syntax/Concrete.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-| The concrete syntax is a raw representation of the program text
@@ -12,48 +12,50 @@
around, it can be printed exactly as the user wrote it.
-}
module Agda.Syntax.Concrete
- ( -- * Expressions
- Expr(..)
- , OpApp(..), fromOrdinary
- , module Agda.Syntax.Concrete.Name
- , appView, AppView(..)
- -- * Bindings
- , LamBinding
- , LamBinding'(..)
- , TypedBindings
- , TypedBindings'(..)
- , TypedBinding
- , TypedBinding'(..)
- , ColoredTypedBinding(..)
- , BoundName(..), mkBoundName_, mkBoundName
- , Telescope -- (..)
- , countTelVars
- -- * Declarations
- , Declaration(..)
- , ModuleApplication(..)
- , TypeSignature
- , TypeSignatureOrInstanceBlock
- , Constructor
- , ImportDirective(..), UsingOrHiding(..), ImportedName(..)
- , Renaming(..), AsName(..)
- , defaultImportDir
- , OpenShortHand(..), RewriteEqn, WithExpr
- , LHS(..), Pattern(..), LHSCore(..)
- , RHS, RHS'(..), WhereClause, WhereClause'(..)
- , Pragma(..)
- , Module
- , ThingWithFixity(..)
- , topLevelModuleName
+ ( -- * Expressions
+ Expr(..)
+ , OpApp(..), fromOrdinary
+ , module Agda.Syntax.Concrete.Name
+ , appView, AppView(..)
+ -- * Bindings
+ , LamBinding
+ , LamBinding'(..)
+ , TypedBindings
+ , TypedBindings'(..)
+ , TypedBinding
+ , TypedBinding'(..)
+ , ColoredTypedBinding(..)
+ , BoundName(..), mkBoundName_, mkBoundName
+ , Telescope -- (..)
+ , countTelVars
+ -- * Declarations
+ , Declaration(..)
+ , ModuleApplication(..)
+ , TypeSignature
+ , TypeSignatureOrInstanceBlock
+ , Constructor
+ , ImportDirective(..), UsingOrHiding(..), ImportedName(..)
+ , Renaming(..), AsName(..)
+ , defaultImportDir
+ , OpenShortHand(..), RewriteEqn, WithExpr
+ , LHS(..), Pattern(..), LHSCore(..)
+ , RHS, RHS'(..), WhereClause, WhereClause'(..)
+ , Pragma(..)
+ , Module
+ , ThingWithFixity(..)
+ , topLevelModuleName
-- * Pattern tools
- , patternHead, patternNames
+ , patternHead, patternNames
+ -- * Lenses
+ , mapLhsOriginalPattern
-- * Concrete instances
- , Color
- , Arg
--- , Dom
- , NamedArg
- , ArgInfo
- )
- where
+ , Color
+ , Arg
+ -- , Dom
+ , NamedArg
+ , ArgInfo
+ )
+ where
import Control.DeepSeq
import Data.Typeable (Typeable)
@@ -69,7 +71,9 @@ import Agda.Syntax.Literal
import Agda.Syntax.Concrete.Name
-#include "../undefined.h"
+import Agda.Utils.Lens
+
+#include "undefined.h"
import Agda.Utils.Impossible
type Color = Expr
@@ -79,9 +83,11 @@ type NamedArg a = Common.NamedArg Color a
type ArgInfo = Common.ArgInfo Color
data OpApp e
- = SyntaxBindingLambda !Range [LamBinding] e -- ^ an abstraction inside a special syntax declaration (see Issue 358 why we introduce this).
- | Ordinary e
- deriving (Typeable, Functor, Foldable, Traversable)
+ = SyntaxBindingLambda !Range [LamBinding] e
+ -- ^ An abstraction inside a special syntax declaration
+ -- (see Issue 358 why we introduce this).
+ | Ordinary e
+ deriving (Typeable, Functor, Foldable, Traversable)
fromOrdinary :: e -> OpApp e -> e
fromOrdinary d (Ordinary e) = e
@@ -89,84 +95,86 @@ fromOrdinary d _ = d
-- | Concrete expressions. Should represent exactly what the user wrote.
data Expr
- = Ident QName -- ^ ex: @x@
- | Lit Literal -- ^ ex: @1@ or @\"foo\"@
- | QuestionMark !Range (Maybe Nat) -- ^ ex: @?@ or @{! ... !}@
- | Underscore !Range (Maybe String) -- ^ ex: @_@ or @_A_5@
- | RawApp !Range [Expr] -- ^ before parsing operators
- | App !Range Expr (NamedArg Expr) -- ^ ex: @e e@, @e {e}@, or @e {x = e}@
- | OpApp !Range QName [NamedArg (OpApp Expr)] -- ^ ex: @e + e@
- | WithApp !Range Expr [Expr] -- ^ ex: @e | e1 | .. | en@
- | HiddenArg !Range (Named_ Expr) -- ^ ex: @{e}@ or @{x=e}@
- | InstanceArg !Range (Named_ Expr) -- ^ ex: @{{e}}@ or @{{x=e}}@
- | Lam !Range [LamBinding] Expr -- ^ ex: @\\x {y} -> e@ or @\\(x:A){y:B} -> e@
- | AbsurdLam !Range Hiding -- ^ ex: @\\ ()@
- | ExtendedLam !Range [(LHS,RHS,WhereClause)] -- ^ ex: @\\ { p11 .. p1a -> e1 ; .. ; pn1 .. pnz -> en }@
- | Fun !Range Expr Expr -- ^ ex: @e -> e@ or @.e -> e@ (NYI: @{e} -> e@)
- | Pi Telescope Expr -- ^ ex: @(xs:e) -> e@ or @{xs:e} -> e@
- | Set !Range -- ^ ex: @Set@
- | Prop !Range -- ^ ex: @Prop@
- | SetN !Range Integer -- ^ ex: @Set0, Set1, ..@
- | Rec !Range [(Name, Expr)] -- ^ ex: @record {x = a; y = b}@
- | RecUpdate !Range Expr [(Name, Expr)] -- ^ ex: @record e {x = a; y = b}@
- | Let !Range [Declaration] Expr -- ^ ex: @let Ds in e@
- | Paren !Range Expr -- ^ ex: @(e)@
- | Absurd !Range -- ^ ex: @()@ or @{}@, only in patterns
- | As !Range Name Expr -- ^ ex: @x\@p@, only in patterns
- | Dot !Range Expr -- ^ ex: @.p@, only in patterns
- | ETel Telescope -- ^ only used for printing telescopes
- | QuoteGoal !Range Name Expr -- ^ ex: @quoteGoal x in e@
- | QuoteContext !Range Name Expr -- ^ ex: @quoteContext ctx in e@
- | Quote !Range -- ^ ex: @quote@, should be applied to a name
- | QuoteTerm !Range -- ^ ex: @quoteTerm@, should be applied to a term
- | Tactic !Range Expr [Expr] -- ^ @tactic solve | subgoal1 | .. | subgoalN@
- | Unquote !Range -- ^ ex: @unquote@, should be applied to a term of type @Term@
- | DontCare Expr -- ^ to print irrelevant things
- | Equal !Range Expr Expr -- ^ ex: @a = b@, used internally in the parser
- deriving (Typeable)
+ = Ident QName -- ^ ex: @x@
+ | Lit Literal -- ^ ex: @1@ or @\"foo\"@
+ | QuestionMark !Range (Maybe Nat) -- ^ ex: @?@ or @{! ... !}@
+ | Underscore !Range (Maybe String) -- ^ ex: @_@ or @_A_5@
+ | RawApp !Range [Expr] -- ^ before parsing operators
+ | App !Range Expr (NamedArg Expr) -- ^ ex: @e e@, @e {e}@, or @e {x = e}@
+ | OpApp !Range QName [NamedArg (OpApp Expr)] -- ^ ex: @e + e@
+ | WithApp !Range Expr [Expr] -- ^ ex: @e | e1 | .. | en@
+ | HiddenArg !Range (Named_ Expr) -- ^ ex: @{e}@ or @{x=e}@
+ | InstanceArg !Range (Named_ Expr) -- ^ ex: @{{e}}@ or @{{x=e}}@
+ | Lam !Range [LamBinding] Expr -- ^ ex: @\\x {y} -> e@ or @\\(x:A){y:B} -> e@
+ | AbsurdLam !Range Hiding -- ^ ex: @\\ ()@
+ | ExtendedLam !Range [(LHS,RHS,WhereClause)] -- ^ ex: @\\ { p11 .. p1a -> e1 ; .. ; pn1 .. pnz -> en }@
+ | Fun !Range Expr Expr -- ^ ex: @e -> e@ or @.e -> e@ (NYI: @{e} -> e@)
+ | Pi Telescope Expr -- ^ ex: @(xs:e) -> e@ or @{xs:e} -> e@
+ | Set !Range -- ^ ex: @Set@
+ | Prop !Range -- ^ ex: @Prop@
+ | SetN !Range Integer -- ^ ex: @Set0, Set1, ..@
+ | Rec !Range [(Name, Expr)] -- ^ ex: @record {x = a; y = b}@
+ | RecUpdate !Range Expr [(Name, Expr)] -- ^ ex: @record e {x = a; y = b}@
+ | Let !Range [Declaration] Expr -- ^ ex: @let Ds in e@
+ | Paren !Range Expr -- ^ ex: @(e)@
+ | Absurd !Range -- ^ ex: @()@ or @{}@, only in patterns
+ | As !Range Name Expr -- ^ ex: @x\@p@, only in patterns
+ | Dot !Range Expr -- ^ ex: @.p@, only in patterns
+ | ETel Telescope -- ^ only used for printing telescopes
+ | QuoteGoal !Range Name Expr -- ^ ex: @quoteGoal x in e@
+ | QuoteContext !Range Name Expr -- ^ ex: @quoteContext ctx in e@
+ | Quote !Range -- ^ ex: @quote@, should be applied to a name
+ | QuoteTerm !Range -- ^ ex: @quoteTerm@, should be applied to a term
+ | Tactic !Range Expr [Expr] -- ^ @tactic solve | subgoal1 | .. | subgoalN@
+ | Unquote !Range -- ^ ex: @unquote@, should be applied to a term of type @Term@
+ | DontCare Expr -- ^ to print irrelevant things
+ | Equal !Range Expr Expr -- ^ ex: @a = b@, used internally in the parser
+ deriving (Typeable)
instance NFData Expr
-- | Concrete patterns. No literals in patterns at the moment.
data Pattern
- = IdentP QName -- ^ @c@ or @x@
- | QuoteP !Range -- ^ @quote@
- | AppP Pattern (NamedArg Pattern) -- ^ @p p'@ or @p {x = p'}@
- | RawAppP !Range [Pattern] -- ^ @p1..pn@ before parsing operators
- | OpAppP !Range QName [NamedArg Pattern] -- ^ eg: @p => p'@ for operator @_=>_@
- | HiddenP !Range (Named_ Pattern) -- ^ @{p}@ or @{x = p}@
- | InstanceP !Range (Named_ Pattern) -- ^ @{{p}}@ or @{{x = p}}@
- | ParenP !Range Pattern -- ^ @(p)@
- | WildP !Range -- ^ @_@
- | AbsurdP !Range -- ^ @()@
- | AsP !Range Name Pattern -- ^ @x\@p@ unused
- | DotP !Range Expr -- ^ @.e@
- | LitP Literal -- ^ @0@, @1@, etc.
- deriving (Typeable)
+ = IdentP QName -- ^ @c@ or @x@
+ | QuoteP !Range -- ^ @quote@
+ | AppP Pattern (NamedArg Pattern) -- ^ @p p'@ or @p {x = p'}@
+ | RawAppP !Range [Pattern] -- ^ @p1..pn@ before parsing operators
+ | OpAppP !Range QName [NamedArg Pattern] -- ^ eg: @p => p'@ for operator @_=>_@
+ | HiddenP !Range (Named_ Pattern) -- ^ @{p}@ or @{x = p}@
+ | InstanceP !Range (Named_ Pattern) -- ^ @{{p}}@ or @{{x = p}}@
+ | ParenP !Range Pattern -- ^ @(p)@
+ | WildP !Range -- ^ @_@
+ | AbsurdP !Range -- ^ @()@
+ | AsP !Range Name Pattern -- ^ @x\@p@ unused
+ | DotP !Range Expr -- ^ @.e@
+ | LitP Literal -- ^ @0@, @1@, etc.
+ deriving (Typeable)
instance NFData Pattern
-- | A lambda binding is either domain free or typed.
type LamBinding = LamBinding' TypedBindings
data LamBinding' a
- = DomainFree ArgInfo BoundName -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@
- | DomainFull a -- ^ . @(xs : e)@ or @{xs : e}@
- deriving (Typeable, Functor, Foldable, Traversable)
+ = DomainFree ArgInfo BoundName -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@
+ | DomainFull a -- ^ . @(xs : e)@ or @{xs : e}@
+ deriving (Typeable, Functor, Foldable, Traversable)
-- | A sequence of typed bindings with hiding information. Appears in dependent
-- function spaces, typed lambdas, and telescopes.
+
type TypedBindings = TypedBindings' TypedBinding
-data TypedBindings' a = TypedBindings !Range (Arg a)
- -- ^ . @(xs : e)@ or @{xs : e}@
- deriving (Typeable, Functor, Foldable, Traversable)
+data TypedBindings' a = TypedBindings !Range (Arg a)
+ -- ^ . @(xs : e)@ or @{xs : e}@
+ deriving (Typeable, Functor, Foldable, Traversable)
-data BoundName = BName { boundName :: Name
- , boundLabel :: Name -- ^ for implicit function types the label matters and can't be alpha-renamed
- , bnameFixity :: Fixity'
- }
- deriving (Typeable)
+data BoundName = BName
+ { boundName :: Name
+ , boundLabel :: Name -- ^ for implicit function types the label matters and can't be alpha-renamed
+ , bnameFixity :: Fixity'
+ }
+ deriving (Typeable)
mkBoundName_ :: Name -> BoundName
mkBoundName_ x = mkBoundName x defaultFixity'
@@ -175,10 +183,12 @@ mkBoundName :: Name -> Fixity' -> BoundName
mkBoundName x f = BName x x f
-- | A typed binding.
+
type TypedBinding = TypedBinding' Expr
+
data TypedBinding' e
- = TBind !Range [BoundName] e -- ^ Binding @(x1 ... xn : A)@.
- | TLet !Range [Declaration] -- ^ Let binding @(let Ds)@ or @(open M args)@.
+ = TBind !Range [BoundName] e -- ^ Binding @(x1 ... xn : A)@.
+ | TLet !Range [Declaration] -- ^ Let binding @(let Ds)@ or @(open M args)@.
deriving (Typeable, Functor, Foldable, Traversable)
-- | Color a TypeBinding. Used by Pretty.
@@ -202,14 +212,15 @@ countTelVars tel =
We use fixity information to see which name is actually defined.
-}
-data LHS = LHS { lhsOriginalPattern :: Pattern -- ^ @f ps@
- , lhsWithPattern :: [Pattern] -- ^ @| p@ (many)
- , lhsRewriteEqn :: [RewriteEqn] -- ^ @rewrite e@ (many)
- , lhsWithExpr :: [WithExpr] -- ^ @with e@ (many)
- }
- -- ^ original pattern, with-patterns, rewrite equations and with-expressions
- | Ellipsis Range [Pattern] [RewriteEqn] [WithExpr]
- -- ^ new with-patterns, rewrite equations and with-expressions
+data LHS
+ = LHS { lhsOriginalPattern :: Pattern -- ^ @f ps@
+ , lhsWithPattern :: [Pattern] -- ^ @| p@ (many)
+ , lhsRewriteEqn :: [RewriteEqn] -- ^ @rewrite e@ (many)
+ , lhsWithExpr :: [WithExpr] -- ^ @with e@ (many)
+ }
+ -- ^ original pattern, with-patterns, rewrite equations and with-expressions
+ | Ellipsis Range [Pattern] [RewriteEqn] [WithExpr]
+ -- ^ new with-patterns, rewrite equations and with-expressions
deriving (Typeable)
type RewriteEqn = Expr
@@ -240,75 +251,75 @@ lhsCoreToPattern (LHSProj d ps1 lhscore ps2) = OpAppP (fuseRange d ps) (unqualif
type RHS = RHS' Expr
data RHS' e
- = AbsurdRHS -- ^ No right hand side because of absurd match.
- | RHS e
+ = AbsurdRHS -- ^ No right hand side because of absurd match.
+ | RHS e
deriving (Typeable, Functor, Foldable, Traversable)
type WhereClause = WhereClause' [Declaration]
data WhereClause' decls
- = NoWhere -- ^ No @where@ clauses.
- | AnyWhere decls -- ^ Ordinary @where at .
- | SomeWhere Name decls -- ^ Named where: @module M where at .
+ = NoWhere -- ^ No @where@ clauses.
+ | AnyWhere decls -- ^ Ordinary @where at .
+ | SomeWhere Name decls -- ^ Named where: @module M where at .
deriving (Typeable, Functor, Foldable, Traversable)
-- | The things you are allowed to say when you shuffle names between name
-- spaces (i.e. in @import@, @namespace@, or @open@ declarations).
-data ImportDirective
- = ImportDirective
- { importDirRange :: !Range
- , usingOrHiding :: UsingOrHiding
- , renaming :: [Renaming]
- , publicOpen :: Bool -- ^ Only for @open at . Exports the opened names from the current module.
- }
- deriving (Typeable)
+data ImportDirective = ImportDirective
+ { importDirRange :: !Range
+ , usingOrHiding :: UsingOrHiding
+ , renaming :: [Renaming]
+ , publicOpen :: Bool -- ^ Only for @open at . Exports the opened names from the current module.
+ }
+ deriving (Typeable)
-- | Default is directive is @private@ (use everything, but do not export).
defaultImportDir :: ImportDirective
defaultImportDir = ImportDirective noRange (Hiding []) [] False
data UsingOrHiding
- = Hiding [ImportedName]
- | Using [ImportedName]
- deriving (Typeable)
+ = Hiding [ImportedName]
+ | Using [ImportedName]
+ deriving (Typeable)
-- | An imported name can be a module or a defined name
-data ImportedName = ImportedModule { importedName :: Name }
- | ImportedName { importedName :: Name }
- deriving (Typeable, Eq, Ord)
+data ImportedName
+ = ImportedModule { importedName :: Name }
+ | ImportedName { importedName :: Name }
+ deriving (Typeable, Eq, Ord)
instance Show ImportedName where
- show (ImportedModule x) = "module " ++ show x
- show (ImportedName x) = show x
-
-data Renaming = Renaming { renFrom :: ImportedName
- -- ^ Rename from this name.
- , renTo :: Name
- -- ^ To this one.
- , renToRange :: Range
- -- ^ The range of the \"to\" keyword. Retained
- -- for highlighting purposes.
- }
- deriving (Typeable)
-
-data AsName = AsName { asName :: Name
- -- ^ The \"as\" name.
- , asRange :: Range
- -- ^ The range of the \"as\" keyword. Retained
- -- for highlighting purposes.
- }
- deriving (Typeable, Show)
+ show (ImportedModule x) = "module " ++ show x
+ show (ImportedName x) = show x
+
+data Renaming = Renaming
+ { renFrom :: ImportedName
+ -- ^ Rename from this name.
+ , renTo :: Name
+ -- ^ To this one.
+ , renToRange :: Range
+ -- ^ The range of the \"to\" keyword. Retained for highlighting purposes.
+ }
+ deriving (Typeable)
+
+data AsName = AsName
+ { asName :: Name
+ -- ^ The \"as\" name.
+ , asRange :: Range
+ -- ^ The range of the \"as\" keyword. Retained for highlighting purposes.
+ }
+ deriving (Typeable, Show)
{--------------------------------------------------------------------------
Declarations
--------------------------------------------------------------------------}
-- | Just type signatures.
-type TypeSignature = Declaration
+type TypeSignature = Declaration
-- | Just type signatures or instance blocks.
-type TypeSignatureOrInstanceBlock = Declaration
+type TypeSignatureOrInstanceBlock = Declaration
-- | A data constructor declaration is just a type signature.
type Constructor = TypeSignature
@@ -318,61 +329,61 @@ type Constructor = TypeSignature
-}
data Declaration
- = TypeSig ArgInfo Name Expr
- -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden)
- | Field Name (Arg Expr) -- ^ Record field, can be hidden and/or irrelevant.
- | FunClause LHS RHS WhereClause
- | DataSig !Range Induction Name [LamBinding] Expr -- ^ lone data signature in mutual block
- | Data !Range Induction Name [LamBinding] (Maybe Expr) [Constructor]
- | RecordSig !Range Name [LamBinding] Expr -- ^ lone record signature in mutual block
- | Record !Range Name (Maybe (Ranged Induction)) (Maybe Name) [LamBinding] (Maybe Expr) [Declaration]
- -- ^ The optional name is a name for the record constructor.
- | Infix Fixity [Name]
- | Syntax Name Notation -- ^ notation declaration for a name
- | PatternSyn !Range Name [Arg Name] Pattern
- | Mutual !Range [Declaration]
- | Abstract !Range [Declaration]
- | Private !Range [Declaration]
- | InstanceB !Range [Declaration]
- | Postulate !Range [TypeSignatureOrInstanceBlock]
- | Primitive !Range [TypeSignature]
- | Open !Range QName ImportDirective
- | Import !Range QName (Maybe AsName) OpenShortHand ImportDirective
- | ModuleMacro !Range Name ModuleApplication OpenShortHand ImportDirective
- | Module !Range QName [TypedBindings] [Declaration]
- | UnquoteDecl !Range Name Expr
- | Pragma Pragma
- deriving (Typeable)
+ = TypeSig ArgInfo Name Expr
+ -- ^ Axioms and functions can be irrelevant. (Hiding should be NotHidden)
+ | Field Name (Arg Expr) -- ^ Record field, can be hidden and/or irrelevant.
+ | FunClause LHS RHS WhereClause
+ | DataSig !Range Induction Name [LamBinding] Expr -- ^ lone data signature in mutual block
+ | Data !Range Induction Name [LamBinding] (Maybe Expr) [Constructor]
+ | RecordSig !Range Name [LamBinding] Expr -- ^ lone record signature in mutual block
+ | Record !Range Name (Maybe (Ranged Induction)) (Maybe Name) [LamBinding] (Maybe Expr) [Declaration]
+ -- ^ The optional name is a name for the record constructor.
+ | Infix Fixity [Name]
+ | Syntax Name Notation -- ^ notation declaration for a name
+ | PatternSyn !Range Name [Arg Name] Pattern
+ | Mutual !Range [Declaration]
+ | Abstract !Range [Declaration]
+ | Private !Range [Declaration]
+ | InstanceB !Range [Declaration]
+ | Postulate !Range [TypeSignatureOrInstanceBlock]
+ | Primitive !Range [TypeSignature]
+ | Open !Range QName ImportDirective
+ | Import !Range QName (Maybe AsName) OpenShortHand ImportDirective
+ | ModuleMacro !Range Name ModuleApplication OpenShortHand ImportDirective
+ | Module !Range QName [TypedBindings] [Declaration]
+ | UnquoteDecl !Range Name Expr
+ | Pragma Pragma
+ deriving (Typeable)
data ModuleApplication
= SectionApp Range [TypedBindings] Expr
-- ^ @tel. M args@
| RecordModuleIFS Range QName
-- ^ @M {{...}}@
- deriving (Typeable)
+ deriving (Typeable)
data OpenShortHand = DoOpen | DontOpen
- deriving (Typeable, Eq, Show)
+ deriving (Typeable, Eq, Show)
-- Pragmas ----------------------------------------------------------------
-data Pragma = OptionsPragma !Range [String]
- | BuiltinPragma !Range String Expr
- | RewritePragma !Range QName
- | CompiledDataPragma !Range QName String [String]
- | CompiledTypePragma !Range QName String
- | CompiledPragma !Range QName String
- | CompiledExportPragma !Range QName String
- | CompiledEpicPragma !Range QName String
- | CompiledJSPragma !Range QName String
- | StaticPragma !Range QName
- | ImportPragma !Range String
- -- ^ Invariant: The string must be a valid Haskell
- -- module name.
- | ImpossiblePragma !Range
- | EtaPragma !Range QName
- | TerminationCheckPragma !Range (TerminationCheck Name)
- deriving (Typeable)
+data Pragma
+ = OptionsPragma !Range [String]
+ | BuiltinPragma !Range String Expr
+ | RewritePragma !Range QName
+ | CompiledDataPragma !Range QName String [String]
+ | CompiledTypePragma !Range QName String
+ | CompiledPragma !Range QName String
+ | CompiledExportPragma !Range QName String
+ | CompiledEpicPragma !Range QName String
+ | CompiledJSPragma !Range QName String
+ | StaticPragma !Range QName
+ | ImportPragma !Range String
+ -- ^ Invariant: The string must be a valid Haskell module name.
+ | ImpossiblePragma !Range
+ | EtaPragma !Range QName
+ | TerminationCheckPragma !Range (TerminationCheck Name)
+ deriving (Typeable)
---------------------------------------------------------------------------
@@ -391,6 +402,15 @@ topLevelModuleName (_, ds) = case last ds of
_ -> __IMPOSSIBLE__
{--------------------------------------------------------------------------
+ Lenses
+ --------------------------------------------------------------------------}
+
+mapLhsOriginalPattern :: (Pattern -> Pattern) -> LHS -> LHS
+mapLhsOriginalPattern f lhs at Ellipsis{} = lhs
+mapLhsOriginalPattern f lhs at LHS{ lhsOriginalPattern = p } =
+ lhs { lhsOriginalPattern = f p }
+
+{--------------------------------------------------------------------------
Views
--------------------------------------------------------------------------}
@@ -399,13 +419,13 @@ data AppView = AppView Expr [NamedArg Expr]
appView :: Expr -> AppView
appView (App r e1 e2) = vApp (appView e1) e2
- where
- vApp (AppView e es) arg = AppView e (es ++ [arg])
+ where
+ vApp (AppView e es) arg = AppView e (es ++ [arg])
appView (RawApp _ (e:es)) = AppView e $ map arg es
- where
- arg (HiddenArg _ e) = noColorArg Hidden Relevant e
- arg (InstanceArg _ e) = noColorArg Instance Relevant e
- arg e = noColorArg NotHidden Relevant (unnamed e)
+ where
+ arg (HiddenArg _ e) = noColorArg Hidden Relevant e
+ arg (InstanceArg _ e) = noColorArg Instance Relevant e
+ arg e = noColorArg NotHidden Relevant (unnamed e)
appView e = AppView e []
{--------------------------------------------------------------------------
@@ -416,20 +436,20 @@ appView e = AppView e []
patternHead :: Pattern -> Maybe Name
patternHead p =
case p of
- IdentP x -> return $ unqualify x
- AppP p p' -> patternHead p
- RawAppP _ [] -> __IMPOSSIBLE__
- RawAppP _ (p:_) -> patternHead p
- OpAppP _ name ps -> return $ unqualify name
- HiddenP _ (namedPat) -> patternHead (namedThing namedPat)
- ParenP _ p -> patternHead p
- WildP _ -> Nothing
- AbsurdP _ -> Nothing
- AsP _ x p -> patternHead p
- DotP{} -> Nothing
- LitP (LitQName _ x) -> Nothing -- return $ unqualify x -- does not compile
- LitP _ -> Nothing
- QuoteP _ -> Nothing
+ IdentP x -> return $ unqualify x
+ AppP p p' -> patternHead p
+ RawAppP _ [] -> __IMPOSSIBLE__
+ RawAppP _ (p:_) -> patternHead p
+ OpAppP _ name ps -> return $ unqualify name
+ HiddenP _ (namedPat) -> patternHead (namedThing namedPat)
+ ParenP _ p -> patternHead p
+ WildP _ -> Nothing
+ AbsurdP _ -> Nothing
+ AsP _ x p -> patternHead p
+ DotP{} -> Nothing
+ LitP (LitQName _ x) -> Nothing -- return $ unqualify x -- does not compile
+ LitP _ -> Nothing
+ QuoteP _ -> Nothing
InstanceP _ (namedPat) -> patternHead (namedThing namedPat)
@@ -437,18 +457,18 @@ patternHead p =
patternNames :: Pattern -> [Name]
patternNames p =
case p of
- IdentP x -> [unqualify x]
- AppP p p' -> concatMap patternNames [p, namedArg p']
- RawAppP _ ps -> concatMap patternNames ps
- OpAppP _ name ps -> unqualify name : concatMap (patternNames . namedArg) ps
- HiddenP _ (namedPat) -> patternNames (namedThing namedPat)
- ParenP _ p -> patternNames p
- WildP _ -> []
- AbsurdP _ -> []
- AsP _ x p -> patternNames p
- DotP{} -> []
- LitP _ -> []
- QuoteP _ -> []
+ IdentP x -> [unqualify x]
+ AppP p p' -> concatMap patternNames [p, namedArg p']
+ RawAppP _ ps -> concatMap patternNames ps
+ OpAppP _ name ps -> unqualify name : concatMap (patternNames . namedArg) ps
+ HiddenP _ (namedPat) -> patternNames (namedThing namedPat)
+ ParenP _ p -> patternNames p
+ WildP _ -> []
+ AbsurdP _ -> []
+ AsP _ x p -> patternNames p
+ DotP{} -> []
+ LitP _ -> []
+ QuoteP _ -> []
InstanceP _ (namedPat) -> patternNames (namedThing namedPat)
{--------------------------------------------------------------------------
@@ -456,68 +476,68 @@ patternNames p =
--------------------------------------------------------------------------}
instance HasRange e => HasRange (OpApp e) where
- getRange e = case e of
- Ordinary e -> getRange e
- SyntaxBindingLambda r _ _ -> r
+ getRange e = case e of
+ Ordinary e -> getRange e
+ SyntaxBindingLambda r _ _ -> r
instance HasRange Expr where
- getRange e =
- case e of
- Ident x -> getRange x
- Lit x -> getRange x
- QuestionMark r _ -> r
- Underscore r _ -> r
- App r _ _ -> r
- RawApp r _ -> r
- OpApp r _ _ -> r
- WithApp r _ _ -> r
- Lam r _ _ -> r
- AbsurdLam r _ -> r
- ExtendedLam r _ -> r
- Fun r _ _ -> r
- Pi b e -> fuseRange b e
- Set r -> r
- Prop r -> r
- SetN r _ -> r
- Let r _ _ -> r
- Paren r _ -> r
- As r _ _ -> r
- Dot r _ -> r
- Absurd r -> r
- HiddenArg r _ -> r
- InstanceArg r _ -> r
- Rec r _ -> r
- RecUpdate r _ _ -> r
- ETel tel -> getRange tel
- QuoteGoal r _ _ -> r
- QuoteContext r _ _ -> r
- Quote r -> r
- QuoteTerm r -> r
- Unquote r -> r
- Tactic r _ _ -> r
- DontCare{} -> noRange
- Equal r _ _ -> r
+ getRange e =
+ case e of
+ Ident x -> getRange x
+ Lit x -> getRange x
+ QuestionMark r _ -> r
+ Underscore r _ -> r
+ App r _ _ -> r
+ RawApp r _ -> r
+ OpApp r _ _ -> r
+ WithApp r _ _ -> r
+ Lam r _ _ -> r
+ AbsurdLam r _ -> r
+ ExtendedLam r _ -> r
+ Fun r _ _ -> r
+ Pi b e -> fuseRange b e
+ Set r -> r
+ Prop r -> r
+ SetN r _ -> r
+ Let r _ _ -> r
+ Paren r _ -> r
+ As r _ _ -> r
+ Dot r _ -> r
+ Absurd r -> r
+ HiddenArg r _ -> r
+ InstanceArg r _ -> r
+ Rec r _ -> r
+ RecUpdate r _ _ -> r
+ ETel tel -> getRange tel
+ QuoteGoal r _ _ -> r
+ QuoteContext r _ _ -> r
+ Quote r -> r
+ QuoteTerm r -> r
+ Unquote r -> r
+ Tactic r _ _ -> r
+ DontCare{} -> noRange
+ Equal r _ _ -> r
-- instance HasRange Telescope where
-- getRange (TeleBind bs) = getRange bs
-- getRange (TeleFun x y) = fuseRange x y
instance HasRange TypedBindings where
- getRange (TypedBindings r _) = r
+ getRange (TypedBindings r _) = r
instance HasRange TypedBinding where
- getRange (TBind r _ _) = r
- getRange (TLet r _) = r
+ getRange (TBind r _ _) = r
+ getRange (TLet r _) = r
instance HasRange LamBinding where
- getRange (DomainFree _ x) = getRange x
- getRange (DomainFull b) = getRange b
+ getRange (DomainFree _ x) = getRange x
+ getRange (DomainFull b) = getRange b
instance HasRange BoundName where
getRange = getRange . boundName
instance HasRange WhereClause where
- getRange NoWhere = noRange
+ getRange NoWhere = noRange
getRange (AnyWhere ds) = getRange ds
getRange (SomeWhere _ ds) = getRange ds
@@ -526,67 +546,67 @@ instance HasRange ModuleApplication where
getRange (RecordModuleIFS r _) = r
instance HasRange Declaration where
- getRange (TypeSig _ x t) = fuseRange x t
- getRange (Field x t) = fuseRange x t
- getRange (FunClause lhs rhs wh) = fuseRange lhs rhs `fuseRange` wh
- getRange (DataSig r _ _ _ _) = r
- getRange (Data r _ _ _ _ _) = r
- getRange (RecordSig r _ _ _) = r
- getRange (Record r _ _ _ _ _ _) = r
- getRange (Mutual r _) = r
- getRange (Abstract r _) = r
- getRange (Open r _ _) = r
- getRange (ModuleMacro r _ _ _ _) = r
- getRange (Import r _ _ _ _) = r
- getRange (InstanceB r _) = r
- getRange (Private r _) = r
- getRange (Postulate r _) = r
- getRange (Primitive r _) = r
- getRange (Module r _ _ _) = r
- getRange (Infix f _) = getRange f
- getRange (Syntax n _) = getRange n
- getRange (PatternSyn r _ _ _) = r
- getRange (UnquoteDecl r _ _) = r
- getRange (Pragma p) = getRange p
+ getRange (TypeSig _ x t) = fuseRange x t
+ getRange (Field x t) = fuseRange x t
+ getRange (FunClause lhs rhs wh) = fuseRange lhs rhs `fuseRange` wh
+ getRange (DataSig r _ _ _ _) = r
+ getRange (Data r _ _ _ _ _) = r
+ getRange (RecordSig r _ _ _) = r
+ getRange (Record r _ _ _ _ _ _) = r
+ getRange (Mutual r _) = r
+ getRange (Abstract r _) = r
+ getRange (Open r _ _) = r
+ getRange (ModuleMacro r _ _ _ _) = r
+ getRange (Import r _ _ _ _) = r
+ getRange (InstanceB r _) = r
+ getRange (Private r _) = r
+ getRange (Postulate r _) = r
+ getRange (Primitive r _) = r
+ getRange (Module r _ _ _) = r
+ getRange (Infix f _) = getRange f
+ getRange (Syntax n _) = getRange n
+ getRange (PatternSyn r _ _ _) = r
+ getRange (UnquoteDecl r _ _) = r
+ getRange (Pragma p) = getRange p
instance HasRange LHS where
getRange (LHS p ps eqns ws) = fuseRange p (fuseRange ps (eqns ++ ws))
getRange (Ellipsis r _ _ _) = r
instance HasRange LHSCore where
- getRange (LHSHead f ps) = fuseRange f ps
+ getRange (LHSHead f ps) = fuseRange f ps
getRange (LHSProj d ps1 lhscore ps2) = d `fuseRange` ps1 `fuseRange` lhscore `fuseRange` ps2
instance HasRange RHS where
- getRange AbsurdRHS = noRange
- getRange (RHS e) = getRange e
+ getRange AbsurdRHS = noRange
+ getRange (RHS e) = getRange e
instance HasRange Pragma where
- getRange (OptionsPragma r _) = r
- getRange (BuiltinPragma r _ _) = r
- getRange (RewritePragma r _) = r
- getRange (CompiledDataPragma r _ _ _) = r
- getRange (CompiledTypePragma r _ _) = r
- getRange (CompiledPragma r _ _) = r
- getRange (CompiledExportPragma r _ _) = r
- getRange (CompiledEpicPragma r _ _) = r
- getRange (CompiledJSPragma r _ _) = r
- getRange (StaticPragma r _) = r
- getRange (ImportPragma r _) = r
- getRange (ImpossiblePragma r) = r
- getRange (EtaPragma r _) = r
- getRange (TerminationCheckPragma r _) = r
+ getRange (OptionsPragma r _) = r
+ getRange (BuiltinPragma r _ _) = r
+ getRange (RewritePragma r _) = r
+ getRange (CompiledDataPragma r _ _ _) = r
+ getRange (CompiledTypePragma r _ _) = r
+ getRange (CompiledPragma r _ _) = r
+ getRange (CompiledExportPragma r _ _) = r
+ getRange (CompiledEpicPragma r _ _) = r
+ getRange (CompiledJSPragma r _ _) = r
+ getRange (StaticPragma r _) = r
+ getRange (ImportPragma r _) = r
+ getRange (ImpossiblePragma r) = r
+ getRange (EtaPragma r _) = r
+ getRange (TerminationCheckPragma r _) = r
instance HasRange UsingOrHiding where
- getRange (Using xs) = getRange xs
- getRange (Hiding xs) = getRange xs
+ getRange (Using xs) = getRange xs
+ getRange (Hiding xs) = getRange xs
instance HasRange ImportDirective where
- getRange = importDirRange
+ getRange = importDirRange
instance HasRange ImportedName where
- getRange (ImportedName x) = getRange x
- getRange (ImportedModule x) = getRange x
+ getRange (ImportedName x) = getRange x
+ getRange (ImportedModule x) = getRange x
instance HasRange Renaming where
getRange r = getRange (renFrom r, renTo r)
@@ -595,19 +615,19 @@ instance HasRange AsName where
getRange a = getRange (asRange a, asName a)
instance HasRange Pattern where
- getRange (IdentP x) = getRange x
- getRange (AppP p q) = fuseRange p q
- getRange (OpAppP r _ _) = r
- getRange (RawAppP r _) = r
- getRange (ParenP r _) = r
- getRange (WildP r) = r
- getRange (AsP r _ _) = r
- getRange (AbsurdP r) = r
- getRange (LitP l) = getRange l
- getRange (QuoteP r) = r
- getRange (HiddenP r _) = r
- getRange (InstanceP r _) = r
- getRange (DotP r _) = r
+ getRange (IdentP x) = getRange x
+ getRange (AppP p q) = fuseRange p q
+ getRange (OpAppP r _ _) = r
+ getRange (RawAppP r _) = r
+ getRange (ParenP r _) = r
+ getRange (WildP r) = r
+ getRange (AsP r _ _) = r
+ getRange (AbsurdP r) = r
+ getRange (LitP l) = getRange l
+ getRange (QuoteP r) = r
+ getRange (HiddenP r _) = r
+ getRange (InstanceP r _) = r
+ getRange (DotP r _) = r
instance KillRange AsName where
killRange (AsName n _) = killRange1 (flip AsName noRange) n
diff --git a/src/full/Agda/Syntax/Concrete/Definitions.hs b/src/full/Agda/Syntax/Concrete/Definitions.hs
index b3432b8..acc46d1 100644
--- a/src/full/Agda/Syntax/Concrete/Definitions.hs
+++ b/src/full/Agda/Syntax/Concrete/Definitions.hs
@@ -1,6 +1,32 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.
+--
+-- * Attach fixity and syntax declarations to the definition they refer to.
+--
+-- * Distribute the following attributes to the individual definitions:
+-- @abstract@,
+-- @instance@,
+-- @postulate@,
+-- @primitive@,
+-- @private@,
+-- termination pragmas.
+--
+-- * Gather the function clauses belonging to one function definition.
+--
+-- * Expand ellipsis @...@ in function clauses following @with at .
+--
+-- * Infer mutual blocks.
+-- A block starts when a lone signature is encountered, and ends when
+-- all lone signatures have seen their definition.
+--
+-- * Report basic well-formedness error,
+-- when one of the above transformation fails.
module Agda.Syntax.Concrete.Definitions
( NiceDeclaration(..)
@@ -15,15 +41,15 @@ module Agda.Syntax.Concrete.Definitions
import Control.Arrow ((***))
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.State
-import Data.Typeable (Typeable)
import Data.Foldable hiding (concatMap, mapM_, notElem, elem, all)
import qualified Data.Map as Map
import Data.Map (Map)
+import Data.Monoid ( Monoid(mappend, mempty) )
import Data.List as List
import Data.Traversable (traverse)
+import Data.Typeable (Typeable)
import Agda.Syntax.Concrete
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo, TerminationCheck())
@@ -32,12 +58,15 @@ import Agda.Syntax.Position
import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Concrete.Pretty ()
-import Agda.Utils.Pretty
-import Agda.Utils.List (mhead, isSublistOf)
+
+import Agda.Utils.Except ( Error(noMsg, strMsg), MonadError(throwError) )
+import Agda.Utils.Lens
+import Agda.Utils.List (headMaybe, isSublistOf)
import Agda.Utils.Monad
+import Agda.Utils.Pretty
import Agda.Utils.Update
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{--------------------------------------------------------------------------
@@ -111,6 +140,9 @@ data DeclarationException
| InvalidMeasureMutual Range
-- ^ In a mutual block, all or none need a MEASURE pragma.
-- Range is of mutual block.
+ | PragmaNoTerminationCheck Range
+ -- ^ Pragma @{-# NO_TERMINATION_CHECK #-}@ has been replaced
+ -- by {-# TERMINATING #-} and {-# NON_TERMINATING #-}.
deriving (Typeable)
instance HasRange DeclarationException where
@@ -132,6 +164,7 @@ instance HasRange DeclarationException where
getRange (WrongContentPostulateBlock r) = r
getRange (InvalidTerminationCheckPragma r) = r
getRange (InvalidMeasureMutual r) = r
+ getRange (PragmaNoTerminationCheck r) = r
instance HasRange NiceDeclaration where
getRange (Axiom r _ _ _ _ _ _) = r
@@ -157,13 +190,15 @@ instance Error DeclarationException where
noMsg = strMsg ""
strMsg = DeclarationPanic
+-- These error messages can (should) be terminated by a dot ".",
+-- there is no error context printed after them.
instance Show DeclarationException where
show (MultipleFixityDecls xs) = show $
- sep [ fsep $ pwords "Multiple fixity declarations for"
+ sep [ fsep $ pwords "Multiple fixity or syntax declarations for"
, vcat $ map f xs
]
where
- f (x, fs) = pretty x <> text ":" <+> fsep (map (text . show) fs)
+ f (x, fs) = pretty x <> text ": " <+> fsep (map pretty fs)
show (MissingDefinition x) = show $ fsep $
pwords "Missing definition for" ++ [pretty x]
show (MissingWithClauses x) = show $ fsep $
@@ -181,7 +216,7 @@ instance Show DeclarationException where
pwords "More than one matching type signature for left hand side" ++ [pretty lhs] ++
pwords "it could belong to any of:" ++ map pretty xs
show (UnknownNamesInFixityDecl xs) = show $ fsep $
- pwords "Names out of scope in fixity declarations:" ++ map pretty xs
+ pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):" ++ map pretty xs
show (UselessPrivate _) = show $ fsep $
pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."
show (UselessAbstract _) = show $ fsep $
@@ -190,24 +225,33 @@ instance Show DeclarationException where
pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms."
show (WrongContentPostulateBlock _) = show $ fsep $
pwords "A postulate block can only contain type signatures or instance blocks"
+ show (PragmaNoTerminationCheck _) = show $ fsep $
+ pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed. To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}."
show (InvalidTerminationCheckPragma _) = show $ fsep $
- pwords "Termination checking pragmas can only preceed a mutual block or a function definition."
+ pwords "Termination checking pragmas can only precede a mutual block or a function definition."
show (InvalidMeasureMutual _) = show $ fsep $
pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma."
show (NotAllowedInMutual nd) = show $ fsep $
[text $ decl nd] ++ pwords "are not allowed in mutual blocks"
where
- decl (Axiom{}) = "Postulates"
- decl (NiceField{}) = "Fields"
- decl (NiceMutual{}) = "Mutual blocks"
- decl (NiceModule{}) = "Modules"
- decl (NiceModuleMacro{}) = "Modules"
- decl (NiceOpen{}) = "Open declarations"
- decl (NiceImport{}) = "Import statements"
- decl (NicePragma{}) = "Pragmas"
- decl (PrimitiveFunction{}) = "Primitive declarations"
- decl (NicePatternSyn{}) = "Pattern synonyms"
- decl _ = __IMPOSSIBLE__
+ decl Axiom{} = "Postulates"
+ decl NiceField{} = "Fields"
+ decl NiceMutual{} = "Mutual blocks"
+ decl NiceModule{} = "Modules"
+ decl NiceModuleMacro{} = "Modules"
+ decl NiceOpen{} = "Open declarations"
+ decl NiceImport{} = "Import statements"
+ decl NicePragma{} = "Pragmas"
+ decl PrimitiveFunction{} = "Primitive declarations"
+ decl NicePatternSyn{} = "Pattern synonyms"
+ decl NiceUnquoteDecl{} = "Unquoted declarations"
+ decl NiceRecSig{} = __IMPOSSIBLE__
+ decl NiceDataSig{} = __IMPOSSIBLE__
+ decl NiceFunClause{} = __IMPOSSIBLE__
+ decl FunSig{} = __IMPOSSIBLE__
+ decl FunDef{} = __IMPOSSIBLE__
+ decl RecDef{} = __IMPOSSIBLE__
+ decl DataDef{} = __IMPOSSIBLE__
show (Codata _) =
"The codata construction has been removed. " ++
"Use the INFINITY builtin instead."
@@ -260,53 +304,85 @@ combineTermChecks r tcs = loop tcs where
let failure r = throwError $ InvalidMeasureMutual r
tc' <- loop tcs
case (tc, tc') of
- (TerminationCheck , _ ) -> return tc'
- (_ , TerminationCheck ) -> return tc
- (NonTerminating , NonTerminating ) -> return tc
- (NoTerminationCheck , NoTerminationCheck ) -> return tc
+ (TerminationCheck , tc' ) -> return tc'
+ (tc , TerminationCheck ) -> return tc
+ (NonTerminating , NonTerminating ) -> return NonTerminating
+ (NoTerminationCheck , NoTerminationCheck ) -> return NoTerminationCheck
+ (NoTerminationCheck , Terminating ) -> return Terminating
+ (Terminating , NoTerminationCheck ) -> return Terminating
+ (Terminating , Terminating ) -> return Terminating
(TerminationMeasure{} , TerminationMeasure{} ) -> return tc
(TerminationMeasure r _, NoTerminationCheck ) -> failure r
+ (TerminationMeasure r _, Terminating ) -> failure r
(NoTerminationCheck , TerminationMeasure r _) -> failure r
+ (Terminating , TerminationMeasure r _) -> failure r
(TerminationMeasure r _, NonTerminating ) -> failure r
(NonTerminating , TerminationMeasure r _) -> failure r
(NoTerminationCheck , NonTerminating ) -> failure r
+ (Terminating , NonTerminating ) -> failure r
(NonTerminating , NoTerminationCheck ) -> failure r
+ (NonTerminating , Terminating ) -> failure r
+
+
+-- | Nicifier monad.
+
+type Nice = StateT NiceEnv (Either DeclarationException)
+
+-- | Nicifier state.
-type LoneSigs = [(DataRecOrFun, Name)]
data NiceEnv = NiceEnv
- { loneSigs :: LoneSigs -- ^ lone type signatures that wait for their definition
- , fixs :: Map Name Fixity'
+ { _loneSigs :: LoneSigs
+ -- ^ Lone type signatures that wait for their definition.
+ , fixs :: Fixities
}
+type LoneSigs = [(DataRecOrFun, Name)]
+type Fixities = Map Name Fixity'
+
+-- | Initial nicifier state.
+
initNiceEnv :: NiceEnv
initNiceEnv = NiceEnv
- { loneSigs = []
+ { _loneSigs = []
, fixs = Map.empty
}
-type Nice = StateT NiceEnv (Either DeclarationException)
+-- * Handling the lone signatures, stored to infer mutual blocks.
+
+-- | Lens for field '_loneSigs'.
+
+loneSigs :: Lens' LoneSigs NiceEnv
+loneSigs f e = f (_loneSigs e) <&> \ s -> e { _loneSigs = s }
+
+-- | Adding a lone signature to the state.
addLoneSig :: DataRecOrFun -> Name -> Nice ()
-addLoneSig k x = modify $ \ niceEnv -> niceEnv { loneSigs = (k, x) : loneSigs niceEnv }
+addLoneSig k x = loneSigs %= ((k, x) :)
+
+-- | Remove a lone signature from the state.
removeLoneSig :: Name -> Nice ()
-removeLoneSig x = modify $ \ niceEnv ->
- niceEnv { loneSigs = filter (\ (k', x') -> x /= x') $ loneSigs niceEnv }
+removeLoneSig x = loneSigs %= filter (\ (k', x') -> x /= x')
+
+-- | Search for forward type signature.
--- | Search for forward type signature that
getSig :: Name -> Nice (Maybe DataRecOrFun)
-getSig n = gets $ fmap fst . List.find (\ (k, x) -> x == n) . loneSigs
+getSig n = fmap fst . List.find (\ (k, x) -> x == n) <$> use loneSigs
+
+-- | Check that no lone signatures are left in the state.
noLoneSigs :: Nice Bool
-noLoneSigs = gets $ null . loneSigs
+noLoneSigs = null <$> use loneSigs
-- | Ensure that all forward declarations have been given a definition.
+
checkLoneSigs :: LoneSigs -> Nice ()
checkLoneSigs xs =
case xs of
[] -> return ()
(_, x):_ -> throwError $ MissingDefinition x
+
getFixity :: Name -> Nice Fixity'
getFixity x = gets $ Map.findWithDefault defaultFixity' x . fixs
@@ -319,6 +395,7 @@ data DeclKind
| OtherDecl
deriving (Eq, Show)
+declKind :: NiceDeclaration -> DeclKind
declKind (FunSig _ _ _ _ _ tc x _) = LoneSig (FunName tc) x
declKind (NiceRecSig _ _ _ x pars _) = LoneSig (RecName $ parameters pars) x
declKind (NiceDataSig _ _ _ x pars _) = LoneSig (DataName $ parameters pars) x
@@ -334,61 +411,54 @@ parameters = List.concat . List.map numP where
numP (DomainFull (TypedBindings _ (Common.Arg i (TBind _ xs _)))) = List.replicate (length xs) $ argInfoHiding i
numP (DomainFull (TypedBindings _ (Common.Arg _ TLet{}))) = []
-{- OLD:
-
--- | Compute number of visible parameters of a data or record signature or definition.
-numberOfPars :: [LamBinding] -> Params
-numberOfPars = List.sum . List.map numP where
- numP (DomainFree NotHidden _ _) = 1
- numP (DomainFull (TypedBindings _ (Arg NotHidden _ (TBind _ xs _)))) = length xs
- numP _ = 0 -- hidden / instance argument
--- | Compute number of parameters of a data or record signature or definition.
-numberOfPars :: [LamBinding] -> Int
-numberOfPars = List.sum . List.map numP where
- numP (DomainFree{}) = 1
- numP (DomainFull (TypedBindings _ arg)) = nP $ unArg arg where
- nP (TBind _ xs _) = length xs
--}
-
+-- | Main.
niceDeclarations :: [Declaration] -> Nice [NiceDeclaration]
niceDeclarations ds = do
+ -- Get fixity and syntax declarations.
fixs <- fixities ds
case Map.keys fixs \\ concatMap declaredNames ds of
- [] -> localState $ do
+ -- If we have fixity/syntax decls for names not declared
+ -- in the current scope, fail.
+ xs@(_:_) -> throwError $ UnknownNamesInFixityDecl xs
+ [] -> localState $ do
+ -- Run the nicifier in an initial environment of fixity decls.
put $ initNiceEnv { fixs = fixs }
ds <- nice ds
- checkLoneSigs =<< gets loneSigs
- modify $ \s -> s { loneSigs = [] }
+ -- Check that every signature got its definition.
+ checkLoneSigs =<< use loneSigs
+ -- Note that loneSigs is ensured to be empty.
+ -- (Important, since inferMutualBlocks also uses loneSigs state).
inferMutualBlocks ds
- xs -> throwError $ UnknownNamesInFixityDecl xs
where
- -- Compute the names defined in a declaration
+ -- Compute the names defined in a declaration.
+ -- We stay in the current scope, i.e., do not go into modules.
declaredNames :: Declaration -> [Name]
declaredNames d = case d of
- TypeSig _ x _ -> [x]
- Field x _ -> [x]
+ TypeSig _ x _ -> [x]
+ Field x _ -> [x]
FunClause (LHS p [] [] []) _ _
- | IdentP (QName x) <- removeSingletonRawAppP p -> [x]
- FunClause{} -> []
- DataSig _ _ x _ _ -> [x]
- Data _ _ x _ _ cs -> x : concatMap declaredNames cs
- RecordSig _ x _ _ -> [x]
- Record _ x _ c _ _ _ -> x : foldMap (:[]) c
- Infix _ _ -> []
- Syntax _ _ -> []
- PatternSyn _ x _ _ -> [x]
- Mutual _ ds -> concatMap declaredNames ds
- Abstract _ ds -> concatMap declaredNames ds
- Private _ ds -> concatMap declaredNames ds
- InstanceB _ ds -> concatMap declaredNames ds
- Postulate _ ds -> concatMap declaredNames ds
- Primitive _ ds -> concatMap declaredNames ds
- Open{} -> []
- Import{} -> []
- ModuleMacro{} -> []
- Module{} -> []
- UnquoteDecl _ x _ -> [x]
- Pragma{} -> []
+ | IdentP (QName x) <- removeSingletonRawAppP p
+ -> [x]
+ FunClause{} -> []
+ DataSig _ _ x _ _ -> [x]
+ Data _ _ x _ _ cs -> x : concatMap declaredNames cs
+ RecordSig _ x _ _ -> [x]
+ Record _ x _ c _ _ _ -> x : foldMap (:[]) c
+ Infix _ _ -> []
+ Syntax _ _ -> []
+ PatternSyn _ x _ _ -> [x]
+ Mutual _ ds -> concatMap declaredNames ds
+ Abstract _ ds -> concatMap declaredNames ds
+ Private _ ds -> concatMap declaredNames ds
+ InstanceB _ ds -> concatMap declaredNames ds
+ Postulate _ ds -> concatMap declaredNames ds
+ Primitive _ ds -> concatMap declaredNames ds
+ Open{} -> []
+ Import{} -> []
+ ModuleMacro{} -> []
+ Module{} -> []
+ UnquoteDecl _ x _ -> [x]
+ Pragma{} -> []
inferMutualBlocks :: [NiceDeclaration] -> Nice [NiceDeclaration]
inferMutualBlocks [] = return []
@@ -416,7 +486,7 @@ niceDeclarations ds = do
done <- noLoneSigs
if done then return (tc, ([], ds)) else
case ds of
- [] -> __IMPOSSIBLE__ <$ (checkLoneSigs =<< gets loneSigs)
+ [] -> __IMPOSSIBLE__ <$ (checkLoneSigs =<< use loneSigs)
d : ds -> case declKind d of
LoneSig k x -> addLoneSig k x >> cons d (untilAllDefined (terminationCheck k : tc) ds)
LoneDef k x -> removeLoneSig x >> cons d (untilAllDefined (terminationCheck k : tc) ds)
@@ -429,6 +499,9 @@ niceDeclarations ds = do
nice :: [Declaration] -> Nice [NiceDeclaration]
nice [] = return []
+ -- Andreas, AIM XX: do not forbid NO_TERMINATION_CHECK in maintenance version.
+ -- nice (Pragma (TerminationCheckPragma r NoTerminationCheck) : _) =
+ -- throwError $ PragmaNoTerminationCheck r
nice (Pragma (TerminationCheckPragma r tc) : ds@(Mutual{} : _)) | notMeasure tc = do
ds <- nice ds
case ds of
@@ -495,8 +568,10 @@ niceDeclarations ds = do
(NiceModuleMacro r PublicAccess x modapp op is :)
<$> nice ds
+ -- Fixity and syntax declarations have been looked at already.
Infix _ _ -> nice ds
Syntax _ _ -> nice ds
+
PatternSyn r n as p -> do
fx <- getFixity n
(NicePatternSyn r fx n as p :) <$> nice ds
@@ -506,21 +581,19 @@ niceDeclarations ds = do
UnquoteDecl r x e -> do
fx <- getFixity x
(NiceUnquoteDecl r fx PublicAccess ConcreteDef TerminationCheck x e :) <$> nice ds
-
+ -- Andreas, AIM XX: do not forbid NO_TERMINATION_CHECK in maintenance version.
+ -- Pragma (TerminationCheckPragma r NoTerminationCheck) ->
+ -- throwError $ PragmaNoTerminationCheck r
Pragma (TerminationCheckPragma r _) ->
throwError $ InvalidTerminationCheckPragma r
Pragma p -> (NicePragma (getRange p) p :) <$> nice ds
niceFunClause :: TerminationCheck -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
niceFunClause termCheck d@(FunClause lhs _ _) ds = do
- xs <- gets $ map snd . filter (isFunName . fst) . loneSigs
+ xs <- map snd . filter (isFunName . fst) <$> use loneSigs
-- for each type signature 'x' waiting for clauses, we try
-- if we have some clauses for 'x'
fixs <- gets fixs
-{- OLD CODE, a bit dense
- case filter (\ (x,(fits,rest)) -> not $ null fits) $
- map (\ x -> (x, span (couldBeFunClauseOf (Map.lookup x fixs) x) $ d : ds)) xs of
--}
case [ (x, (fits, rest))
| x <- xs
, let (fits, rest) =
@@ -678,7 +751,7 @@ niceDeclarations ds = do
-- trace ("xStrings = " ++ show xStrings) $
-- trace ("patStrings = " ++ show patStrings) $
-- trace ("mFixity = " ++ show mFixity) $
- case (mhead pns, mFixity) of
+ case (headMaybe pns, mFixity) of
-- first identifier in the patterns is the fun.symbol?
(Just y, _) | x == y -> True -- trace ("couldBe since y = " ++ show y) $ True
-- are the parts of x contained in p
@@ -798,48 +871,6 @@ niceDeclarations ds = do
mkAbstractWhere (AnyWhere ds) = dirty $ AnyWhere [Abstract noRange ds]
mkAbstractWhere (SomeWhere m ds) = dirty $SomeWhere m [Abstract noRange ds]
-{- OLD CODE
- abstractBlock _ [] = return []
- abstractBlock r ds
- -- hack to avoid failing on inherited abstract blocks in where clauses
- | r == noRange = return $ map mkAbstract ds
- | all uselessAbstract ds = throwError $ UselessAbstract r
- | otherwise = return $ map mkAbstract ds
-
- uselessAbstract d = case d of
- FunDef{} -> False
- DataDef{} -> False
- RecDef{} -> False
- _ -> True
-
- -- Make a declaration abstract
- mkAbstract d =
- case d of
- NiceField r f a _ x e -> NiceField r f a AbstractDef x e
- PrimitiveFunction r f a _ x e -> PrimitiveFunction r f a AbstractDef x e
- NiceMutual r termCheck ds -> NiceMutual r termCheck (map mkAbstract ds)
- FunDef r ds f _ tc x cs -> FunDef r ds f AbstractDef tc x (map mkAbstractClause cs)
- DataDef r f _ x ps cs -> DataDef r f AbstractDef x ps $ map mkAbstract cs
- RecDef r f _ x i c ps cs -> RecDef r f AbstractDef x i c ps $ map mkAbstract cs
- NiceFunClause r a _ termCheck d -> NiceFunClause r a AbstractDef termCheck d
- NiceModule{} -> d
- NiceModuleMacro{} -> d
- Axiom{} -> d
- NicePragma{} -> d
- NiceOpen{} -> d
- NiceImport{} -> d
- FunSig{} -> d
- NiceRecSig{} -> d
- NiceDataSig{} -> d
- NicePatternSyn{} -> d
-
- mkAbstractClause (Clause x lhs rhs wh with) =
- Clause x lhs rhs (mkAbstractWhere wh) (map mkAbstractClause with)
-
- mkAbstractWhere NoWhere = NoWhere
- mkAbstractWhere (AnyWhere ds) = AnyWhere [Abstract noRange ds]
- mkAbstractWhere (SomeWhere m ds) = SomeWhere m [Abstract noRange ds]
--}
privateBlock _ [] = return []
privateBlock r ds = do
let (ds', anyChange) = runChange $ mapM mkPrivate ds
@@ -865,18 +896,6 @@ niceDeclarations ds = do
NiceDataSig r f p x ls t -> (\ p -> NiceDataSig r f p x ls t) <$> setPrivate p
NiceFunClause r p a termCheck d -> (\ p -> NiceFunClause r p a termCheck d) <$> setPrivate p
NiceUnquoteDecl r f p a t x e -> (\ p -> NiceUnquoteDecl r f p a t x e) <$> setPrivate p
-{-
- Axiom r f _ rel x e -> dirty $ Axiom r f PrivateAccess rel x e
- NiceField r f _ a x e -> dirty $ NiceField r f PrivateAccess a x e
- PrimitiveFunction r f _ a x e -> dirty $ PrimitiveFunction r f PrivateAccess a x e
- NiceMutual r termCheck ds -> NiceMutual r termCheck <$> mapM mkPrivate ds
- NiceModule r _ a x tel ds -> dirty $ NiceModule r PrivateAccess a x tel ds
- NiceModuleMacro r _ x ma op is -> dirty $ NiceModuleMacro r PrivateAccess x ma op is
- FunSig r f _ rel tc x e -> dirty $ FunSig r f PrivateAccess rel tc x e
- NiceRecSig r f _ x ls t -> dirty $ NiceRecSig r f PrivateAccess x ls t
- NiceDataSig r f _ x ls t -> dirty $ NiceDataSig r f PrivateAccess x ls t
- NiceFunClause r _ a termCheck d -> dirty $ NiceFunClause r PrivateAccess a termCheck d
--}
NicePragma _ _ -> return $ d
NiceOpen _ _ _ -> return $ d
NiceImport _ _ _ _ _ -> return $ d
@@ -902,49 +921,6 @@ niceDeclarations ds = do
mkPrivateWhere (AnyWhere ds) = dirty $ AnyWhere [Private (getRange ds) ds]
mkPrivateWhere (SomeWhere m ds) = dirty $ SomeWhere m [Private (getRange ds) ds]
-{- OLD CODE, with two functions (uselessPrivate, mkPrivate) to be maintained in sync.
-
- privateBlock _ [] = return []
- privateBlock r ds
- | all uselessPrivate ds = throwError $ UselessPrivate r
- | otherwise = return $ map mkPrivate ds
-
- uselessPrivate d = case d of
- FunDef{} -> True
- DataDef{} -> True
- RecDef{} -> True
- _ -> False
-
- -- Make a declaration private
- mkPrivate d =
- case d of
- Axiom r f _ rel x e -> Axiom r f PrivateAccess rel x e
- NiceField r f _ a x e -> NiceField r f PrivateAccess a x e
- PrimitiveFunction r f _ a x e -> PrimitiveFunction r f PrivateAccess a x e
- NiceMutual r termCheck ds -> NiceMutual r termCheck (map mkPrivate ds)
- NiceModule r _ a x tel ds -> NiceModule r PrivateAccess a x tel ds
- NiceModuleMacro r _ x ma op is -> NiceModuleMacro r PrivateAccess x ma op is
- FunSig r f _ rel tc x e -> FunSig r f PrivateAccess rel tc x e
- NiceRecSig r f _ x ls t -> NiceRecSig r f PrivateAccess x ls t
- NiceDataSig r f _ x ls t -> NiceDataSig r f PrivateAccess x ls t
- NiceFunClause r _ a termCheck d -> NiceFunClause r PrivateAccess a termCheck d
- NiceUnquoteDecl r fx _ a term x d -> NiceUnquoteDecl r fx PrivateAccess a term x d
- NicePragma _ _ -> d
- NiceOpen _ _ _ -> d
- NiceImport _ _ _ _ _ -> d
- FunDef{} -> d
- DataDef{} -> d
- RecDef{} -> d
- NicePatternSyn _ _ _ _ _ -> d
-
- mkPrivateClause (Clause x lhs rhs wh with) =
- Clause x lhs rhs (mkPrivateWhere wh) (map mkPrivateClause with)
-
- mkPrivateWhere NoWhere = NoWhere
- mkPrivateWhere (AnyWhere ds) = AnyWhere [Private (getRange ds) ds]
- mkPrivateWhere (SomeWhere m ds) = SomeWhere m [Private (getRange ds) ds]
--}
-
instanceBlock _ [] = return []
instanceBlock r ds = do
let (ds', anyChange) = runChange $ mapM mkInstance ds
@@ -980,42 +956,83 @@ niceDeclarations ds = do
_ -> dirty $ InstanceDef
-- | Add more fixities. Throw an exception for multiple fixity declarations.
-plusFixities :: Map.Map Name Fixity' -> Map.Map Name Fixity' -> Nice (Map.Map Name Fixity')
+-- OR: Disjoint union of fixity maps. Throws exception if not disjoint.
+
+plusFixities :: Fixities -> Fixities -> Nice Fixities
plusFixities m1 m2
+ -- If maps are not disjoint, report conflicts as exception.
| not (null isect) = throwError $ MultipleFixityDecls isect
- | otherwise = return $ Map.unionWithKey mergeFixites m1 m2
- where mergeFixites name (Fixity' f1 s1) (Fixity' f2 s2) = Fixity' f s
+ -- Otherwise, do the union.
+ | otherwise = return $ Map.unionWithKey mergeFixites m1 m2
+ where
+ -- Merge two fixities, assuming there is no conflict
+ mergeFixites name (Fixity' f1 s1) (Fixity' f2 s2) = Fixity' f s
where f | f1 == noFixity = f2
| f2 == noFixity = f1
| otherwise = __IMPOSSIBLE__
s | s1 == noNotation = s2
| s2 == noNotation = s1
| otherwise = __IMPOSSIBLE__
- isect = [decls x | (x,compat) <- Map.assocs (Map.intersectionWith compatible m1 m2), not compat]
-
- decls x = (x, map (Map.findWithDefault __IMPOSSIBLE__ x) [m1,m2])
- -- cpp doesn't know about primes
- compatible (Fixity' f1 s1) (Fixity' f2 s2) = (f1 == noFixity || f2 == noFixity) &&
- (s1 == noNotation || s2 == noNotation)
--- | Get the fixities from the current block. Doesn't go inside /any/ blocks.
+ -- Compute a list of conflicts in a format suitable for error reporting.
+ isect = [ (x, map (Map.findWithDefault __IMPOSSIBLE__ x) [m1,m2])
+ | (x, False) <- Map.assocs $ Map.intersectionWith compatible m1 m2 ]
+
+ -- Check for no conflict.
+ compatible (Fixity' f1 s1) (Fixity' f2 s2) = (f1 == noFixity || f2 == noFixity) &&
+ (s1 == noNotation || s2 == noNotation)
+
+-- | While 'Fixities' is not a monoid under disjoint union (which might fail),
+-- we get the monoid instance for the monadic @Nice Fixities@ which propagates
+-- the first error.
+instance Monoid (Nice Fixities) where
+ mempty = return $ Map.empty
+ mappend c1 c2 = do
+ m1 <- c1
+ m2 <- c2
+ plusFixities m1 m2
+
+-- | Get the fixities from the current block.
+-- Doesn't go inside modules and where blocks.
-- The reason for this is that fixity declarations have to appear at the same
-- level (or possibly outside an abstract or mutual block) as its target
-- declaration.
-fixities :: [Declaration] -> Nice (Map.Map Name Fixity')
-fixities (d:ds) = case d of
- Syntax x syn -> plusFixities (Map.singleton x (Fixity' noFixity syn)) =<< fixities ds
- Infix f xs -> plusFixities (Map.fromList [ (x,Fixity' f noNotation) | x <- xs ]) =<< fixities ds
- Mutual _ ds' -> fixities (ds' ++ ds)
- Abstract _ ds' -> fixities (ds' ++ ds)
- Private _ ds' -> fixities (ds' ++ ds)
- _ -> fixities ds
-fixities [] = return $ Map.empty
+fixities :: [Declaration] -> Nice Fixities
+fixities = foldMap $ \ d -> case d of
+ -- These declarations define fixities:
+ Syntax x syn -> return $ Map.singleton x $ Fixity' noFixity syn
+ Infix f xs -> return $ Map.fromList $ map (,Fixity' f noNotation) xs
+ -- We look into these blocks:
+ Mutual _ ds' -> fixities ds'
+ Abstract _ ds' -> fixities ds'
+ Private _ ds' -> fixities ds'
+ InstanceB _ ds' -> fixities ds'
+ -- All other declarations are ignored.
+ -- We expand these boring cases to trigger a revisit
+ -- in case the @Declaration@ type is extended in the future.
+ TypeSig {} -> mempty
+ Field {} -> mempty
+ FunClause {} -> mempty
+ DataSig {} -> mempty
+ Data {} -> mempty
+ RecordSig {} -> mempty
+ Record {} -> mempty
+ PatternSyn {} -> mempty
+ Postulate {} -> mempty
+ Primitive {} -> mempty
+ Open {} -> mempty
+ Import {} -> mempty
+ ModuleMacro {} -> mempty
+ Module {} -> mempty
+ UnquoteDecl {} -> mempty
+ Pragma {} -> mempty
-- Andreas, 2012-04-07
-- The following function is only used twice, for building a Let, and for
-- printing an error message.
+
+-- | (Approximately) convert a 'NiceDeclaration' back to a 'Declaration'.
notSoNiceDeclaration :: NiceDeclaration -> Declaration
notSoNiceDeclaration d =
case d of
@@ -1040,28 +1057,3 @@ notSoNiceDeclaration d =
NicePatternSyn r _ n as p -> PatternSyn r n as p
NiceUnquoteDecl r _ _ _ _ x e -> UnquoteDecl r x e
-{-
--- Andreas, 2012-03-08 the following function is only used twice,
--- both just on a single declaration.
-notSoNiceDeclarations :: [NiceDeclaration] -> [Declaration]
-notSoNiceDeclarations = concatMap notNice
- where
- notNice d = case d of
- Axiom _ _ _ rel x e -> [TypeSig rel x e]
- NiceField _ _ _ _ x argt -> [Field x argt]
- PrimitiveFunction r _ _ _ x e -> [Primitive r [TypeSig Relevant x e]]
- NiceMutual _ _ ds -> concatMap notNice ds
- NiceModule r _ _ x tel ds -> [Module r x tel ds]
- NiceModuleMacro r _ x ma o dir -> [ModuleMacro r x ma o dir]
- NiceOpen r x dir -> [Open r x dir]
- NiceImport r x as o dir -> [Import r x as o dir]
- NicePragma _ p -> [Pragma p]
- NiceRecSig r _ _ x bs e -> [RecordSig r x bs e]
- NiceDataSig r _ _ x bs e -> [DataSig r Inductive x bs e]
- FunSig _ _ _ rel tc x e -> [TypeSig rel x e]
- FunDef _ ds _ _ _ _ _ -> ds
- DataDef r _ _ x bs cs -> [Data r Inductive x bs Nothing $ concatMap notNice cs]
- RecDef r _ _ x c bs ds -> [Record r x (unThing <$> c) bs Nothing $ concatMap notNice ds]
- where unThing (ThingWithFixity c _) = c
- NicePatternSyn r _ n as p -> [PatternSyn r n as p]
--}
diff --git a/src/full/Agda/Syntax/Concrete/Generic.hs b/src/full/Agda/Syntax/Concrete/Generic.hs
index 3717d42..f499b2b 100644
--- a/src/full/Agda/Syntax/Concrete/Generic.hs
+++ b/src/full/Agda/Syntax/Concrete/Generic.hs
@@ -1,12 +1,12 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
-- | Generic traversal and reduce for concrete syntax,
-- in the style of 'Agda.Syntax.Internal.Generic'.
--
-- However, here we use the terminology of 'Data.Traversable'.
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
module Agda.Syntax.Concrete.Generic where
import Control.Applicative
@@ -18,7 +18,7 @@ import Data.Foldable
import Agda.Syntax.Common hiding (Arg)
import Agda.Syntax.Concrete
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Generic traversals for concrete expressions.
diff --git a/src/full/Agda/Syntax/Concrete/Name.hs b/src/full/Agda/Syntax/Concrete/Name.hs
index 06ba292..437b592 100644
--- a/src/full/Agda/Syntax/Concrete/Name.hs
+++ b/src/full/Agda/Syntax/Concrete/Name.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-| Names in the concrete syntax are just strings (or lists of strings for
@@ -26,7 +26,7 @@ import Agda.Syntax.Position
import Agda.Utils.FileName
import Agda.Utils.Pretty
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{-| A name is a non-empty list of alternating 'Id's and 'Hole's. A normal name
@@ -69,7 +69,7 @@ data NamePart
instance Eq Name where
Name _ xs == Name _ ys = xs == ys
NoName _ i == NoName _ j = i == j
- _ == _ = False
+ _ == _ = False
instance Ord Name where
compare (Name _ xs) (Name _ ys) = compare xs ys
@@ -156,8 +156,8 @@ isNonfix x = not (isHole (head xs)) && not (isHole (last xs)) where xs = namePa
-- | @qualify A.B x == A.B.x@
qualify :: QName -> Name -> QName
-qualify (QName m) x = Qual m (QName x)
-qualify (Qual m m') x = Qual m $ qualify m' x
+qualify (QName m) x = Qual m (QName x)
+qualify (Qual m m') x = Qual m $ qualify m' x
-- | @unqualify A.B.x == x@
--
@@ -241,9 +241,13 @@ instance IsNoName QName where
-- no instance for TopLevelModuleName
------------------------------------------------------------------------
--- * Printing names
+-- * Showing names
------------------------------------------------------------------------
+-- TODO: 'Show' should output Haskell-parseable representations.
+-- The following instances are deprecated, and Pretty should be used
+-- instead. Later, simply derive Show for these types:
+
instance Show Name where
show (Name _ xs) = concatMap show xs
show (NoName _ _) = "_"
@@ -256,6 +260,22 @@ instance Show QName where
show (Qual m x) = show m ++ "." ++ show x
show (QName x) = show x
+------------------------------------------------------------------------
+-- * Printing names
+------------------------------------------------------------------------
+
+instance Pretty Name where
+ pretty (Name _ xs) = hcat $ map pretty xs
+ pretty (NoName _ _) = text $ "_"
+
+instance Pretty NamePart where
+ pretty Hole = text $ "_"
+ pretty (Id s) = text $ rawNameToString s
+
+instance Pretty QName where
+ pretty (Qual m x) = pretty m <> pretty "." <> pretty x
+ pretty (QName x) = pretty x
+
instance Pretty TopLevelModuleName where
pretty (TopLevelModuleName ms) = text $ intercalate "." ms
@@ -279,7 +299,7 @@ instance HasRange Name where
instance HasRange QName where
getRange (QName x) = getRange x
- getRange (Qual n x) = fuseRange n x
+ getRange (Qual n x) = fuseRange n x
instance SetRange Name where
setRange r (Name _ ps) = Name r ps
diff --git a/src/full/Agda/Syntax/Concrete/Operators.hs b/src/full/Agda/Syntax/Concrete/Operators.hs
index 586b425..2fa1546 100644
--- a/src/full/Agda/Syntax/Concrete/Operators.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-| The parser doesn't know about operators and parses everything as normal
@@ -15,18 +15,6 @@ module Agda.Syntax.Concrete.Operators
, parseLHS
, parsePattern
, parsePatternSyn
- , paren
- , mparen
- -- exports for Copatterns
- , validConPattern
- , patternAppView
- , fullParen
- , buildParsers, buildParser
- , parsePat
- , getDefinedNames
- , UseBoundNames(..)
- , qualifierModules
- , patternQNames
) where
import Control.DeepSeq
@@ -36,12 +24,13 @@ import Control.Monad
import Data.Either (partitionEithers)
import Data.Function
import Data.List
-import Data.Traversable (traverse)
-import qualified Data.Traversable as Trav
+import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
+import Data.Traversable (traverse)
+import qualified Data.Traversable as Trav
import Agda.Syntax.Concrete.Pretty ()
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
@@ -65,7 +54,7 @@ import Agda.Utils.Either
import Agda.Utils.ReadP
import Agda.Utils.List
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -87,15 +76,18 @@ partsInScope flat = do
where
first:iparts = [ i | i@(Id {}) <- xs ]
-type FlatScope = Map.Map QName [AbstractName]
+type FlatScope = Map QName [AbstractName]
-- | Compute all unqualified defined names in scope and their fixities.
+-- Note that overloaded names (constructors) can have several fixities.
+-- Then we 'chooseFixity'. (See issue 1194.)
getDefinedNames :: [KindOfName] -> FlatScope -> [(QName, Fixity')]
getDefinedNames kinds names =
- [ (x, A.nameFixity $ A.qnameName $ anameName d)
+ [ (x, chooseFixity fixs)
| (x, ds) <- Map.toList names
- , d <- take 1 ds
- , any (\ d -> anameKind d `elem` kinds) ds
+ , any ((`elem` kinds) . anameKind) ds
+ , let fixs = map (A.nameFixity . A.qnameName . anameName) ds
+ , not (null fixs)
-- 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,
@@ -107,25 +99,38 @@ getDefinedNames kinds names =
localNames :: FlatScope -> ScopeM ([QName], [NewNotation])
localNames flat = do
let defs = getDefinedNames allKindsOfNames flat
- locals <- scopeLocals <$> getScope
- return $ split $ uniqBy fst $ map localOp locals ++ defs
+ locals <- notShadowedLocals <$> getLocalVars
+ -- Note: Debug printout aligned with the one in buildParsers.
+ reportSLn "scope.operators" 50 $ unlines
+ [ "flat = " ++ show flat
+ , "defs = " ++ show defs
+ , "locals= " ++ show locals
+ ]
+ return $ split $ uniqOn fst $ map localOp locals ++ defs
where
localOp (x, y) = (QName x, A.nameFixity y)
split ops = partitionEithers $ concatMap opOrNot ops
- opOrNot (q, Fixity' fx syn) = Left q
- : case unqualify q of
- Name _ [_] -> []
- x -> [Right (q, fx, syntaxOf x)]
- ++ case syn of
- [] -> []
- _ -> [Right (q, fx, syn)]
-
-data UseBoundNames = UseBoundNames | DontUseBoundNames
-
-
+ opOrNot (q, Fixity' fx syn) = Left q : map Right (notaFromName ++ nota)
+ where
+ notaFromName = case unqualify q of
+ Name _ [_] -> []
+ x -> [NewNotation q fx $ syntaxOf x]
+ nota = if null syn then [] else [NewNotation q fx syn]
+-- | Data structure filled in by @buildParsers at .
+-- The top-level parser @pTop@ is of primary interest,
+-- but @pArgs@ is used to convert module application
+-- from concrete to abstract syntax.
+data Parsers e = Parsers
+ { pTop :: ReadP e e
+ , pApp :: ReadP e e
+ , pArgs :: ReadP e [NamedArg e]
+ , pNonfix :: ReadP e e
+ , pAtom :: ReadP e e
+ }
+data UseBoundNames = UseBoundNames | DontUseBoundNames
{-| Builds parser for operator applications from all the operators and function
symbols in scope. When parsing a pattern we use 'DontUseBoundNames'.
@@ -153,46 +158,7 @@ data UseBoundNames = UseBoundNames | DontUseBoundNames
different associativity the parser won't complain. One could argue that
this is a Bad Thing, but since it's not trivial to implement the check it
will stay this way until people start complaining about it.
-
-}
-
-data NotationStyle = InfixS | Prefix | Postfix | Nonfix | None
- deriving (Eq)
-
-fixStyle :: Notation -> NotationStyle
-fixStyle [] = None
-fixStyle syn = case (isAHole (head syn), isAHole (last syn)) of
- (True,True) -> InfixS
- (True,False) -> Postfix
- (False,True) -> Prefix
- (False,False) -> Nonfix
-
-
-notationNames :: NewNotation -> [QName]
-notationNames (q, _, ps) = zipWith ($) (requal : repeat QName) [Name noRange [Id x] | IdPart x <- ps ]
- where
- ms = init (qnameParts q)
- requal x = foldr Qual (QName x) ms
-
--- | Data structure filled in by @buildParsers at .
--- The top-level parser @pTop@ is of primary interest,
--- but @pArgs@ is used to convert module application
--- from concrete to abstract syntax.
-data Parsers e = Parsers
- { pTop :: ReadP e e -- this was returned by @buildParser@
- , pApp :: ReadP e e
- , pArgs :: ReadP e [NamedArg e]
- , pNonfix :: ReadP e e
- , pAtom :: ReadP e e
- }
-
--- | For backwards compatibility.
--- Returns the @pTop@ from @buildParsers at .
-buildParser :: forall e. IsExpr e => Range -> FlatScope -> UseBoundNames -> ScopeM (ReadP e e)
-buildParser r flat use = do
- p <- buildParsers r flat use
- return $ pTop p
-
buildParsers :: forall e. IsExpr e => Range -> FlatScope -> UseBoundNames -> ScopeM (Parsers e)
buildParsers r flat use = do
(names, ops) <- localNames flat
@@ -224,24 +190,25 @@ buildParsers r flat use = do
}
where
level :: NewNotation -> Integer
- level (_name, fixity, _syn) = fixityLevel fixity
+ level = fixityLevel . notaFixity
isinfixl, isinfixr, isinfix, nonfix, isprefix, ispostfix :: NewNotation -> Bool
- isinfixl (_, LeftAssoc _ _, syn) = isInfix syn
- isinfixl _ = False
+ isinfixl (NewNotation _ (LeftAssoc _ _) syn) = isInfix syn
+ isinfixl _ = False
- isinfixr (_, RightAssoc _ _, syn) = isInfix syn
- isinfixr _ = False
+ isinfixr (NewNotation _ (RightAssoc _ _) syn) = isInfix syn
+ isinfixr _ = False
- isinfix (_, NonAssoc _ _,syn) = isInfix syn
- isinfix _ = False
+ isinfix (NewNotation _ (NonAssoc _ _) syn) = isInfix syn
+ isinfix _ = False
+
+ nonfix (NewNotation _ _ syn) = notationKind syn == NonfixNotation
+ isprefix (NewNotation _ _ syn) = notationKind syn == PrefixNotation
+ ispostfix (NewNotation _ _ syn) = notationKind syn == PostfixNotation
- nonfix (_,_,syn) = fixStyle syn == Nonfix
- isprefix (_,_,syn) = fixStyle syn == Prefix
- ispostfix (_,_,syn) = fixStyle syn == Postfix
isInfix :: Notation -> Bool
- isInfix syn = fixStyle syn == InfixS
+ isInfix syn = notationKind syn == InfixNotation
-- | Group operators by precedence level
order :: [NewNotation] -> [[NewNotation]]
@@ -656,43 +623,3 @@ fullParen' e = case exprView e of
LamV bs e -> par $ unExprView $ LamV bs (fullParen e)
where
par = unExprView . ParenV
-
-paren :: Monad m => (QName -> m Fixity) -> Expr -> m (Precedence -> Expr)
-paren _ e@(App _ _ _) = return $ \p -> mparen (appBrackets p) e
-paren f e@(OpApp _ op _) = do fx <- f op; return $ \p -> mparen (opBrackets fx p) e
-paren _ e@(Lam _ _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(AbsurdLam _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(ExtendedLam _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(Fun _ _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(Pi _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(Let _ _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(Rec _ _) = return $ \p -> mparen (appBrackets p) e
-paren _ e@(RecUpdate _ _ _) = return $ \p -> mparen (appBrackets p) e
-paren _ e@(WithApp _ _ _) = return $ \p -> mparen (withAppBrackets p) e
-paren _ e at Tactic{} = return $ \p -> mparen (withAppBrackets p) e
-paren _ e@(Ident _) = return $ \p -> e
-paren _ e@(Lit _) = return $ \p -> e
-paren _ e@(QuestionMark _ _) = return $ \p -> e
-paren _ e@(Underscore _ _) = return $ \p -> e
-paren _ e@(Set _) = return $ \p -> e
-paren _ e@(SetN _ _) = return $ \p -> e
-paren _ e@(Prop _) = return $ \p -> e
-paren _ e@(Paren _ _) = return $ \p -> e
-paren _ e@(As _ _ _) = return $ \p -> e
-paren _ e@(Dot _ _) = return $ \p -> e
-paren _ e@(Absurd _) = return $ \p -> e
-paren _ e@(ETel _) = return $ \p -> e
-paren _ e@(RawApp _ _) = __IMPOSSIBLE__
-paren _ e@(HiddenArg _ _) = __IMPOSSIBLE__
-paren _ e@(InstanceArg _ _) = __IMPOSSIBLE__
-paren _ e@(QuoteGoal _ _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(QuoteContext _ _ _) = return $ \p -> mparen (lamBrackets p) e
-paren _ e@(Quote _) = return $ \p -> e
-paren _ e@(QuoteTerm _) = return $ \p -> e
-paren _ e@(Unquote _) = return $ \p -> e
-paren _ e@(DontCare _) = return $ \p -> e
-paren _ e@(Equal _ _ _) = __IMPOSSIBLE__
-
-mparen :: Bool -> Expr -> Expr
-mparen True e = Paren (getRange e) e
-mparen False e = e
diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
index a924ff5..b8e5a55 100644
--- a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Syntax.Concrete.Operators.Parser where
@@ -16,7 +16,7 @@ import Agda.TypeChecking.Monad.Base (TCErr(Exception))
import Agda.Utils.ReadP
import Agda.Utils.Monad
-#include "../../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
data ExprView e
@@ -54,9 +54,9 @@ partP ms s = do
Nothing -> pfail
where
str = show (foldr Qual (QName (Name noRange [Id s])) ms)
- isLocal e = case exprView e of
- LocalV y | str == show y -> Just (getRange y)
- _ -> Nothing
+ isLocal e = case exprView e of
+ LocalV y | str == show y -> Just (getRange y)
+ _ -> Nothing
binop :: IsExpr e => ReadP e (NewNotation,Range,[e]) -> ReadP e (e -> e -> e)
binop middleP = do
@@ -80,14 +80,14 @@ postop middleP = do
-- place as where the holes are discarded, however that would require a dependently
-- typed function (or duplicated code)
opP :: IsExpr e => ReadP e e -> NewNotation -> ReadP e (NewNotation,Range,[e])
-opP p nsyn@(q,_,syn) = do
+opP p nsyn@(NewNotation q _ syn) = do
(range,es) <- worker (init $ qnameParts q) $ removeExternalHoles syn
return (nsyn,range,es)
where worker ms [IdPart x] = do r <- partP ms x; return (r,[])
worker ms (IdPart x : _ : xs) = do
r1 <- partP ms x
- e <- p
- (r2 , es) <- worker [] xs -- only the first part is qualified
+ e <- p
+ (r2 , es) <- worker [] xs -- only the first part is qualified
return (fuseRanges r1 r2, e : es)
worker _ x = __IMPOSSIBLE__ -- holes and non-holes must be alternated.
@@ -97,7 +97,7 @@ opP p nsyn@(q,_,syn) = do
-- | Given a name with a syntax spec, and a list of parsed expressions
-- fitting it, rebuild the expression.
rebuild :: forall e. IsExpr e => NewNotation -> Range -> [e] -> e
-rebuild (name,_,syn) r es = unExprView $ OpAppV (setRange r name) exprs
+rebuild (NewNotation name _ syn) r es = unExprView $ OpAppV (setRange r name) exprs
where
exprs = map findExprFor [0..lastHole]
filledHoles = zip es (filter isAHole syn)
@@ -140,9 +140,9 @@ infixP op p = do
e <- p
restP e
where
- restP x = return x +++ do
- f <- binop op
- f x <$> p
+ restP x = return x +++ do
+ f <- binop op
+ f x <$> p
nonfixP op p = do
(nsyn,r,es) <- op
@@ -152,26 +152,26 @@ nonfixP op p = do
argsP :: IsExpr e => ReadP e e -> ReadP e [NamedArg e]
argsP p = many (nothidden +++ hidden +++ instanceH)
where
- isHidden (HiddenArgV _) = True
- isHidden _ = False
+ isHidden (HiddenArgV _) = True
+ isHidden _ = False
- isInstance (InstanceArgV _) = True
- isInstance _ = False
+ isInstance (InstanceArgV _) = True
+ isInstance _ = False
- nothidden = defaultArg . unnamed <$> do
- e <- p
- case exprView e of
- HiddenArgV _ -> pfail
- InstanceArgV _ -> pfail
- _ -> return e
+ nothidden = defaultArg . unnamed <$> do
+ e <- p
+ case exprView e of
+ HiddenArgV _ -> pfail
+ InstanceArgV _ -> pfail
+ _ -> return e
- instanceH = do
- InstanceArgV e <- exprView <$> satisfy (isInstance . exprView)
- return $ makeInstance $ defaultArg e
+ instanceH = do
+ InstanceArgV e <- exprView <$> satisfy (isInstance . exprView)
+ return $ makeInstance $ defaultArg e
- hidden = do
- HiddenArgV e <- exprView <$> satisfy (isHidden . exprView)
- return $ hide $ defaultArg e
+ hidden = do
+ HiddenArgV e <- exprView <$> satisfy (isHidden . exprView)
+ return $ hide $ defaultArg e
appP :: IsExpr e => ReadP e e -> ReadP e [NamedArg e] -> ReadP e e
appP p pa = do
@@ -179,11 +179,11 @@ appP p pa = do
es <- pa
return $ foldl app h es
where
- app e = unExprView . AppV e
+ app e = unExprView . AppV e
atomP :: IsExpr e => (QName -> Bool) -> ReadP e e
atomP p = do
e <- get
case exprView e of
- LocalV x | not (p x) -> pfail
- _ -> return e
+ LocalV x | not (p x) -> pfail
+ _ -> return e
diff --git a/src/full/Agda/Syntax/Concrete/Pretty.hs b/src/full/Agda/Syntax/Concrete/Pretty.hs
index 1a306f0..c2fe806 100644
--- a/src/full/Agda/Syntax/Concrete/Pretty.hs
+++ b/src/full/Agda/Syntax/Concrete/Pretty.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
-{-# OPTIONS -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-| Pretty printer for the concrete syntax.
-}
@@ -14,27 +14,29 @@ import Data.Maybe
import qualified Agda.Syntax.Common as Common
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo)
-import Agda.Syntax.Position
import Agda.Syntax.Concrete
import Agda.Syntax.Fixity
import Agda.Syntax.Literal
+import Agda.Syntax.Notation
+import Agda.Syntax.Position
import Agda.Utils.Pretty
import Agda.Utils.String
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-instance Show Expr where show = show . pretty
+instance Show Expr where show = show . pretty
instance Show Declaration where show = show . pretty
-instance Show Pattern where show = show . pretty
+instance Show Pattern where show = show . pretty
instance Show TypedBinding where show = show . pretty
instance Show TypedBindings where show = show . pretty
instance Show LamBinding where show = show . pretty
instance Show ImportDirective where show = show . pretty
-instance Show Pragma where show = show . pretty
-instance Show RHS where show = show . pretty
+instance Show Pragma where show = show . pretty
+instance Show RHS where show = show . pretty
+braces' :: Doc -> Doc
braces' d = case render d of
-- Add space to avoid starting a comment
'-':_ -> braces (text " " <> d)
@@ -58,6 +60,7 @@ bracesAndSemicolons [] = text "{}"
bracesAndSemicolons (d : ds) =
sep ([text "{" <+> d] ++ map (text ";" <+>) ds ++ [text "}"])
+arrow, lambda :: Doc
arrow = text "\x2192"
lambda = text "\x03bb"
@@ -90,12 +93,6 @@ instance (Pretty a, Pretty b) => Pretty (a, b) where
instance Pretty (ThingWithFixity Name) where
pretty (ThingWithFixity n _) = pretty n
-instance Pretty Name where
- pretty = text . show
-
-instance Pretty QName where
- pretty = text . show
-
instance Pretty Relevance where
pretty Forced = empty
pretty UnusedArg = empty
@@ -113,62 +110,62 @@ instance Pretty (OpApp Expr) where
instance Pretty Expr where
pretty e =
- case e of
- Ident x -> pretty x
- Lit l -> pretty l
- QuestionMark _ n -> text "?" <> maybe empty (text . show) n
- Underscore _ n -> maybe underscore text n
--- Underscore _ n -> underscore <> maybe empty (text . show) n
- App _ _ _ ->
- case appView e of
- AppView e1 args ->
- fsep $ pretty e1 : map pretty args
--- sep [ pretty e1
--- , nest 2 $ fsep $ map pretty args
--- ]
- RawApp _ es -> fsep $ map pretty es
- OpApp _ q es -> fsep $ prettyOpApp q es
-
- WithApp _ e es -> fsep $
- pretty e : map ((text "|" <+>) . pretty) es
-
- HiddenArg _ e -> braces' $ pretty e
- InstanceArg _ e -> dbraces $ pretty e
- Lam _ bs e ->
- sep [ lambda <+> fsep (map pretty bs) <+> arrow
- , nest 2 $ pretty e
- ]
+ case e of
+ Ident x -> pretty x
+ Lit l -> pretty l
+ QuestionMark _ n -> text "?" <> maybe empty (text . show) n
+ Underscore _ n -> maybe underscore text n
+-- Underscore _ n -> underscore <> maybe empty (text . show) n
+ App _ _ _ ->
+ case appView e of
+ AppView e1 args ->
+ fsep $ pretty e1 : map pretty args
+-- sep [ pretty e1
+-- , nest 2 $ fsep $ map pretty args
+-- ]
+ RawApp _ es -> fsep $ map pretty es
+ OpApp _ q es -> fsep $ prettyOpApp q es
+
+ WithApp _ e es -> fsep $
+ pretty e : map ((text "|" <+>) . pretty) es
+
+ HiddenArg _ e -> braces' $ pretty e
+ InstanceArg _ e -> dbraces $ pretty e
+ Lam _ bs e ->
+ sep [ lambda <+> fsep (map pretty bs) <+> arrow
+ , nest 2 $ pretty e
+ ]
AbsurdLam _ NotHidden -> lambda <+> text "()"
AbsurdLam _ Instance -> lambda <+> text "{{}}"
AbsurdLam _ Hidden -> lambda <+> text "{}"
- ExtendedLam _ pes ->
+ ExtendedLam _ pes ->
lambda <+> bracesAndSemicolons (map (\(x,y,z) -> prettyClause x y z) pes)
where prettyClause lhs rhs wh = sep [ pretty lhs
, nest 2 $ pretty' rhs
] $$ nest 2 (pretty wh)
pretty' (RHS e) = arrow <+> pretty e
pretty' AbsurdRHS = empty
- Fun _ e1 e2 ->
- sep [ pretty e1 <+> arrow
- , pretty e2
- ]
- Pi tel e ->
- sep [ pretty (Tel $ smashTel tel) <+> arrow
- , pretty e
- ]
- Set _ -> text "Set"
- Prop _ -> text "Prop"
- SetN _ n -> text "Set" <> text (showIndex n)
- Let _ ds e ->
- sep [ text "let" <+> vcat (map pretty ds)
- , text "in" <+> pretty e
- ]
- Paren _ e -> parens $ pretty e
- As _ x e -> pretty x <> text "@" <> pretty e
- Dot _ e -> text "." <> pretty e
- Absurd _ -> text "()"
- Rec _ xs -> sep [text "record", bracesAndSemicolons (map recPr xs)]
- RecUpdate _ e xs ->
+ Fun _ e1 e2 ->
+ sep [ pretty e1 <+> arrow
+ , pretty e2
+ ]
+ Pi tel e ->
+ sep [ pretty (Tel $ smashTel tel) <+> arrow
+ , pretty e
+ ]
+ Set _ -> text "Set"
+ Prop _ -> text "Prop"
+ SetN _ n -> text "Set" <> text (showIndex n)
+ Let _ ds e ->
+ sep [ text "let" <+> vcat (map pretty ds)
+ , text "in" <+> pretty e
+ ]
+ Paren _ e -> parens $ pretty e
+ As _ x e -> pretty x <> text "@" <> pretty e
+ Dot _ e -> text "." <> pretty e
+ Absurd _ -> text "()"
+ Rec _ xs -> sep [text "record", bracesAndSemicolons (map recPr xs)]
+ RecUpdate _ e xs ->
sep [text "record" <+> pretty e, bracesAndSemicolons (map recPr xs)]
ETel [] -> text "()"
ETel tel -> fsep $ map pretty tel
@@ -178,7 +175,7 @@ instance Pretty Expr where
nest 2 $ pretty e]
Quote _ -> text "quote"
QuoteTerm _ -> text "quoteTerm"
- Unquote _ -> text "unquote"
+ Unquote _ -> text "unquote"
Tactic _ t es ->
sep [ text "tactic" <+> pretty t
, fsep [ text "|" <+> pretty e | e <- es ]
@@ -186,8 +183,8 @@ instance Pretty Expr where
-- Andreas, 2011-10-03 print irrelevant things as .(e)
DontCare e -> text "." <> parens (pretty e)
Equal _ a b -> pretty a <+> text "=" <+> pretty b
- where
- recPr (x, e) = sep [ pretty x <+> text "=" , nest 2 $ pretty e ]
+ where
+ recPr (x, e) = sep [ pretty x <+> text "=" , nest 2 $ pretty e ]
instance Pretty BoundName where
pretty BName{ boundName = x, boundLabel = l }
@@ -200,16 +197,17 @@ instance Pretty LamBinding where
pretty (DomainFull b) = pretty b
instance Pretty TypedBindings where
- pretty (TypedBindings _ a) =
- pRelevance (argInfo a) $ bracks $ pretty $ WithColors (argColors a) $ unArg a
- where
- bracks = case getHiding a of
- Hidden -> braces'
- Instance -> dbraces
- NotHidden | isMeta (unArg a) -> id
- | otherwise -> parens
- isMeta (TBind _ _ (Underscore _ Nothing)) = True
- isMeta _ = False
+ pretty (TypedBindings _ a) =
+ pRelevance (argInfo a) $ bracks $ pretty $ WithColors (argColors a) $ unArg a
+ where
+ bracks = case getHiding a of
+ Hidden -> braces'
+ Instance -> dbraces
+ NotHidden | isMeta (unArg a) -> id
+ | otherwise -> parens
+
+ isMeta (TBind _ _ (Underscore _ Nothing)) = True
+ isMeta _ = False
newtype Tel = Tel Telescope
@@ -230,9 +228,9 @@ instance Pretty ColoredTypedBinding where
text "let" <+> vcat (map pretty ds)
pretty (WithColors _ (TLet _ _)) = __IMPOSSIBLE__
pretty (WithColors cs (TBind _ xs e)) =
- sep [ fsep (map pretty xs)
- , pColors ":" cs <+> pretty e
- ]
+ sep [ fsep (map pretty xs)
+ , pColors ":" cs <+> pretty e
+ ]
pColors :: String -> [Color] -> Doc
pColors s [] = text s
@@ -240,9 +238,9 @@ pColors s cs = text (s ++ "{") <+> fsep (map pretty cs) <+> text "}"
instance Pretty TypedBinding where
pretty (TBind _ xs e) =
- sep [ fsep (map pretty xs)
- , text ":" <+> pretty e
- ]
+ sep [ fsep (map pretty xs)
+ , text ":" <+> pretty e
+ ]
pretty (TLet _ ds) =
text "let" <+> vcat (map pretty ds)
@@ -269,8 +267,8 @@ instance Pretty WhereClause where
pretty (AnyWhere ds) = vcat [ text "where", nest 2 (vcat $ map pretty ds) ]
pretty (SomeWhere m ds) =
vcat [ hsep [ text "module", pretty m, text "where" ]
- , nest 2 (vcat $ map pretty ds)
- ]
+ , nest 2 (vcat $ map pretty ds)
+ ]
instance Show LHS where show = show . pretty
instance Pretty LHS where
@@ -286,7 +284,7 @@ instance Pretty LHS where
]
pThing thing [] = empty
pThing thing (e : es) = fsep $ (text thing <+> pretty e)
- : map ((text "|" <+>) . pretty) es
+ : map ((text "|" <+>) . pretty) es
instance Show LHSCore where show = show . pretty
instance Pretty LHSCore where
@@ -305,120 +303,120 @@ instance Pretty ModuleApplication where
instance Pretty Declaration where
pretty d =
- case d of
- TypeSig i x e ->
+ case d of
+ TypeSig i x e ->
sep [ pRelevance i $ pretty x <+> pColors ":" (argInfoColors i)
- , nest 2 $ pretty e
- ]
+ , nest 2 $ pretty e
+ ]
Field x (Common.Arg i e) ->
sep [ text "field"
, nest 2 $ pRelevance i $ pHidden i $
TypeSig (i {argInfoRelevance = Relevant}) x e
]
- FunClause lhs rhs wh ->
- sep [ pretty lhs
- , nest 2 $ pretty rhs
- ] $$ nest 2 (pretty wh)
- DataSig _ ind x tel e ->
- sep [ hsep [ pretty ind
- , pretty x
- , fcat (map pretty tel)
- ]
- , nest 2 $ hsep
- [ text ":"
- , pretty e
- ]
- ]
- Data _ ind x tel (Just e) cs ->
- sep [ hsep [ pretty ind
- , pretty x
- , fcat (map pretty tel)
- ]
- , nest 2 $ hsep
- [ text ":"
- , pretty e
- , text "where"
- ]
- ] $$ nest 2 (vcat $ map pretty cs)
- Data _ ind x tel Nothing cs ->
- sep [ hsep [ pretty ind
- , pretty x
- , fcat (map pretty tel)
- ]
- , nest 2 $ text "where"
- ] $$ nest 2 (vcat $ map pretty cs)
- RecordSig _ x tel e ->
- sep [ hsep [ text "record"
- , pretty x
- , fcat (map pretty tel)
- ]
- , nest 2 $ hsep
- [ text ":"
- , pretty e
- ]
- ]
- Record _ x ind con tel me cs ->
- sep [ hsep [ text "record"
- , pretty x
- , fcat (map pretty tel)
- ]
- , nest 2 $ pType me
- ] $$ nest 2 (vcat $ pInd ++
+ FunClause lhs rhs wh ->
+ sep [ pretty lhs
+ , nest 2 $ pretty rhs
+ ] $$ nest 2 (pretty wh)
+ DataSig _ ind x tel e ->
+ sep [ hsep [ pretty ind
+ , pretty x
+ , fcat (map pretty tel)
+ ]
+ , nest 2 $ hsep
+ [ text ":"
+ , pretty e
+ ]
+ ]
+ Data _ ind x tel (Just e) cs ->
+ sep [ hsep [ pretty ind
+ , pretty x
+ , fcat (map pretty tel)
+ ]
+ , nest 2 $ hsep
+ [ text ":"
+ , pretty e
+ , text "where"
+ ]
+ ] $$ nest 2 (vcat $ map pretty cs)
+ Data _ ind x tel Nothing cs ->
+ sep [ hsep [ pretty ind
+ , pretty x
+ , fcat (map pretty tel)
+ ]
+ , nest 2 $ text "where"
+ ] $$ nest 2 (vcat $ map pretty cs)
+ RecordSig _ x tel e ->
+ sep [ hsep [ text "record"
+ , pretty x
+ , fcat (map pretty tel)
+ ]
+ , nest 2 $ hsep
+ [ text ":"
+ , pretty e
+ ]
+ ]
+ Record _ x ind con tel me cs ->
+ sep [ hsep [ text "record"
+ , pretty x
+ , fcat (map pretty tel)
+ ]
+ , nest 2 $ pType me
+ ] $$ nest 2 (vcat $ pInd ++
pCon ++
map pretty cs)
where pType (Just e) = hsep
- [ text ":"
- , pretty e
- , text "where"
- ]
+ [ text ":"
+ , pretty e
+ , text "where"
+ ]
pType Nothing =
text "where"
pInd = maybeToList $ text . show . rangedThing <$> ind
pCon = maybeToList $ (text "constructor" <+>) . pretty <$> con
- Infix f xs ->
- pretty f <+> (fsep $ punctuate comma $ map pretty xs)
+ Infix f xs ->
+ pretty f <+> (fsep $ punctuate comma $ map pretty xs)
Syntax n xs -> text "syntax" <+> pretty n <+> text "..."
PatternSyn _ n as p -> text "pattern" <+> pretty n <+> fsep (map pretty as)
<+> text "=" <+> pretty p
- Mutual _ ds -> namedBlock "mutual" ds
- Abstract _ ds -> namedBlock "abstract" ds
- Private _ ds -> namedBlock "private" ds
- InstanceB _ ds -> namedBlock "instance" ds
- Postulate _ ds -> namedBlock "postulate" ds
- Primitive _ ds -> namedBlock "primitive" ds
- Module _ x tel ds ->
- hsep [ text "module"
- , pretty x
- , fcat (map pretty tel)
- , text "where"
- ] $$ nest 2 (vcat $ map pretty ds)
- ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x ->
- sep [ pretty DoOpen
+ Mutual _ ds -> namedBlock "mutual" ds
+ Abstract _ ds -> namedBlock "abstract" ds
+ Private _ ds -> namedBlock "private" ds
+ InstanceB _ ds -> namedBlock "instance" ds
+ Postulate _ ds -> namedBlock "postulate" ds
+ Primitive _ ds -> namedBlock "primitive" ds
+ Module _ x tel ds ->
+ hsep [ text "module"
+ , pretty x
+ , fcat (map pretty tel)
+ , text "where"
+ ] $$ nest 2 (vcat $ map pretty ds)
+ ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x ->
+ sep [ pretty DoOpen
, nest 2 $ pretty e
, nest 4 $ pretty i
]
- ModuleMacro _ x (SectionApp _ tel e) open i ->
- sep [ pretty open <+> text "module" <+> pretty x <+> fcat (map pretty tel)
- , nest 2 $ text "=" <+> pretty e <+> pretty i
- ]
- ModuleMacro _ x (RecordModuleIFS _ rec) open i ->
- sep [ pretty open <+> text "module" <+> pretty x
- , nest 2 $ text "=" <+> pretty rec <+> text "{{...}}"
- ]
- Open _ x i -> hsep [ text "open", pretty x, pretty i ]
- Import _ x rn open i ->
- hsep [ pretty open, text "import", pretty x, as rn, pretty i ]
- where
- as Nothing = empty
- as (Just x) = text "as" <+> pretty (asName x)
+ ModuleMacro _ x (SectionApp _ tel e) open i ->
+ sep [ pretty open <+> text "module" <+> pretty x <+> fcat (map pretty tel)
+ , nest 2 $ text "=" <+> pretty e <+> pretty i
+ ]
+ ModuleMacro _ x (RecordModuleIFS _ rec) open i ->
+ sep [ pretty open <+> text "module" <+> pretty x
+ , nest 2 $ text "=" <+> pretty rec <+> text "{{...}}"
+ ]
+ Open _ x i -> hsep [ text "open", pretty x, pretty i ]
+ Import _ x rn open i ->
+ hsep [ pretty open, text "import", pretty x, as rn, pretty i ]
+ where
+ as Nothing = empty
+ as (Just x) = text "as" <+> pretty (asName x)
UnquoteDecl _ x t ->
sep [ text "unquoteDecl" <+> pretty x <+> text "=", nest 2 $ pretty t ]
- Pragma pr -> sep [ text "{-#" <+> pretty pr, text "#-}" ]
- where
- namedBlock s ds =
- sep [ text s
- , nest 2 $ vcat $ map pretty ds
- ]
+ Pragma pr -> sep [ text "{-#" <+> pretty pr, text "#-}" ]
+ where
+ namedBlock s ds =
+ sep [ text s
+ , nest 2 $ vcat $ map pretty ds
+ ]
instance Pretty OpenShortHand where
pretty DoOpen = text "open"
@@ -454,12 +452,26 @@ instance Pretty Pragma where
TerminationCheck -> __IMPOSSIBLE__
NoTerminationCheck -> text "NO_TERMINATION_CHECK"
NonTerminating -> text "NON_TERMINATING"
+ Terminating -> text "TERMINATING"
TerminationMeasure _ x -> hsep $ [text "MEASURE", pretty x]
instance Pretty Fixity where
- pretty (LeftAssoc _ n) = text "infixl" <+> text (show n)
+ pretty (LeftAssoc _ n) = text "infixl" <+> text (show n)
pretty (RightAssoc _ n) = text "infixr" <+> text (show n)
- pretty (NonAssoc _ n) = text "infix" <+> text (show n)
+ pretty (NonAssoc _ n) = text "infix" <+> text (show n)
+
+instance Pretty GenPart where
+ pretty (IdPart x) = text x
+ pretty BindHole{} = underscore
+ pretty NormalHole{} = underscore
+
+instance Pretty Notation where
+ pretty = hcat . map pretty
+
+instance Pretty Fixity' where
+ pretty (Fixity' fix nota)
+ | nota == defaultNotation = pretty fix
+ | otherwise = text "syntax" <+> pretty nota
instance Pretty e => Pretty (Arg e) where
-- Andreas 2010-09-21: do not print relevance in general, only in function types!
@@ -477,19 +489,19 @@ instance Pretty [Pattern] where
instance Pretty Pattern where
pretty p =
- case p of
- IdentP x -> pretty x
- AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ]
- RawAppP _ ps -> fsep $ map pretty ps
- OpAppP _ q ps -> fsep $ prettyOpApp q ps
- HiddenP _ p -> braces' $ pretty p
- InstanceP _ p -> dbraces $ pretty p
- ParenP _ p -> parens $ pretty p
- WildP _ -> underscore
- AsP _ x p -> pretty x <> text "@" <> pretty p
- DotP _ p -> text "." <> pretty p
- AbsurdP _ -> text "()"
- LitP l -> pretty l
+ case p of
+ IdentP x -> pretty x
+ AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ]
+ RawAppP _ ps -> fsep $ map pretty ps
+ OpAppP _ q ps -> fsep $ prettyOpApp q ps
+ HiddenP _ p -> braces' $ pretty p
+ InstanceP _ p -> dbraces $ pretty p
+ ParenP _ p -> parens $ pretty p
+ WildP _ -> underscore
+ AsP _ x p -> pretty x <> text "@" <> pretty p
+ DotP _ p -> text "." <> pretty p
+ AbsurdP _ -> text "()"
+ LitP l -> pretty l
QuoteP _ -> text "quote"
prettyOpApp :: Pretty a => QName -> [a] -> [Doc]
@@ -502,33 +514,33 @@ prettyOpApp q es = prOp ms xs es
prOp ms (Hole : xs) (e : es) = pretty e : prOp ms xs es
prOp _ (Hole : _) [] = __IMPOSSIBLE__
prOp ms (Id x : xs) es = pretty (foldr Qual (QName (Name noRange $ [Id x])) ms) : prOp [] xs es
- prOp _ [] [] = []
- prOp _ [] es = map pretty es
+ prOp _ [] [] = []
+ prOp _ [] es = map pretty es
instance Pretty ImportDirective where
pretty i =
- sep [ public (publicOpen i)
- , pretty $ usingOrHiding i
- , rename $ renaming i
- ]
- where
- public True = text "public"
- public False = empty
+ sep [ public (publicOpen i)
+ , pretty $ usingOrHiding i
+ , rename $ renaming i
+ ]
+ where
+ public True = text "public"
+ public False = empty
- rename [] = empty
- rename xs = hsep [ text "renaming"
- , parens $ fsep $ punctuate (text ";") $ map pr xs
- ]
+ rename [] = empty
+ rename xs = hsep [ text "renaming"
+ , parens $ fsep $ punctuate (text ";") $ map pr xs
+ ]
- pr r = hsep [ pretty (renFrom r), text "to", pretty (renTo r) ]
+ pr r = hsep [ pretty (renFrom r), text "to", pretty (renTo r) ]
instance Pretty UsingOrHiding where
- pretty (Hiding []) = empty
- pretty (Hiding xs) =
- text "hiding" <+> parens (fsep $ punctuate (text ";") $ map pretty xs)
- pretty (Using xs) =
- text "using" <+> parens (fsep $ punctuate (text ";") $ map pretty xs)
+ pretty (Hiding []) = empty
+ pretty (Hiding xs) =
+ text "hiding" <+> parens (fsep $ punctuate (text ";") $ map pretty xs)
+ pretty (Using xs) =
+ text "using" <+> parens (fsep $ punctuate (text ";") $ map pretty xs)
instance Pretty ImportedName where
- pretty (ImportedName x) = pretty x
- pretty (ImportedModule x) = text "module" <+> pretty x
+ pretty (ImportedName x) = pretty x
+ pretty (ImportedModule x) = text "module" <+> pretty x
diff --git a/src/full/Agda/Syntax/Fixity.hs b/src/full/Agda/Syntax/Fixity.hs
index 665496d..ddf7947 100644
--- a/src/full/Agda/Syntax/Fixity.hs
+++ b/src/full/Agda/Syntax/Fixity.hs
@@ -1,79 +1,142 @@
--- {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
-{-| Definitions for fixity and precedence levels.
+{-| Definitions for fixity, precedence levels, and declared syntax.
-}
module Agda.Syntax.Fixity where
-import Data.Typeable (Typeable)
import Data.Foldable
+import Data.List as List
import Data.Traversable
+import Data.Typeable (Typeable)
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Concrete.Name
import Agda.Syntax.Notation
--- | The notation is handled as the fixity in the renamer. Hence they
--- are grouped together in this type.
+import Agda.Utils.List
+
+-- * Notation coupled with 'Fixity'
+
+-- | The notation is handled as the fixity in the renamer.
+-- Hence, they are grouped together in this type.
data Fixity' = Fixity'
- {theFixity :: Fixity,
- theNotation :: Notation}
+ { theFixity :: Fixity
+ , theNotation :: Notation
+ }
deriving (Typeable, Show, Eq)
-data ThingWithFixity x = ThingWithFixity x Fixity' deriving (Functor,Foldable,Traversable,Typeable,Show)
+-- | Decorating something with @Fixity'@.
+data ThingWithFixity x = ThingWithFixity x Fixity'
+ deriving (Functor, Foldable, Traversable, Typeable, Show)
+
-- | All the notation information related to a name.
-type NewNotation = (QName, Fixity, Notation)
+data NewNotation = NewNotation
+ { notaName :: QName
+ -- ^ The concrete name the syntax or fixity belongs to.
+ , notaFixity :: Fixity
+ -- ^ Associativity and precedence (fixity) of the name.
+ , notation :: Notation
+ -- ^ Syntax associated with the name.
+ } deriving (Typeable, Show)
-- | If an operator has no specific notation, recover it from its name.
oldToNewNotation :: (QName, Fixity') -> NewNotation
-oldToNewNotation (name, Fixity' f []) = (name, f, syntaxOf $ unqualify name)
-oldToNewNotation (name, Fixity' f syn) = (name, f, syn)
-
+oldToNewNotation (name, Fixity' f syn) = NewNotation
+ { notaName = name
+ , notaFixity = f
+ , notation = if null syn then syntaxOf $ unqualify name else syn
+ }
+
+-- | Return the 'IdPart's of a notation, the first part qualified,
+-- the other parts unqualified.
+-- This allows for qualified use of operators, e.g.,
+-- @M.for x ∈ xs return e@, or @x ℕ.+ y at .
+notationNames :: NewNotation -> [QName]
+notationNames (NewNotation q _ parts) =
+ zipWith ($) (reQualify : repeat QName) [Name noRange [Id x] | IdPart x <- parts ]
+ where
+ -- The qualification of @q at .
+ modules = init (qnameParts q)
+ -- Putting the qualification onto @x at .
+ reQualify x = List.foldr Qual (QName x) modules
+
+-- | Create a 'Notation' (without binders) from a concrete 'Name'.
+-- Does the obvious thing:
+-- 'Hole's become 'NormalHole's, 'Id's become 'IdParts'.
+-- If 'Name' has no 'Hole's, it returns 'noNotation'.
syntaxOf :: Name -> Notation
-syntaxOf (NoName _ _) = []
-syntaxOf (Name _ [_]) = []
+syntaxOf (NoName _ _) = noNotation
+syntaxOf (Name _ [_]) = noNotation
syntaxOf (Name _ xs) = mkSyn 0 xs
- where mkSyn :: Int -> [NamePart] -> Notation
- mkSyn n [] = []
- mkSyn n (Hole:xs) = NormalHole (defaultNamedArg n) : mkSyn (1+n) xs
- mkSyn n (Id x:xs) = IdPart x : mkSyn n xs
+ where
+ -- Turn a concrete name into a Notation,
+ -- numbering the holes from left to right.
+ -- Result will have no 'BindingHole's.
+ mkSyn :: Int -> [NamePart] -> Notation
+ mkSyn n [] = []
+ mkSyn n (Hole : xs) = NormalHole (defaultNamedArg n) : mkSyn (1 + n) xs
+ mkSyn n (Id x : xs) = IdPart x : mkSyn n xs
+
+defaultFixity' :: Fixity'
+defaultFixity' = Fixity' defaultFixity defaultNotation
+-- | Removes copies of @defaultFixity'@ from a list of fixities.
+-- Never returns an empty list, though, rather a singleton list
+-- consisting of @defaultFixity'@.
+interestingFixities :: [Fixity'] -> [Fixity']
+interestingFixities fixs = if null fixs' then [defaultFixity'] else fixs'
+ where fixs' = filter (not . (== defaultFixity')) fixs
-defaultFixity' = Fixity' defaultFixity defaultNotation
+-- | If different interesting fixities are available for the same symbol,
+-- we take none of them.
+chooseFixity :: [Fixity'] -> Fixity'
+chooseFixity fixs = if allEqual fixs' then head fixs' else defaultFixity'
+ where fixs' = interestingFixities fixs
-noFixity = NonAssoc noRange (negate 666) -- ts,ts,ts, why the number of the beast? Revelation 13, 18
- -- It's not the number of the beast, it's the negation of the
- -- number of the beast, which must be a divine number, right?
+-- * Fixity
-- | Fixity of operators.
-data Fixity = LeftAssoc Range Integer
- | RightAssoc Range Integer
- | NonAssoc Range Integer
- deriving (Typeable, Show)
+
+data Fixity
+ = LeftAssoc { fixityRange :: Range, fixityLevel :: Integer }
+ | RightAssoc { fixityRange :: Range, fixityLevel :: Integer }
+ | NonAssoc { fixityRange :: Range, fixityLevel :: Integer }
+ deriving (Typeable, Show)
instance Eq Fixity where
- LeftAssoc _ n == LeftAssoc _ m = n == m
- RightAssoc _ n == RightAssoc _ m = n == m
- NonAssoc _ n == NonAssoc _ m = n == m
- _ == _ = False
+ LeftAssoc _ n == LeftAssoc _ m = n == m
+ RightAssoc _ n == RightAssoc _ m = n == m
+ NonAssoc _ n == NonAssoc _ m = n == m
+ _ == _ = False
-fixityLevel :: Fixity -> Integer
-fixityLevel (LeftAssoc _ n) = n
-fixityLevel (RightAssoc _ n) = n
-fixityLevel (NonAssoc _ n) = n
+-- For @instance Pretty Fixity@, see Agda.Syntax.Concrete.Pretty
-- | The default fixity. Currently defined to be @'NonAssoc' 20 at .
defaultFixity :: Fixity
defaultFixity = NonAssoc noRange 20
+-- | Hack used for @syntax@ facility.
+noFixity :: Fixity
+noFixity = NonAssoc noRange (negate 666)
+ -- Ts,ts,ts, why the number of the beast? Revelation 13, 18
+ --
+ -- It's not the number of the beast, it's the negation of the
+ -- number of the beast, which must be a divine number, right?
+ --
+ -- The divine is not the negation of evil.
+ -- Evil is only the absense of the good and divine.
+
+
+-- * Precendence
+
-- | Precedence is associated with a context.
data Precedence = TopCtx | FunctionSpaceDomainCtx
- | LeftOperandCtx Fixity | RightOperandCtx Fixity
- | FunctionCtx | ArgumentCtx | InsideOperandCtx
+ | LeftOperandCtx Fixity | RightOperandCtx Fixity
+ | FunctionCtx | ArgumentCtx | InsideOperandCtx
| WithFunCtx | WithArgCtx | DotPatternCtx
deriving (Show,Typeable)
@@ -97,10 +160,10 @@ opBrackets f1
(RightOperandCtx f2) | fixityLevel f1 > fixityLevel f2 = False
opBrackets _ TopCtx = False
opBrackets _ FunctionSpaceDomainCtx = False
-opBrackets _ InsideOperandCtx = False
+opBrackets _ InsideOperandCtx = False
opBrackets _ WithArgCtx = False
opBrackets _ WithFunCtx = False
-opBrackets _ _ = True
+opBrackets _ _ = True
-- | Does a lambda-like thing (lambda, let or pi) need brackets in the
-- given context? A peculiar thing with lambdas is that they don't
@@ -113,7 +176,7 @@ opBrackets _ _ = True
-- (here @_>>=_@ is left associative).
lamBrackets :: Precedence -> Bool
lamBrackets TopCtx = False
-lamBrackets _ = True
+lamBrackets _ = True
-- | Does a function application need brackets?
appBrackets :: Precedence -> Bool
@@ -131,16 +194,14 @@ withAppBrackets _ = True
-- | Does a function space need brackets?
piBrackets :: Precedence -> Bool
piBrackets TopCtx = False
-piBrackets _ = True
+piBrackets _ = True
roundFixBrackets :: Precedence -> Bool
roundFixBrackets DotPatternCtx = True
roundFixBrackets _ = False
instance HasRange Fixity where
- getRange (LeftAssoc r _) = r
- getRange (RightAssoc r _) = r
- getRange (NonAssoc r _) = r
+ getRange = fixityRange
instance KillRange Fixity where
killRange (LeftAssoc _ n) = LeftAssoc noRange n
diff --git a/src/full/Agda/Syntax/Info.hs b/src/full/Agda/Syntax/Info.hs
index ed6f299..5c91955 100644
--- a/src/full/Agda/Syntax/Info.hs
+++ b/src/full/Agda/Syntax/Info.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-| An info object contains additional information about a piece of abstract
@@ -44,45 +44,39 @@ instance HasRange MetaInfo where
getRange = metaRange
instance KillRange MetaInfo where
- killRange m = m { metaRange = killRange $ metaRange m }
+ killRange m = m { metaRange = noRange }
{--------------------------------------------------------------------------
General expression information
--------------------------------------------------------------------------}
--- | For a general expression we can either remember just the source code
--- position or the entire concrete expression it came from.
-data ExprInfo
- = ExprRange Range
- | ExprSource Range (Precedence -> Expr)
- -- ^ Even if we store the original expression we have to know
- -- whether to put parenthesis around it.
+newtype ExprInfo = ExprRange Range
deriving (Typeable, Show)
+exprNoRange :: ExprInfo
+exprNoRange = ExprRange noRange
+
instance HasRange ExprInfo where
- getRange (ExprRange r ) = r
- getRange (ExprSource r _) = r
+ getRange (ExprRange r) = r
instance KillRange ExprInfo where
- killRange (ExprRange r) = ExprRange (killRange r)
- killRange (ExprSource r f) = ExprSource (killRange r) f
+ killRange (ExprRange r) = exprNoRange
{--------------------------------------------------------------------------
Module information
--------------------------------------------------------------------------}
-data ModuleInfo =
- ModuleInfo { minfoRange :: Range
- , minfoAsTo :: Range
- -- The range of the \"as\" and \"to\" keywords,
- -- if any. Retained for highlighting purposes.
- , minfoAsName :: Maybe C.Name
- -- The \"as\" module name, if any. Retained for
- -- highlighting purposes.
- , minfoOpenShort :: Maybe OpenShortHand
- , minfoDirective :: Maybe ImportDirective
- -- Retained for abstractToConcrete of ModuleMacro
- }
+data ModuleInfo = ModuleInfo
+ { minfoRange :: Range
+ , minfoAsTo :: Range
+ -- ^ The range of the \"as\" and \"to\" keywords,
+ -- if any. Retained for highlighting purposes.
+ , minfoAsName :: Maybe C.Name
+ -- ^ The \"as\" module name, if any. Retained for highlighting purposes.
+ , minfoOpenShort :: Maybe OpenShortHand
+ , minfoDirective :: Maybe ImportDirective
+ -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'.
+ }
deriving (Typeable)
deriving instance (Show OpenShortHand, Show ImportDirective) => Show ModuleInfo
@@ -94,7 +88,7 @@ instance SetRange ModuleInfo where
setRange r i = i { minfoRange = r }
instance KillRange ModuleInfo where
- killRange m = m { minfoRange = killRange $ minfoRange m }
+ killRange m = m { minfoRange = noRange }
---------------------------------------------------------------------------
-- Let info
@@ -107,19 +101,19 @@ instance HasRange LetInfo where
getRange (LetRange r) = r
instance KillRange LetInfo where
- killRange (LetRange r) = LetRange (killRange r)
+ killRange (LetRange r) = LetRange noRange
{--------------------------------------------------------------------------
Definition information (declarations that actually define something)
--------------------------------------------------------------------------}
-data DefInfo =
- DefInfo { defFixity :: Fixity'
- , defAccess :: Access
- , defAbstract :: IsAbstract
- , defInstance :: IsInstance
- , defInfo :: DeclInfo
- }
+data DefInfo = DefInfo
+ { defFixity :: Fixity'
+ , defAccess :: Access
+ , defAbstract :: IsAbstract
+ , defInstance :: IsInstance
+ , defInfo :: DeclInfo
+ }
deriving (Typeable, Show)
mkDefInfo :: Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo
@@ -142,10 +136,10 @@ instance KillRange DefInfo where
General declaration information
--------------------------------------------------------------------------}
-data DeclInfo =
- DeclInfo { declName :: Name
- , declRange :: Range
- }
+data DeclInfo = DeclInfo
+ { declName :: Name
+ , declRange :: Range
+ }
deriving (Typeable, Show)
instance HasRange DeclInfo where
@@ -155,23 +149,23 @@ instance SetRange DeclInfo where
setRange r i = i { declRange = r }
instance KillRange DeclInfo where
- killRange i = i { declRange = killRange $ declRange i }
+ killRange i = i { declRange = noRange }
{--------------------------------------------------------------------------
Mutual block information
--------------------------------------------------------------------------}
-data MutualInfo =
- MutualInfo { mutualTermCheck :: TerminationCheck Name
- , mutualRange :: Range
- }
+data MutualInfo = MutualInfo
+ { mutualTermCheck :: TerminationCheck Name
+ , mutualRange :: Range
+ }
deriving (Typeable, Show)
instance HasRange MutualInfo where
getRange = mutualRange
instance KillRange MutualInfo where
- killRange i = i { mutualRange = killRange $ mutualRange i }
+ killRange i = i { mutualRange = noRange }
{--------------------------------------------------------------------------
Left hand side information
@@ -184,17 +178,19 @@ instance HasRange LHSInfo where
getRange (LHSRange r) = r
instance KillRange LHSInfo where
- killRange (LHSRange r) = LHSRange (killRange r)
+ killRange (LHSRange r) = LHSRange noRange
{--------------------------------------------------------------------------
Pattern information
--------------------------------------------------------------------------}
--- TODO: Is it safe to add Typeable/Data here? PatInfo contains a
--- function space.
-
-data PatInfo = PatRange Range
- | PatSource Range (Precedence -> Pattern)
+-- | For a general pattern we can either remember just the source code
+-- position or the entire concrete pattern it came from.
+data PatInfo
+ = PatRange Range
+ | PatSource Range (Precedence -> Pattern)
+ -- ^ Even if we store the original pattern we have to know
+ -- whether to put parenthesis around it.
deriving (Typeable)
instance Show PatInfo where
@@ -206,8 +202,8 @@ instance HasRange PatInfo where
getRange (PatSource r _) = r
instance KillRange PatInfo where
- killRange (PatRange r) = PatRange $ killRange r
- killRange (PatSource r f) = PatSource (killRange r) f
+ killRange (PatRange r) = PatRange noRange
+ killRange (PatSource r f) = PatSource noRange f
-- | Empty range for patterns.
patNoRange :: PatInfo
@@ -216,7 +212,7 @@ patNoRange = PatRange noRange
-- | Constructor pattern info.
data ConPatInfo = ConPatInfo
{ patImplicit :: Bool
- -- ^ Does this pattern come form the eta-expansion of an implicit pattern.
+ -- ^ Does this pattern come form the eta-expansion of an implicit pattern?
, patInfo :: PatInfo
}
diff --git a/src/full/Agda/Syntax/Internal.hs b/src/full/Agda/Syntax/Internal.hs
index 8959d10..5fda241 100644
--- a/src/full/Agda/Syntax/Internal.hs
+++ b/src/full/Agda/Syntax/Internal.hs
@@ -1,13 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Agda.Syntax.Internal
( module Agda.Syntax.Internal
@@ -36,6 +36,7 @@ import qualified Agda.Syntax.Common as Common
import Agda.Syntax.Literal
import Agda.Syntax.Abstract.Name
+import Agda.Utils.Empty
import Agda.Utils.Functor
import Agda.Utils.Geniplate
import Agda.Utils.List
@@ -45,7 +46,7 @@ import Agda.Utils.Pointer
import Agda.Utils.Size
import Agda.Utils.Pretty
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
type Color = Term
@@ -63,17 +64,12 @@ type NamedArgs = [NamedArg Term]
-- This allows reduction of projection redexes outside of TCM.
-- For instance, during substitution and application.
data ConHead = ConHead
- { conName :: QName -- ^ The name of the constructor.
- , conFields :: [QName] -- ^ The name of the record fields.
- -- Empty list for data constructors.
- -- 'Arg' is not needed here since it
- -- is stored in the constructor args.
-{-
- , conFields :: [Arg QName] -- ^ The name of the record fields.
- -- Empty list for data constructors.
- -- 'Arg' is needed for irrelevance, to
- -- insert 'DontCare's in short-cut reduction.
--}
+ { conName :: QName -- ^ The name of the constructor.
+ , conInductive :: Induction -- ^ Record constructors can be coinductive.
+ , conFields :: [QName] -- ^ The name of the record fields.
+ -- Empty list for data constructors.
+ -- 'Arg' is not needed here since it
+ -- is stored in the constructor args.
} deriving (Typeable)
instance Eq ConHead where
@@ -83,7 +79,7 @@ instance Ord ConHead where
(<=) = (<=) `on` conName
instance Show ConHead where
- show (ConHead c fs) = show c ++ show fs
+ show (ConHead c i fs) = show c ++ "(" ++ show i ++ ")" ++ show fs
instance HasRange ConHead where
getRange = getRange . conName
@@ -111,15 +107,15 @@ instance LensConName ConHead where
-- list of clauses.
--
data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral
- | Lam ArgInfo (Abs Term) -- ^ Terms are beta normal. Relevance is ignored
+ | Lam ArgInfo (Abs Term) -- ^ Terms are beta normal. Relevance is ignored
| ExtLam [Clause] Args -- ^ Only used by unquote --> reify. Should never appear elsewhere.
- | Lit Literal
- | Def QName Elims -- ^ @f es@, possibly a delta/iota-redex
- | Con ConHead Args -- ^ @c vs@
- | Pi (Dom Type) (Abs Type) -- ^ dependent or non-dependent function space
- | Sort Sort
+ | Lit Literal
+ | Def QName Elims -- ^ @f es@, possibly a delta/iota-redex
+ | Con ConHead Args -- ^ @c vs@
+ | Pi (Dom Type) (Abs Type) -- ^ dependent or non-dependent function space
+ | Sort Sort
| Level Level
- | MetaV {-# UNPACK #-} !MetaId Elims
+ | MetaV {-# UNPACK #-} !MetaId Elims
| DontCare Term
-- ^ Irrelevant stuff in relevant position, but created
-- in an irrelevant context. Basically, an internal
@@ -149,7 +145,7 @@ appendArgNames :: ArgName -> ArgName -> ArgName
appendArgNames = (++)
nameToArgName :: Name -> ArgName
-nameToArgName = stringToArgName . show
+nameToArgName = stringToArgName . prettyShow
-- | Binder.
-- 'Abs': The bound variable might appear in the body.
@@ -174,11 +170,16 @@ instance Decoration Type' where
-- | Sequence of types. An argument of the first type is bound in later types
-- and so on.
data Tele a = EmptyTel
- | ExtendTel a (Abs (Tele a)) -- ^ 'Abs' is never 'NoAbs'.
+ | ExtendTel a (Abs (Tele a)) -- ^ 'Abs' is never 'NoAbs'.
deriving (Typeable, Show, Functor, Foldable, Traversable)
type Telescope = Tele (Dom Type)
+instance Null (Tele a) where
+ null EmptyTel = True
+ null ExtendTel{} = False
+ empty = EmptyTel
+
mapAbsNamesM :: Applicative m => (ArgName -> m ArgName) -> Tele a -> m (Tele a)
mapAbsNamesM f EmptyTel = pure EmptyTel
mapAbsNamesM f (ExtendTel a (Abs x b)) = ExtendTel a <$> (Abs <$> f x <*> mapAbsNamesM f b)
@@ -203,7 +204,7 @@ replaceEmptyName x = mapAbsNames $ \ y -> if null y then x else y
-- | Sorts.
--
data Sort = Type Level
- | Prop -- ignore me
+ | Prop -- ignore me
| Inf
| DLub Sort (Abs Sort)
-- ^ if the free variable occurs in the second sort
@@ -287,7 +288,7 @@ clausePats = map (fmap namedThing) . namedClausePats
-- clauseArgs cl = evalState (argsToTerms $ namedClausePats cl) xs
-- where
-- perm = clausePerm cl
--- xs = permute (invertP perm) $ downFrom (size perm)
+-- xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm)
--
-- next = do x : xs <- get; put xs; return x
--
@@ -300,8 +301,8 @@ clausePats = map (fmap namedThing) . namedClausePats
-- ProjP{} -> __IMPOSSIBLE__ -- TODO
data ClauseBodyF a = Body a
- | Bind (Abs (ClauseBodyF a))
- | NoBody -- ^ for absurd clauses.
+ | Bind (Abs (ClauseBodyF a))
+ | NoBody -- ^ for absurd clauses.
deriving (Typeable, Show, Functor, Foldable, Traversable)
type ClauseBody = ClauseBodyF Term
@@ -324,16 +325,23 @@ nameToPatVarName = nameToArgName
-- This also meshes well with the fact that values (i.e.
-- the arguments we are matching with) use @QName at .
--
-data Pattern
- = VarP PatVarName
- -- ^ The @PatVarName@ is a name suggestion.
+data Pattern' x
+ = VarP x
+ -- ^ @x@
| DotP Term
- | ConP ConHead ConPatternInfo [NamedArg Pattern]
- -- ^ The @Pattern at s do not contain any projection copatterns.
+ -- ^ @.t@
+ | ConP ConHead ConPatternInfo [NamedArg (Pattern' x)]
+ -- ^ @c ps@
+ -- The subpatterns do not contain any projection copatterns.
| LitP Literal
+ -- ^ E.g. @5@, @"hello"@.
| ProjP QName
-- ^ Projection copattern. Can only appear by itself.
- deriving (Typeable, Show)
+ deriving (Typeable, Show, Functor, Foldable, Traversable)
+
+type Pattern = Pattern' PatVarName
+ -- ^ The @PatVarName@ is a name suggestion.
+
namedVarP :: PatVarName -> Named (Ranged PatVarName) Pattern
namedVarP x = Named named $ VarP x
@@ -366,6 +374,36 @@ properlyMatching (ConP _ mt ps) = isNothing mt || -- not a record cons
List.any (properlyMatching . namedArg) ps -- or one of subpatterns is a proper m
properlyMatching ProjP{} = True
+-----------------------------------------------------------------------------
+-- * Explicit substitutions
+-----------------------------------------------------------------------------
+
+-- | Substitutions.
+
+infixr 4 :#
+data Substitution
+
+ = IdS -- Γ ⊢ IdS : Γ
+
+ | EmptyS -- Γ ⊢ EmptyS : ()
+
+ -- Γ ⊢ ρ : Δ
+ | Wk !Int Substitution -- -------------------
+ -- Γ, Ψ ⊢ Wk |Ψ| ρ : Δ
+
+ -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ
+ | Term :# Substitution -- ---------------------
+ -- Γ ⊢ u :# ρ : Δ, A
+
+ -- First argument is __IMPOSSIBLE__ -- Γ ⊢ ρ : Δ
+ | Strengthen Empty Substitution -- ---------------------------
+ -- Γ ⊢ Strengthen ρ : Δ, A
+
+ -- Γ ⊢ ρ : Δ
+ | Lift !Int Substitution -- -------------------------
+ -- Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ
+ deriving (Show)
+
---------------------------------------------------------------------------
-- * Absurd Lambda
---------------------------------------------------------------------------
@@ -473,10 +511,13 @@ typeDontCare = El Prop (Sort Prop)
topSort :: Type
topSort = El Inf (Sort Inf)
-set0 = set 0
-set n = sort $ mkType n
-prop = sort Prop
-sort s = El (sSuc s) $ Sort s
+prop :: Type
+prop = sort Prop
+
+sort :: Sort -> Type
+sort s = El (sSuc s) $ Sort s
+
+varSort :: Int -> Sort
varSort n = Type $ Max [Plus 0 $ NeutralLevel $ Var n []]
-- | Get the next higher sort.
@@ -486,11 +527,13 @@ sSuc Inf = Inf
sSuc (DLub a b) = DLub (sSuc a) (fmap sSuc b)
sSuc (Type l) = Type $ levelSuc l
+levelSuc :: Level -> Level
levelSuc (Max []) = Max [ClosedLevel 1]
levelSuc (Max as) = Max $ map inc as
where inc (ClosedLevel n) = ClosedLevel (n + 1)
inc (Plus n l) = Plus (n + 1) l
+mkType :: Integer -> Sort
mkType n = Type $ Max [ClosedLevel n | n > 0]
impossibleTerm :: String -> Int -> Term
@@ -499,8 +542,14 @@ impossibleTerm file line = Lit $ LitString noRange $ unlines
, "Location of the error: " ++ file ++ ":" ++ show line
]
-sgTel :: Dom (ArgName, Type) -> Telescope
-sgTel (Common.Dom ai (x, t)) = ExtendTel (Common.Dom ai t) $ Abs x EmptyTel
+class SgTel a where
+ sgTel :: a -> Telescope
+
+instance SgTel (ArgName, Dom Type) where
+ sgTel (x, dom) = ExtendTel dom $ Abs x EmptyTel
+
+instance SgTel (Dom (ArgName, Type)) where
+ sgTel (Common.Dom ai (x, t)) = ExtendTel (Common.Dom ai t) $ Abs x EmptyTel
hackReifyToMeta :: Term
hackReifyToMeta = DontCare $ Lit $ LitInt noRange (-42)
@@ -547,8 +596,8 @@ arity t = case ignoreSharing $ unEl t of
argName :: Type -> String
argName = argN . ignoreSharing . unEl
where
- argN (Pi _ b) = "." ++ argNameToString (absName b)
- argN _ = __IMPOSSIBLE__
+ argN (Pi _ b) = "." ++ argNameToString (absName b)
+ argN _ = __IMPOSSIBLE__
-- | Pick the better name suggestion, i.e., the one that is not just underscore.
class Suggest a b where
@@ -707,7 +756,7 @@ instance Sized LevelAtom where
size (UnreducedLevel v) = size v
instance Sized (Tele a) where
- size EmptyTel = 0
+ size EmptyTel = 0
size (ExtendTel _ tel) = 1 + size tel
instance Sized a => Sized (Abs a) where
@@ -722,7 +771,7 @@ instance Sized a => Sized (Elim' a) where
---------------------------------------------------------------------------
instance KillRange ConHead where
- killRange (ConHead c fs) = killRange2 ConHead c fs
+ killRange (ConHead c i fs) = killRange3 ConHead c i fs
instance KillRange Term where
killRange v = case v of
@@ -821,7 +870,7 @@ instance Pretty Term where
, nest 2 $ pretty (unAbs b) ]
Lit l -> pretty l
Def q els -> text (show q) `pApp` els
- Con (ConHead c _) vs -> text (show c) `pApp` map Apply vs
+ Con c vs -> text (show $ conName c) `pApp` map Apply vs
Pi a (NoAbs _ b) -> mparens (p > 0) $
sep [ prettyPrec 1 (unDom a) <+> text "->"
, nest 2 $ pretty b ]
@@ -895,4 +944,3 @@ instance Pretty a => Pretty (Arg a) where
NotHidden -> prettyPrec p
Hidden -> braces . pretty
Instance -> braces . braces . pretty
-
diff --git a/src/full/Agda/Syntax/Internal/Defs.hs b/src/full/Agda/Syntax/Internal/Defs.hs
index 2ea05eb..dd4fc38 100644
--- a/src/full/Agda/Syntax/Internal/Defs.hs
+++ b/src/full/Agda/Syntax/Internal/Defs.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-- | Extract used definitions from terms.
module Agda.Syntax.Internal.Defs where
@@ -12,7 +14,7 @@ import Agda.Syntax.Common
import Agda.Syntax.Internal hiding (ArgInfo, Arg, Dom)
import Agda.Utils.Impossible
-#include "../../undefined.h"
+#include "undefined.h"
-- | @getDefs' lookup emb a@ extracts all used definitions
-- (functions, data/record types) from @a@, embedded into a monoid via @emb at .
diff --git a/src/full/Agda/Syntax/Internal/Generic.hs b/src/full/Agda/Syntax/Internal/Generic.hs
index fb143b0..9da57c2 100644
--- a/src/full/Agda/Syntax/Internal/Generic.hs
+++ b/src/full/Agda/Syntax/Internal/Generic.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.Syntax.Internal.Generic where
@@ -11,7 +11,7 @@ import Data.Foldable
import Agda.Syntax.Internal
import Agda.Utils.Impossible
-#include "../../undefined.h"
+#include "undefined.h"
class TermLike a where
traverseTerm :: (Term -> Term) -> a -> a
diff --git a/src/full/Agda/Syntax/Internal/Pattern.hs b/src/full/Agda/Syntax/Internal/Pattern.hs
index e101bf9..7f9ca74 100644
--- a/src/full/Agda/Syntax/Internal/Pattern.hs
+++ b/src/full/Agda/Syntax/Internal/Pattern.hs
@@ -1,6 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-} -- because of func. deps.
module Agda.Syntax.Internal.Pattern where
@@ -21,7 +27,7 @@ import Agda.Utils.Permutation
import Agda.Utils.Size (size)
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- * Tools for clauses
@@ -57,55 +63,75 @@ instance FunArity [Clause] where
-- * Tools for patterns
+-- | Label the pattern variables from left to right
+-- using one label for each variable pattern and one for each dot pattern.
+class LabelPatVars a b i | b -> i where
+ labelPatVars :: a -> State [i] b
+ -- ^ Intended, but unpractical due to the absence of type-level lambda, is:
+ -- @labelPatVars :: f (Pattern' x) -> State [i] (f (Pattern' (i,x)))@
+
+instance LabelPatVars a b i => LabelPatVars (Arg c a) (Arg c b) i where
+ labelPatVars = traverse labelPatVars
+
+instance LabelPatVars a b i => LabelPatVars (Named x a) (Named x b) i where
+ labelPatVars = traverse labelPatVars
+
+instance LabelPatVars a b i => LabelPatVars [a] [b] i where
+ labelPatVars = traverse labelPatVars
+
+instance LabelPatVars (Pattern' x) (Pattern' (i,x)) i where
+ labelPatVars p =
+ case p of
+ VarP x -> VarP . (,x) <$> next
+ DotP t -> DotP t <$ next
+ ConP c mt ps -> ConP c mt <$> labelPatVars ps
+ LitP l -> return $ LitP l
+ ProjP q -> return $ ProjP q
+ where next = do (x:xs) <- get; put xs; return x
+
+-- | Augment pattern variables with their de Bruijn index.
+{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [(NamedArg (Pattern' (Int, x)))] #-}
+numberPatVars :: LabelPatVars a b Int => Permutation -> a -> b
+numberPatVars perm ps = evalState (labelPatVars ps) $
+ permute (invertP __IMPOSSIBLE__ perm) $ downFrom $ size perm
+
instance IsProjP Pattern where
isProjP (ProjP d) = Just d
isProjP _ = Nothing
--- Special case of Agda.Syntax.Abstract.IsProjP (Arg...)
--- instance IsProjP (Common.Arg c Pattern) where
--- isProjP = isProjP . unArg
-
-{- NOTE: The following definition does not work, since Elim' already
- contains Arg. Otherwise, we could have fixed it using traverseF.
-
-patternsToElims :: Permutation -> [I.NamedArg Pattern] -> Elims
-patternsToElims perm aps = evalState (argPatsToElims aps) xs
- where
- xs = permute (invertP perm) $ downFrom (size perm)
-
- tick :: State [Int] Int
- tick = do x : xs <- get; put xs; return x
-
- argPatsToElims :: [I.NamedArg Pattern] -> State [Int] Elims
- argPatsToElims = traverse $ traverse $ patToElim . namedThing
-
- patToElim :: Pattern -> State [Int] (Elim' Term)
- patToElim p = case p of
- VarP _ -> Apply . flip var <$> tick
- DotP v -> Apply v <$ tick -- dot patterns count as variables
- ConP c _ ps -> Apply . Con c . map argFromElim <$> argPatsToElims ps
- LitP l -> pure $ Apply $ Lit l
- ProjP d -> pure $ Proj d
--}
-
patternsToElims :: Permutation -> [I.NamedArg Pattern] -> [Elim]
-patternsToElims perm ps = evalState (mapM build' ps) xs
+patternsToElims perm ps = map build' $ numberPatVars perm ps
where
- xs = permute (invertP perm) $ downFrom (size perm)
-
- tick :: State [Int] Int
- tick = do x : xs <- get; put xs; return x
- build' :: NamedArg Pattern -> State [Int] Elim
+ build' :: NamedArg (Pattern' (Int, PatVarName)) -> Elim
build' = build . fmap namedThing
- build :: I.Arg Pattern -> State [Int] Elim
- build (Arg ai (VarP _) ) = Apply . Arg ai . var <$> tick
- build (Arg ai (ConP c _ ps)) =
- Apply . Arg ai . Con c <$> mapM (argFromElim <.> build') ps
- build (Arg ai (DotP t) ) = Apply (Arg ai t) <$ tick
- build (Arg ai (LitP l) ) = return $ Apply $ Arg ai $ Lit l
- build (Arg ai (ProjP dest) ) = return $ Proj $ dest
+ build :: I.Arg (Pattern' (Int, PatVarName)) -> Elim
+ build (Arg ai (VarP (i, _))) = Apply $ Arg ai $ var i
+ build (Arg ai (ConP c _ ps)) = Apply $ Arg ai $ Con c $
+ map (argFromElim . build') ps
+ build (Arg ai (DotP t) ) = Apply $ Arg ai t
+ build (Arg ai (LitP l) ) = Apply $ Arg ai $ Lit l
+ build (Arg ai (ProjP dest) ) = Proj $ dest
+
+-- patternsToElims :: Permutation -> [I.NamedArg Pattern] -> [Elim]
+-- patternsToElims perm ps = evalState (mapM build' ps) xs
+-- where
+-- xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm)
+
+-- tick :: State [Int] Int
+-- tick = do x : xs <- get; put xs; return x
+
+-- build' :: NamedArg Pattern -> State [Int] Elim
+-- build' = build . fmap namedThing
+
+-- build :: I.Arg Pattern -> State [Int] Elim
+-- build (Arg ai (VarP _) ) = Apply . Arg ai . var <$> tick
+-- build (Arg ai (ConP c _ ps)) =
+-- Apply . Arg ai . Con c <$> mapM (argFromElim <.> build') ps
+-- build (Arg ai (DotP t) ) = Apply (Arg ai t) <$ tick
+-- build (Arg ai (LitP l) ) = return $ Apply $ Arg ai $ Lit l
+-- build (Arg ai (ProjP dest) ) = return $ Proj $ dest
-- * One hole patterns
@@ -117,7 +143,7 @@ data OneHolePatterns = OHPats [NamedArg Pattern]
[NamedArg Pattern]
deriving (Show)
data OneHolePattern = Hole
- | OHCon ConHead ConPatternInfo OneHolePatterns
+ | OHCon ConHead ConPatternInfo OneHolePatterns
-- ^ The type in 'ConPatternInfo' serves the same role as in 'ConP'.
--
-- TODO: If a hole is plugged this type may
diff --git a/src/full/Agda/Syntax/Literal.hs b/src/full/Agda/Syntax/Literal.hs
index ca1c2a9..a9f06c9 100644
--- a/src/full/Agda/Syntax/Literal.hs
+++ b/src/full/Agda/Syntax/Literal.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+
module Agda.Syntax.Literal where
import Data.Char
@@ -8,9 +9,9 @@ import Agda.Syntax.Abstract.Name
import Agda.Utils.Pretty
data Literal = LitInt Range Integer
- | LitFloat Range Double
- | LitString Range String
- | LitChar Range Char
+ | LitFloat Range Double
+ | LitString Range String
+ | LitChar Range Char
| LitQName Range QName
deriving (Typeable)
@@ -26,7 +27,7 @@ instance Show Literal where
sh c x = showString (c ++ " ") . shows x
instance Pretty Literal where
- pretty (LitInt _ n) = text $ show n
+ pretty (LitInt _ n) = text $ show n
pretty (LitFloat _ x) = text $ show x
pretty (LitString _ s) = text $ showString' s ""
pretty (LitChar _ c) = text $ "'" ++ showChar' c "" ++ "'"
@@ -37,12 +38,12 @@ showString' s =
foldr (.) id $ [ showString "\"" ] ++ map showChar' s ++ [ showString "\"" ]
showChar' :: Char -> ShowS
-showChar' '"' = showString "\\\""
+showChar' '"' = showString "\\\""
showChar' c
| escapeMe c = showLitChar c
- | otherwise = showString [c]
+ | otherwise = showString [c]
where
- escapeMe c = not (isPrint c) || c == '\\'
+ escapeMe c = not (isPrint c) || c == '\\'
instance Eq Literal where
LitInt _ n == LitInt _ m = n == m
diff --git a/src/full/Agda/Syntax/Notation.hs b/src/full/Agda/Syntax/Notation.hs
index e28f261..71bc525 100644
--- a/src/full/Agda/Syntax/Notation.hs
+++ b/src/full/Agda/Syntax/Notation.hs
@@ -1,11 +1,22 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+{-| As a concrete name, a notation is a non-empty list of alternating 'IdPart's and holes.
+ In contrast to concrete names, holes can be binders.
+
+ Example:
+ @
+ syntax fmap (λ x → e) xs = for x ∈ xs return e
+ @
+
+ The declared notation for @fmap@ is @for_∈_return_@ where the first hole is a binder.
+-}
module Agda.Syntax.Notation where
import Control.Applicative
import Control.Monad
-import Control.Monad.Error (throwError)
import Data.List
import Data.Maybe
@@ -13,89 +24,130 @@ import Data.Typeable (Typeable)
import Agda.Syntax.Common
-#include "../undefined.h"
-import Agda.Utils.Impossible
-
-{-| A name is a non-empty list of alternating 'Id's and 'Hole's. A normal name
- is represented by a singleton list, and operators are represented by a list
- with 'Hole's where the arguments should go. For instance: @[Hole,Id "+",Hole]@
- is infix addition.
+import Agda.Utils.Except ( MonadError(throwError) )
+import Agda.Utils.List
- Equality and ordering on @Name at s are defined to ignore range so same names
- in different locations are equal.
--}
+import Agda.Utils.Impossible
+#include "undefined.h"
-- | Data type constructed in the Happy parser; converted to 'GenPart'
--- before it leaves the Happy code.
-data HoleName = LambdaHole RawName RawName -- ^ (\x -> y) ; 1st argument is the bound name (unused for now)
- | ExprHole RawName -- ^ simple named hole with hiding
-
--- | Target of a hole
-holeName (LambdaHole _ n) = n
-holeName (ExprHole n) = n
+-- before it leaves the Happy code.
+data HoleName
+ = LambdaHole { _bindHoleName :: RawName
+ , holeName :: RawName }
+ -- ^ @\ x -> y@; 1st argument is the bound name (unused for now).
+ | ExprHole { holeName :: RawName }
+ -- ^ Simple named hole with hiding.
+
+-- | Is the hole a binder?
+isLambdaHole :: HoleName -> Bool
+isLambdaHole (LambdaHole _ _) = True
+isLambdaHole _ = False
+-- | Notation as provided by the @syntax@ declaration.
type Notation = [GenPart]
-- | Part of a Notation
-data GenPart = BindHole Int -- ^ Argument is the position of the hole (with binding) where the binding should occur.
- | NormalHole (NamedArg () Int) -- ^ Argument is where the expression should go
- | IdPart RawName
+data GenPart
+ = BindHole Int
+ -- ^ Argument is the position of the hole (with binding) where the binding should occur.
+ | NormalHole (NamedArg () Int)
+ -- ^ Argument is where the expression should go.
+ | IdPart RawName
deriving (Typeable, Show, Eq)
-- | Get a flat list of identifier parts of a notation.
stringParts :: Notation -> [RawName]
stringParts gs = [ x | IdPart x <- gs ]
--- | Target argument position of a part (Nothing if it is not a hole)
+-- | Target argument position of a part (Nothing if it is not a hole).
holeTarget :: GenPart -> Maybe Int
-holeTarget (BindHole n) = Just n
-holeTarget (NormalHole n) = Just (namedArg n)
-holeTarget (IdPart _) = Nothing
+holeTarget (BindHole n) = Just n
+holeTarget (NormalHole n) = Just $ namedArg n
+holeTarget IdPart{} = Nothing
-- | Is the part a hole?
isAHole :: GenPart -> Bool
isAHole = isJust . holeTarget
+-- | Is the part a binder?
+isBindingHole :: GenPart -> Bool
isBindingHole (BindHole _) = True
isBindingHole _ = False
-isLambdaHole (LambdaHole _ _) = True
-isLambdaHole _ = False
-
+-- | Classification of notations.
+
+data NotationKind
+ = InfixNotation -- ^ Ex: @_bla_blub_ at .
+ | PrefixNotation -- ^ Ex: @_bla_blub at .
+ | PostfixNotation -- ^ Ex: @bla_blub_ at .
+ | NonfixNotation -- ^ Ex: @bla_blub at .
+ | NoNotation
+ deriving (Eq)
+
+-- | Classify a notation by presence of leading and/or trailing hole.
+notationKind :: Notation -> NotationKind
+notationKind [] = NoNotation
+notationKind syn =
+ case (isAHole $ head syn, isAHole $ last syn) of
+ (True , True ) -> InfixNotation
+ (True , False) -> PostfixNotation
+ (False, True ) -> PrefixNotation
+ (False, False) -> NonfixNotation
-- | From notation with names to notation with indices.
+--
+-- Example:
+-- @
+-- ids = ["for", "x", "∈", "xs", "return", "e"]
+-- holes = [ LambdaHole "x" "e", ExprHole "xs" ]
+-- @
+-- creates the notation
+-- @
+-- [ IdPart "for" , BindHole 0
+-- , IdPart "∈" , NormalHole 1
+-- , IdPart "return" , NormalHole 0
+-- ]
+-- @
mkNotation :: [NamedArg c HoleName] -> [RawName] -> Either String Notation
mkNotation _ [] = throwError "empty notation is disallowed"
mkNotation holes ids = do
- unless (uniqueNames holes) $ throwError "syntax must use unique argument names"
- let xs = map mkPart ids
+ unless uniqueHoleNames $ throwError "syntax must use unique argument names"
+ let xs :: Notation = map mkPart ids
unless (isAlternating xs) $ throwError "syntax must alternate holes and non-holes"
unless (isExprLinear xs) $ throwError "syntax must use holes exactly once"
unless (isLambdaLinear xs) $ throwError "syntax must use binding holes exactly once"
return xs
- where mkPart ident = fromMaybe (IdPart ident) $ lookup ident holeMap
-
- holeMap = concat $ zipWith mkHole [0..] holes
- where mkHole i h =
- case namedArg h of
- ExprHole x -> [(x, normalHole)]
- LambdaHole x y -> [(x, BindHole i), (y, normalHole)]
- where normalHole = NormalHole $ setArgColors [] $ fmap (i <$) h
-
- uniqueNames hs = nub xs == xs
- where xs = concatMap (names . namedArg) hs
- names (ExprHole x) = [x]
- names (LambdaHole x y) = [x, y]
-
- isExprLinear xs = sort [ namedArg x | NormalHole x <- xs] == [ i | (i, h) <- zip [0..] holes ]
- isLambdaLinear xs = sort [ x | BindHole x <- xs] == [ i | (i, h) <- zip [0..] holes, isLambdaHole (namedArg h) ]
-
- isAlternating :: [GenPart] -> Bool
- isAlternating [] = __IMPOSSIBLE__
- isAlternating [x] = True
- isAlternating (x:y:xs) = isAHole x /= isAHole y && isAlternating (y:xs)
-
-
--- | No notation by default
+ where
+ mkPart ident = fromMaybe (IdPart ident) $ lookup ident holeMap
+
+ holeNumbers = [0 .. length holes - 1]
+ numberedHoles = zip holeNumbers holes
+
+ -- 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 = do
+ (i, h) <- numberedHoles
+ let normalHole = NormalHole $ setArgColors [] $ fmap (i <$) h
+ case namedArg h of
+ ExprHole y -> [(y, normalHole)]
+ LambdaHole x y -> [(x, BindHole i), (y, normalHole)]
+
+ -- Check whether all hole names are distinct.
+ -- The hole names are the keys of the @holeMap at .
+ uniqueHoleNames = distinct $ map fst holeMap
+
+ isExprLinear xs = sort [ namedArg x | NormalHole x <- xs] == holeNumbers
+ isLambdaLinear xs = sort [ x | BindHole x <- xs] == [ i | (i, h) <- numberedHoles, isLambdaHole (namedArg h) ]
+
+ isAlternating :: [GenPart] -> Bool
+ isAlternating [] = __IMPOSSIBLE__
+ isAlternating [x] = True
+ isAlternating (x:y:xs) = isAHole x /= isAHole y && isAlternating (y:xs)
+
+-- | No notation by default.
+defaultNotation, noNotation :: Notation
defaultNotation = []
noNotation = []
diff --git a/src/full/Agda/Syntax/Parser.hs b/src/full/Agda/Syntax/Parser.hs
index 6f54b79..4c764a1 100644
--- a/src/full/Agda/Syntax/Parser.hs
+++ b/src/full/Agda/Syntax/Parser.hs
@@ -32,15 +32,15 @@ import Agda.Utils.FileName
-- Wrapping parse results
wrap :: ParseResult a -> a
-wrap (ParseOk _ x) = x
-wrap (ParseFailed err) = throw err
+wrap (ParseOk _ x) = x
+wrap (ParseFailed err) = throw err
wrapM:: Monad m => m (ParseResult a) -> m a
wrapM m =
- do r <- m
- case r of
- ParseOk _ x -> return x
- ParseFailed err -> throw err
+ do r <- m
+ case r of
+ ParseOk _ x -> return x
+ ParseFailed err -> throw err
------------------------------------------------------------------------
-- Parse functions
diff --git a/src/full/Agda/Syntax/Parser/Alex.hs b/src/full/Agda/Syntax/Parser/Alex.hs
index 0710b68..9149194 100644
--- a/src/full/Agda/Syntax/Parser/Alex.hs
+++ b/src/full/Agda/Syntax/Parser/Alex.hs
@@ -1,10 +1,10 @@
-
{-| This module defines the things required by Alex and some other
Alex related things.
-}
module Agda.Syntax.Parser.Alex
( -- * Alex requirements
AlexInput(..)
+ , lensLexInput
, alexInputPrevChar
, alexGetChar, alexGetByte
-- * Lex actions
@@ -23,14 +23,19 @@ import Data.Word
import Agda.Syntax.Position
import Agda.Syntax.Parser.Monad
+import Agda.Utils.Lens
import Agda.Utils.Monad
-- | This is what the lexer manipulates.
data AlexInput = AlexInput
- { lexPos :: !Position -- ^ current position
- , lexInput :: String -- ^ current input
- , lexPrevChar :: !Char -- ^ previously read character
- }
+ { lexPos :: !Position -- ^ current position
+ , lexInput :: String -- ^ current input
+ , lexPrevChar :: !Char -- ^ previously read character
+ }
+
+-- | A lens for 'lexInput'.
+lensLexInput :: Lens' String AlexInput
+lensLexInput f r = f (lexInput r) <&> \ s -> r { lexInput = s }
-- | Get the previously lexed character. Same as 'lexPrevChar'. Alex needs this
-- to be defined to handle \"patterns with a left-context\".
@@ -44,11 +49,11 @@ alexGetChar :: AlexInput -> Maybe (Char, AlexInput)
alexGetChar (AlexInput { lexInput = [] }) = Nothing
alexGetChar (AlexInput { lexInput = c:s, lexPos = p }) =
Just (c, AlexInput
- { lexInput = s
- , lexPos = movePos p c
- , lexPrevChar = c
- }
- )
+ { lexInput = s
+ , lexPos = movePos p c
+ , lexPrevChar = c
+ }
+ )
-- | A variant of 'alexGetChar'.
--
@@ -66,19 +71,19 @@ alexGetByte ai =
getLexInput :: Parser AlexInput
getLexInput = getInp <$> get
where
- getInp s = AlexInput
- { lexPos = parsePos s
- , lexInput = parseInp s
- , lexPrevChar = parsePrevChar s
- }
+ getInp s = AlexInput
+ { lexPos = parsePos s
+ , lexInput = parseInp s
+ , lexPrevChar = parsePrevChar s
+ }
setLexInput :: AlexInput -> Parser ()
setLexInput inp = modify upd
where
- upd s = s { parsePos = lexPos inp
- , parseInp = lexInput inp
- , parsePrevChar = lexPrevChar inp
- }
+ upd s = s { parsePos = lexPos inp
+ , parseInp = lexInput inp
+ , parsePrevChar = lexPrevChar inp
+ }
{--------------------------------------------------------------------------
Lex actions
diff --git a/src/full/Agda/Syntax/Parser/Comments.hs b/src/full/Agda/Syntax/Parser/Comments.hs
index 7c3ce9f..93426d4 100644
--- a/src/full/Agda/Syntax/Parser/Comments.hs
+++ b/src/full/Agda/Syntax/Parser/Comments.hs
@@ -36,8 +36,8 @@ keepCommentsM = fmap parseKeepComments getParseFlags
-- token.
nestedComment :: LexAction Token
nestedComment inp inp' _ =
- do setLexInput inp'
- runLookAhead err $ skipBlock "{-" "-}"
+ do setLexInput inp'
+ runLookAhead err $ skipBlock "{-" "-}"
keep <- keepCommentsM
if keep then do
inp'' <- getLexInput
@@ -48,7 +48,7 @@ nestedComment inp inp' _ =
genericTake (p2 - p1) $ lexInput inp
return $ TokComment (i, s)
else
- lexToken
+ lexToken
where
err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{-'"
@@ -56,10 +56,10 @@ nestedComment inp inp' _ =
-- Returns @'TokSymbol' 'SymQuestionMark'@.
hole :: LexAction Token
hole inp inp' _ =
- do setLexInput inp'
- runLookAhead err $ skipBlock "{!" "!}"
- p <- lexPos <$> getLexInput
- return $ TokSymbol SymQuestionMark (Interval (lexPos inp) p)
+ do setLexInput inp'
+ runLookAhead err $ skipBlock "{!" "!}"
+ p <- lexPos <$> getLexInput
+ return $ TokSymbol SymQuestionMark (Interval (lexPos inp) p)
where
err _ = liftP $ parseErrorAt (lexPos inp) "Unterminated '{!'"
@@ -68,10 +68,10 @@ hole inp inp' _ =
skipBlock :: String -> String -> LookAhead ()
skipBlock open close = scan 1
where
- scan 0 = sync
- scan n = match [ open ==> scan (n + 1)
- , close ==> scan (n - 1)
- ] `other` scan n
- where
- (==>) = (,)
- other = ($)
+ scan 0 = sync
+ scan n = match [ open ==> scan (n + 1)
+ , close ==> scan (n - 1)
+ ] `other` scan n
+ where
+ (==>) = (,)
+ other = ($)
diff --git a/src/full/Agda/Syntax/Parser/Layout.hs b/src/full/Agda/Syntax/Parser/Layout.hs
index 006eb8e..ceda777 100644
--- a/src/full/Agda/Syntax/Parser/Layout.hs
+++ b/src/full/Agda/Syntax/Parser/Layout.hs
@@ -39,9 +39,9 @@ import Agda.Syntax.Position
-- context.
openBrace :: LexAction Token
openBrace = token $ \_ ->
- do pushContext NoLayout
- i <- getParseInterval
- return (TokSymbol SymOpenBrace i)
+ do pushContext NoLayout
+ i <- getParseInterval
+ return (TokSymbol SymOpenBrace i)
{-| Executed upon lexing a close brace (@\'}\'@). Exits the current layout
@@ -51,9 +51,9 @@ openBrace = token $ \_ ->
-}
closeBrace :: LexAction Token
closeBrace = token $ \_ ->
- do popContext
- i <- getParseInterval
- return (TokSymbol SymCloseBrace i)
+ do popContext
+ i <- getParseInterval
+ return (TokSymbol SymCloseBrace i)
{-| Executed for the first token in each line (see 'Agda.Syntax.Parser.Lexer.bol').
@@ -61,31 +61,31 @@ closeBrace = token $ \_ ->
If the token is
- /to the left/ :
- Exit the current context and a return virtual close brace (stay in the
- 'Agda.Syntax.Parser.Lexer.bol' state).
+ Exit the current context and a return virtual close brace (stay in the
+ 'Agda.Syntax.Parser.Lexer.bol' state).
- /same column/ :
- Exit the 'Agda.Syntax.Parser.Lexer.bol' state and return a virtual semi
- colon.
+ Exit the 'Agda.Syntax.Parser.Lexer.bol' state and return a virtual semi
+ colon.
- /to the right/ :
- Exit the 'Agda.Syntax.Parser.Lexer.bol' state and continue lexing.
+ Exit the 'Agda.Syntax.Parser.Lexer.bol' state and continue lexing.
If the current block doesn't use layout (i.e. it was started by
'openBrace') all positions are considered to be /to the right/.
-}
offsideRule :: LexAction Token
offsideRule inp _ _ =
- do offs <- getOffside p
- case offs of
- LT -> do popContext
- return (TokSymbol SymCloseVirtualBrace (Interval p p))
- EQ -> do popLexState
- return (TokSymbol SymVirtualSemi (Interval p p))
- GT -> do popLexState
- lexToken
+ do offs <- getOffside p
+ case offs of
+ LT -> do popContext
+ return (TokSymbol SymCloseVirtualBrace (Interval p p))
+ EQ -> do popLexState
+ return (TokSymbol SymVirtualSemi (Interval p p))
+ GT -> do popLexState
+ lexToken
where
- p = lexPos inp
+ p = lexPos inp
{-| This action is only executed from the 'Agda.Syntax.Parser.Lexer.empty_layout'
@@ -95,11 +95,11 @@ offsideRule inp _ _ =
-}
emptyLayout :: LexAction Token
emptyLayout inp _ _ =
- do popLexState
- pushLexState bol
- return (TokSymbol SymCloseVirtualBrace (Interval p p))
+ do popLexState
+ pushLexState bol
+ return (TokSymbol SymCloseVirtualBrace (Interval p p))
where
- p = lexPos inp
+ p = lexPos inp
{-| Start a new layout context. This is one of two ways to get out of the
@@ -125,24 +125,24 @@ emptyLayout inp _ _ =
-}
newLayoutContext :: LexAction Token
newLayoutContext inp _ _ =
- do let offset = posCol p
- ctx <- topContext
- case ctx of
- Layout prevOffs | prevOffs >= offset ->
- do pushLexState empty_layout
- return (TokSymbol SymOpenVirtualBrace (Interval p p))
- _ ->
- do pushContext (Layout offset)
- return (TokSymbol SymOpenVirtualBrace (Interval p p))
+ do let offset = posCol p
+ ctx <- topContext
+ case ctx of
+ Layout prevOffs | prevOffs >= offset ->
+ do pushLexState empty_layout
+ return (TokSymbol SymOpenVirtualBrace (Interval p p))
+ _ ->
+ do pushContext (Layout offset)
+ return (TokSymbol SymOpenVirtualBrace (Interval p p))
where
- p = lexPos inp
+ p = lexPos inp
-- | Compute the relative position of a location to the
-- current layout context.
getOffside :: Position -> Parser Ordering
getOffside loc =
- do ctx <- topContext
- return $ case ctx of
- Layout n -> compare (posCol loc) n
- _ -> GT
+ do ctx <- topContext
+ return $ case ctx of
+ Layout n -> compare (posCol loc) n
+ _ -> GT
diff --git a/src/full/Agda/Syntax/Parser/LexActions.hs b/src/full/Agda/Syntax/Parser/LexActions.hs
index 0ec1e35..dfd93a0 100644
--- a/src/full/Agda/Syntax/Parser/LexActions.hs
+++ b/src/full/Agda/Syntax/Parser/LexActions.hs
@@ -29,9 +29,9 @@ import Agda.Syntax.Parser.Tokens
import Agda.Syntax.Position
import Agda.Syntax.Literal
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Tuple
-import Agda.Utils.Unicode
{--------------------------------------------------------------------------
Scan functions
@@ -41,8 +41,8 @@ import Agda.Utils.Unicode
returnEOF :: AlexInput -> Parser Token
returnEOF inp =
do setLastPos $ lexPos inp
- setPrevToken "<EOF>"
- return TokEOF
+ setPrevToken "<EOF>"
+ return TokEOF
-- | Set the current input and lex a new token (calls 'lexToken').
skipTo :: AlexInput -> Parser Token
@@ -55,14 +55,14 @@ used by the parser is the continuation version of this function.
-}
lexToken :: Parser Token
lexToken =
- do inp <- getLexInput
- lss@(ls:_) <- getLexState
+ do inp <- getLexInput
+ lss@(ls:_) <- getLexState
flags <- getParseFlags
- case alexScanUser (lss, flags) (foolAlex inp) ls of
- AlexEOF -> returnEOF inp
- AlexSkip inp' len -> skipTo (newInput inp inp' len)
- AlexToken inp' len action -> fmap postToken $ action inp (newInput inp inp' len) len
- AlexError i -> parseError $ "Lexical error" ++
+ case alexScanUser (lss, flags) (foolAlex inp) ls of
+ AlexEOF -> returnEOF inp
+ AlexSkip inp' len -> skipTo (newInput inp inp' len)
+ AlexToken inp' len action -> fmap postToken $ action inp (newInput inp inp' len) len
+ AlexError i -> parseError $ "Lexical error" ++
(case lexInput i of
'\t' : _ -> " (you may want to replace tabs with spaces)"
_ -> "") ++
@@ -88,23 +88,27 @@ postToken t = t
newInput :: PreviousInput -> CurrentInput -> TokenLength -> CurrentInput
newInput inp inp' len =
case drop (len - 1) (lexInput inp) of
- c:s' -> inp' { lexInput = s'
- , lexPrevChar = c
- }
- [] -> inp' { lexInput = [] } -- we do get empty tokens moving between states
+ c:s' -> inp' { lexInput = s'
+ , lexPrevChar = c
+ }
+ [] -> inp' { lexInput = [] } -- we do get empty tokens moving between states
-- | Alex 2 can't handle unicode characters. To solve this we
-- translate all Unicode (non-ASCII) identifiers to @z@, all Unicode
-- operator characters to @+@, and all whitespace characters (except
--- for @\t@ and @\n@) to ' '. It is important that there aren't any
--- keywords containing @z@, @+@ or @ @.
+-- for @\t@ and @\n@) to ' '.
+-- Further, non-printable Unicode characters are translated to an
+-- arbitrary, harmless ASCII non-printable character, @'\1'@.
+--
+-- It is important that there aren't any keywords containing @z@, @+@ or @ @.
+
foolAlex :: AlexInput -> AlexInput
-foolAlex inp = inp { lexInput = map fool $ lexInput inp }
- where
- fool c
- | isSpace c && not (c `elem` "\t\n") = ' '
- | isUnicodeId c = if isAlpha c then 'z' else '+'
- | otherwise = c
+foolAlex = over lensLexInput $ map $ \ c ->
+ case c of
+ _ | isSpace c && not (c `elem` "\t\n") -> ' '
+ _ | isAscii c -> c
+ _ | isPrint c -> if isAlpha c then 'z' else '+'
+ _ | otherwise -> '\1'
{--------------------------------------------------------------------------
Lex actions
@@ -114,17 +118,17 @@ foolAlex inp = inp { lexInput = map fool $ lexInput inp }
token :: (String -> Parser tok) -> LexAction tok
token action inp inp' len =
do setLexInput inp'
- setPrevToken t
- setLastPos $ lexPos inp
- action t
+ setPrevToken t
+ setLastPos $ lexPos inp
+ action t
where
- t = take len $ lexInput inp
+ t = take len $ lexInput inp
-- | Parse a token from an 'Interval' and the lexed string.
withInterval :: ((Interval, String) -> tok) -> LexAction tok
withInterval f = token $ \s -> do
r <- getParseInterval
- return $ f (r,s)
+ return $ f (r,s)
-- | Like 'withInterval', but applies a function to the string.
withInterval' :: (String -> a) -> ((Interval, a) -> tok) -> LexAction tok
@@ -139,50 +143,50 @@ withInterval_ f = withInterval (f . fst)
-- state and performs the given action.
withLayout :: LexAction r -> LexAction r
withLayout a i1 i2 n =
- do pushLexState layout
- a i1 i2 n
+ do pushLexState layout
+ a i1 i2 n
-- | Enter a new state without consuming any input.
begin :: LexState -> LexAction Token
begin code _ _ _ =
- do pushLexState code
- lexToken
+ do pushLexState code
+ lexToken
-- | Enter a new state throwing away the current lexeme.
begin_ :: LexState -> LexAction Token
begin_ code _ inp' _ =
- do pushLexState code
- skipTo inp'
+ do pushLexState code
+ skipTo inp'
-- | Exit the current state throwing away the current lexeme.
end_ :: LexAction Token
end_ _ inp' _ =
- do popLexState
- skipTo inp'
+ do popLexState
+ skipTo inp'
-- | Exit the current state and perform the given action.
endWith :: LexAction a -> LexAction a
endWith a inp inp' n =
- do popLexState
- a inp inp' n
+ do popLexState
+ a inp inp' n
-- | Exit the current state without consuming any input
end :: LexAction Token
end _ _ _ =
- do popLexState
- lexToken
+ do popLexState
+ lexToken
-- | Parse a 'Keyword' token, triggers layout for 'layoutKeywords'.
keyword :: Keyword -> LexAction Token
keyword k = layout $ withInterval_ (TokKeyword k)
where
- layout | elem k layoutKeywords = withLayout
- | otherwise = id
+ layout | elem k layoutKeywords = withLayout
+ | otherwise = id
-- | Parse a 'Symbol' token.
@@ -206,24 +210,24 @@ qualified :: (Either (Interval, String) [(Interval, String)] -> a) -> LexAction
qualified tok =
token $ \s ->
do i <- getParseInterval
- case mkName i $ wordsBy (=='.') s of
- [] -> lexError "lex error on .."
- [x] -> return $ tok $ Left x
- xs -> return $ tok $ Right xs
+ case mkName i $ wordsBy (=='.') s of
+ [] -> lexError "lex error on .."
+ [x] -> return $ tok $ Left x
+ xs -> return $ tok $ Right xs
where
- -- 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 _ [] = []
- mkName i [x] = [(i, x)]
- mkName i (x:xs) = (i0, x) : mkName i1 xs
- where
- p0 = iStart i
- p1 = iEnd i
- p' = movePos (movePosByString p0 x) '.'
- i0 = Interval p0 p'
- i1 = Interval p' p1
+ -- 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 _ [] = []
+ mkName i [x] = [(i, x)]
+ mkName i (x:xs) = (i0, x) : mkName i1 xs
+ where
+ p0 = iStart i
+ p1 = iEnd i
+ p' = movePos (movePosByString p0 x) '.'
+ i0 = Interval p0 p'
+ i1 = Interval p' p1
{--------------------------------------------------------------------------
@@ -234,8 +238,8 @@ qualified tok =
followedBy :: Char -> LexPredicate
followedBy c' _ _ _ inp =
case lexInput inp of
- [] -> False
- c:_ -> c == c'
+ [] -> False
+ c:_ -> c == c'
-- | True if we are at the end of the file.
eof :: LexPredicate
diff --git a/src/full/Agda/Syntax/Parser/Lexer.x b/src/full/Agda/Syntax/Parser/Lexer.x
index 5618879..d861d35 100644
--- a/src/full/Agda/Syntax/Parser/Lexer.x
+++ b/src/full/Agda/Syntax/Parser/Lexer.x
@@ -1,7 +1,11 @@
{
-{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
{-# LANGUAGE BangPatterns #-}
+
{-| The lexer is generated by Alex (<http://www.haskell.org/alex>) and is an
adaptation of GHC's lexer. The main lexing function 'lexer' is called by
the "Agda.Syntax.Parser.Parser" to get the next token from the input.
@@ -31,21 +35,24 @@ import Agda.Syntax.Literal
}
-$digit = 0-9
+-- Unicode is not handled by the following regular expressions.
+-- Instead, unicode characters are translated to 7-bit ASCII
+-- by Agda.Syntax.Parser.LexActions.foolAlex in a preprocessing pass.
+
+$digit = 0-9
$hexdigit = [ $digit a-f A-F ]
-$alpha = [ A-Z a-z _ ]
-$op = [ \- \! \# \$ \% \& \* \+ \/ \< \= \> \^ \| \~ \? \` \[ \] \, \: ]
+$alpha = [ A-Z a-z _ ]
+$op = [ \- \! \# \$ \% \& \* \+ \/ \< \= \> \^ \| \~ \? \` \[ \] \, \: ]
$idstart = [ $digit $alpha $op ]
-$idchar = [ $idstart ' \\ ]
-$endcomment = ~ [ $idchar ]
+$idchar = [ $idstart ' \\ ]
$nonalpha = $idchar # $alpha
$nonalphanum = $nonalpha # $digit
$white_notab = $white # \t
$white_nonl = $white_notab # \n
- at number = $digit+ | "0x" $hexdigit+
+ at number = $digit+ | "0x" $hexdigit+
@exponent = [eE] [\-\+]? @number
- at float = @number \. @number @exponent? | @number @exponent
+ at float = @number \. @number @exponent? | @number @exponent
-- A name can't start with \x (to allow \x -> x).
-- Bug in alex: [ _ op ]+ doesn't seem to work!
@@ -60,7 +67,7 @@ tokens :-
-- Lexing literate files
<tex> $white_nonl* \\ "begin{code}" $white_nonl* $ { end_ }
<tex> .+ / { keepComments } { withInterval TokTeX }
-<tex> .+ ;
+<tex> .+ ;
<tex> \n ;
<tex> () / { eof } { end_ }
<bol_,layout_>
@@ -74,9 +81,9 @@ tokens :-
<pragma_> $white_notab ;
-- Pragmas
-<0,code> "{-#" { begin pragma }
-<pragma_> "{-#" { symbol SymOpenPragma }
-<pragma_> "#-}" { endWith $ symbol SymClosePragma }
+<0,code> "{-#" { begin pragma }
+<pragma_> "{-#" { symbol SymOpenPragma }
+<pragma_> "#-}" { endWith $ symbol SymClosePragma }
<pragma_> "OPTIONS" { keyword KwOPTIONS }
<pragma_> "BUILTIN" { keyword KwBUILTIN }
<pragma_> "REWRITE" { keyword KwREWRITE }
@@ -92,6 +99,7 @@ tokens :-
<pragma_> "ETA" { keyword KwETA }
<pragma_> "NO_TERMINATION_CHECK" { keyword KwNO_TERMINATION_CHECK }
<pragma_> "NON_TERMINATING" { keyword KwNON_TERMINATING }
+<pragma_> "TERMINATING" { keyword KwTERMINATING }
<pragma_> "MEASURE" { keyword KwMEASURE }
<pragma_> "LINE" { keyword KwLINE }
<pragma_> . # [ $white ] + { withInterval $ TokString }
@@ -115,110 +123,110 @@ tokens :-
-- We need to check the offside rule for the first token on each line. We
-- should not check the offside rule for the end of file token or an
-- '\end{code}'
-<0,code,imp_dir_> \n { begin bol_ }
+<0,code,imp_dir_> \n { begin bol_ }
<bol_>
{
- \n ;
--- ^ \\ "end{code}" { end }
- () / { not' eof } { offsideRule }
+ \n ;
+-- ^ \\ "end{code}" { end }
+ () / { not' eof } { offsideRule }
}
-- After a layout keyword there is either an open brace (no layout) or the
-- indentation of the first token decides the column of the layout block.
<layout_>
- { \n ;
--- \{ { endWith openBrace }
- () { endWith newLayoutContext }
+ { \n ;
+-- \{ { endWith openBrace }
+ () { endWith newLayoutContext }
}
-- The only rule for the empty_layout state. Generates a close brace.
-<empty_layout_> () { emptyLayout }
+<empty_layout_> () { emptyLayout }
-- Keywords
-<0,code> let { keyword KwLet }
-<0,code> in { keyword KwIn }
-<0,code> where { keyword KwWhere }
-<0,code> field { keyword KwField }
+<0,code> let { keyword KwLet }
+<0,code> in { keyword KwIn }
+<0,code> where { keyword KwWhere }
+<0,code> field { keyword KwField }
<0,code> with { keyword KwWith }
<0,code> rewrite { keyword KwRewrite }
-<0,code> postulate { keyword KwPostulate }
-<0,code> primitive { keyword KwPrimitive }
-<0,code> open { keyword KwOpen }
-<0,code> import { keyword KwImport }
-<0,code> module { keyword KwModule }
-<0,code> data { keyword KwData }
-<0,code> codata { keyword KwCoData }
-<0,code> record { keyword KwRecord }
+<0,code> postulate { keyword KwPostulate }
+<0,code> primitive { keyword KwPrimitive }
+<0,code> open { keyword KwOpen }
+<0,code> import { keyword KwImport }
+<0,code> module { keyword KwModule }
+<0,code> data { keyword KwData }
+<0,code> codata { keyword KwCoData }
+<0,code> record { keyword KwRecord }
<0,code> constructor { keyword KwConstructor }
<0,code> inductive { keyword KwInductive }
<0,code> coinductive { keyword KwCoInductive }
-<0,code> infix { keyword KwInfix }
-<0,code> infixl { keyword KwInfixL }
-<0,code> infixr { keyword KwInfixR }
-<0,code> mutual { keyword KwMutual }
-<0,code> abstract { keyword KwAbstract }
-<0,code> private { keyword KwPrivate }
-<0,code> instance { keyword KwInstance }
-<0,code> Set { keyword KwSet }
-<0,code> Prop { keyword KwProp }
-<0,code> forall { keyword KwForall }
-<0,code> Set @number { withInterval' (read . drop 3) TokSetN }
-<0,code> quoteGoal { keyword KwQuoteGoal }
-<0,code> quoteContext { keyword KwQuoteContext }
-<0,code> quote { keyword KwQuote }
-<0,code> quoteTerm { keyword KwQuoteTerm }
-<0,code> unquote { keyword KwUnquote }
-<0,code> unquoteDecl { keyword KwUnquoteDecl }
-<0,code> tactic { keyword KwTactic }
-<0,code> syntax { keyword KwSyntax }
-<0,code> pattern { keyword KwPatternSyn }
+<0,code> infix { keyword KwInfix }
+<0,code> infixl { keyword KwInfixL }
+<0,code> infixr { keyword KwInfixR }
+<0,code> mutual { keyword KwMutual }
+<0,code> abstract { keyword KwAbstract }
+<0,code> private { keyword KwPrivate }
+<0,code> instance { keyword KwInstance }
+<0,code> Set { keyword KwSet }
+<0,code> Prop { keyword KwProp }
+<0,code> forall { keyword KwForall }
+<0,code> Set @number { withInterval' (read . drop 3) TokSetN }
+<0,code> quoteGoal { keyword KwQuoteGoal }
+<0,code> quoteContext { keyword KwQuoteContext }
+<0,code> quote { keyword KwQuote }
+<0,code> quoteTerm { keyword KwQuoteTerm }
+<0,code> unquote { keyword KwUnquote }
+<0,code> unquoteDecl { keyword KwUnquoteDecl }
+<0,code> tactic { keyword KwTactic }
+<0,code> syntax { keyword KwSyntax }
+<0,code> pattern { keyword KwPatternSyn }
-- The parser is responsible to put the lexer in the imp_dir_ state when it
-- expects an import directive keyword. This means that if you run the
-- tokensParser you will never see these keywords.
-<0,code> using { keyword KwUsing }
-<0,code> hiding { keyword KwHiding }
+<0,code> using { keyword KwUsing }
+<0,code> hiding { keyword KwHiding }
<0,code> renaming { keyword KwRenaming }
-<imp_dir_> to { endWith $ keyword KwTo }
-<0,code> public { keyword KwPublic }
+<imp_dir_> to { endWith $ keyword KwTo }
+<0,code> public { keyword KwPublic }
-- Holes
-<0,code> "{!" { hole }
+<0,code> "{!" { hole }
-- Special symbols
-<0,code> "..." { symbol SymEllipsis }
-<0,code> ".." { symbol SymDotDot }
-<0,code> "." { symbol SymDot }
-<0,code> ";" { symbol SymSemi }
-<0,code> ":" { symbol SymColon }
-<0,code> "=" { symbol SymEqual }
-<0,code> "_" { symbol SymUnderscore }
-<0,code> "?" { symbol SymQuestionMark }
-<0,code> "|" { symbol SymBar }
-<0,code> "(" { symbol SymOpenParen }
-<0,code> ")" { symbol SymCloseParen }
-<0,code> "->" { symbol SymArrow }
-<0,code> "\" { symbol SymLambda } -- "
-<0,code> "@" { symbol SymAs }
-<0,code> "{{" /[^!] { symbol SymDoubleOpenBrace }
+<0,code> "..." { symbol SymEllipsis }
+<0,code> ".." { symbol SymDotDot }
+<0,code> "." { symbol SymDot }
+<0,code> ";" { symbol SymSemi }
+<0,code> ":" { symbol SymColon }
+<0,code> "=" { symbol SymEqual }
+<0,code> "_" { symbol SymUnderscore }
+<0,code> "?" { symbol SymQuestionMark }
+<0,code> "|" { symbol SymBar }
+<0,code> "(" { symbol SymOpenParen }
+<0,code> ")" { symbol SymCloseParen }
+<0,code> "->" { symbol SymArrow }
+<0,code> "\" { symbol SymLambda } -- "
+<0,code> "@" { symbol SymAs }
+<0,code> "{{" /[^!] { symbol SymDoubleOpenBrace }
-- We don't lex '}}' into a SymDoubleCloseBrace. Instead, we lex it as
-- two SymCloseBrace's. When the parser is looking for a double
-- closing brace, it will also accept two SymCloseBrace's, after
-- verifying that they are immediately next to each other.
-- This trick allows us to keep "record { a = record {}}" working
-- properly.
--- <0,code> "}}" { symbol SymDoubleCloseBrace }
-<0,code> "{" { symbol SymOpenBrace } -- you can't use braces for layout
-<0,code> "}" { symbol SymCloseBrace }
+-- <0,code> "}}" { symbol SymDoubleCloseBrace }
+<0,code> "{" { symbol SymOpenBrace } -- you can't use braces for layout
+<0,code> "}" { symbol SymCloseBrace }
-- Literals
-<0,code> \' { litChar }
-<0,code> \" { litString }
-<0,code> @number { literal LitInt }
-<0,code> @float { literal LitFloat }
+<0,code> \' { litChar }
+<0,code> \" { litString }
+<0,code> @number { literal LitInt }
+<0,code> @float { literal LitFloat }
-- Identifiers
-<0,code,imp_dir_> @q_ident { identifier }
+<0,code,imp_dir_> @q_ident { identifier }
-- Andreas, 2013-02-21, added identifiers to the 'imp_dir_' state.
-- This is to fix issue 782: 'toz' should not be lexed as 'to'
-- (followed by 'z' after leaving imp_dir_).
diff --git a/src/full/Agda/Syntax/Parser/LookAhead.hs b/src/full/Agda/Syntax/Parser/LookAhead.hs
index 3cb543d..c683627 100644
--- a/src/full/Agda/Syntax/Parser/LookAhead.hs
+++ b/src/full/Agda/Syntax/Parser/LookAhead.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE Rank2Types, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE Rank2Types #-}
{-| When lexing by hands (for instance string literals) we need to do some
looking ahead. The 'LookAhead' monad keeps track of the position we are
@@ -34,8 +35,8 @@ import Agda.Syntax.Parser.Monad
-}
newtype LookAhead a =
LookAhead { unLookAhead :: ReaderT ErrorFunction
- (StateT AlexInput Parser) a
- }
+ (StateT AlexInput Parser) a
+ }
deriving (Functor, Applicative)
newtype ErrorFunction =
@@ -49,8 +50,8 @@ instance Monad LookAhead where
return = LookAhead . return
m >>= k = LookAhead $ unLookAhead m >>= unLookAhead . k
fail s =
- do err <- LookAhead ask
- throwError err s
+ do err <- LookAhead ask
+ throwError err s
{--------------------------------------------------------------------------
Operations
@@ -74,34 +75,34 @@ liftP = LookAhead . lift . lift
-- | Look at the next character. Fails if there are no more characters.
nextChar :: LookAhead Char
nextChar =
- do inp <- getInput
- case alexGetChar inp of
- Nothing -> fail "unexpected end of file"
- Just (c,inp') ->
- do setInput inp'
- return c
+ do inp <- getInput
+ case alexGetChar inp of
+ Nothing -> fail "unexpected end of file"
+ Just (c,inp') ->
+ do setInput inp'
+ return c
-- | Consume all the characters up to the current look-ahead position.
sync :: LookAhead ()
sync =
- do inp <- getInput
- liftP $ setLexInput inp
+ do inp <- getInput
+ liftP $ setLexInput inp
-- | Undo look-ahead. Restores the input from the 'ParseState'.
rollback :: LookAhead ()
rollback =
- do inp <- liftP getLexInput
- setInput inp
+ do inp <- liftP getLexInput
+ setInput inp
-- | Consume the next character. Does 'nextChar' followed by 'sync'.
eatNextChar :: LookAhead Char
eatNextChar =
- do c <- nextChar
- sync
- return c
+ do c <- nextChar
+ sync
+ return c
{-| Do a case on the current input string. If any of the given strings match we
@@ -111,8 +112,8 @@ eatNextChar =
-}
match :: [(String, LookAhead a)] -> LookAhead a -> LookAhead a
match xs def =
- do c <- nextChar
- match' c xs def
+ do c <- nextChar
+ match' c xs def
{-| Same as 'match' but takes the initial character from the first argument
instead of reading it from the input. Consequently, in the default case
@@ -120,19 +121,19 @@ match xs def =
-}
match' :: Char -> [(String, LookAhead a)] -> LookAhead a -> LookAhead a
match' c xs def =
- do inp <- getInput
- match'' inp xs c
+ do inp <- getInput
+ match'' inp xs c
where
- match'' inp bs c =
- case bs' of
- [] -> setInput inp >> def
- [("",p)] -> p
- _ -> match'' inp bs' =<< nextChar
- where
- bs' = [ (s, p) | (c':s, p) <- bs, c == c' ]
+ match'' inp bs c =
+ case bs' of
+ [] -> setInput inp >> def
+ [("",p)] -> p
+ _ -> match'' inp bs' =<< nextChar
+ where
+ bs' = [ (s, p) | (c':s, p) <- bs, c == c' ]
-- | Run a 'LookAhead' computation. The first argument is the error function.
runLookAhead :: (forall b. String -> LookAhead b) -> LookAhead a -> Parser a
runLookAhead err (LookAhead m) =
- do inp <- getLexInput
- evalStateT (runReaderT m (ErrorFun err)) inp
+ do inp <- getLexInput
+ evalStateT (runReaderT m (ErrorFun err)) inp
diff --git a/src/full/Agda/Syntax/Parser/Monad.hs b/src/full/Agda/Syntax/Parser/Monad.hs
index ab0a34a..c5cb2d6 100644
--- a/src/full/Agda/Syntax/Parser/Monad.hs
+++ b/src/full/Agda/Syntax/Parser/Monad.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
module Agda.Syntax.Parser.Monad
( -- * The parser monad
Parser
@@ -33,11 +35,12 @@ import Data.Int
import Data.Typeable
import Control.Monad.State
-import Control.Monad.Error
import Control.Applicative
import Agda.Syntax.Position
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
+
import Agda.Utils.FileName
import qualified Agda.Utils.IO.UTF8 as UTF8
@@ -53,15 +56,15 @@ newtype Parser a = P { unP :: ParseState -> ParseResult a }
-- | The parser state. Contains everything the parser and the lexer could ever
-- need.
data ParseState = PState
- { parsePos :: !Position -- ^ position at current input location
- , parseLastPos :: !Position -- ^ position of last token
- , parseInp :: String -- ^ the current input
- , parsePrevChar :: !Char -- ^ the character before the input
- , parsePrevToken:: String -- ^ the previous token
- , parseLayout :: [LayoutContext] -- ^ the stack of layout contexts
- , parseLexState :: [LexState] -- ^ the state of the lexer
- -- (states can be nested so we need a stack)
- , parseFlags :: ParseFlags -- ^ currently there are no flags
+ { parsePos :: !Position -- ^ position at current input location
+ , parseLastPos :: !Position -- ^ position of last token
+ , parseInp :: String -- ^ the current input
+ , parsePrevChar :: !Char -- ^ the character before the input
+ , parsePrevToken:: String -- ^ the previous token
+ , parseLayout :: [LayoutContext] -- ^ the stack of layout contexts
+ , parseLexState :: [LexState] -- ^ the state of the lexer
+ -- (states can be nested so we need a stack)
+ , parseFlags :: ParseFlags -- ^ currently there are no flags
}
deriving Show
@@ -74,48 +77,48 @@ type LexState = Int
-- | We need to keep track of the context to do layout. The context
-- specifies the indentation (if any) of a layout block. See
-- "Agda.Syntax.Parser.Layout" for more informaton.
-data LayoutContext = NoLayout -- ^ no layout
- | Layout Int32 -- ^ layout at specified column
+data LayoutContext = NoLayout -- ^ no layout
+ | Layout Int32 -- ^ layout at specified column
deriving Show
-- | There aren't any parser flags at the moment.
-data ParseFlags = ParseFlags
+data ParseFlags = ParseFlags
{ parseKeepComments :: Bool
-- ^ Should comment tokens be returned by the lexer?
}
deriving Show
-- | What you get if parsing fails.
-data ParseError = ParseError
- { errPos :: Position -- ^ where the error occured
- , errInput :: String -- ^ the remaining input
- , errPrevToken :: String -- ^ the previous token
- , errMsg :: String -- ^ hopefully an explanation
- -- of what happened
- }
+data ParseError = ParseError
+ { errPos :: Position -- ^ where the error occured
+ , errInput :: String -- ^ the remaining input
+ , errPrevToken :: String -- ^ the previous token
+ , errMsg :: String -- ^ hopefully an explanation
+ -- of what happened
+ }
deriving (Typeable)
instance Exception ParseError
-- | The result of parsing something.
data ParseResult a = ParseOk ParseState a
- | ParseFailed ParseError
+ | ParseFailed ParseError
{--------------------------------------------------------------------------
Instances
--------------------------------------------------------------------------}
instance Monad Parser where
- return x = P $ \s -> ParseOk s x
- P m >>= f = P $ \s -> case m s of
- ParseFailed e -> ParseFailed e
- ParseOk s' x -> unP (f x) s'
- fail msg = P $ \s -> ParseFailed $
- ParseError { errPos = parseLastPos s
- , errInput = parseInp s
- , errPrevToken = parsePrevToken s
- , errMsg = msg
- }
+ return x = P $ \s -> ParseOk s x
+ P m >>= f = P $ \s -> case m s of
+ ParseFailed e -> ParseFailed e
+ ParseOk s' x -> unP (f x) s'
+ fail msg = P $ \s -> ParseFailed $
+ ParseError { errPos = parseLastPos s
+ , errInput = parseInp s
+ , errPrevToken = parsePrevToken s
+ , errMsg = msg
+ }
instance Functor Parser where
fmap = liftM
@@ -125,33 +128,33 @@ instance Applicative Parser where
(<*>) = ap
instance MonadError ParseError Parser where
- throwError e = P $ \_ -> ParseFailed e
- P m `catchError` h = P $ \s -> case m s of
- ParseFailed err -> unP (h err) s
- m' -> m'
+ throwError e = P $ \_ -> ParseFailed e
+ P m `catchError` h = P $ \s -> case m s of
+ ParseFailed err -> unP (h err) s
+ m' -> m'
instance MonadState ParseState Parser where
- get = P $ \s -> ParseOk s s
+ get = P $ \s -> ParseOk s s
put s = P $ \_ -> ParseOk s ()
instance Show ParseError where
show err =
- unlines
- [ pos ++ ": " ++ errMsg err
- --, replicate (length pos + 2) ' ' ++ "on '" ++ errPrevToken err ++ "'"
+ unlines
+ [ pos ++ ": " ++ errMsg err
+ --, replicate (length pos + 2) ' ' ++ "on '" ++ errPrevToken err ++ "'"
, errPrevToken err ++ "<ERROR>\n" ++ take 30 (errInput err) ++ "..."
- ]
- where
- pos = show (errPos err)
+ ]
+ where
+ pos = show (errPos err)
--- showInp "" = "at end of file"
--- showInp t = "on input " ++ elide 5 t
+-- showInp "" = "at end of file"
+-- showInp t = "on input " ++ elide 5 t
--
--- elide 3 s
--- | length (take 4 s) < 4 = s
--- | otherwise = "..."
--- elide n (c:s) = c : elide (n - 1) s
--- elide _ "" = ""
+-- elide 3 s
+-- | length (take 4 s) < 4 = s
+-- | otherwise = "..."
+-- elide n (c:s) = c : elide (n - 1) s
+-- elide _ "" = ""
instance HasRange ParseError where
getRange err = posToRange (errPos err) (errPos err)
@@ -162,15 +165,15 @@ instance HasRange ParseError where
initStatePos :: Position -> ParseFlags -> String -> [LexState] -> ParseState
initStatePos pos flags inp st =
- PState { parsePos = pos
- , parseLastPos = pos
- , parseInp = inp
- , parsePrevChar = '\n'
- , parsePrevToken = ""
- , parseLexState = st
- , parseLayout = [NoLayout]
- , parseFlags = flags
- }
+ PState { parsePos = pos
+ , parseLastPos = pos
+ , parseInp = inp
+ , parsePrevChar = '\n'
+ , parsePrevToken = ""
+ , parseLexState = st
+ , parseLayout = [NoLayout]
+ , parseFlags = flags
+ }
-- | Constructs the initial state of the parser. The string argument
-- is the input string, the file path is only there because it's part
@@ -203,8 +206,8 @@ parsePosString pos flags st p input = unP p (initStatePos pos flags input st)
parseFile :: ParseFlags -> [LexState] -> Parser a -> AbsolutePath
-> IO (ParseResult a)
parseFile flags st p file =
- do input <- liftIO $ UTF8.readTextFile $ filePath file
- return $ unP p (initState (Just file) flags input st)
+ do input <- liftIO $ UTF8.readTextFile $ filePath file
+ return $ unP p (initState (Just file) flags input st)
{--------------------------------------------------------------------------
Manipulating the state
@@ -225,24 +228,24 @@ getLastPos = get >>= return . parseLastPos
-- | The parse interval is between the last position and the current position.
getParseInterval :: Parser Interval
getParseInterval =
- do s <- get
- return $ Interval (parseLastPos s) (parsePos s)
+ do s <- get
+ return $ Interval (parseLastPos s) (parsePos s)
getLexState :: Parser [LexState]
getLexState = parseLexState <$> get
setLexState :: [LexState] -> Parser ()
setLexState ls =
- do s <- get
- put $ s { parseLexState = ls }
+ do s <- get
+ put $ s { parseLexState = ls }
pushLexState :: LexState -> Parser ()
pushLexState l = do s <- getLexState
- setLexState (l:s)
+ setLexState (l:s)
popLexState :: Parser ()
popLexState = do _:ls <- getLexState
- setLexState ls
+ setLexState ls
getParseFlags :: Parser ParseFlags
getParseFlags = parseFlags <$> get
@@ -259,8 +262,8 @@ parseError = fail
-- comment.
parseErrorAt :: Position -> String -> Parser a
parseErrorAt p msg =
- do setLastPos p
- parseError msg
+ do setLastPos p
+ parseError msg
-- | Use 'parseErrorAt' or 'parseError' as appropriate.
parseError' :: Maybe Position -> String -> Parser a
@@ -273,8 +276,8 @@ parseError' = maybe parseError parseErrorAt
-- lexed). This function does 'parseErrorAt' the current position.
lexError :: String -> Parser a
lexError msg =
- do p <- parsePos <$> get
- parseErrorAt p msg
+ do p <- parsePos <$> get
+ parseErrorAt p msg
{--------------------------------------------------------------------------
Layout
@@ -285,33 +288,33 @@ getContext = parseLayout <$> get
setContext :: [LayoutContext] -> Parser ()
setContext ctx =
- do s <- get
- put $ s { parseLayout = ctx }
+ do s <- get
+ put $ s { parseLayout = ctx }
-- | Return the current layout context.
topContext :: Parser LayoutContext
topContext =
- do ctx <- getContext
- case ctx of
- [] -> parseError "No layout context in scope"
- l:_ -> return l
+ do ctx <- getContext
+ case ctx of
+ [] -> parseError "No layout context in scope"
+ l:_ -> return l
popContext :: Parser ()
popContext =
- do ctx <- getContext
- case ctx of
- [] -> parseError "There is no layout block to close at this point."
- _:ctx -> setContext ctx
+ do ctx <- getContext
+ case ctx of
+ [] -> parseError "There is no layout block to close at this point."
+ _:ctx -> setContext ctx
pushContext :: LayoutContext -> Parser ()
pushContext l =
- do ctx <- getContext
- setContext (l : ctx)
+ do ctx <- getContext
+ setContext (l : ctx)
-- | Should only be used at the beginning of a file. When we start parsing
-- we should be in layout mode. Instead of forcing zero indentation we use
-- the indentation of the first token.
pushCurrentContext :: Parser ()
pushCurrentContext =
- do p <- getLastPos
- pushContext (Layout (posCol p))
+ do p <- getLastPos
+ pushContext (Layout (posCol p))
diff --git a/src/full/Agda/Syntax/Parser/Parser.y b/src/full/Agda/Syntax/Parser/Parser.y
index 9abe09b..0181719 100644
--- a/src/full/Agda/Syntax/Parser/Parser.y
+++ b/src/full/Agda/Syntax/Parser/Parser.y
@@ -108,6 +108,7 @@ import Agda.Utils.Tuple
'ETA' { TokKeyword KwETA $$ }
'NO_TERMINATION_CHECK' { TokKeyword KwNO_TERMINATION_CHECK $$ }
'NON_TERMINATING' { TokKeyword KwNON_TERMINATING $$ }
+ 'TERMINATING' { TokKeyword KwTERMINATING $$ }
'MEASURE' { TokKeyword KwMEASURE $$ }
'COMPILED' { TokKeyword KwCOMPILED $$ }
'COMPILED_EXPORT' { TokKeyword KwCOMPILED_EXPORT $$ }
@@ -124,40 +125,40 @@ import Agda.Utils.Tuple
'unquote' { TokKeyword KwUnquote $$ }
'unquoteDecl' { TokKeyword KwUnquoteDecl $$ }
- setN { TokSetN $$ }
- tex { TokTeX $$ }
- comment { TokComment $$ }
-
- '...' { TokSymbol SymEllipsis $$ }
- '..' { TokSymbol SymDotDot $$ }
- '.' { TokSymbol SymDot $$ }
- ';' { TokSymbol SymSemi $$ }
- ':' { TokSymbol SymColon $$ }
- '=' { TokSymbol SymEqual $$ }
- '_' { TokSymbol SymUnderscore $$ }
- '?' { TokSymbol SymQuestionMark $$ }
- '->' { TokSymbol SymArrow $$ }
- '\\' { TokSymbol SymLambda $$ }
- '@' { TokSymbol SymAs $$ }
- '|' { TokSymbol SymBar $$ }
- '(' { TokSymbol SymOpenParen $$ }
- ')' { TokSymbol SymCloseParen $$ }
- '{{' { TokSymbol SymDoubleOpenBrace $$ }
- '}}' { TokSymbol SymDoubleCloseBrace $$ }
- '{' { TokSymbol SymOpenBrace $$ }
- '}' { TokSymbol SymCloseBrace $$ }
--- ':{' { TokSymbol SymColonBrace $$ }
- vopen { TokSymbol SymOpenVirtualBrace $$ }
- vclose { TokSymbol SymCloseVirtualBrace $$ }
- vsemi { TokSymbol SymVirtualSemi $$ }
- '{-#' { TokSymbol SymOpenPragma $$ }
- '#-}' { TokSymbol SymClosePragma $$ }
-
- id { TokId $$ }
- q_id { TokQId $$ }
-
- string { TokString $$ }
- literal { TokLiteral $$ }
+ setN { TokSetN $$ }
+ tex { TokTeX $$ }
+ comment { TokComment $$ }
+
+ '...' { TokSymbol SymEllipsis $$ }
+ '..' { TokSymbol SymDotDot $$ }
+ '.' { TokSymbol SymDot $$ }
+ ';' { TokSymbol SymSemi $$ }
+ ':' { TokSymbol SymColon $$ }
+ '=' { TokSymbol SymEqual $$ }
+ '_' { TokSymbol SymUnderscore $$ }
+ '?' { TokSymbol SymQuestionMark $$ }
+ '->' { TokSymbol SymArrow $$ }
+ '\\' { TokSymbol SymLambda $$ }
+ '@' { TokSymbol SymAs $$ }
+ '|' { TokSymbol SymBar $$ }
+ '(' { TokSymbol SymOpenParen $$ }
+ ')' { TokSymbol SymCloseParen $$ }
+ '{{' { TokSymbol SymDoubleOpenBrace $$ }
+ '}}' { TokSymbol SymDoubleCloseBrace $$ }
+ '{' { TokSymbol SymOpenBrace $$ }
+ '}' { TokSymbol SymCloseBrace $$ }
+-- ':{' { TokSymbol SymColonBrace $$ }
+ vopen { TokSymbol SymOpenVirtualBrace $$ }
+ vclose { TokSymbol SymCloseVirtualBrace $$ }
+ vsemi { TokSymbol SymVirtualSemi $$ }
+ '{-#' { TokSymbol SymOpenPragma $$ }
+ '#-}' { TokSymbol SymClosePragma $$ }
+
+ id { TokId $$ }
+ q_id { TokQId $$ }
+
+ string { TokString $$ }
+ literal { TokLiteral $$ }
%%
@@ -167,52 +168,52 @@ import Agda.Utils.Tuple
-- Parse a list of tokens.
Tokens :: { [Token] }
-Tokens : TokensR { reverse $1 }
+Tokens : TokensR { reverse $1 }
-- Happy is much better at parsing left recursive grammars (constant
-- stack size vs. linear stack size for right recursive).
TokensR :: { [Token] }
-TokensR : TokensR Token { $2 : $1 }
- | { [] }
+TokensR : TokensR Token { $2 : $1 }
+ | { [] }
-- Parse single token.
Token :: { Token }
Token
- : 'let' { TokKeyword KwLet $1 }
- | 'in' { TokKeyword KwIn $1 }
- | 'where' { TokKeyword KwWhere $1 }
- | 'with' { TokKeyword KwWith $1 }
- | 'rewrite' { TokKeyword KwRewrite $1 }
+ : 'let' { TokKeyword KwLet $1 }
+ | 'in' { TokKeyword KwIn $1 }
+ | 'where' { TokKeyword KwWhere $1 }
+ | 'with' { TokKeyword KwWith $1 }
+ | 'rewrite' { TokKeyword KwRewrite $1 }
| 'postulate' { TokKeyword KwPostulate $1 }
| 'primitive' { TokKeyword KwPrimitive $1 }
- | 'open' { TokKeyword KwOpen $1 }
- | 'import' { TokKeyword KwImport $1 }
- | 'using' { TokKeyword KwUsing $1 }
- | 'hiding' { TokKeyword KwHiding $1 }
+ | 'open' { TokKeyword KwOpen $1 }
+ | 'import' { TokKeyword KwImport $1 }
+ | 'using' { TokKeyword KwUsing $1 }
+ | 'hiding' { TokKeyword KwHiding $1 }
| 'renaming' { TokKeyword KwRenaming $1 }
- | 'to' { TokKeyword KwTo $1 }
- | 'public' { TokKeyword KwPublic $1 }
- | 'module' { TokKeyword KwModule $1 }
- | 'data' { TokKeyword KwData $1 }
- | 'codata' { TokKeyword KwCoData $1 }
- | 'record' { TokKeyword KwRecord $1 }
+ | 'to' { TokKeyword KwTo $1 }
+ | 'public' { TokKeyword KwPublic $1 }
+ | 'module' { TokKeyword KwModule $1 }
+ | 'data' { TokKeyword KwData $1 }
+ | 'codata' { TokKeyword KwCoData $1 }
+ | 'record' { TokKeyword KwRecord $1 }
| 'constructor' { TokKeyword KwConstructor $1 }
| 'inductive' { TokKeyword KwInductive $1 }
| 'coinductive' { TokKeyword KwCoInductive $1 }
| 'field' { TokKeyword KwField $1 }
- | 'infix' { TokKeyword KwInfix $1 }
- | 'infixl' { TokKeyword KwInfixL $1 }
- | 'infixr' { TokKeyword KwInfixR $1 }
- | 'mutual' { TokKeyword KwMutual $1 }
+ | 'infix' { TokKeyword KwInfix $1 }
+ | 'infixl' { TokKeyword KwInfixL $1 }
+ | 'infixr' { TokKeyword KwInfixR $1 }
+ | 'mutual' { TokKeyword KwMutual $1 }
| 'abstract' { TokKeyword KwAbstract $1 }
- | 'private' { TokKeyword KwPrivate $1 }
- | 'instance' { TokKeyword KwInstance $1 }
- | 'Prop' { TokKeyword KwProp $1 }
- | 'Set' { TokKeyword KwSet $1 }
- | 'forall' { TokKeyword KwForall $1 }
+ | 'private' { TokKeyword KwPrivate $1 }
+ | 'instance' { TokKeyword KwInstance $1 }
+ | 'Prop' { TokKeyword KwProp $1 }
+ | 'Set' { TokKeyword KwSet $1 }
+ | 'forall' { TokKeyword KwForall $1 }
| 'syntax' { TokKeyword KwSyntax $1 }
| 'pattern' { TokKeyword KwPatternSyn $1 }
- | 'OPTIONS' { TokKeyword KwOPTIONS $1 }
+ | 'OPTIONS' { TokKeyword KwOPTIONS $1 }
| 'BUILTIN' { TokKeyword KwBUILTIN $1 }
| 'REWRITE' { TokKeyword KwREWRITE $1 }
| 'IMPORT' { TokKeyword KwIMPORT $1 }
@@ -227,6 +228,7 @@ Token
| 'ETA' { TokKeyword KwETA $1 }
| 'NO_TERMINATION_CHECK' { TokKeyword KwNO_TERMINATION_CHECK $1 }
| 'NON_TERMINATING' { TokKeyword KwNON_TERMINATING $1 }
+ | 'TERMINATING' { TokKeyword KwTERMINATING $1 }
| 'MEASURE' { TokKeyword KwMEASURE $1 }
| 'quoteGoal' { TokKeyword KwQuoteGoal $1 }
| 'quoteContext' { TokKeyword KwQuoteContext $1 }
@@ -236,39 +238,39 @@ Token
| 'unquote' { TokKeyword KwUnquote $1 }
| 'unquoteDecl' { TokKeyword KwUnquoteDecl $1 }
- | setN { TokSetN $1 }
- | tex { TokTeX $1 }
- | comment { TokComment $1 }
-
- | '...' { TokSymbol SymEllipsis $1 }
- | '..' { TokSymbol SymDotDot $1 }
- | '.' { TokSymbol SymDot $1 }
- | ';' { TokSymbol SymSemi $1 }
- | ':' { TokSymbol SymColon $1 }
- | '=' { TokSymbol SymEqual $1 }
- | '_' { TokSymbol SymUnderscore $1 }
- | '?' { TokSymbol SymQuestionMark $1 }
- | '->' { TokSymbol SymArrow $1 }
- | '\\' { TokSymbol SymLambda $1 }
- | '@' { TokSymbol SymAs $1 }
- | '|' { TokSymbol SymBar $1 }
- | '(' { TokSymbol SymOpenParen $1 }
- | ')' { TokSymbol SymCloseParen $1 }
- | '{{' { TokSymbol SymDoubleOpenBrace $1 }
- | '}}' { TokSymbol SymDoubleCloseBrace $1 }
- | '{' { TokSymbol SymOpenBrace $1 }
- | '}' { TokSymbol SymCloseBrace $1 }
- | vopen { TokSymbol SymOpenVirtualBrace $1 }
- | vclose { TokSymbol SymCloseVirtualBrace $1 }
- | vsemi { TokSymbol SymVirtualSemi $1 }
- | '{-#' { TokSymbol SymOpenPragma $1 }
- | '#-}' { TokSymbol SymClosePragma $1 }
-
- | id { TokId $1 }
- | q_id { TokQId $1 }
- | string { TokString $1 }
-
- | literal { TokLiteral $1 }
+ | setN { TokSetN $1 }
+ | tex { TokTeX $1 }
+ | comment { TokComment $1 }
+
+ | '...' { TokSymbol SymEllipsis $1 }
+ | '..' { TokSymbol SymDotDot $1 }
+ | '.' { TokSymbol SymDot $1 }
+ | ';' { TokSymbol SymSemi $1 }
+ | ':' { TokSymbol SymColon $1 }
+ | '=' { TokSymbol SymEqual $1 }
+ | '_' { TokSymbol SymUnderscore $1 }
+ | '?' { TokSymbol SymQuestionMark $1 }
+ | '->' { TokSymbol SymArrow $1 }
+ | '\\' { TokSymbol SymLambda $1 }
+ | '@' { TokSymbol SymAs $1 }
+ | '|' { TokSymbol SymBar $1 }
+ | '(' { TokSymbol SymOpenParen $1 }
+ | ')' { TokSymbol SymCloseParen $1 }
+ | '{{' { TokSymbol SymDoubleOpenBrace $1 }
+ | '}}' { TokSymbol SymDoubleCloseBrace $1 }
+ | '{' { TokSymbol SymOpenBrace $1 }
+ | '}' { TokSymbol SymCloseBrace $1 }
+ | vopen { TokSymbol SymOpenVirtualBrace $1 }
+ | vclose { TokSymbol SymCloseVirtualBrace $1 }
+ | vsemi { TokSymbol SymVirtualSemi $1 }
+ | '{-#' { TokSymbol SymOpenPragma $1 }
+ | '#-}' { TokSymbol SymClosePragma $1 }
+
+ | id { TokId $1 }
+ | q_id { TokQId $1 }
+ | string { TokString $1 }
+
+ | literal { TokLiteral $1 }
{--------------------------------------------------------------------------
Top level
@@ -286,18 +288,18 @@ maybe_vclose : {- empty -} { () }
-- The first token in a file decides the indentation of the top-level layout
-- block. Or not. It will if we allow the top-level module to be omitted.
--- topen : {- empty -} {% pushCurrentContext }
+-- topen : {- empty -} {% pushCurrentContext }
{- A layout block might have to be closed by a parse error. Example:
- let x = e in e'
+ let x = e in e'
Here the 'let' starts a layout block which should end before the 'in'. The
problem is that the lexer doesn't know this, so there is no virtual close
brace. However when the parser sees the 'in' there will be a parse error.
This is our cue to close the layout block.
-}
close : vclose { () }
- | error {% popContext }
+ | error {% popContext }
-- You can use concrete semi colons in a layout block started with a virtual
@@ -318,16 +320,16 @@ beginImpDir : {- empty -} {% pushLexState imp_dir }
-- An integer. Used in fixity declarations.
Int :: { Integer }
-Int : literal {% case $1 of {
- LitInt _ i -> return i;
- _ -> fail $ "Expected integer"
- }
- }
- | id {% case $1 of {
+Int : literal {% case $1 of {
+ LitInt _ i -> return i;
+ _ -> fail $ "Expected integer"
+ }
+ }
+ | id {% case $1 of {
(_, s) -> case readM s of {
Right i -> return i;
- Left (err :: String) -> fail $ "Expected integer"
- }
+ Left (err :: String) -> fail $ "Expected integer"
+ }
}
}
@@ -339,13 +341,13 @@ Int : literal {% case $1 of {
-- A name is really a sequence of parts, but the lexer just sees it as a
-- string, so we have to do the translation here.
Id :: { Name }
-Id : id {% mkName $1 }
+Id : id {% mkName $1 }
-- Space separated list of one or more identifiers.
SpaceIds :: { [Name] }
SpaceIds
: Id SpaceIds { $1 : $2 }
- | Id { [$1] }
+ | Id { [$1] }
-- When looking for a double closed brace, we accept either a single token '}}'
-- (which is what the unicode character "RIGHT WHITE CURLY BRACKET" is
@@ -358,9 +360,9 @@ DoubleCloseBrace
: '}}' { getRange $1 }
| '}' '}' {%
if posPos (fromJust (rEnd (getRange $2))) -
- posPos (fromJust (rStart (getRange $1))) > 2
+ posPos (fromJust (rStart (getRange $1))) > 2
then parseErrorAt (fromJust (rStart (getRange $2)))
- "Expecting '}}', found separated '}'s."
+ "Expecting '}}', found separated '}'s."
else return $ getRange ($1, $2)
}
@@ -425,7 +427,7 @@ MaybeDottedBId
SpaceBIds :: { [Name] }
SpaceBIds
: BId SpaceBIds { $1 : $2 }
- | BId { [$1] }
+ | BId { [$1] }
{- DOES PRODUCE REDUCE/REDUCE CONFLICTS!
-- Space-separated list of binding identifiers. Used in dependent
@@ -436,7 +438,7 @@ SpaceBIds
CommaBIds :: { [Name] }
CommaBIds
: CommaBIds BId { $1 ++ [$2] } -- SWITCHING DOES NOT HELP
- | BId { [$1] }
+ | BId { [$1] }
-}
-- Space-separated list of binding identifiers. Used in dependent
@@ -456,19 +458,19 @@ CommaBIds : CommaBIdAndAbsurds {
}
{-
let getName (Ident (QName x)) = Just x
- getName (Underscore r _) = Just (Name r [Hole])
- getName _ = Nothing
+ getName (Underscore r _) = Just (Name r [Hole])
+ getName _ = Nothing
in
case partition isJust $ map getName $1 of
- (good, []) -> return $ map fromJust good
- _ -> fail $ "expected sequence of bound identifiers"
+ (good, []) -> return $ map fromJust good
+ _ -> fail $ "expected sequence of bound identifiers"
-}
CommaBIdAndAbsurds :: { Either [Name] [Expr] }
CommaBIdAndAbsurds : Application {%
let getName (Ident (QName x)) = Just x
- getName (Underscore r _) = Just (Name r [Hole])
- getName _ = Nothing
+ getName (Underscore r _) = Just (Name r [Hole])
+ getName _ = Nothing
containsAbsurd (Absurd _) = True
containsAbsurd (HiddenArg _ (Named _ e)) = containsAbsurd e
@@ -479,15 +481,15 @@ CommaBIdAndAbsurds : Application {%
in
if isJust $ find containsAbsurd $1 then return $ Right $1 else
case partition isJust $ map getName $1 of
- (good, []) -> return $ Left $ map fromJust good
- _ -> fail $ "expected sequence of bound identifiers"
+ (good, []) -> return $ Left $ map fromJust good
+ _ -> fail $ "expected sequence of bound identifiers"
}
-- Space separated list of strings in a pragma.
PragmaStrings :: { [String] }
PragmaStrings
- : {- empty -} { [] }
+ : {- empty -} { [] }
| string PragmaStrings { snd $1 : $2 }
PragmaString :: { String }
@@ -508,11 +510,11 @@ PragmaQName : string {% fmap QName (mkName $1) }
expression category (lowest precedence). The reason they don't is that we
want to parse things like
- m >>= \x -> k x
+ m >>= \x -> k x
This will leads to a conflict in the following case
- m >>= \x -> k x >>= \y -> k' y
+ m >>= \x -> k x >>= \y -> k' y
At the second '>>=' we can either shift or reduce. We solve this problem
using Happy's precedence directives. The rule 'Expr -> Expr1' (which is the
@@ -534,28 +536,28 @@ Expr
-- Level 1: Application
Expr1 : WithExprs {% case $1 of
- { [e] -> return e
- ; e : es -> return $ WithApp (fuseRange e es) e es
- ; [] -> fail "impossible: empty with expressions"
- }
- }
+ { [e] -> return e
+ ; e : es -> return $ WithApp (fuseRange e es) e es
+ ; [] -> fail "impossible: empty with expressions"
+ }
+ }
WithExprs :: { [Expr] }
WithExprs
: Application3 '|' WithExprs { RawApp (getRange $1) $1 : $3 }
- | Application { [RawApp (getRange $1) $1] }
+ | Application { [RawApp (getRange $1) $1] }
Application :: { [Expr] }
Application
- : Expr2 { [$1] }
+ : Expr2 { [$1] }
| Expr3 Application { $1 : $2 }
-- Level 2: Lambdas and lets
Expr2
- : '\\' LamBindings Expr { Lam (getRange ($1,$2,$3)) $2 $3 }
+ : '\\' LamBindings Expr { Lam (getRange ($1,$2,$3)) $2 $3 }
| ExtendedOrAbsurdLam { $1 }
| 'let' Declarations 'in' Expr { Let (getRange ($1,$2,$3,$4)) $2 $4 }
- | Expr3 { $1 }
+ | Expr3 { $1 }
| 'quoteGoal' Id 'in' Expr { QuoteGoal (getRange ($1,$2,$3,$4)) $2 $4 }
| 'quoteContext' Id 'in' Expr { QuoteContext (getRange ($1,$2,$3,$4)) $2 $4 }
| 'tactic' Application3 { Tactic (getRange ($1, $2)) (RawApp (getRange $2) $2) [] }
@@ -568,7 +570,7 @@ ExtendedOrAbsurdLam
Left (bs, h) -> if null bs then return $ AbsurdLam r h else
return $ Lam r bs (AbsurdLam r h)
where r = fuseRange $1 bs
- Right es -> do -- it is of the form @\ { p1 ... () }@
+ Right es -> do -- it is of the form @\ { p1 ... () }@
p <- exprToLHS (RawApp (getRange es) es);
return $ ExtendedLam (fuseRange $1 es)
[(p [] [], AbsurdRHS, NoWhere)]
@@ -576,52 +578,52 @@ ExtendedOrAbsurdLam
Application3 :: { [Expr] }
Application3
- : Expr3 { [$1] }
+ : Expr3 { [$1] }
| Expr3 Application3 { $1 : $2 }
-- Level 3: Atoms
Expr3Curly
- : '{' Expr '}' { HiddenArg (getRange ($1,$2,$3)) (maybeNamed $2) }
- | '{' '}' { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }
+ : '{' Expr '}' { HiddenArg (getRange ($1,$2,$3)) (maybeNamed $2) }
+ | '{' '}' { let r = fuseRange $1 $2 in HiddenArg r $ unnamed $ Absurd r }
Expr3NoCurly
- : QId { Ident $1 }
- | literal { Lit $1 }
- | '?' { QuestionMark (getRange $1) Nothing }
- | '_' { Underscore (getRange $1) Nothing }
- | 'Prop' { Prop (getRange $1) }
- | 'Set' { Set (getRange $1) }
+ : QId { Ident $1 }
+ | literal { Lit $1 }
+ | '?' { QuestionMark (getRange $1) Nothing }
+ | '_' { Underscore (getRange $1) Nothing }
+ | 'Prop' { Prop (getRange $1) }
+ | 'Set' { Set (getRange $1) }
| 'quote' { Quote (getRange $1) }
| 'quoteTerm' { QuoteTerm (getRange $1) }
| 'unquote' { Unquote (getRange $1) }
- | setN { SetN (getRange (fst $1)) (snd $1) }
- | '{{' Expr DoubleCloseBrace { InstanceArg (getRange ($1,$2,$3))
+ | setN { SetN (getRange (fst $1)) (snd $1) }
+ | '{{' Expr DoubleCloseBrace { InstanceArg (getRange ($1,$2,$3))
(maybeNamed $2) }
- | '(' Expr ')' { Paren (getRange ($1,$2,$3)) $2 }
- | '(' ')' { Absurd (fuseRange $1 $2) }
+ | '(' Expr ')' { Paren (getRange ($1,$2,$3)) $2 }
+ | '(' ')' { Absurd (fuseRange $1 $2) }
| '{{' DoubleCloseBrace { let r = fuseRange $1 $2 in InstanceArg r $ unnamed $ Absurd r }
- | Id '@' Expr3 { As (getRange ($1,$2,$3)) $1 $3 }
- | '.' Expr3 { Dot (fuseRange $1 $2) $2 }
+ | Id '@' Expr3 { As (getRange ($1,$2,$3)) $1 $3 }
+ | '.' Expr3 { Dot (fuseRange $1 $2) $2 }
| 'record' '{' FieldAssignments '}' { Rec (getRange ($1,$2,$3,$4)) $3 }
| 'record' Expr3NoCurly '{' FieldAssignments '}' { RecUpdate (getRange ($1,$2,$3,$4,$5)) $2 $4 }
Expr3
- : Expr3Curly { $1 }
- | Expr3NoCurly { $1 }
+ : Expr3Curly { $1 }
+ | Expr3NoCurly { $1 }
FieldAssignments :: { [(Name, Expr)] }
FieldAssignments
- : {- empty -} { [] }
+ : {- empty -} { [] }
| FieldAssignments1 { $1 }
FieldAssignments1 :: { [(Name, Expr)] }
FieldAssignments1
- : FieldAssignment { [$1] }
+ : FieldAssignment { [$1] }
| FieldAssignment ';' FieldAssignments1 { $1 : $3 }
FieldAssignment :: { (Name, Expr) }
FieldAssignment
- : Id '=' Expr { ($1, $3) }
+ : Id '=' Expr { ($1, $3) }
{--------------------------------------------------------------------------
Bindings
@@ -631,12 +633,12 @@ FieldAssignment
TeleArrow : Telescope1 '->' { $1 }
Telescope1
- : TypedBindingss { {-TeleBind-} $1 }
+ : TypedBindingss { {-TeleBind-} $1 }
TypedBindingss :: { [TypedBindings] }
TypedBindingss
: TypedBindings TypedBindingss { $1 : $2 }
- | TypedBindings { [$1] }
+ | TypedBindings { [$1] }
-- A typed binding is either (x1 .. xn : A) or {y1 .. ym : B}
@@ -683,7 +685,7 @@ LamBindings
: LamBinds '->' {%
case reverse $1 of
Left _ : _ -> parseError "Absurd lambda cannot have a body."
- _ : _ -> return [ b | Right b <- $1 ]
+ _ : _ -> return [ b | Right b <- $1 ]
[] -> parsePanic "Empty LamBinds"
}
@@ -704,7 +706,7 @@ LamBinds
: DomainFreeBinding LamBinds { map Right $1 ++ $2 }
| TypedBindings LamBinds { Right (DomainFull $1) : $2 }
| DomainFreeBinding { map Right $1 }
- | TypedBindings { [Right $ DomainFull $1] }
+ | TypedBindings { [Right $ DomainFull $1] }
| '(' ')' { [Left NotHidden] }
| '{' '}' { [Left Hidden] }
| '{{' DoubleCloseBrace { [Left Instance] }
@@ -712,12 +714,12 @@ LamBinds
-- Like LamBinds, but could also parse an absurd LHS of an extended lambda @{ p1 ... () }@
LamBindsAbsurd :: { Either [Either Hiding LamBinding] [Expr] }
LamBindsAbsurd
- : DomainFreeBinding LamBinds { Left $ map Right $1 ++ $2 }
- | TypedBindings LamBinds { Left $ Right (DomainFull $1) : $2 }
- | DomainFreeBindingAbsurd { case $1 of
+ : DomainFreeBinding LamBinds { Left $ map Right $1 ++ $2 }
+ | TypedBindings LamBinds { Left $ Right (DomainFull $1) : $2 }
+ | DomainFreeBindingAbsurd { case $1 of
Left lb -> Left $ map Right lb
Right es -> Right es }
- | TypedBindings { Left [Right $ DomainFull $1] }
+ | TypedBindings { Left [Right $ DomainFull $1] }
| '(' ')' { Left [Left NotHidden] }
| '{' '}' { Left [Left Hidden] }
| '{{' DoubleCloseBrace { Left [Left Instance] }
@@ -728,7 +730,7 @@ NonAbsurdLamClause
: Application3 '->' Expr {% do
p <- exprToLHS (RawApp (getRange $1) $1) ;
return (p [] [], RHS $3, NoWhere)
- }
+ }
AbsurdLamClause :: { (LHS,RHS,WhereClause) }
AbsurdLamClause
@@ -737,7 +739,7 @@ AbsurdLamClause
: Application {% do
p <- exprToLHS (RawApp (getRange $1) $1);
return (p [] [], AbsurdRHS, NoWhere)
- }
+ }
LamClause :: { (LHS,RHS,WhereClause) }
LamClause
@@ -762,7 +764,7 @@ ForallBindings
TypedUntypedBindings1 :: { [LamBinding] }
TypedUntypedBindings1
: DomainFreeBinding TypedUntypedBindings1 { $1 ++ $2 }
- | TypedBindings TypedUntypedBindings1 { DomainFull $1 : $2 }
+ | TypedBindings TypedUntypedBindings1 { DomainFull $1 : $2 }
| DomainFreeBinding { $1 }
| TypedBindings { [DomainFull $1] }
@@ -771,7 +773,7 @@ TypedUntypedBindings1
TypedUntypedBindings :: { [LamBinding] }
TypedUntypedBindings
: DomainFreeBinding TypedUntypedBindings { $1 ++ $2 }
- | TypedBindings TypedUntypedBindings { DomainFull $1 : $2 }
+ | TypedBindings TypedUntypedBindings { DomainFull $1 : $2 }
| { [] }
-- A domain free binding is either x or {x1 .. xn}
@@ -781,9 +783,9 @@ DomainFreeBinding
Left lbs -> lbs
Right _ -> fail "expected sequence of bound identifiers, not absurd pattern"
}
-{- : BId { [DomainFree NotHidden Relevant $ mkBoundName_ $1] }
- | '.' BId { [DomainFree NotHidden Irrelevant $ mkBoundName_ $2] }
- | '..' BId { [DomainFree NotHidden NonStrict $ mkBoundName_ $2] }
+{- : BId { [DomainFree NotHidden Relevant $ mkBoundName_ $1] }
+ | '.' BId { [DomainFree NotHidden Irrelevant $ mkBoundName_ $2] }
+ | '..' BId { [DomainFree NotHidden NonStrict $ mkBoundName_ $2] }
| '{' CommaBIds '}' { map (DomainFree Hidden Relevant . mkBoundName_) $2 }
| '{{' CommaBIds DoubleCloseBrace { map (DomainFree (setHiding Instance defaultArgInfo) . mkBoundName_) $2 }
| '.' '{' CommaBIds '}' { map (DomainFree Hidden Irrelevant . mkBoundName_) $3 }
@@ -796,9 +798,9 @@ DomainFreeBinding
-- A domain free binding is either x or {x1 .. xn}
DomainFreeBindingAbsurd :: { Either [LamBinding] [Expr]}
DomainFreeBindingAbsurd
- : BId { Left [DomainFree defaultArgInfo $ mkBoundName_ $1] }
- | '.' BId { Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ $2] }
- | '..' BId { Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ $2] }
+ : BId { Left [DomainFree defaultArgInfo $ mkBoundName_ $1] }
+ | '.' BId { Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ $2] }
+ | '..' BId { Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ $2] }
| '{' CommaBIdAndAbsurds '}'
{ either (Left . map (DomainFree (setHiding Hidden $ defaultArgInfo) . mkBoundName_)) Right $2 }
| '{{' CommaBIds DoubleCloseBrace { Left $ map (DomainFree (setHiding Instance $ defaultArgInfo) . mkBoundName_) $2 }
@@ -815,7 +817,7 @@ DomainFreeBindingAbsurd
-- You can rename imports
-- ImportImportDirective :: { (Maybe AsName, ImportDirective) }
-- ImportImportDirective
--- : ImportDirective { (Nothing, $1) }
+-- : ImportDirective { (Nothing, $1) }
-- | id Id ImportDirective {% isName "as" $1 >>
-- return (Just (AsName $2 (getRange (fst $1))), $3) }
@@ -836,7 +838,7 @@ ImportDirective1 :: { ImportDirective }
UsingOrHiding :: { (UsingOrHiding , Range) }
UsingOrHiding
: 'using' '(' CommaImportNames ')' { (Using $3 , getRange ($1,$2,$3,$4)) }
- -- using can have an empty list
+ -- using can have an empty list
| 'hiding' '(' CommaImportNames ')' { (Hiding $3 , getRange ($1,$2,$3,$4)) }
-- if you want to hide nothing that's fine, isn't it?
-- | 'hiding' '(' CommaImportNames1 ')' { (Hiding $3 , getRange ($1,$2,$3,$4)) }
@@ -860,22 +862,22 @@ Renaming
-- the imp_dir state exactly one token before the 'to'
ImportName_ :: { ImportedName }
ImportName_
- : beginImpDir Id { ImportedName $2 }
+ : beginImpDir Id { ImportedName $2 }
| 'module' beginImpDir Id { ImportedModule $3 }
ImportName :: { ImportedName }
-ImportName : Id { ImportedName $1 }
- | 'module' Id { ImportedModule $2 }
+ImportName : Id { ImportedName $1 }
+ | 'module' Id { ImportedModule $2 }
-- Actually semi-colon separated
CommaImportNames :: { [ImportedName] }
CommaImportNames
- : {- empty -} { [] }
- | CommaImportNames1 { $1 }
+ : {- empty -} { [] }
+ | CommaImportNames1 { $1 }
CommaImportNames1
- : ImportName { [$1] }
- | ImportName ';' CommaImportNames1 { $1 : $3 }
+ : ImportName { [$1] }
+ | ImportName ';' CommaImportNames1 { $1 : $3 }
{--------------------------------------------------------------------------
Function clauses
@@ -890,29 +892,29 @@ LHS : Expr1 RewriteEquations WithExpressions
{ Ellipsis (getRange ($1,$2,$3,$4)) $2 $3 $4 }
WithPats :: { [Pattern] }
-WithPats : {- empty -} { [] }
- | '|' Application3 WithPats
- {% exprToPattern (RawApp (getRange $2) $2) >>= \p ->
- return (p : $3)
- }
+WithPats : {- empty -} { [] }
+ | '|' Application3 WithPats
+ {% exprToPattern (RawApp (getRange $2) $2) >>= \p ->
+ return (p : $3)
+ }
WithExpressions :: { [Expr] }
WithExpressions
- : {- empty -} { [] }
+ : {- empty -} { [] }
| 'with' Expr
{ case $2 of { WithApp _ e es -> e : es; e -> [e] } }
RewriteEquations :: { [Expr] }
RewriteEquations
- : {- empty -} { [] }
+ : {- empty -} { [] }
| 'rewrite' Expr1
{ case $2 of { WithApp _ e es -> e : es; e -> [e] } }
-- Where clauses are optional.
WhereClause :: { WhereClause }
WhereClause
- : {- empty -} { NoWhere }
- | 'where' Declarations0 { AnyWhere $2 }
+ : {- empty -} { NoWhere }
+ | 'where' Declarations0 { AnyWhere $2 }
| 'module' Id 'where' Declarations0 { SomeWhere $2 $4 }
| 'module' Underscore 'where' Declarations0 { SomeWhere $2 $4 }
@@ -924,24 +926,24 @@ WhereClause
-- Top-level definitions.
Declaration :: { [Declaration] }
Declaration
- : Fields { $1 }
+ : Fields { $1 }
| FunClause { $1 }
- | Data { [$1] }
- | DataSig { [$1] } -- lone data type signature in mutual block
- | Record { [$1] }
- | RecordSig { [$1] } -- lone record signature in mutual block
- | Infix { [$1] }
- | Mutual { [$1] }
- | Abstract { [$1] }
- | Private { [$1] }
- | Instance { [$1] }
- | Postulate { [$1] }
- | Primitive { [$1] }
- | Open { $1 }
--- | Import { [$1] }
+ | Data { [$1] }
+ | DataSig { [$1] } -- lone data type signature in mutual block
+ | Record { [$1] }
+ | RecordSig { [$1] } -- lone record signature in mutual block
+ | Infix { [$1] }
+ | Mutual { [$1] }
+ | Abstract { [$1] }
+ | Private { [$1] }
+ | Instance { [$1] }
+ | Postulate { [$1] }
+ | Primitive { [$1] }
+ | Open { $1 }
+-- | Import { [$1] }
| ModuleMacro { [$1] }
- | Module { [$1] }
- | Pragma { [$1] }
+ | Module { [$1] }
+ | Pragma { [$1] }
| Syntax { [$1] }
| PatternSyn { [$1] }
| UnquoteDecl { [$1] }
@@ -966,25 +968,25 @@ ArgTypeSigs : ArgIds ':' Expr { map (fmap (flip (TypeSig defaultArgInfo) $3)) $1
-- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'.
-- FunClause also handle possibly dotted type signatures.
FunClause :: { [Declaration] }
-FunClause : LHS RHS WhereClause {% funClauseOrTypeSigs $1 $2 $3 }
+FunClause : LHS RHS WhereClause {% funClauseOrTypeSigs $1 $2 $3 }
RHS :: { RHSOrTypeSigs }
-RHS : '=' Expr { JustRHS (RHS $2) }
+RHS : '=' Expr { JustRHS (RHS $2) }
| ':' Expr { TypeSigsRHS $2 }
| {- empty -} { JustRHS AbsurdRHS }
-- Data declaration. Can be local.
Data :: { Declaration }
Data : 'data' Id TypedUntypedBindings ':' Expr 'where'
- Constructors { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) Inductive $2 $3 (Just $5) $7 }
+ Constructors { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) Inductive $2 $3 (Just $5) $7 }
| 'codata' Id TypedUntypedBindings ':' Expr 'where'
- Constructors { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) CoInductive $2 $3 (Just $5) $7 }
+ Constructors { Data (getRange ($1,$2,$3,$4,$5,$6,$7)) CoInductive $2 $3 (Just $5) $7 }
-- New cases when we already had a DataSig. Then one can omit the sort.
| 'data' Id TypedUntypedBindings 'where'
- Constructors { Data (getRange ($1,$2,$3,$4,$5)) Inductive $2 $3 Nothing $5 }
+ Constructors { Data (getRange ($1,$2,$3,$4,$5)) Inductive $2 $3 Nothing $5 }
| 'codata' Id TypedUntypedBindings 'where'
- Constructors { Data (getRange ($1,$2,$3,$4,$5)) CoInductive $2 $3 Nothing $5 }
+ Constructors { Data (getRange ($1,$2,$3,$4,$5)) CoInductive $2 $3 Nothing $5 }
-- Data type signature. Found in mutual blocks.
DataSig :: { Declaration }
@@ -998,10 +1000,10 @@ DataSig : 'data' Id TypedUntypedBindings ':' Expr
-- Record declarations.
Record :: { Declaration }
Record : 'record' Expr3NoCurly TypedUntypedBindings ':' Expr 'where'
- RecordDeclarations
+ RecordDeclarations
{% exprToName $2 >>= \ n -> return $ Record (getRange ($1,$2,$3,$4,$5,$6,$7)) n (fst3 $7) (snd3 $7) $3 (Just $5) (thd3 $7) }
| 'record' Expr3NoCurly TypedUntypedBindings 'where'
- RecordDeclarations
+ RecordDeclarations
{% exprToName $2 >>= \ n -> return $ Record (getRange ($1,$2,$3,$4,$5)) n (fst3 $5) (snd3 $5) $3 Nothing (thd3 $5) }
-- Record type signature. In mutual blocks.
@@ -1037,7 +1039,7 @@ Abstract : 'abstract' Declarations { Abstract (fuseRange $1 $2) $2 }
-- Private can only appear on the top-level (or rather the module level).
Private :: { Declaration }
-Private : 'private' Declarations { Private (fuseRange $1 $2) $2 }
+Private : 'private' Declarations { Private (fuseRange $1 $2) $2 }
-- Instance declarations.
@@ -1051,7 +1053,7 @@ Postulate : 'postulate' Declarations { Postulate (fuseRange $1 $2) $2 }
-- Primitives. Can only contain type signatures.
Primitive :: { Declaration }
-Primitive : 'primitive' TypeSignatures { Primitive (fuseRange $1 $2) $2 }
+Primitive : 'primitive' TypeSignatures { Primitive (fuseRange $1 $2) $2 }
-- Unquoting declarations.
UnquoteDecl :: { Declaration }
@@ -1062,9 +1064,9 @@ Syntax :: { Declaration }
Syntax : 'syntax' Id HoleNames '=' SimpleIds {%
case $2 of
Name _ [_] -> case mkNotation $3 (map rangedThing $5) of
- Left err -> parseError $ "malformed syntax declaration: " ++ err
+ Left err -> parseError $ "Malformed syntax declaration: " ++ err
Right n -> return $ Syntax $2 n
- _ -> parseError "syntax declarations are allowed only for simple names (without holes)"
+ _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"
}
-- Pattern synonyms.
@@ -1172,8 +1174,8 @@ Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%
[ case es of
{ [] -> Open r m dir
; _ -> Private r [ ModuleMacro r (noName $ beginningOf $ getRange m)
- (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))
- DoOpen dir
+ (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es)))
+ DoOpen dir
]
}
]
@@ -1181,7 +1183,7 @@ Open : MaybeOpen 'import' ModuleName OpenArgs ImportDirective {%
| 'open' ModuleName '{{' '...' DoubleCloseBrace ImportDirective {
let r = getRange $2 in
[ Private r [ ModuleMacro r (noName $ beginningOf $ getRange $2)
- (RecordModuleIFS r $2) DoOpen $6
+ (RecordModuleIFS r $2) DoOpen $6
]
]
}
@@ -1192,28 +1194,28 @@ OpenArgs : {- empty -} { [] }
ModuleApplication :: { [TypedBindings] -> Parser ModuleApplication }
ModuleApplication : ModuleName '{{' '...' DoubleCloseBrace { (\ts ->
- if null ts then return $ RecordModuleIFS (getRange ($1,$2,$3,$4)) $1
- else parseError "No bindings allowed for record module with non-canonical implicits" )
- }
- | ModuleName OpenArgs {
- (\ts -> return $ SectionApp (getRange ($1, $2)) ts (RawApp (fuseRange $1 $2) (Ident $1 : $2)) ) }
+ if null ts then return $ RecordModuleIFS (getRange ($1,$2,$3,$4)) $1
+ else parseError "No bindings allowed for record module with non-canonical implicits" )
+ }
+ | ModuleName OpenArgs {
+ (\ts -> return $ SectionApp (getRange ($1, $2)) ts (RawApp (fuseRange $1 $2) (Ident $1 : $2)) ) }
-- Module instantiation
ModuleMacro :: { Declaration }
ModuleMacro : 'module' ModuleName TypedUntypedBindings '=' ModuleApplication ImportDirective
- {% do { ma <- $5 (map addType $3)
+ {% do { ma <- $5 (map addType $3)
; name <- ensureUnqual $2
; return $ ModuleMacro (getRange ($1, $2, ma, $6)) name ma DontOpen $6 } }
- | 'open' 'module' Id TypedUntypedBindings '=' ModuleApplication ImportDirective
- {% do {ma <- $6 (map addType $4); return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) $3 ma DoOpen $7 } }
+ | 'open' 'module' Id TypedUntypedBindings '=' ModuleApplication ImportDirective
+ {% do {ma <- $6 (map addType $4); return $ ModuleMacro (getRange ($1, $2, $3, ma, $7)) $3 ma DoOpen $7 } }
-- Module
Module :: { Declaration }
Module : 'module' ModuleName TypedUntypedBindings 'where' Declarations0
- { Module (getRange ($1,$2,$3,$4,$5)) $2 (map addType $3) $5 }
+ { Module (getRange ($1,$2,$3,$4,$5)) $2 (map addType $3) $5 }
| 'module' Underscore TypedUntypedBindings 'where' Declarations0
- { Module (getRange ($1,$2,$3,$4,$5)) (QName $2) (map addType $3) $5 }
+ { Module (getRange ($1,$2,$3,$4,$5)) (QName $2) (map addType $3) $5 }
Underscore :: { Name }
Underscore : '_' { noName (getRange $1) }
@@ -1238,6 +1240,7 @@ DeclarationPragma
| ImportPragma { $1 }
| ImpossiblePragma { $1 }
| RecordEtaPragma { $1 }
+ | TerminatingPragma { $1 }
| NonTerminatingPragma { $1 }
| NoTerminationCheckPragma { $1 }
| MeasurePragma { $1 }
@@ -1311,6 +1314,11 @@ NonTerminatingPragma
: '{-#' 'NON_TERMINATING' '#-}'
{ TerminationCheckPragma (getRange ($1,$2,$3)) NonTerminating }
+TerminatingPragma :: { Pragma }
+TerminatingPragma
+ : '{-#' 'TERMINATING' '#-}'
+ { TerminationCheckPragma (getRange ($1,$2,$3)) Terminating }
+
MeasurePragma :: { Pragma }
MeasurePragma
: '{-#' 'MEASURE' PragmaName '#-}'
@@ -1460,17 +1468,17 @@ mkName (i, s) = do
unless (alternating xs) $ fail $ "a name cannot contain two consecutive underscores"
return $ Name (getRange i) xs
where
- isValidId Hole = return ()
- isValidId (Id y) = do
+ isValidId Hole = return ()
+ isValidId (Id y) = do
let x = rawNameToString y
case parse defaultParseFlags [0] (lexer return) x of
- ParseOk _ (TokId _) -> return ()
- _ -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"
+ ParseOk _ (TokId _) -> return ()
+ _ -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid"
- -- we know that there are no two Ids in a row
- alternating (Hole : Hole : _) = False
- alternating (_ : xs) = alternating xs
- alternating [] = True
+ -- we know that there are no two Ids in a row
+ alternating (Hole : Hole : _) = False
+ alternating (_ : xs) = alternating xs
+ alternating [] = True
-- | Create a qualified name from a list of strings
mkQName :: [(Interval, String)] -> Parser QName
@@ -1485,8 +1493,8 @@ ensureUnqual q at Qual{} = parseError' (rStart $ getRange q) "Qualified name not a
-- | Match a particular name.
isName :: String -> (Interval, String) -> Parser ()
isName s (_,s')
- | s == s' = return ()
- | otherwise = fail $ "expected " ++ s ++ ", found " ++ s'
+ | s == s' = return ()
+ | otherwise = fail $ "expected " ++ s ++ ", found " ++ s'
-- | Build a forall pi (forall x y z -> ...)
forallPi :: [LamBinding] -> Expr -> Expr
@@ -1498,7 +1506,7 @@ tLet r = TypedBindings r . Common.Arg defaultArgInfo . TLet r
-- | Converts lambda bindings to typed bindings.
addType :: LamBinding -> TypedBindings
-addType (DomainFull b) = b
+addType (DomainFull b) = b
addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [x] $ Underscore r Nothing
where r = getRange x
@@ -1527,22 +1535,22 @@ mergeImportDirectives is = do
verifyImportDirective :: ImportDirective -> Parser ImportDirective
verifyImportDirective i =
case filter ((>1) . length)
- $ group
- $ sort xs
+ $ group
+ $ sort xs
of
- [] -> return i
- yss -> let Just pos = rStart $ getRange $ head $ concat yss in
+ [] -> return i
+ yss -> let Just pos = rStart $ getRange $ head $ concat yss in
parseErrorAt pos $
- "repeated name" ++ s ++ " in import directive: " ++
- concat (intersperse ", " $ map (show . head) yss)
- where
- s = case yss of
- [_] -> ""
- _ -> "s"
+ "Repeated name" ++ s ++ " in import directive: " ++
+ concat (intersperse ", " $ map (show . head) yss)
+ where
+ s = case yss of
+ [_] -> ""
+ _ -> "s"
where
- xs = names (usingOrHiding i) ++ map renFrom (renaming i)
- names (Using xs) = xs
- names (Hiding xs) = xs
+ xs = names (usingOrHiding i) ++ map renFrom (renaming i)
+ names (Using xs) = xs
+ names (Hiding xs) = xs
-- | Breaks up a string into substrings. Returns every maximal
-- subsequence of zero or more characters distinct from @'.'@.
@@ -1590,34 +1598,34 @@ validHaskellModuleName = all ok . splitOnDots
exprToLHS :: Expr -> Parser ([Expr] -> [Expr] -> LHS)
exprToLHS e = case e of
WithApp r e es -> LHS <$> exprToPattern e <*> mapM exprToPattern es
- _ -> LHS <$> exprToPattern e <*> return []
+ _ -> LHS <$> exprToPattern e <*> return []
-- | Turn an expression into a pattern. Fails if the expression is not a
-- valid pattern.
exprToPattern :: Expr -> Parser Pattern
exprToPattern e =
case e of
- Ident x -> return $ IdentP x
- App _ e1 e2 -> AppP <$> exprToPattern e1
- <*> T.mapM (T.mapM exprToPattern) e2
- Paren r e -> ParenP r
- <$> exprToPattern e
- Underscore r _ -> return $ WildP r
- Absurd r -> return $ AbsurdP r
- As r x e -> AsP r x <$> exprToPattern e
- Dot r (HiddenArg _ e) -> return $ HiddenP r $ fmap (DotP r) e
- Dot r e -> return $ DotP r e
- Lit l -> return $ LitP l
- HiddenArg r e -> HiddenP r <$> T.mapM exprToPattern e
- InstanceArg r e -> InstanceP r <$> T.mapM exprToPattern e
- RawApp r es -> RawAppP r <$> mapM exprToPattern es
+ Ident x -> return $ IdentP x
+ App _ e1 e2 -> AppP <$> exprToPattern e1
+ <*> T.mapM (T.mapM exprToPattern) e2
+ Paren r e -> ParenP r
+ <$> exprToPattern e
+ Underscore r _ -> return $ WildP r
+ Absurd r -> return $ AbsurdP r
+ As r x e -> AsP r x <$> exprToPattern e
+ Dot r (HiddenArg _ e) -> return $ HiddenP r $ fmap (DotP r) e
+ Dot r e -> return $ DotP r e
+ Lit l -> return $ LitP l
+ HiddenArg r e -> HiddenP r <$> T.mapM exprToPattern e
+ InstanceArg r e -> InstanceP r <$> T.mapM exprToPattern e
+ RawApp r es -> RawAppP r <$> mapM exprToPattern es
Quote r -> return $ QuoteP r
- _ ->
+ _ ->
let Just pos = rStart $ getRange e in
parseErrorAt pos $ "Not a valid pattern: " ++ show e
opAppExprToPattern :: OpApp Expr -> Parser Pattern
-opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "syntax binding lambda cannot appear in a pattern"
+opAppExprToPattern (SyntaxBindingLambda _ _ _) = parseError "Syntax binding lambda cannot appear in a pattern"
opAppExprToPattern (Ordinary e) = exprToPattern e
-- | Turn an expression into a name. Fails if the expression is not a
@@ -1663,6 +1671,7 @@ data RHSOrTypeSigs = JustRHS RHS
namesOfPattern :: Pattern -> Maybe [(C.ArgInfo, Name)]
namesOfPattern (IdentP (QName i)) = Just [(defaultArgInfo, i)]
+namesOfPattern (WildP r) = Just [(defaultArgInfo, C.noName r)]
namesOfPattern (DotP _ (Ident (QName i))) = Just [(setRelevance Irrelevant defaultArgInfo, i)]
namesOfPattern (RawAppP _ ps) = fmap concat $ mapM namesOfPattern ps
namesOfPattern _ = Nothing
diff --git a/src/full/Agda/Syntax/Parser/StringLiterals.hs b/src/full/Agda/Syntax/Parser/StringLiterals.hs
index e0718da..f45ceb1 100644
--- a/src/full/Agda/Syntax/Parser/StringLiterals.hs
+++ b/src/full/Agda/Syntax/Parser/StringLiterals.hs
@@ -1,4 +1,3 @@
-
{-| The code to lex string and character literals. Basically the same code
as in GHC.
-}
@@ -35,10 +34,10 @@ litString = stringToken '"' (\i s ->
-}
litChar :: LexAction Token
litChar = stringToken '\'' $ \i s ->
- do case s of
- [c] -> return $ TokLiteral $ LitChar (getRange i) c
- _ -> lexError
- "character literal must contain a single character"
+ do case s of
+ [c] -> return $ TokLiteral $ LitChar (getRange i) c
+ _ -> lexError
+ "character literal must contain a single character"
{--------------------------------------------------------------------------
@@ -48,9 +47,9 @@ litChar = stringToken '\'' $ \i s ->
-- | Custom error function.
litError :: String -> LookAhead a
litError msg =
- do sync
- liftP $ lexError $
- "Lexical error in string or character literal: " ++ msg
+ do sync
+ liftP $ lexError $
+ "Lexical error in string or character literal: " ++ msg
{--------------------------------------------------------------------------
@@ -62,13 +61,13 @@ litError msg =
-- characters).
stringToken :: Char -> (Interval -> String -> Parser tok) -> LexAction tok
stringToken del mkTok inp inp' n =
- do setLastPos (backupPos $ lexPos inp')
+ do setLastPos (backupPos $ lexPos inp')
setLexInput inp'
-- TODO: Should setPrevToken be run here? Compare with
-- Agda.Syntax.Parser.LexActions.token.
- tok <- runLookAhead litError $ lexString del ""
- i <- getParseInterval
- mkTok i tok
+ tok <- runLookAhead litError $ lexString del ""
+ i <- getParseInterval
+ mkTok i tok
-- | This is where the work happens. The string argument is an accumulating
@@ -76,90 +75,90 @@ stringToken del mkTok inp inp' n =
lexString :: Char -> String -> LookAhead String
lexString del s =
- do c <- nextChar
- case c of
+ do c <- nextChar
+ case c of
- c | c == del -> sync >> return (reverse s)
+ c | c == del -> sync >> return (reverse s)
- '\\' ->
- do c' <- nextChar
- case c' of
- '&' -> sync >> lexString del s
- c | isSpace c -> sync >> lexStringGap del s
- _ -> normalChar
+ '\\' ->
+ do c' <- nextChar
+ case c' of
+ '&' -> sync >> lexString del s
+ c | isSpace c -> sync >> lexStringGap del s
+ _ -> normalChar
- _ -> normalChar
+ _ -> normalChar
where
- normalChar =
- do rollback
- c <- lexChar
- lexString del (c:s)
+ normalChar =
+ do rollback
+ c <- lexChar
+ lexString del (c:s)
-- | A string gap consists of whitespace (possibly including line breaks)
-- enclosed in backslashes. The gap is not part of the resulting string.
lexStringGap :: Char -> String -> LookAhead String
lexStringGap del s =
- do c <- eatNextChar
- case c of
- '\\' -> lexString del s
- c | isSpace c -> lexStringGap del s
- _ -> fail "non-space in string gap"
+ do c <- eatNextChar
+ case c of
+ '\\' -> lexString del s
+ c | isSpace c -> lexStringGap del s
+ _ -> fail "non-space in string gap"
-- | Lex a single character.
lexChar :: LookAhead Char
lexChar =
- do c <- eatNextChar
- case c of
- '\\' -> lexEscape
- _ -> return c
+ do c <- eatNextChar
+ case c of
+ '\\' -> lexEscape
+ _ -> return c
-- | Lex an escaped character. Assumes the backslash has been lexed.
lexEscape :: LookAhead Char
lexEscape =
- do c <- eatNextChar
- case c of
- '^' -> do c <- eatNextChar
- if c >= '@' && c <= '_'
- then return (chr (ord c - ord '@'))
- else fail "invalid control character"
-
- 'x' -> readNum isHexDigit 16 hexDigit
- 'o' -> readNum isOctDigit 8 octDigit
- x | isDigit x
- -> readNumAcc isDigit 10 decDigit (decDigit x)
-
- c ->
- -- Try to match the input (starting with c) against the
- -- silly escape codes.
- do esc <- match' c (map (id -*- return) sillyEscapeChars)
- (fail "bad escape code")
- sync
- return esc
+ do c <- eatNextChar
+ case c of
+ '^' -> do c <- eatNextChar
+ if c >= '@' && c <= '_'
+ then return (chr (ord c - ord '@'))
+ else fail "invalid control character"
+
+ 'x' -> readNum isHexDigit 16 hexDigit
+ 'o' -> readNum isOctDigit 8 octDigit
+ x | isDigit x
+ -> readNumAcc isDigit 10 decDigit (decDigit x)
+
+ c ->
+ -- Try to match the input (starting with c) against the
+ -- silly escape codes.
+ do esc <- match' c (map (id -*- return) sillyEscapeChars)
+ (fail "bad escape code")
+ sync
+ return esc
-- | Read a number in the specified base.
readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> LookAhead Char
readNum isDigit base conv =
- do c <- eatNextChar
- if isDigit c
- then readNumAcc isDigit base conv (conv c)
- else fail "non-digit in numeral"
+ do c <- eatNextChar
+ if isDigit c
+ then readNumAcc isDigit base conv (conv c)
+ else fail "non-digit in numeral"
-- | Same as 'readNum' but with an accumulating parameter.
readNumAcc :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> LookAhead Char
readNumAcc isDigit base conv i = scan i
where
- scan i =
- do inp <- getInput
- c <- nextChar
- case c of
- c | isDigit c -> scan (i*base + conv c)
- _ ->
- do setInput inp
- sync
- if i >= ord minBound && i <= ord maxBound
- then return (chr i)
- else fail "character literal out of bounds"
+ scan i =
+ do inp <- getInput
+ c <- nextChar
+ case c of
+ c | isDigit c -> scan (i*base + conv c)
+ _ ->
+ do setInput inp
+ sync
+ if i >= ord minBound && i <= ord maxBound
+ then return (chr i)
+ else fail "character literal out of bounds"
-- | The escape codes.
sillyEscapeChars :: [(String, Char)]
diff --git a/src/full/Agda/Syntax/Parser/Tokens.hs b/src/full/Agda/Syntax/Parser/Tokens.hs
index 87680ee..65b47ea 100644
--- a/src/full/Agda/Syntax/Parser/Tokens.hs
+++ b/src/full/Agda/Syntax/Parser/Tokens.hs
@@ -1,4 +1,3 @@
-
module Agda.Syntax.Parser.Tokens
( Token(..)
, Keyword(..)
@@ -10,19 +9,21 @@ import Agda.Syntax.Literal (Literal)
import Agda.Syntax.Position
data Keyword
- = KwLet | KwIn | KwWhere | KwData | KwCoData
- | KwPostulate | KwMutual | KwAbstract | KwPrivate | KwInstance
- | KwOpen | KwImport | KwModule | KwPrimitive
- | KwInfix | KwInfixL | KwInfixR | KwWith | KwRewrite
- | KwSet | KwProp | KwForall | KwRecord | KwConstructor | KwField
+ = KwLet | KwIn | KwWhere | KwData | KwCoData
+ | KwPostulate | KwMutual | KwAbstract | KwPrivate | KwInstance
+ | KwOpen | KwImport | KwModule | KwPrimitive
+ | KwInfix | KwInfixL | KwInfixR | KwWith | KwRewrite
+ | KwSet | KwProp | KwForall | KwRecord | KwConstructor | KwField
| KwInductive | KwCoInductive
- | KwHiding | KwUsing | KwRenaming | KwTo | KwPublic
- | KwOPTIONS | KwBUILTIN | KwLINE
- | KwCOMPILED_DATA | KwCOMPILED_TYPE | KwCOMPILED | KwCOMPILED_EXPORT
+ | KwHiding | KwUsing | KwRenaming | KwTo | KwPublic
+ | KwOPTIONS | KwBUILTIN | KwLINE
+ | KwCOMPILED_DATA | KwCOMPILED_TYPE | KwCOMPILED | KwCOMPILED_EXPORT
| KwCOMPILED_EPIC | KwCOMPILED_JS
- | KwIMPORT | KwIMPOSSIBLE | KwETA | KwNO_TERMINATION_CHECK | KwNON_TERMINATING | KwMEASURE | KwSTATIC
+ | KwIMPORT | KwIMPOSSIBLE | KwETA | KwSTATIC
+ | KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING
+ | KwMEASURE
| KwREWRITE
- | KwQuoteGoal | KwQuoteContext | KwQuote | KwQuoteTerm | KwUnquote | KwUnquoteDecl | KwSyntax
+ | KwQuoteGoal | KwQuoteContext | KwQuote | KwQuoteTerm | KwUnquote | KwUnquoteDecl | KwSyntax
| KwPatternSyn | KwTactic
deriving (Eq, Show)
@@ -31,37 +32,37 @@ layoutKeywords =
[ KwLet, KwWhere, KwPostulate, KwMutual, KwAbstract, KwPrivate, KwInstance, KwPrimitive, KwField ]
data Symbol
- = SymDot | SymSemi | SymVirtualSemi | SymBar
- | SymColon | SymArrow | SymEqual | SymLambda
- | SymUnderscore | SymQuestionMark | SymAs
- | SymOpenParen | SymCloseParen
- | SymDoubleOpenBrace | SymDoubleCloseBrace
- | SymOpenBrace | SymCloseBrace
- | SymOpenVirtualBrace | SymCloseVirtualBrace
- | SymOpenPragma | SymClosePragma | SymEllipsis | SymDotDot
+ = SymDot | SymSemi | SymVirtualSemi | SymBar
+ | SymColon | SymArrow | SymEqual | SymLambda
+ | SymUnderscore | SymQuestionMark | SymAs
+ | SymOpenParen | SymCloseParen
+ | SymDoubleOpenBrace | SymDoubleCloseBrace
+ | SymOpenBrace | SymCloseBrace
+ | SymOpenVirtualBrace | SymCloseVirtualBrace
+ | SymOpenPragma | SymClosePragma | SymEllipsis | SymDotDot
| SymEndComment -- ^ A misplaced end-comment "-}".
deriving (Eq, Show)
data Token
- -- Keywords
- = TokKeyword Keyword Interval
- -- Identifiers and operators
- | TokId (Interval, String)
- | TokQId [(Interval, String)]
+ -- Keywords
+ = TokKeyword Keyword Interval
+ -- Identifiers and operators
+ | TokId (Interval, String)
+ | TokQId [(Interval, String)]
-- Non-empty namespace. The intervals for
-- "A.B.x" correspond to "A.", "B." and "x".
- -- Literals
- | TokLiteral Literal
- -- Special symbols
- | TokSymbol Symbol Interval
- -- Other tokens
- | TokString (Interval, String) -- arbitrary string, used in pragmas
- | TokSetN (Interval, Integer)
- | TokTeX (Interval, String)
+ -- Literals
+ | TokLiteral Literal
+ -- Special symbols
+ | TokSymbol Symbol Interval
+ -- Other tokens
+ | TokString (Interval, String) -- arbitrary string, used in pragmas
+ | TokSetN (Interval, Integer)
+ | TokTeX (Interval, String)
| TokComment (Interval, String)
- | TokDummy -- Dummy token to make Happy not complain
- -- about overlapping cases.
- | TokEOF
+ | TokDummy -- Dummy token to make Happy not complain
+ -- about overlapping cases.
+ | TokEOF
deriving (Eq, Show)
instance HasRange Token where
diff --git a/src/full/Agda/Syntax/Position.hs b/src/full/Agda/Syntax/Position.hs
index f07a40f..33ac69b 100644
--- a/src/full/Agda/Syntax/Position.hs
+++ b/src/full/Agda/Syntax/Position.hs
@@ -1,18 +1,18 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
#if __GLASGOW_HASKELL__ <= 700
{-# LANGUAGE OverlappingInstances #-}
#endif
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-| Position information for syntax. Crucial for giving good error messages.
@@ -83,10 +83,11 @@ import Test.QuickCheck.All
import Agda.Utils.FileName hiding (tests)
import Agda.Utils.Maybe
import Agda.Utils.Null
+import Agda.Utils.Pretty ( (<>), Pretty(pretty) )
import Agda.Utils.TestHelpers
import Agda.Utils.QuickCheck
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{--------------------------------------------------------------------------
@@ -118,6 +119,7 @@ positionInvariant :: Position' a -> Bool
positionInvariant p =
posPos p > 0 && posLine p > 0 && posCol p > 0
+importantPart :: Position' a -> (a, Int32)
importantPart p = (srcFile p, posPos p)
instance Eq a => Eq (Position' a) where
@@ -126,7 +128,7 @@ instance Eq a => Eq (Position' a) where
instance Ord a => Ord (Position' a) where
compare = compare `on` importantPart
-type SrcFile = Maybe AbsolutePath
+type SrcFile = Maybe AbsolutePath
type Position = Position' SrcFile
@@ -136,7 +138,7 @@ type Position = Position' SrcFile
data Interval' a = Interval { iStart, iEnd :: !(Position' a) }
deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable)
-type Interval = Interval' SrcFile
+type Interval = Interval' SrcFile
intervalInvariant :: Ord a => Interval' a -> Bool
intervalInvariant i =
@@ -155,7 +157,7 @@ iLength i = posPos (iEnd i) - posPos (iStart i)
newtype Range' a = Range [Interval' a]
deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable, Null)
-type Range = Range' SrcFile
+type Range = Range' SrcFile
rangeInvariant :: Range -> Bool
rangeInvariant (Range []) = True
@@ -219,15 +221,118 @@ class KillRange a where
type KillRangeT a = a -> a
-killRange1 f a = f (killRange a)
-killRange2 f a = killRange1 (f $ killRange a)
-killRange3 f a = killRange2 (f $ killRange a)
-killRange4 f a = killRange3 (f $ killRange a)
-killRange5 f a = killRange4 (f $ killRange a)
-killRange6 f a = killRange5 (f $ killRange a)
-killRange7 f a = killRange6 (f $ killRange a)
-killRange8 f a = killRange7 (f $ killRange a)
-killRange9 f a = killRange8 (f $ killRange a)
+killRange1 :: KillRange a => (a -> b) -> a -> b
+
+killRange2 :: (KillRange a, KillRange b) => (a -> b -> c) -> a -> b -> c
+
+killRange3 :: (KillRange a, KillRange b, KillRange c) =>
+ (a -> b -> c -> d) -> a -> b -> c -> d
+
+killRange4 :: (KillRange a, KillRange b, KillRange c, KillRange d) =>
+ (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e
+
+killRange5 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e ) =>
+ (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f
+
+killRange6 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f ) =>
+ (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g
+
+killRange7 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h) -> a -> b -> c -> d -> e -> f -> g -> h
+
+killRange8 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i
+
+killRange9 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j
+
+killRange10 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
+
+killRange11 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l
+
+killRange12 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m
+
+killRange13 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n
+
+killRange14 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m, KillRange n ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o
+
+killRange15 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m, KillRange n, KillRange o ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p
+
+killRange16 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m, KillRange n, KillRange o, KillRange p ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q
+
+killRange17 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m, KillRange n, KillRange o, KillRange p
+ , KillRange q ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r
+
+killRange18 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m, KillRange n, KillRange o, KillRange p
+ , KillRange q, KillRange r ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s
+
+killRange19 :: ( KillRange a, KillRange b, KillRange c, KillRange d
+ , KillRange e, KillRange f, KillRange g, KillRange h
+ , KillRange i, KillRange j, KillRange k, KillRange l
+ , KillRange m, KillRange n, KillRange o, KillRange p
+ , KillRange q, KillRange r, KillRange s ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s -> t) ->
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o -> p -> q -> r -> s -> t
+
+killRange1 f a = f (killRange a)
+killRange2 f a = killRange1 (f $ killRange a)
+killRange3 f a = killRange2 (f $ killRange a)
+killRange4 f a = killRange3 (f $ killRange a)
+killRange5 f a = killRange4 (f $ killRange a)
+killRange6 f a = killRange5 (f $ killRange a)
+killRange7 f a = killRange6 (f $ killRange a)
+killRange8 f a = killRange7 (f $ killRange a)
+killRange9 f a = killRange8 (f $ killRange a)
killRange10 f a = killRange9 (f $ killRange a)
killRange11 f a = killRange10 (f $ killRange a)
killRange12 f a = killRange11 (f $ killRange a)
@@ -268,9 +373,13 @@ instance (KillRange a, KillRange b) => KillRange (Either a b) where
killRange (Left x) = Left $ killRange x
killRange (Right x) = Right $ killRange x
-{--------------------------------------------------------------------------
- Pretty printing
- --------------------------------------------------------------------------}
+------------------------------------------------------------------------
+-- Showing
+------------------------------------------------------------------------
+
+-- TODO: 'Show' should output Haskell-parseable representations.
+-- The following instances are deprecated, and Pretty should be used
+-- instead. Later, simply derive Show for these types:
instance Show a => Show (Position' (Maybe a)) where
show (Pn Nothing _ l c) = show l ++ "," ++ show c
@@ -278,25 +387,34 @@ instance Show a => Show (Position' (Maybe a)) where
instance Show a => Show (Interval' (Maybe a)) where
show (Interval s e) = file ++ start ++ "-" ++ end
- where
- f = srcFile s
- sl = posLine s
- el = posLine e
- sc = posCol s
- ec = posCol e
- file = case f of
+ where
+ f = srcFile s
+ sl = posLine s
+ el = posLine e
+ sc = posCol s
+ ec = posCol e
+ file = case f of
Nothing -> ""
Just f -> show f ++ ":"
- start = show sl ++ "," ++ show sc
- end
- | sl == el = show ec
- | otherwise = show el ++ "," ++ show ec
+ start = show sl ++ "," ++ show sc
+ end
+ | sl == el = show ec
+ | otherwise = show el ++ "," ++ show ec
instance Show a => Show (Range' (Maybe a)) where
show r = case rangeToInterval r of
Nothing -> ""
Just i -> show i
+------------------------------------------------------------------------
+-- Printing
+------------------------------------------------------------------------
+
+instance Pretty a => Pretty (Position' (Maybe a)) where
+ pretty (Pn Nothing _ l c) = pretty l <> pretty "," <> pretty c
+ pretty (Pn (Just f) _ l c) =
+ pretty f <> pretty ":" <> pretty l <> pretty "," <> pretty c
+
{--------------------------------------------------------------------------
Functions on postitions and ranges
--------------------------------------------------------------------------}
@@ -315,7 +433,7 @@ noRange = Range []
-- position to the next column.
movePos :: Position' a -> Char -> Position' a
movePos (Pn f p l c) '\n' = Pn f (p + 1) (l + 1) 1
-movePos (Pn f p l c) _ = Pn f (p + 1) l (c + 1)
+movePos (Pn f p l c) _ = Pn f (p + 1) l (c + 1)
-- | Advance the position by a string.
--
@@ -448,12 +566,16 @@ makeInterval s
| Set.null s = Set.empty
| otherwise = Set.fromList [Set.findMin s .. Set.findMax s]
+prop_iLength :: Interval' Integer -> Bool
prop_iLength i = iLength i >= 0
+prop_startPos :: Maybe AbsolutePath -> Bool
prop_startPos = positionInvariant . startPos
+prop_noRange :: Bool
prop_noRange = rangeInvariant noRange
+prop_takeI_dropI :: Interval' Integer -> Property
prop_takeI_dropI i =
forAll (choose (0, toInteger $ iLength i)) $ \n ->
let s = genericReplicate n ' '
@@ -464,17 +586,20 @@ prop_takeI_dropI i =
intervalInvariant d &&
fuseIntervals t d == i
+prop_rangeToInterval :: Range' Integer -> Bool
prop_rangeToInterval (Range []) = True
prop_rangeToInterval r =
intervalInvariant i &&
iPositions i == makeInterval (rPositions r)
where Just i = rangeToInterval r
+prop_continuous :: Range -> Bool
prop_continuous r =
rangeInvariant cr &&
rPositions cr == makeInterval (rPositions r)
where cr = continuous r
+prop_fuseIntervals :: Interval' Integer -> Property
prop_fuseIntervals i1 =
forAll (intervalInSameFileAs i1) $ \i2 ->
let i = fuseIntervals i1 i2 in
@@ -488,8 +613,10 @@ prop_fuseRanges r1 r2 =
rPositions r == Set.union (rPositions r1) (rPositions r2)
where r = fuseRanges r1 r2
+prop_beginningOf :: Range -> Bool
prop_beginningOf r = rangeInvariant (beginningOf r)
+prop_beginningOfFile :: Range -> Bool
prop_beginningOfFile r = rangeInvariant (beginningOfFile r)
instance Arbitrary a => Arbitrary (Position' a) where
@@ -511,8 +638,10 @@ setFile f (Interval p1 p2) =
-- | Generates an interval located in the same file as the given
-- interval.
+intervalInSameFileAs :: Interval' Integer -> Gen (Interval' Integer)
intervalInSameFileAs i = setFile (srcFile $ iStart i) <$> arbitrary
+prop_intervalInSameFileAs :: Interval' Integer -> Property
prop_intervalInSameFileAs i =
forAll (intervalInSameFileAs i) $ \i' ->
intervalInvariant i' &&
@@ -535,9 +664,14 @@ instance (Ord a, Arbitrary a) => Arbitrary (Range' a) where
| otherwise = i1 : fuse (i2 : is)
fuse is = is
+prop_positionInvariant :: Position' Integer -> Bool
prop_positionInvariant = positionInvariant
+
+prop_intervalInvariant :: Interval' Integer -> Bool
prop_intervalInvariant = intervalInvariant
-prop_rangeInvariant = rangeInvariant
+
+prop_rangeInvariant :: Range -> Bool
+prop_rangeInvariant = rangeInvariant
instance Show (Position' Integer) where show = show . fmap Just
instance Show (Interval' Integer) where show = show . fmap Just
diff --git a/src/full/Agda/Syntax/Scope/Base.hs b/src/full/Agda/Syntax/Scope/Base.hs
index 528454c..34d9e45 100644
--- a/src/full/Agda/Syntax/Scope/Base.hs
+++ b/src/full/Agda/Syntax/Scope/Base.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
{-| This module defines the notion of a scope and operations on scopes.
@@ -12,14 +12,17 @@ module Agda.Syntax.Scope.Base where
import Control.Arrow ((***), first, second)
import Control.Applicative
+import Control.DeepSeq
import Data.Function
-import Data.List
+import Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Typeable (Typeable)
+-- import Debug.Trace (trace)
+
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Fixity
@@ -28,10 +31,14 @@ import Agda.Syntax.Concrete.Name as C
import Agda.Syntax.Concrete
(ImportDirective(..), UsingOrHiding(..), ImportedName(..), Renaming(..))
-import qualified Agda.Utils.Map as Map
+import Agda.Utils.AssocList (AssocList)
+import qualified Agda.Utils.AssocList as AssocList
+import Agda.Utils.Functor
+import Agda.Utils.Lens
import Agda.Utils.List
+import qualified Agda.Utils.Map as Map
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- * Scope representation
@@ -41,15 +48,24 @@ import Agda.Utils.Impossible
data Scope = Scope
{ scopeName :: A.ModuleName
, scopeParents :: [A.ModuleName]
- , scopeNameSpaces :: [(NameSpaceId, NameSpace)]
+ , scopeNameSpaces :: ScopeNameSpaces
, scopeImports :: Map C.QName A.ModuleName
, scopeDatatypeModule :: Bool
}
deriving (Typeable)
-data NameSpaceId = PrivateNS | PublicNS | ImportedNS | OnlyQualifiedNS
+-- | See 'Agda.Syntax.Common.Access'.
+data NameSpaceId
+ = PrivateNS -- ^ Things not exported by this module.
+ | PublicNS -- ^ Things defined and exported by this module.
+ | ImportedNS -- ^ Things from open public, exported by this module.
+ | OnlyQualifiedNS -- ^ Visible (as qualified) from outside,
+ -- but not exported when opening the module.
+ -- Used for qualified constructors.
deriving (Typeable, Eq, Bounded, Enum)
+type ScopeNameSpaces = [(NameSpaceId, NameSpace)]
+
localNameSpace :: Access -> NameSpaceId
localNameSpace PublicAccess = PublicNS
localNameSpace PrivateAccess = PrivateNS
@@ -63,25 +79,74 @@ nameSpaceAccess _ = PublicAccess
scopeNameSpace :: NameSpaceId -> Scope -> NameSpace
scopeNameSpace ns = fromMaybe __IMPOSSIBLE__ . lookup ns . scopeNameSpaces
+-- | A lens for 'scopeNameSpaces'
+updateScopeNameSpaces :: (ScopeNameSpaces -> ScopeNameSpaces) -> Scope -> Scope
+updateScopeNameSpaces f s = s { scopeNameSpaces = f (scopeNameSpaces s) }
+
+-- | ``Monadic'' lens (Functor sufficient).
+updateScopeNameSpacesM ::
+ (Functor m) => (ScopeNameSpaces -> m ScopeNameSpaces) -> Scope -> m Scope
+updateScopeNameSpacesM f s = for (f $ scopeNameSpaces s) $ \ x ->
+ s { scopeNameSpaces = x }
+
-- | The complete information about the scope at a particular program point
-- includes the scope stack, the local variables, and the context precedence.
data ScopeInfo = ScopeInfo
{ scopeCurrent :: A.ModuleName
, scopeModules :: Map A.ModuleName Scope
- , scopeLocals :: LocalVars
+ , scopeLocals :: LocalVars
, scopePrecedence :: Precedence
}
deriving (Typeable)
-- | Local variables.
-type LocalVars = [(C.Name, A.Name)]
+type LocalVars = AssocList C.Name LocalVar
+
+-- | A local variable can be shadowed by an import.
+-- In case of reference to a shadowed variable, we want to report
+-- a scope error.
+data LocalVar
+ = LocalVar { localVar :: A.Name }
+ -- ^ Unique ID of local variable.
+ | ShadowedVar { localVar :: A.Name, localShadowedBy :: [AbstractName] }
+ -- ^ This local variable is shadowed by one or more imports.
+ -- (List not empty).
+ deriving (Typeable)
+
+instance NFData LocalVar
+
+instance Eq LocalVar where
+ (==) = (==) `on` localVar
+
+instance Ord LocalVar where
+ compare = compare `on` localVar
+
+-- | We show shadowed variables as prefixed by a ".", as not in scope.
+instance Show LocalVar where
+ show (LocalVar x) = show x
+ show (ShadowedVar x xs) = "." ++ show x
+
+-- | Shadow a local name by a non-empty list of imports.
+shadowLocal :: [AbstractName] -> LocalVar -> LocalVar
+shadowLocal [] _ = __IMPOSSIBLE__
+shadowLocal ys (LocalVar x ) = ShadowedVar x ys
+shadowLocal ys (ShadowedVar x zs) = ShadowedVar x (ys ++ zs)
+
+-- | Project name of unshadowed local variable.
+notShadowedLocal :: LocalVar -> Maybe A.Name
+notShadowedLocal (LocalVar x) = Just x
+notShadowedLocal ShadowedVar{} = Nothing
+
+-- | Get all locals that are not shadowed.
+notShadowedLocals :: LocalVars -> AssocList C.Name A.Name
+notShadowedLocals = mapMaybe $ \ (c,x) -> (c,) <$> notShadowedLocal x
-- | Lens for 'scopeLocals'.
-modifyScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
-modifyScopeLocals f sc = sc { scopeLocals = f (scopeLocals sc) }
+updateScopeLocals :: (LocalVars -> LocalVars) -> ScopeInfo -> ScopeInfo
+updateScopeLocals f sc = sc { scopeLocals = f (scopeLocals sc) }
setScopeLocals :: LocalVars -> ScopeInfo -> ScopeInfo
-setScopeLocals vars = modifyScopeLocals (const vars)
+setScopeLocals vars = updateScopeLocals (const vars)
------------------------------------------------------------------------
-- * Name spaces
@@ -93,7 +158,7 @@ setScopeLocals vars = modifyScopeLocals (const vars)
-- write to the abstract fully qualified names that the type checker wants to
-- read.
data NameSpace = NameSpace
- { nsNames :: NamesInScope
+ { nsNames :: NamesInScope
-- ^ Maps concrete names to a list of abstract names.
, nsModules :: ModulesInScope
-- ^ Maps concrete module names to a list of abstract module names.
@@ -189,12 +254,20 @@ instance Eq AbstractName where
instance Ord AbstractName where
compare = compare `on` anameName
+-- | Van Laarhoven lens on 'anameName'.
+lensAnameName :: Functor m => (A.QName -> m A.QName) -> AbstractName -> m AbstractName
+lensAnameName f am = f (anameName am) <&> \ m -> am { anameName = m }
+
instance Eq AbstractModule where
(==) = (==) `on` amodName
instance Ord AbstractModule where
compare = compare `on` amodName
+-- | Van Laarhoven lens on 'amodName'.
+lensAmodName :: Functor m => (A.ModuleName -> m A.ModuleName) -> AbstractModule -> m AbstractModule
+lensAmodName f am = f (amodName am) <&> \ m -> am { amodName = m }
+
-- * Operations on name and module maps.
mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a
@@ -211,31 +284,30 @@ emptyNameSpace = NameSpace Map.empty Map.empty
-- | Map functions over the names and modules in a name space.
mapNameSpace :: (NamesInScope -> NamesInScope ) ->
- (ModulesInScope -> ModulesInScope) ->
- NameSpace -> NameSpace
+ (ModulesInScope -> ModulesInScope) ->
+ NameSpace -> NameSpace
mapNameSpace fd fm ns =
- ns { nsNames = fd $ nsNames ns
+ ns { nsNames = fd $ nsNames ns
, nsModules = fm $ nsModules ns
}
-- | Zip together two name spaces.
zipNameSpace :: (NamesInScope -> NamesInScope -> NamesInScope ) ->
- (ModulesInScope -> ModulesInScope -> ModulesInScope) ->
- NameSpace -> NameSpace -> NameSpace
+ (ModulesInScope -> ModulesInScope -> ModulesInScope) ->
+ NameSpace -> NameSpace -> NameSpace
zipNameSpace fd fm ns1 ns2 =
- ns1 { nsNames = nsNames ns1 `fd` nsNames ns2
+ ns1 { nsNames = nsNames ns1 `fd` nsNames ns2
, nsModules = nsModules ns1 `fm` nsModules ns2
}
-- | Map monadic function over a namespace.
-mapNameSpaceM :: Monad m =>
+mapNameSpaceM :: Applicative m =>
(NamesInScope -> m NamesInScope ) ->
(ModulesInScope -> m ModulesInScope) ->
NameSpace -> m NameSpace
-mapNameSpaceM fd fm ns = do
- ds <- fd $ nsNames ns
- ms <- fm $ nsModules ns
- return $ ns { nsNames = ds, nsModules = ms }
+mapNameSpaceM fd fm ns = update ns <$> fd (nsNames ns) <*> fm (nsModules ns)
+ where
+ update ns ds ms = ns { nsNames = ds, nsModules = ms }
------------------------------------------------------------------------
-- * General operations on scopes
@@ -256,39 +328,36 @@ emptyScopeInfo :: ScopeInfo
emptyScopeInfo = ScopeInfo
{ scopeCurrent = noModuleName
, scopeModules = Map.singleton noModuleName emptyScope
- , scopeLocals = []
+ , scopeLocals = []
, scopePrecedence = TopCtx
}
-- | Map functions over the names and modules in a scope.
mapScope :: (NameSpaceId -> NamesInScope -> NamesInScope ) ->
- (NameSpaceId -> ModulesInScope -> ModulesInScope) ->
- Scope -> Scope
-mapScope fd fm s =
- s { scopeNameSpaces = [ (nsid, mapNS nsid ns) | (nsid, ns) <- scopeNameSpaces s ] }
+ (NameSpaceId -> ModulesInScope -> ModulesInScope) ->
+ Scope -> Scope
+mapScope fd fm = updateScopeNameSpaces $ AssocList.mapWithKey mapNS
where
mapNS acc = mapNameSpace (fd acc) (fm acc)
-- | Same as 'mapScope' but applies the same function to all name spaces.
mapScope_ :: (NamesInScope -> NamesInScope ) ->
- (ModulesInScope -> ModulesInScope) ->
- Scope -> Scope
+ (ModulesInScope -> ModulesInScope) ->
+ Scope -> Scope
mapScope_ fd fm = mapScope (const fd) (const fm)
-- | Map monadic functions over the names and modules in a scope.
-mapScopeM :: (Functor m, Monad m) =>
+mapScopeM :: (Functor m, Applicative m) =>
(NameSpaceId -> NamesInScope -> m NamesInScope ) ->
(NameSpaceId -> ModulesInScope -> m ModulesInScope) ->
Scope -> m Scope
-mapScopeM fd fm s = do
- nss <- sequence [ (,) nsid <$> mapNS nsid ns | (nsid, ns) <- scopeNameSpaces s ]
- return $ s { scopeNameSpaces = nss }
+mapScopeM fd fm = updateScopeNameSpacesM $ AssocList.mapWithKeyM mapNS
where
mapNS acc = mapNameSpaceM (fd acc) (fm acc)
-- | Same as 'mapScopeM' but applies the same function to both the public and
-- private name spaces.
-mapScopeM_ :: (Functor m, Monad m) =>
+mapScopeM_ :: (Functor m, Applicative m) =>
(NamesInScope -> m NamesInScope ) ->
(ModulesInScope -> m ModulesInScope) ->
Scope -> m Scope
@@ -297,8 +366,8 @@ mapScopeM_ fd fm = mapScopeM (const fd) (const fm)
-- | Zip together two scopes. The resulting scope has the same name as the
-- first scope.
zipScope :: (NameSpaceId -> NamesInScope -> NamesInScope -> NamesInScope ) ->
- (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) ->
- Scope -> Scope -> Scope
+ (NameSpaceId -> ModulesInScope -> ModulesInScope -> ModulesInScope) ->
+ Scope -> Scope -> Scope
zipScope fd fm s1 s2 =
s1 { scopeNameSpaces = [ (nsid, zipNS nsid ns1 ns2)
| ((nsid, ns1), (nsid', ns2)) <- zipWith' (,) (scopeNameSpaces s1) (scopeNameSpaces s2)
@@ -314,8 +383,8 @@ zipScope fd fm s1 s2 =
-- | Same as 'zipScope' but applies the same function to both the public and
-- private name spaces.
zipScope_ :: (NamesInScope -> NamesInScope -> NamesInScope ) ->
- (ModulesInScope -> ModulesInScope -> ModulesInScope) ->
- Scope -> Scope -> Scope
+ (ModulesInScope -> ModulesInScope -> ModulesInScope) ->
+ Scope -> Scope -> Scope
zipScope_ fd fm = zipScope (const fd) (const fm)
-- | Filter a scope keeping only concrete names matching the predicates.
@@ -364,8 +433,7 @@ mergeScopes ss = foldr1 mergeScope ss
-- | Move all names in a scope to the given name space (except never move from
-- Imported to Public).
setScopeAccess :: NameSpaceId -> Scope -> Scope
-setScopeAccess a s = s { scopeNameSpaces = [ (nsid, ns nsid) | (nsid, _) <- scopeNameSpaces s ]
- }
+setScopeAccess a s = (`updateScopeNameSpaces` s) $ AssocList.mapWithKey $ const . ns
where
zero = emptyNameSpace
one = allThingsInScope s
@@ -378,10 +446,9 @@ setScopeAccess a s = s { scopeNameSpaces = [ (nsid, ns nsid) | (nsid, _) <- scop
_ | a == b -> one
| otherwise -> zero
+-- | Update a particular name space.
setNameSpace :: NameSpaceId -> NameSpace -> Scope -> Scope
-setNameSpace nsid ns s =
- s { scopeNameSpaces = [ (nsid', if nsid == nsid' then ns else ns')
- | (nsid', ns') <- scopeNameSpaces s ] }
+setNameSpace nsid ns = updateScopeNameSpaces $ AssocList.update nsid ns
-- | Add names to a scope.
addNamesToScope :: NameSpaceId -> C.Name -> [AbstractName] -> Scope -> Scope
@@ -413,54 +480,53 @@ applyImportDirective :: ImportDirective -> Scope -> Scope
applyImportDirective dir s = mergeScope usedOrHidden renamed
where
usedOrHidden = useOrHide (hideLHS (renaming dir) $ usingOrHiding dir) s
- renamed = rename (renaming dir) $ useOrHide useRenamedThings s
+ renamed = rename (renaming dir) $ useOrHide useRenamedThings s
useRenamedThings = Using $ map renFrom $ renaming dir
hideLHS :: [Renaming] -> UsingOrHiding -> UsingOrHiding
- hideLHS _ i@(Using _) = i
+ hideLHS _ i@(Using _) = i
hideLHS ren (Hiding xs) = Hiding $ xs ++ map renFrom ren
useOrHide :: UsingOrHiding -> Scope -> Scope
useOrHide (Hiding xs) s = filterNames notElem notElem xs s
- useOrHide (Using xs) s = filterNames elem elem xs s
+ useOrHide (Using xs) s = filterNames elem elem xs s
filterNames :: (C.Name -> [C.Name] -> Bool) -> (C.Name -> [C.Name] -> Bool) ->
- [ImportedName] -> Scope -> Scope
+ [ImportedName] -> Scope -> Scope
filterNames pd pm xs = filterScope' (flip pd ds) (flip pm ms)
where
- ds = [ x | ImportedName x <- xs ]
- ms = [ m | ImportedModule m <- xs ]
+ ds = [ x | ImportedName x <- xs ]
+ ms = [ m | ImportedModule m <- xs ]
filterScope' pd pm = filterScope pd pm
-- Renaming
rename :: [Renaming] -> Scope -> Scope
rename rho = mapScope_ (Map.mapKeys $ ren drho)
- (Map.mapKeys $ ren mrho)
+ (Map.mapKeys $ ren mrho)
where
- mrho = [ (x, y) | Renaming { renFrom = ImportedModule x, renTo = y } <- rho ]
- drho = [ (x, y) | Renaming { renFrom = ImportedName x, renTo = y } <- rho ]
+ mrho = [ (x, y) | Renaming { renFrom = ImportedModule x, renTo = y } <- rho ]
+ drho = [ (x, y) | Renaming { renFrom = ImportedName x, renTo = y } <- rho ]
- ren r x = maybe x id $ lookup x r
+ ren r x = fromMaybe x $ lookup x r
-- | Rename the abstract names in a scope.
renameCanonicalNames :: Map A.QName A.QName -> Map A.ModuleName A.ModuleName ->
- Scope -> Scope
+ Scope -> Scope
renameCanonicalNames renD renM = mapScope_ renameD renameM
where
- renameD = Map.map (map $ onName rD)
- renameM = Map.map (map $ onMName rM)
-
- onName f x = x { anameName = f $ anameName x }
- onMName f x = x { amodName = f $ amodName x }
+ renameD = Map.map $ map $ over lensAnameName $ \ x -> Map.findWithDefault x x renD
+ renameM = Map.map $ map $ over lensAmodName $ \ x -> Map.findWithDefault x x renM
- rD x = maybe x id $ Map.lookup x renD
- rM x = maybe x id $ Map.lookup x renM
-
--- | Restrict the private name space of a scope
+-- | Remove private name space of a scope.
+--
+-- Should be a right identity for 'exportedNamesInScope'.
+-- @exportedNamesInScope . restrictPrivate == exportedNamesInscope at .
restrictPrivate :: Scope -> Scope
-restrictPrivate s = setNameSpace PrivateNS emptyNameSpace $ s { scopeImports = Map.empty }
+restrictPrivate s
+ = setNameSpace PrivateNS emptyNameSpace
+ $ s { scopeImports = Map.empty }
-- | Remove names that can only be used qualified (when opening a scope)
removeOnlyQualified :: Scope -> Scope
@@ -475,35 +541,31 @@ inScopeBecause f = mapScope_ mapName mapMod
-- | Get the public parts of the public modules of a scope
publicModules :: ScopeInfo -> Map A.ModuleName Scope
-publicModules scope = Map.filterWithKey (\m _ -> reachable m) allMods
+publicModules scope = Map.filterWithKey (\ m _ -> reachable m) allMods
where
+ -- Get all modules in the ScopeInfo.
allMods = Map.map restrictPrivate $ scopeModules scope
root = scopeCurrent scope
+
modules s = map amodName $ concat $ Map.elems $ allNamesInScope s
- chase m = m : case Map.lookup m allMods of
- Just s -> concatMap chase $ modules s
- Nothing -> __IMPOSSIBLE__
+ chase m = m : concatMap chase ms
+ where ms = maybe __IMPOSSIBLE__ modules $ Map.lookup m allMods
reachable = (`elem` chase root)
everythingInScope :: ScopeInfo -> NameSpace
-everythingInScope scope =
- allThingsInScope
- $ mergeScopes
+everythingInScope scope = allThingsInScope $ mergeScopes $
[ s | (m, s) <- Map.toList (scopeModules scope), m `elem` current ]
where
this = scopeCurrent scope
- parents = case Map.lookup this (scopeModules scope) of
- Just s -> scopeParents s
- Nothing -> __IMPOSSIBLE__
+ parents = maybe __IMPOSSIBLE__ scopeParents $ Map.lookup this $ scopeModules scope
current = this : parents
-- | 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.filterKeys (\q -> elem (init $ C.qnameParts q) ([]:ms)) $
Map.unionWith (++)
(build ms allNamesInScope root)
imported
@@ -529,7 +591,7 @@ flattenScope ms scope =
$ Map.unionsWith (++) $
[ Map.mapKeys (\y -> C.Qual x y) $ build ms' exportedNamesInScope $ moduleScope m
| (x, mods) <- Map.toList (getNames s)
- , let ms' = [ ms' | m':ms' <- ms, m' == x ]
+ , let ms' = [ tl | hd:tl <- ms, hd == x ]
, not $ null ms'
, AbsModule m _ <- mods ]
@@ -541,61 +603,77 @@ scopeLookup :: InScope a => C.QName -> ScopeInfo -> [a]
scopeLookup q scope = map fst $ scopeLookup' q scope
scopeLookup' :: forall a. InScope a => C.QName -> ScopeInfo -> [(a, Access)]
-scopeLookup' q scope = nubBy ((==) `on` fst) $ findName q root ++ imports
+scopeLookup' q scope = nubBy ((==) `on` fst) $ findName q root ++ topImports ++ imports
where
+ -- 1. Finding a name in the current scope and its parents.
+
+ moduleScope :: A.ModuleName -> Scope
+ moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
+
current :: Scope
current = moduleScope $ scopeCurrent scope
root :: Scope
root = mergeScopes $ current : map moduleScope (scopeParents current)
- -- return all possible splittings, e.g.
- -- splitName X.Y.Z = [(X, Y.Z), (X.Y, Z)]
- splitName :: C.QName -> [(C.QName, C.QName)]
- splitName (C.QName x) = []
- splitName (C.Qual x q) = (C.QName x, q) : do
- (m, r) <- splitName q
- return (C.Qual x m, r)
+ -- | Find a concrete, possibly qualified name in scope @s at .
+ findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)]
+ findName q0 s = case q0 of
+ C.QName x -> lookupName x s
+ C.Qual x q -> do
+ let -- | Get the modules named @x@ in scope @s at .
+ mods :: [A.ModuleName]
+ mods = amodName . fst <$> lookupName x s
+ -- | Get the definitions named @x@ in scope @s@ and interpret them as modules.
+ -- Andreas, 2013-05-01: Issue 836 debates this feature:
+ -- Qualified constructors are qualified by their datatype rather than a module
+ defs :: [A.ModuleName]
+ defs = mnameFromList . qnameToList . anameName . fst <$> lookupName x s
+ -- Andreas, 2013-05-01: Issue 836 complains about the feature
+ -- that constructors can also be qualified by their datatype
+ -- and projections by their record type. This feature is off
+ -- if we just consider the modules:
+ -- m <- mods
+ -- The feature is on if we consider also the data and record types:
+ -- trace ("mods ++ defs = " ++ show (mods ++ defs)) $ do
+ m <- nub $ mods ++ defs -- record types will appear both as a mod and a def
+ -- Get the scope of module m, if any, and remove its private definitions.
+ let ss = maybeToList $ Map.lookup m $ scopeModules scope
+ ss' = restrictPrivate <$> ss
+ -- trace ("ss = " ++ show ss ) $ do
+ -- trace ("ss' = " ++ show ss') $ do
+ s' <- ss'
+ findName q s'
+ where
+ lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)]
+ lookupName x s = fromMaybe [] $ Map.lookup x $ allNamesInScope' s
- imported :: C.QName -> [(A.ModuleName, Access)]
- imported q = maybe [] ((:[]) . (, PublicAccess)) $ Map.lookup q $ scopeImports root
+ -- 2. Finding a name in the top imports.
topImports :: [(a, Access)]
topImports = case (inScopeTag :: InScopeTag a) of
NameTag -> []
ModuleTag -> map (first (`AbsModule` Defined)) (imported q)
+ imported :: C.QName -> [(A.ModuleName, Access)]
+ imported q = map (,PublicAccess) $ maybeToList $ Map.lookup q $ scopeImports root
+
+ -- 3. Finding a name in the imports belonging to an initial part of the qualifier.
+
imports :: [(a, Access)]
- imports = topImports ++ do
+ imports = do
(m, x) <- splitName q
m <- fst <$> imported m
findName x (restrictPrivate $ moduleScope m)
- moduleScope :: A.ModuleName -> Scope
- moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scopeModules scope
-
- lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)]
- lookupName x s = maybe [] id $ Map.lookup x (allNamesInScope' s)
+ -- return all possible splittings, e.g.
+ -- splitName X.Y.Z = [(X, Y.Z), (X.Y, Z)]
+ splitName :: C.QName -> [(C.QName, C.QName)]
+ splitName (C.QName x) = []
+ splitName (C.Qual x q) =
+ (C.QName x, q) : [ (C.Qual x m, r) | (m, r) <- splitName q ]
- findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)]
- findName (C.QName x) s = lookupName x s
- findName (C.Qual x q) s = do
- -- Andreas, 2013-05-01: Issue 836 complains about the feature
- -- that constructors can also be qualified by their datatype
- -- and projections by their record type. This feature is off
- -- if we just consider the modules:
- -- m <- mods
- -- The feature is on if we consider also the data and record types:
- m <- nub $ mods ++ defs -- record types will appear both as a mod and a def
- Just s' <- return $ Map.lookup m (scopeModules scope)
- findName q (restrictPrivate s')
- where
- mods, defs :: [ModuleName]
- mods = amodName . fst <$> lookupName x s
- -- Andreas, 2013-05-01: Issue 836 debates this feature:
- -- Qualified constructors are qualified by their datatype rather than a module
- defs = mnameFromList . qnameToList . anameName . fst <$> lookupName x s
-- * Inverse look-up
@@ -626,9 +704,8 @@ inverseScopeLookup' ambCon name scope = case name of
len (C.QName _) = 1
len (C.Qual _ x) = 1 + len x
- best xs = case sortBy (compare `on` len) xs of
- [] -> Nothing
- x : _ -> Just x
+ best :: [C.QName] -> Maybe C.QName
+ best xs = headMaybe $ sortBy (compare `on` len) xs
unique :: forall a . [a] -> Bool
unique [] = __IMPOSSIBLE__
@@ -641,7 +718,7 @@ inverseScopeLookup' ambCon name scope = case name of
findName :: Ord a => Map a [(A.ModuleName, C.Name)] -> a -> [C.QName]
findName table q = do
- (m, x) <- maybe [] id $ Map.lookup q table
+ (m, x) <- fromMaybe [] $ Map.lookup q table
if m `elem` current
then return (C.QName x)
else do
@@ -650,7 +727,7 @@ inverseScopeLookup' ambCon name scope = case name of
findModule :: A.ModuleName -> [C.QName]
findModule q = findName moduleMap q ++
- maybe [] id (Map.lookup q importMap)
+ fromMaybe [] (Map.lookup q importMap)
importMap = Map.unionsWith (++) $ do
(m, s) <- scopes
@@ -707,7 +784,7 @@ instance Show NameSpace where
pr (x, y) = show x ++ " --> " ++ show y
instance Show Scope where
- show (scope @ Scope { scopeName = name, scopeParents = parents, scopeImports = imps }) =
+ show (scope at Scope{ scopeName = name, scopeParents = parents, scopeImports = imps }) =
unlines $
[ "* scope " ++ show name ] ++ ind (
concat [ blockOfLines (show nsid) (lines $ show $ scopeNameSpace nsid scope)
diff --git a/src/full/Agda/Syntax/Scope/Monad.hs b/src/full/Agda/Syntax/Scope/Monad.hs
index 0bac96a..0b7f399 100644
--- a/src/full/Agda/Syntax/Scope/Monad.hs
+++ b/src/full/Agda/Syntax/Scope/Monad.hs
@@ -12,7 +12,7 @@ import Control.Monad hiding (mapM)
import Control.Monad.Writer hiding (mapM)
import Control.Monad.State hiding (mapM)
-import Data.List
+import Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
@@ -30,12 +30,15 @@ import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.State
import Agda.TypeChecking.Monad.Options
-import Agda.Utils.Tuple
-import Agda.Utils.Fresh
-import Agda.Utils.Size
+import qualified Agda.Utils.AssocList as AssocList
+import Agda.Utils.Function
import Agda.Utils.List
+import Agda.Utils.Maybe
+import Agda.Utils.Null (unlessNull)
+import Agda.Utils.Size
+import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- * The scope checking monad
@@ -98,9 +101,7 @@ createModule b m = do
-- | Apply a function to the scope info.
modifyScopeInfo :: (ScopeInfo -> ScopeInfo) -> ScopeM ()
-modifyScopeInfo f = do
- scope <- getScope
- setScope $ f scope
+modifyScopeInfo = modifyScope
-- | Apply a function to the scope map.
modifyScopes :: (Map A.ModuleName Scope -> Map A.ModuleName Scope) -> ScopeM ()
@@ -110,32 +111,24 @@ modifyScopes f = modifyScopeInfo $ \s -> s { scopeModules = f $ scopeModules s }
modifyNamedScope :: A.ModuleName -> (Scope -> Scope) -> ScopeM ()
modifyNamedScope m f = modifyScopes $ Map.adjust f m
--- | Apply a function to the current scope.
-modifyCurrentScope :: (Scope -> Scope) -> ScopeM ()
-modifyCurrentScope f = do
- m <- getCurrentModule
- modifyNamedScope m f
+setNamedScope :: A.ModuleName -> Scope -> ScopeM ()
+setNamedScope m s = modifyNamedScope m $ const s
-- | Apply a monadic function to the top scope.
modifyNamedScopeM :: A.ModuleName -> (Scope -> ScopeM Scope) -> ScopeM ()
-modifyNamedScopeM m f = do
- s <- getNamedScope m
- s' <- f s
- modifyNamedScope m (const s')
+modifyNamedScopeM m f = setNamedScope m =<< f =<< getNamedScope m
+
+-- | Apply a function to the current scope.
+modifyCurrentScope :: (Scope -> Scope) -> ScopeM ()
+modifyCurrentScope f = getCurrentModule >>= (`modifyNamedScope` f)
modifyCurrentScopeM :: (Scope -> ScopeM Scope) -> ScopeM ()
-modifyCurrentScopeM f = do
- m <- getCurrentModule
- modifyNamedScopeM m f
+modifyCurrentScopeM f = getCurrentModule >>= (`modifyNamedScopeM` f)
-- | Apply a function to the public or private name space.
modifyCurrentNameSpace :: NameSpaceId -> (NameSpace -> NameSpace) -> ScopeM ()
-modifyCurrentNameSpace acc f = modifyCurrentScope action
- where
- action s = s { scopeNameSpaces = [ (nsid, f' nsid ns) | (nsid, ns) <- scopeNameSpaces s ] }
-
- f' a | a == acc = f
- | otherwise = id
+modifyCurrentNameSpace acc f = modifyCurrentScope $ updateScopeNameSpaces $
+ AssocList.updateAt acc f
setContextPrecedence :: Precedence -> ScopeM ()
setContextPrecedence p = modifyScopeInfo $ \s -> s { scopePrecedence = p }
@@ -154,8 +147,11 @@ withContextPrecedence p m = do
getLocalVars :: ScopeM LocalVars
getLocalVars = scopeLocals <$> getScope
+modifyLocalVars :: (LocalVars -> LocalVars) -> ScopeM ()
+modifyLocalVars = modifyScope . updateScopeLocals
+
setLocalVars :: LocalVars -> ScopeM ()
-setLocalVars vars = modifyScope $ setScopeLocals vars
+setLocalVars vars = modifyLocalVars $ const vars
-- | Run a computation without changing the local variables.
withLocalVars :: ScopeM a -> ScopeM a
@@ -216,9 +212,13 @@ resolveName = resolveName' allKindsOfNames
resolveName' :: [KindOfName] -> C.QName -> ScopeM ResolvedName
resolveName' kinds x = do
scope <- getScope
- let vars = map (C.QName -*- id) $ scopeLocals scope
+ let vars = AssocList.mapKeysMonotonic C.QName $ scopeLocals scope
case lookup x vars of
- Just y -> return $ VarName $ y { nameConcrete = unqualify x }
+ -- Case: we have a local variable x.
+ Just (LocalVar y) -> return $ VarName $ y { nameConcrete = unqualify x }
+ -- Case: ... but is shadowed by some imports.
+ Just (ShadowedVar y ys) -> typeError $ AmbiguousName x $ A.qualify_ y : map anameName ys
+ -- Case: we do not have a local variable x.
Nothing -> case filter ((`elem` kinds) . anameKind . fst) $ scopeLookup' x scope of
[] -> return UnknownName
ds | all ((==ConName) . anameKind . fst) ds ->
@@ -248,25 +248,20 @@ getFixity :: C.QName -> ScopeM Fixity'
getFixity x = do
r <- resolveName x
case r of
- VarName y -> return $ nameFixity y
- DefinedName _ d -> return $ nameFixity $ qnameName $ anameName d
- FieldName d -> return $ nameFixity $ qnameName $ anameName d
- ConstructorName ds
- | null fs -> __IMPOSSIBLE__
- | allEqual fs -> return $ head fs
- | otherwise -> return defaultFixity'
- where
- fs = map (nameFixity . qnameName . anameName) ds
- PatternSynResName n -> return $ nameFixity $ qnameName $ anameName n
+ VarName y -> return $ nameFixity y
+ DefinedName _ d -> return $ aFixity d
+ FieldName d -> return $ aFixity d
+ ConstructorName ds -> return $ chooseFixity $ map aFixity ds
+ PatternSynResName n -> return $ aFixity n
UnknownName -> __IMPOSSIBLE__
+ where
+ aFixity = nameFixity . qnameName . anameName
-- * Binding names
-- | Bind a variable. The abstract name is supplied as the second argument.
bindVariable :: C.Name -> A.Name -> ScopeM ()
-bindVariable x y = do
- scope <- getScope
- setScope scope { scopeLocals = (x, y) : scopeLocals scope }
+bindVariable x y = modifyScope $ updateScopeLocals $ AssocList.insert x $ LocalVar y
-- | Bind a defined name. Must not shadow anything.
bindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM ()
@@ -279,13 +274,10 @@ bindName acc kind x y = do
ConstructorName [] -> __IMPOSSIBLE__
ConstructorName ds
| kind == ConName && all ((==ConName) . anameKind) ds -> return [ AbsName y kind Defined ]
- | otherwise -> typeError $ ClashingDefinition (C.QName x) $ anameName (head' ds)
+ | otherwise -> typeError $ ClashingDefinition (C.QName x) $ anameName (headWithDefault __IMPOSSIBLE__ ds)
PatternSynResName n -> typeError $ ClashingDefinition (C.QName x) $ anameName n
UnknownName -> return [AbsName y kind Defined]
modifyCurrentScope $ addNamesToScope (localNameSpace acc) x ys
- where
- head' [] = {- ' -} __IMPOSSIBLE__
- head' (x:_) = x
-- | Rebind a name. Use with care!
-- Ulf, 2014-06-29: Currently used to rebind the name defined by an
@@ -310,11 +302,9 @@ bindQModule acc q m = modifyCurrentScope $ \s ->
-- | Clear the scope of any no names.
stripNoNames :: ScopeM ()
-stripNoNames = modifyScopes $ Map.map strip
+stripNoNames = modifyScopes $ Map.map $ mapScope_ stripN stripN
where
- strip = mapScope (\_ -> stripN) (\_ -> stripN)
- stripN m = Map.filterWithKey (const . notNoName) m
- notNoName = not . isNoName
+ stripN = Map.filterWithKey $ const . not . isNoName
type Out = (A.Ren A.ModuleName, A.Ren A.QName)
type WSM = StateT Out ScopeM
@@ -322,50 +312,49 @@ type WSM = StateT Out ScopeM
-- | Create a new scope with the given name from an old scope. Renames
-- public names in the old scope to match the new name and returns the
-- renamings.
+--
+-- Data and record types share a common abstract name with their module.
+-- This invariant needs to be preserved by @copyScope@, since constructors
+-- (fields) can be qualified by their data (record) type name (as an
+-- alternative to qualification by their module).
+-- (See Issue 836).
copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, (A.Ren A.ModuleName, A.Ren A.QName))
copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy new s) (Map.empty, Map.empty)
where
+ -- | A memoizing algorithm, the renamings serving as memo structure.
+ copy :: A.ModuleName -> Scope -> StateT (A.Ren A.ModuleName, A.Ren A.QName) ScopeM Scope
copy new s = do
lift $ reportSLn "scope.copy" 20 $ "Copying scope " ++ show old ++ " to " ++ show new
lift $ reportSLn "scope.copy" 50 $ show s
s0 <- lift $ getNamedScope new
- s' <- mapScopeM copyD copyM s
+ -- Delete private names, then copy names and modules.
+ s' <- mapScopeM_ copyD copyM $ setNameSpace PrivateNS emptyNameSpace s
+ -- Fix name and parent.
return $ s' { scopeName = scopeName s0
, scopeParents = scopeParents s0
}
where
new' = killRange new
+ newL = A.mnameToList new'
old = scopeName s
- copyM :: NameSpaceId -> ModulesInScope -> WSM ModulesInScope
- copyM ImportedNS ms = traverse (mapM $ onMod renMod) ms
- copyM PrivateNS _ = return Map.empty
- copyM PublicNS ms = traverse (mapM $ onMod renMod) ms
- copyM OnlyQualifiedNS ms = traverse (mapM $ onMod renMod) ms
+ copyD :: NamesInScope -> WSM NamesInScope
+ copyD = traverse $ mapM $ onName renName
- copyD :: NameSpaceId -> NamesInScope -> WSM NamesInScope
- copyD ImportedNS ds = traverse (mapM $ onName renName) ds
- copyD PrivateNS _ = return Map.empty
- copyD PublicNS ds = traverse (mapM $ onName renName) ds
- copyD OnlyQualifiedNS ds = traverse (mapM $ onName renName) ds
-
- onMod f m = do
- x <- f $ amodName m
- return m { amodName = x }
+ copyM :: ModulesInScope -> WSM ModulesInScope
+ copyM = traverse $ mapM $ lensAmodName renMod
+ onName :: (A.QName -> WSM A.QName) -> AbstractName -> WSM AbstractName
onName f d =
case anameKind d of
PatternSynName -> return d -- Pattern synonyms are simply aliased, not renamed
- _ -> do
- x <- f $ anameName d
- return d { anameName = x }
-
- addName x y = addNames (Map.singleton x y)
- addMod x y = addMods (Map.singleton x y)
+ _ -> lensAnameName f d
- addNames rd' = modify $ \(rm, rd) -> (rm, Map.union rd rd')
- addMods rm' = modify $ \(rm, rd) -> (Map.union rm rm', rd)
+ -- Adding to memo structure.
+ addName x y = modify $ second $ Map.insert x y
+ addMod x y = modify $ first $ Map.insert x y
+ -- Querying the memo structure.
findName x = Map.lookup x <$> gets snd
findMod x = Map.lookup x <$> gets fst
@@ -373,39 +362,34 @@ copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy
renName :: A.QName -> WSM A.QName
renName x = do
lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x
- -- Check if we've seen it already
- my <- findName x
- case my of
- Just y -> return y
- Nothing -> do
- -- First time, generate a fresh name for it
- i <- lift fresh
- let y = qualifyQ new' . dequalify
- $ x { qnameName = (qnameName x) { nameId = i } }
- addName x y
- return y
- where
- dequalify q = A.qnameFromList [last $ A.qnameToList q]
+ -- If we've seen it already, just return its copy.
+ (`fromMaybeM` findName x) $ do
+ -- We have not processed this name @x@, so copy it to some @y at .
+ -- Check whether we have already seen a module of the same name.
+ -- If yes, use its copy as @y at .
+ y <- ifJustM (findMod $ qnameToMName x) (return . mnameToQName) $ {- else -} do
+ -- First time, generate a fresh name for it.
+ i <- lift fresh
+ return $ A.qualify new' $ (qnameName x) { nameId = i }
+ addName x y
+ return y
-- Change a binding M.x -> old.M'.y to M.x -> new.M'.y
renMod :: A.ModuleName -> WSM A.ModuleName
renMod x = do
- -- Check if we've seen it already
- my <- findMod x
- case my of
- Just y -> return y
- Nothing -> do
- -- Create the name of the new module
- let y = qualifyM new' $ dequalify x
- addMod x y
-
- -- We need to copy the contents of included modules recursively
- s0 <- lift $ createModule False y >> getNamedScope x
- s <- withCurrentModule' y $ copy y s0
- lift $ modifyNamedScope y (const s)
- return y
- where
- dequalify = A.mnameFromList . drop (size old) . A.mnameToList
+ -- If we've seen it already, just return its copy.
+ (`fromMaybeM` findMod x) $ do
+ -- We have not processed this name @x@, so copy it to some @y at .
+ -- Check whether we have seen it already, yet as name.
+ -- If yes, use its copy as @y at .
+ y <- ifJustM (findName $ mnameToQName x) (return . qnameToMName) $ {- else -} do
+ return $ A.mnameFromList $ (newL ++) $ drop (size old) $ A.mnameToList x
+ addMod x y
+ -- We need to copy the contents of included modules recursively
+ s0 <- lift $ createModule False y >> getNamedScope x
+ s <- withCurrentModule' y $ copy y s0
+ lift $ modifyNamedScope y (const s)
+ return y
-- | Apply an import directive and check that all the names mentioned actually
-- exist.
@@ -442,11 +426,23 @@ openModule_ :: C.QName -> ImportDirective -> ScopeM ()
openModule_ cm dir = do
current <- getCurrentModule
m <- amodName <$> resolveModule cm
- let ns = namespace current m
- s <- setScopeAccess ns <$>
+ let acc = namespace current m
+ -- Get the scope exported by module to be opened.
+ s <- setScopeAccess acc <$>
(applyImportDirectiveM cm dir . inScopeBecause (Opened cm) . removeOnlyQualified . restrictPrivate =<< getNamedScope m)
- checkForClashes (scopeNameSpace ns s)
+ let ns = scopeNameSpace acc s
+ checkForClashes ns
modifyCurrentScope (`mergeScope` s)
+ verboseS "scope.locals" 10 $ do
+ locals <- mapMaybe (\ (c,x) -> c <$ notShadowedLocal x) <$> getLocalVars
+ let newdefs = Map.keys $ nsNames ns
+ shadowed = List.intersect locals newdefs
+ reportSLn "scope.locals" 10 $ "opening module shadows the following locals vars: " ++ show shadowed
+ -- Andreas, 2014-09-03, issue 1266: shadow local variables by imported defs.
+ modifyLocalVars $ AssocList.mapWithKey $ \ c x ->
+ case Map.lookup c $ nsNames ns of
+ Nothing -> x
+ Just ys -> shadowLocal ys x
where
namespace m0 m1
| not (publicOpen dir) = PrivateNS
@@ -455,26 +451,26 @@ openModule_ cm dir = do
-- Only checks for clashes that would lead to the same
-- name being exported twice from the module.
- checkForClashes new
- | not (publicOpen dir) = return ()
- | otherwise = do
+ checkForClashes new = when (publicOpen dir) $ do
old <- allThingsInScope . restrictPrivate <$> (getNamedScope =<< getCurrentModule)
let defClashes = Map.toList $ Map.intersectionWith (,) (nsNames new) (nsNames old)
modClashes = Map.toList $ Map.intersectionWith (,) (nsModules new) (nsModules old)
+ -- No ambiguity if concrete identifier is mapped to
+ -- single, identical abstract identifiers.
realClash (_, ([x],[y])) = x /= y
realClash _ = True
+ -- No ambiguity if concrete identifier is only mapped to
+ -- constructor names.
defClash (_, (qs0, qs1)) =
any ((/= ConName) . anameKind) (qs0 ++ qs1)
- (f & g) x = f x && g x
+ -- We report the first clashing exported identifier.
+ unlessNull (filter (\ x -> realClash x && defClash x) defClashes) $
+ \ ((x, (_, q:_)) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q)
- case filter (realClash & defClash) defClashes of
- (x, (_, q:_)):_ -> typeError $ ClashingDefinition (C.QName x) (anameName q)
- _ -> return ()
- case filter realClash modClashes of
- (_, (m0:_, m1:_)):_ -> typeError $ ClashingModule (amodName m0) (amodName m1)
- _ -> return ()
+ unlessNull (filter realClash modClashes) $ \ ((_, (m0:_, m1:_)) : _) ->
+ typeError $ ClashingModule (amodName m0) (amodName m1)
diff --git a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
index 8ab7b48..31e6675 100644
--- a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
+++ b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs
@@ -1,12 +1,13 @@
--- {-# OPTIONS -fwarn-unused-binds #-}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- {-# OPTIONS -fwarn-unused-binds #-}
{-| The translation of abstract syntax to concrete syntax has two purposes.
First it allows us to pretty print abstract syntax values without having to
@@ -34,6 +35,7 @@ import Control.Applicative hiding (empty)
import Control.Monad.Reader
import Data.List as List hiding (null)
+import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Set (Set)
@@ -55,11 +57,12 @@ import Agda.TypeChecking.Monad.State (getScope)
import Agda.TypeChecking.Monad.Base (TCM, NamedMeta(..))
import Agda.TypeChecking.Monad.Options
-import Agda.Utils.Monad hiding (bracket)
+import qualified Agda.Utils.AssocList as AssocList
+import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- Environment ------------------------------------------------------------
@@ -164,7 +167,7 @@ unsafeQNameToName (C.Qual _ x) = unsafeQNameToName x
lookupName :: A.Name -> AbsToCon C.Name
lookupName x = do
names <- asks $ scopeLocals . currentScope
- case lookup x $ map swap names of
+ case lookup x $ mapMaybe (\ (c,x) -> (,c) <$> notShadowedLocal x) names of
Just y -> return y
Nothing -> return $ nameConcrete x
@@ -197,9 +200,8 @@ bindName x ret = do
True -> bindName (nextName x) ret
False ->
local (\e -> e { takenNames = Set.insert y $ takenNames e
- , currentScope = (currentScope e)
- { scopeLocals = (y, x) : scopeLocals (currentScope e)
- }
+ , currentScope = (`updateScopeLocals` currentScope e) $
+ AssocList.insert y (LocalVar x)
}
) $ ret y
@@ -349,6 +351,7 @@ instance ToConcrete A.ModuleName C.QName where
instance ToConcrete A.Expr C.Expr where
toConcrete (Var x) = Ident . C.QName <$> toConcrete x
toConcrete (Def x) = Ident <$> toConcrete x
+ toConcrete (Proj x) = Ident <$> toConcrete x
toConcrete (Con (AmbQ (x:_))) = Ident <$> toConcrete x
toConcrete (Con (AmbQ [])) = __IMPOSSIBLE__
-- for names we have to use the name from the info, since the abstract
@@ -826,9 +829,13 @@ instance ToConcrete RangeAndPragma C.Pragma where
-- Left hand sides --------------------------------------------------------
+noImplicitArgs :: A.Patterns -> A.Patterns
noImplicitArgs = filter (noImplicit . namedArg)
+
+noImplicitPats :: [A.Pattern] -> [A.Pattern]
noImplicitPats = filter noImplicit
+noImplicit :: A.Pattern -> Bool
noImplicit (A.ImplicitP _) = False
noImplicit _ = True
@@ -962,13 +969,6 @@ recoverOpApp bracket opApp view e mDefault = case view e of
where
xs = C.nameParts $ C.unqualify n
numHoles = length (filter (== Hole) xs)
-{- UNUSED
- msg = concat [ "doQName "
- , showList xs ""
- , " on "
- , show (length es)
- , " args" ]
--}
-- binary case
doQName fixity n as
diff --git a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
index d37082c..2c0fd75 100644
--- a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis,
figuring out infix operator precedences and tidying up definitions.
@@ -27,10 +27,9 @@ module Agda.Syntax.Translation.ConcreteToAbstract
, PatName, APatName, LetDef, LetDefs
) where
-import Prelude hiding (mapM)
+import Prelude hiding (mapM, null)
import Control.Applicative
import Control.Monad.Reader hiding (mapM)
-import Control.Monad.Error hiding (mapM)
import Data.Foldable (Foldable, traverse_)
import Data.Traversable (mapM, traverse)
@@ -54,7 +53,8 @@ import Agda.Syntax.Scope.Base
import Agda.Syntax.Scope.Monad
import Agda.TypeChecking.Monad.Base (TypeError(..), Call(..), typeError,
- TCErr(..), extendlambdaname)
+ TCErr(..), extendedLambdaName, fresh,
+ freshName, freshName_, freshNoName)
import Agda.TypeChecking.Monad.Benchmark (billTo, billTop, reimburseTop)
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)
@@ -68,14 +68,15 @@ import Agda.Interaction.FindFile (checkModuleName)
import {-# SOURCE #-} Agda.Interaction.Imports (scopeCheckImport)
import Agda.Interaction.Options
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.FileName
import Agda.Utils.Functor
-import Agda.Utils.Fresh
import Agda.Utils.List
import Agda.Utils.Monad
+import Agda.Utils.Null
import Agda.Utils.Pretty
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
import Agda.ImpossibleTest (impossibleTest)
@@ -83,12 +84,20 @@ import Agda.ImpossibleTest (impossibleTest)
Exceptions
--------------------------------------------------------------------------}
-notAModuleExpr e = typeError $ NotAModuleExpr e
-notAnExpression e = typeError $ NotAnExpression e
-notAValidLetBinding d = typeError $ NotAValidLetBinding d
+-- notAModuleExpr e = typeError $ NotAModuleExpr e
+
+notAnExpression :: C.Expr -> ScopeM A.Expr
+notAnExpression e = typeError $ NotAnExpression e
+
+nothingAppliedToHiddenArg :: C.Expr -> ScopeM A.Expr
nothingAppliedToHiddenArg e = typeError $ NothingAppliedToHiddenArg e
+
+nothingAppliedToInstanceArg :: C.Expr -> ScopeM A.Expr
nothingAppliedToInstanceArg e = typeError $ NothingAppliedToInstanceArg e
+notAValidLetBinding :: NiceDeclaration -> ScopeM a
+notAValidLetBinding d = typeError $ NotAValidLetBinding d
+
-- Debugging
printLocals :: Int -> String -> ScopeM ()
@@ -122,9 +131,8 @@ expandEllipsis p ps (C.Clause x (C.Ellipsis _ ps' eqs es) rhs wh wcs) =
-- | Make sure that each variable occurs only once.
checkPatternLinearity :: [A.Pattern' e] -> ScopeM ()
-checkPatternLinearity ps = case xs \\ nub xs of
- [] -> return ()
- ys -> typeError $ RepeatedVariablesInPattern $ nub ys
+checkPatternLinearity ps = unlessNull (duplicates xs) $ \ ys -> do
+ typeError $ RepeatedVariablesInPattern ys
where
xs = concatMap vars ps
vars :: A.Pattern' e -> [C.Name]
@@ -172,7 +180,7 @@ recordConstructorType fields = build fs
-- | @checkModuleApplication modapp m0 x dir = return (modapp', renD, renM)@
--
-- @m0@ is the new (abstract) module name and
--- @x@ its concret form (used for error messages).
+-- @x@ its concrete form (used for error messages).
checkModuleApplication
:: C.ModuleApplication
-> ModuleName
@@ -183,11 +191,11 @@ checkModuleApplication
checkModuleApplication (C.SectionApp _ tel e) m0 x dir' =
-- For the following, set the current module to be m0.
withCurrentModule m0 $ do
- -- check that expression @e@ is of the form @m args@
+ -- Check that expression @e@ is of the form @m args at .
(m, args) <- parseModuleApplication e
- -- scope check the telescope (introduces bindings!)
+ -- Scope check the telescope (introduces bindings!).
tel' <- toAbstract tel
- -- scope the old module name, the module args
+ -- Scope check the old module name and the module args.
(m1, args') <- toAbstract (OldModuleName m, args)
-- Drop constructors (OnlyQualified) if there are arguments. The record constructor
-- isn't properly in the record module, so copying it will lead to badness.
@@ -226,7 +234,7 @@ checkModuleMacro
-> OpenShortHand
-> ImportDirective
-> ScopeM [a]
-checkModuleMacro apply r p x modapp open dir = withLocalVars $ do
+checkModuleMacro apply r p x modapp open dir = do
notPublicWithoutOpen open dir
m0 <- toAbstract (NewModuleName x)
@@ -239,9 +247,11 @@ checkModuleMacro apply r p x modapp open dir = withLocalVars $ do
DontOpen -> dir
DoOpen -> defaultImportDir
- (modapp', renD, renM) <- checkModuleApplication modapp m0 x dir'
+ -- Restore the locals after module application has been checked.
+ (modapp', renD, renM) <- withLocalVars $ checkModuleApplication modapp m0 x dir'
bindModule p x m0
printScope "mod.inst.copy.after" 20 "after copying"
+ -- Andreas, 2014-09-02 openModule_ might shadow some locals!
when (open == DoOpen) $
openModule_ (C.QName x) dir
printScope "mod.inst" 20 $ show open
@@ -284,7 +294,7 @@ concreteToAbstract scope x = withScope_ scope (toAbstract x)
-- | Things that can be translated to abstract syntax are instances of this
-- class.
class ToAbstract concrete abstract | concrete -> abstract where
- toAbstract :: concrete -> ScopeM abstract
+ toAbstract :: concrete -> ScopeM abstract
-- | This function should be used instead of 'toAbstract' for things that need
-- to keep track of precedences to make sure that we don't forget about it.
@@ -353,9 +363,9 @@ instance ToAbstract (NewName C.BoundName) A.Name where
nameExpr :: AbstractName -> A.Expr
nameExpr d = mk (anameKind d) $ anameName d
where
- mk DefName x = Def x
- mk FldName x = Def x
- mk ConName x = Con $ AmbQ [x]
+ mk DefName x = A.Def x
+ mk FldName x = A.Proj x
+ mk ConName x = A.Con $ AmbQ [x]
mk PatternSynName x = A.PatternSyn x
mk QuotableName x = A.App i (A.Quote i) (defaultNamedArg $ A.Def x)
where i = ExprRange (getRange x)
@@ -468,8 +478,7 @@ mkArg' info e = Common.Arg (setHiding NotHidden info) e
-- | By default, arguments are @Relevant at .
mkArg :: C.Expr -> C.Arg C.Expr
--- mkArg (C.Dot _ e) = mkArg' Irrelevant e
-mkArg e = mkArg' defaultArgInfo e
+mkArg e = mkArg' defaultArgInfo e
-- | Parse a possibly dotted C.Expr as A.Expr. Bool = True if dotted.
@@ -492,21 +501,68 @@ toAbstractDot prec e = do
e <- toAbstractCtx prec e
return (e, False)
+-- | An argument @OpApp C.Expr@ to an operator can have binders,
+-- in case the operator is some @syntax at -notation.
+-- For these binders, we have to create lambda-abstractions.
toAbstractOpArg :: Precedence -> OpApp C.Expr -> ScopeM A.Expr
-toAbstractOpArg ctx (Ordinary e) = toAbstractCtx ctx e
+toAbstractOpArg ctx (Ordinary e) = toAbstractCtx ctx e
toAbstractOpArg ctx (SyntaxBindingLambda r bs e) = toAbstractLam r bs e ctx
+-- | Translate concrete expression under at least one binder into nested
+-- lambda abstraction in abstract syntax.
toAbstractLam :: Range -> [C.LamBinding] -> C.Expr -> Precedence -> ScopeM A.Expr
toAbstractLam r bs e ctx = do
- localToAbstract (map (C.DomainFull . makeDomainFull) bs) $ \bs ->
- case bs of
- b:bs' -> do
- e <- toAbstractCtx ctx e
- let info = ExprRange r
- return $ A.Lam info b $ foldr mkLam e bs'
- where
- mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e
- [] -> __IMPOSSIBLE__
+ -- Translate the binders
+ localToAbstract (map (C.DomainFull . makeDomainFull) bs) $ \ bs -> do
+ -- Translate the body
+ e <- toAbstractCtx ctx e
+ -- We have at least one binder. Get first @b@ and rest @bs at .
+ caseList bs __IMPOSSIBLE__ $ \ b bs -> do
+ return $ A.Lam (ExprRange r) b $ foldr mkLam e bs
+ where
+ mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e
+
+-- | Scope check extended lambda expression.
+scopeCheckExtendedLam :: Range -> [(C.LHS, C.RHS, WhereClause)] -> ScopeM A.Expr
+scopeCheckExtendedLam r cs = do
+ whenM isInsideDotPattern $
+ typeError $ GenericError "Extended lambdas are not allowed in dot patterns"
+
+ -- Find an unused name for the extended lambda definition.
+ cname <- nextlamname r 0 extendedLambdaName
+ name <- freshAbstractName_ cname
+ reportSLn "scope.extendedLambda" 10 $ "new extended lambda name: " ++ show name
+ qname <- qualifyName_ name
+ bindName PrivateAccess DefName cname qname
+
+ -- Compose a function definition an scope check it.
+ let
+ insertApp (C.RawAppP r es) = C.RawAppP r $ IdentP (C.QName cname) : es
+ insertApp (C.IdentP q ) = C.RawAppP r $ IdentP (C.QName cname) : [C.IdentP q]
+ where r = getRange q
+ insertApp _ = __IMPOSSIBLE__
+ d = C.FunDef r [] defaultFixity' ConcreteDef TerminationCheck cname $
+ for cs $ \ (lhs, rhs, wh) -> -- wh == NoWhere, see parser for more info
+ C.Clause cname (mapLhsOriginalPattern insertApp lhs) rhs wh []
+ scdef <- toAbstract d
+
+ -- Create the abstract syntax for the extended lambda.
+ case scdef of
+ A.ScopedDecl si [A.FunDef di qname' NotDelayed cs] -> do
+ setScope si -- This turns into an A.ScopedExpr si $ A.ExtendedLam...
+ return $ A.ExtendedLam (ExprRange r) di qname' cs
+ _ -> __IMPOSSIBLE__
+
+ where
+ -- Get a concrete name that is not yet in scope.
+ nextlamname :: Range -> Int -> String -> ScopeM C.Name
+ nextlamname r i s = do
+ let cname = C.Name r [Id $ stringToRawName $ s ++ show i]
+ rn <- resolveName $ C.QName cname
+ case rn of
+ UnknownName -> return cname
+ _ -> nextlamname r (i+1) s
+
instance ToAbstract C.Expr A.Expr where
@@ -546,15 +602,6 @@ instance ToAbstract C.Expr A.Expr where
parseApplication es
toAbstract e
-{- Andreas, 2010-09-06 STALE COMMENT
- -- Dots are used in dot patterns and in irrelevant function space .A n -> B
- -- we propagate dots out from the head of applications
-
- C.Dot r e1 -> do
- t1 <- toAbstract e1
- return $ A.Dot t1
--}
-
-- Application
C.App r e1 e2 -> do
e1 <- toAbstractCtx FunctionCtx e1
@@ -570,7 +617,7 @@ instance ToAbstract C.Expr A.Expr where
es <- mapM (toAbstractCtx WithArgCtx) es
return $ A.WithApp (ExprRange r) e es
- -- Malplaced hidden argument
+ -- Misplaced hidden argument
C.HiddenArg _ _ -> nothingAppliedToHiddenArg e
C.InstanceArg _ _ -> nothingAppliedToInstanceArg e
@@ -580,36 +627,9 @@ instance ToAbstract C.Expr A.Expr where
C.Lam r bs e -> toAbstractLam r bs e TopCtx
-- Extended Lambda
- C.ExtendedLam r cs ->
- ifM isInsideDotPattern (typeError $ GenericError "Extended lambdas are not allowed in dot patterns") $ do
- cname <- nextlamname r 0 extendlambdaname
- name <- freshAbstractName_ cname
- reportSLn "toabstract.extendlambda" 10 $ "new extended lambda name: " ++ show name
- qname <- qualifyName_ name
- bindName PrivateAccess DefName cname qname
- let insertApp (C.RawAppP r es) = C.RawAppP r ((IdentP (C.QName cname)) : es)
- insertApp (C.IdentP q) = C.RawAppP (getRange q) ((IdentP (C.QName cname)) : [C.IdentP q])
- insertApp _ = __IMPOSSIBLE__
- insertHead (C.LHS p wps eqs with) = C.LHS (insertApp p) wps eqs with
- insertHead (C.Ellipsis r wps eqs with) = C.Ellipsis r wps eqs with
- scdef <- toAbstract (C.FunDef r [] defaultFixity' ConcreteDef TerminationCheck cname
- (map (\(lhs,rhs,wh) -> -- wh = NoWhere, see parser for more info
- C.Clause cname (insertHead lhs) rhs wh []) cs))
- case scdef of
- (A.ScopedDecl si [A.FunDef di qname' NotDelayed cs]) -> do
- setScope si
- return $ A.ExtendedLam (ExprRange r) di qname' cs
- _ -> __IMPOSSIBLE__
- where
- nextlamname :: Range -> Int -> String -> ScopeM C.Name
- nextlamname r i s = do
- let cname_pre = C.Name r [Id $ stringToRawName $ s ++ show i]
- rn <- resolveName (C.QName cname_pre)
- case rn of
- UnknownName -> return $ cname_pre
- _ -> nextlamname r (i+1) s
-
--- Irrelevant non-dependent function type
+ C.ExtendedLam r cs -> scopeCheckExtendedLam r cs
+
+ -- Relevant and irrelevant non-dependent function type
C.Fun r e1 e2 -> do
Common.Arg info (e0, dotted) <- traverse (toAbstractDot FunctionSpaceDomainCtx) $ mkArg e1
@@ -618,16 +638,7 @@ instance ToAbstract C.Expr A.Expr where
e2 <- toAbstractCtx TopCtx e2
return $ A.Fun (ExprRange r) e1 e2
-{-
--- Other function types
-
- C.Fun r e1 e2 -> do
- e1 <- toAbstractCtx FunctionSpaceDomainCtx $ mkArg e1
- e2 <- toAbstractCtx TopCtx e2
- let info = ExprRange r
- return $ A.Fun info e1 e2
--}
-
+ -- Dependent function type
e0@(C.Pi tel e) ->
localToAbstract tel $ \tel -> do
e <- toAbstractCtx TopCtx e
@@ -727,9 +738,10 @@ scopeCheckNiceModule
-> ScopeM [A.Declaration]
-> ScopeM [A.Declaration]
scopeCheckNiceModule r p name tel checkDs
- | telHasOpenStms tel = do
+ | telHasOpenStmsOrModuleMacros tel = do
-- Andreas, 2013-12-10:
- -- If the module telescope contains open statements,
+ -- If the module telescope contains open statements
+ -- or module macros (Issue 1299),
-- add an extra anonymous module around the current one.
-- Otherwise, the open statements would create
-- identifiers in the parent scope of the current module.
@@ -764,20 +776,20 @@ scopeCheckNiceModule r p name tel checkDs
defaultImportDir { publicOpen = True }
return ds
--- | Check whether a telescope has open declarations.
-telHasOpenStms :: C.Telescope -> Bool
-telHasOpenStms = any isOpenBinds
+-- | Check whether a telescope has open declarations or module macros.
+telHasOpenStmsOrModuleMacros :: C.Telescope -> Bool
+telHasOpenStmsOrModuleMacros = any yesBinds
where
- isOpenBinds (C.TypedBindings _ tb) = isOpenBind $ unArg tb
- isOpenBind C.TBind{} = False
- isOpenBind (C.TLet _ ds) = any isOpen ds
- isOpen (C.ModuleMacro _ _ _ DoOpen _) = True
- isOpen C.Open{} = True
- isOpen C.Import{} = __IMPOSSIBLE__
- isOpen (C.Mutual _ ds) = any isOpen ds
- isOpen (C.Abstract _ ds) = any isOpen ds
- isOpen (C.Private _ ds) = any isOpen ds
- isOpen _ = False
+ yesBinds (C.TypedBindings _ tb) = yesBind $ unArg tb
+ yesBind C.TBind{} = False
+ yesBind (C.TLet _ ds) = any yes ds
+ yes C.ModuleMacro{} = True
+ yes C.Open{} = True
+ yes C.Import{} = __IMPOSSIBLE__
+ yes (C.Mutual _ ds) = any yes ds
+ yes (C.Abstract _ ds) = any yes ds
+ yes (C.Private _ ds) = any yes ds
+ yes _ = False
{- UNUSED
telHasLetStms :: C.Telescope -> Bool
@@ -869,13 +881,17 @@ data TopLevelInfo = TopLevelInfo
topLevelModuleName :: TopLevelInfo -> A.ModuleName
topLevelModuleName topLevel = scopeCurrent (insideScope topLevel)
--- Top-level declarations are always (import|open)* module
+-- | Top-level declarations are always
+-- @
+-- (import|open)* -- a bunch of possibly opened imports
+-- module ThisModule ... -- the top-level module of this file
+-- @
instance ToAbstract (TopLevel [C.Declaration]) TopLevelInfo where
toAbstract (TopLevel file ds) =
-- A file is a bunch of preliminary decls (imports etc.)
-- plus a single module decl.
case splitAt (length ds - 1) ds of
- (ds', [C.Module r m0 tel ds]) -> do
+ (outsideDecls, [C.Module r m0 tel insideDecls]) -> do
-- If the module name is _ compute the name from the file path
m <- if isNoName m0
then return $ C.QName $ C.Name noRange [Id $ stringToRawName $ rootName file]
@@ -888,10 +904,12 @@ instance ToAbstract (TopLevel [C.Declaration]) TopLevelInfo where
return m0
setTopLevelModule m
am <- toAbstract (NewModuleQName m)
- ds' <- toAbstract ds'
- (scope0, ds) <- scopeCheckModule r m am tel $ toAbstract ds
- scope <- getScope
- return $ TopLevelInfo (ds' ++ ds) scope scope0
+ -- Scope check the declarations outside
+ outsideDecls <- toAbstract outsideDecls
+ (insideScope, insideDecls) <- scopeCheckModule r m am tel $
+ toAbstract insideDecls
+ outsideScope <- getScope
+ return $ TopLevelInfo (outsideDecls ++ insideDecls) outsideScope insideScope
_ -> __IMPOSSIBLE__
-- | runs Syntax.Concrete.Definitions.niceDeclarations on main module
@@ -909,7 +927,9 @@ instance ToAbstract [C.Declaration] [A.Declaration] where
noNoTermCheck (C.Pragma (C.TerminationCheckPragma r NoTerminationCheck)) =
typeError $ SafeFlagNoTerminationCheck
noNoTermCheck (C.Pragma (C.TerminationCheckPragma r NonTerminating)) =
- typeError $ SafeFlagNoTerminationCheck
+ typeError $ SafeFlagNonTerminating
+ noNoTermCheck (C.Pragma (C.TerminationCheckPragma r Terminating)) =
+ typeError $ SafeFlagTerminating
noNoTermCheck d = return d
newtype LetDefs = LetDefs [C.Declaration]
@@ -972,20 +992,20 @@ instance ToAbstract LetDef [A.LetBinding] where
-- You can't open public in a let
NiceOpen r x dirs | not (C.publicOpen dirs) -> do
m <- toAbstract (OldModuleName x)
- n <- length . scopeLocals <$> getScope
openModule_ x dirs
- return [A.LetOpen (ModuleInfo
- { minfoRange = r
- , minfoAsName = Nothing
- , minfoAsTo = renamingRange dirs
- , minfoOpenShort = Nothing
- , minfoDirective = Just dirs
- })
- m
- ]
+ let minfo = ModuleInfo
+ { minfoRange = r
+ , minfoAsName = Nothing
+ , minfoAsTo = renamingRange dirs
+ , minfoOpenShort = Nothing
+ , minfoDirective = Just dirs
+ }
+ return [A.LetOpen minfo m]
NiceModuleMacro r p x modapp open dir | not (C.publicOpen dir) ->
- checkModuleMacro LetApply r p x modapp open dir
+ -- Andreas, 2014-10-09, Issue 1299: module macros in lets need
+ -- to be private
+ checkModuleMacro LetApply r PrivateAccess x modapp open dir
_ -> notAValidLetBinding d
where
@@ -1176,14 +1196,14 @@ instance ToAbstract NiceDeclaration A.Declaration where
printScope "open" 20 $ "opening " ++ show x
openModule_ x dir
printScope "open" 20 $ "result:"
- return [A.Open (ModuleInfo
- { minfoRange = r
- , minfoAsName = Nothing
- , minfoAsTo = renamingRange dir
- , minfoOpenShort = Nothing
- , minfoDirective = Just dir
- })
- m]
+ let minfo = ModuleInfo
+ { minfoRange = r
+ , minfoAsName = Nothing
+ , minfoAsTo = renamingRange dir
+ , minfoOpenShort = Nothing
+ , minfoDirective = Just dir
+ }
+ return [A.Open minfo m]
NicePragma r p -> do
ps <- toAbstract p
@@ -1222,21 +1242,17 @@ instance ToAbstract NiceDeclaration A.Declaration where
Nothing -> (x, noRange, Nothing)
Just a -> (C.QName (asName a), asRange a, Just (asName a))
case open of
- DoOpen -> do
- toAbstract [ C.Open r name dir ]
- return ()
- DontOpen -> do
- -- If not opening import directives are applied to the original scope
- modifyNamedScopeM m $ applyImportDirectiveM x dir
- return [ A.Import (ModuleInfo
- { minfoRange = r
- , minfoAsName = theAsName
- , minfoAsTo =
- getRange (theAsSymbol, renamingRange dir)
- , minfoOpenShort = Just open
- , minfoDirective = Just dir
- })
- m ]
+ DoOpen -> void $ toAbstract [ C.Open r name dir ]
+ -- If not opening, import directives are applied to the original scope.
+ DontOpen -> modifyNamedScopeM m $ applyImportDirectiveM x dir
+ let minfo = ModuleInfo
+ { minfoRange = r
+ , minfoAsName = theAsName
+ , minfoAsTo = getRange (theAsSymbol, renamingRange dir)
+ , minfoOpenShort = Just open
+ , minfoDirective = Just dir
+ }
+ return [ A.Import minfo m ]
NiceUnquoteDecl r fx p a tc x e -> do
y <- freshAbstractQName fx x
@@ -1253,6 +1269,7 @@ instance ToAbstract NiceDeclaration A.Declaration where
bindName PublicAccess PatternSynName n y
defn@(as, p) <- withLocalVars $ do
p <- toAbstract =<< toAbstract =<< parsePatternSyn p
+ checkPatternLinearity [p]
as <- (traverse . mapM) (unVarName <=< resolveName . C.QName) as
as <- (map . fmap) unBlind <$> toAbstract ((map . fmap) Blind as)
return (as, p)
@@ -1275,6 +1292,8 @@ instance ToAbstract NiceDeclaration A.Declaration where
data IsRecordCon = YesRec | NoRec
data ConstrDecl = ConstrDecl IsRecordCon A.ModuleName IsAbstract Access C.NiceDeclaration
+bindConstructorName :: ModuleName -> C.Name -> Fixity'-> IsAbstract ->
+ Access -> IsRecordCon -> ScopeM A.QName
bindConstructorName m x f a p record = do
-- The abstract name is the qualified one
y <- withCurrentModule m $ freshAbstractQName f x
@@ -1312,6 +1331,7 @@ instance ToAbstract C.Pragma [A.Pragma] where
e <- toAbstract $ OldQName x
case e of
A.Def x -> return [ A.RewritePragma x ]
+ A.Proj x -> return [ A.RewritePragma x ]
A.Con (AmbQ [x]) -> return [ A.RewritePragma x ]
A.Con x -> fail $ "REWRITE used on ambiguous name " ++ show x
_ -> __IMPOSSIBLE__
@@ -1329,6 +1349,7 @@ instance ToAbstract C.Pragma [A.Pragma] where
e <- toAbstract $ OldQName x
y <- case e of
A.Def x -> return x
+ A.Proj x -> return x -- TODO: do we need to do s.th. special for projections? (Andreas, 2014-10-12)
A.Con _ -> fail "Use COMPILED_DATA for constructors" -- TODO
_ -> __IMPOSSIBLE__
return [ A.CompiledPragma y hs ]
@@ -1336,7 +1357,6 @@ instance ToAbstract C.Pragma [A.Pragma] where
e <- toAbstract $ OldQName x
y <- case e of
A.Def x -> return x
- --A.Con x -> return x
_ -> __IMPOSSIBLE__
return [ A.CompiledExportPragma y hs ]
toAbstract (C.CompiledEpicPragma _ x ep) = do
@@ -1349,6 +1369,7 @@ instance ToAbstract C.Pragma [A.Pragma] where
e <- toAbstract $ OldQName x
y <- case e of
A.Def x -> return x
+ A.Proj x -> return x
A.Con (AmbQ [x]) -> return x
A.Con x -> fail ("COMPILED_JS used on ambiguous name " ++ show x)
_ -> __IMPOSSIBLE__
@@ -1583,6 +1604,7 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
getHiding p == NotHidden = do
e <- toAbstract (OldQName x)
let quoted (A.Def x) = return x
+ quoted (A.Proj x) = return x
quoted (A.Con (AmbQ [x])) = return x
quoted (A.Con (AmbQ xs)) = typeError $ GenericError $ "quote: Ambigous name: " ++ show xs
quoted (A.ScopedExpr _ e) = quoted e
@@ -1644,34 +1666,47 @@ instance ToAbstract C.Pattern (A.Pattern' C.Expr) where
-- right precedences for the various arguments.
toAbstractOpApp :: C.QName -> [C.NamedArg (OpApp C.Expr)] -> ScopeM A.Expr
toAbstractOpApp op es = do
+ -- Get the notation for the operator.
f <- getFixity op
- let (_,_,parts) = oldToNewNotation $ (op, f)
+ let parts = notation . oldToNewNotation $ (op, f)
+ -- We can throw away the @BindingHoles@, since binders
+ -- have been preprocessed into @OpApp C.Expr at .
+ let nonBindingParts = filter (not . isBindingHole) parts
+ -- We should be left with as many holes as we have been given args @es at .
+ -- If not, crash.
+ unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__
+ -- Translate operator and its arguments (each in the right context).
op <- toAbstract (OldQName op)
- foldl' app op <$> left (theFixity f) [p | p <- parts, not (isBindingHole p)] es
- where
- app e arg = A.App (ExprRange (fuseRange e arg)) e (setArgColors [] arg)
-
- toAbsOpArg cxt = traverse $ traverse $ toAbstractOpArg cxt
-
- left f (IdPart _ : xs) es = inside f xs es
- left f (_ : xs) (e : es) = do
- e <- toAbsOpArg (LeftOperandCtx f) e
- es <- inside f xs es
- return (e : es)
- left f (_ : _) [] = __IMPOSSIBLE__
- left f [] _ = __IMPOSSIBLE__
-
- inside f [x] es = right f x es
- inside f (IdPart _ : xs) es = inside f xs es
- inside f (_ : xs) (e : es) = do
- e <- toAbsOpArg InsideOperandCtx e
- es <- inside f xs es
- return (e : es)
- inside _ (_ : _) [] = __IMPOSSIBLE__
- inside _ [] _ = __IMPOSSIBLE__
-
- right _ (IdPart _) [] = return []
- right f _ [e] = do
- e <- toAbsOpArg (RightOperandCtx f) e
- return [e]
- right _ _ _ = __IMPOSSIBLE__
+ foldl' app op <$> left (theFixity f) nonBindingParts es
+ where
+ -- Build an application in the abstract syntax, with correct Range.
+ app e arg = A.App (ExprRange (fuseRange e arg)) e (setArgColors [] arg)
+
+ -- Translate an argument (inside @C.NamedArg . OpApp@).
+ toAbsOpArg cxt = traverse $ traverse $ toAbstractOpArg cxt
+
+ -- The hole left to the first @IdPart@ is filled with an expression in @LeftOperandCtx at .
+ left f (IdPart _ : xs) es = inside f xs es
+ left f (_ : xs) (e : es) = do
+ e <- toAbsOpArg (LeftOperandCtx f) e
+ es <- inside f xs es
+ return (e : es)
+ left f (_ : _) [] = __IMPOSSIBLE__
+ left f [] _ = __IMPOSSIBLE__
+
+ -- The holes in between the @IdPart at s is filled with an expression in @InsideOperandCtx at .
+ inside f [x] es = right f x es
+ inside f (IdPart _ : xs) es = inside f xs es
+ inside f (_ : xs) (e : es) = do
+ e <- toAbsOpArg InsideOperandCtx e
+ es <- inside f xs es
+ return (e : es)
+ inside _ (_ : _) [] = __IMPOSSIBLE__
+ inside _ [] _ = __IMPOSSIBLE__
+
+ -- The hole right of the last @IdPart@ is filled with an expression in @RightOperandCtx at .
+ right _ (IdPart _) [] = return []
+ right f _ [e] = do
+ e <- toAbsOpArg (RightOperandCtx f) e
+ return [e]
+ right _ _ _ = __IMPOSSIBLE__
diff --git a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
index db761a5..da47b35 100644
--- a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
+++ b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
Translating from internal syntax to abstract syntax. Enables nice
@@ -29,7 +29,6 @@ import Prelude hiding (mapM_, mapM)
import Control.Applicative
import Control.Arrow
import Control.Monad.State hiding (mapM_, mapM)
-import Control.Monad.Error hiding (mapM_, mapM)
import Control.Monad.Reader hiding (mapM_, mapM)
import Data.Foldable (foldMap)
@@ -63,13 +62,14 @@ import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.DropArgs
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- Composition of reified applications ------------------------------------
@@ -151,7 +151,7 @@ instance Reify DisplayTerm Expr where
reify d = case d of
DTerm v -> reifyTerm False v
DDot v -> reify v
- DCon c vs -> apps (A.Con (AmbQ [c])) =<< reifyIArgs vs
+ DCon c vs -> apps (A.Con (AmbQ [conName c])) =<< reifyIArgs vs
DDef f vs -> apps (A.Def f) =<< reifyIArgs vs
DWithApp u us vs -> do
(e, es) <- reify (u, us)
@@ -220,7 +220,7 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
okTerm (I.Var _ []) = True
okTerm (I.Con c vs) = all okArg vs
- okTerm (I.Def x []) = show x == "_" -- Handling wildcards in display forms
+ okTerm (I.Def x []) = isNoName $ qnameToConcrete x -- Handling wildcards in display forms
okTerm _ = True -- False
-- Flatten a dt into (parentName, parentArgs, withArgs).
@@ -229,7 +229,7 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
(f, vs, ds0) -> (f, vs, ds0 ++ ds1 ++ map (DTerm . unArg) ds2)
flattenWith (DDef f vs) = (f, vs, []) -- .^ hacky, but we should only hit this when printing debug info
flattenWith (DTerm (I.Def f es)) =
- let vs = maybe __IMPOSSIBLE__ id $ mapM isApplyElim es
+ let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es
in (f, map (fmap DTerm) vs, [])
flattenWith _ = __IMPOSSIBLE__
@@ -249,7 +249,7 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
termToPat (DTerm (I.Var n [])) = return $ ps !! n
- termToPat (DCon c vs) = A.ConP ci (AmbQ [c]) <$> do
+ termToPat (DCon c vs) = A.ConP ci (AmbQ [conName c]) <$> do
mapM argToPat =<< reifyIArgs' vs
termToPat (DTerm (I.Con c vs)) = A.ConP ci (AmbQ [conName c]) <$> do
@@ -274,10 +274,10 @@ reifyDisplayFormP lhs@(A.SpineLHS i f ps wps) =
I.Con c vs ->
apps (A.Con (AmbQ [conName c])) =<< argsToExpr vs
I.Def f es -> do
- let vs = maybe __IMPOSSIBLE__ id $ mapM isApplyElim es
+ let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es
apps (A.Def f) =<< argsToExpr vs
I.Var n es -> do
- let vs = maybe __IMPOSSIBLE__ id $ mapM isApplyElim es
+ let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es
-- Andreas, 2014-06-11 Issue 1177
-- due to β-normalization in substitution,
-- even the pattern variables @n < len@ can be
@@ -790,6 +790,7 @@ instance DotVars A.Expr where
A.ScopedExpr _ e -> dotVars e
A.Var x -> Set.singleton x -- add any expression variable
A.Def _ -> Set.empty
+ A.Proj _ -> Set.empty
A.Con _ -> Set.empty
A.Lit _ -> Set.empty
A.QuestionMark{} -> Set.empty
@@ -846,7 +847,7 @@ reifyPatterns tel perm ps = evalStateT (reifyArgs ps) 0
translate = (vars !!)
where
- vars = permute (invertP perm) [0..]
+ vars = permute (invertP __IMPOSSIBLE__ perm) [0..]
reifyPat :: I.Pattern -> StateT Nat TCM A.Pattern
reifyPat p = case p of
diff --git a/src/full/Agda/Termination/CallGraph.hs b/src/full/Agda/Termination/CallGraph.hs
index 90e161d..635ea95 100644
--- a/src/full/Agda/Termination/CallGraph.hs
+++ b/src/full/Agda/Termination/CallGraph.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-- | Call graphs and related concepts, more or less as defined in
-- \"A Predicative Analysis of Structural Recursion\" by
@@ -20,6 +20,7 @@ module Agda.Termination.CallGraph
, (>*<)
-- * Call graphs
, CallGraph(..)
+ , targetNodes
, fromList
, toList
, empty
@@ -34,14 +35,15 @@ module Agda.Termination.CallGraph
import Prelude hiding (null)
+import Data.Foldable (Foldable)
+import qualified Data.Foldable as Fold
import Data.Function
+import qualified Data.List as List
import Data.Map (Map, (!))
import qualified Data.Map as Map
-import qualified Data.List as List
import Data.Monoid
-
-import Data.Foldable (Foldable)
-import qualified Data.Foldable as Fold
+import Data.Set (Set)
+import qualified Data.Set as Set
import Data.Traversable (Traversable)
import qualified Data.Traversable as Trav
@@ -70,7 +72,7 @@ import Agda.Utils.QuickCheck hiding (label)
import Agda.Utils.TestHelpers
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -125,6 +127,12 @@ instance Monoid cinfo => CallComb (Call cinfo) where
newtype CallGraph cinfo = CallGraph { theCallGraph :: Graph Node Node (CMSet cinfo) }
deriving (Show)
+
+-- | Returns all the nodes with incoming edges. Somewhat expensive. @O(e)@.
+
+targetNodes :: CallGraph cinfo -> Set Node
+targetNodes = Graph.targetNodes . theCallGraph
+
-- | Converts a call graph to a list of calls with associated meta
-- information.
@@ -230,7 +238,7 @@ combineNewOldCallGraph (CallGraph new) (CallGraph old) = CallGraph -*- CallGraph
-- h@ are present in the graph, then @f -> h@ should also be present.
complete :: (?cutoff :: CutOff) => Monoid cinfo => CallGraph cinfo -> CallGraph cinfo
-complete cs = trampoline (mapFst (not . null) . completionStep cs) cs
+complete cs = repeatWhile (mapFst (not . null) . completionStep cs) cs
completionStep :: (?cutoff :: CutOff) => Monoid cinfo =>
CallGraph cinfo -> CallGraph cinfo -> (CallGraph cinfo, CallGraph cinfo)
diff --git a/src/full/Agda/Termination/CallMatrix.hs b/src/full/Agda/Termination/CallMatrix.hs
index 034b07f..40a30e9 100644
--- a/src/full/Agda/Termination/CallMatrix.hs
+++ b/src/full/Agda/Termination/CallMatrix.hs
@@ -1,13 +1,13 @@
--- {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+-- {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Agda.Termination.CallMatrix where
diff --git a/src/full/Agda/Termination/Inlining.hs b/src/full/Agda/Termination/Inlining.hs
index d7482e9..9cb52a6 100644
--- a/src/full/Agda/Termination/Inlining.hs
+++ b/src/full/Agda/Termination/Inlining.hs
@@ -70,7 +70,7 @@ import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Impossible
-#include "../undefined.h"
+#include "undefined.h"
inlineWithClauses :: QName -> Clause -> TCM [Clause]
inlineWithClauses f cl = inTopContext $ do
@@ -207,7 +207,7 @@ inline f pcl t wf wcl = inTopContext $ addCtxTel (clauseTel wcl) $ do
dtermToPat v =
case v of
DWithApp{} -> __IMPOSSIBLE__ -- I believe
- DCon c vs -> ConP (ConHead c []) Nothing . map (fmap unnamed)
+ DCon c vs -> ConP c Nothing . map (fmap unnamed)
<$> mapM (traverse dtermToPat) vs
DDef{} -> DotP (dtermToTerm v) <$ skip
DDot v -> DotP v <$ skip
@@ -233,7 +233,7 @@ expandWithFunctionCall f es = do
dtermToTerm :: DisplayTerm -> Term
dtermToTerm (DWithApp d ds vs) = dtermToTerm d `apply` (map (defaultArg . dtermToTerm) ds ++ vs)
-dtermToTerm (DCon c args) = Con (ConHead c []) $ map (fmap dtermToTerm) args
+dtermToTerm (DCon c args) = Con c $ map (fmap dtermToTerm) args
dtermToTerm (DDef f args) = Def f $ map (Apply . fmap dtermToTerm) args
dtermToTerm (DDot v) = v
dtermToTerm (DTerm v) = v
diff --git a/src/full/Agda/Termination/Monad.hs b/src/full/Agda/Termination/Monad.hs
index f14e382..91bef83 100644
--- a/src/full/Agda/Termination/Monad.hs
+++ b/src/full/Agda/Termination/Monad.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-- | The monad for the termination checker.
--
@@ -14,7 +14,6 @@
module Agda.Termination.Monad where
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
@@ -22,7 +21,7 @@ import Control.Monad.State
import Data.Functor ((<$>))
import qualified Data.List as List
-import Agda.Interaction.Options (defaultCutOff)
+import Agda.Interaction.Options
import Agda.Syntax.Abstract (QName,IsProjP(..))
import Agda.Syntax.Common (Delayed(..), Induction(..), Dom(..))
@@ -40,6 +39,7 @@ import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Records
import Agda.TypeChecking.Substitute
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Pretty (Pretty)
@@ -47,7 +47,7 @@ import qualified Agda.Utils.Pretty as P
import Agda.Utils.VarSet (VarSet)
import qualified Agda.Utils.VarSet as VarSet
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | The mutual block we are checking.
@@ -172,13 +172,46 @@ class (Functor m, Monad m) => MonadTer m where
newtype TerM a = TerM { terM :: ReaderT TerEnv TCM a }
deriving (Functor, Applicative, Monad)
-runTerm :: TerEnv -> TerM a -> TCM a
-runTerm tenv (TerM m) = runReaderT m tenv
-
instance MonadTer TerM where
terAsk = TerM $ ask
terLocal f = TerM . local f . terM
+-- | Generic run method for termination monad.
+runTer :: TerEnv -> TerM a -> TCM a
+runTer tenv (TerM m) = runReaderT m tenv
+
+-- | Run TerM computation in default environment (created from options).
+
+runTerDefault :: TerM a -> TCM a
+runTerDefault cont = do
+
+ -- Assemble then initial configuration of the termination environment.
+
+ cutoff <- optTerminationDepth <$> pragmaOptions
+
+ -- Get the name of size suc (if sized types are enabled)
+ suc <- sizeSucName
+
+ -- The name of sharp (if available).
+ sharp <- fmap nameOfSharp <$> coinductionKit
+
+ guardingTypeConstructors <-
+ optGuardingTypeConstructors <$> pragmaOptions
+
+ -- Andreas, 2014-08-28
+ -- We do not inline with functions if --without-K.
+ inlineWithFunctions <- not . optWithoutK <$> pragmaOptions
+
+ let tenv = defaultTerEnv
+ { terGuardingTypeConstructors = guardingTypeConstructors
+ , terInlineWithFunctions = inlineWithFunctions
+ , terSizeSuc = suc
+ , terSharp = sharp
+ , terCutOff = cutoff
+ }
+
+ runTer tenv cont
+
-- * Termination monad is a 'MonadTCM'.
instance MonadReader TCEnv TerM where
@@ -198,7 +231,7 @@ instance MonadTCM TerM where
instance MonadError TCErr TerM where
throwError = liftTCM . throwError
catchError m handler = TerM $ ReaderT $ \ tenv -> do
- runTerm tenv m `catchError` (\ err -> runTerm tenv $ handler err)
+ runTer tenv m `catchError` (\ err -> runTer tenv $ handler err)
-- * Modifiers and accessors for the termination environment in the monad.
@@ -399,7 +432,11 @@ data DeBruijnPat' a
-- ^ The name refers to either an ordinary
-- constructor or the successor function on sized types.
| LitDBP Literal
+ -- ^ Literal. Also abused to censor part of a pattern.
+ | TermDBP Term
+ -- ^ Part of dot pattern that cannot be converted into a pattern.
| ProjDBP QName
+ -- ^ Projection pattern.
deriving (Functor, Show)
instance IsProjP (DeBruijnPat' a) where
@@ -407,11 +444,23 @@ instance IsProjP (DeBruijnPat' a) where
isProjP _ = Nothing
instance PrettyTCM DeBruijnPat where
- prettyTCM (VarDBP i) = text $ show i
- prettyTCM (ConDBP c ps) = parens (prettyTCM c <+> hsep (map prettyTCM ps))
+ prettyTCM (VarDBP i) = prettyTCM $ var i
+ prettyTCM (ConDBP c ps) = parens $ do prettyTCM c <+> hsep (map prettyTCM ps)
prettyTCM (LitDBP l) = prettyTCM l
+ prettyTCM (TermDBP v) = parens $ prettyTCM v
prettyTCM (ProjDBP d) = prettyTCM d
+-- | How long is the path to the deepest variable?
+patternDepth :: DeBruijnPat' a -> Int
+patternDepth p =
+ case p of
+ ConDBP _ ps -> succ $ maximum $ 0 : map patternDepth ps
+ VarDBP{} -> 0
+ LitDBP{} -> 0
+ TermDBP{} -> 0
+ ProjDBP{} -> 0
+
+
-- | A dummy pattern used to mask a pattern that cannot be used
-- for structural descent.
@@ -441,6 +490,7 @@ instance UsableSizeVars DeBruijnPat where
VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) (return $ mempty)
ConDBP c ps -> conUseSizeLt c $ usableSizeVars ps
LitDBP{} -> return mempty
+ TermDBP{} -> return mempty
ProjDBP{} -> return mempty
instance UsableSizeVars [DeBruijnPat] where
diff --git a/src/full/Agda/Termination/Order.hs b/src/full/Agda/Termination/Order.hs
index be8a7e7..b513927 100644
--- a/src/full/Agda/Termination/Order.hs
+++ b/src/full/Agda/Termination/Order.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | An Abstract domain of relative sizes, i.e., differences
@@ -15,7 +15,7 @@ module Agda.Termination.Order
, supremum, infimum
, orderSemiring
, le, lt, unknown, orderMat, collapseO
- , decreasing, isDecr
+ , nonIncreasing, decreasing, isDecr
, NotWorse(..)
, tests
) where
@@ -35,7 +35,7 @@ import Agda.Utils.Pretty hiding (empty)
import Agda.Utils.QuickCheck
import Agda.Utils.TestHelpers
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -200,9 +200,13 @@ lt = Decr 1
unknown :: Order
unknown = Unknown
+nonIncreasing :: Order -> Bool
+nonIncreasing (Decr k) = k >= 0
+nonIncreasing _ = False
+
decreasing :: Order -> Bool
-decreasing (Decr k) | k > 0 = True
-decreasing _ = False
+decreasing (Decr k) = k > 0
+decreasing _ = False
-- | Matrix-shaped order is decreasing if any diagonal element is decreasing.
isDecr :: Order -> Bool
diff --git a/src/full/Agda/Termination/RecCheck.hs b/src/full/Agda/Termination/RecCheck.hs
index b651e18..100192f 100644
--- a/src/full/Agda/Termination/RecCheck.hs
+++ b/src/full/Agda/Termination/RecCheck.hs
@@ -56,8 +56,8 @@ anyDefs names a = do
-- Prepare function to lookup metas outside of TCM
st <- getMetaStore
let lookup x = case mvInstantiation <$> Map.lookup x st of
- Just (InstV v) -> Just v
- _ -> Nothing
+ Just (InstV _ v) -> Just v -- TODO: ignoring the lambdas might be bad?
+ _ -> Nothing
-- we collect only those used definitions that are in @names@
emb d = if d `elem` names then [d] else []
-- get all the Defs that are in names
diff --git a/src/full/Agda/Termination/Semiring.hs b/src/full/Agda/Termination/Semiring.hs
index aca2cfa..624e337 100644
--- a/src/full/Agda/Termination/Semiring.hs
+++ b/src/full/Agda/Termination/Semiring.hs
@@ -80,6 +80,7 @@ instance SemiRing Integer where
integerSemiring :: Semiring Integer
integerSemiring = Semiring { add = (+), mul = (*), zero = 0 } -- , one = 1 }
+prop_integerSemiring :: Integer -> Integer -> Integer -> Bool
prop_integerSemiring = semiringInvariant integerSemiring
-- | The standard semiring on 'Int's.
@@ -97,6 +98,7 @@ instance SemiRing Int where
intSemiring :: Semiring Int
intSemiring = Semiring { add = (+), mul = (*), zero = 0 } -- , one = 1 }
+prop_intSemiring :: Int -> Int -> Int -> Bool
prop_intSemiring = semiringInvariant intSemiring
-- | The standard semiring on 'Bool's.
@@ -105,6 +107,7 @@ boolSemiring :: Semiring Bool
boolSemiring =
Semiring { add = (||), mul = (&&), zero = False } --, one = True }
+prop_boolSemiring :: Bool -> Bool -> Bool -> Bool
prop_boolSemiring = semiringInvariant boolSemiring
------------------------------------------------------------------------
diff --git a/src/full/Agda/Termination/SparseMatrix.hs b/src/full/Agda/Termination/SparseMatrix.hs
index 19e940a..b90a538 100644
--- a/src/full/Agda/Termination/SparseMatrix.hs
+++ b/src/full/Agda/Termination/SparseMatrix.hs
@@ -1,13 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{- | Sparse matrices.
@@ -78,7 +78,7 @@ import Agda.Utils.QuickCheck
import Agda.Utils.TestHelpers
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -563,6 +563,7 @@ matrix :: (Arbitrary i, Integral i, Arbitrary b, HasZero b)
=> Size i -> Gen (Matrix i b)
matrix sz = matrixUsingRowGen sz (\n -> vectorOf (fromIntegral n) arbitrary)
+prop_matrix :: Size Int -> Property
prop_matrix sz = forAll (matrix sz :: Gen TM) $ \ m -> size m == sz
-- | Generate a matrix of arbitrary size.
@@ -605,10 +606,10 @@ prop_diagonal :: TM -> Bool
prop_diagonal m@(Matrix (Size r c) _) =
length (diagonal m) == min r c
-prop_diagonal' n =
- forAll natural $ \n ->
- forAll (matrix (Size n n) :: Gen TM) $ \m ->
- length (diagonal m) == n
+-- prop_diagonal' n =
+-- forAll natural $ \n ->
+-- forAll (matrix (Size n n) :: Gen TM) $ \m ->
+-- length (diagonal m) == n
-- | Transposing twice is the identity.
@@ -647,6 +648,7 @@ prop_zipMatrices_correct m1 m2 =
-- | Matrix addition is well-defined, associative and commutative.
+prop_add :: Size Int -> Property
prop_add sz =
forAll (three (matrix sz :: Gen TM)) $ \(m1, m2, m3) ->
let m' = add (+) m1 m2 in
@@ -693,6 +695,7 @@ prop_interAssocWith_correct xs ys =
-- | Matrix multiplication is well-defined and associative.
+prop_mul :: Size Int -> Property
prop_mul sz =
mapSize (`div` 2) $
forAll (two natural) $ \(c2, c3) ->
diff --git a/src/full/Agda/Termination/TermCheck.hs b/src/full/Agda/Termination/TermCheck.hs
index de8099d..5139949 100644
--- a/src/full/Agda/Termination/TermCheck.hs
+++ b/src/full/Agda/Termination/TermCheck.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImplicitParams #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
{- Checking for Structural recursion
Authors: Andreas Abel, Nils Anders Danielsson, Ulf Norell,
@@ -20,14 +20,17 @@ module Agda.Termination.TermCheck
, Result, DeBruijnPat
) where
+import Prelude hiding (null)
+
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.State
-import Data.List as List
+import Data.List hiding (null)
+import qualified Data.List as List
import Data.Maybe (mapMaybe, isJust, fromMaybe)
import Data.Monoid
import qualified Data.Map as Map
+import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (traverse)
@@ -41,8 +44,8 @@ import Agda.Syntax.Literal (Literal(LitString))
import Agda.Termination.CutOff
import Agda.Termination.Monad
-import Agda.Termination.CallGraph (CallGraph)
-import Agda.Termination.CallGraph as CallGraph
+import Agda.Termination.CallGraph hiding (null)
+import qualified Agda.Termination.CallGraph as CallGraph
import Agda.Termination.CallMatrix hiding (null)
import Agda.Termination.Order as Order
import qualified Agda.Termination.SparseMatrix as Matrix
@@ -74,13 +77,14 @@ import Agda.Utils.List
import Agda.Utils.Size
import Agda.Utils.Maybe
import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M)
+import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Pointed
import Agda.Utils.Pretty (render)
import Agda.Utils.VarSet (VarSet)
import qualified Agda.Utils.VarSet as VarSet
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Call graph with call info for composed calls.
@@ -92,7 +96,6 @@ type Calls = CallGraph CallPath
type Result = [TerminationError]
-
-- | Termination check a single declaration.
termDecl :: A.Declaration -> TCM Result
@@ -187,7 +190,7 @@ termMutual i ds = if names == [] then return mempty else
billTo [Benchmark.Termination, Benchmark.RecCheck] $ recursive allNames
-- NO_TERMINATION_CHECK
- if (Info.mutualTermCheck i == NoTerminationCheck) then do
+ if (Info.mutualTermCheck i `elem` [ NoTerminationCheck, Terminating ]) then do
reportSLn "term.warn.yes" 2 $ "Skipping termination check for " ++ show names
forM_ allNames $ \ q -> setTerminates q True -- considered terminating!
return mempty
@@ -203,43 +206,24 @@ termMutual i ds = if names == [] then return mempty else
return mempty)
$ {- else -} do
- -- Assemble then initial configuration of the termination environment.
-
- cutoff <- optTerminationDepth <$> pragmaOptions
-
- reportSLn "term.top" 10 $ "Termination checking " ++ show names ++
- " with cutoff=" ++ show cutoff ++ "..."
-
- -- Get the name of size suc (if sized types are enabled)
- suc <- sizeSucName
-
- -- The name of sharp (if available).
- sharp <- fmap nameOfSharp <$> coinductionKit
-
- guardingTypeConstructors <-
- optGuardingTypeConstructors <$> pragmaOptions
-
- -- Andreas, 2014-08-28
- -- We do not inline with functions if --without-K.
- inlineWithFunctions <- not . optWithoutK <$> pragmaOptions
-
- let tenv = defaultTerEnv
- { terGuardingTypeConstructors = guardingTypeConstructors
- , terInlineWithFunctions = inlineWithFunctions
- , terSizeSuc = suc
- , terSharp = sharp
- , terCutOff = cutoff
- , terMutual = allNames
- , terUserNames = names
+ -- Set the mutual names in the termination environment.
+ let setNames e = e
+ { terMutual = allNames
+ , terUserNames = names
}
+ runTerm cont = runTerDefault $ do
+ cutoff <- terGetCutOff
+ reportSLn "term.top" 10 $ "Termination checking " ++ show names ++
+ " with cutoff=" ++ show cutoff ++ "..."
+ terLocal setNames cont
-- New check currently only makes a difference for copatterns.
-- Since it is slow, only invoke it if --copatterns.
res <- ifM (optCopatterns <$> pragmaOptions)
-- Then: New check, one after another.
- (runTerm tenv $ forM' allNames $ termFunction)
+ (runTerm $ forM' allNames $ termFunction)
-- Else: Old check, all at once.
- (runTerm tenv $ termMutual')
+ (runTerm $ termMutual')
-- record result of termination check in signature
let terminates = List.null res
@@ -300,6 +284,10 @@ termMutual' = do
show (names) ++ " does termination check"
return mempty
+-- ASR (08 November 2014). The type of the function could be
+--
+-- @Either a b -> TerM (Either a b)@.
+billToTerGraph :: a -> TerM a
billToTerGraph = billPureTo [Benchmark.Termination, Benchmark.Graph]
-- | @reportCalls@ for debug printing.
@@ -337,9 +325,9 @@ reportCalls no calls = do
step cs = do
let (new, cs') = completionStep cs0 cs
report " New call matrices " new
- return (not $ CallGraph.null new, cs')
+ return $ if CallGraph.null new then Left () else Right cs'
report " Initial call matrices " cs0
- void $ trampolineM step cs0
+ trampolineM step cs0
-- Print the result of completion.
let calls' = CallGraph.complete calls
@@ -376,10 +364,22 @@ termFunction name = do
reportTarget target
terSetTarget target $ do
- -- Collect all recursive calls in the block,
- -- taking the target of the current function into account.
-
- let collect = forM' allNames termDef
+ -- Collect the recursive calls in the block which (transitively)
+ -- involve @name@,
+ -- taking the target of @name@ into account for computing guardedness.
+
+ let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do
+ if null todo then return $ Left calls else do
+ -- Extract calls originating from indices in @todo at .
+ new <- forM' todo $ \ i ->
+ termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i
+ -- Mark those functions as processed and add the calls to the result.
+ let done' = done `mappend` todo
+ calls' = new `mappend` calls
+ -- Compute the new todo list:
+ todo' = CallGraph.targetNodes new Set.\\ done'
+ -- Jump the trampoline.
+ return $ Right (todo', done', calls')
-- First try to termination check ignoring the dot patterns
calls1 <- terSetUseDotPatterns False $ collect
@@ -423,6 +423,15 @@ typeEndsInDef t = liftTCM $ do
_ -> return Nothing
-- | Termination check a definition by pattern matching.
+--
+-- TODO: Refactor!
+-- As this function may be called twice,
+-- once disregarding dot patterns,
+-- the second time regarding dot patterns,
+-- it is better if we separated bare call extraction
+-- from computing the change in structural order.
+-- Only the latter depends on the choice whether we
+-- consider dot patterns or not.
termDef :: QName -> TerM Calls
termDef name = terSetCurrent name $ do
@@ -452,12 +461,20 @@ termDef name = terSetCurrent name $ do
-- | Mask arguments and result for termination checking
-- according to type of function.
--- Only arguments of data/record type are counted in.
+-- Only arguments of types ending in data/record or Size are counted in.
setMasks :: Type -> TerM a -> TerM a
setMasks t cont = do
- TelV tel core <- liftTCM $ telView t
- ds <- liftTCM $ mapM ((isJust <.> isDataOrRecord) <=< (reduce . unEl . snd . unDom)) $ telToList tel
- d <- liftTCM . isJust <.> isDataOrRecord . unEl $ t
+ (ds, d) <- liftTCM $ do
+ TelV tel core <- telView t
+ -- Check argument types
+ ds <- forM (telToList tel) $ \ t -> do
+ TelV _ t <- telView $ snd $ unDom t
+ (isJust <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)
+ -- Check result types
+ d <- isJust <.> isDataOrRecord . unEl $ core
+ unless d $
+ reportSLn "term.mask" 20 $ "result type is not data or record type, ignoring guardedness for --without-K"
+ return (ds, d)
terSetMaskArgs (ds ++ repeat False) $ terSetMaskResult d $ cont
{- Termination check clauses:
@@ -503,18 +520,27 @@ matchingTarget conf t = maybe (return True) (match t) (currentTarget conf)
-}
-- | Convert a term (from a dot pattern) to a DeBruijn pattern.
+--
+-- The term is first normalized and stripped of all non-coinductive projections.
termToDBP :: Term -> TerM DeBruijnPat
termToDBP t = ifNotM terGetUseDotPatterns (return unusedVar) $ {- else -} do
- suc <- terGetSizeSuc
- t <- liftTCM $ stripAllProjections =<< constructorForm t
- case ignoreSharing t of
- Var i [] -> return $ VarDBP i
- Con c args -> ConDBP (conName c) <$> mapM (termToDBP . unArg) args
- Def s [Apply arg] | Just s == suc
- -> ConDBP s . (:[]) <$> termToDBP (unArg arg)
- Lit l -> return $ LitDBP l
- _ -> return unusedVar
+ suc <- terGetSizeSuc
+ let
+ loop :: Term -> TCM DeBruijnPat
+ loop t = do
+ t <- constructorForm t
+ case ignoreSharing t of
+ -- Constructors.
+ Con c args -> ConDBP (conName c) <$> mapM (loop . unArg) args
+ Def s [Apply arg] | Just s == suc
+ -> ConDBP s . (:[]) <$> loop (unArg arg)
+ DontCare t -> __IMPOSSIBLE__ -- removed by stripAllProjections
+ -- Leaves.
+ Var i [] -> return $ VarDBP i
+ Lit l -> return $ LitDBP l
+ t -> return $ TermDBP t
+ liftTCM $ loop =<< stripAllProjections =<< normalise t
-- | Masks coconstructor patterns in a deBruijn pattern.
@@ -530,12 +556,15 @@ stripCoConstructors p = do
-- The remaining (atomic) patterns cannot contain coconstructors, obviously.
VarDBP{} -> return p
LitDBP{} -> return p
+ TermDBP{} -> return p -- Can contain coconstructors, but they do not count here.
ProjDBP{} -> return p
-- | Masks all non-data/record type patterns if --without-K.
maskNonDataArgs :: [DeBruijnPat] -> TerM [DeBruijnPat]
-maskNonDataArgs ps = do
- zipWith (\ p d -> if d then p else unusedVar) ps <$> terGetMaskArgs
+maskNonDataArgs ps = zipWith mask ps <$> terGetMaskArgs
+ where
+ mask p at ProjDBP{} _ = p
+ mask p d = if d then p else unusedVar
-- | cf. 'TypeChecking.Coverage.Match.buildMPatterns'
openClause :: Permutation -> [Pattern] -> ClauseBody -> TerM ([DeBruijnPat], Maybe Term)
@@ -551,7 +580,7 @@ openClause perm ps body = do
-- length of the telescope
n = size perm
-- the variables as a map from the body variables to the clause telescope
- xs = permute (invertP perm) $ downFrom (size perm)
+ xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm)
tick = do x : xs <- get; put xs; return x
@@ -1115,12 +1144,13 @@ offsetFromConstructor :: MonadTCM tcm => QName -> tcm Int
offsetFromConstructor c = maybe 1 (const 0) <$> do
liftTCM $ isRecordConstructor c
--- | Compute the sub patterns of a 'DeBruijnPat'.
+-- | Compute the proper subpatterns of a 'DeBruijnPat'.
subPatterns :: DeBruijnPat -> [DeBruijnPat]
subPatterns p = case p of
- VarDBP _ -> []
ConDBP c ps -> ps ++ concatMap subPatterns ps
+ VarDBP _ -> []
LitDBP _ -> []
+ TermDBP _ -> []
ProjDBP _ -> []
compareTerm :: Term -> DeBruijnPat -> TerM Order
@@ -1186,11 +1216,11 @@ instance StripAllProjections Term where
-- Precondition: top meta variable resolved
compareTerm' :: Term -> DeBruijnPat -> TerM Order
-compareTerm' v0 p = do
+compareTerm' v p = do
suc <- terGetSizeSuc
cutoff <- terGetCutOff
let ?cutoff = cutoff
- let v = ignoreSharing v0
+ v <- return $ ignoreSharing v
case (v, p) of
-- Andreas, 2013-11-20 do not drop projections,
@@ -1234,25 +1264,41 @@ compareTerm' v0 p = do
increase <$> offsetFromConstructor (conName c)
<*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) p) ts)
- (t, p) | isSubTerm t p -> return Order.le
-
- _ -> return Order.unknown
-
--- TODO: isSubTerm should compute a size difference (Order)
-isSubTerm :: Term -> DeBruijnPat -> Bool
-isSubTerm t p = equal t p || properSubTerm t p
+ -- Andreas, 2014-09-22, issue 1281:
+ -- For metas, termination checking should be optimistic.
+ -- If there is any instance of the meta making termination
+ -- checking succeed, then we should not fail.
+ -- Thus, we assume the meta will be instantiated with the
+ -- deepest variable in @p at .
+ -- For sized types, the depth is maximally context length - 1,
+ -- which is the number of SIZELT hypotheses one can have in a context.
+ (MetaV{}, p) -> Order.decr . max (patternDepth p) . pred <$> getContextSize
+
+ (t, p) -> return $ subTerm t p
+
+-- | @subTerm@ computes a size difference (Order)
+subTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPat -> Order
+subTerm t p = if equal t p then Order.le else properSubTerm t p
where
equal (Shared p) dbp = equal (derefPtr p) dbp
equal (Con c ts) (ConDBP c' ps) =
and $ (conName c == c')
: (length ts == length ps)
: zipWith equal (map unArg ts) ps
- equal (Var i []) (VarDBP j) = i == j
- equal (Lit l) (LitDBP l') = l == l'
+ equal (Var i []) (VarDBP i') = i == i'
+ equal (Lit l) (LitDBP l') = l == l'
+ -- Terms.
+ -- Checking for identity here is very fragile.
+ -- However, we cannot do much more, as we are not allowed to normalize t.
+ -- (It might diverge, and we are just in the process of termination checking.)
+ equal t (TermDBP t') = t == t'
equal _ _ = False
- properSubTerm t (ConDBP _ ps) = any (isSubTerm t) ps
- properSubTerm _ _ = False
+ properSubTerm t (ConDBP _ ps) = decrease 1 $ supremum $ map (subTerm t) ps
+ properSubTerm _ _ = Order.unknown
+
+isSubTerm :: (?cutoff :: CutOff) => Term -> DeBruijnPat -> Bool
+isSubTerm t p = nonIncreasing $ subTerm t p
compareConArgs :: Args -> [DeBruijnPat] -> TerM Order
compareConArgs ts ps = do
@@ -1285,13 +1331,14 @@ compareConArgs ts ps = do
compareVar :: Nat -> DeBruijnPat -> TerM Order
compareVar i (VarDBP j) = compareVarVar i j
-compareVar i (LitDBP _) = return $ Order.unknown
-compareVar i (ProjDBP _) = return $ Order.unknown
compareVar i (ConDBP c ps) = do
cutoff <- terGetCutOff
let ?cutoff = cutoff
decrease <$> offsetFromConstructor c
<*> (Order.supremum <$> mapM (compareVar i) ps)
+compareVar i LitDBP{} = return $ Order.unknown
+compareVar i TermDBP{} = return $ Order.unknown
+compareVar i ProjDBP{} = return $ Order.unknown
-- | Compare two variables.
--
diff --git a/src/full/Agda/Termination/Termination.hs b/src/full/Agda/Termination/Termination.hs
index e0eb67c..cdab9e4 100644
--- a/src/full/Agda/Termination/Termination.hs
+++ b/src/full/Agda/Termination/Termination.hs
@@ -72,7 +72,7 @@ endos cs = [ m | c <- cs, source c == target c
]
checkIdems :: (Monoid cinfo, ?cutoff :: CutOff) => [CallMatrixAug cinfo] -> Either cinfo ()
-checkIdems calls = caseMaybe (mhead offending) (Right ()) $ Left . augCallInfo
+checkIdems calls = caseMaybe (headMaybe offending) (Right ()) $ Left . augCallInfo
where
-- Every idempotent call must have decrease, otherwise it offends us.
offending = filter (not . hasDecrease) $ filter idempotent calls
diff --git a/src/full/Agda/Tests.hs b/src/full/Agda/Tests.hs
index bfa2f18..627420b 100644
--- a/src/full/Agda/Tests.hs
+++ b/src/full/Agda/Tests.hs
@@ -1,4 +1,3 @@
-
-- | Responsible for running all internal tests.
module Agda.Tests (testSuite) where
@@ -12,26 +11,28 @@ import Agda.Interaction.Highlighting.Range as InteRang (tests)
import Agda.Interaction.Options as InteOpti (tests)
import Agda.Syntax.Parser.Parser as SyntPars (tests)
import Agda.Syntax.Position as SyntPosi (tests)
-import Agda.Termination.CallGraph as TermCall (tests)
-import Agda.Termination.CallMatrix as TermCM (tests)
+import Agda.Termination.CallGraph as TermCall (tests)
+import Agda.Termination.CallMatrix as TermCM (tests)
-- import Agda.Termination.Lexicographic as TermLex (tests)
-- import Agda.Termination.Matrix as TermMatrix (tests)
-import Agda.Termination.Order as TermOrd (tests)
-import Agda.Termination.Semiring as TermRing (tests)
+import Agda.Termination.Order as TermOrd (tests)
+import Agda.Termination.Semiring as TermRing (tests)
import Agda.Termination.SparseMatrix as TermSparse (tests)
-import Agda.Termination.Termination as TermTerm (tests)
+import Agda.Termination.Termination as TermTerm (tests)
import Agda.TypeChecking.Irrelevance as Irrel (tests)
import Agda.TypeChecking.Tests as TypeChck (tests)
import Agda.TypeChecking.SizedTypes.Tests as SizedTypes (tests)
-import Agda.Utils.BiMap as UtilBiMap (tests)
-import Agda.Utils.Cluster as UtilClust (tests)
-import Agda.Utils.Either as UtilEith (tests)
+import Agda.Utils.Bag as UtilBag (tests)
+import Agda.Utils.BiMap as UtilBiMap (tests)
+import Agda.Utils.Cluster as UtilClust (tests)
+import Agda.Utils.Either as UtilEith (tests)
import Agda.Utils.Favorites as UtilFav (tests)
import Agda.Utils.FileName as UtilFile (tests)
import Agda.Utils.Graph.AdjacencyMap as UtilGrap (tests)
import Agda.Utils.Graph.AdjacencyMap.Unidirectional as UtilGraphUni (tests)
import Agda.Utils.List as UtilList (tests)
import Agda.Utils.PartialOrd as UtilPOrd (tests)
+import Agda.Utils.Permutation.Tests as UtilPerm (tests)
import Agda.Utils.Warshall as UtilWarsh (tests)
testSuite :: IO Bool
@@ -39,6 +40,7 @@ testSuite = runTests "QuickCheck test suite:"
[ Irrel.tests
, SizedTypes.tests
, UtilFav.tests
+ , UtilPerm.tests
, UtilPOrd.tests
, CompEnco.tests
, InteEmac.tests
@@ -57,6 +59,7 @@ testSuite = runTests "QuickCheck test suite:"
, TermSparse.tests
, TermTerm.tests
, TypeChck.tests
+ , UtilBag.tests
, UtilBiMap.tests
, UtilClust.tests
, UtilEith.tests
diff --git a/src/full/Agda/TheTypeChecker.hs b/src/full/Agda/TheTypeChecker.hs
index 7b5376c..4b0abb1 100644
--- a/src/full/Agda/TheTypeChecker.hs
+++ b/src/full/Agda/TheTypeChecker.hs
@@ -1,4 +1,3 @@
-
module Agda.TheTypeChecker
( checkDecls, checkDecl
, inferExpr, checkExpr
diff --git a/src/full/Agda/TypeChecking/Abstract.hs b/src/full/Agda/TypeChecking/Abstract.hs
index 111bda5..7f65788 100644
--- a/src/full/Agda/TypeChecking/Abstract.hs
+++ b/src/full/Agda/TypeChecking/Abstract.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Functions for abstracting terms over other terms.
@@ -18,7 +18,7 @@ import Agda.TypeChecking.Substitute
import Agda.Utils.List (splitExactlyAt)
import Agda.Utils.Impossible
-#include "../undefined.h"
+#include "undefined.h"
piAbstractTerm :: Term -> Type -> Type -> Type
piAbstractTerm v a b = fun a (abstractTerm v b)
@@ -56,7 +56,7 @@ class AbstractTerm a where
abstractTerm :: Term -> a -> a
instance AbstractTerm Term where
- abstractTerm u v | Just es <- u `isPrefixOf` v = Var 0 es
+ abstractTerm u v | Just es <- u `isPrefixOf` v = Var 0 $ raise 1 es
| otherwise =
case v of
-- Andreas, 2013-10-20: the original impl. works only at base types
diff --git a/src/full/Agda/TypeChecking/CheckInternal.hs b/src/full/Agda/TypeChecking/CheckInternal.hs
index 7c4f66b..eedb07a 100644
--- a/src/full/Agda/TypeChecking/CheckInternal.hs
+++ b/src/full/Agda/TypeChecking/CheckInternal.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- Initially authored by Andreas, 2013-10-22.
@@ -35,7 +35,7 @@ import Agda.Utils.Functor (($>))
import Agda.Utils.Monad
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Entry point for e.g. checking WithFunctionType.
@@ -177,11 +177,24 @@ checkDef' f a es t = do
-}
checkSpine :: Type -> Term -> Elims -> Type -> TCM ()
-checkSpine a self es t = inferSpine a self es >>= (`subtype` t)
+checkSpine a self es t = do
+ reportSDoc "tc.check.internal" 20 $ sep
+ [ text "checking spine "
+ , text "("
+ , prettyTCM self
+ , text " : "
+ , prettyTCM a
+ , text ")"
+ , prettyTCM es
+ , text " : "
+ , prettyTCM t
+ ]
+ inferSpine a self es >>= (`subtype` t)
checkArgs :: Type -> Term -> Args -> Type -> TCM ()
checkArgs a self vs t = checkSpine a self (map Apply vs) t
+-- | @checkArgInfo actual expected at .
checkArgInfo :: I.ArgInfo -> I.ArgInfo -> TCM ()
checkArgInfo ai ai' = do
checkHiding (getHiding ai) (getHiding ai')
diff --git a/src/full/Agda/TypeChecking/CompiledClause.hs b/src/full/Agda/TypeChecking/CompiledClause.hs
index 19692e2..eb9ce69 100644
--- a/src/full/Agda/TypeChecking/CompiledClause.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause.hs
@@ -1,9 +1,15 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Case trees.
+--
+-- After coverage checking, pattern matching is translated
+-- to case trees, i.e., a tree of successive case splits
+-- on one variable at a time.
module Agda.TypeChecking.CompiledClause where
@@ -19,34 +25,33 @@ import Agda.Syntax.Literal
import Agda.Utils.Pretty
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-type key :-> value = Map key value
-
data WithArity c = WithArity { arity :: Int, content :: c }
deriving (Typeable, Functor, Foldable, Traversable)
-- | Branches in a case tree.
+
data Case c = Branches
- { conBranches :: QName :-> WithArity c -- ^ Map from constructor (or projection) names to their arity and the case subtree. (Projections have arity 0.)
- , litBranches :: Literal :-> c -- ^ Map from literal to case subtree.
- , catchAllBranch :: Maybe c -- ^ (Possibly additional) catch-all clause.
+ { conBranches :: Map QName (WithArity c)
+ -- ^ Map from constructor (or projection) names to their arity
+ -- and the case subtree. (Projections have arity 0.)
+ , litBranches :: Map Literal c
+ -- ^ Map from literal to case subtree.
+ , catchAllBranch :: Maybe c
+ -- ^ (Possibly additional) catch-all clause.
}
deriving (Typeable, Functor, Foldable, Traversable)
-- | Case tree with bodies.
+
data CompiledClauses
= Case Int (Case CompiledClauses)
-- ^ @Case n bs@ stands for a match on the @n at -th argument
-- (counting from zero) with @bs@ as the case branches.
-- If the @n at -th argument is a projection, we have only 'conBranches'.
-- with arity 0.
-{-
- | CoCase Int (QName :-> CompiledClauses)
- -- ^ @CoCase n bs@ matches on projections.
- -- Catch-all is not meaningful here.
--}
| Done [Arg ArgName] Term
-- ^ @Done xs b@ stands for the body @b@ where the @xs@ contains hiding
-- and name suggestions for the free variables. This is needed to build
@@ -56,16 +61,23 @@ data CompiledClauses
-- ^ Absurd case.
deriving (Typeable)
+emptyBranches :: Case CompiledClauses
emptyBranches = Branches Map.empty Map.empty Nothing
+
+litCase :: Literal -> c -> Case c
litCase l x = Branches Map.empty (Map.singleton l x) Nothing
+
+conCase :: QName -> WithArity c -> Case c
conCase c x = Branches (Map.singleton c x) Map.empty Nothing
-catchAll x = Branches Map.empty Map.empty (Just x)
+
+catchAll :: c -> Case c
+catchAll x = Branches Map.empty Map.empty (Just x)
instance Monoid c => Monoid (WithArity c) where
- mempty = WithArity __IMPOSSIBLE__ mempty
- mappend (WithArity n1 c1) (WithArity n2 c2)
- | n1 == n2 = WithArity n1 $ mappend c1 c2
- | otherwise = __IMPOSSIBLE__ -- arity must match!
+ mempty = WithArity __IMPOSSIBLE__ mempty
+ mappend (WithArity n1 c1) (WithArity n2 c2)
+ | n1 == n2 = WithArity n1 $ mappend c1 c2
+ | otherwise = __IMPOSSIBLE__ -- arity must match!
instance Monoid m => Monoid (Case m) where
mempty = Branches Map.empty Map.empty Nothing
@@ -94,7 +106,7 @@ instance Pretty a => Pretty (Case a) where
prC Nothing = []
prC (Just x) = [text "_ ->" <+> pretty x]
-prettyMap :: (Show k, Pretty v) => (k :-> v) -> [Doc]
+prettyMap :: (Show k, Pretty v) => Map k v -> [Doc]
prettyMap m = [ sep [ text (show x ++ " ->")
, nest 2 $ pretty v ]
| (x, v) <- Map.toList m ]
@@ -106,9 +118,3 @@ instance Pretty CompiledClauses where
sep [ text ("case " ++ show n ++ " of")
, nest 2 $ pretty bs
]
-{-
- pretty (CoCase n bs) =
- sep [ text ("cocase " ++ show n ++ " of")
- , nest 2 $ vcat $ prettyMap bs
- ]
--}
diff --git a/src/full/Agda/TypeChecking/CompiledClause/Compile.hs b/src/full/Agda/TypeChecking/CompiledClause/Compile.hs
index a127b01..aa07064 100644
--- a/src/full/Agda/TypeChecking/CompiledClause/Compile.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause/Compile.hs
@@ -18,10 +18,10 @@ import Agda.TypeChecking.RecordPatterns
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Pretty
-import Agda.Utils.Functor
+import Agda.Utils.Functor (($>))
import Agda.Utils.List
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Process function clauses into case tree.
@@ -73,7 +73,6 @@ compileWithSplitTree t cs = case t of
-- after end of split tree, continue with left-to-right strategy
where
-
compiles :: SplitTrees -> Case Cls -> Case CompiledClauses
compiles ts br at Branches{ conBranches = cons
, litBranches = lits
@@ -179,7 +178,7 @@ expandCatchAlls single n cs =
-- True if nth pattern is variable or there are less than n patterns.
isCatchAllNth ps = all (isVar . unArg) $ take 1 $ drop n ps
- nth qs = fromMaybe __IMPOSSIBLE__ $ mhead $ drop n qs
+ nth qs = headWithDefault __IMPOSSIBLE__ $ drop n qs
classify (LitP l) = Left l
classify (ConP c _ _) = Right c
diff --git a/src/full/Agda/TypeChecking/CompiledClause/Match.hs b/src/full/Agda/TypeChecking/CompiledClause/Match.hs
index f40d849..7833baa 100644
--- a/src/full/Agda/TypeChecking/CompiledClause/Match.hs
+++ b/src/full/Agda/TypeChecking/CompiledClause/Match.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.TypeChecking.CompiledClause.Match where
@@ -20,7 +20,7 @@ import Agda.TypeChecking.Substitute
import Agda.Utils.Maybe
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
matchCompiled :: CompiledClauses -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Args) Term)
diff --git a/src/full/Agda/TypeChecking/Constraints.hs b/src/full/Agda/TypeChecking/Constraints.hs
index 4ed935a..8c6f191 100644
--- a/src/full/Agda/TypeChecking/Constraints.hs
+++ b/src/full/Agda/TypeChecking/Constraints.hs
@@ -4,7 +4,6 @@ module Agda.TypeChecking.Constraints where
import Control.Monad.State
import Control.Monad.Reader
-import Control.Monad.Error
import Control.Applicative
import Data.List as List
@@ -23,11 +22,11 @@ import {-# SOURCE #-} Agda.TypeChecking.MetaVars
import {-# SOURCE #-} Agda.TypeChecking.Empty
-- import {-# SOURCE #-} Agda.TypeChecking.UniversePolymorphism -- RETIRED
-import Agda.Utils.Fresh
+import Agda.Utils.Except ( MonadError(throwError) )
import Agda.Utils.Maybe
import Agda.Utils.Monad
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Catches pattern violation errors and adds a constraint.
@@ -40,8 +39,8 @@ catchConstraint c v = liftTCM $
-- 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 s -> put s >> addConstraint c
- _ -> throwError err
+ PatternErr{} -> addConstraint c
+ _ -> throwError err
addConstraint :: Constraint -> TCM ()
addConstraint c = do
@@ -175,12 +174,12 @@ solveConstraint_ (UnBlock m) =
BlockedConst t -> do
reportSDoc "tc.constr.blocked" 15 $
text ("blocked const " ++ show m ++ " :=") <+> prettyTCM t
- assignTerm m t
+ assignTerm m [] t
PostponedTypeCheckingProblem cl unblock -> enterClosure cl $ \prob -> do
ifNotM unblock (addConstraint $ UnBlock m) $ do
tel <- getContextTelescope
v <- liftTCM $ checkTypeCheckingProblem prob
- assignTerm m $ teleLam tel v
+ assignTerm m (telToArgs tel) v
-- Andreas, 2009-02-09, the following were IMPOSSIBLE cases
-- somehow they pop up in the context of sized types
--
diff --git a/src/full/Agda/TypeChecking/Conversion.hs b/src/full/Agda/TypeChecking/Conversion.hs
index b206338..7955956 100644
--- a/src/full/Agda/TypeChecking/Conversion.hs
+++ b/src/full/Agda/TypeChecking/Conversion.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.Conversion where
@@ -9,7 +9,6 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
-import Control.Monad.Error
import Data.List hiding (sort)
import qualified Data.List as List
@@ -45,13 +44,14 @@ import Agda.TypeChecking.ProjectionLike (elimView)
import Agda.Interaction.Options
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.Functor (($>))
import Agda.Utils.Monad
import Agda.Utils.Maybe
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{- MOVED to TypeChecking.Level
@@ -70,7 +70,7 @@ tryConversion m = (noConstraints m $> True)
sameVars :: Elims -> Elims -> Bool
sameVars xs ys = and $ zipWith same xs ys
where
- same (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = n == m
+ same (Apply (Arg _ (Var n []))) (Apply (Arg _ (Var m []))) = n == m
same _ _ = False
-- | @intersectVars us vs@ checks whether all relevant elements in @us@ and @vs@
@@ -174,10 +174,9 @@ compareTerm cmp a u v = do
"shortcut successful\n result: " ++ show u
-- Should be ok with catchError_ but catchError is much safer since we don't
-- rethrow errors.
- m `orelse` h = m `catchError` \err -> case err of
- PatternErr s -> put s >> h
- _ -> h
+ orelse m h = catchError m (\_ -> h)
+unifyPointers :: Comparison -> Term -> Term -> TCM () -> TCM ()
unifyPointers _ _ _ action = action
-- unifyPointers cmp _ _ action | cmp /= CmpEq = action
-- unifyPointers _ u v action = do
@@ -243,29 +242,35 @@ compareTerm' cmp a m n =
isrec <- isEtaRecord r
if isrec
then do
- dontHaveCopatterns <- not . optCopatterns <$> pragmaOptions
+ sig <- getSignature
let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
-- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem
-- to change Agda's behavior
-- isNeutral Blocked{} = False
isNeutral = isNeutral' . fmap ignoreSharing
isMeta = isMeta' . fmap ignoreSharing
- isNeutral' (NotBlocked Con{}) = False
+ isNeutral' (NotBlocked Con{}) = return False
-- Andreas, 2013-09-18: this is expensive:
-- should only do this when copatterns are on
- isNeutral' (NotBlocked Def{}) = dontHaveCopatterns -- a def by copattern can reduce if projected
- isNeutral' _ = True
+ isNeutral' (NotBlocked (Def q _)) = do
+ d <- getConstInfo q
+ return $ case d of
+ Defn {theDef = Function {funCopatternLHS = True}} -> False -- a def by copattern can reduce if projected
+ _ -> True
+ isNeutral' _ = return True
isMeta' (NotBlocked MetaV{}) = True
isMeta' _ = False
reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> text "is eta record type"
m <- reduceB m
+ mNeutral <- isNeutral m
n <- reduceB n
+ nNeutral <- isNeutral n
case (m, n) of
_ | isMeta m || isMeta n ->
compareAtom cmp a' (ignoreBlocking m) (ignoreBlocking n)
- _ | isNeutral m && isNeutral n -> do
+ _ | mNeutral && nNeutral -> do
-- Andreas 2011-03-23: (fixing issue 396)
-- if we are dealing with a singleton record,
-- we can succeed immediately
@@ -338,8 +343,8 @@ compareTel t1 t2 cmp tel1 tel2 =
addCtx name dom1 $
if dependent
- then guardConstraint c checkDom
- else checkDom >> solveConstraint_ c
+ then guardConstraint c checkDom
+ else checkDom >> solveConstraint_ c
-}
where
-- Andreas, 2011-05-10 better report message about types
@@ -388,7 +393,7 @@ compareAtom cmp t m n =
-- if a PatternErr is thrown, rebuild constraint!
catchConstraint (ValueCmp cmp t m n) $ do
reportSDoc "tc.conv.atom" 50 $
- text "compareAtom" <+> fsep [ prettyTCM m <+> prettyTCM cmp
+ text "compareAtom" <+> fsep [ prettyTCM m <+> prettyTCM cmp
, prettyTCM n
, text ":" <+> prettyTCM t ]
-- Andreas: what happens if I cut out the eta expansion here?
@@ -401,7 +406,7 @@ compareAtom cmp t m n =
-- constructorForm changes literal to constructors
-- only needed if the other side is not a literal
(mb'', nb'') <- case (ignoreSharing $ ignoreBlocking mb', ignoreSharing $ ignoreBlocking nb') of
- (Lit _, Lit _) -> return (mb', nb')
+ (Lit _, Lit _) -> return (mb', nb')
_ -> (,) <$> traverse constructorForm mb'
<*> traverse constructorForm nb'
@@ -417,7 +422,7 @@ compareAtom cmp t m n =
n <- normalise n -- is this what we want?
m <- normalise m
if m == n
- then return () -- Check syntactic equality for blocked terms
+ then return () -- Check syntactic equality for blocked terms
else postpone
dir = fromCmp cmp
@@ -428,7 +433,7 @@ compareAtom cmp t m n =
unifyPointers cmp (ignoreBlocking mb') (ignoreBlocking nb') $ do -- this needs to go after eta expansion to avoid creating infinite terms
reportSDoc "tc.conv.atom" 30 $
- text "compareAtom" <+> fsep [ prettyTCM mb <+> prettyTCM cmp
+ text "compareAtom" <+> fsep [ prettyTCM mb <+> prettyTCM cmp
, prettyTCM nb
, text ":" <+> prettyTCM t ]
case (ignoreSharing <$> mb, ignoreSharing <$> nb) of
@@ -455,12 +460,12 @@ compareAtom cmp t m n =
-- instantiate later meta variables first
let (solve1, solve2)
| (p1,x) > (p2,y) = (l,r)
- | otherwise = (r,l)
+ | otherwise = (r,l)
where l = assign dir x xArgs n
r = assign rid y yArgs m
try m h = m `catchError_` \err -> case err of
- PatternErr s -> put s >> h
+ PatternErr{} -> h
_ -> throwError err
-- First try the one with the highest priority. If that doesn't
@@ -468,9 +473,9 @@ compareAtom cmp t m n =
try solve1 solve2
-- one side a meta, the other an unblocked term
- (NotBlocked (MetaV x es), _) -> assign dir x es n
- (_, NotBlocked (MetaV x es)) -> assign rid x es m
- (Blocked{}, Blocked{}) -> checkSyntacticEquality
+ (NotBlocked (MetaV x es), _) -> assign dir x es n
+ (_, NotBlocked (MetaV x es)) -> assign rid x es m
+ (Blocked{}, Blocked{}) -> checkSyntacticEquality
(Blocked{}, _) -> useInjectivity cmp t m n
(_,Blocked{}) -> useInjectivity cmp t m n
_ -> do
@@ -481,15 +486,15 @@ compareAtom cmp t m n =
m <- elimView False m
n <- elimView False n
case (ignoreSharing m, ignoreSharing n) of
- (Pi{}, Pi{}) -> equalFun m n
+ (Pi{}, Pi{}) -> equalFun m n
- (Sort s1, Sort s2) -> compareSort CmpEq s1 s2
+ (Sort s1, Sort s2) -> compareSort CmpEq s1 s2
- (Lit l1, Lit l2) | l1 == l2 -> return ()
- (Var i es, Var i' es') | i == i' -> do
- a <- typeOfBV i
+ (Lit l1, Lit l2) | l1 == l2 -> return ()
+ (Var i es, Var i' es') | i == i' -> do
+ a <- typeOfBV i
-- Variables are invariant in their arguments
- compareElims [] a (var i) es es'
+ compareElims [] a (var i) es es'
(Def f es, Def f' es') | f == f' -> do
a <- defType <$> getConstInfo f
pol <- getPolarity' cmp f
@@ -546,8 +551,8 @@ compareAtom cmp t m n =
reportSLn "tc.conv.elim" 50 $ "v (raw) = " ++ show v
compareElims pol a v els1 els2
-}
- (Con x xArgs, Con y yArgs)
- | x == y -> do
+ (Con x xArgs, Con y yArgs)
+ | x == y -> do
-- Get the type of the constructor instantiated to the datatype parameters.
a' <- conType x t
-- Constructors are invariant in their arguments
@@ -584,13 +589,13 @@ compareAtom cmp t m n =
_ -> impossible
-}
equalFun t1 t2 = case (ignoreSharing t1, ignoreSharing t2) of
- (Pi dom1@(Dom i1 a1@(El a1s a1t)) b1, Pi (Dom i2 a2) b2)
- | argInfoHiding i1 /= argInfoHiding i2 -> typeError $ UnequalHiding t1 t2
+ (Pi dom1@(Dom i1 a1@(El a1s a1t)) b1, Pi (Dom i2 a2) b2)
+ | argInfoHiding i1 /= argInfoHiding i2 -> typeError $ UnequalHiding t1 t2
-- Andreas 2010-09-21 compare r1 and r2, but ignore forcing annotations!
- | not (compareRelevance cmp (ignoreForced $ argInfoRelevance i2)
+ | not (compareRelevance cmp (ignoreForced $ argInfoRelevance i2)
(ignoreForced $ argInfoRelevance i1))
-> typeError $ UnequalRelevance cmp t1 t2
- | otherwise -> verboseBracket "tc.conv.fun" 15 "compare function types" $ do
+ | otherwise -> verboseBracket "tc.conv.fun" 15 "compare function types" $ do
reportSDoc "tc.conv.fun" 20 $ nest 2 $ vcat
[ text "t1 =" <+> prettyTCM t1
, text "t2 =" <+> prettyTCM t2 ]
@@ -620,7 +625,7 @@ compareAtom cmp t m n =
then guardConstraint conCoDom checkDom
else checkDom >> solveConstraint_ conCoDom
-}
- _ -> __IMPOSSIBLE__
+ _ -> __IMPOSSIBLE__
compareRelevance :: Comparison -> Relevance -> Relevance -> Bool
compareRelevance CmpEq = (==)
@@ -836,14 +841,14 @@ compareType :: Comparison -> Type -> Type -> TCM ()
compareType cmp ty1@(El s1 a1) ty2@(El s2 a2) =
verboseBracket "tc.conv.type" 20 "compareType" $
catchConstraint (TypeCmp cmp ty1 ty2) $ do
- reportSDoc "tc.conv.type" 50 $ vcat
+ reportSDoc "tc.conv.type" 50 $ vcat
[ text "compareType" <+> sep [ prettyTCM ty1 <+> prettyTCM cmp
, prettyTCM ty2 ]
, hsep [ text " sorts:", prettyTCM s1, text " and ", prettyTCM s2 ]
]
-- Andreas, 2011-4-27 should not compare sorts, but currently this is needed
-- for solving sort and level metas
- compareSort CmpEq s1 s2 `catchError` \err -> case err of
+ compareSort CmpEq s1 s2 `catchError` \err -> case err of
TypeError _ e -> do
reportSDoc "tc.conv.type" 30 $ vcat
[ text "sort comparison failed"
@@ -873,8 +878,8 @@ compareType cmp ty1@(El s1 a1) ty2@(El s2 a2) =
-- throwError err
compareSort CmpEq s1 s2
_ -> throwError err
- compareTerm cmp (sort s1) a1 a2
- return ()
+ compareTerm cmp (sort s1) a1 a2
+ return ()
leqType :: Type -> Type -> TCM ()
leqType = compareType CmpLeq
@@ -962,28 +967,28 @@ leqSort :: Sort -> Sort -> TCM ()
leqSort s1 s2 =
ifM typeInType (return ()) $
catchConstraint (SortCmp CmpLeq s1 s2) $
- do (s1,s2) <- reduce (s1,s2)
+ do (s1,s2) <- reduce (s1,s2)
let postpone = addConstraint (SortCmp CmpLeq s1 s2)
reportSDoc "tc.conv.sort" 30 $
sep [ text "leqSort"
, nest 2 $ fsep [ prettyTCM s1 <+> text "=<"
, prettyTCM s2 ]
]
- case (s1, s2) of
+ case (s1, s2) of
(Type a, Type b) -> leqLevel a b
- (Prop , Prop ) -> return ()
- (Type _ , Prop ) -> notLeq s1 s2
+ (Prop , Prop ) -> return ()
+ (Type _ , Prop ) -> notLeq s1 s2
- (Prop , Type _ ) -> return ()
+ (Prop , Type _ ) -> return ()
(_ , Inf ) -> return ()
(Inf , _ ) -> equalSort s1 s2
(DLub{} , _ ) -> postpone
(_ , DLub{} ) -> postpone
where
- notLeq s1 s2 = typeError $ NotLeqSort s1 s2
+ notLeq s1 s2 = typeError $ NotLeqSort s1 s2
leqLevel :: Level -> Level -> TCM ()
leqLevel a b = liftTCM $ do
@@ -1271,13 +1276,13 @@ equalSort s1 s2 =
, text (show s2) ]
]
]
- case (s1, s2) of
+ case (s1, s2) of
(Type a , Type b ) -> equalLevel a b
- (Prop , Prop ) -> return ()
- (Type _ , Prop ) -> notEq s1 s2
- (Prop , Type _ ) -> notEq s1 s2
+ (Prop , Prop ) -> return ()
+ (Type _ , Prop ) -> notEq s1 s2
+ (Prop , Type _ ) -> notEq s1 s2
(Inf , Inf ) -> return ()
(Inf , Type (Max as@(_:_))) -> mapM_ (isInf $ notEq s1 s2) as
@@ -1297,7 +1302,7 @@ equalSort s1 s2 =
(DLub{} , _ ) -> postpone
(_ , DLub{} ) -> postpone
where
- notEq s1 s2 = typeError $ UnequalSorts s1 s2
+ notEq s1 s2 = typeError $ UnequalSorts s1 s2
isInf notok ClosedLevel{} = notok
isInf notok (Plus _ l) = case l of
diff --git a/src/full/Agda/TypeChecking/Coverage.hs b/src/full/Agda/TypeChecking/Coverage.hs
index 49947d6..e71c431 100644
--- a/src/full/Agda/TypeChecking/Coverage.hs
+++ b/src/full/Agda/TypeChecking/Coverage.hs
@@ -1,12 +1,25 @@
-{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fwarn-unused-imports #-}
+
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+
+{-| Coverage checking, case splitting, and splitting for refine tactics.
-module Agda.TypeChecking.Coverage where
+ -}
+
+module Agda.TypeChecking.Coverage
+ ( SplitClause(..), clauseToSplitClause, fixTarget
+ , Covering(..), splitClauses
+ , coverageCheck
+ , splitClauseWithAbsurd
+ , splitLast
+ , splitResult
+ ) where
import Control.Monad
-import Control.Monad.Error
+import Control.Monad.Trans ( lift )
import Control.Applicative hiding (empty)
import Data.List
@@ -31,9 +44,8 @@ import Agda.TypeChecking.Monad.Context
import Agda.TypeChecking.Rules.LHS.Problem (FlexibleVar(..),flexibleVarFromHiding)
import Agda.TypeChecking.Rules.LHS.Unify
-import Agda.TypeChecking.Rules.LHS.Instantiate
-import Agda.TypeChecking.Rules.LHS
-import qualified Agda.TypeChecking.Rules.LHS.Split as Split
+import Agda.TypeChecking.Rules.LHS.Instantiate (instantiateTel)
+import Agda.TypeChecking.Rules.LHS (instantiatePattern)
import Agda.TypeChecking.Coverage.Match
import Agda.TypeChecking.Coverage.SplitTree
@@ -48,7 +60,8 @@ import Agda.TypeChecking.Irrelevance
import Agda.Interaction.Options
-import Agda.Utils.Functor (for, ($>))
+import Agda.Utils.Either
+import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
@@ -56,16 +69,37 @@ import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
data SplitClause = SClause
- { scTel :: Telescope -- ^ Type of variables in @scPats at .
- , scPerm :: Permutation -- ^ How to get from the variables in the patterns to the telescope.
- , scPats :: [I.NamedArg Pattern] -- ^ The patterns leading to the currently considered branch of the split tree.
- , scSubst :: Substitution -- ^ Substitution from @scTel@ to old context.
- , scTarget :: Maybe (I.Arg Type) -- ^ The type of the rhs.
- }
+ { scTel :: Telescope
+ -- ^ Type of variables in @scPats at .
+ , scPerm :: Permutation
+ -- ^ How to get from the variables in the patterns to the telescope.
+ , scPats :: [I.NamedArg Pattern]
+ -- ^ The patterns leading to the currently considered branch of
+ -- the split tree.
+ , scSubst :: Substitution
+ -- ^ 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.
+ , scTarget :: Maybe (I.Arg Type)
+ -- ^ The type of the rhs, living in context 'scTel'.
+ -- This invariant is broken before calls to 'fixTarget';
+ -- there, 'scTarget' lives in the old context.
+ -- 'fixTarget' moves 'scTarget' to the new context by applying
+ -- substitution 'scSubst'.
+ }
-- | A @Covering@ is the result of splitting a 'SplitClause'.
data Covering = Covering
@@ -90,29 +124,6 @@ clauseToSplitClause cl = SClause
type CoverM = ExceptionT SplitError TCM
-{- UNUSED
-typeOfVar :: Telescope -> Nat -> Dom Type
-typeOfVar tel n
- | n >= len = __IMPOSSIBLE__
- | otherwise = fmap snd -- throw away name, keep Arg Type
- $ ts !! fromIntegral (len - 1 - n)
- where
- len = genericLength ts
- ts = telToList tel
--}
-
--- | Old top-level function for checking pattern coverage.
--- DEPRECATED
-checkCoverage :: QName -> TCM ()
-checkCoverage f = do
- d <- getConstInfo f
- case theDef d of
- Function{ funProjection = Nothing, funClauses = cs@(_:_) } -> do
- coverageCheck f (defType d) cs
- return ()
- Function{ funProjection = Just _ } -> __IMPOSSIBLE__
- _ -> __IMPOSSIBLE__
-
-- | Top-level function for checking pattern coverage.
coverageCheck :: QName -> Type -> [Clause] -> TCM SplitTree
coverageCheck f t cs = do
@@ -168,7 +179,6 @@ cover f cs sc@(SClause tel perm ps _ target) = do
reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i
-- Check if any earlier clauses could match with appropriate literals
let is = [ j | (j, c) <- zip [0..i-1] cs, matchLits c ups perm ]
- -- OLD: let is = [ j | (j, c) <- zip [0..] (genericTake i cs), matchLits c ps perm ]
reportSLn "tc.cover.cover" 10 $ "literal matches: " ++ show is
return (SplittingDone (size tel), Set.fromList (i : is), [])
No -> do
@@ -182,46 +192,14 @@ cover f cs sc@(SClause tel perm ps _ target) = do
let done = return (SplittingDone (size tel), Set.empty, [ps])
caseMaybeM (splitResult f sc) done $ \ (Covering n scs) -> do
(projs, (trees, useds, psss)) <- mapSnd unzip3 . unzip <$> do
- forM scs $ \ (proj, sc') -> (proj,) <$> do cover f cs =<< fixTarget sc'
- -- OR: mapM (traverseF $ cover f cs <=< fixTarget) scs
+ mapM (traverseF $ cover f cs <=< (snd <.> fixTarget)) scs
+ -- OR:
+ -- forM scs $ \ (proj, sc') -> (proj,) <$> do
+ -- cover f cs =<< do
+ -- snd <$> fixTarget sc'
let tree = SplitAt n $ zip projs trees
return (tree, Set.unions useds, concat psss)
- -- caseMaybe target done $ \ t -> do
- -- isR <- addCtxTel tel $ isRecordType $ unArg t
- -- case isR of
- -- Just (_r, vs, Record{ recFields = fs }) -> do
- -- reportSDoc "tc.cover" 20 $ sep
- -- [ text $ "we are of record type _r = " ++ show _r
- -- , text "applied to parameters vs = " <+> (addCtxTel tel $ prettyTCM vs)
- -- , text $ "and have fields fs = " ++ show fs
- -- ]
- -- fvs <- freeVarsToApply f
- -- let es = patternsToElims perm ps
- -- let self = defaultArg $ Def f (map Apply fvs) `applyE` es
- -- pargs = vs ++ [self]
- -- reportSDoc "tc.cover" 20 $ sep
- -- [ text "we are self = " <+> (addCtxTel tel $ prettyTCM $ unArg self)
- -- ]
- -- (projs, (trees, useds, psss)) <- mapSnd unzip3 . unzip <$> do
- -- forM fs $ \ proj -> do
- -- -- compute the new target
- -- dType <- defType <$> do getConstInfo $ unArg proj -- WRONG: typeOfConst $ unArg proj
- -- let -- type of projection instantiated at self
- -- target' = Just $ proj $> dType `apply` pargs
- -- sc' = sc { scPats = scPats sc ++ [fmap (Named Nothing . ProjP) proj]
- -- , scTarget = target'
- -- }
- -- (unArg proj,) <$> do cover f cs =<< fixTarget sc'
- -- let -- WRONG: -- n = length ps -- past the last argument, is pos. of proj pat.
- -- -- n = size tel -- past the last variable, is pos. of proj pat. DURING SPLITTING
- -- n = permRange perm -- Andreas & James, 2013-11-19 includes the dot patterns!
- -- -- See test/succeed/CopatternsAndDotPatterns.agda for a case with dot patterns
- -- -- and copatterns which fails for @n = size tel@ with a broken case tree.
- -- tree = SplitAt n $ zip projs trees
- -- return (tree, Set.unions useds, concat psss)
- -- _ -> done
-
-- case: split on variable
Block bs -> do
reportSLn "tc.cover.strategy" 20 $ "blocking vars = " ++ show bs
@@ -255,7 +233,7 @@ splitStrategy bs tel = return $ updateLast clearBlockingVarCons xs
-- Otherwise, we will not get a nice error message.
where
xs = bs
-{-
+{- KEEP!
-- Andreas, 2012-10-13
-- The following split strategy which prefers all-constructor columns
-- fails on test/fail/CoverStrategy
@@ -290,32 +268,57 @@ isDatatype ind at = do
| otherwise -> do
let (ps, is) = genericSplitAt np args
return (d, ps, is, cs)
- Record{recPars = np, recConHead = con} ->
- return (d, args, [], [conName con])
+ Record{recPars = np, recConHead = con, recInduction = i}
+ | i == Just CoInductive && ind /= CoInductive ->
+ throw CoinductiveDatatype
+ | otherwise ->
+ return (d, args, [], [conName con])
_ -> throw NotADatatype
_ -> throw NotADatatype
--- | update the target type, add more patterns to split clause
--- if target becomes a function type.
-fixTarget :: SplitClause -> TCM SplitClause
-fixTarget sc at SClause{ scSubst = sigma, scTarget = target } =
- caseMaybe target (return sc) $ \ a -> do
- reportSDoc "tc.cover.target" 20 $
- text "target type before substitution: " <+> prettyTCM a
+-- | Update the target type, add more patterns to split clause
+-- if target becomes a function type.
+-- Returns @True@ if new patterns were added.
+fixTarget :: SplitClause -> TCM (Bool, SplitClause)
+fixTarget sc at SClause{ scTel = sctel, scPerm = perm, scPats = ps, scSubst = sigma, scTarget = target } =
+ caseMaybe target (return (False, sc)) $ \ a -> do
+ reportSDoc "tc.cover.target" 20 $ sep
+ [ text "split clause telescope: " <+> prettyTCM sctel
+ , text "old permutation : " <+> prettyTCM perm
+ , text "old patterns : " <+> sep (map (prettyTCM . namedArg) ps)
+ ]
+ reportSDoc "tc.cover.target" 30 $ sep
+ [ text "target type before substitution (variables may be wrong): " <+> do
+ addContext sctel $ prettyTCM a
+ ]
TelV tel b <- telView $ applySubst sigma $ unArg a
- reportSDoc "tc.cover.target" 10 $
- text "telescope (after substitution): " <+> prettyTCM tel
- let n = size tel
- lgamma = telToList tel
- xs = for lgamma $ \ (Common.Dom ai (x, _)) -> Common.Arg ai $ namedVarP "_"
- if (n == 0) then return sc { scTarget = Just $ a $> b }
- else return $ SClause
- { scTel = telFromList $ telToList (scTel sc) ++ lgamma
- , scPerm = liftP n $ scPerm sc
- , scPats = scPats sc ++ xs
- , scSubst = liftS n $ sigma
- , scTarget = Just $ a $> b
- }
+ reportSDoc "tc.cover.target" 10 $ sep
+ [ text "target type telescope (after substitution): " <+> do
+ addContext sctel $ prettyTCM tel
+ , text "target type core (after substitution): " <+> do
+ addContext sctel $ addContext tel $ prettyTCM b
+ ]
+ let n = size tel
+ lgamma = telToList tel
+ xs = for lgamma $ \ (Common.Dom ai (x, _)) -> Common.Arg ai $ namedVarP "_"
+ -- Compute new split clause
+ sctel' = telFromList $ telToList (raise n sctel) ++ lgamma
+ perm' = liftP n $ scPerm sc
+ -- Dot patterns in @ps@ need to be raised! (Issue 1298)
+ ps' = raise n ps ++ xs
+ newTarget = Just $ a $> b
+ sc' = SClause
+ { scTel = sctel'
+ , scPerm = perm'
+ , scPats = ps'
+ , scSubst = liftS n $ sigma
+ , scTarget = newTarget
+ }
+ reportSDoc "tc.cover.target" 20 $ sep
+ [ text "new split clause"
+ , prettyTCM sc'
+ ]
+ return $ if n == 0 then (False, sc { scTarget = newTarget }) else (True, sc')
-- | @computeNeighbourhood delta1 delta2 perm d pars ixs hix hps con@
--
@@ -513,6 +516,8 @@ splitClauseWithAbsurd :: Clause -> Nat -> TCM (Either SplitError (Either SplitCl
splitClauseWithAbsurd c x = split' Inductive (clauseToSplitClause c) (BlockingVar x Nothing)
-- | Entry point from @TypeChecking.Empty@ and @Interaction.BasicOps at .
+-- @splitLast CoInductive@ is used in the @refine@ tactics.
+
splitLast :: Induction -> Telescope -> [I.NamedArg Pattern] -> TCM (Either SplitError Covering)
splitLast ind tel ps = split ind sc (BlockingVar 0 Nothing)
where sc = SClause tel (idP $ size tel) ps __IMPOSSIBLE__ Nothing
@@ -539,7 +544,7 @@ split ind sc x = fmap (blendInAbsurdClause (splitDbIndexToLevel sc x)) <$>
split' ind sc x
where
blendInAbsurdClause :: Nat -> Either SplitClause Covering -> Covering
- blendInAbsurdClause n = either (const $ Covering n []) id
+ blendInAbsurdClause n = fromRight (const $ Covering n [])
splitDbIndexToLevel :: SplitClause -> BlockingVar -> Nat
splitDbIndexToLevel sc at SClause{ scTel = tel, scPerm = perm } x =
@@ -548,6 +553,7 @@ split ind sc x = fmap (blendInAbsurdClause (splitDbIndexToLevel sc x)) <$>
-- | Convert a de Bruijn index relative to a telescope to a de Buijn level.
-- The result should be the argument (counted from left, starting with 0)
-- to split at (dot patterns included!).
+dbIndexToLevel :: Telescope -> Permutation -> Int -> Nat
dbIndexToLevel tel perm x = if n < 0 then __IMPOSSIBLE__ else n
where n = if k < 0 then __IMPOSSIBLE__ else permute perm [0..] !! k
k = size tel - x - 1
@@ -599,15 +605,13 @@ split' ind sc@(SClause tel perm ps _ target) (BlockingVar x mcons) = liftTCM $ r
-- cons = constructors of this datatype
(d, pars, ixs, cons) <- inContextOfT $ isDatatype ind t
- --liftTCM $ whenM (optWithoutK <$> pragmaOptions) $
- -- inContextOfT $ Split.wellFormedIndices (unDom t)
-
-- Compute the neighbourhoods for the constructors
ns <- catMaybes <$> do
forM cons $ \ con ->
fmap (con,) <$> do
- Trav.mapM (\sc -> lift $ fixTarget $ sc { scTarget = target }) =<< do
- computeNeighbourhood delta1 n delta2 perm d pars ixs hix hps con
+ msc <- computeNeighbourhood delta1 n delta2 perm d pars ixs hix hps con
+ Trav.forM msc $ \ sc -> lift $ snd <$> fixTarget sc{ scTarget = target }
+
case ns of
[] -> do
let absurd = VarP "()"
@@ -644,6 +648,7 @@ split' ind sc@(SClause tel perm ps _ target) (BlockingVar x mcons) = liftTCM $ r
_ -> return $ Right $ Covering xDBLevel ns
where
+ xDBLevel :: Nat
xDBLevel = dbIndexToLevel tel perm x
inContextOfT :: MonadTCM tcm => tcm a -> tcm a
@@ -716,7 +721,28 @@ splitResult f sc@(SClause tel perm ps _ target) = do
let -- type of projection instantiated at self
target' = Just $ proj $> dType `apply` pargs
sc' = sc { scPats = scPats sc ++ [fmap (Named Nothing . ProjP) proj]
+ , scSubst = idS
, scTarget = target'
}
return (unArg proj, sc')
_ -> done
+
+-- * Boring instances
+
+-- | For debugging only.
+instance PrettyTCM SplitClause where
+ prettyTCM (SClause tel perm pats sigma target) = sep
+ [ text "SplitClause"
+ , nest 2 $ vcat
+ [ text "tel = " <+> prettyTCM tel
+ , text "perm = " <+> prettyTCM perm
+ , text "pats = " <+> sep (map (prettyTCM . namedArg) pats)
+ , text "subst = " <+> (text . show) sigma
+ , text "target = " <+> do
+ caseMaybe target empty $ \ t -> do
+ addContext tel $ prettyTCM t
+ , text "subst target = " <+> do
+ caseMaybe target empty $ \ t -> do
+ addContext tel $ prettyTCM $ applySubst sigma t
+ ]
+ ]
diff --git a/src/full/Agda/TypeChecking/Coverage/Match.hs b/src/full/Agda/TypeChecking/Coverage/Match.hs
index e916a95..d67b442 100644
--- a/src/full/Agda/TypeChecking/Coverage/Match.hs
+++ b/src/full/Agda/TypeChecking/Coverage/Match.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternGuards #-}
@@ -22,7 +22,7 @@ import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.List
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{-| Given
@@ -78,7 +78,7 @@ data MPat
buildMPatterns :: Permutation -> [Arg Pattern] -> [Arg MPat]
buildMPatterns perm ps = evalState (mapM (traverse build) ps) xs
where
- xs = permute (invertP perm) $ downFrom (size perm)
+ xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm)
tick = do x : xs <- get; put xs; return x
build (VarP _) = VarMP <$> tick
diff --git a/src/full/Agda/TypeChecking/Coverage/SplitTree.hs b/src/full/Agda/TypeChecking/Coverage/SplitTree.hs
index 670e3fa..0c0bf04 100644
--- a/src/full/Agda/TypeChecking/Coverage/SplitTree.hs
+++ b/src/full/Agda/TypeChecking/Coverage/SplitTree.hs
@@ -20,7 +20,7 @@ import Agda.Syntax.Abstract.Name
import Agda.Utils.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
type SplitTree = SplitTree' QName
@@ -93,4 +93,5 @@ instance Arbitrary CName where
arbitrary = CName <$> elements
[ "zero", "suc", "nil", "cons", "left", "right", "just", "nothing" ]
+testSplitTreePrinting :: IO ()
testSplitTreePrinting = sample (arbitrary :: Gen (SplitTree' CName))
diff --git a/src/full/Agda/TypeChecking/Datatypes.hs b/src/full/Agda/TypeChecking/Datatypes.hs
index 75bcd20..ca1d986 100644
--- a/src/full/Agda/TypeChecking/Datatypes.hs
+++ b/src/full/Agda/TypeChecking/Datatypes.hs
@@ -17,7 +17,7 @@ import Agda.TypeChecking.Substitute
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -126,10 +126,12 @@ isDataOrRecordType d = do
Record{} -> return $ Just IsRecord
_ -> return $ Nothing
+-- | Precodition: 'Term' is 'reduce'd.
isDataOrRecord :: Term -> TCM (Maybe QName)
-isDataOrRecord (Def d _) = fmap (const d) <$> isDataOrRecordType d
-isDataOrRecord (Shared p) = isDataOrRecord (derefPtr p)
-isDataOrRecord _ = return Nothing
+isDataOrRecord v = do
+ case ignoreSharing v of
+ Def d _ -> fmap (const d) <$> isDataOrRecordType d
+ _ -> return Nothing
getNumberOfParameters :: QName -> TCM (Maybe Nat)
getNumberOfParameters d = do
diff --git a/src/full/Agda/TypeChecking/DisplayForm.hs b/src/full/Agda/TypeChecking/DisplayForm.hs
index 7b774f6..a61e820 100644
--- a/src/full/Agda/TypeChecking/DisplayForm.hs
+++ b/src/full/Agda/TypeChecking/DisplayForm.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.DisplayForm where
import Control.Applicative
-import Control.Monad.Error
+import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Traversable (traverse)
@@ -20,7 +20,7 @@ import Agda.TypeChecking.Level
import Agda.Utils.List
import Agda.Utils.Maybe
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Find a matching display form for @q vs at .
@@ -38,7 +38,7 @@ displayForm q vs = do
"displayForm: context = " ++ show n ++
", dfs = " ++ show (map openThingCtxIds odfs)
-- Use only the display forms that can be opened in the current context.
- dfs <- catMaybes <$> mapM tryOpen odfs
+ dfs <- catMaybes <$> mapM tryOpen odfs
scope <- getScope
-- Keep the display forms that match the application @c vs at .
ms <- do
@@ -54,7 +54,7 @@ displayForm q vs = do
, "result : " ++ show (foldr (const . Just) Nothing ms)
]
-- Return the first display form that matches.
- return $ mhead ms
+ return $ headMaybe ms
-- Andreas, 2014-06-11: The following error swallowing
-- is potentially harmful, making debugging harder.
@@ -71,7 +71,7 @@ displayForm q vs = do
-- hd (DTerm (Con x _)) = Just $ conName x
-- hd (DTerm (Shared p)) = hd (DTerm $ derefPtr p)
-- hd (DWithApp d _ _) = hd d
- -- hd _ = Nothing
+ -- hd _ = Nothing
-- | Match a 'DisplayForm' @q ps = v@ against @q vs at .
-- Return the 'DisplayTerm' @v[us]@ if the match was successful,
@@ -80,10 +80,9 @@ matchDisplayForm :: DisplayForm -> Args -> MaybeT TCM DisplayTerm
matchDisplayForm (Display _ ps v) vs
| length ps > length vs = mzero
| otherwise = do
+ let (vs0, vs1) = splitAt (length ps) vs
us <- match ps $ raise 1 $ map unArg vs0
return $ applySubst (parallelS $ reverse us) v `apply` vs1
- where
- (vs0, vs1) = splitAt (length ps) vs
-- | Class @Match@ for matching a term @p@ in the role of a pattern
-- against a term @v at .
@@ -118,7 +117,7 @@ instance Match a => Match (Elim' a) where
instance Match Term where
match p v = case (ignoreSharing p, ignoreSharing v) of
- (Var 0 [], v) -> return [subst __IMPOSSIBLE__ v]
+ (Var 0 [], v) -> return [strengthen __IMPOSSIBLE__ v]
(Var i ps, Var j vs) | i == j -> match ps vs
(Def c ps, Def d vs) | c == d -> match ps vs
(Con c ps, Con d vs) | c == d -> match ps vs
diff --git a/src/full/Agda/TypeChecking/DropArgs.hs b/src/full/Agda/TypeChecking/DropArgs.hs
index ead5577..b855f8c 100644
--- a/src/full/Agda/TypeChecking/DropArgs.hs
+++ b/src/full/Agda/TypeChecking/DropArgs.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.DropArgs where
@@ -13,7 +13,7 @@ import Agda.TypeChecking.CompiledClause
import Agda.Utils.Permutation
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
diff --git a/src/full/Agda/TypeChecking/Errors.hs b/src/full/Agda/TypeChecking/Errors.hs
index 62a03e9..cdff5ff 100644
--- a/src/full/Agda/TypeChecking/Errors.hs
+++ b/src/full/Agda/TypeChecking/Errors.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.Errors
@@ -14,10 +14,9 @@ module Agda.TypeChecking.Errors
import Prelude hiding (null)
import Control.Monad.State
-import Control.Monad.Error
import Data.Function
-import Data.List (nub, sortBy)
+import Data.List (nub, sortBy, intercalate)
import Data.Maybe
import qualified Data.Map as Map (empty)
@@ -41,13 +40,14 @@ import Agda.TypeChecking.Monad.Options
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Reduce (instantiate)
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.FileName
import Agda.Utils.Function
import Agda.Utils.Monad
import Agda.Utils.Null hiding (empty)
import qualified Agda.Utils.Pretty as P
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -61,9 +61,9 @@ prettyError err = liftTCM $ show <$> prettyError' err []
prettyError' :: TCErr -> [TCErr] -> TCM Doc
prettyError' err errs
| length errs > 3 = fsep (
- pwords "total panic: error when printing error from printing error from printing error." ++
- pwords "I give up! Approximations of errors (original error last):" )
- $$ vcat (map (text . tcErrString) errs)
+ pwords "total panic: error when printing error from printing error from printing error." ++
+ pwords "I give up! Approximations of errors (original error last):" )
+ $$ vcat (map (text . tcErrString) errs)
| otherwise = applyUnless (null errs) (text "panic: error when printing error!" $$) $ do
(prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs))
`catchError` \ err' -> prettyError' err' (err:errs)
@@ -76,10 +76,7 @@ prettyError err = liftTCM $ show <$> prettyError' err []
-- Invariant: The fields are never empty at the same time.
data Warnings = Warnings
- { terminationProblems :: Maybe TCErr
- -- ^ Termination checking problems are not reported if
- -- 'optTerminationCheck' is 'False'.
- , unsolvedMetaVariables :: [Range]
+ { unsolvedMetaVariables :: [Range]
-- ^ Meta-variable problems are reported as type errors unless
-- 'optAllowUnsolved' is 'True'.
, unsolvedConstraints :: Constraints
@@ -89,10 +86,10 @@ data Warnings = Warnings
-- | Turns warnings into an error. Even if several errors are possible
-- only one is raised.
warningsToError :: Warnings -> TCM a
-warningsToError (Warnings Nothing [] []) = __IMPOSSIBLE__
-warningsToError (Warnings _ w@(_:_) _) = typeError $ UnsolvedMetas w
-warningsToError (Warnings _ _ w@(_:_)) = typeError $ UnsolvedConstraints w
-warningsToError (Warnings (Just w) _ _) = throwError w
+warningsToError (Warnings [] []) = typeError $ SolvedButOpenHoles
+warningsToError (Warnings w@(_:_) _) = typeError $ UnsolvedMetas w
+warningsToError (Warnings _ w@(_:_)) = typeError $ UnsolvedConstraints w
+
---------------------------------------------------------------------------
-- * Helpers
@@ -120,7 +117,7 @@ tcErrString err = show (getRange err) ++ " " ++ case err of
TypeError _ cl -> errorString $ clValue cl
Exception r s -> show r ++ " " ++ s
IOException r e -> show r ++ " " ++ show e
- PatternErr _ -> "PatternErr"
+ PatternErr{} -> "PatternErr"
{- AbortAssign _ -> "AbortAssign" -- UNUSED -}
errorString :: TypeError -> String
@@ -131,6 +128,8 @@ errorString err = case err of
AmbiguousParseForLHS{} -> "AmbiguousParseForLHS"
-- AmbiguousParseForPatternSynonym{} -> "AmbiguousParseForPatternSynonym"
AmbiguousTopLevelModuleName {} -> "AmbiguousTopLevelModuleName"
+ BadArgumentsToPatternSynonym{} -> "BadArgumentsToPatternSynonym"
+ TooFewArgumentsToPatternSynonym{} -> "TooFewArgumentsToPatternSynonym"
BothWithAndRHS -> "BothWithAndRHS"
BuiltinInParameterisedModule{} -> "BuiltinInParameterisedModule"
BuiltinMustBeConstructor{} -> "BuiltinMustBeConstructor"
@@ -203,12 +202,13 @@ errorString err = case err of
NothingAppliedToInstanceArg{} -> "NothingAppliedToInstanceArg"
OverlappingProjects {} -> "OverlappingProjects"
PatternShadowsConstructor {} -> "PatternShadowsConstructor"
- PatternSynonymArityMismatch {} -> "PatternSynonymArityMismatch"
PropMustBeSingleton -> "PropMustBeSingleton"
RepeatedVariablesInPattern{} -> "RepeatedVariablesInPattern"
SafeFlagPostulate{} -> "SafeFlagPostulate"
SafeFlagPragma{} -> "SafeFlagPragma"
SafeFlagNoTerminationCheck{} -> "SafeFlagNoTerminationCheck"
+ SafeFlagNonTerminating{} -> "SafeFlagNonTerminating"
+ SafeFlagTerminating{} -> "SafeFlagTerminating"
SafeFlagPrimTrustMe{} -> "SafeFlagPrimTrustMe"
ShadowedModule{} -> "ShadowedModule"
ShouldBeASort{} -> "ShouldBeASort"
@@ -238,13 +238,16 @@ errorString err = case err of
-- UnequalTelescopes{} -> "UnequalTelescopes" -- UNUSED
UnequalColors{} -> "UnequalTelescopes"
HeterogeneousEquality{} -> "HeterogeneousEquality"
+ WithOnFreeVariable{} -> "WithOnFreeVariable"
UnexpectedWithPatterns{} -> "UnexpectedWithPatterns"
UninstantiatedDotPattern{} -> "UninstantiatedDotPattern"
UninstantiatedModule{} -> "UninstantiatedModule"
UnreachableClauses{} -> "UnreachableClauses"
UnsolvedConstraints{} -> "UnsolvedConstraints"
UnsolvedMetas{} -> "UnsolvedMetas"
+ SolvedButOpenHoles{} -> "SolvedButOpenHoles"
UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym"
+ UnquoteFailed{} -> "UnquoteFailed"
WithClausePatternMismatch{} -> "WithClausePatternMismatch"
WithoutKError{} -> "WithoutKError"
WrongHidingInApplication{} -> "WrongHidingInApplication"
@@ -262,13 +265,13 @@ instance PrettyTCM TCErr where
-- Andreas, 2014-03-23
-- This use of localState seems ok since we do not collect
-- Benchmark info during printing errors.
- TypeError s e -> localState $ do
- put s
- sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e
- Exception r s -> sayWhere r $ fwords s
- IOException r e -> sayWhere r $ fwords $ show e
- PatternErr _ -> sayWhere err $ panic "uncaught pattern violation"
- {- AbortAssign _ -> sayWhere err $ panic "uncaught aborted assignment" -- UNUSED -}
+ TypeError s e -> localState $ do
+ put s
+ sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e
+ Exception r s -> sayWhere r $ fwords s
+ IOException r e -> sayWhere r $ fwords $ show e
+ PatternErr{} -> sayWhere err $ panic "uncaught pattern violation"
+ {- AbortAssign _ -> sayWhere err $ panic "uncaught aborted assignment" -- UNUSED -}
instance PrettyTCM CallInfo where
prettyTCM c = do
@@ -284,57 +287,57 @@ dropTopLevelModule (QName (MName ns) n) = QName (MName (drop 1 ns)) n
instance PrettyTCM TypeError where
prettyTCM err = do
- case err of
- InternalError s -> panic s
- NotImplemented s -> fwords $ "Not implemented: " ++ s
- NotSupported s -> fwords $ "Not supported: " ++ s
- CompilationError s -> sep [fwords "Compilation error:", text s]
- GenericError s -> fwords s
- GenericDocError d -> return d
- TerminationCheckFailed because ->
+ case err of
+ InternalError s -> panic s
+ NotImplemented s -> fwords $ "Not implemented: " ++ s
+ NotSupported s -> fwords $ "Not supported: " ++ s
+ CompilationError s -> sep [fwords "Compilation error:", text s]
+ GenericError s -> fwords s
+ GenericDocError d -> return d
+ TerminationCheckFailed because ->
fwords "Termination checking failed for the following functions:"
- $$ (nest 2 $
- fsep (punctuate comma (map (text . show . dropTopLevelModule)
- (concatMap termErrFunctions because))))
+ $$ (nest 2 $ fsep $ punctuate comma $
+ map (pretty . dropTopLevelModule) $
+ concatMap termErrFunctions because)
$$ fwords "Problematic calls:"
$$ (nest 2 $ fmap (P.vcat . nub) $
mapM prettyTCM $ sortBy (compare `on` callInfoRange) $
concatMap termErrCalls because)
- PropMustBeSingleton -> fwords
- "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled"
- DataMustEndInSort t -> fsep $
- pwords "The type of a datatype must end in a sort."
- ++ [prettyTCM t] ++ pwords "isn't a sort."
+ PropMustBeSingleton -> fwords
+ "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled"
+ DataMustEndInSort t -> fsep $
+ pwords "The type of a datatype must end in a sort."
+ ++ [prettyTCM t] ++ pwords "isn't a sort."
{- UNUSED:
- DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type."
+ DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type."
-}
- ShouldEndInApplicationOfTheDatatype t -> fsep $
- pwords "The target of a constructor must be the datatype applied to its parameters,"
- ++ [prettyTCM t] ++ pwords "isn't"
- ShouldBeAppliedToTheDatatypeParameters s t -> fsep $
- pwords "The target of the constructor should be" ++ [prettyTCM s] ++
- pwords "instead of" ++ [prettyTCM t]
- ShouldBeApplicationOf t q -> fsep $
- pwords "The pattern constructs an element of" ++ [prettyTCM q] ++
- pwords "which is not the right datatype"
- ShouldBeRecordType t -> fsep $
- pwords "Expected non-abstract record type, found " ++ [prettyTCM t]
- ShouldBeRecordPattern p -> fsep $
- pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]
- NotAProjectionPattern p -> fsep $
- pwords "Not a valid projection for a copattern: " ++ [ prettyA p ]
- DifferentArities ->
- fwords "The number of arguments in the defining equations differ"
- WrongHidingInLHS -> do
- fwords "Unexpected implicit argument"
- WrongHidingInLambda t -> do
- fwords "Found an implicit lambda where an explicit lambda was expected"
- WrongIrrelevanceInLambda t -> do
- fwords "Found an irrelevant lambda where a relevant lambda was expected"
- WrongNamedArgument a -> fsep $
- pwords "Function does not accept argument " ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"
- WrongHidingInApplication t -> do
- fwords "Found an implicit application where an explicit application was expected"
+ ShouldEndInApplicationOfTheDatatype t -> fsep $
+ pwords "The target of a constructor must be the datatype applied to its parameters,"
+ ++ [prettyTCM t] ++ pwords "isn't"
+ ShouldBeAppliedToTheDatatypeParameters s t -> fsep $
+ pwords "The target of the constructor should be" ++ [prettyTCM s] ++
+ pwords "instead of" ++ [prettyTCM t]
+ ShouldBeApplicationOf t q -> fsep $
+ pwords "The pattern constructs an element of" ++ [prettyTCM q] ++
+ pwords "which is not the right datatype"
+ ShouldBeRecordType t -> fsep $
+ pwords "Expected non-abstract record type, found " ++ [prettyTCM t]
+ ShouldBeRecordPattern p -> fsep $
+ pwords "Expected record pattern" -- ", found " ++ [prettyTCM p]
+ NotAProjectionPattern p -> fsep $
+ pwords "Not a valid projection for a copattern: " ++ [ prettyA p ]
+ DifferentArities ->
+ fwords "The number of arguments in the defining equations differ"
+ WrongHidingInLHS -> do
+ fwords "Unexpected implicit argument"
+ WrongHidingInLambda t -> do
+ fwords "Found an implicit lambda where an explicit lambda was expected"
+ WrongIrrelevanceInLambda t -> do
+ fwords "Found an irrelevant lambda where a relevant lambda was expected"
+ WrongNamedArgument a -> fsep $
+ pwords "Function does not accept argument " ++ [prettyTCM a] -- ++ pwords " (wrong argument name)"
+ WrongHidingInApplication t -> do
+ fwords "Found an implicit application where an explicit application was expected"
HidingMismatch h h' -> fwords $
"Expected " ++ verbalize (Indefinite h') ++ " argument, but found " ++
verbalize (Indefinite h) ++ " argument"
@@ -367,7 +370,9 @@ instance PrettyTCM TypeError where
pwords "The constructor" ++ [prettyTCM c] ++ pwords "expects" ++
[text (show expect)] ++ pwords "arguments (including hidden ones), but has been given" ++ [text (show given)] ++ pwords "(including hidden ones)"
CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $
- pwords ("Can't resolve overloaded constructors targeting the same datatype (" ++ show d ++ "):") ++ map (text . show) cs
+ pwords ("Can't resolve overloaded constructors targeting the same datatype ("
+ ++ show (qnameToConcrete d) ++ "):")
+ ++ map pretty cs
DoesNotConstructAnElementOf c t -> fsep $
pwords "The constructor" ++ [prettyTCM c] ++
pwords "does not construct an element of" ++ [prettyTCM t]
@@ -418,24 +423,24 @@ instance PrettyTCM TypeError where
pwords "is not parameterized, but is being applied to arguments"
ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $
pwords "The arguments to " ++ [prettyTCM m] ++ pwords "does not fit the telescope" ++
- [prettyTCM tel]
+ [prettyTCM tel]
ShouldBeEmpty t [] -> fsep $
- [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me"
- ShouldBeEmpty t ps -> fsep (
- [prettyTCM t] ++
+ [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me"
+ ShouldBeEmpty t ps -> fsep (
+ [prettyTCM t] ++
pwords "should be empty, but the following constructor patterns are valid:"
) $$ nest 2 (vcat $ map (showPat 0) ps)
- ShouldBeASort t -> fsep $
- [prettyTCM t] ++ pwords "should be a sort, but it isn't"
- ShouldBePi t -> fsep $
- [prettyTCM t] ++ pwords "should be a function type, but it isn't"
- NotAProperTerm ->
- fwords "Found a malformed term"
- SetOmegaNotValidType ->
- fwords "Setω is not a valid type"
- InvalidType v -> fsep $
- [prettyTCM v] ++ pwords "is not a valid type"
+ ShouldBeASort t -> fsep $
+ [prettyTCM t] ++ pwords "should be a sort, but it isn't"
+ ShouldBePi t -> fsep $
+ [prettyTCM t] ++ pwords "should be a function type, but it isn't"
+ NotAProperTerm ->
+ fwords "Found a malformed term"
+ SetOmegaNotValidType ->
+ fwords "Setω is not a valid type"
+ InvalidType v -> fsep $
+ [prettyTCM v] ++ pwords "is not a valid type"
SplitOnIrrelevant p t -> fsep $
pwords "Cannot pattern match" ++ [prettyA p] ++
pwords "against irrelevant type" ++ [prettyTCM t]
@@ -443,142 +448,146 @@ instance PrettyTCM TypeError where
text "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"
VariableIsIrrelevant x -> fsep $
text "Variable" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here"
- UnequalBecauseOfUniverseConflict cmp s t -> fsep $
- [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ]
- UnequalTerms cmp s t a -> do
+ UnequalBecauseOfUniverseConflict cmp s t -> fsep $
+ [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ]
+ UnequalTerms cmp s t a -> do
(d1, d2, d) <- prettyInEqual s t
- fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d]
+ fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d]
-- UnequalLevel is UNUSED
--- UnequalLevel cmp s t -> fsep $
--- [prettyTCM s, notCmp cmp, prettyTCM t]
+-- UnequalLevel cmp s t -> fsep $
+-- [prettyTCM s, notCmp cmp, prettyTCM t]
-- UnequalTelescopes is UNUSED
--- UnequalTelescopes cmp a b -> fsep $
--- [prettyTCM a, notCmp cmp, prettyTCM b]
- UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b
+-- UnequalTelescopes cmp a b -> fsep $
+-- [prettyTCM a, notCmp cmp, prettyTCM b]
+ UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b
-- fsep $ [prettyTCM a, notCmp cmp, prettyTCM b]
UnequalColors a b -> error "TODO guilhem 4"
- HeterogeneousEquality u a v b -> fsep $
+ HeterogeneousEquality u a v b -> fsep $
pwords "Refuse to solve heterogeneous constraint" ++
[prettyTCM u] ++ pwords ":" ++ [prettyTCM a] ++ pwords "=?=" ++
[prettyTCM v] ++ pwords ":" ++ [prettyTCM b]
- UnequalRelevance cmp a b -> fsep $
- [prettyTCM a, notCmp cmp, prettyTCM b] ++
+ UnequalRelevance cmp a b -> fsep $
+ [prettyTCM a, notCmp cmp, prettyTCM b] ++
-- Andreas 2010-09-21 to reveal Forced annotations, print also uglily
--- [text $ show a, notCmp cmp, text $ show b] ++
- pwords "because one is a relevant function type and the other is an irrelevant function type"
- UnequalHiding a b -> fsep $
- [prettyTCM a, text "!=", prettyTCM b] ++
- pwords "because one is an implicit function type and the other is an explicit function type"
- UnequalSorts s1 s2 -> fsep $
- [prettyTCM s1, text "!=", prettyTCM s2]
- NotLeqSort s1 s2 -> fsep $
- pwords "The type of the constructor does not fit in the sort of the datatype, since"
- ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]
- TooFewFields r xs -> fsep $
- pwords "Missing fields" ++ punctuate comma (map pretty xs) ++
- pwords "in an element of the record" ++ [prettyTCM r]
- TooManyFields r xs -> fsep $
- pwords "The record type" ++ [prettyTCM r] ++
- pwords "does not have the fields" ++ punctuate comma (map pretty xs)
- DuplicateConstructors xs -> fsep $
- pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++
- pwords "in datatype"
- DuplicateFields xs -> fsep $
- pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++
- pwords "in record"
+-- [text $ show a, notCmp cmp, text $ show b] ++
+ pwords "because one is a relevant function type and the other is an irrelevant function type"
+ UnequalHiding a b -> fsep $
+ [prettyTCM a, text "!=", prettyTCM b] ++
+ pwords "because one is an implicit function type and the other is an explicit function type"
+ UnequalSorts s1 s2 -> fsep $
+ [prettyTCM s1, text "!=", prettyTCM s2]
+ NotLeqSort s1 s2 -> fsep $
+ pwords "The type of the constructor does not fit in the sort of the datatype, since"
+ ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2]
+ TooFewFields r xs -> fsep $
+ pwords "Missing fields" ++ punctuate comma (map pretty xs) ++
+ pwords "in an element of the record" ++ [prettyTCM r]
+ TooManyFields r xs -> fsep $
+ pwords "The record type" ++ [prettyTCM r] ++
+ pwords "does not have the fields" ++ punctuate comma (map pretty xs)
+ DuplicateConstructors xs -> fsep $
+ pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++
+ pwords "in datatype"
+ DuplicateFields xs -> fsep $
+ pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++
+ pwords "in record"
+ WithOnFreeVariable e -> fsep $
+ pwords "Cannot `with` on variable " ++ [prettyA e] ++
+ pwords " bound in a module telescope (or patterns of a parent clause)"
UnexpectedWithPatterns ps -> fsep $
pwords "Unexpected with patterns" ++ (punctuate (text " |") $ map prettyA ps)
WithClausePatternMismatch p q -> fsep $
pwords "With clause pattern " ++ [prettyA p] ++
pwords " is not an instance of its parent pattern " ++ [prettyTCM q]
-- TODO: prettier printing for internal patterns
- MetaCannotDependOn m ps i -> fsep $
- pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++ pwords "cannot depend on" ++ [pvar i] ++
- pwords "because it" ++ deps
- where
+ MetaCannotDependOn m ps i -> fsep $
+ pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++ pwords "cannot depend on" ++ [pvar i] ++
+ pwords "because it" ++ deps
+ where
pvar = prettyTCM . I.var
- deps = case map pvar ps of
- [] -> pwords "does not depend on any variables"
- [x] -> pwords "only depends on the variable" ++ [x]
- xs -> pwords "only depends on the variables" ++ punctuate comma xs
+ deps = case map pvar ps of
+ [] -> pwords "does not depend on any variables"
+ [x] -> pwords "only depends on the variable" ++ [x]
+ xs -> pwords "only depends on the variables" ++ punctuate comma xs
- MetaOccursInItself m -> fsep $
- pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []]
+ MetaOccursInItself m -> fsep $
+ pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []]
BuiltinMustBeConstructor s e -> fsep $
[prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [text s]
- NoSuchBuiltinName s -> fsep $
- pwords "There is no built-in thing called" ++ [text s]
- DuplicateBuiltinBinding b x y -> fsep $
- pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++
- pwords "previous binding to" ++ [prettyTCM x]
- NoBindingForBuiltin x -> fsep $
- pwords "No binding for builtin thing" ++ [text x <> comma] ++
- pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'")
- NoSuchPrimitiveFunction x -> fsep $
- pwords "There is no primitive function called" ++ [text x]
- BuiltinInParameterisedModule x -> fwords $
- "The BUILTIN pragma cannot appear inside a bound context " ++
- "(for instance, in a parameterised module or as a local declaration)"
+ NoSuchBuiltinName s -> fsep $
+ pwords "There is no built-in thing called" ++ [text s]
+ DuplicateBuiltinBinding b x y -> fsep $
+ pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++
+ pwords "previous binding to" ++ [prettyTCM x]
+ NoBindingForBuiltin x -> fsep $
+ pwords "No binding for builtin thing" ++ [text x <> comma] ++
+ pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'")
+ NoSuchPrimitiveFunction x -> fsep $
+ pwords "There is no primitive function called" ++ [text x]
+ BuiltinInParameterisedModule x -> fwords $
+ "The BUILTIN pragma cannot appear inside a bound context " ++
+ "(for instance, in a parameterised module or as a local declaration)"
IllegalLetInTelescope tb -> fsep $
-- pwords "The binding" ++
[pretty tb] ++
pwords " is not allowed in a telescope here."
- NoRHSRequiresAbsurdPattern ps -> fwords $
- "The right-hand side can only be omitted if there " ++
- "is an absurd pattern, () or {}, in the left-hand side."
- AbsurdPatternRequiresNoRHS ps -> fwords $
- "The right-hand side must be omitted if there " ++
- "is an absurd pattern, () or {}, in the left-hand side."
- LocalVsImportedModuleClash m -> fsep $
- pwords "The module" ++ [text $ show m] ++
- pwords "can refer to either a local module or an imported module"
- UnsolvedMetas rs ->
- fsep ( pwords "Unsolved metas at the following locations:" )
- $$ nest 2 (vcat $ map prettyTCM rs)
- UnsolvedConstraints cs ->
- fsep ( pwords "Failed to solve the following constraints:" )
- $$ nest 2 (vcat $ map prettyConstraint cs)
+ NoRHSRequiresAbsurdPattern ps -> fwords $
+ "The right-hand side can only be omitted if there " ++
+ "is an absurd pattern, () or {}, in the left-hand side."
+ AbsurdPatternRequiresNoRHS ps -> fwords $
+ "The right-hand side must be omitted if there " ++
+ "is an absurd pattern, () or {}, in the left-hand side."
+ LocalVsImportedModuleClash m -> fsep $
+ pwords "The module" ++ [text $ show m] ++
+ pwords "can refer to either a local module or an imported module"
+ SolvedButOpenHoles -> text "Module cannot be imported since it has open interaction points"
+ UnsolvedMetas rs ->
+ fsep ( pwords "Unsolved metas at the following locations:" )
+ $$ nest 2 (vcat $ map prettyTCM rs)
+ UnsolvedConstraints cs ->
+ fsep ( pwords "Failed to solve the following constraints:" )
+ $$ nest 2 (vcat $ map prettyConstraint cs)
where prettyConstraint :: ProblemConstraint -> TCM Doc
prettyConstraint c = f (prettyTCM c)
where
r = getRange c
f d = if null (show r) then d else d $$ nest 4 (text "[ at" <+> prettyTCM r <+> text "]")
- CyclicModuleDependency ms ->
- fsep (pwords "cyclic module dependency:")
- $$ nest 2 (vcat $ map pretty ms)
- FileNotFound x files ->
- fsep ( pwords "Failed to find source of module" ++ [pretty x] ++
- pwords "in any of the following locations:"
- ) $$ nest 2 (vcat $ map (text . filePath) files)
+ CyclicModuleDependency ms ->
+ fsep (pwords "cyclic module dependency:")
+ $$ nest 2 (vcat $ map pretty ms)
+ FileNotFound x files ->
+ fsep ( pwords "Failed to find source of module" ++ [pretty x] ++
+ pwords "in any of the following locations:"
+ ) $$ nest 2 (vcat $ map (text . filePath) files)
OverlappingProjects f m1 m2 ->
- fsep ( pwords "The file" ++ [text (filePath f)] ++
+ fsep ( pwords "The file" ++ [text (filePath f)] ++
pwords "can be accessed via several project roots. Both" ++
[pretty m1] ++ pwords "and" ++ [pretty m2] ++
pwords "point to this file."
)
- AmbiguousTopLevelModuleName x files ->
- fsep ( pwords "Ambiguous module name. The module name" ++
+ AmbiguousTopLevelModuleName x files ->
+ fsep ( pwords "Ambiguous module name. The module name" ++
[pretty x] ++
- pwords "could refer to any of the following files:"
- ) $$ nest 2 (vcat $ map (text . filePath) files)
- ClashingFileNamesFor x files ->
- fsep ( pwords "Multiple possible sources for module" ++ [text $ show x] ++
- pwords "found:"
- ) $$ nest 2 (vcat $ map (text . filePath) files)
+ pwords "could refer to any of the following files:"
+ ) $$ nest 2 (vcat $ map (text . filePath) files)
+ ClashingFileNamesFor x files ->
+ fsep ( pwords "Multiple possible sources for module" ++ [text $ show x] ++
+ pwords "found:"
+ ) $$ nest 2 (vcat $ map (text . filePath) files)
ModuleDefinedInOtherFile mod file file' -> fsep $
pwords "You tried to load" ++ [text (filePath file)] ++
pwords "which defines the module" ++ [pretty mod <> text "."] ++
pwords "However, according to the include path this module should" ++
pwords "be defined in" ++ [text (filePath file') <> text "."]
- ModuleNameDoesntMatchFileName given files ->
+ ModuleNameDoesntMatchFileName given files ->
fsep (pwords "The name of the top level module does not match the file name. The module" ++
[ pretty given ] ++ pwords "should be defined in one of the following files:")
- $$ nest 2 (vcat $ map (text . filePath) files)
+ $$ nest 2 (vcat $ map (text . filePath) files)
BothWithAndRHS -> fsep $
pwords "Unexpected right hand side"
- NotInScope xs ->
- fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map name xs)
- where
+ NotInScope xs ->
+ fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map name xs)
+ where
name x = fsep [ pretty x, text "at" <+> prettyTCM (getRange x), suggestion (show x) ]
suggestion s
| elem ':' s = parens $ text "did you forget space around the ':'?"
@@ -586,72 +595,72 @@ instance PrettyTCM TypeError where
| otherwise = empty
where
two = zipWith (\a b -> [a,b]) s (tail s)
- NoSuchModule x -> fsep $
- pwords "No such module" ++ [pretty x]
- AmbiguousName x ys -> vcat
- [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++
- pwords "It could refer to any one of"
- , nest 2 $ vcat $ map nameWithBinding ys
+ NoSuchModule x -> fsep $
+ pwords "No such module" ++ [pretty x]
+ AmbiguousName x ys -> vcat
+ [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++
+ pwords "It could refer to any one of"
+ , nest 2 $ vcat $ map nameWithBinding ys
, fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"
- ]
- AmbiguousModule x ys -> vcat
- [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> text "."] ++
- pwords "It could refer to any one of"
- , nest 2 $ vcat $ map help ys
+ ]
+ AmbiguousModule x ys -> vcat
+ [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> text "."] ++
+ pwords "It could refer to any one of"
+ , nest 2 $ vcat $ map help ys
, fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"
- ]
+ ]
where
help :: ModuleName -> TCM Doc
help m = do
b <- isDatatypeModule m
sep [prettyTCM m, if b then text "(datatype module)" else empty]
- UninstantiatedModule x -> fsep (
- pwords "Cannot access the contents of the parameterised module" ++ [pretty x <> text "."] ++
- pwords "To do this the module first has to be instantiated. For instance:"
- ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ])
- ClashingDefinition x y -> fsep $
- pwords "Multiple definitions of" ++ [pretty x <> text "."] ++
- pwords "Previous definition at" ++ [prettyTCM $ nameBindingSite $ qnameName y]
- ClashingModule m1 m2 -> fsep $
- pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2] ++ pwords "clash."
- ClashingImport x y -> fsep $
- pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y]
- ClashingModuleImport x y -> fsep $
- pwords "Module import clash between" ++ [pretty x, text "and", prettyTCM y]
- PatternShadowsConstructor x c -> fsep $
+ UninstantiatedModule x -> fsep (
+ pwords "Cannot access the contents of the parameterised module" ++ [pretty x <> text "."] ++
+ pwords "To do this the module first has to be instantiated. For instance:"
+ ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ])
+ ClashingDefinition x y -> fsep $
+ pwords "Multiple definitions of" ++ [pretty x <> text "."] ++
+ pwords "Previous definition at" ++ [prettyTCM $ nameBindingSite $ qnameName y]
+ ClashingModule m1 m2 -> fsep $
+ pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2] ++ pwords "clash."
+ ClashingImport x y -> fsep $
+ pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y]
+ ClashingModuleImport x y -> fsep $
+ pwords "Module import clash between" ++ [pretty x, text "and", prettyTCM y]
+ PatternShadowsConstructor x c -> fsep $
pwords "The pattern variable" ++ [prettyTCM x] ++
pwords "has the same name as the constructor" ++ [prettyTCM c]
DuplicateImports m xs -> fsep $
pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++
punctuate comma (map pretty xs)
- ModuleDoesntExport m xs -> fsep $
- pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++
- punctuate comma (map pretty xs)
- NotAModuleExpr e -> fsep $
- pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++
- pwords "where M is a module name. The expression" ++ [pretty e, text "doesn't."]
+ ModuleDoesntExport m xs -> fsep $
+ pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++
+ punctuate comma (map pretty xs)
+ NotAModuleExpr e -> fsep $
+ pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++
+ pwords "where M is a module name. The expression" ++ [pretty e, text "doesn't."]
FieldOutsideRecord -> fsep $
pwords "Field appearing outside record declaration."
InvalidPattern p -> fsep $
pretty p : pwords "is not a valid pattern"
- RepeatedVariablesInPattern xs -> fsep $
- pwords "Repeated variables in left hand side:" ++ map pretty xs
- NotAnExpression e -> fsep $
- [pretty e] ++ pwords "is not a valid expression."
- NotAValidLetBinding nd -> fwords $
- "Not a valid let-declaration"
- NothingAppliedToHiddenArg e -> fsep $
- [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
- pwords "a function expecting an implicit argument."
- NothingAppliedToInstanceArg e -> fsep $
- [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
- pwords "a function expecting an instance argument."
- NoParseForApplication es -> fsep $
- pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es]
- AmbiguousParseForApplication es es' -> fsep (
- pwords "Don't know how to parse" ++ [pretty_es <> (text ".")] ++
- pwords "Could mean any one of:"
- ) $$ nest 2 (vcat $ map pretty' es')
+ RepeatedVariablesInPattern xs -> fsep $
+ pwords "Repeated variables in pattern:" ++ map pretty xs
+ NotAnExpression e -> fsep $
+ [pretty e] ++ pwords "is not a valid expression."
+ NotAValidLetBinding nd -> fwords $
+ "Not a valid let-declaration"
+ NothingAppliedToHiddenArg e -> fsep $
+ [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
+ pwords "a function expecting an implicit argument."
+ NothingAppliedToInstanceArg e -> fsep $
+ [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++
+ pwords "a function expecting an instance argument."
+ NoParseForApplication es -> fsep $
+ pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es]
+ AmbiguousParseForApplication es es' -> fsep (
+ pwords "Don't know how to parse" ++ [pretty_es <> (text ".")] ++
+ pwords "Could mean any one of:"
+ ) $$ nest 2 (vcat $ map pretty' es')
where
pretty_es :: TCM Doc
pretty_es = pretty $ C.RawApp noRange es
@@ -674,22 +683,24 @@ instance PrettyTCM TypeError where
fromOrdinary :: C.OpApp e -> e
fromOrdinary (C.Ordinary e) = e
fromOrdinary _ = __IMPOSSIBLE__
+ BadArgumentsToPatternSynonym x -> fsep $
+ pwords "Bad arguments to pattern synonym " ++ [prettyTCM x]
+ TooFewArgumentsToPatternSynonym x -> fsep $
+ pwords "Too few arguments to pattern synonym " ++ [prettyTCM x]
UnusedVariableInPatternSynonym -> fsep $
pwords "Unused variable in pattern synonym."
- PatternSynonymArityMismatch x -> fsep $
- pwords "Arity mismatch when using pattern synonym" ++ [prettyTCM x]
- NoParseForLHS IsLHS p -> fsep $
- pwords "Could not parse the left-hand side" ++ [pretty p]
- NoParseForLHS IsPatSyn p -> fsep $
- pwords "Could not parse the pattern synonym" ++ [pretty p]
+ NoParseForLHS IsLHS p -> fsep $
+ pwords "Could not parse the left-hand side" ++ [pretty p]
+ NoParseForLHS IsPatSyn p -> fsep $
+ pwords "Could not parse the pattern synonym" ++ [pretty p]
{- UNUSED
- NoParseForPatternSynonym p -> fsep $
- pwords "Could not parse the pattern synonym" ++ [pretty p]
+ NoParseForPatternSynonym p -> fsep $
+ pwords "Could not parse the pattern synonym" ++ [pretty p]
-}
- AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep (
- pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++
- pwords "Could mean any one of:"
- ) $$ nest 2 (vcat $ map pretty' ps)
+ AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep (
+ pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++
+ pwords "Could mean any one of:"
+ ) $$ nest 2 (vcat $ map pretty' ps)
where
pretty_p :: TCM Doc
pretty_p = pretty p
@@ -711,14 +722,14 @@ instance PrettyTCM TypeError where
unambiguousP (C.OpAppP r op xs) = foldl C.AppP (C.IdentP op) xs
unambiguousP e = e
{- UNUSED
- AmbiguousParseForPatternSynonym p ps -> fsep (
- pwords "Don't know how to parse" ++ [pretty p <> text "."] ++
- pwords "Could mean any one of:"
- ) $$ nest 2 (vcat $ map pretty ps)
+ AmbiguousParseForPatternSynonym p ps -> fsep (
+ pwords "Don't know how to parse" ++ [pretty p <> text "."] ++
+ pwords "Could mean any one of:"
+ ) $$ nest 2 (vcat $ map pretty ps)
-}
- IncompletePatternMatching v args -> fsep $
- pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++
- pwords "No match for" ++ map prettyTCM args
+ IncompletePatternMatching v args -> fsep $
+ pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++
+ pwords "No match for" ++ map prettyTCM args
UnreachableClauses f pss -> fsep $
pwords "Unreachable" ++ pwords (plural (length pss) "clause")
where
@@ -747,7 +758,6 @@ instance PrettyTCM TypeError where
pwords "unification problems (inferred index ≟ expected index):"
] ++
zipWith (\c g -> nest 2 $ prettyTCM c <+> text "≟" <+> prettyTCM g) cIxs gIxs)
-
CoverageCantSplitIrrelevantType a -> fsep $
pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM a]
@@ -759,34 +769,56 @@ instance PrettyTCM TypeError where
WithoutKError a u v -> fsep $
pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++ pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++ pwords "because K has been disabled."
- NotStrictlyPositive d ocs -> fsep $
- pwords "The datatype" ++ [prettyTCM d] ++ pwords "is not strictly positive, because"
- ++ prettyOcc "it" ocs
- where
- prettyOcc _ [] = []
- prettyOcc it (OccCon d c r : ocs) = concat
- [ pwords it, pwords "occurs", prettyR r
- , pwords "in the constructor", [prettyTCM c], pwords "of"
- , [prettyTCM d <> com ocs], prettyOcc "which" ocs
- ]
- prettyOcc it (OccClause f n r : ocs) = concat
- [ pwords it, pwords "occurs", prettyR r
- , pwords "in the", [th n], pwords "clause of"
- , [prettyTCM f <> com ocs], prettyOcc "which" ocs
- ]
- prettyR NonPositively = pwords "negatively"
- prettyR (ArgumentTo i q) =
- pwords "as the" ++ [th i] ++
- pwords "argument to" ++ [prettyTCM q]
- th 0 = text "first"
- th 1 = text "second"
- th 2 = text "third"
- th n = text (show $ n - 1) <> text "th"
-
- com [] = empty
- com (_:_) = comma
+ NotStrictlyPositive d ocs -> fsep $
+ pwords "The datatype" ++ [prettyTCM d] ++ pwords "is not strictly positive, because"
+ ++ prettyOcc "it" ocs
+ where
+ prettyOcc _ [] = []
+ prettyOcc it (OccCon d c r : ocs) = concat
+ [ pwords it, pwords "occurs", prettyR r
+ , pwords "in the constructor", [prettyTCM c], pwords "of"
+ , [prettyTCM d <> com ocs], prettyOcc "which" ocs
+ ]
+ prettyOcc it (OccClause f n r : ocs) = concat
+ [ pwords it, pwords "occurs", prettyR r
+ , pwords "in the", [th n], pwords "clause of"
+ , [prettyTCM f <> com ocs], prettyOcc "which" ocs
+ ]
+ prettyR NonPositively = pwords "negatively"
+ prettyR (ArgumentTo i q) =
+ pwords "as the" ++ [th i] ++
+ pwords "argument to" ++ [prettyTCM q]
+ th 0 = text "first"
+ th 1 = text "second"
+ th 2 = text "third"
+ th n = text (show $ n - 1) <> text "th"
+
+ com [] = empty
+ com (_:_) = comma
IFSNoCandidateInScope t -> fsep $
pwords "No variable of type" ++ [prettyTCM t] ++ pwords "was found in scope."
+ UnquoteFailed e -> case e of
+ (BadVisibility msg arg) -> fsep $
+ pwords $ "Unable to unquote the argument. It should be `" ++ msg ++ "'."
+ (ConInsteadOfDef x def con) -> do
+ fsep $ pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") ++ [prettyTCM x]
+ (DefInsteadOfCon x def con) -> do
+ fsep $ pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor") ++ [prettyTCM x]
+ (NotAConstructor kind t) ->
+ fwords "Unable to unquote the term"
+ $$ nest 2 (prettyTCM t)
+ $$ fwords ("of type " ++ kind ++ ". Reason: not a constructor.")
+ (NotALiteral kind t) ->
+ fwords "Unable to unquote the term"
+ $$ nest 2 (prettyTCM t)
+ $$ fwords ("of type " ++ kind ++ ". Reason: not a literal value.")
+ (RhsUsesDottedVar ixs t) ->
+ fwords "Unable to unquote the term"
+ $$ nest 2 (prettyTCM t)
+ $$ fwords "of type Clause. Reason: the right-hand side contains variables that are referring to a dot pattern."
+ $$ fwords ("Offending De Bruijn indices: " ++ intercalate ", " (map show ixs) ++ ".")
+ (BlockedOnMeta m) -> __IMPOSSIBLE__
+ (UnquotePanic err) -> __IMPOSSIBLE__
SafeFlagPostulate e -> fsep $
pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag"
SafeFlagPragma xs ->
@@ -795,6 +827,8 @@ instance PrettyTCM TypeError where
in fsep $ [fwords ("Cannot set OPTION pragma" ++ plural)]
++ map text xs ++ [fwords "with safe flag."]
SafeFlagNoTerminationCheck -> fsep (pwords "Cannot use NO_TERMINATION_CHECK pragma with safe flag.")
+ SafeFlagNonTerminating -> fsep (pwords "Cannot use NON_TERMINATING pragma with safe flag.")
+ SafeFlagTerminating -> fsep (pwords "Cannot use TERMINATING pragma with safe flag.")
SafeFlagPrimTrustMe -> fsep (pwords "Cannot use primTrustMe with safe flag")
NeedOptionCopatterns -> fsep (pwords "Option --copatterns needed to enable destructor patterns")
where
@@ -877,43 +911,43 @@ instance PrettyTCM SplitError where
instance PrettyTCM Call where
prettyTCM c = case c of
- CheckClause t cl _ -> fsep $
- pwords "when checking that the clause"
- ++ [P.prettyA cl] ++ pwords "has type" ++ [prettyTCM t]
- CheckPattern p tel t _ -> addCtxTel tel $ fsep $
- pwords "when checking that the pattern"
- ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]
- CheckLetBinding b _ -> fsep $
- pwords "when checking the let binding" ++ [P.prettyA b]
- InferExpr e _ -> fsep $
- pwords "when inferring the type of" ++ [prettyA e]
- CheckExprCall e t _ -> fsep $
- pwords "when checking that the expression"
- ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t]
- IsTypeCall e s _ -> fsep $
- pwords "when checking that the expression"
- ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s]
- IsType_ e _ -> fsep $
- pwords "when checking that the expression"
- ++ [prettyA e] ++ pwords "is a type"
- CheckArguments r es t0 t1 _ -> fsep $
- pwords "when checking that" ++
- map hPretty es ++ pwords "are valid arguments to a function of type" ++ [prettyTCM t0]
- CheckRecDef _ x ps cs _ ->
- fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
- CheckDataDef _ x ps cs _ ->
- fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
- CheckConstructor d _ _ (A.Axiom _ _ _ c _) _ -> fsep $
- pwords "when checking the constructor" ++ [prettyTCM c] ++
- pwords "in the declaration of" ++ [prettyTCM d]
- CheckConstructor _ _ _ _ _ -> __IMPOSSIBLE__
- CheckFunDef _ f _ _ ->
- fsep $ pwords "when checking the definition of" ++ [prettyTCM f]
- CheckPragma _ p _ ->
- fsep $ pwords "when checking the pragma" ++ [prettyA $ RangeAndPragma noRange p]
- CheckPrimitive _ x e _ -> fsep $
- pwords "when checking that the type of the primitive function" ++
- [prettyTCM x] ++ pwords "is" ++ [prettyA e]
+ CheckClause t cl _ -> fsep $
+ pwords "when checking that the clause"
+ ++ [P.prettyA cl] ++ pwords "has type" ++ [prettyTCM t]
+ CheckPattern p tel t _ -> addCtxTel tel $ fsep $
+ pwords "when checking that the pattern"
+ ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t]
+ CheckLetBinding b _ -> fsep $
+ pwords "when checking the let binding" ++ [P.prettyA b]
+ InferExpr e _ -> fsep $
+ pwords "when inferring the type of" ++ [prettyA e]
+ CheckExprCall e t _ -> fsep $
+ pwords "when checking that the expression"
+ ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t]
+ IsTypeCall e s _ -> fsep $
+ pwords "when checking that the expression"
+ ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s]
+ IsType_ e _ -> fsep $
+ pwords "when checking that the expression"
+ ++ [prettyA e] ++ pwords "is a type"
+ CheckArguments r es t0 t1 _ -> fsep $
+ pwords "when checking that" ++
+ map hPretty es ++ pwords "are valid arguments to a function of type" ++ [prettyTCM t0]
+ CheckRecDef _ x ps cs _ ->
+ fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
+ CheckDataDef _ x ps cs _ ->
+ fsep $ pwords "when checking the definition of" ++ [prettyTCM x]
+ CheckConstructor d _ _ (A.Axiom _ _ _ c _) _ -> fsep $
+ pwords "when checking the constructor" ++ [prettyTCM c] ++
+ pwords "in the declaration of" ++ [prettyTCM d]
+ CheckConstructor _ _ _ _ _ -> __IMPOSSIBLE__
+ CheckFunDef _ f _ _ ->
+ fsep $ pwords "when checking the definition of" ++ [prettyTCM f]
+ CheckPragma _ p _ ->
+ fsep $ pwords "when checking the pragma" ++ [prettyA $ RangeAndPragma noRange p]
+ CheckPrimitive _ x e _ -> fsep $
+ pwords "when checking that the type of the primitive function" ++
+ [prettyTCM x] ++ pwords "is" ++ [prettyA e]
CheckWithFunctionType e _ -> fsep $
pwords "when checking that the type" ++
[prettyA e] ++ pwords "of the generated with function is well-formed"
@@ -922,37 +956,37 @@ instance PrettyTCM Call where
pwords "matches the inferred value" ++ [prettyTCM v]
CheckPatternShadowing c _ -> fsep $
pwords "when checking the clause" ++ [P.prettyA c]
- InferVar x _ ->
- fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
- InferDef _ x _ ->
- fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
+ InferVar x _ ->
+ fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
+ InferDef _ x _ ->
+ fsep $ pwords "when inferring the type of" ++ [prettyTCM x]
CheckIsEmpty r t _ ->
fsep $ pwords "when checking that" ++ [prettyTCM t] ++ pwords "has no constructors"
- ScopeCheckExpr e _ ->
- fsep $ pwords "when scope checking" ++ [pretty e]
- ScopeCheckDeclaration d _ ->
- fwords "when scope checking the declaration" $$
- nest 2 (pretty $ simpleDecl d)
- ScopeCheckLHS x p _ ->
- fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++
- pwords "in the definition of" ++ [pretty x]
+ ScopeCheckExpr e _ ->
+ fsep $ pwords "when scope checking" ++ [pretty e]
+ ScopeCheckDeclaration d _ ->
+ fwords "when scope checking the declaration" $$
+ nest 2 (pretty $ simpleDecl d)
+ ScopeCheckLHS x p _ ->
+ fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++
+ pwords "in the definition of" ++ [pretty x]
NoHighlighting _ -> empty
- SetRange r _ ->
- fsep (pwords "when doing something at") <+> prettyTCM r
+ SetRange r _ ->
+ fsep (pwords "when doing something at") <+> prettyTCM r
CheckSectionApplication _ m1 modapp _ -> fsep $
pwords "when checking the module application" ++
[prettyA $ A.Apply info m1 modapp Map.empty Map.empty]
where
info = A.ModuleInfo noRange noRange Nothing Nothing Nothing
- where
+ where
hPretty :: I.Arg (Named_ Expr) -> TCM Doc
hPretty a = do
info <- reify $ argInfo a
pretty =<< (abstractToConcreteCtx (hiddenArgumentCtx (getHiding a))
$ Common.Arg info $ unArg a)
- simpleDecl = D.notSoNiceDeclaration
+ simpleDecl = D.notSoNiceDeclaration
---------------------------------------------------------------------------
-- * Natural language
diff --git a/src/full/Agda/TypeChecking/EtaContract.hs b/src/full/Agda/TypeChecking/EtaContract.hs
index 684d044..52d77df 100644
--- a/src/full/Agda/TypeChecking/EtaContract.hs
+++ b/src/full/Agda/TypeChecking/EtaContract.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards #-}
-- | Compute eta short normal forms.
module Agda.TypeChecking.EtaContract where
@@ -19,7 +19,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Records
import {-# SOURCE #-} Agda.TypeChecking.Datatypes
import Agda.Utils.Monad
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- TODO: move to Agda.Syntax.Internal.SomeThing
@@ -75,7 +75,7 @@ etaOnce v = case v of
| (isIrrelevant info || isVar0 v)
&& allowed imp info
&& not (freeIn 0 u) ->
- return $ subst __IMPOSSIBLE__ u
+ return $ strengthen __IMPOSSIBLE__ u
_ -> return v
where
isVar0 (Shared p) = __IMPOSSIBLE__ -- isVar0 (derefPtr p)
diff --git a/src/full/Agda/TypeChecking/Forcing.hs b/src/full/Agda/TypeChecking/Forcing.hs
index 2dc84cf..bd9862c 100644
--- a/src/full/Agda/TypeChecking/Forcing.hs
+++ b/src/full/Agda/TypeChecking/Forcing.hs
@@ -13,7 +13,7 @@ import Agda.Utils.Size
import Agda.Utils.Monad
import Agda.Interaction.Options
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
addForcingAnnotations :: Type -> TCM Type
diff --git a/src/full/Agda/TypeChecking/Free.hs b/src/full/Agda/TypeChecking/Free.hs
index 19e87e0..727dbcc 100644
--- a/src/full/Agda/TypeChecking/Free.hs
+++ b/src/full/Agda/TypeChecking/Free.hs
@@ -1,13 +1,30 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Computing the free variables of a term.
+--
+-- The distinction between rigid and strongly rigid occurrences comes from:
+-- Jason C. Reed, PhD thesis, 2009, page 96 (see also his LFMTP 2009 paper)
+--
+-- The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly
+-- in t. It might have a solution if the occurrence is not strongly rigid, e.g.
+--
+-- x = \f -> suc (f (x (\ y -> k))) has x = \f -> suc (f (suc k))
+--
+-- [Jason C. Reed, PhD thesis, page 106]
+--
+-- Under coinductive constructors, occurrences are never strongly rigid.
+-- Also, function types and lambdas do not establish strong rigidity.
+-- Only inductive constructors do so.
+-- (See issue 1271).
+
module Agda.TypeChecking.Free
( FreeVars(..)
- , Free(..)
- , FreeConf(..), IgnoreSorts(..)
+ , Free
+ , IgnoreSorts(..)
, freeVars
+ , freeVarsIgnore
, allVars
, relevantVars
, rigidVars
@@ -18,52 +35,70 @@ module Agda.TypeChecking.Free
, occurrence
) where
-import qualified Agda.Utils.VarSet as Set
-import Agda.Utils.VarSet (VarSet)
+import Control.Applicative hiding (empty)
+import Control.Monad.Reader
+
+import Data.Foldable (foldMap)
+import Data.Monoid
import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
import Agda.Syntax.Internal
-import Agda.Utils.Impossible
-#include "../undefined.h"
+import Agda.Utils.Function
+import Agda.Utils.Functor
+import Agda.Utils.Monad
+import Agda.Utils.VarSet (VarSet)
+import qualified Agda.Utils.VarSet as Set
--- | The distinction between rigid and strongly rigid occurrences comes from:
--- Jason C. Reed, PhD thesis, 2009, page 96 (see also his LFMTP 2009 paper)
---
--- The main idea is that x = t(x) is unsolvable if x occurs strongly rigidly
--- in t. It might have a solution if the occurrence is not strongly rigid, e.g.
---
--- x = \f -> suc (f (x (\ y -> k))) has x = \f -> suc (f (suc k))
---
--- [Jason C. Reed, PhD thesis, page 106]
+#include "undefined.h"
+import Agda.Utils.Impossible
-- | Free variables of a term, (disjointly) partitioned into strongly and
-- and weakly rigid variables, flexible variables and irrelevant variables.
data FreeVars = FV
- { stronglyRigidVars :: VarSet -- ^ variables at top and under constructors
- , weaklyRigidVars :: VarSet -- ^ ord. rigid variables, e.g., in arguments of variables
- , flexibleVars :: VarSet -- ^ variables occuring in arguments of metas. These are potentially free, depending how the meta variable is instantiated.
- , irrelevantVars :: VarSet -- ^ variables in irrelevant arguments and under a @DontCare@, i.e., in irrelevant positions
- , unusedVars :: VarSet -- ^ variables in 'UnusedArg'uments
+ { stronglyRigidVars :: VarSet
+ -- ^ Variables under only and at least one inductive constructor(s).
+ , unguardedVars :: VarSet
+ -- ^ Variables at top or only under inductive record constructors
+ -- λs and Πs.
+ -- The purpose of recording these separately is that they
+ -- can still become strongly rigid if put under a constructor
+ -- whereas weakly rigid ones stay weakly rigid.
+ , weaklyRigidVars :: VarSet
+ -- ^ Ordinary rigid variables, e.g., in arguments of variables.
+ , flexibleVars :: VarSet
+ -- ^ Variables occuring in arguments of metas.
+ -- These are only potentially free, depending how the meta variable is instantiated.
+ , irrelevantVars :: VarSet
+ -- ^ Variables in irrelevant arguments and under a @DontCare@, i.e.,
+ -- in irrelevant positions.
+ , unusedVars :: VarSet
+ -- ^ Variables in 'UnusedArg'uments.
}
+-- | Rigid variables: either strongly rigid, unguarded, or weakly rigid.
rigidVars :: FreeVars -> VarSet
-rigidVars fv = Set.union (stronglyRigidVars fv) (weaklyRigidVars fv)
-
--- | @allVars fv@ includes irrelevant variables.
-allVars :: FreeVars -> VarSet
-allVars fv = Set.unions [rigidVars fv, flexibleVars fv, irrelevantVars fv, unusedVars fv]
+rigidVars fv = Set.unions
+ [ stronglyRigidVars fv
+ , unguardedVars fv
+ , weaklyRigidVars fv
+ ]
-- | All but the irrelevant variables.
relevantVars :: FreeVars -> VarSet
relevantVars fv = Set.unions [rigidVars fv, flexibleVars fv]
+-- | @allVars fv@ includes irrelevant variables.
+allVars :: FreeVars -> VarSet
+allVars fv = Set.unions [relevantVars fv, irrelevantVars fv, unusedVars fv]
+
data Occurrence
= NoOccurrence
| Irrelevantly
- | StronglyRigid
- | WeaklyRigid
- | Flexible
+ | StronglyRigid -- ^ Under at least one and only inductive constructors.
+ | Unguarded -- ^ In top position, or only under inductive record constructors.
+ | WeaklyRigid -- ^ In arguments to variables and definitions.
+ | Flexible -- ^ In arguments of metas.
| Unused
deriving (Eq,Show)
@@ -73,6 +108,7 @@ data Occurrence
occurrence :: Nat -> FreeVars -> Occurrence
occurrence x fv
| x `Set.member` stronglyRigidVars fv = StronglyRigid
+ | x `Set.member` unguardedVars fv = Unguarded
| x `Set.member` weaklyRigidVars fv = WeaklyRigid
| x `Set.member` flexibleVars fv = Flexible
| x `Set.member` irrelevantVars fv = Irrelevantly
@@ -83,6 +119,7 @@ occurrence x fv
flexible :: FreeVars -> FreeVars
flexible fv =
fv { stronglyRigidVars = Set.empty
+ , unguardedVars = Set.empty
, weaklyRigidVars = Set.empty
, flexibleVars = relevantVars fv
}
@@ -91,9 +128,30 @@ flexible fv =
weakly :: FreeVars -> FreeVars
weakly fv = fv
{ stronglyRigidVars = Set.empty
+ , unguardedVars = Set.empty
, weaklyRigidVars = rigidVars fv
}
+-- | Mark unguarded variables as strongly rigid. Useful when traversion arguments of inductive constructors.
+strongly :: FreeVars -> FreeVars
+strongly fv = fv
+ { stronglyRigidVars = stronglyRigidVars fv `Set.union` unguardedVars fv
+ , unguardedVars = Set.empty
+ }
+
+-- | What happens to the variables occurring under a constructor?
+underConstructor :: ConHead -> FreeVars -> FreeVars
+underConstructor (ConHead c i fs) =
+ case (i,fs) of
+ -- Coinductive (record) constructors admit infinite cycles:
+ (CoInductive, _) -> weakly
+ -- Inductive data constructors do not admit infinite cycles:
+ (Inductive, []) -> strongly
+ -- Inductive record constructors do not admit infinite cycles,
+ -- but this cannot be proven inside Agda.
+ -- Thus, unification should not prove it either.
+ (Inductive, (_:_)) -> id
+
-- | Mark all free variables as irrelevant.
irrelevantly :: FreeVars -> FreeVars
irrelevantly fv = empty { irrelevantVars = allVars fv }
@@ -107,32 +165,35 @@ unused fv = empty
-- | Pointwise union.
union :: FreeVars -> FreeVars -> FreeVars
-union (FV sv1 rv1 fv1 iv1 uv1) (FV sv2 rv2 fv2 iv2 uv2) =
- FV (Set.union sv1 sv2) (Set.union rv1 rv2) (Set.union fv1 fv2) (Set.union iv1 iv2) (Set.union uv1 uv2)
+union (FV sv1 gv1 rv1 fv1 iv1 uv1) (FV sv2 gv2 rv2 fv2 iv2 uv2) =
+ FV (Set.union sv1 sv2) (Set.union gv1 gv2) (Set.union rv1 rv2) (Set.union fv1 fv2) (Set.union iv1 iv2) (Set.union uv1 uv2)
unions :: [FreeVars] -> FreeVars
unions = foldr union empty
empty :: FreeVars
-empty = FV Set.empty Set.empty Set.empty Set.empty Set.empty
+empty = FV Set.empty Set.empty Set.empty Set.empty Set.empty Set.empty
+
+-- | Free variable sets form a monoid under 'union'.
+instance Monoid FreeVars where
+ mempty = empty
+ mappend = union
+ mconcat = unions
-- | @delete x fv@ deletes variable @x@ from variable set @fv at .
delete :: Nat -> FreeVars -> FreeVars
-delete n (FV sv rv fv iv uv) = FV (Set.delete n sv) (Set.delete n rv) (Set.delete n fv) (Set.delete n iv) (Set.delete n uv)
+delete n (FV sv gv rv fv iv uv) = FV (Set.delete n sv) (Set.delete n gv) (Set.delete n rv) (Set.delete n fv) (Set.delete n iv) (Set.delete n uv)
-- | @subtractFV n fv@ subtracts $n$ from each free variable in @fv at .
subtractFV :: Nat -> FreeVars -> FreeVars
-subtractFV n (FV sv rv fv iv uv) = FV (Set.subtract n sv) (Set.subtract n rv) (Set.subtract n fv) (Set.subtract n iv) (Set.subtract n uv)
+subtractFV n (FV sv gv rv fv iv uv) = FV (Set.subtract n sv) (Set.subtract n gv) (Set.subtract n rv) (Set.subtract n fv) (Set.subtract n iv) (Set.subtract n uv)
--- | A single (strongly) rigid variable.
+-- | A single unguarded variable.
singleton :: Nat -> FreeVars
-singleton x = empty { stronglyRigidVars = Set.singleton x }
+singleton x = empty { unguardedVars = Set.singleton x }
-- * Collecting free variables.
-class Free a where
- freeVars' :: FreeConf -> a -> FreeVars
-
-- | Where should we skip sorts in free variable analysis?
data IgnoreSorts
= IgnoreNot -- ^ Do not skip.
@@ -141,75 +202,115 @@ data IgnoreSorts
deriving (Eq, Show)
data FreeConf = FreeConf
- { fcIgnoreSorts :: IgnoreSorts -- ^ Ignore free variables in sorts.
+ { fcIgnoreSorts :: !IgnoreSorts
+ -- ^ Ignore free variables in sorts.
+ , fcContext :: !Int
+ -- ^ Under how many binders have we stepped?
+ }
+
+initFreeConf :: FreeConf
+initFreeConf = FreeConf
+ { fcIgnoreSorts = IgnoreNot
+ , fcContext = 0
}
-- | Doesn't go inside solved metas, but collects the variables from a
-- metavariable application @X ts@ as @flexibleVars at .
freeVars :: Free a => a -> FreeVars
-freeVars = freeVars' FreeConf{ fcIgnoreSorts = IgnoreNot }
+freeVars t = freeVars' t `runReader` initFreeConf
+
+freeVarsIgnore :: Free a => IgnoreSorts -> a -> FreeVars
+freeVarsIgnore i t = freeVars' t `runReader` initFreeConf{ fcIgnoreSorts = i }
+
+-- | Return type of fold over syntax.
+type FreeT = Reader FreeConf FreeVars
+
+instance Monoid FreeT where
+ mempty = pure mempty
+ mappend = liftA2 mappend
+ mconcat = mconcat <.> sequence
+
+-- | Base case: a variable.
+variable :: Int -> FreeT
+variable n = do
+ m <- (n -) <$> asks fcContext
+ if m >= 0 then pure $ singleton m else mempty
+
+-- | Going under a binder.
+bind :: FreeT -> FreeT
+bind = local $ \ e -> e { fcContext = 1 + fcContext e }
+
+class Free a where
+ freeVars' :: a -> FreeT
instance Free Term where
- freeVars' conf t = case t of
- Var n ts -> singleton n `union` weakly (freeVars' conf ts)
- Lam _ t -> freeVars' conf t
- Lit _ -> empty
- Def _ ts -> weakly $ freeVars' conf ts -- because we are not in TCM
+ freeVars' t = case t of
+ Var n ts -> variable n `mappend` do weakly <$> freeVars' ts
+ -- λ is not considered guarding, as
+ -- we cannot prove that x ≡ λy.x is impossible.
+ Lam _ t -> freeVars' t
+ Lit _ -> mempty
+ Def _ ts -> weakly <$> freeVars' ts -- because we are not in TCM
-- we cannot query whether we are dealing with a data/record (strongly r.)
-- or a definition by pattern matching (weakly rigid)
-- thus, we approximate, losing that x = List x is unsolvable
- Con _ ts -> freeVars' conf ts
- Pi a b -> freeVars' conf (a,b)
- Sort s -> freeVars' conf s
- Level l -> freeVars' conf l
- MetaV _ ts -> flexible $ freeVars' conf ts
- DontCare mt -> irrelevantly $ freeVars' conf mt
- Shared p -> freeVars' conf (derefPtr p)
- ExtLam cs ts -> freeVars' conf (cs, ts)
+ Con c ts -> underConstructor c <$> freeVars' ts
+ -- Pi is not guarding, since we cannot prove that A ≡ B → A is impossible.
+ -- Even as we do not permit infinite type expressions,
+ -- we cannot prove their absence (as Set is not inductive).
+ -- Also, this is incompatible with univalence (HoTT).
+ Pi a b -> freeVars' (a,b)
+ Sort s -> freeVars' s
+ Level l -> freeVars' l
+ MetaV _ ts -> flexible <$> freeVars' ts
+ DontCare mt -> irrelevantly <$> freeVars' mt
+ Shared p -> freeVars' (derefPtr p)
+ ExtLam cs ts -> freeVars' (cs, ts)
instance Free Type where
- freeVars' conf (El s t)
- | fcIgnoreSorts conf == IgnoreNot = freeVars' conf (s, t)
- | otherwise = freeVars' conf t
+ freeVars' (El s t) =
+ ifM ((IgnoreNot ==) <$> asks fcIgnoreSorts)
+ {- then -} (freeVars' (s, t))
+ {- else -} (freeVars' t)
instance Free Sort where
- freeVars' conf s
- | fcIgnoreSorts conf == IgnoreAll = empty
- | otherwise = case s of
- Type a -> freeVars' conf a
- Prop -> empty
- Inf -> empty
- DLub s1 s2 -> weakly $ freeVars' conf (s1, s2)
+ freeVars' s =
+ ifM ((IgnoreAll ==) <$> asks fcIgnoreSorts) mempty $ {- else -}
+ case s of
+ Type a -> freeVars' a
+ Prop -> mempty
+ Inf -> mempty
+ DLub s1 s2 -> weakly <$> freeVars' (s1, s2)
instance Free Level where
- freeVars' conf (Max as) = freeVars' conf as
+ freeVars' (Max as) = freeVars' as
instance Free PlusLevel where
- freeVars' conf ClosedLevel{} = empty
- freeVars' conf (Plus _ l) = freeVars' conf l
+ freeVars' ClosedLevel{} = mempty
+ freeVars' (Plus _ l) = freeVars' l
instance Free LevelAtom where
- freeVars' conf l = case l of
- MetaLevel _ vs -> flexible $ freeVars' conf vs
- NeutralLevel v -> freeVars' conf v
- BlockedLevel _ v -> freeVars' conf v
- UnreducedLevel v -> freeVars' conf v
+ freeVars' l = case l of
+ MetaLevel _ vs -> flexible <$> freeVars' vs
+ NeutralLevel v -> freeVars' v
+ BlockedLevel _ v -> freeVars' v
+ UnreducedLevel v -> freeVars' v
instance Free a => Free [a] where
- freeVars' conf = unions . map (freeVars' conf)
+ freeVars' = foldMap freeVars'
instance Free a => Free (Maybe a) where
- freeVars' conf = maybe empty (freeVars' conf)
+ freeVars' = foldMap freeVars'
instance (Free a, Free b) => Free (a,b) where
- freeVars' conf (x,y) = freeVars' conf x `union` freeVars' conf y
+ freeVars' (x,y) = freeVars' x `mappend` freeVars' y
instance Free a => Free (Elim' a) where
- freeVars' conf (Apply a) = freeVars' conf a
- freeVars' conf (Proj{} ) = empty
+ freeVars' (Apply a) = freeVars' a
+ freeVars' (Proj{} ) = mempty
instance Free a => Free (Arg a) where
- freeVars' conf a = f $ freeVars' conf $ unArg a
+ freeVars' a = f <$> freeVars' (unArg a)
where f = case getRelevance a of
Irrelevant -> irrelevantly
UnusedArg -> unused
@@ -217,41 +318,41 @@ instance Free a => Free (Arg a) where
instance Free a => Free (Dom a) where
- freeVars' conf = freeVars' conf . unDom
+ freeVars' = freeVars' . unDom
instance Free a => Free (Abs a) where
- freeVars' conf (Abs _ b) = subtractFV 1 $ delete 0 $ freeVars' conf b
- freeVars' conf (NoAbs _ b) = freeVars' conf b
+ freeVars' (Abs _ b) = bind $ freeVars' b
+ freeVars' (NoAbs _ b) = freeVars' b
instance Free a => Free (Tele a) where
- freeVars' conf EmptyTel = empty
- freeVars' conf (ExtendTel a tel) = freeVars' conf (a, tel)
+ freeVars' EmptyTel = mempty
+ freeVars' (ExtendTel a tel) = freeVars' (a, tel)
instance Free ClauseBody where
- freeVars' conf (Body t) = freeVars' conf t
- freeVars' conf (Bind b) = freeVars' conf b
- freeVars' conf NoBody = empty
+ freeVars' (Body t) = freeVars' t
+ freeVars' (Bind b) = freeVars' b
+ freeVars' NoBody = mempty
instance Free Clause where
- freeVars' conf = freeVars' conf . clauseBody
+ freeVars' = freeVars' . clauseBody
freeIn :: Free a => Nat -> a -> Bool
freeIn v t = v `Set.member` allVars (freeVars t)
freeInIgnoringSorts :: Free a => Nat -> a -> Bool
freeInIgnoringSorts v t =
- v `Set.member` allVars (freeVars' FreeConf{ fcIgnoreSorts = IgnoreAll } t)
+ v `Set.member` allVars (freeVarsIgnore IgnoreAll t)
freeInIgnoringSortAnn :: Free a => Nat -> a -> Bool
freeInIgnoringSortAnn v t =
- v `Set.member` allVars (freeVars' FreeConf{ fcIgnoreSorts = IgnoreInAnnotations } t)
+ v `Set.member` allVars (freeVarsIgnore IgnoreInAnnotations t)
relevantInIgnoringSortAnn :: Free a => Nat -> a -> Bool
relevantInIgnoringSortAnn v t =
- v `Set.member` relevantVars (freeVars' FreeConf{ fcIgnoreSorts = IgnoreInAnnotations } t)
+ v `Set.member` relevantVars (freeVarsIgnore IgnoreInAnnotations t)
relevantIn :: Free a => Nat -> a -> Bool
-relevantIn v t = v `Set.member` relevantVars (freeVars' FreeConf{ fcIgnoreSorts = IgnoreAll } t)
+relevantIn v t = v `Set.member` relevantVars (freeVarsIgnore IgnoreAll t)
-- | Is the variable bound by the abstraction actually used?
isBinderUsed :: Free a => Abs a -> Bool
diff --git a/src/full/Agda/TypeChecking/Implicit.hs b/src/full/Agda/TypeChecking/Implicit.hs
index ca79598..19d6473 100644
--- a/src/full/Agda/TypeChecking/Implicit.hs
+++ b/src/full/Agda/TypeChecking/Implicit.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-| Functions for inserting implicit arguments at the right places.
@@ -22,7 +22,7 @@ import Agda.TypeChecking.Pretty
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | @implicitArgs n expand t@ generates up to @n@ implicit arguments
@@ -76,8 +76,8 @@ introImplicits expand t = do
---------------------------------------------------------------------------
data ImplicitInsertion
- = ImpInsert [Hiding] -- ^ this many implicits have to be inserted
- | BadImplicits -- ^ hidden argument where there should have been a non-hidden arg
+ = ImpInsert [Hiding] -- ^ this many implicits have to be inserted
+ | BadImplicits -- ^ hidden argument where there should have been a non-hidden arg
| NoSuchName ArgName -- ^ bad named argument
| NoInsertNeeded
deriving (Show)
@@ -108,4 +108,4 @@ insertImplicit a ts =
| x == y && hidingx == getHiding a = impInsert $ reverse hs
| x == y && hidingx /= getHiding a = BadImplicits
| otherwise = find (getHiding a:hs) x hidingx ts
- find i x _ [] = NoSuchName x
+ find i x _ [] = NoSuchName x
diff --git a/src/full/Agda/TypeChecking/Injectivity.hs b/src/full/Agda/TypeChecking/Injectivity.hs
index 9ed5710..38e632c 100644
--- a/src/full/Agda/TypeChecking/Injectivity.hs
+++ b/src/full/Agda/TypeChecking/Injectivity.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Injectivity where
@@ -6,7 +6,6 @@ module Agda.TypeChecking.Injectivity where
import Prelude hiding (mapM)
import Control.Applicative
-import Control.Monad.Error hiding (mapM, forM)
import Control.Monad.State hiding (mapM, forM)
import Control.Monad.Reader hiding (mapM, forM)
@@ -16,6 +15,7 @@ import qualified Data.Set as Set
import Data.Maybe
import Data.Traversable hiding (for)
+import qualified Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Common
import Agda.Syntax.Internal
@@ -29,11 +29,12 @@ import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Polarity
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.List
import Agda.Utils.Functor
import Agda.Utils.Permutation
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
headSymbol :: Term -> TCM (Maybe TermHead)
@@ -78,7 +79,8 @@ headSymbol v = do -- ignoreAbstractMode $ do
checkInjectivity :: QName -> [Clause] -> TCM FunctionInverse
checkInjectivity f cs
| pointLess cs = do
- reportSLn "tc.inj.check" 20 $ "Injectivity of " ++ show f ++ " would be pointless."
+ reportSLn "tc.inj.check.pointless" 20 $
+ "Injectivity of " ++ show (A.qnameToConcrete f) ++ " would be pointless."
return NotInjective
where
-- Is it pointless to use injectivity for this function?
@@ -125,6 +127,8 @@ functionInverse v = case ignoreSharing v of
data InvView = Inv QName [Elim] (Map TermHead Clause)
| NoInv
+data MaybeAbort = Abort | KeepGoing
+
useInjectivity :: Comparison -> Type -> Term -> Term -> TCM ()
useInjectivity cmp a u v = do
reportSDoc "tc.inj.use" 30 $ fsep $
@@ -178,7 +182,7 @@ useInjectivity cmp a u v = do
invert org f ftype inv args (Just h) = case Map.lookup h inv of
Nothing -> typeError $ UnequalTerms cmp u v a
Just cl at Clause{ clauseTel = tel
- , clausePerm = perm } -> do
+ , clausePerm = perm } -> maybeAbort $ do
let ps = clausePats cl
-- These are what dot patterns should be instantiated at
ms <- map unArg <$> newTelMeta tel
@@ -189,7 +193,7 @@ useInjectivity cmp a u v = do
, text " ps =" <+> prettyList (map (text . show) ps)
]
-- and this is the order the variables occur in the patterns
- let ms' = permute (invertP $ compactP perm) ms
+ let ms' = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms
let sub = parallelS (reverse ms)
margs <- runReaderT (evalStateT (mapM metaElim ps) ms') sub
reportSDoc "tc.inj.invert" 20 $ vcat
@@ -207,7 +211,7 @@ useInjectivity cmp a u v = do
-- The clause might not give as many patterns as there
-- are arguments (point-free style definitions).
let args' = take (length margs) args
- compareElims pol ftype org margs args'
+ compareElims pol ftype (Def f []) margs args'
{- Andreas, 2011-05-09 allow unsolved constraints as long as progress
unless (null cs) $ do
reportSDoc "tc.inj.invert" 30 $
@@ -219,21 +223,21 @@ useInjectivity cmp a u v = do
org <- reduce org
h <- headSymbol org
case h of
- Just h -> compareTerm cmp a u v
+ Just h -> KeepGoing <$ compareTerm cmp a u v
Nothing -> do
- reportSDoc "tc.inj.invert" 30 $ vcat
- [ text "aborting inversion;" <+> prettyTCM org
- , text "plainly," <+> text (show org)
- , text "has TermHead" <+> text (show h)
- , text "which does not expose a constructor"
- ]
- patternViolation
- `catchError` \err -> case err of
- TypeError {} -> throwError err
- Exception {} -> throwError err
- IOException {} -> throwError err
- PatternErr {} -> fallBack
- {- AbortAssign {} -> fallBack -- UNUSED -}
+ reportSDoc "tc.inj.invert" 30 $ vcat
+ [ text "aborting inversion;" <+> prettyTCM org
+ , text "plainly," <+> text (show org)
+ , text "has TermHead" <+> text (show h)
+ , text "which does not expose a constructor"
+ ]
+ return Abort
+
+ maybeAbort m = do
+ (a, s) <- localTCStateSaving m
+ case a of
+ KeepGoing -> put s
+ Abort -> fallBack
nextMeta = do
m : ms <- get
diff --git a/src/full/Agda/TypeChecking/InstanceArguments.hs b/src/full/Agda/TypeChecking/InstanceArguments.hs
index 6ee28dd..d689d74 100644
--- a/src/full/Agda/TypeChecking/InstanceArguments.hs
+++ b/src/full/Agda/TypeChecking/InstanceArguments.hs
@@ -3,7 +3,6 @@
module Agda.TypeChecking.InstanceArguments where
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as Map
@@ -26,10 +25,12 @@ import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkArguments)
import {-# SOURCE #-} Agda.TypeChecking.MetaVars
import {-# SOURCE #-} Agda.TypeChecking.Conversion
+import Agda.Utils.Except ( MonadError(catchError, throwError), runExceptT )
+import Agda.Utils.Lens
import Agda.Utils.Maybe
import Agda.Utils.Monad
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | A candidate solution for an instance meta is a term with its type.
@@ -105,6 +106,7 @@ initialIFSCandidates t = do
-- with suggested name @s at .
initializeIFSMeta :: String -> Type -> TCM Term
initializeIFSMeta s t = do
+ t <- reduce t -- see Issue 1321
cands <- initialIFSCandidates t
newIFSMeta s t cands
@@ -118,7 +120,7 @@ initializeIFSMeta s t = do
-- its type again.
findInScope :: MetaId -> Maybe Candidates -> TCM ()
findInScope m Nothing = do
- reportSLn "tc.constr.findInScope" 20 $ "The type of the FindInScope constraint isn't known, trying to find it again."
+ reportSLn "tc.instance" 20 $ "The type of the FindInScope constraint isn't known, trying to find it again."
t <- getMetaType m
cands <- initialIFSCandidates t
case cands of
@@ -133,11 +135,11 @@ findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do
-- Andreas, 2013-12-28 issue 1003:
-- If instance meta is already solved, simply discard the constraint.
ifM (isInstantiatedMeta m) (return Nothing) $ do
- reportSLn "tc.constr.findInScope" 15 $
+ reportSLn "tc.instance" 15 $
"findInScope 2: constraint: " ++ show m ++ "; candidates left: " ++ show (length cands)
t <- normalise =<< getMetaTypeInContext m
- reportSDoc "tc.constr.findInScope" 15 $ text "findInScope 3: t =" <+> prettyTCM t
- reportSLn "tc.constr.findInScope" 70 $ "findInScope 3: t: " ++ show t
+ reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t
+ reportSLn "tc.instance" 70 $ "findInScope 3: t: " ++ show t
mv <- lookupMeta m
-- If there are recursive instances, it's not safe to instantiate
-- metavariables in the goal, so we freeze them before checking candidates.
@@ -151,18 +153,18 @@ findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do
filterM (shouldFreeze rigid) (allMetas t)
forM_ metas $ \ m -> updateMetaVar m $ \ mv -> mv { mvFrozen = Frozen }
cands <- checkCandidates m t cands
- reportSLn "tc.constr.findInScope" 15 $
+ reportSLn "tc.instance" 15 $
"findInScope 4: cands left: " ++ show (length cands)
unfreezeMeta metas
case cands of
[] -> do
- reportSDoc "tc.constr.findInScope" 15 $
+ reportSDoc "tc.instance" 15 $
text "findInScope 5: not a single candidate found..."
typeError $ IFSNoCandidateInScope t
[(term, t')] -> do
- reportSDoc "tc.constr.findInScope" 15 $ vcat
+ reportSDoc "tc.instance" 15 $ vcat
[ text "findInScope 5: found one candidate"
, nest 2 $ prettyTCM term
, text "of type " <+> prettyTCM t'
@@ -170,7 +172,7 @@ findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do
]
-- if t' takes initial hidden arguments, apply them
- ca <- liftTCM $ runErrorT $ checkArguments ExpandLast ExpandInstanceArguments (getRange mv) [] t' t
+ ca <- liftTCM $ runExceptT $ checkArguments ExpandLast ExpandInstanceArguments (getRange mv) [] t' t
case ca of
Left _ -> __IMPOSSIBLE__
Right (args, t'') -> do
@@ -183,14 +185,14 @@ findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do
ctxArgs <- getContextArgs
v <- (`applyDroppingParameters` args) =<< reduce term
assignV DirEq m ctxArgs v
- reportSDoc "tc.constr.findInScope" 10 $ vcat
+ reportSDoc "tc.instance" 10 $ vcat
[ text "solved by instance search:"
, prettyTCM m <+> text ":=" <+> prettyTCM v
]
return Nothing
cs -> do
- reportSDoc "tc.constr.findInScope" 15 $
+ reportSDoc "tc.instance" 15 $
text ("findInScope 5: more than one candidate found: ") <+>
prettyTCM (List.map fst cs)
return (Just cs)
@@ -210,7 +212,7 @@ findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do
-- search, since the constraint limits the solution space.
rigidlyConstrainedMetas :: TCM [MetaId]
rigidlyConstrainedMetas = do
- cs <- (++) <$> gets stSleepingConstraints <*> gets stAwakeConstraints
+ cs <- (++) <$> use stSleepingConstraints <*> use stAwakeConstraints
catMaybes <$> mapM rigidMetas cs
where
isRigid v =
@@ -256,10 +258,10 @@ checkCandidates m t cands = localTCState $ disableDestructiveUpdate $ do
where
checkCandidateForMeta :: MetaId -> Type -> Term -> Type -> TCM Bool
checkCandidateForMeta m t term t' =
- verboseBracket "tc.constr.findInScope" 20 ("checkCandidateForMeta " ++ show m) $ do
+ verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ show m) $ do
liftTCM $ flip catchError handle $ do
- reportSLn "tc.constr.findInScope" 70 $ " t: " ++ show t ++ "\n t':" ++ show t' ++ "\n term: " ++ show term ++ "."
- reportSDoc "tc.constr.findInScope" 20 $ vcat
+ reportSLn "tc.instance" 70 $ " t: " ++ show t ++ "\n t':" ++ show t' ++ "\n term: " ++ show term ++ "."
+ reportSDoc "tc.instance" 20 $ vcat
[ text "checkCandidateForMeta"
, text "t =" <+> prettyTCM t
, text "t' =" <+> prettyTCM t'
@@ -268,11 +270,11 @@ checkCandidates m t cands = localTCState $ disableDestructiveUpdate $ do
localTCState $ do
-- domi: we assume that nothing below performs direct IO (except
-- for logging and such, I guess)
- ca <- runErrorT $ checkArguments ExpandLast ExpandInstanceArguments noRange [] t' t
+ ca <- runExceptT $ checkArguments ExpandLast ExpandInstanceArguments noRange [] t' t
case ca of
Left _ -> return False
Right (args, t'') -> do
- reportSDoc "tc.constr.findInScope" 20 $
+ reportSDoc "tc.instance" 20 $
text "instance search: checking" <+> prettyTCM t''
<+> text "<=" <+> prettyTCM t
-- if constraints remain, we abort, but keep the candidate
@@ -280,7 +282,7 @@ checkCandidates m t cands = localTCState $ disableDestructiveUpdate $ do
--tel <- getContextTelescope
ctxArgs <- getContextArgs
v <- (`applyDroppingParameters` args) =<< reduce term
- reportSDoc "tc.constr.findInScope" 15 $ vcat
+ reportSDoc "tc.instance" 15 $ vcat
[ text "instance search: attempting"
, nest 2 $ prettyTCM m <+> text ":=" <+> prettyTCM v
]
@@ -294,7 +296,7 @@ checkCandidates m t cands = localTCState $ disableDestructiveUpdate $ do
return True
where
handle err = do
- reportSDoc "tc.constr.findInScope" 50 $
+ reportSDoc "tc.instance" 50 $
text "assignment failed:" <+> prettyTCM err
return False
isIFSConstraint :: Constraint -> Bool
diff --git a/src/full/Agda/TypeChecking/Level.hs b/src/full/Agda/TypeChecking/Level.hs
index a1a3f45..dc934a2 100644
--- a/src/full/Agda/TypeChecking/Level.hs
+++ b/src/full/Agda/TypeChecking/Level.hs
@@ -2,7 +2,6 @@
module Agda.TypeChecking.Level where
-import Control.Monad.Error
import Control.Applicative
import Data.List as List
@@ -14,7 +13,9 @@ import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Reduce.Monad ()
import Agda.TypeChecking.Monad.Builtin
-#include "../undefined.h"
+import Agda.Utils.Except ( MonadError(catchError) )
+
+#include "undefined.h"
import Agda.Utils.Impossible
data LevelKit = LevelKit
@@ -93,6 +94,7 @@ unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax = max } (Max as) =
[] -> zer
as -> foldr1 max as
+unPlusV :: Term -> (Term -> Term) -> PlusLevel -> Term
unPlusV zer suc (ClosedLevel n) = foldr (.) id (genericReplicate n suc) zer
unPlusV _ suc (Plus n a) = foldr (.) id (genericReplicate n suc) (unLevelAtom a)
diff --git a/src/full/Agda/TypeChecking/LevelConstraints.hs b/src/full/Agda/TypeChecking/LevelConstraints.hs
index 52db0c4..9423c9a 100644
--- a/src/full/Agda/TypeChecking/LevelConstraints.hs
+++ b/src/full/Agda/TypeChecking/LevelConstraints.hs
@@ -1,4 +1,3 @@
-
module Agda.TypeChecking.LevelConstraints ( simplifyLevelConstraint ) where
import Agda.Syntax.Common (Nat)
@@ -33,6 +32,7 @@ simplifyLevelConstraint n new old =
data Leq = PlusLevel :=< PlusLevel
deriving (Show, Eq)
+inequalities :: Constraint -> [Leq]
inequalities (LevelCmp CmpEq (Max [a, b]) (Max [c]))
| a == c = [b :=< a]
| b == c = [a :=< b]
diff --git a/src/full/Agda/TypeChecking/MetaVars.hs b/src/full/Agda/TypeChecking/MetaVars.hs
index bbb6848..fbf76e9 100644
--- a/src/full/Agda/TypeChecking/MetaVars.hs
+++ b/src/full/Agda/TypeChecking/MetaVars.hs
@@ -1,14 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RelaxedPolyRec #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RelaxedPolyRec #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.MetaVars where
import Control.Monad.Reader
-import Control.Monad.Error
import Data.Function
import Data.List hiding (sort)
@@ -42,7 +41,13 @@ import Agda.TypeChecking.SizedTypes (boundedSizeMetaHook, isSizeProblem)
-- import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (checkInternal)
import Agda.TypeChecking.MetaVars.Occurs
-import Agda.Utils.Fresh
+import Agda.Utils.Except
+ ( Error(noMsg)
+ , ExceptT
+ , MonadError(throwError)
+ , runExceptT
+ )
+
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
@@ -51,7 +56,7 @@ import Agda.Utils.Tuple
import Agda.Utils.Permutation
import qualified Agda.Utils.VarSet as Set
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Find position of a value in a list.
@@ -68,12 +73,12 @@ isBlockedTerm x = do
reportSLn "tc.meta.blocked" 12 $ "is " ++ show x ++ " a blocked term? "
i <- mvInstantiation <$> lookupMeta x
let r = case i of
- BlockedConst{} -> True
+ BlockedConst{} -> True
PostponedTypeCheckingProblem{} -> True
- InstV{} -> False
- InstS{} -> False
- Open{} -> False
- OpenIFS{} -> False
+ InstV{} -> False
+ InstS{} -> False
+ Open{} -> False
+ OpenIFS{} -> False
reportSLn "tc.meta.blocked" 12 $
if r then " yes, because " ++ show i else " no"
return r
@@ -96,16 +101,16 @@ isEtaExpandable x = do
-- The instantiation should not be an 'InstV' or 'InstS' and the 'MetaId'
-- should point to something 'Open' or a 'BlockedConst'.
-- Further, the meta variable may not be 'Frozen'.
-assignTerm :: MetaId -> Term -> TCM ()
-assignTerm x t = do
+assignTerm :: MetaId -> [I.Arg ArgName] -> Term -> TCM ()
+assignTerm x tel v = do
-- verify (new) invariants
whenM (isFrozen x) __IMPOSSIBLE__
- assignTerm' x t
+ assignTerm' x tel v
-- | Skip frozen check. Used for eta expanding frozen metas.
-assignTerm' :: MetaId -> Term -> TCM ()
-assignTerm' x t = do
- reportSLn "tc.meta.assign" 70 $ show x ++ " := " ++ show t
+assignTerm' :: MetaId -> [I.Arg ArgName] -> Term -> TCM ()
+assignTerm' x tel v = do
+ reportSLn "tc.meta.assign" 70 $ show x ++ " := " ++ show v ++ "\n in " ++ show tel
-- verify (new) invariants
whenM (not <$> asks envAssignMetas) __IMPOSSIBLE__
@@ -123,14 +128,14 @@ assignTerm' x t = do
-- dontAssignMetas $ do
-- checkInternal t . jMetaType . mvJudgement =<< lookupMeta x
- let i = metaInstance (killRange t)
+ let i = metaInstance tel v
verboseS "profile.metas" 10 $ liftTCM $ tickMax "max-open-metas" . size =<< getOpenMetas
modifyMetaStore $ ins x i
etaExpandListeners x
wakeupConstraints x
reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ show x
where
- metaInstance = InstV
+ metaInstance tel v = InstV tel v
ins x i store = Map.adjust (inst i) x store
inst i mv = mv { mvInstantiation = i }
@@ -177,7 +182,7 @@ newTypeMeta_ = newTypeMeta =<< (workOnTypes $ newSortMeta)
-- lambdas in front of it.
newIFSMeta :: MetaNameSuggestion -> Type -> Maybe [(Term, Type)] -> TCM Term
newIFSMeta s t cands = do
- let TelV tel t' = telView' t
+ TelV tel t' <- telView t
addCtxTel tel $ do
vs <- getContextArgs
ctx <- getContextTelescope
@@ -192,8 +197,8 @@ newIFSMetaCtx s t vs cands = do
]
i0 <- createMetaInfo
let i = i0 { miNameSuggestion = s }
- let TelV tel _ = telView' t
- perm = idP (size tel)
+ TelV tel _ <- telView t
+ let perm = idP (size tel)
x <- newMeta' OpenIFS i normalMetaPriority perm (HasType () t)
reportSDoc "tc.meta.new" 50 $ fsep
[ nest 2 $ text (show x) <+> text ":" <+> prettyTCM t
@@ -230,8 +235,8 @@ newValueMeta' b t = do
newValueMetaCtx' :: RunMetaOccursCheck -> Type -> Args -> TCM Term
newValueMetaCtx' b t vs = do
i <- createMetaInfo' b
- let TelV tel a = telView' t
- perm = idP (size tel)
+ TelV tel a <- telView t
+ let perm = idP (size tel)
x <- newMeta i normalMetaPriority perm (HasType () t)
reportSDoc "tc.meta.new" 50 $ fsep
[ text "new meta:"
@@ -248,6 +253,8 @@ newTelMeta :: Telescope -> TCM Args
newTelMeta tel = newArgsMeta (abstract tel $ El Prop $ Sort Prop)
type Condition = I.Dom Type -> Abs Type -> Bool
+
+trueCondition :: Condition
trueCondition _ _ = True
newArgsMeta :: Type -> TCM Args
@@ -289,7 +296,7 @@ newRecordMeta r pars = do
newRecordMetaCtx :: QName -> Args -> Telescope -> Args -> TCM Term
newRecordMetaCtx r pars tel ctx = do
- ftel <- flip apply pars <$> getRecordFieldTypes r
+ ftel <- flip apply pars <$> getRecordFieldTypes r
fields <- newArgsMetaCtx (telePi_ ftel $ sort Prop) tel ctx
con <- getRecordConstructor r
return $ Con con fields
@@ -394,7 +401,7 @@ problemType (CheckArgs _ _ _ _ _ t _) = t
etaExpandListeners :: MetaId -> TCM ()
etaExpandListeners m = do
ls <- getMetaListeners m
- clearMetaListeners m -- we don't really have to do this
+ clearMetaListeners m -- we don't really have to do this
mapM_ wakeupListener ls
-- | Wake up a meta listener and let it do its thing
@@ -454,8 +461,8 @@ etaExpandMeta kinds m = whenM (isEtaExpandable m) $ do
lvl@(Def r es) ->
ifM (isEtaRecord r) {- then -} (do
let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- let expand = do
- u <- abstract tel <$> do withMetaInfo' meta $ newRecordMetaCtx r ps tel $ teleArgs tel
+ let expand = do
+ u <- withMetaInfo' meta $ newRecordMetaCtx r ps tel $ teleArgs tel
inTopContext $ do
verboseS "tc.meta.eta" 15 $ do
du <- prettyTCM u
@@ -463,7 +470,7 @@ etaExpandMeta kinds m = whenM (isEtaExpandable m) $ do
-- Andreas, 2012-03-29: No need for occurrence check etc.
-- we directly assign the solution for the meta
-- 2012-05-23: We also bypass the check for frozen.
- noConstraints $ assignTerm' m u -- should never produce any constraints
+ noConstraints $ assignTerm' m (telToArgs tel) u -- should never produce any constraints
if Records `elem` kinds then
expand
else if (SingletonRecords `elem` kinds) then do
@@ -480,7 +487,7 @@ etaExpandMeta kinds m = whenM (isEtaExpandable m) $ do
reportSLn "tc.meta.eta" 20 $ "Expanding level meta to 0 (type-in-type)"
-- Andreas, 2012-03-30: No need for occurrence check etc.
-- we directly assign the solution for the meta
- noConstraints $ assignTerm m (abstract tel $ Level $ Max [])
+ noConstraints $ assignTerm m (telToArgs tel) (Level $ Max [])
) $ {- else -} dontExpand
_ -> dontExpand
@@ -563,8 +570,8 @@ assign dir x args v = do
reportSLn "tc.meta.assign" 25 $ "aborting: meta is frozen!"
patternViolation
- -- We never get blocked terms here anymore. TODO: we actually do. why?
- whenM (isBlockedTerm x) patternViolation
+ -- We never get blocked terms here anymore. TODO: we actually do. why?
+ whenM (isBlockedTerm x) patternViolation
-- Andreas, 2010-10-15 I want to see whether rhs is blocked
reportSLn "tc.meta.assign" 50 $ "MetaVars.assign: I want to see whether rhs is blocked"
@@ -623,17 +630,17 @@ assign dir x args v = do
, text "fvars lhs (irr):" <+> sep (map (text . show) irrVL)
]
- -- Check that the x doesn't occur in the right hand side.
+ -- Check that the x doesn't occur in the right hand side.
-- Prune mvars on rhs such that they can only depend on varsL.
-- Herein, distinguish relevant and irrelevant vars,
-- since when abstracting irrelevant lhs vars, they may only occur
-- irrelevantly on rhs.
- v <- liftTCM $ occursCheck x (relVL, irrVL) v
+ v <- liftTCM $ occursCheck x (relVL, irrVL) v
- reportSLn "tc.meta.assign" 15 "passed occursCheck"
- verboseS "tc.meta.assign" 30 $ do
- let n = size v
- when (n > 200) $ reportSDoc "tc.meta.assign" 30 $
+ reportSLn "tc.meta.assign" 15 "passed occursCheck"
+ verboseS "tc.meta.assign" 30 $ do
+ let n = size v
+ when (n > 200) $ reportSDoc "tc.meta.assign" 30 $
sep [ text "size" <+> text (show n)
-- , nest 2 $ text "type" <+> prettyTCM t
, nest 2 $ text "term" <+> prettyTCM v
@@ -648,9 +655,9 @@ assign dir x args v = do
reportSDoc "tc.meta.assign" 20 $
text "fvars rhs:" <+> sep (map (text . show) $ Set.toList fvs)
- -- Check that the arguments are variables
- mids <- do
- res <- runErrorT $ inverseSubst args
+ -- Check that the arguments are variables
+ mids <- do
+ res <- runExceptT $ inverseSubst args
case res of
-- all args are variables
Right ids -> do
@@ -671,7 +678,7 @@ assign dir x args v = do
Just ids -> do
-- Check linearity
ids <- do
- res <- runErrorT $ checkLinearity {- (`Set.member` fvs) -} ids
+ res <- runExceptT $ checkLinearity {- (`Set.member` fvs) -} ids
case res of
-- case: linear
Right ids -> return ids
@@ -719,15 +726,16 @@ attemptInertRHSImprovement m args v = do
-- Solve the meta with _M := \ xs -> D (_Y1 xs) .. (_Yn xs), for fresh metas
-- _Yi.
metaArgs <- inTopContext $ addCtxTel tel $ newArgsMeta a
- let varArgs = map Apply $ reverse $ zipWith (\i a -> var i <$ a) [0..] (reverse args)
- sol = foldr (\a -> Lam (argInfo a) . Abs "x") (mkRHS metaArgs) args
+ let varArgs = map Apply $ reverse $ zipWith (\i a -> var i <$ a) [0..] (reverse args)
+ sol = mkRHS metaArgs
+ argTel = map ("x" <$) args
reportSDoc "tc.meta.inert" 30 $ nest 2 $ vcat
[ text "a =" <+> prettyTCM a
, text "tel =" <+> prettyTCM tel
, text "metas =" <+> prettyList (map prettyTCM metaArgs)
, text "sol =" <+> prettyTCM sol
]
- assignTerm m sol
+ assignTerm m argTel sol
patternViolation -- throwing a pattern violation here lets the constraint
-- machinery worry about restarting the comparison.
where
@@ -830,10 +838,11 @@ assignMeta' m x t n ids v = do
-- ALT 2: O(m)
let assocToList i l = case l of
_ | i >= m -> []
- ((j,u) : l) | i == j -> u : assocToList (i+1) l
- _ -> __IMPOSSIBLE__ : assocToList (i+1) l
+ ((j,u) : l) | i == j -> Just u : assocToList (i+1) l
+ _ -> Nothing : assocToList (i+1) l
ivs = assocToList 0 ids
- return $ applySubst (ivs ++# raiseS n) v
+ rho = prependS __IMPOSSIBLE__ ivs $ raiseS n
+ return $ applySubst rho v
-- Metas are top-level so we do the assignment at top-level.
inTopContext $ do
@@ -853,12 +862,10 @@ assignMeta' m x t n ids v = do
when (size tel' < n)
patternViolation -- WAS: __IMPOSSIBLE__
- -- The solution.
- let u = killRange $ abstract tel' v'
-- Perform the assignment (and wake constraints).
reportSDoc "tc.meta.assign" 10 $
- text "solving" <+> prettyTCM x <+> text ":=" <+> prettyTCM u
- assignTerm x u
+ text "solving" <+> prettyTCM x <+> text ":=" <+> prettyTCM (abstract tel' v')
+ assignTerm x (telToArgs tel') v'
-- | Turn the assignment problem @_X args <= SizeLt u@ into
@@ -892,7 +899,7 @@ subtypingForSizeLt dir x mvar t args v cont = do
-- so we cannot fall back to the original handler.
let xArgs = MetaV x $ map Apply args
v' = Def qSizeLt [Apply $ Arg ai yArgs]
- c = dirToCmp (`ValueCmp` set0) dir xArgs v'
+ c = dirToCmp (`ValueCmp` sizeUniv) dir xArgs v'
catchConstraint c $ cont v'
_ -> fallback
@@ -929,7 +936,8 @@ instance Error ProjVarExc where
noMsg = __IMPOSSIBLE__
instance NoProjectedVar Term where
- noProjectedVar (Var i es) | Just qs@(_:_) <- mapM isProjElim es = Left $ ProjVarExc i qs
+ noProjectedVar (Var i es)
+ | qs@(_:_) <- takeWhileJust id $ map isProjElim es = Left $ ProjVarExc i qs
noProjectedVar _ = return ()
instance NoProjectedVar a => NoProjectedVar (I.Arg a) where
@@ -996,7 +1004,7 @@ type SubstCand = [(Nat,Term)] -- ^ a possibly non-deterministic substitution
-- | Turn non-det substitution into proper substitution, if possible.
-- Otherwise, raise the error.
-checkLinearity :: SubstCand -> ErrorT () TCM SubstCand
+checkLinearity :: SubstCand -> ExceptT () TCM SubstCand
checkLinearity ids0 = do
let ids = sortBy (compare `on` fst) ids0 -- see issue 920
let grps = groupOn fst ids
@@ -1004,7 +1012,7 @@ checkLinearity ids0 = do
where
-- | Non-determinism can be healed if type is singleton. [Issue 593]
-- (Same as for irrelevance.)
- makeLinear :: SubstCand -> ErrorT () TCM SubstCand
+ makeLinear :: SubstCand -> ExceptT () TCM SubstCand
makeLinear [] = __IMPOSSIBLE__
makeLinear grp@[_] = return grp
makeLinear (p@(i,t) : _) =
@@ -1060,7 +1068,7 @@ instance Error InvertExcept where
-- Linearity, i.e., whether the substitution is deterministic,
-- has to be checked separately.
--
-inverseSubst :: Args -> ErrorT InvertExcept TCM SubstCand
+inverseSubst :: Args -> ExceptT InvertExcept TCM SubstCand
inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
where
loop = foldM isVarOrIrrelevant []
@@ -1072,7 +1080,7 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
throwError CantInvert
neutralArg = throwError NeutralArg
- isVarOrIrrelevant :: Res -> (I.Arg Term, Term) -> ErrorT InvertExcept TCM Res
+ isVarOrIrrelevant :: Res -> (I.Arg Term, Term) -> ExceptT InvertExcept TCM Res
isVarOrIrrelevant vars (arg, t) =
case ignoreSharing <$> arg of
-- i := x
@@ -1146,10 +1154,6 @@ inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)
-- filter out duplicate irrelevants
filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars
-
-
-
-
-- | Used in 'Agda.Interaction.BasicOps.giveExpr'.
updateMeta :: MetaId -> Term -> TCM ()
updateMeta mI v = do
diff --git a/src/full/Agda/TypeChecking/MetaVars.hs-boot b/src/full/Agda/TypeChecking/MetaVars.hs-boot
index 4166338..ef21be7 100644
--- a/src/full/Agda/TypeChecking/MetaVars.hs-boot
+++ b/src/full/Agda/TypeChecking/MetaVars.hs-boot
@@ -1,17 +1,17 @@
module Agda.TypeChecking.MetaVars where
-import Agda.Syntax.Internal ( MetaId, Term, Type, Args, Abs, Dom, Telescope )
+import Agda.Syntax.Internal ( MetaId, Term, Type, Arg, Args, Abs, Dom, Telescope )
import Agda.Syntax.Internal.Generic ( TermLike )
import Agda.TypeChecking.Monad.Base ( TCM, RunMetaOccursCheck(..), CompareDirection(..) )
type Condition = Dom Type -> Abs Type -> Bool
newArgsMeta' :: Condition -> Type -> TCM Args
newArgsMeta :: Type -> TCM Args
-assignTerm :: MetaId -> Term -> TCM ()
+assignTerm :: MetaId -> [Arg String] -> Term -> TCM ()
etaExpandMetaSafe :: MetaId -> TCM ()
assignV :: CompareDirection -> MetaId -> Args -> Term -> TCM ()
-assign :: CompareDirection -> MetaId -> Args -> Term -> TCM ()
-newIFSMeta :: String -> Type -> Maybe [(Term, Type)] -> TCM Term
+assign :: CompareDirection -> MetaId -> Args -> Term -> TCM ()
+newIFSMeta :: String -> Type -> Maybe [(Term, Type)] -> TCM Term
newValueMeta :: RunMetaOccursCheck -> Type -> TCM Term
newNamedValueMeta :: RunMetaOccursCheck -> String -> Type -> TCM Term
newTelMeta :: Telescope -> TCM Args
diff --git a/src/full/Agda/TypeChecking/MetaVars/Mention.hs b/src/full/Agda/TypeChecking/MetaVars/Mention.hs
index c59d817..f032dbc 100644
--- a/src/full/Agda/TypeChecking/MetaVars/Mention.hs
+++ b/src/full/Agda/TypeChecking/MetaVars/Mention.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
module Agda.TypeChecking.MetaVars.Mention where
import Agda.Syntax.Common
@@ -6,7 +9,7 @@ import Agda.Syntax.Internal as I
import Agda.TypeChecking.Monad
import Agda.Utils.Impossible
-#include "../../undefined.h"
+#include "undefined.h"
class MentionsMeta t where
mentionsMeta :: MetaId -> t -> Bool
diff --git a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
index b819621..c0ee637 100644
--- a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
+++ b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.MetaVars.Occurs where
import Control.Applicative
import Control.Monad
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
@@ -23,11 +22,18 @@ import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Free hiding (Occurrence(..))
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Records
-import Agda.TypeChecking.Datatypes (isDataOrRecordType)
import {-# SOURCE #-} Agda.TypeChecking.MetaVars
-- import Agda.TypeChecking.MetaVars
import Agda.Utils.Either
+
+import Agda.Utils.Except
+ ( ExceptT
+ , MonadError(catchError, throwError)
+ , runExceptT
+ )
+
+import Agda.Utils.Lens
import Agda.Utils.List (takeWhileJust)
import Agda.Utils.Maybe
import Agda.Utils.Monad
@@ -35,7 +41,7 @@ import Agda.Utils.Permutation
import Agda.Utils.Size
import qualified Agda.Utils.VarSet as VarSet
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
{- To address issue 585 (meta var occurrences in mutual defs)
@@ -74,8 +80,7 @@ successful). This way, we do not duplicate work.
-}
modifyOccursCheckDefs :: (Set QName -> Set QName) -> TCM ()
-modifyOccursCheckDefs f = modify $ \ st ->
- st { stOccursCheckDefs = f (stOccursCheckDefs st) }
+modifyOccursCheckDefs f = stOccursCheckDefs %= f
-- | Set the names of definitions to be looked at
-- to the defs in the current mutual block.
@@ -87,7 +92,7 @@ initOccursCheck mv = modifyOccursCheckDefs . const =<<
-- | Is a def in the list of stuff to be checked?
defNeedsChecking :: QName -> TCM Bool
-defNeedsChecking d = Set.member d <$> gets stOccursCheckDefs
+defNeedsChecking d = Set.member d <$> use stOccursCheckDefs
-- | Remove a def from the list of defs to be looked at.
tallyDef :: QName -> TCM ()
@@ -226,14 +231,14 @@ instance Occurs Term where
abort (strongly ctx) $ MetaCannotDependOn m (takeRelevant xs) i
-- is a singleton type with unique inhabitant sv
Right (Just sv) -> return $ sv `applyE` es
- Lam h f -> Lam h <$> occ (leaveTop ctx) f
+ Lam h f -> Lam h <$> occ (leaveTop ctx) f
Level l -> Level <$> occ ctx l -- stay in Top
- Lit l -> return v
+ Lit l -> return v
DontCare v -> dontCare <$> occurs red Irrel m (goIrrelevant xs) v
Def d es -> Def d <$> occDef d (leaveTop ctx) es
Con c vs -> Con c <$> occ (leaveTop ctx) vs -- if strongly rigid, remain so
- Pi a b -> uncurry Pi <$> occ (leaveTop ctx) (a,b)
- Sort s -> Sort <$> occ (leaveTop ctx) s
+ Pi a b -> uncurry Pi <$> occ (leaveTop ctx) (a,b)
+ Sort s -> Sort <$> occ (leaveTop ctx) s
v at Shared{} -> updateSharedTerm (occ ctx) v
ExtLam{} -> __IMPOSSIBLE__
MetaV m' es -> do
@@ -442,7 +447,7 @@ instance Occurs a => Occurs [a] where
-- reduction for a suitable instantiation of the meta variable.
prune :: MetaId -> Args -> [Nat] -> TCM PruneResult
prune m' vs xs = do
- caseEitherM (runErrorT $ mapM (hasBadRigid xs) $ map unArg vs)
+ caseEitherM (runExceptT $ mapM (hasBadRigid xs) $ map unArg vs)
(const $ return PrunedNothing) $ \ kills -> do
reportSDoc "tc.meta.kill" 10 $ vcat
[ text "attempting kills"
@@ -470,7 +475,7 @@ prune m' vs xs = do
-- @hasBadRigid xs v = Nothing@ means that
-- we cannot prune at all as one of the meta args is matchable.
-- (See issue 1147.)
-hasBadRigid :: [Nat] -> Term -> ErrorT () TCM Bool
+hasBadRigid :: [Nat] -> Term -> ExceptT () TCM Bool
hasBadRigid xs t = do
-- We fail if we encounter a matchable argument.
let failure = throwError ()
@@ -590,7 +595,7 @@ killedType :: [(I.Dom (ArgName, Type), Bool)] -> Type -> ([I.Arg Bool], Type)
killedType [] b = ([], b)
killedType ((arg@(Dom info _), kill) : kills) b
| dontKill = (Arg info False : args, mkPi arg b') -- OLD: telePi (telFromList [arg]) b')
- | otherwise = (Arg info True : args, subst __IMPOSSIBLE__ b')
+ | otherwise = (Arg info True : args, strengthen __IMPOSSIBLE__ b')
where
(args, b') = killedType kills b
dontKill = not kill || 0 `freeIn` b'
@@ -608,14 +613,15 @@ performKill kills m a = do
etaExpandMetaSafe m'
let vars = reverse [ Arg info (var i) | (i, Arg info False) <- zip [0..] kills ]
lam b a = Lam (argInfo a) (Abs "v" b)
- u = foldl' lam (MetaV m' $ map Apply vars) kills
+ tel = map ("v" <$) (reverse kills)
+ u = MetaV m' $ map Apply vars
{- OLD CODE
hs = reverse [ argHiding a | a <- kills ]
lam h b = Lam h (Abs "v" b)
u = foldr lam (MetaV m' vars) hs
-}
dbg m' u
- assignTerm m u
+ assignTerm m tel u
where
dbg m' u = reportSDoc "tc.meta.kill" 10 $ vcat
[ text "actual killing"
diff --git a/src/full/Agda/TypeChecking/Monad/Base.hs b/src/full/Agda/TypeChecking/Monad/Base.hs
index 1145491..186c546 100644
--- a/src/full/Agda/TypeChecking/Monad/Base.hs
+++ b/src/full/Agda/TypeChecking/Monad/Base.hs
@@ -1,18 +1,18 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.TypeChecking.Monad.Base where
@@ -20,7 +20,6 @@ import Control.Arrow ((***), first, second)
import qualified Control.Concurrent as C
import Control.DeepSeq
import Control.Exception as E
-import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
@@ -29,10 +28,12 @@ import Control.Applicative
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 as Map
import Data.Set as Set
-import Data.Sequence as Seq
import Data.Typeable (Typeable)
import Data.Foldable
import Data.Traversable
@@ -45,6 +46,8 @@ import qualified Agda.Syntax.Concrete as C
import qualified Agda.Syntax.Concrete.Definitions as D
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Internal as I
+import Agda.Syntax.Internal.Pattern ()
+import Agda.Syntax.Fixity
import Agda.Syntax.Position
import Agda.Syntax.Scope.Base
@@ -63,75 +66,106 @@ import qualified Agda.Compiler.JS.Syntax as JS
import Agda.TypeChecking.Monad.Base.Benchmark (Benchmark)
import qualified Agda.TypeChecking.Monad.Base.Benchmark as Benchmark
+import Agda.Utils.Except
+ ( Error(noMsg, strMsg)
+ , ExceptT
+ , MonadError(catchError, throwError)
+ )
+
import Agda.Utils.FileName
-import Agda.Utils.Fresh
import Agda.Utils.HashMap as HMap
import Agda.Utils.Hash
+import Agda.Utils.Lens
import Agda.Utils.Permutation
import Agda.Utils.Pretty
import Agda.Utils.Time
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
-- * Type checking state
---------------------------------------------------------------------------
-data TCState =
- TCSt { stFreshThings :: FreshThings
- , stSyntaxInfo :: CompressedFile
- -- ^ Highlighting info.
- , stTokens :: CompressedFile
- -- ^ Highlighting info for tokens (but not those tokens for
- -- which highlighting exists in 'stSyntaxInfo').
- , stTermErrs :: Seq TerminationError
- , stMetaStore :: MetaStore
- , stInteractionPoints :: InteractionPoints
- , stAwakeConstraints :: Constraints
- , stSleepingConstraints :: Constraints
- , stDirty :: Bool
- , stOccursCheckDefs :: Set QName
- -- ^ 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.
- , stSignature :: Signature
- -- ^ Declared identifiers of the current file.
- -- These will be serialized after successful type checking.
- , stImports :: Signature
- -- ^ Imported declared identifiers.
- -- Those most not be serialized!
- , stImportedModules :: Set ModuleName
- , stModuleToSource :: ModuleToSource
- , stVisitedModules :: VisitedModules
- , stCurrentModule :: Maybe ModuleName
- -- ^ The current module is available after it has been type
- -- checked.
- , stScope :: ScopeInfo
- , stPatternSyns :: A.PatternSynDefns
- -- ^ Pattern synonyms of the current file. Serialized.
- , stPatternSynImports :: A.PatternSynDefns
- -- ^ Imported pattern synonyms. Must not be serialized!
- , stInstanceDefs :: TempInstanceTable
- , stPragmaOptions :: PragmaOptions
- -- ^ Options applying to the current file. @OPTIONS@
- -- pragmas only affect this field.
- , stStatistics :: Statistics
- -- ^ Counters to collect various statistics about meta variables etc.
- , stMutualBlocks :: Map MutualId (Set QName)
- , stLocalBuiltins :: BuiltinThings PrimFun
- , stImportedBuiltins :: BuiltinThings PrimFun
- , stHaskellImports :: Set String
- -- ^ Imports that should be generated by the compiler (this
- -- includes imports from imported modules).
- , stPersistent :: PersistentTCState
- -- ^ Options which apply to all files, unless overridden.
- }
+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.
+ }
+
+data PreScopeState = PreScopeState
+ { stPreTokens :: CompressedFile -- from lexer
+ -- ^ Highlighting info for tokens (but not those tokens for
+ -- which highlighting exists in 'stSyntaxInfo').
+ , stPreInteractionPoints :: InteractionPoints -- scope checker first
+ , stPreImports :: Signature -- XX populated by scopec hecker
+ -- ^ Imported declared identifiers.
+ -- Those most not be serialized!
+ , stPreImportedModules :: Set ModuleName -- imports logic
+ , stPreModuleToSource :: ModuleToSource -- imports
+ , stPreVisitedModules :: VisitedModules -- imports
+ , stPreScope :: ScopeInfo
+ -- generated by scope checker, current file: which modules you have, public definitions, current file, maps concrete names to abstract names.
+ , stPrePatternSyns :: A.PatternSynDefns
+ -- ^ Pattern synonyms of the current file. Serialized.
+ , stPrePatternSynImports :: A.PatternSynDefns
+ -- ^ Imported pattern synonyms. Must not be serialized!
+ , stPrePragmaOptions :: PragmaOptions
+ -- ^ Options applying to the current file. @OPTIONS@
+ -- pragmas only affect this field.
+ , stPreImportedBuiltins :: BuiltinThings PrimFun
+ , stPreHaskellImports :: Set String
+ -- ^ Imports that should be generated by the compiler (this
+ -- includes imports from imported modules).
+ , stPreFreshInteractionId :: InteractionId
+ , stPreFreshNameId :: NameId
+ }
+
+type DisambiguatedNames = IntMap A.QName
+
+data PostScopeState = PostScopeState
+ { stPostSyntaxInfo :: CompressedFile
+ -- ^ Highlighting info.
+ , stPostDisambiguatedNames :: !DisambiguatedNames
+ -- ^ Disambiguation carried out by the type checker.
+ -- Maps position of first name character to disambiguated @'A.QName'@
+ -- for each @'A.AmbiguousQName'@ already passed by the type checker.
+ , stPostMetaStore :: MetaStore
+ , stPostInteractionPoints :: InteractionPoints -- scope checker first
+ , 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.
+ , stPostCurrentModule :: Maybe ModuleName
+ -- ^ The current module is available after it has been type
+ -- checked.
+ , stPostInstanceDefs :: TempInstanceTable
+ , stPostStatistics :: Statistics
+ -- ^ Counters to collect various statistics about meta variables etc.
+ -- Only for current file.
+ , stPostMutualBlocks :: Map MutualId (Set QName)
+ , stPostLocalBuiltins :: BuiltinThings PrimFun
+ , stPostFreshMetaId :: MetaId
+ , stPostFreshMutualId :: MutualId
+ , stPostFreshCtxId :: CtxId
+ , stPostFreshProblemId :: ProblemId
+ , stPostFreshInt :: Int
+ }
-- | 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
@@ -142,6 +176,8 @@ data PersistentTCState = PersistentTCSt
, 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.
}
-- | Empty persistent state.
@@ -152,85 +188,259 @@ initPersistentState = PersistentTCSt
, stDecodedModules = Map.empty
, stInteractionOutputCallback = defaultInteractionOutputCallback
, stBenchmark = Benchmark.empty
+ , stAccumStatistics = Map.empty
}
-data FreshThings =
- Fresh { fMeta :: MetaId
- , fInteraction :: InteractionId
- , fMutual :: MutualId
- , fName :: NameId
- , fCtx :: CtxId
- , fProblem :: ProblemId
- , fInt :: Int
- -- ^ Can be used for various things.
- }
- deriving (Show)
-
-- | Empty state of type checker.
+initPreScopeState :: PreScopeState
+initPreScopeState = PreScopeState
+ { stPreTokens = mempty
+ , stPreInteractionPoints = Map.empty
+ , stPreImports = emptySignature
+ , stPreImportedModules = Set.empty
+ , stPreModuleToSource = Map.empty
+ , stPreVisitedModules = Map.empty
+ , stPreScope = emptyScopeInfo
+ , stPrePatternSyns = Map.empty
+ , stPrePatternSynImports = Map.empty
+ , stPrePragmaOptions = defaultInteractionOptions
+ , stPreImportedBuiltins = Map.empty
+ , stPreHaskellImports = Set.empty
+ , stPreFreshInteractionId = 0
+ , stPreFreshNameId = NameId 0 0
+ }
+
+initPostScopeState :: PostScopeState
+initPostScopeState = PostScopeState
+ { stPostSyntaxInfo = mempty
+ , stPostDisambiguatedNames = IntMap.empty
+ , stPostMetaStore = Map.empty
+ , stPostInteractionPoints = Map.empty
+ , stPostAwakeConstraints = []
+ , stPostSleepingConstraints = []
+ , stPostDirty = False
+ , stPostOccursCheckDefs = Set.empty
+ , stPostSignature = emptySignature
+ , stPostCurrentModule = Nothing
+ , stPostInstanceDefs = (Map.empty , [])
+ , stPostStatistics = Map.empty
+ , stPostMutualBlocks = Map.empty
+ , stPostLocalBuiltins = Map.empty
+ , stPostFreshMetaId = 0
+ , stPostFreshMutualId = 0
+ , stPostFreshCtxId = 0
+ , stPostFreshProblemId = 1
+ , stPostFreshInt = 0
+ }
+
initState :: TCState
initState = TCSt
- { stFreshThings = (Fresh 0 0 0 (NameId 0 0) 0 0 0) { fProblem = 1 }
- , stMetaStore = Map.empty
- , stSyntaxInfo = mempty
- , stTokens = mempty
- , stTermErrs = Seq.empty
- , stInteractionPoints = Map.empty
- , stAwakeConstraints = []
- , stSleepingConstraints = []
- , stDirty = False
- , stOccursCheckDefs = Set.empty
- , stSignature = emptySignature
- , stImports = emptySignature
- , stImportedModules = Set.empty
- , stModuleToSource = Map.empty
- , stVisitedModules = Map.empty
- , stCurrentModule = Nothing
- , stScope = emptyScopeInfo
- , stPatternSyns = Map.empty
- , stPatternSynImports = Map.empty
- , stInstanceDefs = (Map.empty , [])
- , stPragmaOptions = defaultInteractionOptions
- , stStatistics = Map.empty
- , stMutualBlocks = Map.empty
- , stLocalBuiltins = Map.empty
- , stImportedBuiltins = Map.empty
- , stHaskellImports = Set.empty
- , stPersistent = initPersistentState
+ { stPreScopeState = initPreScopeState
+ , stPostScopeState = initPostScopeState
+ , stPersistentState = initPersistentState
}
+-- * st-prefixed lenses
+------------------------------------------------------------------------
+
+stTokens :: Lens' CompressedFile TCState
+stTokens f s =
+ f (stPreTokens (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}}
+
+stImports :: Lens' Signature TCState
+stImports f s =
+ f (stPreImports (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}}
+
+stImportedModules :: Lens' (Set ModuleName) TCState
+stImportedModules f s =
+ f (stPreImportedModules (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}}
+
+stModuleToSource :: Lens' ModuleToSource TCState
+stModuleToSource f s =
+ f (stPreModuleToSource (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}}
+
+stVisitedModules :: Lens' VisitedModules TCState
+stVisitedModules f s =
+ f (stPreVisitedModules (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}}
+
+stScope :: Lens' ScopeInfo TCState
+stScope f s =
+ f (stPreScope (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}}
+
+stPatternSyns :: Lens' A.PatternSynDefns TCState
+stPatternSyns f s =
+ f (stPrePatternSyns (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}}
+
+stPatternSynImports :: Lens' A.PatternSynDefns TCState
+stPatternSynImports f s =
+ f (stPrePatternSynImports (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}}
+
+stPragmaOptions :: Lens' PragmaOptions TCState
+stPragmaOptions f s =
+ f (stPrePragmaOptions (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}}
+
+stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState
+stImportedBuiltins f s =
+ f (stPreImportedBuiltins (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}}
+
+stHaskellImports :: Lens' (Set String) TCState
+stHaskellImports f s =
+ f (stPreHaskellImports (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreHaskellImports = x}}
+
+stFreshInteractionId :: Lens' InteractionId TCState
+stFreshInteractionId f s =
+ f (stPreFreshInteractionId (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}
+
+stFreshNameId :: Lens' NameId TCState
+stFreshNameId f s =
+ f (stPreFreshNameId (stPreScopeState s)) <&>
+ \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshNameId = x}}
+
+stSyntaxInfo :: Lens' CompressedFile TCState
+stSyntaxInfo f s =
+ f (stPostSyntaxInfo (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}}
+
+stDisambiguatedNames :: Lens' DisambiguatedNames TCState
+stDisambiguatedNames f s =
+ f (stPostDisambiguatedNames (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}}
+
+stMetaStore :: Lens' MetaStore TCState
+stMetaStore f s =
+ f (stPostMetaStore (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostMetaStore = x}}
+
+stInteractionPoints :: Lens' InteractionPoints TCState
+stInteractionPoints f s =
+ f (stPostInteractionPoints (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}
+
+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}}
+
+stCurrentModule :: Lens' (Maybe ModuleName) TCState
+stCurrentModule f s =
+ f (stPostCurrentModule (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = x}}
+
+stInstanceDefs :: Lens' TempInstanceTable TCState
+stInstanceDefs f s =
+ f (stPostInstanceDefs (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}}
+
+stStatistics :: Lens' Statistics TCState
+stStatistics f s =
+ f (stPostStatistics (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}
+
+stMutualBlocks :: Lens' (Map MutualId (Set QName)) TCState
+stMutualBlocks f s =
+ f (stPostMutualBlocks (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}
+
+stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState
+stLocalBuiltins f s =
+ f (stPostLocalBuiltins (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}}
+
+stFreshMetaId :: Lens' MetaId TCState
+stFreshMetaId f s =
+ f (stPostFreshMetaId (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}}
+
+stFreshMutualId :: Lens' MutualId TCState
+stFreshMutualId f s =
+ f (stPostFreshMutualId (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}}
+
+stFreshCtxId :: Lens' CtxId TCState
+stFreshCtxId f s =
+ f (stPostFreshCtxId (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCtxId = x}}
+
+stFreshProblemId :: Lens' ProblemId TCState
+stFreshProblemId f s =
+ f (stPostFreshProblemId (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}
+
+stFreshInt :: Lens' Int TCState
+stFreshInt f s =
+ f (stPostFreshInt (stPostScopeState s)) <&>
+ \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}}
+
stBuiltinThings :: TCState -> BuiltinThings PrimFun
-stBuiltinThings s = stLocalBuiltins s `Map.union` stImportedBuiltins s
-
-instance HasFresh MetaId FreshThings where
- nextFresh s = (i, s { fMeta = i + 1 })
- where
- i = fMeta s
-
-instance HasFresh MutualId FreshThings where
- nextFresh s = (i, s { fMutual = i + 1 })
- where
- i = fMutual s
-
-instance HasFresh InteractionId FreshThings where
- nextFresh s = (i, s { fInteraction = i + 1 })
- where
- i = fInteraction s
-
-instance HasFresh NameId FreshThings where
- nextFresh s = (i, s { fName = succ i })
- where
- i = fName s
-
-instance HasFresh CtxId FreshThings where
- nextFresh s = (i, s { fCtx = succ i })
- where
- i = fCtx s
-
-instance HasFresh Int FreshThings where
- nextFresh s = (i, s { fInt = succ i })
- where
- i = fInt s
+stBuiltinThings s = (s^.stLocalBuiltins) `Map.union` (s^.stImportedBuiltins)
+
+-- * Fresh things
+------------------------------------------------------------------------
+
+class Enum i => HasFresh i where
+ freshLens :: Lens' i TCState
+
+nextFresh :: HasFresh i => TCState -> (i, TCState)
+nextFresh s =
+ let c = s^.freshLens
+ in (c, set freshLens (succ c) s)
+
+fresh :: (HasFresh i, MonadState TCState m) => m i
+fresh =
+ do c <- use freshLens
+ freshLens .= succ c
+ 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
+
+instance HasFresh CtxId where
+ freshLens = stFreshCtxId
+
+instance HasFresh Int where
+ freshLens = stFreshInt
newtype ProblemId = ProblemId Nat
deriving (Typeable, Eq, Ord, Enum, Real, Integral, Num)
@@ -238,15 +448,37 @@ newtype ProblemId = ProblemId Nat
instance Show ProblemId where
show (ProblemId n) = show n
-instance HasFresh ProblemId FreshThings where
- nextFresh s = (i, s { fProblem = succ i })
- where i = fProblem s
+instance HasFresh ProblemId where
+ freshLens = stFreshProblemId
+
+freshName :: (MonadState TCState m, HasFresh NameId) => Range -> String -> m Name
+freshName r s = do
+ i <- fresh
+ return $ mkName r i s
+
+freshNoName :: (MonadState TCState m, HasFresh NameId) => Range -> m Name
+freshNoName r =
+ do i <- fresh
+ return $ Name i (C.NoName noRange i) r defaultFixity'
+
+freshNoName_ :: (MonadState TCState m, HasFresh NameId) => m Name
+freshNoName_ = freshNoName noRange
-instance HasFresh i FreshThings => HasFresh i TCState where
- nextFresh s = ((,) $! i) $! s { stFreshThings = f }
- where
- (i, f) = nextFresh $ stFreshThings s
+-- | Create a fresh name from @a at .
+class FreshName a where
+ freshName_ :: (MonadState TCState m, HasFresh NameId) => a -> m Name
+instance FreshName (Range, String) where
+ freshName_ = uncurry freshName
+
+instance FreshName String where
+ freshName_ = freshName noRange
+
+instance FreshName Range where
+ freshName_ = freshNoName
+
+instance FreshName () where
+ freshName_ () = freshNoName_
---------------------------------------------------------------------------
-- ** Managing file names
@@ -269,8 +501,7 @@ sourceToModule =
Map.fromList
. List.map (\(m, f) -> (f, m))
. Map.toList
- . stModuleToSource
- <$> get
+ <$> use stModuleToSource
---------------------------------------------------------------------------
-- ** Interface
@@ -298,10 +529,15 @@ data Interface = Interface
, iModuleName :: ModuleName
-- ^ Module name of this interface.
, iScope :: Map ModuleName Scope
+ -- ^ Scope defined by this module.
, iInsideScope :: ScopeInfo
-- ^ Scope after we loaded this interface.
-- Used in 'Agda.Interaction.BasicOps.AtTopLevel'
-- and 'Agda.Interaction.CommandLine.CommandLine.interactionLoop'.
+ --
+ -- Andreas, AIM XX: For performance reason, this field is
+ -- not serialized, so if you deserialize an interface, @iInsideScope@
+ -- will be empty. You need to type-check the file to get @iInsideScope at .
, iSignature :: Signature
, iBuiltin :: BuiltinThings (String, QName)
, iHaskellImports :: Set String
@@ -324,10 +560,10 @@ iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)
---------------------------------------------------------------------------
data Closure a = Closure { clSignature :: Signature
- , clEnv :: TCEnv
- , clScope :: ScopeInfo
- , clValue :: a
- }
+ , clEnv :: TCEnv
+ , clScope :: ScopeInfo
+ , clValue :: a
+ }
deriving (Typeable)
instance Show a => Show (Closure a) where
@@ -339,8 +575,8 @@ instance HasRange a => HasRange (Closure a) where
buildClosure :: a -> TCM (Closure a)
buildClosure x = do
env <- ask
- sig <- gets stSignature
- scope <- gets stScope
+ sig <- use stSignature
+ scope <- use stScope
return $ Closure sig env scope x
---------------------------------------------------------------------------
@@ -439,8 +675,8 @@ data Open a = OpenThing { openThingCtxIds :: [CtxId], openThing :: a }
---------------------------------------------------------------------------
data Judgement t a
- = HasType { jMetaId :: a, jMetaType :: t }
- | IsSort { jMetaId :: a, jMetaType :: t } -- Andreas, 2011-04-26: type needed for higher-order sort metas
+ = HasType { jMetaId :: a, jMetaType :: t }
+ | IsSort { jMetaId :: a, jMetaType :: t } -- Andreas, 2011-04-26: type needed for higher-order sort metas
deriving (Typeable, Functor, Foldable, Traversable)
instance (Show t, Show a) => Show (Judgement t a) where
@@ -452,17 +688,17 @@ instance (Show t, Show a) => Show (Judgement t a) where
---------------------------------------------------------------------------
data MetaVariable =
- MetaVar { mvInfo :: MetaInfo
- , mvPriority :: MetaPriority -- ^ some metavariables are more eager to be instantiated
+ 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 Type MetaId
- , mvInstantiation :: MetaInstantiation
- , mvListeners :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one
+ , mvJudgement :: Judgement Type MetaId
+ , mvInstantiation :: MetaInstantiation
+ , mvListeners :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one
, mvFrozen :: Frozen -- ^ are we past the point where we can instantiate this meta variable?
- }
+ }
deriving (Typeable)
data Listener = EtaExpand MetaId
@@ -490,11 +726,11 @@ data Frozen
deriving (Eq, Show)
data MetaInstantiation
- = InstV Term -- ^ solved by term
- | InstS Term -- ^ solved by @Lam .. Sort s@
- | Open -- ^ unsolved
- | OpenIFS -- ^ open, to be instantiated as "implicit from scope"
- | BlockedConst Term -- ^ solution blocked by unsolved constraints
+ = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)
+ | InstS Term -- ^ solved by @Lam .. Sort s@
+ | Open -- ^ unsolved
+ | OpenIFS -- ^ open, to be instantiated as "implicit from scope"
+ | BlockedConst Term -- ^ solution blocked by unsolved constraints
| PostponedTypeCheckingProblem (Closure TypeCheckingProblem) (TCM Bool)
deriving (Typeable)
@@ -504,7 +740,7 @@ data TypeCheckingProblem
deriving (Typeable)
instance Show MetaInstantiation where
- show (InstV t) = "InstV (" ++ show t ++ ")"
+ show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"
show (InstS s) = "InstS (" ++ show s ++ ")"
show Open = "Open"
show OpenIFS = "OpenIFS"
@@ -615,17 +851,17 @@ data Signature = Sig
}
deriving (Typeable, Show)
-type Sections = Map ModuleName Section
+type Sections = Map ModuleName Section
type Definitions = HashMap QName Definition
data Section = Section
{ secTelescope :: Telescope
- , secFreeVars :: Nat -- ^ This is the number of parameters when
- -- we're inside the section and 0
- -- outside. It's used to know how much of
- -- the context to apply function from the
- -- section to when translating from
- -- abstract to internal syntax.
+ , secFreeVars :: Nat -- ^ This is the number of parameters when
+ -- we're inside the section and 0
+ -- outside. It's used to know how much of
+ -- the context to apply function from the
+ -- section to when translating from
+ -- abstract to internal syntax.
}
deriving (Typeable, Show)
@@ -666,7 +902,7 @@ data DisplayTerm
-- The list of 'DisplayTerm's are the with expressions @ws at .
-- The 'Args' are additional arguments @us@
-- (possible in case the with-application is of function type).
- | DCon QName [Arg DisplayTerm]
+ | DCon ConHead [Arg DisplayTerm]
-- ^ @c vs at .
| DDef QName [Arg DisplayTerm]
-- ^ @d vs at .
@@ -680,8 +916,11 @@ data DisplayTerm
defaultDisplayForm :: QName -> [Open DisplayForm]
defaultDisplayForm c = []
+defRelevance :: Definition -> Relevance
defRelevance = argInfoRelevance . defArgInfo
-defColors = argInfoColors . defArgInfo
+
+defColors :: Definition -> [Color]
+defColors = argInfoColors . defArgInfo
type RewriteRules = [RewriteRule]
@@ -699,7 +938,7 @@ data RewriteRule = RewriteRule
data Definition = Defn
{ defArgInfo :: ArgInfo -- ^ Hiding should not be used.
, defName :: QName
- , defType :: Type -- ^ Type of the lifted definition.
+ , defType :: Type -- ^ Type of the lifted definition.
, defPolarity :: [Polarity]
, defArgOccurrences :: [Occurrence]
, defDisplay :: [Open DisplayForm]
@@ -801,7 +1040,7 @@ data Projection = Projection
data Defn = Axiom
-- ^ Postulate.
- | Function
+ | Function
{ funClauses :: [Clause]
, funCompiled :: Maybe CompiledClauses
-- ^ 'Nothing' while function is still type-checked.
@@ -834,8 +1073,10 @@ data Defn = Axiom
, funWith :: Maybe QName
-- ^ Is this a generated with-function? If yes, then what's the
-- name of the parent function.
+ , funCopatternLHS :: Bool
+ -- ^ Is this a function defined by copatterns?
}
- | Datatype
+ | Datatype
{ dataPars :: Nat -- ^ Number of parameters.
, dataSmallPars :: Permutation -- ^ Parameters that are maybe small.
, dataNonLinPars :: Drop Permutation -- ^ Parameters that appear in indices.
@@ -847,7 +1088,7 @@ data Defn = Axiom
, dataMutual :: [QName] -- ^ Mutually recursive functions, @data at s and @record at s. Does not include this data type.
, dataAbstr :: IsAbstract
}
- | Record
+ | Record
{ recPars :: Nat -- ^ Number of parameters.
, recClause :: Maybe Clause
, recConHead :: ConHead -- ^ Constructor name and fields.
@@ -866,14 +1107,14 @@ data Defn = Axiom
, recRecursive :: Bool -- ^ Recursive record. Implies @recEtaEquality = False at . Projections are not size-preserving.
, recAbstr :: IsAbstract
}
- | Constructor
+ | Constructor
{ conPars :: Nat -- ^ Number of parameters.
- , conSrcCon :: ConHead -- ^ Name of (original) constructor and fields. (This might be in a module instance.)
- , conData :: QName -- ^ Name of datatype or record type.
- , conAbstr :: IsAbstract
+ , 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?
}
- | Primitive
+ | Primitive
{ primAbstr :: IsAbstract
, primName :: String
, primClauses :: [Clause]
@@ -900,8 +1141,11 @@ emptyFunction = Function
, funTerminates = Nothing
, funExtLam = Nothing
, funWith = Nothing
+ , funCopatternLHS = False
}
+isCopatternLHS :: [Clause] -> Bool
+isCopatternLHS = List.any (List.any (isJust . A.isProjP) . clausePats)
recCon :: Defn -> QName
recCon Record{ recConHead } = conName recConHead
@@ -979,10 +1223,10 @@ allReductions :: AllowedReductions
allReductions = [minBound..pred maxBound]
data PrimFun = PrimFun
- { primFunName :: QName
- , primFunArity :: Arity
- , primFunImplementation :: [Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)
- }
+ { primFunName :: QName
+ , primFunArity :: Arity
+ , primFunImplementation :: [Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)
+ }
deriving (Typeable)
defClauses :: Definition -> [Clause]
@@ -1048,7 +1292,7 @@ data TermHead = SortHead
---------------------------------------------------------------------------
newtype MutualId = MutId Int32
- deriving (Typeable, Eq, Ord, Show, Num)
+ deriving (Typeable, Eq, Ord, Show, Num, Enum)
---------------------------------------------------------------------------
-- ** Statistics
@@ -1061,31 +1305,31 @@ type Statistics = Map String Integer
---------------------------------------------------------------------------
data Call = CheckClause Type A.SpineClause (Maybe Clause)
- | forall a. CheckPattern A.Pattern Telescope Type (Maybe a)
- | CheckLetBinding A.LetBinding (Maybe ())
- | InferExpr A.Expr (Maybe (Term, Type))
- | CheckExprCall A.Expr Type (Maybe Term)
- | CheckDotPattern A.Expr Term (Maybe Constraints)
- | CheckPatternShadowing A.SpineClause (Maybe ())
- | IsTypeCall A.Expr Sort (Maybe Type)
- | IsType_ A.Expr (Maybe Type)
- | InferVar Name (Maybe (Term, Type))
- | InferDef Range QName (Maybe (Term, Type))
- | CheckArguments Range [NamedArg A.Expr] Type Type (Maybe (Args, Type))
- | CheckDataDef Range Name [A.LamBinding] [A.Constructor] (Maybe ())
- | CheckRecDef Range Name [A.LamBinding] [A.Constructor] (Maybe ())
- | CheckConstructor QName Telescope Sort A.Constructor (Maybe ())
- | CheckFunDef Range Name [A.Clause] (Maybe ())
- | CheckPragma Range A.Pragma (Maybe ())
- | CheckPrimitive Range Name A.Expr (Maybe ())
+ | forall a. CheckPattern A.Pattern Telescope Type (Maybe a)
+ | CheckLetBinding A.LetBinding (Maybe ())
+ | InferExpr A.Expr (Maybe (Term, Type))
+ | CheckExprCall A.Expr Type (Maybe Term)
+ | CheckDotPattern A.Expr Term (Maybe Constraints)
+ | CheckPatternShadowing A.SpineClause (Maybe ())
+ | IsTypeCall A.Expr Sort (Maybe Type)
+ | IsType_ A.Expr (Maybe Type)
+ | InferVar Name (Maybe (Term, Type))
+ | InferDef Range QName (Maybe (Term, Type))
+ | CheckArguments Range [NamedArg A.Expr] Type Type (Maybe (Args, Type))
+ | CheckDataDef Range Name [A.LamBinding] [A.Constructor] (Maybe ())
+ | CheckRecDef Range Name [A.LamBinding] [A.Constructor] (Maybe ())
+ | CheckConstructor QName Telescope Sort A.Constructor (Maybe ())
+ | CheckFunDef Range Name [A.Clause] (Maybe ())
+ | CheckPragma Range A.Pragma (Maybe ())
+ | CheckPrimitive Range Name A.Expr (Maybe ())
| CheckIsEmpty Range Type (Maybe ())
| CheckWithFunctionType A.Expr (Maybe ())
| CheckSectionApplication Range ModuleName A.ModuleApplication (Maybe ())
- | ScopeCheckExpr C.Expr (Maybe A.Expr)
- | ScopeCheckDeclaration D.NiceDeclaration (Maybe [A.Declaration])
- | ScopeCheckLHS C.Name C.Pattern (Maybe A.LHS)
+ | ScopeCheckExpr C.Expr (Maybe A.Expr)
+ | ScopeCheckDeclaration D.NiceDeclaration (Maybe [A.Declaration])
+ | ScopeCheckLHS C.Name C.Pattern (Maybe A.LHS)
| forall a. NoHighlighting (Maybe a)
- | forall a. SetRange Range (Maybe a) -- ^ used by 'setCurrentRange'
+ | forall a. SetRange Range (Maybe a) -- ^ used by 'setCurrentRange'
deriving (Typeable)
instance HasRange Call where
@@ -1155,8 +1399,8 @@ data BuiltinInfo =
type BuiltinThings pf = Map String (Builtin pf)
data Builtin pf
- = Builtin Term
- | Prim pf
+ = Builtin Term
+ | Prim pf
deriving (Typeable, Show, Functor, Foldable, Traversable)
---------------------------------------------------------------------------
@@ -1201,24 +1445,25 @@ ifTopLevelAndHighlightingLevelIs l m = do
data TCEnv =
TCEnv { envContext :: Context
- , envLetBindings :: LetBindings
- , envCurrentModule :: ModuleName
- , envCurrentPath :: AbsolutePath
+ , envLetBindings :: LetBindings
+ , envCurrentModule :: ModuleName
+ , envCurrentPath :: AbsolutePath
-- ^ The path to the file that is currently being
-- type-checked.
, envAnonymousModules :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables
- , envImportPath :: [C.TopLevelModuleName] -- ^ to detect import cycles
- , envMutualBlock :: Maybe MutualId -- ^ the current (if any) mutual block
+ , envImportPath :: [C.TopLevelModuleName] -- ^ to detect import cycles
+ , envMutualBlock :: Maybe MutualId -- ^ the current (if any) mutual block
+ , envTerminationCheck :: TerminationCheck () -- ^ are we inside the scope of a termination pragma
, envSolvingConstraints :: Bool
-- ^ Are we currently in the process of solving active constraints?
, envAssignMetas :: Bool
-- ^ Are we allowed to assign metas?
, envActiveProblems :: [ProblemId]
- , envAbstractMode :: AbstractMode
- -- ^ When checking the typesignature of a public definition
- -- or the body of a non-abstract definition this is true.
- -- To prevent information about abstract things leaking
- -- outside the module.
+ , envAbstractMode :: AbstractMode
+ -- ^ When checking the typesignature of a public definition
+ -- or the body of a non-abstract definition this is true.
+ -- To prevent information about abstract things leaking
+ -- outside the module.
, envRelevance :: Relevance
-- ^ Are we checking an irrelevant argument? (=@Irrelevant@)
-- Then top-level irrelevant declarations are enabled.
@@ -1283,21 +1528,22 @@ data TCEnv =
-- ^ The rules for translating internal to abstract syntax are
-- slightly different when the internal term comes from an
-- unquote.
- }
+ }
deriving (Typeable)
initEnv :: TCEnv
-initEnv = TCEnv { envContext = []
- , envLetBindings = Map.empty
- , envCurrentModule = noModuleName
- , envCurrentPath = __IMPOSSIBLE__
+initEnv = TCEnv { envContext = []
+ , envLetBindings = Map.empty
+ , envCurrentModule = noModuleName
+ , envCurrentPath = __IMPOSSIBLE__
, envAnonymousModules = []
- , envImportPath = []
- , envMutualBlock = Nothing
+ , envImportPath = []
+ , envMutualBlock = Nothing
+ , envTerminationCheck = TerminationCheck
, envSolvingConstraints = False
, envActiveProblems = [0]
, envAssignMetas = True
- , envAbstractMode = ConcreteMode
+ , 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
@@ -1326,20 +1572,20 @@ initEnv = TCEnv { envContext = []
, envPrintDomainFreePi = False
, envInsideDotPattern = False
, envReifyUnquoted = False
- }
+ }
---------------------------------------------------------------------------
-- ** Context
---------------------------------------------------------------------------
-- | The @Context@ is a stack of 'ContextEntry's.
-type Context = [ContextEntry]
-data ContextEntry = Ctx { ctxId :: CtxId
- , ctxEntry :: Dom (Name, Type)
- }
+type Context = [ContextEntry]
+data ContextEntry = Ctx { ctxId :: CtxId
+ , ctxEntry :: Dom (Name, Type)
+ }
deriving (Typeable)
-newtype CtxId = CtxId Nat
+newtype CtxId = CtxId Nat
deriving (Typeable, Eq, Ord, Show, Enum, Real, Integral, Num)
---------------------------------------------------------------------------
@@ -1377,10 +1623,10 @@ data ExpandInstances
---------------------------------------------------------------------------
-- Occurence of a name in a datatype definition
-data Occ = OccCon { occDatatype :: QName
- , occConstructor :: QName
- , occPosition :: OccPos
- }
+data Occ = OccCon { occDatatype :: QName
+ , occConstructor :: QName
+ , occPosition :: OccPos
+ }
| OccClause { occFunction :: QName
, occClause :: Int
, occPosition :: OccPos
@@ -1404,9 +1650,8 @@ data CallInfo = CallInfo
-- no Eq, Ord instances: too expensive! (see issues 851, 852)
-- | We only 'show' the name of the callee.
-instance Show CallInfo where show = show . callInfoTarget
-
-instance Pretty CallInfo where pretty = text . show . callInfoTarget
+instance Show CallInfo where show = show . callInfoTarget
+instance Pretty CallInfo where pretty = text . show
-- | Information about a mutual block which did not pass the
-- termination checker.
@@ -1434,29 +1679,43 @@ instance Error SplitError where
noMsg = strMsg ""
strMsg = GenericSplitError
+data UnquoteError
+ = BadVisibility String (I.Arg I.Term)
+ | ConInsteadOfDef QName String String
+ | DefInsteadOfCon QName String String
+ | NotAConstructor String I.Term -- ^ @NotAConstructor kind term@
+ | NotALiteral String I.Term
+ | RhsUsesDottedVar [Int] I.Term
+ | BlockedOnMeta MetaId
+ | UnquotePanic String
+ deriving (Show)
+
+instance Error UnquoteError where
+ strMsg msg = UnquotePanic msg
+
data TypeError
- = InternalError String
- | NotImplemented String
- | NotSupported String
+ = InternalError String
+ | NotImplemented String
+ | NotSupported String
| CompilationError String
- | TerminationCheckFailed [TerminationError]
- | PropMustBeSingleton
- | DataMustEndInSort Term
+ | TerminationCheckFailed [TerminationError]
+ | PropMustBeSingleton
+ | DataMustEndInSort Term
{- UNUSED
| DataTooManyParameters
-- ^ In @data D xs where@ the number of parameters @xs@ does not fit the
-- the parameters given in the forward declaraion @data D Gamma : T at .
-}
- | 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
+ | ShouldEndInApplicationOfTheDatatype Type
+ -- ^ The target of a constructor isn't an application of its
+ -- datatype. The 'Type' records what it does target.
+ | ShouldBeAppliedToTheDatatypeParameters Term Term
+ -- ^ The target of a constructor isn't its datatype applied to
+ -- something that isn't the parameters. First term is the correct
+ -- target and the second term is the actual target.
+ | ShouldBeApplicationOf Type QName
+ -- ^ Expected a type to be an application of a particular datatype.
+ | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype
| IndicesNotConstructorApplications [Arg Term] -- ^ Indices.
| IndexVariablesNotDistinct [Nat] [Arg Term] -- ^ Variables, indices.
| IndicesFreeInParameters [Nat] [Arg Term] [Arg Term]
@@ -1466,42 +1725,42 @@ data TypeError
| CantResolveOverloadedConstructorsTargetingSameDatatype QName [QName]
-- ^ Datatype, constructors.
| DoesNotConstructAnElementOf QName Type -- ^ constructor, type
- | DifferentArities
- -- ^ Varying number of arguments for a function.
- | WrongHidingInLHS
- -- ^ The left hand side of a function definition has a hidden argument
- -- where a non-hidden was expected.
- | WrongHidingInLambda Type
- -- ^ Expected a non-hidden function and found a hidden lambda.
- | WrongHidingInApplication Type
- -- ^ A function is applied to a hidden argument where a non-hidden was expected.
+ | DifferentArities
+ -- ^ Varying number of arguments for a function.
+ | WrongHidingInLHS
+ -- ^ The left hand side of a function definition has a hidden argument
+ -- where a non-hidden was expected.
+ | WrongHidingInLambda Type
+ -- ^ Expected a non-hidden function and found a hidden lambda.
+ | WrongHidingInApplication Type
+ -- ^ A function is applied to a hidden argument where a non-hidden was expected.
| WrongNamedArgument (I.NamedArg A.Expr)
-- ^ A function is applied to a hidden named argument it does not have.
- | WrongIrrelevanceInLambda Type
- -- ^ Expected a relevant function and found an irrelevant lambda.
+ | WrongIrrelevanceInLambda Type
+ -- ^ Expected a relevant function and found an irrelevant lambda.
| 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.
| ColorMismatch [Color] [Color]
-- ^ The given color does not correspond to the expected color.
- | NotInductive Term
+ | NotInductive Term
-- ^ The term does not correspond to an inductive data type.
- | UninstantiatedDotPattern A.Expr
- | IlltypedPattern A.Pattern Type
- | IllformedProjectionPattern A.Pattern
- | CannotEliminateWithPattern (A.NamedArg A.Pattern) Type
- | TooManyArgumentsInLHS Type
- | WrongNumberOfConstructorArguments QName Nat Nat
- | ShouldBeEmpty Type [Pattern]
- | ShouldBeASort Type
- -- ^ The given type should have been a sort.
- | ShouldBePi Type
- -- ^ The given type should have been a pi.
- | ShouldBeRecordType Type
- | ShouldBeRecordPattern Pattern
+ | UninstantiatedDotPattern A.Expr
+ | IlltypedPattern A.Pattern Type
+ | IllformedProjectionPattern A.Pattern
+ | CannotEliminateWithPattern (A.NamedArg A.Pattern) Type
+ | TooManyArgumentsInLHS Type
+ | WrongNumberOfConstructorArguments QName Nat Nat
+ | ShouldBeEmpty Type [Pattern]
+ | ShouldBeASort Type
+ -- ^ The given type should have been a sort.
+ | ShouldBePi Type
+ -- ^ The given type should have been a pi.
+ | ShouldBeRecordType Type
+ | ShouldBeRecordPattern Pattern
| NotAProjectionPattern (A.NamedArg A.Pattern)
- | NotAProperTerm
+ | NotAProperTerm
| SetOmegaNotValidType
| InvalidType Term
-- ^ This term is not a type expression.
@@ -1509,49 +1768,50 @@ data TypeError
| DefinitionIsIrrelevant QName
| VariableIsIrrelevant Name
-- | UnequalLevel Comparison Term Term -- UNUSED
- | UnequalTerms Comparison Term Term Type
- | UnequalTypes Comparison Type Type
--- | UnequalTelescopes Comparison Telescope Telescope -- UNUSED
- | UnequalRelevance Comparison Term Term
- -- ^ The two function types have different relevance.
- | UnequalHiding Term Term
- -- ^ The two function types have different hiding.
- | UnequalColors Term Term
- -- ^ The two function types have different color.
- | UnequalSorts Sort Sort
+ | UnequalTerms Comparison Term Term Type
+ | UnequalTypes Comparison Type Type
+-- | UnequalTelescopes Comparison Telescope Telescope -- UNUSED
+ | UnequalRelevance Comparison Term Term
+ -- ^ The two function types have different relevance.
+ | UnequalHiding Term Term
+ -- ^ The two function types have different hiding.
+ | UnequalColors Term Term
+ -- ^ The two function types have different color.
+ | UnequalSorts Sort Sort
| UnequalBecauseOfUniverseConflict Comparison Term Term
| HeterogeneousEquality Term Type Term Type
-- ^ We ended up with an equality constraint where the terms
-- have different types. This is not supported.
- | NotLeqSort Sort Sort
- | MetaCannotDependOn MetaId [Nat] Nat
- -- ^ The arguments are the meta variable, the parameters it can
- -- depend on and the paratemeter that it wants to depend on.
- | MetaOccursInItself MetaId
- | GenericError String
- | GenericDocError Doc
+ | NotLeqSort Sort Sort
+ | MetaCannotDependOn MetaId [Nat] Nat
+ -- ^ The arguments are the meta variable, the parameters it can
+ -- depend on and the paratemeter that it wants to depend on.
+ | MetaOccursInItself MetaId
+ | GenericError String
+ | GenericDocError Doc
| BuiltinMustBeConstructor String A.Expr
- | NoSuchBuiltinName String
- | DuplicateBuiltinBinding String Term Term
- | NoBindingForBuiltin String
- | NoSuchPrimitiveFunction String
+ | NoSuchBuiltinName String
+ | DuplicateBuiltinBinding String Term Term
+ | NoBindingForBuiltin String
+ | NoSuchPrimitiveFunction String
| ShadowedModule C.Name [A.ModuleName]
- | BuiltinInParameterisedModule String
+ | BuiltinInParameterisedModule String
| IllegalLetInTelescope C.TypedBinding
- | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]
- | AbsurdPatternRequiresNoRHS [NamedArg A.Pattern]
- | TooFewFields QName [C.Name]
- | TooManyFields QName [C.Name]
- | DuplicateFields [C.Name]
- | DuplicateConstructors [C.Name]
- | UnexpectedWithPatterns [A.Pattern]
- | WithClausePatternMismatch A.Pattern Pattern
+ | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]
+ | AbsurdPatternRequiresNoRHS [NamedArg A.Pattern]
+ | TooFewFields QName [C.Name]
+ | TooManyFields QName [C.Name]
+ | DuplicateFields [C.Name]
+ | DuplicateConstructors [C.Name]
+ | WithOnFreeVariable A.Expr
+ | UnexpectedWithPatterns [A.Pattern]
+ | WithClausePatternMismatch A.Pattern Pattern
| FieldOutsideRecord
| ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]
-- Coverage errors
-- TODO: Remove some of the constructors in this section, now that
-- the SplitError constructor has been added?
- | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off
+ | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off
| CoverageFailure QName [[Arg Pattern]]
| UnreachableClauses QName [[Arg Pattern]]
| CoverageCantSplitOn QName Telescope Args Args
@@ -1560,62 +1820,73 @@ data TypeError
| WithoutKError Type Term Term
| SplitError SplitError
-- Positivity errors
- | NotStrictlyPositive QName [Occ]
+ | NotStrictlyPositive QName [Occ]
-- Import errors
- | LocalVsImportedModuleClash ModuleName
- | UnsolvedMetas [Range]
- | UnsolvedConstraints Constraints
- | CyclicModuleDependency [C.TopLevelModuleName]
- | FileNotFound C.TopLevelModuleName [AbsolutePath]
+ | LocalVsImportedModuleClash ModuleName
+ | UnsolvedMetas [Range]
+ | UnsolvedConstraints Constraints
+ | SolvedButOpenHoles
+ -- ^ Some interaction points (holes) have not be 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]
- | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]
- | ClashingFileNamesFor ModuleName [AbsolutePath]
+ | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]
+ | ClashingFileNamesFor ModuleName [AbsolutePath]
| ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath
-- ^ Module name, file from which it was loaded, file which
-- the include path says contains the module.
-- Scope errors
- | BothWithAndRHS
- | NotInScope [C.QName]
- | NoSuchModule C.QName
- | AmbiguousName C.QName [A.QName]
- | AmbiguousModule C.QName [A.ModuleName]
- | UninstantiatedModule C.QName
- | ClashingDefinition C.QName A.QName
- | ClashingModule A.ModuleName A.ModuleName
- | ClashingImport C.Name A.QName
- | ClashingModuleImport C.Name A.ModuleName
- | PatternShadowsConstructor A.Name A.QName
- | ModuleDoesntExport C.QName [C.ImportedName]
+ | BothWithAndRHS
+ | NotInScope [C.QName]
+ | NoSuchModule C.QName
+ | AmbiguousName C.QName [A.QName]
+ | AmbiguousModule C.QName [A.ModuleName]
+ | UninstantiatedModule C.QName
+ | ClashingDefinition C.QName A.QName
+ | ClashingModule A.ModuleName A.ModuleName
+ | ClashingImport C.Name A.QName
+ | ClashingModuleImport C.Name A.ModuleName
+ | PatternShadowsConstructor A.Name A.QName
+ | ModuleDoesntExport C.QName [C.ImportedName]
| DuplicateImports C.QName [C.ImportedName]
- | InvalidPattern C.Pattern
- | RepeatedVariablesInPattern [C.Name]
+ | InvalidPattern C.Pattern
+ | RepeatedVariablesInPattern [C.Name]
-- Concrete to Abstract errors
- | NotAModuleExpr C.Expr
- -- ^ The expr was used in the right hand side of an implicit module
- -- definition, but it wasn't of the form @m Delta at .
- | NotAnExpression C.Expr
- | NotAValidLetBinding D.NiceDeclaration
- | NothingAppliedToHiddenArg C.Expr
- | NothingAppliedToInstanceArg C.Expr
+ | 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 at .
+ | NotAnExpression C.Expr
+ | NotAValidLetBinding D.NiceDeclaration
+ | NothingAppliedToHiddenArg C.Expr
+ | NothingAppliedToInstanceArg C.Expr
+ -- Pattern synonym errors
+ | BadArgumentsToPatternSynonym A.QName
+ | TooFewArgumentsToPatternSynonym A.QName
| UnusedVariableInPatternSynonym
- | PatternSynonymArityMismatch A.QName
-- Operator errors
- | NoParseForApplication [C.Expr]
- | AmbiguousParseForApplication [C.Expr] [C.Expr]
- | NoParseForLHS LHSOrPatSyn C.Pattern
- | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]
+ | NoParseForApplication [C.Expr]
+ | AmbiguousParseForApplication [C.Expr] [C.Expr]
+ | NoParseForLHS LHSOrPatSyn C.Pattern
+ | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]
{- UNUSED
- | NoParseForPatternSynonym C.Pattern
- | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]
+ | NoParseForPatternSynonym C.Pattern
+ | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]
-}
-- Usage errors
-- Implicit From Scope errors
| IFSNoCandidateInScope Type
+ -- Reflection errors
+ | UnquoteFailed UnquoteError
-- Safe flag errors
| SafeFlagPostulate C.Name
| SafeFlagPragma [String]
| SafeFlagNoTerminationCheck
+ | SafeFlagNonTerminating
+ | SafeFlagTerminating
| SafeFlagPrimTrustMe
-- Language option errors
| NeedOptionCopatterns
@@ -1634,10 +1905,10 @@ instance Error TypeError where
-- | Type-checking errors.
data TCErr = TypeError TCState (Closure TypeError)
- | Exception Range String
+ | Exception Range String
| IOException Range E.IOException
- | PatternErr TCState -- ^ for pattern violations
- {- AbortAssign TCState -- ^ used to abort assignment to meta when there are instantiations -- UNUSED -}
+ | PatternErr -- TCState -- ^ for pattern violations
+ {- AbortAssign TCState -- ^ used to abort assignment to meta when there are instantiations -- UNUSED -}
deriving (Typeable)
instance Error TCErr where
@@ -1648,14 +1919,14 @@ instance Show TCErr where
show (TypeError _ e) = show (envRange $ clEnv e) ++ ": " ++ show (clValue e)
show (Exception r s) = show r ++ ": " ++ s
show (IOException r e) = show r ++ ": " ++ show e
- show (PatternErr _) = "Pattern violation (you shouldn't see this)"
+ show PatternErr{} = "Pattern violation (you shouldn't see this)"
{- show (AbortAssign _) = "Abort assignment (you shouldn't see this)" -- UNUSED -}
instance HasRange TCErr where
getRange (TypeError _ cl) = envRange $ clEnv cl
getRange (Exception r _) = r
getRange (IOException r _) = r
- getRange (PatternErr s) = noRange
+ getRange PatternErr{} = noRange
{- getRange (AbortAssign s) = noRange -- UNUSED -}
instance Exception TCErr
@@ -1729,10 +2000,13 @@ instance MonadError TCErr (TCMT IO) where
oldState <- liftIO (readIORef r)
unTCM m r e `E.catch` \err -> do
-- Reset the state, but do not forget changes to the persistent
- -- component.
- liftIO $ do
- newState <- readIORef r
- writeIORef r $ oldState { stPersistent = stPersistent newState }
+ -- 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
-- | Preserve the state of the failing computation.
@@ -1757,7 +2031,7 @@ instance MonadIO m => MonadTCM (TCMT m) where
instance MonadTCM tcm => MonadTCM (MaybeT tcm) where
liftTCM = lift . liftTCM
-instance (Error err, MonadTCM tcm) => MonadTCM (ErrorT err tcm) where
+instance (Error err, MonadTCM tcm) => MonadTCM (ExceptT err tcm) where
liftTCM = lift . liftTCM
instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm) where
@@ -1834,9 +2108,7 @@ instance MonadIO m => MonadIO (TCMT m) where
handleException r s = throwIO $ Exception r s
patternViolation :: TCM a
-patternViolation = do
- s <- get
- throwError $ PatternErr s
+patternViolation = throwError PatternErr
internalError :: MonadTCM tcm => String -> tcm a
internalError s = typeError $ InternalError s
@@ -1901,12 +2173,13 @@ forkTCM m = do
-- | Base name for extended lambda patterns
-extendlambdaname = ".extendedlambda"
+extendedLambdaName :: String
+extendedLambdaName = ".extendedlambda"
-- | Name of absurdLambda definitions.
+absurdLambdaName :: String
absurdLambdaName = ".absurdlambda"
-- | Check whether we have an definition from an absurd lambda.
isAbsurdLambdaName :: QName -> Bool
-isAbsurdLambdaName (QName _ x) | show x == absurdLambdaName = True
-isAbsurdLambdaName _ = False
+isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName
diff --git a/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs b/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs
index ce38919..b3df15a 100644
--- a/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs
+++ b/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs
@@ -3,6 +3,7 @@
module Agda.TypeChecking.Monad.Base.Benchmark where
import Agda.Utils.Trie as Trie
+import Agda.Utils.Time (CPUTime)
-- | Phases to allocate CPU time to.
data Phase
@@ -46,6 +47,10 @@ data Phase
-- ^ Subphase for 'Import'.
| Sort
-- ^ Subphase for 'Serialize'.
+ | BinaryEncode
+ -- ^ Subphase for 'Serialize'.
+ | Compress
+ -- ^ Subphase for 'Serialize'.
| Operators
-- ^ Subphase for 'Parsing'.
| BuildParser
@@ -53,12 +58,10 @@ data Phase
deriving (Eq, Ord, Show, Enum, Bounded)
-- | Account we can bill computation time to.
+-- A word of 'Phase's.
type Account = [Phase]
--- | We measure CPU time spent on certain tasks.
-type CPUTime = Integer
-
--- | Benchmark structure is a trie, mapping phases (and subphases)
+-- | Benchmark structure is a trie, mapping accounts (phases and subphases)
-- to CPU time spent on their performance.
type Benchmark = Trie Phase CPUTime
diff --git a/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs b/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs
index d7707c1..0819b0d 100644
--- a/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs
+++ b/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, OverlappingInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-- | 'KillRange' instances for data structures from 'Agda.TypeChecking.Monad.Base'.
@@ -44,8 +46,8 @@ instance KillRange Defn where
killRange def =
case def of
Axiom -> Axiom
- Function cls comp inv mut isAbs delayed proj static copy term extlam with ->
- killRange12 Function cls comp inv mut isAbs delayed proj static copy term extlam with
+ Function cls comp inv mut isAbs delayed proj static copy term extlam with cop ->
+ killRange13 Function cls comp inv mut isAbs delayed proj static copy term extlam with cop
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 -> killRange12 Record a b c d e f g h i j k l
Constructor a b c d e -> killRange5 Constructor a b c d e
diff --git a/src/full/Agda/TypeChecking/Monad/Benchmark.hs b/src/full/Agda/TypeChecking/Monad/Benchmark.hs
index 9b66629..3c93221 100644
--- a/src/full/Agda/TypeChecking/Monad/Benchmark.hs
+++ b/src/full/Agda/TypeChecking/Monad/Benchmark.hs
@@ -22,7 +22,7 @@ import Agda.Utils.Monad
import Agda.Utils.Pretty (Doc)
import Agda.Utils.Time
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Check whether benchmarking is activated.
diff --git a/src/full/Agda/TypeChecking/Monad/Builtin.hs b/src/full/Agda/TypeChecking/Monad/Builtin.hs
index 2f3e7a7..6dc09d0 100644
--- a/src/full/Agda/TypeChecking/Monad/Builtin.hs
+++ b/src/full/Agda/TypeChecking/Monad/Builtin.hs
@@ -3,7 +3,6 @@
module Agda.TypeChecking.Monad.Builtin where
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.State
import Data.Functor
@@ -16,11 +15,13 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Substitute
+import Agda.Utils.Except ( Error, MonadError(catchError) )
+import Agda.Utils.Lens
import Agda.Utils.Monad (when_)
import Agda.Utils.Maybe
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
class (Functor m, Applicative m, Monad m) => HasBuiltins m where
@@ -28,7 +29,7 @@ class (Functor m, Applicative m, Monad m) => HasBuiltins m where
litType :: Literal -> TCM Type
litType l = case l of
- LitInt _ n -> do
+ LitInt _ n -> do
primZero
when_ (n > 0) $ primSuc
el <$> primNat
@@ -40,26 +41,23 @@ litType l = case l of
el t = El (mkType 0) t
instance MonadIO m => HasBuiltins (TCMT m) where
- getBuiltinThing b = liftM2 mplus (Map.lookup b <$> gets stLocalBuiltins)
- (Map.lookup b <$> gets stImportedBuiltins)
+ getBuiltinThing b = liftM2 mplus (Map.lookup b <$> use stLocalBuiltins)
+ (Map.lookup b <$> use stImportedBuiltins)
setBuiltinThings :: BuiltinThings PrimFun -> TCM ()
-setBuiltinThings b = modify $ \s -> s { stLocalBuiltins = b }
+setBuiltinThings b = stLocalBuiltins .= b
bindBuiltinName :: String -> Term -> TCM ()
bindBuiltinName b x = do
- builtin <- getBuiltinThing b
- case builtin of
- Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x
- Just (Prim _) -> typeError $ NoSuchBuiltinName b
- Nothing -> modify $ \st ->
- st { stLocalBuiltins =
- Map.insert b (Builtin x) $ stLocalBuiltins st
- }
+ builtin <- getBuiltinThing b
+ case builtin of
+ Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x
+ Just (Prim _) -> typeError $ NoSuchBuiltinName b
+ Nothing -> stLocalBuiltins %= Map.insert b (Builtin x)
bindPrimitive :: String -> PrimFun -> TCM ()
bindPrimitive b pf = do
- builtin <- gets stLocalBuiltins
+ builtin <- use stLocalBuiltins
setBuiltinThings $ Map.insert b (Prim pf) builtin
getBuiltin :: String -> TCM Term
@@ -70,8 +68,8 @@ getBuiltin' :: HasBuiltins m => String -> m (Maybe Term)
getBuiltin' x = do
builtin <- getBuiltinThing x
case builtin of
- Just (Builtin t) -> return $ Just (killRange t)
- _ -> return Nothing
+ Just (Builtin t) -> return $ Just (killRange t)
+ _ -> return Nothing
getPrimitive' :: HasBuiltins m => String -> m (Maybe PrimFun)
getPrimitive' x = (getPrim =<<) <$> getBuiltinThing x
@@ -130,8 +128,10 @@ primInteger, primFloat, primChar, primString, primBool, primTrue, primFalse,
primAgdaDefinitionPostulate, primAgdaDefinitionPrimitive, primAgdaDefinitionDataConstructor,
primAgdaFunDef, primAgdaFunDefCon, primAgdaClause, primAgdaClauseClause, primAgdaClauseAbsurd,
primAgdaPattern, primAgdaPatCon, primAgdaPatVar, primAgdaPatDot,
- primAgdaDataDef, primAgdaRecordDef
+ primAgdaDataDef, primAgdaRecordDef, primAgdaPatLit, primAgdaPatProj,
+ primAgdaPatAbsurd
:: TCM Term
+
primInteger = getBuiltin builtinInteger
primFloat = getBuiltin builtinFloat
primChar = getBuiltin builtinChar
@@ -225,77 +225,105 @@ primAgdaDefinitionPostulate = getBuiltin builtinAgdaDefinitionPostulate
primAgdaDefinitionPrimitive = getBuiltin builtinAgdaDefinitionPrimitive
primAgdaDefinition = getBuiltin builtinAgdaDefinition
-builtinNat = "NATURAL"
-builtinSuc = "SUC"
-builtinZero = "ZERO"
-builtinNatPlus = "NATPLUS"
-builtinNatMinus = "NATMINUS"
-builtinNatTimes = "NATTIMES"
-builtinNatDivSucAux = "NATDIVSUCAUX"
-builtinNatModSucAux = "NATMODSUCAUX"
-builtinNatEquals = "NATEQUALS"
-builtinNatLess = "NATLESS"
-builtinInteger = "INTEGER"
-builtinFloat = "FLOAT"
-builtinChar = "CHAR"
-builtinString = "STRING"
-builtinBool = "BOOL"
-builtinTrue = "TRUE"
-builtinFalse = "FALSE"
-builtinList = "LIST"
-builtinNil = "NIL"
-builtinCons = "CONS"
-builtinIO = "IO"
-builtinSize = "SIZE"
-builtinSizeLt = "SIZELT"
-builtinSizeSuc = "SIZESUC"
-builtinSizeInf = "SIZEINF"
-builtinSizeMax = "SIZEMAX"
-builtinInf = "INFINITY"
-builtinSharp = "SHARP"
-builtinFlat = "FLAT"
-builtinEquality = "EQUALITY"
-builtinRefl = "REFL"
-builtinRewrite = "REWRITE"
-builtinLevelMax = "LEVELMAX"
-builtinLevel = "LEVEL"
-builtinLevelZero = "LEVELZERO"
-builtinLevelSuc = "LEVELSUC"
-builtinIrrAxiom = "IRRAXIOM"
-builtinQName = "QNAME"
-builtinAgdaSort = "AGDASORT"
-builtinAgdaSortSet = "AGDASORTSET"
-builtinAgdaSortLit = "AGDASORTLIT"
-builtinAgdaSortUnsupported = "AGDASORTUNSUPPORTED"
-builtinAgdaType = "AGDATYPE"
-builtinAgdaTypeEl = "AGDATYPEEL"
-builtinHiding = "HIDING"
-builtinHidden = "HIDDEN"
-builtinInstance = "INSTANCE"
-builtinVisible = "VISIBLE"
-builtinRelevance = "RELEVANCE"
-builtinRelevant = "RELEVANT"
-builtinIrrelevant = "IRRELEVANT"
-builtinArg = "ARG"
-builtinArgInfo = "ARGINFO"
-builtinArgArgInfo = "ARGARGINFO"
-builtinArgArg = "ARGARG"
-builtinAgdaTerm = "AGDATERM"
-builtinAgdaTermVar = "AGDATERMVAR"
-builtinAgdaTermLam = "AGDATERMLAM"
-builtinAgdaTermExtLam = "AGDATERMEXTLAM"
-builtinAgdaTermDef = "AGDATERMDEF"
-builtinAgdaTermCon = "AGDATERMCON"
-builtinAgdaTermPi = "AGDATERMPI"
-builtinAgdaTermSort = "AGDATERMSORT"
-builtinAgdaTermLit = "AGDATERMLIT"
-builtinAgdaTermUnsupported = "AGDATERMUNSUPPORTED"
-builtinAgdaLiteral = "AGDALITERAL"
-builtinAgdaLitNat = "AGDALITNAT"
-builtinAgdaLitFloat = "AGDALITFLOAT"
-builtinAgdaLitChar = "AGDALITCHAR"
-builtinAgdaLitString = "AGDALITSTRING"
-builtinAgdaLitQName = "AGDALITQNAME"
+builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus,
+ builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals,
+ builtinNatLess, builtinInteger, builtinFloat, builtinChar, builtinString,
+ builtinBool, builtinTrue, builtinFalse, builtinList, builtinNil,
+ builtinCons, builtinIO, builtinSize, builtinSizeLt, builtinSizeSuc,
+ builtinSizeInf, builtinSizeMax, builtinInf, builtinSharp, builtinFlat,
+ builtinEquality, builtinRefl, builtinRewrite, builtinLevelMax,
+ builtinLevel, builtinLevelZero, builtinLevelSuc, builtinIrrAxiom,
+ builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit,
+ builtinAgdaSortUnsupported, builtinAgdaType, builtinAgdaTypeEl,
+ builtinHiding, builtinHidden, builtinInstance, builtinVisible,
+ builtinRelevance, builtinRelevant, builtinIrrelevant, builtinArg,
+ builtinArgInfo, builtinArgArgInfo, builtinArgArg, builtinAgdaTerm,
+ builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,
+ builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi,
+ builtinAgdaTermSort, builtinAgdaTermLit, builtinAgdaTermUnsupported,
+ builtinAgdaLiteral, builtinAgdaLitNat, builtinAgdaLitFloat,
+ builtinAgdaLitChar, builtinAgdaLitString, builtinAgdaLitQName,
+ builtinAgdaFunDef, builtinAgdaFunDefCon, builtinAgdaClause,
+ builtinAgdaClauseClause, builtinAgdaClauseAbsurd, builtinAgdaPattern,
+ builtinAgdaPatVar, builtinAgdaPatCon, builtinAgdaPatDot, builtinAgdaPatLit,
+ builtinAgdaPatProj, builtinAgdaPatAbsurd, builtinAgdaDataDef,
+ builtinAgdaRecordDef, builtinAgdaDefinitionFunDef,
+ builtinAgdaDefinitionDataDef, builtinAgdaDefinitionRecordDef,
+ builtinAgdaDefinitionDataConstructor, builtinAgdaDefinitionPostulate,
+ builtinAgdaDefinitionPrimitive, builtinAgdaDefinition
+ :: String
+
+builtinNat = "NATURAL"
+builtinSuc = "SUC"
+builtinZero = "ZERO"
+builtinNatPlus = "NATPLUS"
+builtinNatMinus = "NATMINUS"
+builtinNatTimes = "NATTIMES"
+builtinNatDivSucAux = "NATDIVSUCAUX"
+builtinNatModSucAux = "NATMODSUCAUX"
+builtinNatEquals = "NATEQUALS"
+builtinNatLess = "NATLESS"
+builtinInteger = "INTEGER"
+builtinFloat = "FLOAT"
+builtinChar = "CHAR"
+builtinString = "STRING"
+builtinBool = "BOOL"
+builtinTrue = "TRUE"
+builtinFalse = "FALSE"
+builtinList = "LIST"
+builtinNil = "NIL"
+builtinCons = "CONS"
+builtinIO = "IO"
+builtinSize = "SIZE"
+builtinSizeLt = "SIZELT"
+builtinSizeSuc = "SIZESUC"
+builtinSizeInf = "SIZEINF"
+builtinSizeMax = "SIZEMAX"
+builtinInf = "INFINITY"
+builtinSharp = "SHARP"
+builtinFlat = "FLAT"
+builtinEquality = "EQUALITY"
+builtinRefl = "REFL"
+builtinRewrite = "REWRITE"
+builtinLevelMax = "LEVELMAX"
+builtinLevel = "LEVEL"
+builtinLevelZero = "LEVELZERO"
+builtinLevelSuc = "LEVELSUC"
+builtinIrrAxiom = "IRRAXIOM"
+builtinQName = "QNAME"
+builtinAgdaSort = "AGDASORT"
+builtinAgdaSortSet = "AGDASORTSET"
+builtinAgdaSortLit = "AGDASORTLIT"
+builtinAgdaSortUnsupported = "AGDASORTUNSUPPORTED"
+builtinAgdaType = "AGDATYPE"
+builtinAgdaTypeEl = "AGDATYPEEL"
+builtinHiding = "HIDING"
+builtinHidden = "HIDDEN"
+builtinInstance = "INSTANCE"
+builtinVisible = "VISIBLE"
+builtinRelevance = "RELEVANCE"
+builtinRelevant = "RELEVANT"
+builtinIrrelevant = "IRRELEVANT"
+builtinArg = "ARG"
+builtinArgInfo = "ARGINFO"
+builtinArgArgInfo = "ARGARGINFO"
+builtinArgArg = "ARGARG"
+builtinAgdaTerm = "AGDATERM"
+builtinAgdaTermVar = "AGDATERMVAR"
+builtinAgdaTermLam = "AGDATERMLAM"
+builtinAgdaTermExtLam = "AGDATERMEXTLAM"
+builtinAgdaTermDef = "AGDATERMDEF"
+builtinAgdaTermCon = "AGDATERMCON"
+builtinAgdaTermPi = "AGDATERMPI"
+builtinAgdaTermSort = "AGDATERMSORT"
+builtinAgdaTermLit = "AGDATERMLIT"
+builtinAgdaTermUnsupported = "AGDATERMUNSUPPORTED"
+builtinAgdaLiteral = "AGDALITERAL"
+builtinAgdaLitNat = "AGDALITNAT"
+builtinAgdaLitFloat = "AGDALITFLOAT"
+builtinAgdaLitChar = "AGDALITCHAR"
+builtinAgdaLitString = "AGDALITSTRING"
+builtinAgdaLitQName = "AGDALITQNAME"
builtinAgdaFunDef = "AGDAFUNDEF"
builtinAgdaFunDefCon = "AGDAFUNDEFCON"
builtinAgdaClause = "AGDACLAUSE"
diff --git a/src/full/Agda/TypeChecking/Monad/Closure.hs b/src/full/Agda/TypeChecking/Monad/Closure.hs
index f8e2b70..1e988bc 100644
--- a/src/full/Agda/TypeChecking/Monad/Closure.hs
+++ b/src/full/Agda/TypeChecking/Monad/Closure.hs
@@ -1,4 +1,3 @@
-
module Agda.TypeChecking.Monad.Closure where
import Agda.TypeChecking.Monad.Base
diff --git a/src/full/Agda/TypeChecking/Monad/Constraints.hs b/src/full/Agda/TypeChecking/Monad/Constraints.hs
index 7ecefff..1eac04a 100644
--- a/src/full/Agda/TypeChecking/Monad/Constraints.hs
+++ b/src/full/Agda/TypeChecking/Monad/Constraints.hs
@@ -14,15 +14,16 @@ import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.Closure
import Agda.TypeChecking.Monad.Options
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Get the current problem
currentProblem :: TCM ProblemId
-currentProblem = fromMaybe __IMPOSSIBLE__ . mhead <$> asks envActiveProblems
+currentProblem = headWithDefault __IMPOSSIBLE__ <$> asks envActiveProblems
-- | Steal all constraints belonging to the given problem and add them to the current problem.
stealConstraints :: ProblemId -> TCM ()
@@ -60,11 +61,11 @@ getConstraintsForProblem pid = List.filter ((== pid) . constraintProblem) <$> ge
-- | Get the awake constraints
getAwakeConstraints :: TCM Constraints
-getAwakeConstraints = gets stAwakeConstraints
+getAwakeConstraints = use stAwakeConstraints
wakeConstraints :: (ProblemConstraint-> Bool) -> TCM ()
wakeConstraints wake = do
- (wakeup, sleepin) <- List.partition wake <$> gets stSleepingConstraints
+ (wakeup, sleepin) <- List.partition wake <$> use stSleepingConstraints
reportSLn "tc.constr.wake" 50 $
"waking up " ++ show (List.map constraintProblem wakeup) ++ "\n" ++
" still sleeping: " ++ show (List.map constraintProblem sleepin)
@@ -80,7 +81,7 @@ dropConstraints crit = do
putAllConstraintsToSleep :: TCM ()
putAllConstraintsToSleep = do
- awakeOnes <- gets stAwakeConstraints
+ awakeOnes <- use stAwakeConstraints
modifySleepingConstraints $ (++ awakeOnes)
modifyAwakeConstraints $ const []
@@ -94,7 +95,7 @@ takeAwakeConstraint = do
return $ Just c
getAllConstraints :: TCM Constraints
-getAllConstraints = gets $ \s -> stAwakeConstraints s ++ stSleepingConstraints s
+getAllConstraints = gets $ \s -> s^.stAwakeConstraints ++ s^.stSleepingConstraints
withConstraint :: (Constraint -> TCM a) -> ProblemConstraint -> TCM a
withConstraint f (PConstr pid c) = do
@@ -114,7 +115,8 @@ buildConstraint c = flip buildProblemConstraint c =<< currentProblem
addConstraint' :: Constraint -> TCM ()
addConstraint' c = do
pc <- build
- modify $ \s -> s { stDirty = True, stSleepingConstraints = pc : stSleepingConstraints s }
+ stDirty .= True
+ stSleepingConstraints %= (pc :)
where
build | isBlocking c = buildConstraint c
| otherwise = buildProblemConstraint 0 c
@@ -145,10 +147,10 @@ isSolvingConstraints = asks envSolvingConstraints
---------------------------------------------------------------------------
mapAwakeConstraints :: (Constraints -> Constraints) -> TCState -> TCState
-mapAwakeConstraints f s = s { stAwakeConstraints = f (stAwakeConstraints s) }
+mapAwakeConstraints = over stAwakeConstraints
mapSleepingConstraints :: (Constraints -> Constraints) -> TCState -> TCState
-mapSleepingConstraints f s = s { stSleepingConstraints = f (stSleepingConstraints s) }
+mapSleepingConstraints = over stSleepingConstraints
modifyAwakeConstraints :: (Constraints -> Constraints) -> TCM ()
modifyAwakeConstraints = modify . mapAwakeConstraints
diff --git a/src/full/Agda/TypeChecking/Monad/Context.hs b/src/full/Agda/TypeChecking/Monad/Context.hs
index 5a7fdd5..54c6671 100644
--- a/src/full/Agda/TypeChecking/Monad/Context.hs
+++ b/src/full/Agda/TypeChecking/Monad/Context.hs
@@ -1,5 +1,7 @@
-{-# LANGUAGE TupleSections,
- FlexibleInstances, TypeSynonymInstances, OverlappingInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
module Agda.TypeChecking.Monad.Context where
@@ -18,7 +20,6 @@ import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Monad.Open
-import Agda.Utils.Fresh
import Agda.Utils.Functor
import Agda.Utils.List ((!!!), downFrom)
import Agda.Utils.Monad
@@ -203,6 +204,7 @@ getContextArgs :: MonadTCM tcm => tcm Args
getContextArgs = reverse . zipWith mkArg [0..] <$> getContext
where mkArg i (Common.Dom info _) = Common.Arg info $ var i
+-- | Generate @[var (n - 1), ..., var 0]@ for all declarations in the context.
{-# SPECIALIZE getContextTerms :: TCM [Term] #-}
getContextTerms :: MonadTCM tcm => tcm [Term]
getContextTerms = map var . downFrom <$> getContextSize
@@ -245,13 +247,13 @@ nameOfBV n = fst . unDom <$> lookupBV n
{-# SPECIALIZE getVarInfo :: Name -> TCM (Term, Dom Type) #-}
getVarInfo :: MonadTCM tcm => Name -> tcm (Term, Dom Type)
getVarInfo x =
- do ctx <- getContext
- def <- asks envLetBindings
- case findIndex ((==x) . fst . unDom) ctx of
- Just n -> do
+ do ctx <- getContext
+ def <- asks envLetBindings
+ case findIndex ((==x) . fst . unDom) ctx of
+ Just n -> do
t <- typeOfBV' n
return (var n, t)
- _ ->
- case Map.lookup x def of
- Just vt -> liftTCM $ getOpen vt
- _ -> fail $ "unbound variable " ++ show x
+ _ ->
+ case Map.lookup x def of
+ Just vt -> liftTCM $ getOpen vt
+ _ -> fail $ "unbound variable " ++ show (nameConcrete x)
diff --git a/src/full/Agda/TypeChecking/Monad/Debug.hs b/src/full/Agda/TypeChecking/Monad/Debug.hs
index 7771a1a..fc4a83d 100644
--- a/src/full/Agda/TypeChecking/Monad/Debug.hs
+++ b/src/full/Agda/TypeChecking/Monad/Debug.hs
@@ -1,4 +1,3 @@
-
module Agda.TypeChecking.Monad.Debug where
import Control.Monad.Trans ( MonadIO(liftIO) )
diff --git a/src/full/Agda/TypeChecking/Monad/Env.hs b/src/full/Agda/TypeChecking/Monad/Env.hs
index fcf0fcb..f180423 100644
--- a/src/full/Agda/TypeChecking/Monad/Env.hs
+++ b/src/full/Agda/TypeChecking/Monad/Env.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
+
module Agda.TypeChecking.Monad.Env where
import Control.Monad.Reader
@@ -70,21 +71,29 @@ performedSimplification' simpl = local $ \ e -> e { envSimplification = simpl `m
getSimplification :: MonadReader TCEnv m => m Simplification
getSimplification = asks envSimplification
--- | Reduce @Def f vs@ only if @f@ is a projection.
-onlyReduceProjections :: TCM a -> TCM a
-onlyReduceProjections = local $ \ e -> e { envAllowedReductions = [ProjectionReductions] }
+-- * Controlling reduction.
+
+-- | Lens for 'AllowedReductions'.
+updateAllowedReductions :: (AllowedReductions -> AllowedReductions) -> TCEnv -> TCEnv
+updateAllowedReductions f e = e { envAllowedReductions = f (envAllowedReductions e) }
-dontReduceProjections :: TCM a -> TCM a
-dontReduceProjections = local $ \ e -> e { envAllowedReductions = allReductions \\ [ProjectionReductions] }
+modifyAllowedReductions :: (AllowedReductions -> AllowedReductions) -> TCM a -> TCM a
+modifyAllowedReductions = local . updateAllowedReductions
-dontReduceLevels :: TCM a -> TCM a
-dontReduceLevels = local $ \ e -> e { envAllowedReductions = allReductions \\ [LevelReductions] }
+putAllowedReductions :: AllowedReductions -> TCM a -> TCM a
+putAllowedReductions = modifyAllowedReductions . const
+
+-- | Reduce @Def f vs@ only if @f@ is a projection.
+onlyReduceProjections :: TCM a -> TCM a
+onlyReduceProjections = putAllowedReductions [ProjectionReductions]
+-- | Allow all reductions except for non-terminating functions (default).
allowAllReductions :: TCM a -> TCM a
-allowAllReductions = local $ \ e -> e { envAllowedReductions = allReductions }
+allowAllReductions = putAllowedReductions allReductions
+-- | Allow all reductions including non-terminating functions.
allowNonTerminatingReductions :: TCM a -> TCM a
-allowNonTerminatingReductions = local $ \ e -> e { envAllowedReductions = allReductions ++ [NonTerminatingReductions] }
+allowNonTerminatingReductions = putAllowedReductions $ [NonTerminatingReductions] ++ allReductions
insideDotPattern :: TCM a -> TCM a
insideDotPattern = local $ \e -> e { envInsideDotPattern = True }
diff --git a/src/full/Agda/TypeChecking/Monad/Exception.hs b/src/full/Agda/TypeChecking/Monad/Exception.hs
index 516bb5c..dc9f33b 100644
--- a/src/full/Agda/TypeChecking/Monad/Exception.hs
+++ b/src/full/Agda/TypeChecking/Monad/Exception.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
-- | Basically a copy of the ErrorT monad transformer. It's handy to slap
-- onto TCM and still be a MonadTCM (which isn't possible with ErrorT).
@@ -13,11 +13,12 @@
module Agda.TypeChecking.Monad.Exception where
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
+
import Agda.TypeChecking.Monad.Base
+import Agda.Utils.Except ( Error(strMsg), MonadError(catchError, throwError) )
newtype ExceptionT err m a = ExceptionT { runExceptionT :: m (Either err a) }
diff --git a/src/full/Agda/TypeChecking/Monad/Imports.hs b/src/full/Agda/TypeChecking/Monad/Imports.hs
index c9e4d92..f1095f8 100644
--- a/src/full/Agda/TypeChecking/Monad/Imports.hs
+++ b/src/full/Agda/TypeChecking/Monad/Imports.hs
@@ -1,4 +1,3 @@
-
module Agda.TypeChecking.Monad.Imports where
import Control.Monad.State
@@ -11,20 +10,21 @@ import qualified Data.Set as Set
import Agda.Syntax.Abstract.Name
import qualified Agda.Syntax.Concrete.Name as C
import Agda.TypeChecking.Monad.Base
+import Agda.Utils.Lens
import Agda.Utils.Monad
import Agda.Utils.Time
import Agda.Utils.Hash
addImport :: ModuleName -> TCM ()
addImport m =
- modify $ \s -> s { stImportedModules = Set.insert m $ stImportedModules s }
+ stImportedModules %= Set.insert m
addImportCycleCheck :: C.TopLevelModuleName -> TCM a -> TCM a
addImportCycleCheck m =
local $ \e -> e { envImportPath = m : envImportPath e }
getImports :: TCM (Set ModuleName)
-getImports = gets stImportedModules
+getImports = use stImportedModules
isImported :: ModuleName -> TCM Bool
isImported m = Set.member m <$> getImports
@@ -33,49 +33,48 @@ getImportPath :: TCM [C.TopLevelModuleName]
getImportPath = asks envImportPath
visitModule :: ModuleInfo -> TCM ()
-visitModule mi = modify $ \s ->
- s { stVisitedModules =
- Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi)
- mi $
- stVisitedModules s }
+visitModule mi =
+ stVisitedModules %=
+ Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi
setVisitedModules :: VisitedModules -> TCM ()
-setVisitedModules ms = modify $ \s -> s { stVisitedModules = ms }
+setVisitedModules ms = stVisitedModules .= ms
getVisitedModules :: TCM VisitedModules
-getVisitedModules = gets stVisitedModules
+getVisitedModules = use stVisitedModules
isVisited :: C.TopLevelModuleName -> TCM Bool
-isVisited x = gets $ Map.member x . stVisitedModules
+isVisited x = Map.member x <$> use stVisitedModules
getVisitedModule :: C.TopLevelModuleName
-> TCM (Maybe ModuleInfo)
-getVisitedModule x = gets $ Map.lookup x . stVisitedModules
+getVisitedModule x = Map.lookup x <$> use stVisitedModules
getDecodedModules :: TCM DecodedModules
-getDecodedModules = stDecodedModules . stPersistent <$> get
+getDecodedModules = stDecodedModules . stPersistentState <$> get
setDecodedModules :: DecodedModules -> TCM ()
setDecodedModules ms = modify $ \s ->
- s { stPersistent = (stPersistent s) { stDecodedModules = ms } }
+ s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } }
getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe Interface)
-getDecodedModule x = Map.lookup x . stDecodedModules . stPersistent <$> get
+getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> get
storeDecodedModule :: Interface -> TCM ()
storeDecodedModule i = modify $ \s ->
- s { stPersistent =
- (stPersistent s) { stDecodedModules =
+ s { stPersistentState =
+ (stPersistentState s) { stDecodedModules =
Map.insert (toTopLevelModuleName $ iModuleName i) i $
- (stDecodedModules $ stPersistent s)
+ (stDecodedModules $ stPersistentState s)
}
}
dropDecodedModule :: C.TopLevelModuleName -> TCM ()
dropDecodedModule x = modify $ \s ->
- s { stPersistent = (stPersistent s) { stDecodedModules =
- Map.delete x $ stDecodedModules $ stPersistent s
- }
+ s { stPersistentState =
+ (stPersistentState s) { stDecodedModules =
+ Map.delete x $ stDecodedModules $ stPersistentState s
+ }
}
withImportPath :: [C.TopLevelModuleName] -> TCM a -> TCM a
@@ -87,4 +86,4 @@ checkForImportCycle :: TCM ()
checkForImportCycle = do
m:ms <- getImportPath
when (m `elem` ms) $ typeError $ CyclicModuleDependency
- $ dropWhile (/= m) $ reverse (m:ms)
+ $ dropWhile (/= m) $ reverse (m:ms)
diff --git a/src/full/Agda/TypeChecking/Monad/MetaVars.hs b/src/full/Agda/TypeChecking/Monad/MetaVars.hs
index bac9153..f4a173a 100644
--- a/src/full/Agda/TypeChecking/Monad/MetaVars.hs
+++ b/src/full/Agda/TypeChecking/Monad/MetaVars.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.Monad.MetaVars where
@@ -27,14 +27,14 @@ import Agda.TypeChecking.Monad.Context
import Agda.TypeChecking.Substitute
import Agda.Utils.Functor ((<.>))
-import Agda.Utils.Fresh
+import Agda.Utils.Lens
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Tuple
import Agda.Utils.Size
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Switch off assignment of metas.
@@ -43,10 +43,10 @@ dontAssignMetas = local $ \ env -> env { envAssignMetas = False }
-- | Get the meta store.
getMetaStore :: TCM MetaStore
-getMetaStore = gets stMetaStore
+getMetaStore = use stMetaStore
modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()
-modifyMetaStore f = modify $ \ st -> st { stMetaStore = f (stMetaStore st) }
+modifyMetaStore f = stMetaStore %= f
-- | Lookup a meta variable
lookupMeta :: MetaId -> TCM MetaVariable
@@ -136,9 +136,9 @@ isInstantiatedMeta' :: MetaId -> TCM (Maybe Term)
isInstantiatedMeta' m = do
mv <- lookupMeta m
return $ case mvInstantiation mv of
- InstV v -> Just v
- InstS v -> Just v
- _ -> Nothing
+ InstV tel v -> Just $ foldr mkLam v tel
+ InstS v -> Just v
+ _ -> Nothing
-- | Create 'MetaInfo' in the current environment.
createMetaInfo :: TCM MetaInfo
@@ -180,7 +180,7 @@ updateMetaVarRange mi r = updateMetaVar mi (setRange r)
modifyInteractionPoints :: (InteractionPoints -> InteractionPoints) -> TCM ()
modifyInteractionPoints f =
- modify $ \ s -> s { stInteractionPoints = f (stInteractionPoints s) }
+ stInteractionPoints %= f
-- | Register an interaction point during scope checking.
-- If there is no interaction id yet, create one.
@@ -189,7 +189,7 @@ registerInteractionPoint r maybeId = do
ii <- case maybeId of
Just i -> return $ InteractionId i
Nothing -> fresh
- m <- gets stInteractionPoints
+ m <- use stInteractionPoints
let ip = InteractionPoint { ipRange = r, ipMeta = Nothing }
case Map.insertLookupWithKey (\ key new old -> old) ii ip m of
-- If the interaction point is already present, we keep the old ip.
@@ -204,7 +204,7 @@ registerInteractionPoint r maybeId = do
-- | Hook up meta variable to interaction point.
connectInteractionPoint :: InteractionId -> MetaId -> TCM ()
connectInteractionPoint ii mi = do
- m <- gets stInteractionPoints
+ m <- use stInteractionPoints
let ip = InteractionPoint { ipRange = __IMPOSSIBLE__, ipMeta = Just mi }
-- The interaction point needs to be present already, we just set the meta.
case Map.insertLookupWithKey (\ key new old -> new { ipRange = ipRange old }) ii ip m of
@@ -219,15 +219,15 @@ removeInteractionPoint ii = do
-- | Get a list of interaction ids.
getInteractionPoints :: TCM [InteractionId]
-getInteractionPoints = Map.keys <$> gets stInteractionPoints
+getInteractionPoints = Map.keys <$> use stInteractionPoints
-- | Get all metas that correspond to interaction ids.
getInteractionMetas :: TCM [MetaId]
-getInteractionMetas = mapMaybe ipMeta . Map.elems <$> gets stInteractionPoints
+getInteractionMetas = mapMaybe ipMeta . Map.elems <$> use stInteractionPoints
-- | Get all metas that correspond to interaction ids.
getInteractionIdsAndMetas :: TCM [(InteractionId,MetaId)]
-getInteractionIdsAndMetas = mapMaybe f . Map.toList <$> gets stInteractionPoints
+getInteractionIdsAndMetas = mapMaybe f . Map.toList <$> use stInteractionPoints
where f (ii, ip) = (ii,) <$> ipMeta ip
-- | Does the meta variable correspond to an interaction point?
@@ -239,7 +239,7 @@ isInteractionMeta x = lookup x . map swap <$> getInteractionIdsAndMetas
-- | Get the information associated to an interaction point.
lookupInteractionPoint :: InteractionId -> TCM InteractionPoint
lookupInteractionPoint ii =
- fromMaybeM err $ Map.lookup ii <$> gets stInteractionPoints
+ fromMaybeM err $ Map.lookup ii <$> use stInteractionPoints
where
err = fail $ "no such interaction point: " ++ show ii
@@ -264,7 +264,7 @@ newMeta' inst mi p perm j = do
mv = MetaVar mi p perm j' inst Set.empty Instantiable
-- printing not available (import cycle)
-- reportSDoc "tc.meta.new" 50 $ text "new meta" <+> prettyTCM j'
- modify $ \st -> st { stMetaStore = Map.insert x mv $ stMetaStore st }
+ stMetaStore %= Map.insert x mv
return x
-- | Get the 'Range' for an interaction point.
@@ -290,24 +290,24 @@ getInstantiatedMetas = do
store <- getMetaStore
return [ i | (i, MetaVar{ mvInstantiation = mi }) <- Map.assocs store, isInst mi ]
where
- isInst Open = False
- isInst OpenIFS = False
- isInst (BlockedConst _) = False
- isInst (PostponedTypeCheckingProblem _ _) = False
- isInst (InstV _) = True
- isInst (InstS _) = True
+ isInst Open = False
+ isInst OpenIFS = False
+ isInst BlockedConst{} = False
+ isInst PostponedTypeCheckingProblem{} = False
+ isInst InstV{} = True
+ isInst InstS{} = True
getOpenMetas :: TCM [MetaId]
getOpenMetas = do
store <- getMetaStore
return [ i | (i, MetaVar{ mvInstantiation = mi }) <- Map.assocs store, isOpen mi ]
where
- isOpen Open = True
- isOpen OpenIFS = True
- isOpen (BlockedConst _) = True
- isOpen (PostponedTypeCheckingProblem _ _) = True
- isOpen (InstV _) = False
- isOpen (InstS _) = False
+ isOpen Open = True
+ isOpen OpenIFS = True
+ isOpen BlockedConst{} = True
+ isOpen PostponedTypeCheckingProblem{} = True
+ isOpen InstV{} = False
+ isOpen InstS{} = False
-- | @listenToMeta l m@: register @l@ as a listener to @m at . This is done
-- when the type of l is blocked by @m at .
diff --git a/src/full/Agda/TypeChecking/Monad/Mutual.hs b/src/full/Agda/TypeChecking/Monad/Mutual.hs
index f047d1e..ecd1113 100644
--- a/src/full/Agda/TypeChecking/Monad/Mutual.hs
+++ b/src/full/Agda/TypeChecking/Monad/Mutual.hs
@@ -6,12 +6,13 @@ import Control.Monad.Reader
import Control.Monad.State
import qualified Data.Map as Map
import Data.Set (Set)
+import Data.Functor ((<$>))
import qualified Data.Set as Set
import qualified Agda.Utils.HashMap as HMap
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad.Base
-import Agda.Utils.Fresh
+import Agda.Utils.Lens
noMutualBlock :: TCM a -> TCM a
noMutualBlock = local $ \e -> e { envMutualBlock = Nothing }
@@ -29,17 +30,14 @@ inMutualBlock m = do
-- | Set the mutual block for a definition
setMutualBlock :: MutualId -> QName -> TCM ()
setMutualBlock i x = do
- modify $ \s -> s { stMutualBlocks = Map.insertWith Set.union i (Set.singleton x) $ stMutualBlocks s
- , stSignature = (stSignature s)
- { sigDefinitions = setMutId x i $ sigDefinitions $ stSignature s
- }
- }
+ stMutualBlocks %= Map.insertWith Set.union i (Set.singleton x)
+ stSignature %= \sig -> sig { sigDefinitions = setMutId x i $ sigDefinitions sig }
where
setMutId x i = flip HMap.adjust x $ \defn -> defn { defMutual = i }
-- | Get all mutual blocks
getMutualBlocks :: TCM [Set QName]
-getMutualBlocks = gets $ Map.elems . stMutualBlocks
+getMutualBlocks = Map.elems <$> use stMutualBlocks
-- | Get the current mutual block, if any, otherwise a fresh mutual
-- block is returned.
@@ -48,7 +46,7 @@ currentOrFreshMutualBlock = maybe fresh return =<< asks envMutualBlock
lookupMutualBlock :: MutualId -> TCM (Set QName)
lookupMutualBlock mi = do
- mb <- gets stMutualBlocks
+ mb <- use stMutualBlocks
case Map.lookup mi mb of
Just qs -> return qs
Nothing -> return Set.empty -- can end up here if we ask for the current mutual block and there is none
diff --git a/src/full/Agda/TypeChecking/Monad/Open.hs b/src/full/Agda/TypeChecking/Monad/Open.hs
index 74b8ada..8748444 100644
--- a/src/full/Agda/TypeChecking/Monad/Open.hs
+++ b/src/full/Agda/TypeChecking/Monad/Open.hs
@@ -1,15 +1,14 @@
-- {-# LANGUAGE CPP #-}
module Agda.TypeChecking.Monad.Open
- ( makeOpen
- , makeClosed
- , getOpen
- , tryOpen
- ) where
+ ( makeOpen
+ , makeClosed
+ , getOpen
+ , tryOpen
+ ) where
import Control.Applicative
import Control.Monad
-import Control.Monad.Error
import Data.List
import Agda.TypeChecking.Substitute
@@ -17,6 +16,8 @@ import Agda.TypeChecking.Monad.Base
import {-# SOURCE #-} Agda.TypeChecking.Monad.Context
+import Agda.Utils.Except ( MonadError(catchError) )
+
-- | Create an open term in the current context.
makeOpen :: a -> TCM (Open a)
makeOpen x = do
diff --git a/src/full/Agda/TypeChecking/Monad/Options.hs b/src/full/Agda/TypeChecking/Monad/Options.hs
index 1027c21..c7821d5 100644
--- a/src/full/Agda/TypeChecking/Monad/Options.hs
+++ b/src/full/Agda/TypeChecking/Monad/Options.hs
@@ -1,10 +1,9 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Agda.TypeChecking.Monad.Options where
import Control.Applicative
-import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.State
import Data.Maybe
@@ -24,13 +23,15 @@ import Agda.Interaction.Options
import qualified Agda.Interaction.Options.Lenses as Lens
import Agda.Interaction.Response
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.FileName
import Agda.Utils.Monad
+import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Trie (Trie)
import qualified Agda.Utils.Trie as Trie
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Sets the pragma options.
@@ -43,7 +44,7 @@ setPragmaOptions opts = do
case checkOpts (clo { optPragmaOptions = opts }) of
Left err -> __IMPOSSIBLE__
Right opts -> do
- modify $ \s -> s { stPragmaOptions = (optPragmaOptions opts) }
+ stPragmaOptions .= optPragmaOptions opts
-- | Sets the command line options (both persistent and pragma options
-- are updated).
@@ -78,19 +79,19 @@ class (Functor m, Applicative m, Monad m) => HasOptions m where
commandLineOptions :: m CommandLineOptions
instance MonadIO m => HasOptions (TCMT m) where
- pragmaOptions = gets stPragmaOptions
+ pragmaOptions = use stPragmaOptions
commandLineOptions = do
- p <- stPragmaOptions <$> get
- cl <- stPersistentOptions . stPersistent <$> get
+ p <- use stPragmaOptions
+ cl <- stPersistentOptions . stPersistentState <$> get
return $ cl { optPragmaOptions = p }
setOptionsFromPragma :: OptionsPragma -> TCM ()
setOptionsFromPragma ps = do
opts <- commandLineOptions
case parsePragmaOptions ps opts of
- Left err -> typeError $ GenericError err
- Right opts' -> setPragmaOptions opts'
+ Left err -> typeError $ GenericError err
+ Right opts' -> setPragmaOptions opts'
-- | Disable display forms.
enableDisplayForms :: TCM a -> TCM a
@@ -209,17 +210,17 @@ setIncludeDirs incs relativeTo = do
setInputFile :: FilePath -> TCM ()
setInputFile file =
- do opts <- commandLineOptions
- setCommandLineOptions $
+ do opts <- commandLineOptions
+ setCommandLineOptions $
opts { optInputFile = Just file }
-- | Should only be run if 'hasInputFile'.
getInputFile :: TCM AbsolutePath
getInputFile =
- do mf <- optInputFile <$> commandLineOptions
- case mf of
- Just file -> liftIO $ absolute file
- Nothing -> __IMPOSSIBLE__
+ do mf <- optInputFile <$> commandLineOptions
+ case mf of
+ Just file -> liftIO $ absolute file
+ Nothing -> __IMPOSSIBLE__
hasInputFile :: TCM Bool
hasInputFile = isJust <$> optInputFile <$> commandLineOptions
@@ -297,7 +298,7 @@ hasVerbosity k n | n < 0 = __IMPOSSIBLE__
| otherwise = do
t <- getVerbosity
let ks = wordsBy (`elem` ".:") k
- m = maximum $ 0 : Trie.lookupPath ks t
+ m = maximum $ 0 : Trie.lookupPath ks t
return (n <= m)
-- | Displays a debug message in a suitable way.
diff --git a/src/full/Agda/TypeChecking/Monad/Sharing.hs b/src/full/Agda/TypeChecking/Monad/Sharing.hs
index c586db6..fba14f1 100644
--- a/src/full/Agda/TypeChecking/Monad/Sharing.hs
+++ b/src/full/Agda/TypeChecking/Monad/Sharing.hs
@@ -12,7 +12,7 @@ import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.Options
import Agda.Utils.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
updateSharedTerm :: MonadTCM tcm => (Term -> tcm Term) -> Term -> tcm Term
diff --git a/src/full/Agda/TypeChecking/Monad/Signature.hs b/src/full/Agda/TypeChecking/Monad/Signature.hs
index eb5a1f7..08e0a39 100644
--- a/src/full/Agda/TypeChecking/Monad/Signature.hs
+++ b/src/full/Agda/TypeChecking/Monad/Signature.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Monad.Signature where
@@ -26,6 +26,7 @@ import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.Monad.Context
import Agda.TypeChecking.Monad.Options
import Agda.TypeChecking.Monad.Env
+import Agda.TypeChecking.Monad.Exception ( ExceptionT )
import Agda.TypeChecking.Monad.Mutual
import Agda.TypeChecking.Monad.Open
import Agda.TypeChecking.Monad.State
@@ -40,10 +41,12 @@ import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Permutation
import Agda.Utils.Pretty
+import Agda.Utils.Lens
import Agda.Utils.List
+import Agda.Utils.Except ( Error )
import qualified Agda.Utils.HashMap as HMap
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Add a constant to the signature. Lifts the definition to top level.
@@ -52,8 +55,8 @@ addConstant q d = do
reportSLn "tc.signature" 20 $ "adding constant " ++ show q ++ " to signature"
tel <- getContextTelescope
let tel' = replaceEmptyName "r" $ killRange $ case theDef d of
- Constructor{} -> fmap (setHiding Hidden) tel
- _ -> tel
+ Constructor{} -> fmap (setHiding Hidden) tel
+ _ -> tel
let d' = abstract tel' $ d { defName = q }
reportSLn "tc.signature" 30 $ "lambda-lifted definition = " ++ show d'
modifySignature $ \sig -> sig
@@ -161,29 +164,29 @@ addDisplayForms x = do
def <- getConstInfo x
let cs = defClauses def
case cs of
- [ Clause{ namedClausePats = pats, clauseBody = b } ]
- | all (isVar . namedArg) pats
+ [ Clause{ namedClausePats = pats, clauseBody = b } ]
+ | all (isVar . namedArg) pats
, Just (m, Def y es) <- strip (b `apply` vs0)
, Just vs <- mapM isApplyElim es -> do
- let ps = raise 1 $ map unArg vs
+ let ps = raise 1 $ map unArg vs
df = Display 0 ps $ DTerm $ Def top $ map Apply args
- reportSLn "tc.display.section" 20 $ "adding display form " ++ show y ++ " --> " ++ show top
+ reportSLn "tc.display.section" 20 $ "adding display form " ++ show y ++ " --> " ++ show top
++ "\n " ++ show df
- addDisplayForm y df
- add args top y vs
- _ -> do
- let reason = case cs of
- [] -> "no clauses"
- _:_:_ -> "many clauses"
- [ Clause{ clauseBody = b } ] -> case strip b of
- Nothing -> "bad body"
- Just (m, Def y es)
- | m < length args -> "too few args"
- | m > length args -> "too many args"
- | otherwise -> "args=" ++ show args ++ " es=" ++ show es
- Just (m, v) -> "not a def body"
- reportSLn "tc.display.section" 30 $ "no display form from " ++ show x ++ " because " ++ reason
- return ()
+ addDisplayForm y df
+ add args top y vs
+ _ -> do
+ let reason = case cs of
+ [] -> "no clauses"
+ _:_:_ -> "many clauses"
+ [ Clause{ clauseBody = b } ] -> case strip b of
+ Nothing -> "bad body"
+ Just (m, Def y es)
+ | m < length args -> "too few args"
+ | m > length args -> "too many args"
+ | otherwise -> "args=" ++ show args ++ " es=" ++ show es
+ Just (m, v) -> "not a def body"
+ reportSLn "tc.display.section" 30 $ "no display form from " ++ show x ++ " because " ++ reason
+ return ()
strip (Body v) = return (0, unSpine v)
strip NoBody = Nothing
strip (Bind b) = do
@@ -227,8 +230,8 @@ applySection new ptel old ts rd rm = do
-- produce out-of-scope constructors.
copyName x = Map.findWithDefault x x rd
- argsToUse x = do
- let m = mnameFromList $ commonPrefix (mnameToList old) (mnameToList $ qnameModule x)
+ argsToUse new = do
+ let m = mnameFromList $ commonPrefix (mnameToList old) (mnameToList new)
reportSLn "tc.mod.apply" 80 $ "Common prefix: " ++ show m
let ms = tail . map mnameFromList . inits . mnameToList $ m
ps <- sequence [ maybe 0 secFreeVars <$> getSection m | m <- ms ]
@@ -238,7 +241,7 @@ applySection new ptel old ts rd rm = do
copyDef :: Args -> (QName, QName) -> TCM ()
copyDef ts (x, y) = do
def <- getConstInfo x
- np <- argsToUse x
+ np <- argsToUse (qnameModule x)
copyDef' np def
where
copyDef' np d = do
@@ -246,20 +249,20 @@ applySection new ptel old ts rd rm = do
reportSLn "tc.mod.apply" 80 $ "args = " ++ show ts' ++ "\n" ++
"old type = " ++ showTerm (unEl $ defType d) ++ "\n" ++
"new type = " ++ showTerm (unEl t)
- addConstant y =<< nd y
+ addConstant y =<< nd y
makeProjection y
- -- Set display form for the old name if it's not a constructor.
+ -- Set display form for the old name if it's not a constructor.
{- BREAKS fail/Issue478
-- Andreas, 2012-10-20 and if we are not an anonymous module
- -- unless (isAnonymousModuleName new || isCon || size ptel > 0) $ do
+ -- unless (isAnonymousModuleName new || isCon || size ptel > 0) $ do
-}
-- Issue1238: the copied def should be an 'instance' if the original
-- def is one. Skip constructors since the original constructor will
-- still work as an instance.
unless isCon $ flip (maybe (return ())) inst $ \c -> addNamedInstance y c
- unless (isCon || size ptel > 0) $ do
- addDisplayForms y
+ unless (isCon || size ptel > 0) $ do
+ addDisplayForms y
where
ts' = take np ts
t = defType d `apply` ts'
@@ -328,6 +331,7 @@ applySection new ptel old ts rd rm = do
, funTerminates = Just True
, funExtLam = extlam
, funWith = with
+ , funCopatternLHS = isCopatternLHS [cl]
}
reportSLn "tc.mod.apply" 80 $ "new def for " ++ show x ++ "\n " ++ show newDef
return newDef
@@ -346,11 +350,15 @@ applySection new ptel old ts rd rm = do
copySec :: Args -> (ModuleName, ModuleName) -> TCM ()
copySec ts (x, y) = do
+ np <- argsToUse x
tel <- lookupSection x
- let fv = size tel - size ts
+ let fv = size tel - np
reportSLn "tc.mod.apply" 80 $ "Copying section " ++ show x ++ " to " ++ show y
reportSLn "tc.mod.apply" 80 $ " free variables: " ++ show fv
- addCtxTel (apply tel ts) $ addSection y fv
+ reportSLn "tc.mod.apply" 80 $ " ts = " ++ show ts
+ reportSLn "tc.mod.apply" 80 $ " tel = " ++ show tel
+ reportSLn "tc.mod.apply" 80 $ " np = " ++ show np
+ addCtxTel (apply tel $ take np ts) $ addSection y fv
addDisplayForm :: QName -> DisplayForm -> TCM ()
addDisplayForm x df = do
@@ -360,8 +368,8 @@ addDisplayForm x df = do
where
add df sig = sig { sigDefinitions = HMap.adjust addDf x defs }
where
- addDf def = def { defDisplay = df : defDisplay def }
- defs = sigDefinitions sig
+ addDf def = def { defDisplay = df : defDisplay def }
+ defs = sigDefinitions sig
canonicalName :: QName -> TCM QName
canonicalName x = do
@@ -421,8 +429,8 @@ class (Functor m, Applicative m, Monad m) => HasConstInfo m where
instance HasConstInfo (TCMT IO) where
getConstInfo q = join $ pureTCM $ \st env ->
- let defs = sigDefinitions $ stSignature st
- idefs = sigDefinitions $ stImports st
+ let defs = sigDefinitions $ st^.stSignature
+ idefs = sigDefinitions $ st^.stImports
in case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of
[] -> fail $ "Unbound name: " ++ show q ++ " " ++ showQNameId q
[d] -> mkAbs env d
@@ -431,8 +439,8 @@ instance HasConstInfo (TCMT IO) where
mkAbs env d
| treatAbstractly' q' env =
case makeAbstract d of
- Just d -> return d
- Nothing -> notInScope $ qnameToConcrete q
+ Just d -> return d
+ Nothing -> notInScope $ qnameToConcrete q
-- the above can happen since the scope checker is a bit sloppy with 'abstract'
| otherwise = return d
where
@@ -449,6 +457,9 @@ instance HasConstInfo (TCMT IO) where
init' [] = {-'-} __IMPOSSIBLE__
init' xs = init xs
+instance (HasConstInfo m, Error err) => HasConstInfo (ExceptionT err m) where
+ getConstInfo = lift . getConstInfo
+
{-# INLINE getConInfo #-}
{-# SPECIALIZE getConstInfo :: QName -> TCM Definition #-}
getConInfo :: MonadTCM tcm => ConHead -> tcm Definition
@@ -629,12 +640,12 @@ treatAbstractly q = asks $ treatAbstractly' q
treatAbstractly' :: QName -> TCEnv -> Bool
treatAbstractly' q env = case envAbstractMode env of
- ConcreteMode -> True
+ ConcreteMode -> True
IgnoreAbstractMode -> False
- AbstractMode -> not $ current == m || current `isSubModuleOf` m
+ AbstractMode -> not $ current == m || current `isSubModuleOf` m
where
current = envCurrentModule env
- m = qnameModule q
+ m = qnameModule q
-- | Get type of a constant, instantiated to the current context.
typeOfConst :: QName -> TCM Type
@@ -651,10 +662,10 @@ colOfConst q = defColors <$> getConstInfo q
-- | The name must be a datatype.
sortOfConst :: QName -> TCM Sort
sortOfConst q =
- do d <- theDef <$> getConstInfo q
- case d of
- Datatype{dataSort = s} -> return s
- _ -> fail $ "Expected " ++ show q ++ " to be a datatype."
+ do d <- theDef <$> getConstInfo q
+ case d of
+ Datatype{dataSort = s} -> return s
+ _ -> fail $ "Expected " ++ show q ++ " to be a datatype."
-- | Is it the name of a record projection?
isProjection :: QName -> TCM (Maybe Projection)
diff --git a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs
index 6a3a3b0..80c4750 100644
--- a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs
+++ b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TupleSections #-}
@@ -9,7 +9,6 @@
module Agda.TypeChecking.Monad.SizedTypes where
import Control.Applicative
-import Control.Monad.Error
import Agda.Interaction.Options
@@ -23,9 +22,10 @@ import Agda.TypeChecking.Monad.Signature
import Agda.TypeChecking.Monad.State
import Agda.TypeChecking.Substitute ()
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -106,12 +106,23 @@ builtinSizeHook s q e' t = do
-- * Constructors
------------------------------------------------------------------------
+-- | The sort of built-in types @SIZE@ and @SIZELT at .
+sizeSort :: Sort
+sizeSort = mkType 0
+
+-- | The type of built-in types @SIZE@ and @SIZELT at .
+sizeUniv :: Type
+sizeUniv = sort $ sizeSort
+
+-- | The built-in type @SIZE@ with user-given name.
sizeType_ :: QName -> Type
-sizeType_ size = El (mkType 0) $ Def size []
+sizeType_ size = El sizeSort $ Def size []
+-- | The built-in type @SIZE at .
sizeType :: TCM Type
-sizeType = El (mkType 0) <$> primSize
+sizeType = El sizeSort <$> primSize
+-- | The name of @SIZESUC at .
sizeSucName :: TCM (Maybe QName)
sizeSucName = liftTCM $
ifM (not . optSizedTypes <$> pragmaOptions) (return Nothing) $ do
diff --git a/src/full/Agda/TypeChecking/Monad/State.hs b/src/full/Agda/TypeChecking/Monad/State.hs
index b3f80f0..9a6684e 100644
--- a/src/full/Agda/TypeChecking/Monad/State.hs
+++ b/src/full/Agda/TypeChecking/Monad/State.hs
@@ -29,19 +29,20 @@ import {-# SOURCE #-} Agda.TypeChecking.Monad.Options
import Agda.Utils.Hash
import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Lens
import Agda.Utils.Monad (bracket_)
import Agda.Utils.Pretty
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Resets the non-persistent part of the type checking state.
resetState :: TCM ()
resetState = do
- pers <- gets stPersistent
- put $ initState { stPersistent = pers }
+ pers <- gets stPersistentState
+ put $ initState { stPersistentState = pers }
-- | Resets all of the type checking state.
--
@@ -63,23 +64,51 @@ localTCState = bracket_ get $ \ s -> do
put s
modifyBenchmark $ const b
+-- | Same as 'localTCState' but also returns the state in which we were just
+-- before reverting it.
+localTCStateSaving :: TCM a -> TCM (a, TCState)
+localTCStateSaving compute = do
+ state <- get
+ result <- compute
+ newState <- get
+ do
+ b <- getBenchmark
+ put state
+ modifyBenchmark $ const b
+ return (result, newState)
+
+
---------------------------------------------------------------------------
--- * Lens for persistent state
+-- * Lens for persistent states and its fields
---------------------------------------------------------------------------
-updatePersistentState :: (PersistentTCState -> PersistentTCState) -> (TCState -> TCState)
-updatePersistentState f s = s { stPersistent = f (stPersistent s) }
+lensPersistentState :: Lens' PersistentTCState TCState
+lensPersistentState f s =
+ f (stPersistentState s) <&> \ p -> s { stPersistentState = p }
+
+updatePersistentState
+ :: (PersistentTCState -> PersistentTCState) -> (TCState -> TCState)
+updatePersistentState f s = s { stPersistentState = f (stPersistentState s) }
modifyPersistentState :: (PersistentTCState -> PersistentTCState) -> TCM ()
modifyPersistentState = modify . updatePersistentState
+-- | Lens for 'stAccumStatistics'.
+
+lensAccumStatisticsP :: Lens' Statistics PersistentTCState
+lensAccumStatisticsP f s = f (stAccumStatistics s) <&> \ a ->
+ s { stAccumStatistics = a }
+
+lensAccumStatistics :: Lens' Statistics TCState
+lensAccumStatistics = lensPersistentState . lensAccumStatisticsP
+
---------------------------------------------------------------------------
-- * Scope
---------------------------------------------------------------------------
-- | Get the current scope.
getScope :: TCM ScopeInfo
-getScope = gets stScope
+getScope = use stScope
-- | Set the current scope.
setScope :: ScopeInfo -> TCM ()
@@ -87,7 +116,7 @@ setScope scope = modifyScope (const scope)
-- | Modify the current scope.
modifyScope :: (ScopeInfo -> ScopeInfo) -> TCM ()
-modifyScope f = modify $ \ s -> s { stScope = f (stScope s) }
+modifyScope f = stScope %= f
-- | Run a computation in a local scope.
withScope :: ScopeInfo -> TCM a -> TCM (a, ScopeInfo)
@@ -130,22 +159,22 @@ printScope tag v s = verboseS ("scope." ++ tag) v $ do
-- ** Lens for 'stSignature' and 'stImports'
modifySignature :: (Signature -> Signature) -> TCM ()
-modifySignature f = modify $ \s -> s { stSignature = f $ stSignature s }
+modifySignature f = stSignature %= f
modifyImportedSignature :: (Signature -> Signature) -> TCM ()
-modifyImportedSignature f = modify $ \s -> s { stImports = f $ stImports s }
+modifyImportedSignature f = stImports %= f
getSignature :: TCM Signature
-getSignature = gets stSignature
+getSignature = use stSignature
getImportedSignature :: TCM Signature
-getImportedSignature = gets stImports
+getImportedSignature = use stImports
setSignature :: Signature -> TCM ()
setSignature sig = modifySignature $ const sig
setImportedSignature :: Signature -> TCM ()
-setImportedSignature sig = modify $ \s -> s { stImports = sig }
+setImportedSignature sig = stImports .= sig
-- | Run some computation in a different signature, restore original signature.
withSignature :: Signature -> TCM a -> TCM a
@@ -194,21 +223,16 @@ updateFunClauses f _ = __IMPOSSIBLE__
-- implementation of 'setTopLevelModule' should be changed.
setTopLevelModule :: C.QName -> TCM ()
-setTopLevelModule x =
- modify $ \s -> s
- { stFreshThings = (stFreshThings s)
- { fName = NameId 0 $ hashString (show x)
- }
- }
+setTopLevelModule x = stFreshNameId .= NameId 0 (hashString (show x))
-- | Use a different top-level module for a computation. Used when generating
-- names for imported modules.
withTopLevelModule :: C.QName -> TCM a -> TCM a
withTopLevelModule x m = do
- next <- gets $ fName . stFreshThings
+ next <- use stFreshNameId
setTopLevelModule x
y <- m
- modify $ \s -> s { stFreshThings = (stFreshThings s) { fName = next } }
+ stFreshNameId .= next
return y
---------------------------------------------------------------------------
@@ -217,12 +241,11 @@ withTopLevelModule x m = do
-- | Tell the compiler to import the given Haskell module.
addHaskellImport :: String -> TCM ()
-addHaskellImport i =
- modify $ \s -> s { stHaskellImports = Set.insert i $ stHaskellImports s }
+addHaskellImport i = stHaskellImports %= Set.insert i
-- | Get the Haskell imports.
getHaskellImports :: TCM (Set String)
-getHaskellImports = gets stHaskellImports
+getHaskellImports = use stHaskellImports
---------------------------------------------------------------------------
-- * Interaction output callback
@@ -230,7 +253,7 @@ getHaskellImports = gets stHaskellImports
getInteractionOutputCallback :: TCM InteractionOutputCallback
getInteractionOutputCallback
- = gets $ stInteractionOutputCallback . stPersistent
+ = gets $ stInteractionOutputCallback . stPersistentState
appInteractionOutputCallback :: Response -> TCM ()
appInteractionOutputCallback r
@@ -245,17 +268,17 @@ setInteractionOutputCallback cb
---------------------------------------------------------------------------
getPatternSyns :: TCM PatternSynDefns
-getPatternSyns = gets stPatternSyns
+getPatternSyns = use stPatternSyns
setPatternSyns :: PatternSynDefns -> TCM ()
setPatternSyns m = modifyPatternSyns (const m)
-- | Lens for 'stPatternSyns'.
modifyPatternSyns :: (PatternSynDefns -> PatternSynDefns) -> TCM ()
-modifyPatternSyns f = modify $ \s -> s { stPatternSyns = f (stPatternSyns s) }
+modifyPatternSyns f = stPatternSyns %= f
getPatternSynImports :: TCM PatternSynDefns
-getPatternSynImports = gets stPatternSynImports
+getPatternSynImports = use stPatternSynImports
lookupPatternSyn :: QName -> TCM PatternSynDefn
lookupPatternSyn x = do
@@ -274,7 +297,7 @@ lookupPatternSyn x = do
-- | Lens getter for 'Benchmark' from 'TCState'.
theBenchmark :: TCState -> Benchmark
-theBenchmark = stBenchmark . stPersistent
+theBenchmark = stBenchmark . stPersistentState
-- | Lens map for 'Benchmark'.
updateBenchmark :: (Benchmark -> Benchmark) -> TCState -> TCState
@@ -294,7 +317,10 @@ freshTCM :: TCM a -> TCM (Either TCErr a)
freshTCM m = do
-- Prepare an initial state with current benchmark info.
b <- getBenchmark
- let s = updateBenchmark (const b) initState
+ a <- use lensAccumStatistics
+ let s = updateBenchmark (const b)
+ . set lensAccumStatistics a
+ $ initState
-- Run subcomputation in initial state.
-- If we encounter an exception, we lose the state and the
-- benchmark info.
@@ -306,6 +332,7 @@ freshTCM m = do
Right (a, s) -> do
-- Keep only the benchmark info from the final state of the subcomp.
modifyBenchmark $ const $ theBenchmark s
+ lensAccumStatistics .= (s^.lensAccumStatistics)
return $ Right a
---------------------------------------------------------------------------
@@ -321,13 +348,13 @@ addSignatureInstances sig = do
-- | Lens for 'stInstanceDefs'.
updateInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> (TCState -> TCState)
-updateInstanceDefs f s = s { stInstanceDefs = f $ stInstanceDefs s }
+updateInstanceDefs = over stInstanceDefs
modifyInstanceDefs :: (TempInstanceTable -> TempInstanceTable) -> TCM ()
modifyInstanceDefs = modify . updateInstanceDefs
getAllInstanceDefs :: TCM TempInstanceTable
-getAllInstanceDefs = gets stInstanceDefs
+getAllInstanceDefs = use stInstanceDefs
getAnonInstanceDefs :: TCM [QName]
getAnonInstanceDefs = snd <$> getAllInstanceDefs
diff --git a/src/full/Agda/TypeChecking/Monad/Statistics.hs b/src/full/Agda/TypeChecking/Monad/Statistics.hs
index 0ae9d2c..e273e40 100644
--- a/src/full/Agda/TypeChecking/Monad/Statistics.hs
+++ b/src/full/Agda/TypeChecking/Monad/Statistics.hs
@@ -1,21 +1,34 @@
-- | Collect statistics.
module Agda.TypeChecking.Monad.Statistics
- ( tick, tickN, tickMax, getStatistics
+ ( tick, tickN, tickMax, getStatistics, modifyStatistics, printStatistics
) where
import Control.Monad.State
-import Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import qualified Text.PrettyPrint.Boxes as Boxes
+
+import Agda.Syntax.Concrete.Name as C
import Agda.TypeChecking.Monad.Base
+import Agda.TypeChecking.Monad.Options
+import Agda.TypeChecking.Monad.State
+
+import Agda.Utils.Lens
+import Agda.Utils.Maybe
+import Agda.Utils.Null
+import Agda.Utils.Pretty
+import Agda.Utils.String
-- | Get the statistics.
getStatistics :: TCM Statistics
-getStatistics = gets stStatistics
+getStatistics = use stStatistics
-- | Modify the statistics via given function.
modifyStatistics :: (Statistics -> Statistics) -> TCM ()
-modifyStatistics f = modify $ \ s -> s { stStatistics = f (stStatistics s) }
+modifyStatistics f = stStatistics %= f
-- | Increase specified counter by @1 at .
tick :: String -> TCM ()
@@ -44,3 +57,15 @@ modifyCounter x f = modifyStatistics $ force . update
update = Map.insertWith (\ new old -> f old) x dummy
dummy = f 0
+-- | Print the given statistics if verbosity "profile" is given.
+printStatistics :: Int -> Maybe C.TopLevelModuleName -> Statistics -> TCM ()
+printStatistics vl mmname stats = verboseS "profile" vl $ do
+ unlessNull (Map.toList stats) $ \ stats -> do
+ let -- First column (left aligned) is accounts.
+ col1 = Boxes.vcat Boxes.left $ map (Boxes.text . fst) stats
+ -- Second column (right aligned) is numbers.
+ col2 = Boxes.vcat Boxes.right $ map (Boxes.text . showThousandSep . snd) stats
+ table = Boxes.hsep 1 Boxes.left [col1, col2]
+ reportSLn "profile" 1 $ caseMaybe mmname "Accumlated statistics" $ \ mname ->
+ "Statistics for " ++ prettyShow mname
+ reportSLn "profile" 1 $ Boxes.render table
diff --git a/src/full/Agda/TypeChecking/Monad/Trace.hs b/src/full/Agda/TypeChecking/Monad/Trace.hs
index c6d1436..a1f7977 100644
--- a/src/full/Agda/TypeChecking/Monad/Trace.hs
+++ b/src/full/Agda/TypeChecking/Monad/Trace.hs
@@ -1,4 +1,3 @@
-
module Agda.TypeChecking.Monad.Trace where
import Prelude hiding (null)
@@ -21,12 +20,12 @@ import Agda.Utils.Null
interestingCall :: Closure Call -> Bool
interestingCall cl = case clValue cl of
- InferVar _ _ -> False
- InferDef _ _ _ -> False
+ InferVar _ _ -> False
+ InferDef _ _ _ -> False
CheckArguments _ [] _ _ _ -> False
- SetRange _ _ -> False
+ SetRange _ _ -> False
NoHighlighting {} -> False
- _ -> True
+ _ -> True
traceCallM :: MonadTCM tcm => tcm (Maybe r -> Call) -> tcm a -> tcm a
traceCallM mkCall m = flip traceCall m =<< mkCall
diff --git a/src/full/Agda/TypeChecking/Patterns/Abstract.hs b/src/full/Agda/TypeChecking/Patterns/Abstract.hs
index 3524913..1abc9bb 100644
--- a/src/full/Agda/TypeChecking/Patterns/Abstract.hs
+++ b/src/full/Agda/TypeChecking/Patterns/Abstract.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | Tools to manipulate patterns in abstract syntax
@@ -8,49 +8,23 @@
module Agda.TypeChecking.Patterns.Abstract where
--- import Control.Applicative
--- import Control.Monad.Error
-
--- import Data.Maybe (fromMaybe)
--- import Data.Monoid (mempty, mappend)
import Data.List
import Data.Traversable hiding (mapM, sequence)
--- import Agda.Interaction.Options
-
-import Agda.Syntax.Common as Common
-import Agda.Syntax.Literal
-import Agda.Syntax.Position
-import Agda.Syntax.Internal as I
--- import Agda.Syntax.Internal.Pattern
--- import Agda.Syntax.Abstract (IsProjP(..))
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Views
+import Agda.Syntax.Common as Common
import Agda.Syntax.Info as A
+import Agda.Syntax.Internal as I
+import Agda.Syntax.Literal
+import Agda.Syntax.Position
import Agda.TypeChecking.Monad
--- import Agda.TypeChecking.Pretty
--- import Agda.TypeChecking.Reduce
--- import Agda.TypeChecking.Substitute
--- import Agda.TypeChecking.Constraints
--- import Agda.TypeChecking.Conversion
--- import Agda.TypeChecking.Datatypes
--- import Agda.TypeChecking.Records
--- import Agda.TypeChecking.Rules.LHS.Problem
import Agda.TypeChecking.Monad.Builtin
--- import Agda.TypeChecking.Free
--- import Agda.TypeChecking.Irrelevance
--- import Agda.TypeChecking.MetaVars
import Agda.Utils.Functor
--- import Agda.Utils.List
--- import Agda.Utils.Maybe
--- import Agda.Utils.Monad
--- import Agda.Utils.Permutation
--- import Agda.Utils.Tuple
--- import qualified Agda.Utils.Pretty as P
-
-#include "../../undefined.h"
+
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Expand literal integer pattern into suc/zero constructor patterns.
@@ -117,6 +91,6 @@ instance ExpandPatternSynonyms A.Pattern where
instPatternSyn (ns, p) as = do
p <- expandPatternSynonyms p
case A.insertImplicitPatSynArgs (A.ImplicitP . PatRange) (getRange x) ns as of
- Nothing -> typeError $ GenericError $ "Bad arguments to pattern synonym " ++ show x
- Just (_, _:_) -> typeError $ GenericError $ "Too few arguments to pattern synonym " ++ show x
+ Nothing -> typeError $ BadArgumentsToPatternSynonym x
+ Just (_, _:_) -> typeError $ TooFewArgumentsToPatternSynonym x
Just (s, []) -> return $ setRange (getRange i) $ A.substPattern s p
diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs b/src/full/Agda/TypeChecking/Patterns/Match.hs
index f9ca052..0a8f5f1 100644
--- a/src/full/Agda/TypeChecking/Patterns/Match.hs
+++ b/src/full/Agda/TypeChecking/Patterns/Match.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.TypeChecking.Patterns.Match where
@@ -21,13 +21,15 @@ import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | If matching is inconclusive (@DontKnow@) we want to know whether
-- it is due to a particular meta variable.
-data Match a = Yes Simplification [a] | No | DontKnow (Maybe MetaId)
- deriving (Functor)
+data Match a = Yes Simplification [a]
+ | No
+ | DontKnow (Maybe MetaId)
+ deriving Functor
instance Monoid (Match a) where
mempty = Yes mempty []
@@ -35,7 +37,7 @@ instance Monoid (Match a) where
Yes s us `mappend` Yes s' vs = Yes (s `mappend` s') (us ++ vs)
Yes _ _ `mappend` No = No
Yes _ _ `mappend` DontKnow m = DontKnow m
- No `mappend` _ = No
+ No `mappend` _ = No
-- Nothing means blocked by a variable. In this case no instantiation of
-- meta-variables will make progress.
@@ -43,7 +45,7 @@ instance Monoid (Match a) where
-- One could imagine DontKnow _ `mappend` No = No, but would break the
-- equivalence to case-trees.
- DontKnow m `mappend` _ = DontKnow m
+ DontKnow m `mappend` _ = DontKnow m
-- | Instead of 'zipWithM', we need to use this lazy version
-- of combining pattern matching computations.
@@ -141,27 +143,27 @@ matchPattern p u = case (p, u) of
w <- reduceB' v
let arg' = arg $> ignoreBlocking w
case ignoreSharing <$> w of
- NotBlocked (Lit l')
- | l == l' -> return (Yes YesSimplification [] , arg')
- | otherwise -> return (No , arg')
- NotBlocked (MetaV x _) -> return (DontKnow $ Just x , arg')
- Blocked x _ -> return (DontKnow $ Just x , arg')
- _ -> return (DontKnow Nothing , arg')
+ NotBlocked (Lit l')
+ | l == l' -> return (Yes YesSimplification [] , arg')
+ | otherwise -> return (No , arg')
+ NotBlocked (MetaV x _) -> return (DontKnow $ Just x , arg')
+ Blocked x _ -> return (DontKnow $ Just x , arg')
+ _ -> return (DontKnow Nothing , arg')
{- Andreas, 2012-04-02 NO LONGER UP-TO-DATE
matchPattern (Arg h' r' (ConP c _ ps)) (Arg h Irrelevant v) = do
-- Andreas, 2010-09-07 matching a record constructor against
-- something irrelevant will just continue matching against
-- irrelevant stuff
- (m, vs) <- matchPatterns ps $
+ (m, vs) <- matchPatterns ps $
repeat $ Arg NotHidden Irrelevant $ DontCare __IMPOSSIBLE__
- return (m, Arg h Irrelevant $ Con c vs)
+ return (m, Arg h Irrelevant $ Con c vs)
-}
-- Case record pattern: always succeed!
-- This case is necessary if we want to use the clauses before
-- record pattern translation (e.g., in type-checking definitions by copatterns).
- (ConP con@(ConHead c ds) Just{} ps, arg@(Arg info v))
+ (ConP con@(ConHead c _ ds) Just{} ps, arg@(Arg info v))
-- precondition: con actually comes with the record fields
| size ds == size ps -> mapSnd (Arg info . Con con) <$> do
matchPatterns ps $ for ds $ \ d -> Arg info $ v `applyE` [Proj d]
@@ -170,7 +172,7 @@ matchPattern (Arg h' r' (ConP c _ ps)) (Arg h Irrelevant v) = do
-- Case data constructor pattern.
(ConP c _ ps, Arg info v) ->
- do w <- traverse constructorForm =<< reduceB' v
+ do w <- traverse constructorForm =<< reduceB' v
-- Unfold delayed (corecursive) definitions one step. This is
-- only necessary if c is a coinductive constructor, but
-- 1) it does not hurt to do it all the time, and
@@ -185,7 +187,7 @@ matchPattern (Arg h' r' (ConP c _ ps)) (Arg h Irrelevant v) = do
-- unfolded (due to open public).
_ -> return w
let v = ignoreBlocking w
- case ignoreSharing <$> w of
+ case ignoreSharing <$> w of
{- Andreas, 2013-10-27 the following considered HARMFUL:
-- Andreas, 2010-09-07 matching a record constructor against
@@ -193,19 +195,23 @@ matchPattern (Arg h' r' (ConP c _ ps)) (Arg h Irrelevant v) = do
-- irrelevant stuff
-- NotBlocked (Sort Prop)
_ | isIrrelevant info -> do
- (m, vs) <- matchPatterns ps $
+ (m, vs) <- matchPatterns ps $
repeat $ setRelevance Irrelevant $ defaultArg $ Sort Prop
-- repeat looks very bad here (non-termination!)
- return (m, Arg info $ Con c vs)
+ return (m, Arg info $ Con c vs)
-}
- NotBlocked (Con c' vs)
- | c == c' -> do
- (m, vs) <- yesSimplification <$> matchPatterns ps vs
- return (m, Arg info $ Con c' vs)
- | otherwise -> return (No, Arg info v) -- NOTE: v the reduced thing(shadowing!). Andreas, 2013-07-03
- NotBlocked (MetaV x vs) -> return (DontKnow $ Just x, Arg info v)
- Blocked x _ -> return (DontKnow $ Just x, Arg info v)
+ NotBlocked (Con c' vs)
+ | c == c' -> do
+ (m, vs) <- yesSimplification <$> matchPatterns ps vs
+ return (m, Arg info $ Con c' vs)
+ | otherwise -> return (No, Arg info v) -- NOTE: v the reduced thing(shadowing!). Andreas, 2013-07-03
+ NotBlocked (MetaV x vs) -> return (DontKnow $ Just x, Arg info v)
+ Blocked x _ -> return (DontKnow $ Just x, Arg info v)
_ -> return (DontKnow Nothing, Arg info v)
+-- ASR (08 November 2014). The type of the function could be
+--
+-- @(Match Term, [I.Arg Term]) -> (Match Term, [I.Arg Term])@.
+yesSimplification :: (Match a, b) -> (Match a, b)
yesSimplification (Yes _ vs, us) = (Yes YesSimplification vs, us)
yesSimplification r = r
diff --git a/src/full/Agda/TypeChecking/Polarity.hs b/src/full/Agda/TypeChecking/Polarity.hs
index 74db82b..0578320 100644
--- a/src/full/Agda/TypeChecking/Polarity.hs
+++ b/src/full/Agda/TypeChecking/Polarity.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.Polarity where
@@ -29,7 +29,7 @@ import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -205,7 +205,7 @@ relevantInIgnoringNonvariant i t (p:ps) = do
-- | Record information that an argument is unused in 'Relevance'.
mkUnused :: Relevance -> Relevance
-mkUnused Relevant = UnusedArg -- commenting out this line switches of 'UnusedArg' polarity machinery
+mkUnused Relevant = UnusedArg -- commenting out this line switches off 'UnusedArg' polarity machinery
mkUnused r = r -- 'Irrelevant' is more informative than 'UnusedArg'.
-- | Improve 'Relevance' information in a type by polarity information.
diff --git a/src/full/Agda/TypeChecking/Positivity.hs b/src/full/Agda/TypeChecking/Positivity.hs
index ef09a85..c8d02e3 100644
--- a/src/full/Agda/TypeChecking/Positivity.hs
+++ b/src/full/Agda/TypeChecking/Positivity.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -38,7 +38,7 @@ import Agda.Utils.SemiRing
import qualified Agda.Utils.Graph.AdjacencyMap as Graph
import Agda.Utils.Graph.AdjacencyMap (Graph)
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Check that the datatypes in the mutual block containing the given
@@ -73,8 +73,7 @@ checkStrictlyPositive qs = disableDestructiveUpdate $ do
let sccs = Graph.sccs gstar
reportSDoc "tc.pos.graph.sccs" 15 $ text $ " sccs = " ++ show sccs
forM_ sccs $ \ scc -> setMut [ q | DefNode q <- scc ]
- whenM positivityCheckEnabled $
- mapM_ (checkPos g) $ Set.toList qs
+ mapM_ (checkPos g) $ Set.toList qs
reportSDoc "tc.pos.tick" 100 $ text "checked positivity"
where
@@ -89,14 +88,16 @@ checkStrictlyPositive qs = disableDestructiveUpdate $ do
loops = filter (critical dr) $ Graph.allPaths (critical dr) (DefNode q) (DefNode q) g
-- if we have a negative loop, raise error
- forM_ [ how | Edge o how <- loops, o <= JustPos ] $ \ how -> do
+ whenM positivityCheckEnabled $ do
+ forM_ [ how | Edge o how <- loops, o <= JustPos ] $ \ how -> do
err <- fsep $
[prettyTCM q] ++ pwords "is not strictly positive, because it occurs" ++
[prettyTCM how]
- setCurrentRange (getRange q) $ typeError $ GenericError (show err)
+ setCurrentRange (getRange q) $ typeError $ GenericDocError err
-- if we find an unguarded record, mark it as such
- case mhead [ how | Edge o how <- loops, o <= StrictPos ] of
+ when (dr == IsRecord) $ do
+ case headMaybe [ how | Edge o how <- loops, o <= StrictPos ] of
Just how -> do
reportSDoc "tc.pos.record" 5 $ sep
[ prettyTCM q <+> text "is not guarded, because it occurs"
@@ -113,7 +114,7 @@ checkStrictlyPositive qs = disableDestructiveUpdate $ do
recursiveRecord q
checkInduction q
- checkInduction q = do
+ checkInduction q = whenM positivityCheckEnabled $ do
-- Check whether the recursive record has been declared as
-- 'Inductive' or 'Coinductive'. Otherwise, error.
unlessM (isJust . recInduction . theDef <$> getConstInfo q) $ do
@@ -154,6 +155,7 @@ checkStrictlyPositive qs = disableDestructiveUpdate $ do
-- it is computed deep-strictly.
setArgOccurrences q $!! args
+getDefArity :: Definition -> TCM Int
getDefArity def = case theDef def of
Function{ funClauses = cs, funProjection = proj } -> do
let dropped = maybe 0 (subtract 1 . projIndex) proj
diff --git a/src/full/Agda/TypeChecking/Pretty.hs b/src/full/Agda/TypeChecking/Pretty.hs
index 3a938a0..0fda40d 100644
--- a/src/full/Agda/TypeChecking/Pretty.hs
+++ b/src/full/Agda/TypeChecking/Pretty.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -25,7 +25,7 @@ import Agda.TypeChecking.Monad
import qualified Agda.Utils.Pretty as P
import Agda.Utils.Permutation (Permutation)
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -35,41 +35,59 @@ import Agda.Utils.Impossible
type Doc = P.Doc
empty, comma, colon, equals :: TCM Doc
+empty = return P.empty
+comma = return P.comma
+colon = return P.colon
+equals = return P.equals
-empty = return P.empty
-comma = return P.comma
-colon = return P.colon
-equals = return P.equals
-pretty x = return $ P.pretty x
-prettyA x = P.prettyA x
+pretty :: P.Pretty a => a -> TCM P.Doc
+pretty x = return $ P.pretty x
+
+prettyA :: (P.Pretty c, ToConcrete a c) => a -> TCM Doc
+prettyA x = P.prettyA x
+
+prettyAs :: (P.Pretty c, ToConcrete a [c]) => a -> TCM Doc
prettyAs x = P.prettyAs x
+
text :: String -> TCM Doc
-text s = return $ P.text s
-pwords s = map return $ P.pwords s
-fwords s = return $ P.fwords s
-sep, fsep, hsep, vcat :: [TCM Doc] -> TCM Doc
-sep ds = P.sep <$> sequence ds
-fsep ds = P.fsep <$> sequence ds
-hsep ds = P.hsep <$> sequence ds
-hcat ds = P.hcat <$> sequence ds
-vcat ds = P.vcat <$> sequence ds
+text s = return $ P.text s
+
+pwords :: String -> [TCM Doc]
+pwords s = map return $ P.pwords s
+
+fwords :: String -> TCM Doc
+fwords s = return $ P.fwords s
+
+sep, fsep, hsep, hcat, vcat :: [TCM Doc] -> TCM Doc
+sep ds = P.sep <$> sequence ds
+fsep ds = P.fsep <$> sequence ds
+hsep ds = P.hsep <$> sequence ds
+hcat ds = P.hcat <$> sequence ds
+vcat ds = P.vcat <$> sequence ds
+
($$), ($+$), (<>), (<+>) :: TCM Doc -> TCM Doc -> TCM Doc
-d1 $$ d2 = (P.$$) <$> d1 <*> d2
-d1 $+$ d2 = (P.$+$) <$> d1 <*> d2
-d1 <> d2 = (P.<>) <$> d1 <*> d2
-d1 <+> d2 = (P.<+>) <$> d1 <*> d2
+d1 $$ d2 = (P.$$) <$> d1 <*> d2
+d1 $+$ d2 = (P.$+$) <$> d1 <*> d2
+d1 <> d2 = (P.<>) <$> d1 <*> d2
+d1 <+> d2 = (P.<+>) <$> d1 <*> d2
+
+nest :: Int -> TCM Doc -> TCM Doc
nest n d = P.nest n <$> d
+
+braces, dbraces, brackets, parens :: TCM Doc -> TCM Doc
braces d = P.braces <$> d
dbraces d = P.dbraces <$> d
brackets d = P.brackets <$> d
parens d = P.parens <$> d
+prettyList :: [TCM Doc] -> TCM Doc
prettyList ds = brackets $ fsep $ punctuate comma ds
+punctuate :: TCM Doc -> [TCM Doc] -> [TCM Doc]
punctuate _ [] = []
punctuate d ds = zipWith (<>) ds (replicate n d ++ [empty])
- where
- n = length ds - 1
+ where
+ n = length ds - 1
---------------------------------------------------------------------------
-- * The PrettyTCM class
@@ -172,40 +190,40 @@ instance PrettyTCM ProblemConstraint where
instance PrettyTCM Constraint where
prettyTCM c = case c of
- ValueCmp cmp ty s t ->
- sep [ sep [ prettyTCM s
- , prettyTCM cmp <+> prettyTCM t
- ]
- , nest 2 $ text ":" <+> prettyTCM ty
- ]
+ ValueCmp cmp ty s t ->
+ sep [ sep [ prettyTCM s
+ , prettyTCM cmp <+> prettyTCM t
+ ]
+ , nest 2 $ text ":" <+> prettyTCM ty
+ ]
ElimCmp cmps t v us vs ->
sep [ sep [ prettyTCM us
, nest 2 $ text "~~" <+> prettyTCM vs
]
, text ":" <+> prettyTCM t ]
- LevelCmp cmp a b ->
- sep [ prettyTCM a
- , prettyTCM cmp <+> prettyTCM b
- ]
- TypeCmp cmp a b ->
- sep [ prettyTCM a
- , prettyTCM cmp <+> prettyTCM b
- ]
- TelCmp a b cmp tela telb ->
- sep [ prettyTCM tela
- , prettyTCM cmp <+> prettyTCM telb
- ]
- SortCmp cmp s1 s2 ->
- sep [ prettyTCM s1
- , prettyTCM cmp <+> prettyTCM s2
- ]
- Guarded c pid ->
- sep [ prettyTCM c
- , nest 2 $ brackets $ text "blocked on problem" <+> text (show pid)
- ]
- UnBlock m -> do
- -- BlockedConst t <- mvInstantiation <$> lookupMeta m
- mi <- mvInstantiation <$> lookupMeta m
+ LevelCmp cmp a b ->
+ sep [ prettyTCM a
+ , prettyTCM cmp <+> prettyTCM b
+ ]
+ TypeCmp cmp a b ->
+ sep [ prettyTCM a
+ , prettyTCM cmp <+> prettyTCM b
+ ]
+ TelCmp a b cmp tela telb ->
+ sep [ prettyTCM tela
+ , prettyTCM cmp <+> prettyTCM telb
+ ]
+ SortCmp cmp s1 s2 ->
+ sep [ prettyTCM s1
+ , prettyTCM cmp <+> prettyTCM s2
+ ]
+ Guarded c pid ->
+ sep [ prettyTCM c
+ , nest 2 $ brackets $ text "blocked on problem" <+> text (show pid)
+ ]
+ UnBlock m -> do
+ -- BlockedConst t <- mvInstantiation <$> lookupMeta m
+ mi <- mvInstantiation <$> lookupMeta m
case mi of
BlockedConst t ->
sep [ text (show m) <+> text ":="
@@ -218,11 +236,11 @@ instance PrettyTCM Constraint where
OpenIFS{} -> __IMPOSSIBLE__
InstS{} -> __IMPOSSIBLE__
InstV{} -> __IMPOSSIBLE__
- FindInScope m Nothing -> do
+ FindInScope m Nothing -> do
t <- getMetaType m
sep [ text $ "Find in scope " ++ (show m) ++ " :" ++ (show t) ++ " (no candidate for now)"
]
- FindInScope m (Just cands) -> do
+ FindInScope m (Just cands) -> do
t <- getMetaType m
sep [ text $ "Find in scope " ++ (show m) ++ " :"
, nest 2 $ prettyTCM t
@@ -267,7 +285,7 @@ instance PrettyTCM PrettyContext where
prettyTCM (PrettyContext ctx) = P.fsep . reverse <$> pr (map ctxEntry ctx)
where
pr :: [Dom (Name, Type)] -> TCM [P.Doc]
- pr [] = return []
+ pr [] = return []
pr (Common.Dom info (x,t) : ctx) = escapeContext 1 $ do
d <- prettyTCM t
x <- prettyTCM x
diff --git a/src/full/Agda/TypeChecking/Pretty.hs-boot b/src/full/Agda/TypeChecking/Pretty.hs-boot
index cb9b908..4d383ce 100644
--- a/src/full/Agda/TypeChecking/Pretty.hs-boot
+++ b/src/full/Agda/TypeChecking/Pretty.hs-boot
@@ -1,4 +1,6 @@
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
module Agda.TypeChecking.Pretty where
-- import Agda.Syntax.Common
diff --git a/src/full/Agda/TypeChecking/Primitive.hs b/src/full/Agda/TypeChecking/Primitive.hs
index 83669f7..acd71b1 100644
--- a/src/full/Agda/TypeChecking/Primitive.hs
+++ b/src/full/Agda/TypeChecking/Primitive.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
{-| Primitive functions, such as addition on builtin integers.
-}
@@ -15,6 +15,7 @@ import Control.Applicative
import Data.Char
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Maybe
import Agda.Interaction.Options
@@ -32,14 +33,14 @@ import Agda.TypeChecking.Reduce.Monad
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Errors
import Agda.TypeChecking.Level
-import Agda.TypeChecking.Quote (quotingKit)
+import Agda.TypeChecking.Quote (QuotingKit, quoteTermWithKit, quoteTypeWithKit, quoteClauseWithKit, quotingKit)
import Agda.TypeChecking.Pretty () -- instances only
import Agda.Utils.Monad
import Agda.Utils.Pretty (pretty)
-import Agda.Utils.Maybe
+import Agda.Utils.String ( Str(Str), unStr )
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
import Debug.Trace
@@ -51,9 +52,6 @@ data PrimitiveImpl = PrimImpl Type PrimFun
-- Haskell type to Agda type
-newtype Str = Str { unStr :: String }
- deriving (Eq, Ord)
-
newtype Nat = Nat { unNat :: Integer }
deriving (Eq, Ord, Num, Enum, Real)
@@ -82,13 +80,13 @@ instance (PrimType a, PrimType b) => PrimTerm (a -> b) where
instance PrimTerm a => PrimType a where
primType _ = el $ primTerm (undefined :: a)
-class PrimTerm a where primTerm :: a -> TCM Term
+class PrimTerm a where primTerm :: a -> TCM Term
instance PrimTerm Integer where primTerm _ = primInteger
-instance PrimTerm Bool where primTerm _ = primBool
-instance PrimTerm Char where primTerm _ = primChar
+instance PrimTerm Bool where primTerm _ = primBool
+instance PrimTerm Char where primTerm _ = primChar
instance PrimTerm Double where primTerm _ = primFloat
-instance PrimTerm Str where primTerm _ = primString
-instance PrimTerm Nat where primTerm _ = primNat
+instance PrimTerm Str where primTerm _ = primString
+instance PrimTerm Nat where primTerm _ = primNat
instance PrimTerm Lvl where primTerm _ = primLevel
instance PrimTerm QName where primTerm _ = primQName
instance PrimTerm Type where primTerm _ = primAgdaType
@@ -108,26 +106,26 @@ class ToTerm a where
toTermR = (pure .) <$> toTerm
instance ToTerm Integer where toTerm = return $ Lit . LitInt noRange
-instance ToTerm Nat where toTerm = return $ Lit . LitInt noRange . unNat
-instance ToTerm Lvl where toTerm = return $ Level . Max . (:[]) . ClosedLevel . unLvl
+instance ToTerm Nat where toTerm = return $ Lit . LitInt noRange . unNat
+instance ToTerm Lvl where toTerm = return $ Level . Max . (:[]) . ClosedLevel . unLvl
instance ToTerm Double where toTerm = return $ Lit . LitFloat noRange
-instance ToTerm Char where toTerm = return $ Lit . LitChar noRange
-instance ToTerm Str where toTerm = return $ Lit . LitString noRange . unStr
-instance ToTerm QName where toTerm = return $ Lit . LitQName noRange
+instance ToTerm Char where toTerm = return $ Lit . LitChar noRange
+instance ToTerm Str where toTerm = return $ Lit . LitString noRange . unStr
+instance ToTerm QName where toTerm = return $ Lit . LitQName noRange
instance ToTerm Bool where
toTerm = do
- true <- primTrue
- false <- primFalse
- return $ \b -> if b then true else false
+ true <- primTrue
+ false <- primFalse
+ return $ \b -> if b then true else false
instance ToTerm Term where
- toTerm = do (f, _, _) <- quotingKit; runReduceF f
- toTermR = do (f, _, _) <- quotingKit; return f
+ toTerm = do kit <- quotingKit; runReduceF (quoteTermWithKit kit)
+ toTermR = do kit <- quotingKit; return (quoteTermWithKit kit)
instance ToTerm Type where
- toTerm = do (_, f, _) <- quotingKit; runReduceF f
- toTermR = do (_, f, _) <- quotingKit; return f
+ toTerm = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit)
+ toTermR = do kit <- quotingKit; return (quoteTypeWithKit kit)
instance ToTerm I.ArgInfo where
toTerm = do
@@ -158,14 +156,14 @@ buildList = do
nil' <- primNil
cons' <- primCons
let nil = nil'
- cons x xs = cons' `apply` [defaultArg x, defaultArg xs]
+ cons x xs = cons' `apply` [defaultArg x, defaultArg xs]
return $ foldr cons nil
instance (PrimTerm a, ToTerm a) => ToTerm [a] where
toTerm = do
- mkList <- buildList
- fromA <- toTerm
- return $ mkList . map fromA
+ mkList <- buildList
+ fromA <- toTerm
+ return $ mkList . map fromA
-- From Haskell value to Agda term
@@ -176,52 +174,52 @@ class FromTerm a where
instance FromTerm Integer where
fromTerm = fromLiteral $ \l -> case l of
- LitInt _ n -> Just n
- _ -> Nothing
+ LitInt _ n -> Just n
+ _ -> Nothing
instance FromTerm Nat where
fromTerm = fromLiteral $ \l -> case l of
- LitInt _ n -> Just $ Nat n
- _ -> Nothing
+ LitInt _ n -> Just $ Nat n
+ _ -> Nothing
instance FromTerm Lvl where
fromTerm = fromReducedTerm $ \l -> case l of
- Level (Max [ClosedLevel n]) -> Just $ Lvl n
- _ -> Nothing
+ Level (Max [ClosedLevel n]) -> Just $ Lvl n
+ _ -> Nothing
instance FromTerm Double where
fromTerm = fromLiteral $ \l -> case l of
- LitFloat _ x -> Just x
- _ -> Nothing
+ LitFloat _ x -> Just x
+ _ -> Nothing
instance FromTerm Char where
fromTerm = fromLiteral $ \l -> case l of
- LitChar _ c -> Just c
- _ -> Nothing
+ LitChar _ c -> Just c
+ _ -> Nothing
instance FromTerm Str where
fromTerm = fromLiteral $ \l -> case l of
- LitString _ s -> Just $ Str s
- _ -> Nothing
+ LitString _ s -> Just $ Str s
+ _ -> Nothing
instance FromTerm QName where
fromTerm = fromLiteral $ \l -> case l of
- LitQName _ x -> Just x
- _ -> Nothing
+ LitQName _ x -> Just x
+ _ -> Nothing
instance FromTerm Bool where
fromTerm = do
- true <- primTrue
- false <- primFalse
- fromReducedTerm $ \t -> case t of
- _ | t === true -> Just True
- | t === false -> Just False
- | otherwise -> Nothing
- where
- Def x [] === Def y [] = x == y
- Con x [] === Con y [] = x == y
- Var n [] === Var m [] = n == m
- _ === _ = False
+ true <- primTrue
+ false <- primFalse
+ fromReducedTerm $ \t -> case t of
+ _ | t === true -> Just True
+ | t === false -> Just False
+ | otherwise -> Nothing
+ where
+ Def x [] === Def y [] = x == y
+ Con x [] === Con y [] = x == y
+ Var n [] === Var m [] = n == m
+ _ === _ = False
instance (ToTerm a, FromTerm a) => FromTerm [a] where
fromTerm = do
@@ -260,12 +258,12 @@ instance (ToTerm a, FromTerm a) => FromTerm [a] where
-- | 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')
+ (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
+ NoReduction x -> return $ NoReduction $ f x
+ YesReduction _ y -> k y
redReturn :: a -> ReduceM (Reduced a' a)
redReturn = return . YesReduction YesSimplification
@@ -274,13 +272,13 @@ fromReducedTerm :: (Term -> Maybe a) -> TCM (FromTermFunction a)
fromReducedTerm f = return $ \t -> do
b <- reduceB' t
case f $ ignoreSharing $ unArg (ignoreBlocking b) of
- Just x -> return $ YesReduction NoSimplification x
- Nothing -> return $ NoReduction (reduced b)
+ Just x -> return $ YesReduction NoSimplification x
+ Nothing -> return $ NoReduction (reduced b)
fromLiteral :: (Literal -> Maybe a) -> TCM (FromTermFunction a)
fromLiteral f = fromReducedTerm $ \t -> case t of
Lit lit -> f lit
- _ -> Nothing
+ _ -> Nothing
-- trustMe : {a : Level} {A : Set a} {x y : A} -> x ≡ y
primTrustMe :: TCM PrimitiveImpl
@@ -309,7 +307,7 @@ primTrustMe = do
-- like this.
-- We can only do untyped equality, e.g., by normalisation.
(u', v') <- normalise' (u, v)
- if (u' == v') then redReturn (refl $ unArg u) else
+ if u' == v' then redReturn (refl $ unArg u) else
return (NoReduction $ map notReduced [a, t, u, v])
{- OLD:
@@ -323,12 +321,12 @@ primTrustMe = do
primQNameType :: TCM PrimitiveImpl
primQNameType = mkPrimFun1TCM (el primQName --> el primAgdaType)
- (\q -> defType <$> getConstInfo q)
+ (\q -> normalise' . defType =<< getConstInfo q)
-- Note: gets the top-level type! All bounds variables have been lifted.
primQNameDefinition :: TCM PrimitiveImpl
primQNameDefinition = do
- (_, qType, qClause) <- quotingKit
+ kit <- quotingKit
agdaFunDef <- primAgdaFunDef
agdaFunDefCon <- primAgdaFunDefCon
agdaDefinitionFunDef <- primAgdaDefinitionFunDef
@@ -339,7 +337,9 @@ primQNameDefinition = do
agdaDefinitionDataConstructor <- primAgdaDefinitionDataConstructor
list <- buildList
- let defapp f xs = apply f . map defaultArg <$> sequence xs
+ let qType = quoteTypeWithKit kit
+ qClause = quoteClauseWithKit kit
+ defapp f xs = apply f . map defaultArg <$> sequence xs
qFunDef t cs = defapp agdaFunDefCon [qType t, list <$> mapM qClause cs]
qQName = Lit . LitQName noRange
con qn = do
@@ -403,11 +403,11 @@ mkPrimFun1TCM mt f = do
-- Tying the knot
mkPrimFun1 :: (PrimType a, PrimType b, FromTerm a, ToTerm b) =>
- (a -> b) -> TCM PrimitiveImpl
+ (a -> b) -> TCM PrimitiveImpl
mkPrimFun1 f = do
toA <- fromTerm
fromB <- toTerm
- t <- primType f
+ t <- primType f
return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 1 $ \ts ->
case ts of
[v] ->
@@ -417,13 +417,13 @@ mkPrimFun1 f = do
_ -> __IMPOSSIBLE__
mkPrimFun2 :: (PrimType a, PrimType b, PrimType c, FromTerm a, ToTerm a, FromTerm b, ToTerm c) =>
- (a -> b -> c) -> TCM PrimitiveImpl
+ (a -> b -> c) -> TCM PrimitiveImpl
mkPrimFun2 f = do
toA <- fromTerm
fromA <- toTerm
- toB <- fromTerm
+ toB <- fromTerm
fromC <- toTerm
- t <- primType f
+ t <- primType f
return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 2 $ \ts ->
case ts of
[v,w] ->
@@ -440,7 +440,7 @@ mkPrimFun4 :: ( PrimType a, FromTerm a, ToTerm a
, PrimType c, FromTerm c, ToTerm c
, PrimType d, FromTerm d
, PrimType e, ToTerm e) =>
- (a -> b -> c -> d -> e) -> TCM PrimitiveImpl
+ (a -> b -> c -> d -> e) -> TCM PrimitiveImpl
mkPrimFun4 f = do
(toA, fromA) <- (,) <$> fromTerm <*> toTerm
(toB, fromB) <- (,) <$> fromTerm <*> toTerm
@@ -497,7 +497,7 @@ gpi info name a b = do
(Pi (Dom info a) (Abs y b))
hPi, nPi :: String -> TCM Type -> TCM Type -> TCM Type
-hPi = gpi $ setHiding Hidden $ defaultArgInfo
+hPi = gpi $ setHiding Hidden defaultArgInfo
nPi = gpi defaultArgInfo
varM :: Int -> TCM Term
@@ -528,13 +528,17 @@ tset :: TCM Type
tset = return $ sort (mkType 0)
-- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@.
-
+argN :: e -> I.Arg e
argN = Arg defaultArgInfo
+
+domN :: e -> I.Dom e
domN = Dom defaultArgInfo
-- | Abbreviation: @argH = 'hide' 'Arg' 'defaultArgInfo'@.
-
+argH :: e -> I.Arg e
argH = Arg $ setHiding Hidden defaultArgInfo
+
+domH :: e -> I.Dom e
domH = Dom $ setHiding Hidden defaultArgInfo
---------------------------------------------------------------------------
@@ -550,71 +554,71 @@ primitiveFunctions :: Map String (TCM PrimitiveImpl)
primitiveFunctions = Map.fromList
-- Integer functions
- [ "primIntegerPlus" |-> mkPrimFun2 ((+) :: Op Integer)
- , "primIntegerMinus" |-> mkPrimFun2 ((-) :: Op Integer)
- , "primIntegerTimes" |-> mkPrimFun2 ((*) :: Op Integer)
- , "primIntegerDiv" |-> mkPrimFun2 (div :: Op Integer) -- partial
- , "primIntegerMod" |-> mkPrimFun2 (mod :: Op Integer) -- partial
+ [ "primIntegerPlus" |-> mkPrimFun2 ((+) :: Op Integer)
+ , "primIntegerMinus" |-> mkPrimFun2 ((-) :: Op Integer)
+ , "primIntegerTimes" |-> mkPrimFun2 ((*) :: Op Integer)
+ , "primIntegerDiv" |-> mkPrimFun2 (div :: Op Integer) -- partial
+ , "primIntegerMod" |-> mkPrimFun2 (mod :: Op Integer) -- partial
, "primIntegerEquality" |-> mkPrimFun2 ((==) :: Rel Integer)
- , "primIntegerLess" |-> mkPrimFun2 ((<) :: Rel Integer)
+ , "primIntegerLess" |-> mkPrimFun2 ((<) :: Rel Integer)
, "primIntegerAbs" |-> mkPrimFun1 (Nat . abs :: Integer -> Nat)
, "primNatToInteger" |-> mkPrimFun1 (unNat :: Nat -> Integer)
- , "primShowInteger" |-> mkPrimFun1 (Str . show :: Integer -> Str)
+ , "primShowInteger" |-> mkPrimFun1 (Str . show :: Integer -> Str)
-- Natural number functions
- , "primNatPlus" |-> mkPrimFun2 ((+) :: Op Nat)
- , "primNatMinus" |-> mkPrimFun2 ((\x y -> max 0 (x - y)) :: Op Nat)
- , "primNatTimes" |-> mkPrimFun2 ((*) :: Op Nat)
+ , "primNatPlus" |-> mkPrimFun2 ((+) :: Op Nat)
+ , "primNatMinus" |-> mkPrimFun2 ((\x y -> max 0 (x - y)) :: Op Nat)
+ , "primNatTimes" |-> mkPrimFun2 ((*) :: Op Nat)
, "primNatDivSucAux" |-> mkPrimFun4 ((\k m n j -> k + div (max 0 $ n + m - j) (m + 1)) :: Nat -> Nat -> Nat -> Nat -> Nat)
, "primNatModSucAux" |->
let aux :: Nat -> Nat -> Nat -> Nat -> Nat
aux k m n j | n > j = mod (n - j - 1) (m + 1)
| otherwise = k + n
in mkPrimFun4 aux
- , "primNatEquality" |-> mkPrimFun2 ((==) :: Rel Nat)
- , "primNatLess" |-> mkPrimFun2 ((<) :: Rel Nat)
- , "primLevelZero" |-> mkPrimLevelZero
- , "primLevelSuc" |-> mkPrimLevelSuc
- , "primLevelMax" |-> mkPrimLevelMax
+ , "primNatEquality" |-> mkPrimFun2 ((==) :: Rel Nat)
+ , "primNatLess" |-> mkPrimFun2 ((<) :: Rel Nat)
+ , "primLevelZero" |-> mkPrimLevelZero
+ , "primLevelSuc" |-> mkPrimLevelSuc
+ , "primLevelMax" |-> mkPrimLevelMax
-- Floating point functions
, "primIntegerToFloat" |-> mkPrimFun1 (fromIntegral :: Integer -> Double)
- , "primFloatPlus" |-> mkPrimFun2 ((+) :: Op Double)
- , "primFloatMinus" |-> mkPrimFun2 ((-) :: Op Double)
- , "primFloatTimes" |-> mkPrimFun2 ((*) :: Op Double)
- , "primFloatDiv" |-> mkPrimFun2 ((/) :: Op Double)
- , "primFloatEquality" |-> mkPrimFun2 ((==) :: Rel Double)
- , "primFloatLess" |-> mkPrimFun2 ((<) :: Rel Double)
- , "primRound" |-> mkPrimFun1 (round :: Double -> Integer)
- , "primFloor" |-> mkPrimFun1 (floor :: Double -> Integer)
- , "primCeiling" |-> mkPrimFun1 (ceiling :: Double -> Integer)
- , "primExp" |-> mkPrimFun1 (exp :: Fun Double)
- , "primLog" |-> mkPrimFun1 (log :: Fun Double) -- partial
- , "primSin" |-> mkPrimFun1 (sin :: Fun Double)
- , "primShowFloat" |-> mkPrimFun1 (Str . show :: Double -> Str)
+ , "primFloatPlus" |-> mkPrimFun2 ((+) :: Op Double)
+ , "primFloatMinus" |-> mkPrimFun2 ((-) :: Op Double)
+ , "primFloatTimes" |-> mkPrimFun2 ((*) :: Op Double)
+ , "primFloatDiv" |-> mkPrimFun2 ((/) :: Op Double)
+ , "primFloatEquality" |-> mkPrimFun2 ((==) :: Rel Double)
+ , "primFloatLess" |-> mkPrimFun2 ((<) :: Rel Double)
+ , "primRound" |-> mkPrimFun1 (round :: Double -> Integer)
+ , "primFloor" |-> mkPrimFun1 (floor :: Double -> Integer)
+ , "primCeiling" |-> mkPrimFun1 (ceiling :: Double -> Integer)
+ , "primExp" |-> mkPrimFun1 (exp :: Fun Double)
+ , "primLog" |-> mkPrimFun1 (log :: Fun Double) -- partial
+ , "primSin" |-> mkPrimFun1 (sin :: Fun Double)
+ , "primShowFloat" |-> mkPrimFun1 (Str . show :: Double -> Str)
-- Character functions
, "primCharEquality" |-> mkPrimFun2 ((==) :: Rel Char)
- , "primIsLower" |-> mkPrimFun1 isLower
- , "primIsDigit" |-> mkPrimFun1 isDigit
- , "primIsAlpha" |-> mkPrimFun1 isAlpha
- , "primIsSpace" |-> mkPrimFun1 isSpace
- , "primIsAscii" |-> mkPrimFun1 isAscii
- , "primIsLatin1" |-> mkPrimFun1 isLatin1
- , "primIsPrint" |-> mkPrimFun1 isPrint
- , "primIsHexDigit" |-> mkPrimFun1 isHexDigit
- , "primToUpper" |-> mkPrimFun1 toUpper
- , "primToLower" |-> mkPrimFun1 toLower
+ , "primIsLower" |-> mkPrimFun1 isLower
+ , "primIsDigit" |-> mkPrimFun1 isDigit
+ , "primIsAlpha" |-> mkPrimFun1 isAlpha
+ , "primIsSpace" |-> mkPrimFun1 isSpace
+ , "primIsAscii" |-> mkPrimFun1 isAscii
+ , "primIsLatin1" |-> mkPrimFun1 isLatin1
+ , "primIsPrint" |-> mkPrimFun1 isPrint
+ , "primIsHexDigit" |-> mkPrimFun1 isHexDigit
+ , "primToUpper" |-> mkPrimFun1 toUpper
+ , "primToLower" |-> mkPrimFun1 toLower
, "primCharToNat" |-> mkPrimFun1 (fromIntegral . fromEnum :: Char -> Nat)
, "primNatToChar" |-> mkPrimFun1 (toEnum . fromIntegral :: Nat -> Char)
- , "primShowChar" |-> mkPrimFun1 (Str . show . pretty . LitChar noRange)
+ , "primShowChar" |-> mkPrimFun1 (Str . show . pretty . LitChar noRange)
-- String functions
, "primStringToList" |-> mkPrimFun1 unStr
, "primStringFromList" |-> mkPrimFun1 Str
, "primStringAppend" |-> mkPrimFun2 (\s1 s2 -> Str $ unStr s1 ++ unStr s2)
, "primStringEquality" |-> mkPrimFun2 ((==) :: Rel Str)
- , "primShowString" |-> mkPrimFun1 (Str . show . pretty . LitString noRange . unStr)
+ , "primShowString" |-> mkPrimFun1 (Str . show . pretty . LitString noRange . unStr)
-- Reflection
, "primQNameType" |-> primQNameType
@@ -627,13 +631,12 @@ primitiveFunctions = Map.fromList
, "primShowQName" |-> mkPrimFun1 (Str . show :: QName -> Str)
]
where
- (|->) = (,)
+ (|->) = (,)
lookupPrimitiveFunction :: String -> TCM PrimitiveImpl
lookupPrimitiveFunction x =
- case Map.lookup x primitiveFunctions of
- Just p -> p
- Nothing -> typeError $ NoSuchPrimitiveFunction x
+ fromMaybe (typeError $ NoSuchPrimitiveFunction x)
+ (Map.lookup x primitiveFunctions)
lookupPrimitiveFunctionQ :: QName -> TCM (String, PrimitiveImpl)
lookupPrimitiveFunctionQ q = do
diff --git a/src/full/Agda/TypeChecking/ProjectionLike.hs b/src/full/Agda/TypeChecking/ProjectionLike.hs
index bc8d598..8269586 100644
--- a/src/full/Agda/TypeChecking/ProjectionLike.hs
+++ b/src/full/Agda/TypeChecking/ProjectionLike.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.ProjectionLike where
@@ -27,7 +27,7 @@ import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Permutation
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | View for a @Def f (Apply a : es)@ where @isProjection f at .
diff --git a/src/full/Agda/TypeChecking/Quote.hs b/src/full/Agda/TypeChecking/Quote.hs
index fa554f5..4078274 100644
--- a/src/full/Agda/TypeChecking/Quote.hs
+++ b/src/full/Agda/TypeChecking/Quote.hs
@@ -1,46 +1,56 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Quote where
import Control.Applicative
import Control.Monad.State (evalState, get, put)
import Control.Monad.Writer (execWriterT, tell)
-import Control.Monad.Error (catchError)
+import Control.Monad.Trans (lift)
+import Data.Char
import Data.Maybe (fromMaybe)
import Data.Traversable (traverse)
-import Data.Char
-import Agda.Syntax.Position
-import Agda.Syntax.Literal
-import Agda.Syntax.Internal as I
import Agda.Syntax.Common
+import Agda.Syntax.Internal as I
+import Agda.Syntax.Literal
+import Agda.Syntax.Position
import Agda.Syntax.Translation.InternalToAbstract
-import {-# SOURCE #-} Agda.TypeChecking.Datatypes
+import Agda.TypeChecking.CompiledClause
+import Agda.TypeChecking.Datatypes ( getConHead )
+import Agda.TypeChecking.DropArgs
+import Agda.TypeChecking.Free
+import Agda.TypeChecking.Level
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
+import Agda.TypeChecking.Monad.Exception
+import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Reduce.Monad
-import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Substitute
-import Agda.TypeChecking.DropArgs
-import Agda.TypeChecking.CompiledClause
-import Agda.TypeChecking.Free
-import Agda.TypeChecking.Level
-
-import Agda.Utils.String
-import Agda.Utils.Permutation
-import Agda.Utils.Monad
-
-#include "../undefined.h"
+import Agda.Utils.Except
import Agda.Utils.Impossible
-
-quotingKit :: TCM (Term -> ReduceM Term, Type -> ReduceM Term, Clause -> ReduceM Term)
+import Agda.Utils.Monad ( ifM )
+import Agda.Utils.Permutation ( Permutation(Perm) )
+import Agda.Utils.String ( Str(Str), unStr )
+import Agda.Utils.VarSet (VarSet)
+import qualified Agda.Utils.VarSet as Set
+
+#include "undefined.h"
+
+data QuotingKit = QuotingKit
+ { quoteTermWithKit :: Term -> ReduceM Term
+ , quoteTypeWithKit :: Type -> ReduceM Term
+ , quoteClauseWithKit :: Clause -> ReduceM Term
+ , quoteDomWithKit :: I.Dom Type -> ReduceM Term
+ }
+
+quotingKit :: TCM QuotingKit
quotingKit = do
hidden <- primHidden
instanceH <- primInstance
@@ -87,66 +97,98 @@ quotingKit = do
t @@ u = apply <$> t <*> ((:[]) . defaultArg <$> u)
(!@) :: Apply a => a -> ReduceM Term -> ReduceM a
- t !@ u = pure t @@ u
+ t !@ u = pure t @@ u
(!@!) :: Apply a => a -> Term -> ReduceM a
t !@! u = pure t @@ pure u
+ quoteHiding :: Hiding -> ReduceM Term
quoteHiding Hidden = pure hidden
quoteHiding Instance = pure instanceH
quoteHiding NotHidden = pure visible
+
+ quoteRelevance :: Relevance -> ReduceM Term
quoteRelevance Relevant = pure relevant
quoteRelevance Irrelevant = pure irrelevant
quoteRelevance NonStrict = pure relevant
quoteRelevance Forced = pure relevant
quoteRelevance UnusedArg = pure relevant
- quoteColors _ = nil -- TODO guilhem
+
+-- quoteColors _ = nil -- TODO guilhem
+
+ quoteArgInfo :: I.ArgInfo -> ReduceM Term
quoteArgInfo (ArgInfo h r cs) = arginfo !@ quoteHiding h
@@ quoteRelevance r
-- @@ quoteColors cs
+
+ quoteLit :: Literal -> ReduceM Term
quoteLit l at LitInt{} = lit !@ (litNat !@! Lit l)
quoteLit l at LitFloat{} = lit !@ (litFloat !@! Lit l)
quoteLit l at LitChar{} = lit !@ (litChar !@! Lit l)
quoteLit l at LitString{} = lit !@ (litString !@! Lit l)
quoteLit l at LitQName{} = lit !@ (litQName !@! Lit l)
+
-- We keep no ranges in the quoted term, so the equality on terms
-- is only on the structure.
+ quoteSortLevelTerm :: Level -> ReduceM Term
quoteSortLevelTerm (Max []) = setLit !@! Lit (LitInt noRange 0)
quoteSortLevelTerm (Max [ClosedLevel n]) = setLit !@! Lit (LitInt noRange n)
- quoteSortLevelTerm l = set !@ quote (unlevelWithKit lkit l)
- quoteSort (Type t) = quoteSortLevelTerm t
- quoteSort Prop = pure unsupportedSort
- quoteSort Inf = pure unsupportedSort
- quoteSort DLub{} = pure unsupportedSort
- quoteType (El s t) = el !@ quoteSort s @@ quote t
+ quoteSortLevelTerm l = set !@ quoteTerm (unlevelWithKit lkit l)
+
+ quoteSort :: Sort -> ReduceM Term
+ quoteSort (Type t) = quoteSortLevelTerm t
+ quoteSort Prop = pure unsupportedSort
+ quoteSort Inf = pure unsupportedSort
+ quoteSort DLub{} = pure unsupportedSort
+ quoteType :: Type -> ReduceM Term
+ quoteType (El s t) = el !@ quoteSort s @@ quoteTerm t
+
+ quoteQName :: QName -> ReduceM Term
quoteQName x = pure $ Lit $ LitQName noRange x
+
+ quotePats :: [I.NamedArg Pattern] -> ReduceM Term
quotePats ps = list $ map (quoteArg quotePat . fmap namedThing) ps
+
+ quotePat :: Pattern -> ReduceM Term
quotePat (VarP "()") = pure absurdP
quotePat (VarP _) = pure varP
quotePat (DotP _) = pure dotP
quotePat (ConP c _ ps) = conP !@ quoteQName (conName c) @@ quotePats ps
quotePat (LitP l) = litP !@! Lit l
quotePat (ProjP x) = projP !@ quoteQName x
- quoteBody (Body a) = Just (quote a)
+
+ quoteBody :: I.ClauseBody -> Maybe (ReduceM Term)
+ quoteBody (Body a) = Just (quoteTerm a)
quoteBody (Bind b) = quoteBody (absBody b)
quoteBody NoBody = Nothing
+
+ quoteClause :: Clause -> ReduceM Term
quoteClause Clause{namedClausePats = ps, clauseBody = body} =
case quoteBody body of
Nothing -> absurdClause !@ quotePats ps
Just b -> normalClause !@ quotePats ps @@ b
- list [] = pure nil
+ list :: [ReduceM Term] -> ReduceM Term
+ list [] = pure nil
list (a : as) = cons !@ a @@ list as
+
+ quoteDom :: (Type -> ReduceM Term) -> I.Dom Type -> ReduceM Term
quoteDom q (Dom info t) = arg !@ quoteArgInfo info @@ q t
+
+ quoteArg :: (a -> ReduceM Term) -> I.Arg a -> ReduceM Term
quoteArg q (Arg info t) = arg !@ quoteArgInfo info @@ q t
- quoteArgs ts = list (map (quoteArg quote) ts)
- quote v =
+
+ quoteArgs :: I.Args -> ReduceM Term
+ quoteArgs ts = list (map (quoteArg quoteTerm) ts)
+
+ quoteTerm :: Term -> ReduceM Term
+ quoteTerm v =
case unSpine v of
Var n es ->
let ts = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
in var !@! Lit (LitInt noRange $ fromIntegral n) @@ quoteArgs ts
- Lam info t -> lam !@ quoteHiding (getHiding info) @@ quote (absBody t)
+ Lam info t -> lam !@ quoteHiding (getHiding info) @@ quoteTerm (absBody t)
Def x es -> do
d <- theDef <$> getConstInfo x
qx d @@ quoteArgs ts
@@ -160,14 +202,15 @@ quotingKit = do
Con x ts -> con !@! quoteConName x @@ quoteArgs ts
Pi t u -> pi !@ quoteDom quoteType t
@@ quoteType (absBody u)
- Level _ -> pure unsupported
+ Level l -> quoteTerm (unlevelWithKit lkit l)
Lit lit -> quoteLit lit
Sort s -> sort !@ quoteSort s
- Shared p -> quote $ derefPtr p
+ Shared p -> quoteTerm $ derefPtr p
MetaV{} -> pure unsupported
DontCare{} -> pure unsupported -- could be exposed at some point but we have to take care
ExtLam{} -> __IMPOSSIBLE__
- return (quote, quoteType, quoteClause)
+
+ return $ QuotingKit quoteTerm quoteType quoteClause (quoteDom quoteType)
quoteName :: QName -> Term
quoteName x = Lit (LitQName noRange x)
@@ -177,344 +220,10 @@ quoteConName = quoteName . conName
quoteTerm :: Term -> TCM Term
quoteTerm v = do
- (f, _, _) <- quotingKit
- runReduceM (f v)
+ kit <- quotingKit
+ runReduceM (quoteTermWithKit kit v)
quoteType :: Type -> TCM Term
quoteType v = do
- (_, f, _) <- quotingKit
- runReduceM (f v)
-
-agdaTermType :: TCM Type
-agdaTermType = El (mkType 0) <$> primAgdaTerm
-
-qNameType :: TCM Type
-qNameType = El (mkType 0) <$> primQName
-
-isCon :: ConHead -> TCM Term -> TCM Bool
-isCon con tm = do t <- tm
- case ignoreSharing t of
- Con con' _ -> return (con == con')
- _ -> return False
-
-unquoteFailedGeneric :: String -> TCM a
-unquoteFailedGeneric msg = typeError . GenericError $ "Unable to unquote the " ++ msg
-
-unquoteFailed :: String -> String -> Term -> TCM a
-unquoteFailed kind msg t = do doc <- prettyTCM t
- unquoteFailedGeneric $ "term (" ++ show doc ++ ") of type " ++ kind ++ ".\nReason: " ++ msg ++ "."
-
-class Unquote a where
- unquote :: Term -> TCM a
-
-unquoteH :: Unquote a => I.Arg Term -> TCM a
-unquoteH a | isHidden a && isRelevant a =
- unquote $ unArg a
-unquoteH _ = unquoteFailedGeneric "argument. It should be `hidden'."
-
-unquoteN :: Unquote a => I.Arg Term -> TCM a
-unquoteN a | notHidden a && isRelevant a =
- unquote $ unArg a
-unquoteN _ = unquoteFailedGeneric "argument. It should be `visible'"
-
-choice :: Monad m => [(m Bool, m a)] -> m a -> m a
-choice [] dflt = dflt
-choice ((mb, mx) : mxs) dflt = ifM mb mx $ choice mxs dflt
-
-ensureDef :: QName -> TCM QName
-ensureDef x = do
- i <- (theDef <$> getConstInfo x) `catchError` \_ -> return Axiom -- for recursive unquoteDecl
- case i of
- Constructor{} -> do
- def <- prettyTCM =<< primAgdaTermDef
- con <- prettyTCM =<< primAgdaTermCon
- c <- prettyTCM x
- setCurrentRange (getRange x) $ typeError $ GenericError $ "Use " ++ show con ++ " instead of " ++ show def ++ " for constructor " ++ show c
- _ -> return x
-
-ensureCon :: QName -> TCM QName
-ensureCon x = do
- i <- (theDef <$> getConstInfo x) `catchError` \_ -> return Axiom -- for recursive unquoteDecl
- case i of
- Constructor{} -> return x
- _ -> do
- def <- prettyTCM =<< primAgdaTermDef
- con <- prettyTCM =<< primAgdaTermCon
- f <- prettyTCM x
- setCurrentRange (getRange x) $ typeError $ GenericError $ "Use " ++ show def ++ " instead of " ++ show con ++ " for non-constructor " ++ show f
-
-pickName :: Type -> String
-pickName a =
- case unEl a of
- Pi{} -> "f"
- Sort{} -> "A"
- Def d _ | c:_ <- show (qnameName d),
- isAlpha c -> [toLower c]
- _ -> "_"
-
-instance Unquote I.ArgInfo where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [h,r] -> do
- choice
- [(c `isCon` primArgArgInfo, ArgInfo <$> unquoteN h <*> unquoteN r <*> return [])]
- (unquoteFailed "ArgInfo" "arity 2 and not the `arginfo' constructor" t)
- _ -> unquoteFailed "ArgInfo" "not of arity 2" t
-
-instance Unquote a => Unquote (I.Arg a) where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [info,x] -> do
- choice
- [(c `isCon` primArgArg, Arg <$> unquoteN info <*> unquoteN x)]
- (unquoteFailed "Arg" "arity 2 and not the `arg' constructor" t)
- _ -> unquoteFailed "Arg" "not of arity 2" t
-
--- Andreas, 2013-10-20: currently, post-fix projections are not part of the
--- quoted syntax.
-instance Unquote a => Unquote (Elim' a) where
- unquote t = Apply <$> unquote t
-
-instance Unquote Integer where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Lit (LitInt _ n) -> return n
- _ -> unquoteFailed "Integer" "not a literal integer" t
-
-instance Unquote Double where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Lit (LitFloat _ x) -> return x
- _ -> unquoteFailed "Float" "not a literal float" t
-
-instance Unquote Char where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Lit (LitChar _ x) -> return x
- _ -> unquoteFailed "Char" "not a literal char" t
-
-instance Unquote Str where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Lit (LitString _ x) -> return (Str x)
- _ -> unquoteFailed "String" "not a literal string" t
-
-instance Unquote a => Unquote [a] where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [x,xs] -> do
- choice
- [(c `isCon` primCons, (:) <$> unquoteN x <*> unquoteN xs)]
- (unquoteFailed "List" "arity 2 and not the `∷' constructor" t)
- Con c [] -> do
- choice
- [(c `isCon` primNil, return [])]
- (unquoteFailed "List" "arity 0 and not the `[]' constructor" t)
- _ -> unquoteFailed "List" "neither `[]' nor `∷'" t
-
-instance Unquote Hiding where
- unquote t = do
- t <- reduce t
- let err = unquoteFailed "Hiding" "neither `hidden' nor `visible'" t
- case ignoreSharing t of
- Con c [] -> do
- choice
- [(c `isCon` primHidden, return Hidden)
- ,(c `isCon` primInstance, return Instance)
- ,(c `isCon` primVisible, return NotHidden)]
- err
- Con c vs -> unquoteFailed "Hiding" "the value is a constructor, but its arity is not 0" t
- _ -> err
-
-instance Unquote Relevance where
- unquote t = do
- t <- reduce t
- let err = unquoteFailed "Relevance" "neither `relevant' or `irrelevant'" t
- case ignoreSharing t of
- Con c [] -> do
- choice
- [(c `isCon` primRelevant, return Relevant)
- ,(c `isCon` primIrrelevant, return Irrelevant)]
- err
- Con c vs -> unquoteFailed "Relevance" "the value is a constructor, but its arity is not 0" t
- _ -> err
-
-instance Unquote QName where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Lit (LitQName _ x) -> return x
- _ -> unquoteFailed "QName" "not a literal qname value" t
-
-instance Unquote ConHead where
- unquote t = getConHead =<< ensureCon =<< unquote t
-
-instance Unquote a => Unquote (Abs a) where
- unquote t = Abs "_" <$> unquote t
-
-instance Unquote Sort where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [] -> do
- choice
- [(c `isCon` primAgdaSortUnsupported, pure $ Type $ Max [Plus 0 $ UnreducedLevel $ hackReifyToMeta])]
- __IMPOSSIBLE__
- Con c [u] -> do
- choice
- [(c `isCon` primAgdaSortSet, Type <$> unquoteN u)
- ,(c `isCon` primAgdaSortLit, Type . levelMax . (:[]) . ClosedLevel <$> unquoteN u)]
- (unquoteFailed "Sort" "arity 1 and not the `set' or the `lit' constructors" t)
- _ -> unquoteFailed "Sort" "not of arity 0 nor 1" t
-
-instance Unquote Level where
- unquote l = Max . (:[]) . Plus 0 . UnreducedLevel <$> unquote l
-
-instance Unquote Type where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [s, u] -> do
- choice
- [(c `isCon` primAgdaTypeEl, El <$> unquoteN s <*> unquoteN u)]
- (unquoteFailed "Type" "arity 2 and not the `el' constructor" t)
- _ -> unquoteFailed "Type" "not of arity 2" t
-
-instance Unquote Literal where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [x] ->
- choice
- [ (c `isCon` primAgdaLitNat, LitInt noRange <$> unquoteN x)
- , (c `isCon` primAgdaLitFloat, LitFloat noRange <$> unquoteN x)
- , (c `isCon` primAgdaLitChar, LitChar noRange <$> unquoteN x)
- , (c `isCon` primAgdaLitString, LitString noRange . getStr <$> unquoteN x)
- , (c `isCon` primAgdaLitQName, LitQName noRange <$> unquoteN x) ]
- (unquoteFailed "Literal" "not a literal constructor" t)
- _ -> unquoteFailed "Literal" "not a literal constructor" t
-
-instance Unquote Term where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [] ->
- choice
- [(c `isCon` primAgdaTermUnsupported, pure hackReifyToMeta)]
- (unquoteFailed "Term" "arity 0 and not the `unsupported' constructor" t)
-
- Con c [x] -> do
- choice
- [ (c `isCon` primAgdaTermSort, Sort <$> unquoteN x)
- , (c `isCon` primAgdaTermLit, Lit <$> unquoteN x) ]
- (unquoteFailed "Term" "bad constructor" t)
-
- Con c [x, y] ->
- choice
- [ (c `isCon` primAgdaTermVar, Var <$> (fromInteger <$> unquoteN x) <*> unquoteN y)
- , (c `isCon` primAgdaTermCon, Con <$> unquoteN x <*> unquoteN y)
- , (c `isCon` primAgdaTermDef, Def <$> (ensureDef =<< unquoteN x) <*> unquoteN y)
- , (c `isCon` primAgdaTermLam, Lam <$> (flip setHiding defaultArgInfo <$> unquoteN x) <*> unquoteN y)
- , (c `isCon` primAgdaTermPi, mkPi <$> (domFromArg <$> unquoteN x) <*> unquoteN y)
- , (c `isCon` primAgdaTermExtLam, mkExtLam <$> unquoteN x <*> unquoteN y) ]
- (unquoteFailed "Term" "bad term constructor" t)
- where
- mkExtLam = ExtLam
- mkPi a (Abs _ b) = Pi a (Abs x b)
- where x | 0 `freeIn` b = pickName (unDom a)
- | otherwise = "_"
- mkPi _ NoAbs{} = __IMPOSSIBLE__
-
- Con{} -> unquoteFailed "Term" "neither arity 0 nor 1 nor 2" t
- Lit{} -> unquoteFailed "Term" "unexpected literal" t
- _ -> unquoteFailed "Term" "not a constructor" t
-
-instance Unquote Pattern where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [] -> do
- choice
- [ (c `isCon` primAgdaPatVar, pure (VarP "x"))
- , (c `isCon` primAgdaPatAbsurd, pure (VarP "()"))
- , (c `isCon` primAgdaPatDot, pure (DotP hackReifyToMeta))
- ] __IMPOSSIBLE__
- Con c [x] -> do
- choice
- [ (c `isCon` primAgdaPatProj, ProjP <$> unquoteN x)
- , (c `isCon` primAgdaPatLit, LitP <$> unquoteN x) ]
- __IMPOSSIBLE__
- Con c [x, y] -> do
- choice
- [ (c `isCon` primAgdaPatCon, flip ConP Nothing <$> unquoteN x <*> (map (fmap unnamed) <$> unquoteN y)) ]
- __IMPOSSIBLE__
- _ -> unquoteFailed "Pattern" "not a constructor" t
-
-data UnquotedFunDef = UnQFun Type [Clause]
-
-instance Unquote Clause where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [x] -> do
- choice
- [ (c `isCon` primAgdaClauseAbsurd, mkClause Nothing <$> unquoteN x) ]
- __IMPOSSIBLE__
- Con c [x, y] -> do
- choice
- [ (c `isCon` primAgdaClauseClause, mkClause . Just <$> unquoteN y <*> unquoteN x) ]
- __IMPOSSIBLE__
- _ -> unquoteFailed "Pattern" "not a constructor" t
- where
- mkClause :: Maybe Term -> [I.Arg Pattern] -> I.Clause
- mkClause b ps0 =
- Clause { clauseRange = noRange
- , clauseTel = dummyTel n'
- , clausePerm = Perm n vs
- , namedClausePats = ps
- , clauseBody = mkBody n b
- , clauseType = Nothing }
- where
- ps = map (fmap unnamed) ps0
- n = vars True ps -- with dot patterns
- n' = vars False ps -- without dot patterns
- dummyTel 0 = EmptyTel
- dummyTel n = ExtendTel (defaultDom typeDontCare) (Abs "x" $ dummyTel (n - 1))
- mkBody 0 b = maybe NoBody Body b
- mkBody n b = Bind $ Abs "x" $ mkBody (n - 1) b
- vars d ps = sum $ map (vars' d . namedArg) ps
- vars' d (ConP _ _ ps) = vars d ps
- vars' d VarP{} = 1
- vars' d DotP{} = if d then 1 else 0
- vars' d LitP{} = 0
- vars' d ProjP{} = 0
-
- vs = evalState (execWriterT $ mapM_ (computePerm . namedArg) ps) 0
- next = do n <- get; put (n + 1); return n
-
- computePerm (ConP _ _ ps) = mapM_ (computePerm . namedArg) ps
- computePerm VarP{} = tell . (:[]) =<< next
- computePerm DotP{} = () <$ next
- computePerm LitP{} = return ()
- computePerm ProjP{} = return ()
-
-instance Unquote UnquotedFunDef where
- unquote t = do
- t <- reduce t
- case ignoreSharing t of
- Con c [x, y] -> do
- choice
- [ (c `isCon` primAgdaFunDefCon, UnQFun <$> unquoteN x <*> unquoteN y) ]
- __IMPOSSIBLE__
- _ -> unquoteFailed "Pattern" "not a constructor" t
-
-reifyUnquoted :: Reify a e => a -> TCM e
-reifyUnquoted = nowReifyingUnquoted . disableDisplayForms . withShowAllArguments . reify
-
+ kit <- quotingKit
+ runReduceM (quoteTypeWithKit kit v)
diff --git a/src/full/Agda/TypeChecking/RecordPatterns.hs b/src/full/Agda/TypeChecking/RecordPatterns.hs
index 5a85783..7a5b31b 100644
--- a/src/full/Agda/TypeChecking/RecordPatterns.hs
+++ b/src/full/Agda/TypeChecking/RecordPatterns.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
-- | Code which replaces pattern matching on record constructors with
-- uses of projection functions.
@@ -44,7 +44,7 @@ import Agda.Utils.Maybe
import Agda.Utils.Permutation hiding (dropFrom)
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -456,7 +456,7 @@ translateRecordPatterns clause = do
-- order (i.e. the type signature for the variable which occurs
-- first in the list of patterns comes first).
flattenedOldTel =
- permute (invertP $ compactP $ clausePerm clause) $
+ permute (invertP __IMPOSSIBLE__ $ compactP $ clausePerm clause) $
zip (teleNames $ clauseTel clause) $
flattenTel $
clauseTel clause
diff --git a/src/full/Agda/TypeChecking/Records.hs b/src/full/Agda/TypeChecking/Records.hs
index 654c279..f6aa95e 100644
--- a/src/full/Agda/TypeChecking/Records.hs
+++ b/src/full/Agda/TypeChecking/Records.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TupleSections #-}
@@ -17,6 +17,7 @@ import qualified Agda.Syntax.Concrete.Name as C
import Agda.Syntax.Abstract.Name
import Agda.Syntax.Internal as I
import Agda.Syntax.Position
+
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Pretty
@@ -30,9 +31,10 @@ import Agda.Utils.Functor (for, ($>))
import Agda.Utils.Maybe
import Agda.Utils.Monad
import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Order the fields of a record construction.
@@ -297,7 +299,7 @@ etaExpandBoundVar i = do
rev = foldl (\ l (Dom ai (n, t)) -> Dom ai (nameToArgName n, t) : l) []
-- Use "f(x)" as variable name for the projection f(x).
- s = show x
+ s = prettyShow x
tel' = mapAbsNames (\ f -> stringToArgName $ argNameToString f ++ "(" ++ s ++ ")") tel
delta = telFromList $ rev gamma1 ++ telToList tel' ++ rev (applySubst tau0 gamma2)
diff --git a/src/full/Agda/TypeChecking/Reduce.hs b/src/full/Agda/TypeChecking/Reduce.hs
index fd4026e..f349c2a 100644
--- a/src/full/Agda/TypeChecking/Reduce.hs
+++ b/src/full/Agda/TypeChecking/Reduce.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.Reduce where
@@ -43,7 +43,7 @@ import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
instantiate :: Instantiate a => a -> TCM a
@@ -75,7 +75,19 @@ instance Instantiate Term where
instantiate' t@(MetaV x es) = do
mi <- mvInstantiation <$> lookupMeta x
case mi of
- InstV a -> instantiate' $ a `applyE` es
+ InstV tel v -> instantiate' inst
+ where
+ -- A slight complication here is that the meta might be underapplied,
+ -- in which case we have to build the lambda abstraction before
+ -- applying the substitution, or overapplied in which case we need to
+ -- fall back to applyE.
+ (es1, es2) = splitAt (length tel) es
+ vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1
+ rho = vs1 ++# wkS (length vs1) idS
+ -- really should be .. ++# emptyS but using wkS makes it reduce to idS
+ -- when applicable
+ -- specification: inst == foldr mkLam v tel `applyE` es
+ inst = applySubst rho (foldr mkLam v $ drop (length es1) tel) `applyE` es2
Open -> return t
OpenIFS -> return t
BlockedConst _ -> return t
@@ -109,12 +121,12 @@ instance Instantiate a => Instantiate (Blocked a) where
instantiate' v@(Blocked x u) = do
mi <- mvInstantiation <$> lookupMeta x
case mi of
- InstV _ -> notBlocked <$> instantiate' u
- Open -> return v
- OpenIFS -> return v
- BlockedConst _ -> return v
- PostponedTypeCheckingProblem _ _ -> return v
- InstS _ -> __IMPOSSIBLE__
+ InstV{} -> notBlocked <$> instantiate' u
+ Open -> return v
+ OpenIFS -> return v
+ BlockedConst{} -> return v
+ PostponedTypeCheckingProblem{} -> return v
+ InstS{} -> __IMPOSSIBLE__
instance Instantiate Type where
instantiate' (El s t) = El <$> instantiate' s <*> instantiate' t
@@ -149,8 +161,8 @@ instance (Instantiate a, Instantiate b,Instantiate c) => Instantiate (a,b,c) whe
instance Instantiate a => Instantiate (Closure a) where
instantiate' cl = do
- x <- enterClosure cl instantiate'
- return $ cl { clValue = x }
+ x <- enterClosure cl instantiate'
+ return $ cl { clValue = x }
instance Instantiate Telescope where
instantiate' tel = return tel
@@ -291,7 +303,6 @@ instance Reduce Term where
Level l -> ifM (elem LevelReductions <$> asks envAllowedReductions)
{- then -} (fmap levelTm <$> reduceB' l)
{- else -} done
- -- Level l -> fmap levelTm <$> reduceB' l
Pi _ _ -> done
Lit _ -> done
Var _ _ -> done
@@ -306,12 +317,12 @@ instance Reduce Term where
mz <- getBuiltin' builtinZero
case v of
_ | Just v == mz -> return $ Lit $ LitInt (getRange c) 0
- _ -> return v
+ _ -> return v
reduceNat v@(Con c [a]) | notHidden a && isRelevant a = do
ms <- fmap ignoreSharing <$> getBuiltin' builtinSuc
case v of
_ | Just (Con c []) == ms -> inc <$> reduce' (unArg a)
- _ -> return v
+ _ -> return v
where
inc w = case ignoreSharing w of
Lit (LitInt r n) -> Lit (LitInt (fuseRange c r) $ n + 1)
@@ -339,63 +350,36 @@ unfoldDefinition' ::
unfoldDefinition' unfoldDelayed keepGoing v0 f es =
{-# SCC "reduceDef" #-} do
info <- getConstInfo f
+ allowed <- asks envAllowedReductions
let def = theDef info
v = v0 `applyE` es
+ -- Non-terminating functions
+ -- (i.e., those that failed the termination check)
+ -- and delayed definitions
+ -- are not unfolded unless explicitely permitted.
+ dontUnfold =
+ (defNonterminating info && notElem NonTerminatingReductions allowed)
+ || (defDelayed info == Delayed && not unfoldDelayed)
case def of
Constructor{conSrcCon = c} ->
retSimpl $ notBlocked $ Con (c `withRangeOf` f) [] `applyE` es
Primitive{primAbstr = ConcreteDef, primName = x, primClauses = cls} -> do
pf <- fromMaybe __IMPOSSIBLE__ <$> getPrimitive' x
- reducePrimitive x v0 f es pf (defDelayed info) (defNonterminating info)
+ reducePrimitive x v0 f es pf dontUnfold
cls (defCompiled info)
_ -> do
- allowed <- asks envAllowedReductions
-{-
- -- case f is projection-like:
- if isProperProjection def then
- if ProjectionReductions `elem` allowed then do
- -- we cannot call elimView right away, since it calls back to reduce'
- -- get rid of projection if possible
- (simpl, w) <- onlyReduceProjections $ do
- reduceNormal (retSimpl <=< reduceB') v0 f (map notReduced args)
- (defDelayed info) (defNonterminating info)
- (defClauses info) (defCompiled info)
- -- Now @w@ should not have any reducible projection in the head.
- -- By not allowing reentrace (dontReduceProjections),
- -- we can now call elimView without risk of circularity.
- case w of
- Blocked{} -> return (simpl, w)
- NotBlocked w' -> do
- ev <- dontReduceProjections $ elimView w'
- case ev of
- DefElim f es -> performedSimplification' simpl $ do
- reduceDefElim f es
- _ -> return (simpl, w)
- else retSimpl $ notBlocked v
- -- case f is not a projection:
- else if FunctionReductions `elem` allowed then
- -- proceed as before, without calling elimView
--}
if FunctionReductions `elem` allowed ||
(isJust (isProjection_ def) && ProjectionReductions `elem` allowed) -- includes projection-like
- then
- reduceNormalE keepGoing v0 f (map notReduced es)
- (defDelayed info) (notElem NonTerminatingReductions allowed && defNonterminating info)
+ then
+ reduceNormalE keepGoing v0 f (map notReduced es)
+ dontUnfold
(defClauses info) (defCompiled info)
else retSimpl $ notBlocked v
where
retSimpl v = (,v) <$> getSimplification
-{-
- reduceDefElim :: QName -> [Elim] -> ReduceM (Simplification, Blocked Term)
- reduceDefElim f es = do
- info <- getConstInfo f
- reduceNormalE keepGoing (Def f []) f (map notReduced es)
- (defDelayed info) (defNonterminating info)
- (defClauses info) (defCompiled info)
--}
- reducePrimitive x v0 f es pf delayed nonterminating cls mcc
+ reducePrimitive x v0 f es pf dontUnfold cls mcc
| genericLength es < ar
= retSimpl $ notBlocked $ v0 `applyE` es -- not fully applied
| otherwise = {-# SCC "reducePrimitive" #-} do
@@ -412,7 +396,7 @@ unfoldDefinition' unfoldDelayed keepGoing v0 f es =
else
reduceNormalE keepGoing v0 f
(es1' ++ map notReduced es2)
- delayed nonterminating cls mcc
+ dontUnfold cls mcc
YesReduction simpl v -> performedSimplification' simpl $
keepGoing $ v `applyE` es2
where
@@ -421,27 +405,11 @@ unfoldDefinition' unfoldDelayed keepGoing v0 f es =
mredToBlocked (MaybeRed NotReduced x) = notBlocked x
mredToBlocked (MaybeRed (Reduced b) x) = x <$ b
-{-
- reduceNormal :: (Term -> ReduceM (Simplification, Blocked Term)) -> Term -> QName -> [MaybeReduced (Arg Term)] -> Delayed -> Bool -> [Clause] -> Maybe CompiledClauses -> ReduceM (Simplification, Blocked Term)
- reduceNormal keepGoing v0 f args = reduceNormalE keepGoing v0 f $ map (fmap Apply) args
--}
-
- reduceNormalE :: (Term -> ReduceM (Simplification, Blocked Term)) -> Term -> QName -> [MaybeReduced Elim] -> Delayed -> Bool -> [Clause] -> Maybe CompiledClauses -> ReduceM (Simplification, Blocked Term)
- reduceNormalE keepGoing v0 f es delayed nonterminating def mcc = {-# SCC "reduceNormal" #-} do
+ reduceNormalE :: (Term -> ReduceM (Simplification, Blocked Term)) -> Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> ReduceM (Simplification, Blocked Term)
+ reduceNormalE keepGoing v0 f es dontUnfold def mcc = {-# SCC "reduceNormal" #-} do
case def of
- _ | nonterminating -> defaultResult
- _ | Delayed <- delayed,
- not unfoldDelayed -> defaultResult
+ _ | dontUnfold -> defaultResult
[] -> defaultResult -- no definition for head
-{- OBSOLETE
- -- stop here if we only want to reduce' (proper) projections
- -- but the symbol @f@ is not one
- cls -> ifM (asks envOnlyReduceProjections `and2M` do not . maybe False projProper <$> isProjection f) defaultResult $ do
--}
-{-
- cls -> allowAllReductions $ do
- -- In subterms, we allow all reductions.
--}
cls -> do
ev <- appDefE_ f v0 cls mcc es
case ev of
@@ -459,33 +427,26 @@ unfoldDefinition' unfoldDelayed keepGoing v0 f es =
keepGoing v
where defaultResult = retSimpl $ notBlocked $ vfull
vfull = v0 `applyE` map ignoreReduced es
--- where defaultResult = retSimpl $ notBlocked $ v0 `apply` (map ignoreReduced args)
-- | Reduce a non-primitive definition if it is a copy linking to another def.
reduceDefCopy :: QName -> Args -> TCM (Reduced () Term)
reduceDefCopy f vs = do
info <- TCM.getConstInfo f
if (defCopy info) then reduceDef_ info f vs else return $ NoReduction ()
-
--- | Reduce a non-primitive definition once unless it is delayed.
-reduceDef :: QName -> Args -> TCM (Reduced () Term)
-reduceDef f vs = do
- info <- TCM.getConstInfo f
- reduceDef_ info f vs
-
-reduceDef_ :: Definition -> QName -> Args -> TCM (Reduced () Term)
-reduceDef_ info f vs = do
- let v0 = Def f []
- args = map notReduced vs
- cls = (defClauses info)
- mcc = (defCompiled info)
- if (defDelayed info == Delayed) || (defNonterminating info)
- then return $ NoReduction ()
- else do
- ev <- runReduceM $ appDef_ f v0 cls mcc args
- case ev of
- YesReduction simpl t -> return $ YesReduction simpl t
- NoReduction args' -> return $ NoReduction ()
+ where
+ reduceDef_ :: Definition -> QName -> Args -> TCM (Reduced () Term)
+ reduceDef_ info f vs = do
+ let v0 = Def f []
+ args = map notReduced vs
+ cls = (defClauses info)
+ mcc = (defCompiled info)
+ if (defDelayed info == Delayed) || (defNonterminating info)
+ then return $ NoReduction ()
+ else do
+ ev <- runReduceM $ appDef_ f v0 cls mcc args
+ case ev of
+ YesReduction simpl t -> return $ YesReduction simpl t
+ NoReduction args' -> return $ NoReduction ()
-- | Reduce simple (single clause) definitions.
reduceHead :: Term -> TCM (Blocked Term)
@@ -553,23 +514,6 @@ appDefE v cc es = do
appDef' :: Term -> [Clause] -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
appDef' v cls args = appDefE' v cls $ map (fmap Apply) args
-{- OLD. With varying function arity, check for underapplication is UNSOUND.
-appDefE' :: Term -> [Clause] -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
-appDefE' _ [] _ = {- ' -} __IMPOSSIBLE__
-appDefE' v cls@(Clause {clausePats = ps} : _) es
- -- case underapplied: no reduction
- | m < n = return $ NoReduction $ notBlocked $ v `applyE` map ignoreReduced es
- | otherwise = do
- let (es0, es1) = splitAt n es
- r <- goCls cls (map ignoreReduced es0)
- case r of
- YesReduction simpl u -> return $ YesReduction simpl $ u `applyE` map ignoreReduced es1
- NoReduction v -> return $ NoReduction $ (`applyE` map ignoreReduced es1) <$> v
- where
-
- n = genericLength ps
- m = genericLength es
--}
appDefE' :: Term -> [Clause] -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
appDefE' v cls es = goCls cls $ map ignoreReduced es
where
@@ -604,9 +548,8 @@ appDefE' v cls es = goCls cls $ map ignoreReduced es
app vs body EmptyS `applyE` es1
| otherwise -> cantReduce es
-
- -- NEW version, building an explicit substitution from arguments
- -- and executing it using parallel substitution.
+ -- Build an explicit substitution from arguments
+ -- and execute it using parallel substitution.
-- Calculating the de Bruijn indices: ;-) for the Bind case
-- Simply-typed version
-- (we are not interested in types, only in de Bruijn indices here)
@@ -617,27 +560,16 @@ appDefE' v cls es = goCls cls $ map ignoreReduced es
-- Δ.A ⊢ b : B
app :: [Term] -> ClauseBody -> Substitution -> Term
app [] (Body v) sigma = applySubst sigma v
--- app (v : vs) (Bind b) sigma = app es (absBody b) (v :# sigma) -- CBN
app (v : vs) (Bind (Abs _ b)) sigma = app vs b (v :# sigma) -- CBN
app (v : vs) (Bind (NoAbs _ b)) sigma = app vs b sigma
app _ NoBody sigma = __IMPOSSIBLE__
- app (_ : _) (Body _) sigma = __IMPOSSIBLE__
+ app (_ : _) (Body _) sigma = __IMPOSSIBLE__
app [] (Bind _) sigma = __IMPOSSIBLE__
-{- OLD version, one substitution after another
- app :: [Elim] -> ClauseBody -> Term
- app [] (Body v') = v'
- app (Proj f : es) b = app es b
- app (Apply arg : es) (Bind b) = app es $ absApp b $ unArg arg -- CBN
- app _ NoBody = __IMPOSSIBLE__
- app (_ : _) (Body _) = __IMPOSSIBLE__
- app [] (Bind _) = __IMPOSSIBLE__
--}
-
instance Reduce a => Reduce (Closure a) where
reduce' cl = do
- x <- enterClosure cl reduce'
- return $ cl { clValue = x }
+ x <- enterClosure cl reduce'
+ return $ cl { clValue = x }
instance Reduce Telescope where
reduce' tel = return tel
@@ -756,13 +688,13 @@ instance (Simplify a, Simplify b) => Simplify (a,b) where
instance (Simplify a, Simplify b, Simplify c) => Simplify (a,b,c) where
simplify' (x,y,z) =
- do (x,(y,z)) <- simplify' (x,(y,z))
- return (x,y,z)
+ do (x,(y,z)) <- simplify' (x,(y,z))
+ return (x,y,z)
instance Simplify a => Simplify (Closure a) where
simplify' cl = do
- x <- enterClosure cl simplify'
- return $ cl { clValue = x }
+ x <- enterClosure cl simplify'
+ return $ cl { clValue = x }
instance (Subst a, Simplify a) => Simplify (Tele a) where
simplify' EmptyTel = return EmptyTel
@@ -800,7 +732,7 @@ instance Simplify Pattern where
instance Simplify ClauseBody where
simplify' (Body t) = Body <$> simplify' t
simplify' (Bind b) = Bind <$> simplify' b
- simplify' NoBody = return NoBody
+ simplify' NoBody = return NoBody
instance Simplify DisplayForm where
simplify' (Display n ps v) = Display n <$> simplify' ps <*> return v
@@ -827,17 +759,17 @@ instance Normalise Type where
instance Normalise Term where
normalise' v =
- do v <- reduce' v
- case v of
- Var n vs -> Var n <$> normalise' vs
- Con c vs -> Con c <$> normalise' vs
- Def f vs -> Def f <$> normalise' vs
- MetaV x vs -> MetaV x <$> normalise' vs
- Lit _ -> return v
+ do v <- reduce' v
+ case v of
+ Var n vs -> Var n <$> normalise' vs
+ Con c vs -> Con c <$> normalise' vs
+ Def f vs -> Def f <$> normalise' vs
+ MetaV x vs -> MetaV x <$> normalise' vs
+ Lit _ -> return v
Level l -> levelTm <$> normalise' l
- Lam h b -> Lam h <$> normalise' b
- Sort s -> sortTm <$> normalise' s
- Pi a b -> uncurry Pi <$> normalise' (a,b)
+ Lam h b -> Lam h <$> normalise' b
+ Sort s -> sortTm <$> normalise' s
+ Pi a b -> uncurry Pi <$> normalise' (a,b)
Shared{} -> __IMPOSSIBLE__ -- updateSharedTerm normalise' v
ExtLam{} -> __IMPOSSIBLE__
DontCare _ -> return v
@@ -865,7 +797,7 @@ instance Normalise LevelAtom where
instance Normalise ClauseBody where
normalise' (Body t) = Body <$> normalise' t
normalise' (Bind b) = Bind <$> normalise' b
- normalise' NoBody = return NoBody
+ normalise' NoBody = return NoBody
instance (Subst t, Normalise t) => Normalise (Abs t) where
normalise' a@(Abs x _) = Abs x <$> underAbstraction_ a normalise'
@@ -889,13 +821,13 @@ instance (Normalise a, Normalise b) => Normalise (a,b) where
instance (Normalise a, Normalise b, Normalise c) => Normalise (a,b,c) where
normalise' (x,y,z) =
- do (x,(y,z)) <- normalise' (x,(y,z))
- return (x,y,z)
+ do (x,(y,z)) <- normalise' (x,(y,z))
+ return (x,y,z)
instance Normalise a => Normalise (Closure a) where
normalise' cl = do
- x <- enterClosure cl normalise'
- return $ cl { clValue = x }
+ x <- enterClosure cl normalise'
+ return $ cl { clValue = x }
instance (Subst a, Normalise a) => Normalise (Tele a) where
normalise' EmptyTel = return EmptyTel
@@ -956,11 +888,11 @@ instance InstantiateFull Name where
instance InstantiateFull Sort where
instantiateFull' s = do
- s <- instantiate' s
- case s of
- Type n -> levelSort <$> instantiateFull' n
- Prop -> return s
- DLub s1 s2 -> dLub <$> instantiateFull' s1 <*> instantiateFull' s2
+ s <- instantiate' s
+ case s of
+ Type n -> levelSort <$> instantiateFull' n
+ Prop -> return s
+ DLub s1 s2 -> dLub <$> instantiateFull' s1 <*> instantiateFull' s2
Inf -> return s
instance InstantiateFull Type where
@@ -976,7 +908,7 @@ instance InstantiateFull Term where
Con c vs -> Con c <$> instantiateFull' vs
Def f vs -> Def f <$> instantiateFull' vs
MetaV x vs -> MetaV x <$> instantiateFull' vs
- Lit _ -> return v
+ Lit _ -> return v
Level l -> levelTm <$> instantiateFull' l
Lam h b -> Lam h <$> instantiateFull' b
Sort s -> sortTm <$> instantiateFull' s
@@ -1006,6 +938,17 @@ instance InstantiateFull LevelAtom where
(BlockedLevel m <$> instantiateFull' v)
UnreducedLevel v -> UnreducedLevel <$> instantiateFull' v
+instance InstantiateFull Substitution where
+ instantiateFull' sigma =
+ case sigma of
+ IdS -> return IdS
+ EmptyS -> return EmptyS
+ Wk n sigma -> Wk n <$> instantiateFull' sigma
+ Lift n sigma -> Lift n <$> instantiateFull' sigma
+ Strengthen bot sigma -> Strengthen bot <$> instantiateFull' sigma
+ t :# sigma -> (:#) <$> instantiateFull' t
+ <*> instantiateFull' sigma
+
instance InstantiateFull Bool where
instantiateFull' = return
@@ -1042,13 +985,13 @@ instance (InstantiateFull a, InstantiateFull b) => InstantiateFull (a,b) where
instance (InstantiateFull a, InstantiateFull b, InstantiateFull c) => InstantiateFull (a,b,c) where
instantiateFull' (x,y,z) =
- do (x,(y,z)) <- instantiateFull' (x,(y,z))
- return (x,y,z)
+ do (x,(y,z)) <- instantiateFull' (x,(y,z))
+ return (x,y,z)
instance InstantiateFull a => InstantiateFull (Closure a) where
instantiateFull' cl = do
- x <- enterClosure cl instantiateFull'
- return $ cl { clValue = x }
+ x <- enterClosure cl instantiateFull'
+ return $ cl { clValue = x }
instance InstantiateFull ProblemConstraint where
instantiateFull' (PConstr p c) = PConstr p <$> instantiateFull' c
@@ -1118,10 +1061,10 @@ instance InstantiateFull DisplayForm where
instantiateFull' (Display n ps v) = uncurry (Display n) <$> instantiateFull' (ps, v)
instance InstantiateFull DisplayTerm where
- instantiateFull' (DTerm v) = DTerm <$> instantiateFull' v
- instantiateFull' (DDot v) = DDot <$> instantiateFull' v
- instantiateFull' (DCon c vs) = DCon c <$> instantiateFull' vs
- instantiateFull' (DDef c vs) = DDef c <$> instantiateFull' vs
+ instantiateFull' (DTerm v) = DTerm <$> instantiateFull' v
+ instantiateFull' (DDot v) = DDot <$> instantiateFull' v
+ instantiateFull' (DCon c vs) = DCon c <$> instantiateFull' vs
+ instantiateFull' (DDef c vs) = DDef c <$> instantiateFull' vs
instantiateFull' (DWithApp v vs ws) = uncurry3 DWithApp <$> instantiateFull' (v, vs, ws)
instance InstantiateFull Defn where
@@ -1131,9 +1074,9 @@ instance InstantiateFull Defn where
(cs, cc, inv) <- instantiateFull' (cs, cc, inv)
return $ d { funClauses = cs, funCompiled = cc, funInv = inv }
Datatype{ dataSort = s, dataClause = cl } -> do
- s <- instantiateFull' s
- cl <- instantiateFull' cl
- return $ d { dataSort = s, dataClause = cl }
+ s <- instantiateFull' s
+ cl <- instantiateFull' cl
+ return $ d { dataSort = s, dataClause = cl }
Record{ recConType = t, recClause = cl, recTel = tel } -> do
t <- instantiateFull' t
cl <- instantiateFull' cl
@@ -1173,9 +1116,9 @@ instance InstantiateFull Clause where
instance InstantiateFull Interface where
instantiateFull' (Interface h ms mod scope inside
sig b hsImports highlighting pragmas patsyns) =
- Interface h ms mod scope inside
- <$> instantiateFull' sig
- <*> instantiateFull' b
+ Interface h ms mod scope inside
+ <$> instantiateFull' sig
+ <*> instantiateFull' b
<*> return hsImports
<*> return highlighting
<*> return pragmas
@@ -1183,7 +1126,7 @@ instance InstantiateFull Interface where
instance InstantiateFull a => InstantiateFull (Builtin a) where
instantiateFull' (Builtin t) = Builtin <$> instantiateFull' t
- instantiateFull' (Prim x) = Prim <$> instantiateFull' x
+ instantiateFull' (Prim x) = Prim <$> instantiateFull' x
instance InstantiateFull QName where
instantiateFull' = return
diff --git a/src/full/Agda/TypeChecking/Reduce/Monad.hs b/src/full/Agda/TypeChecking/Reduce/Monad.hs
index 2215677..e985e92 100644
--- a/src/full/Agda/TypeChecking/Reduce/Monad.hs
+++ b/src/full/Agda/TypeChecking/Reduce/Monad.hs
@@ -1,6 +1,7 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE RankNTypes #-}
module Agda.TypeChecking.Reduce.Monad
( constructorForm
@@ -29,22 +30,25 @@ import Agda.Syntax.Position
import Agda.Syntax.Internal
import Agda.TypeChecking.Monad hiding
( enterClosure, underAbstraction_, underAbstraction, addCtx, mkContextEntry,
- isInstantiatedMeta, verboseS, reportSDoc, reportSLn, typeOfConst, lookupMeta, instantiateDef )
+ isInstantiatedMeta, verboseS, reportSDoc, reportSLn, typeOfConst, lookupMeta )
import Agda.TypeChecking.Monad.Builtin hiding ( constructorForm )
import Agda.TypeChecking.Substitute
import Agda.Interaction.Options
-import Agda.Utils.Fresh
import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Lens
import Agda.Utils.Monad
import Agda.Utils.Pretty
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
gets :: (TCState -> a) -> ReduceM a
gets f = f . redSt <$> ReduceM ask
+useR :: Lens' a TCState -> ReduceM a
+useR l = gets (^.l)
+
askR :: ReduceM ReduceEnv
askR = ReduceM ask
@@ -52,15 +56,15 @@ localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a
localR f = ReduceM . local f . unReduceM
instance HasOptions ReduceM where
- pragmaOptions = gets stPragmaOptions
+ pragmaOptions = useR stPragmaOptions
commandLineOptions = do
- p <- gets stPragmaOptions
- cl <- gets $ stPersistentOptions . stPersistent
+ p <- useR stPragmaOptions
+ cl <- gets $ stPersistentOptions . stPersistentState
return $ cl{ optPragmaOptions = p }
instance HasBuiltins ReduceM where
- getBuiltinThing b = liftM2 mplus (Map.lookup b <$> gets stLocalBuiltins)
- (Map.lookup b <$> gets stImportedBuiltins)
+ getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useR stLocalBuiltins)
+ (Map.lookup b <$> useR stImportedBuiltins)
constructorForm :: Term -> ReduceM Term
constructorForm v = do
@@ -72,9 +76,9 @@ enterClosure :: Closure a -> (a -> ReduceM b) -> ReduceM b
enterClosure (Closure sig env scope x) f = localR (mapRedEnvSt inEnv inState) (f x)
where
inEnv e = env { envAllowDestructiveUpdate = envAllowDestructiveUpdate e }
- inState s = s { stScope = scope } -- TODO: use the signature here? would that fix parts of issue 118?
+ inState s = set stScope scope s -- TODO: use the signature here? would that fix parts of issue 118?
-withFreshR :: HasFresh i FreshThings => (i -> ReduceM a) -> ReduceM a
+withFreshR :: HasFresh i => (i -> ReduceM a) -> ReduceM a
withFreshR f = do
s <- gets id
let (i, s') = nextFresh s
@@ -110,7 +114,7 @@ underAbstraction_ :: Subst a => Abs a -> (a -> ReduceM b) -> ReduceM b
underAbstraction_ = underAbstraction dummyDom
lookupMeta :: MetaId -> ReduceM MetaVariable
-lookupMeta i = fromMaybe __IMPOSSIBLE__ . Map.lookup i <$> gets stMetaStore
+lookupMeta i = fromMaybe __IMPOSSIBLE__ . Map.lookup i <$> useR stMetaStore
isInstantiatedMeta :: MetaId -> ReduceM Bool
isInstantiatedMeta i = do
@@ -157,8 +161,8 @@ traceSLn k n s = applyWhenVerboseS k n (trace s)
instance HasConstInfo ReduceM where
getConstInfo q = ReduceM $ ReaderT $ \(ReduceEnv env st) -> Identity $
- let defs = sigDefinitions $ stSignature st
- idefs = sigDefinitions $ stImports st
+ let defs = sigDefinitions $ st^.stSignature
+ idefs = sigDefinitions $ st^.stImports
in case catMaybes [HMap.lookup q defs, HMap.lookup q idefs] of
[] -> trace ("Unbound name: " ++ show q ++ " " ++ showQNameId q) __IMPOSSIBLE__
[d] -> mkAbs env d
diff --git a/src/full/Agda/TypeChecking/Rewriting.hs b/src/full/Agda/TypeChecking/Rewriting.hs
index 8fd319a..3a6de48 100644
--- a/src/full/Agda/TypeChecking/Rewriting.hs
+++ b/src/full/Agda/TypeChecking/Rewriting.hs
@@ -61,7 +61,7 @@ import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Check that the name given to the BUILTIN REWRITE is actually
diff --git a/src/full/Agda/TypeChecking/Rules/Builtin.hs b/src/full/Agda/TypeChecking/Rules/Builtin.hs
index 6a8defd..b661445 100644
--- a/src/full/Agda/TypeChecking/Rules/Builtin.hs
+++ b/src/full/Agda/TypeChecking/Rules/Builtin.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TupleSections #-}
@@ -6,7 +6,6 @@ module Agda.TypeChecking.Rules.Builtin (bindBuiltin, bindPostulatedName) where
import Control.Applicative
import Control.Monad
-import Control.Monad.Error
import Data.List (find)
import qualified Agda.Syntax.Abstract as A
@@ -28,10 +27,11 @@ import Agda.TypeChecking.Rules.Term ( checkExpr , inferExpr )
import {-# SOURCE #-} Agda.TypeChecking.Rules.Builtin.Coinduction
import {-# SOURCE #-} Agda.TypeChecking.Rewriting
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Maybe
import Agda.Utils.Size
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -402,8 +402,8 @@ bindBuiltinInfo (BuiltinInfo s d) e = do
bindBuiltinName s (name e')
BuiltinPrim pfname axioms -> do
- case e of
- A.Def qx -> do
+ case e of
+ A.Def qx -> do
PrimImpl t pf <- lookupPrimitiveFunction pfname
v <- checkExpr e t
@@ -420,7 +420,7 @@ bindBuiltinInfo (BuiltinInfo s d) e = do
-- needed? yes, for checking equations for mul
bindBuiltinName s v
- _ -> typeError $ GenericError $ "Builtin " ++ s ++ " must be bound to a function"
+ _ -> typeError $ GenericError $ "Builtin " ++ s ++ " must be bound to a function"
BuiltinPostulate rel t -> do
t' <- t
diff --git a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs
index 020276f..3aa1086 100644
--- a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs
+++ b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs
@@ -1,9 +1,9 @@
+-- {-# LANGUAGE CPP #-}
+
------------------------------------------------------------------------
-- | Handling of the INFINITY, SHARP and FLAT builtins.
------------------------------------------------------------------------
--- {-# LANGUAGE CPP #-}
-
module Agda.TypeChecking.Rules.Builtin.Coinduction where
import Control.Applicative
@@ -93,7 +93,7 @@ bindBuiltinSharp e =
addConstant sharp $
sharpDefn { theDef = Constructor
{ conPars = 2
- , conSrcCon = ConHead sharp [] -- flat is added as field later
+ , conSrcCon = ConHead sharp CoInductive [] -- flat is added as field later
, conData = defName infDefn
, conAbstr = ConcreteDef
, conInd = CoInductive
@@ -115,7 +115,7 @@ bindBuiltinFlat e =
Def sharp _ <- ignoreSharing <$> primSharp
kit <- requireLevels
Def inf _ <- ignoreSharing <$> primInf
- let sharpCon = ConHead sharp [flat]
+ let sharpCon = ConHead sharp CoInductive [flat]
level = El (mkType 0) $ Def (typeName kit) []
tel :: Telescope
tel = ExtendTel (domH $ level) $ Abs "a" $
@@ -157,6 +157,7 @@ bindBuiltinFlat e =
, funTerminates = Just True
, funExtLam = Nothing
, funWith = Nothing
+ , funCopatternLHS = isCopatternLHS [clause]
}
}
diff --git a/src/full/Agda/TypeChecking/Rules/Data.hs b/src/full/Agda/TypeChecking/Rules/Data.hs
index 421d97a..b0d0545 100644
--- a/src/full/Agda/TypeChecking/Rules/Data.hs
+++ b/src/full/Agda/TypeChecking/Rules/Data.hs
@@ -36,7 +36,7 @@ import Agda.Utils.Size
import Agda.Utils.Tuple
import qualified Agda.Utils.VarSet as VarSet
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -48,7 +48,7 @@ import Agda.Utils.Impossible
checkDataDef :: Info.DefInfo -> QName -> [A.LamBinding] -> [A.Constructor] -> TCM ()
checkDataDef i name ps cs =
traceCall (CheckDataDef (getRange i) (qnameName name) ps cs) $ do -- TODO!! (qnameName)
- let countPars A.DomainFree{} = 1
+ let countPars A.DomainFree{} = 1
countPars (A.DomainFull (A.TypedBindings _ (Arg _ b))) = case b of
A.TLet{} -> 0
A.TBind _ xs _ -> size xs
@@ -57,8 +57,8 @@ checkDataDef i name ps cs =
-- Add the datatype module
addSection (qnameToMName name) 0
- -- Look up the type of the datatype.
- t <- instantiateFull =<< typeOfConst name
+ -- Look up the type of the datatype.
+ t <- instantiateFull =<< typeOfConst name
-- Make sure the shape of the type is visible
let unTelV (TelV tel a) = telePi tel a
@@ -67,15 +67,15 @@ checkDataDef i name ps cs =
-- Top level free vars
freeVars <- getContextArgs
- -- The parameters are in scope when checking the constructors.
- dataDef <- bindParameters ps t $ \tel t0 -> do
+ -- The parameters are in scope when checking the constructors.
+ dataDef <- bindParameters ps t $ \tel t0 -> do
- -- Parameters are always hidden in constructors
- let tel' = hideAndRelParams <$> tel
- -- let tel' = hideTel tel
+ -- Parameters are always hidden in constructors
+ let tel' = hideAndRelParams <$> tel
+ -- let tel' = hideTel tel
- -- The type we get from bindParameters is Θ -> s where Θ is the type of
- -- the indices. We count the number of indices and return s.
+ -- 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.
(nofIxs, s) <- splitType t0
@@ -103,7 +103,7 @@ checkDataDef i name ps cs =
]
]
- -- Change the datatype from an axiom to a datatype with no constructors.
+ -- Change the datatype from an axiom to a datatype with no constructors.
let dataDef = Datatype
{ dataPars = npars
, dataSmallPars = Perm npars smallPars
@@ -117,14 +117,14 @@ checkDataDef i name ps cs =
, dataMutual = []
}
- escapeContext (size tel) $ do
- addConstant name $
+ escapeContext (size tel) $ do
+ addConstant name $
defaultDefn defaultArgInfo name t dataDef
-- polarity and argOcc.s determined by the positivity checker
- -- Check the types of the constructors
+ -- Check the types of the constructors
-- collect the non-linear parameters of each constructor
- nonLins <- mapM (checkConstructor name tel' nofIxs s) cs
+ nonLins <- mapM (checkConstructor name tel' nofIxs s) cs
-- compute the ascending list of non-linear parameters of the data type
let nonLinPars0 = Set.toAscList $ Set.unions $ map Set.fromList nonLins
-- The constructors are analyzed in the absolute context,
@@ -134,23 +134,23 @@ checkDataDef i name ps cs =
-- is then performed by addConstant, cannot restore the linearity info.
nonLinPars = Drop (size freeVars) $ Perm (npars + size freeVars) nonLinPars0
- -- Return the data definition
- return dataDef{ dataNonLinPars = nonLinPars }
+ -- Return the data definition
+ return dataDef{ dataNonLinPars = nonLinPars }
let s = dataSort dataDef
cons = map A.axiomName cs -- get constructor names
- -- If proof irrelevance is enabled we have to check that datatypes in
- -- Prop contain at most one element.
- do proofIrr <- proofIrrelevance
- case (proofIrr, s, cs) of
- (True, Prop, _:_:_) -> setCurrentRange (getRange cons) $
+ -- If proof irrelevance is enabled we have to check that datatypes in
+ -- Prop contain at most one element.
+ do proofIrr <- proofIrrelevance
+ case (proofIrr, s, cs) of
+ (True, Prop, _:_:_) -> setCurrentRange (getRange cons) $
typeError PropMustBeSingleton
- _ -> return ()
+ _ -> return ()
- -- Add the datatype to the signature with its constructors.
+ -- Add the datatype to the signature with its constructors.
-- It was previously added without them.
- addConstant name $
+ addConstant name $
defaultDefn defaultArgInfo name t $
dataDef{ dataCons = cons }
@@ -207,27 +207,27 @@ checkConstructor d tel nofIxs s con@(A.Axiom _ i _ c e) =
-}
-- check that the type of the constructor is well-formed
debugEnter c e
- t <- isType_ e
+ t <- isType_ e
-- check that the type of the constructor ends in the data type
- n <- getContextSize
- -- OLD: n <- size <$> getContextTelescope
+ n <- getContextSize
+ -- OLD: n <- size <$> getContextTelescope
debugEndsIn t d n
- nonLinPars <- constructs n t d
+ nonLinPars <- constructs n t d
debugNonLinPars nonLinPars
-- check that the sort (universe level) of the constructor type
-- is contained in the sort of the data type
-- (to avoid impredicative existential types)
debugFitsIn s
- t `fitsIn` s
+ t `fitsIn` s
-- check which constructor arguments are determined by the type ('forcing')
t' <- addForcingAnnotations t
debugAdd c t'
-- add parameters to constructor type and put into signature
- let con = ConHead c [] -- data constructors have no projectable fields
+ let con = ConHead c Inductive [] -- data constructors have no projectable fields and are always inductive
escapeContext (size tel) $
addConstant c $
- defaultDefn defaultArgInfo c (telePi tel t') $
+ defaultDefn defaultArgInfo c (telePi tel t') $
Constructor (size tel) con d (Info.defAbstract i) Inductive
-- declare the constructor as eligible for instance search
@@ -271,9 +271,9 @@ bindParameters (A.DomainFull (A.TypedBindings _ (Arg info (A.TLet _ lbs))) : bs)
bindParameters ps0@(A.DomainFree info x : ps) (El _ (Pi arg@(Dom info' a) b)) ret
-- Andreas, 2011-04-07 ignore relevance information in binding?!
| argInfoHiding info /= argInfoHiding info' =
- __IMPOSSIBLE__
+ __IMPOSSIBLE__
| otherwise = addContext (x, arg) $ bindParameters ps (absBody b) $ \tel s ->
- ret (ExtendTel arg $ Abs (nameToArgName x) tel) s
+ ret (ExtendTel arg $ Abs (nameToArgName x) tel) s
bindParameters bs (El s (Shared p)) ret = bindParameters bs (El s $ derefPtr p) ret
bindParameters (b : bs) t _ = __IMPOSSIBLE__
{- Andreas, 2012-01-17 Concrete.Definitions ensures number and hiding of parameters to be correct
@@ -320,29 +320,29 @@ constructs nofPars t q = constrT 0 t
where
{- OLD
constrT :: Nat -> Type -> TCM ()
- constrT n (El s v) = constr n s v
+ constrT n (El s v) = constr n s v
constr :: Nat -> Sort -> Term -> TCM ()
- constr n s v = do
- v <- reduce v
- case ignoreSharing v of
- Pi _ (NoAbs _ b) -> constrT n b
- Pi a b -> underAbstraction a b $ constrT (n + 1)
- Def d vs
- | d == q -> checkParams n =<< reduce (take nofPars vs)
- -- we only check the parameters
- _ -> bad $ El s v
-
- bad t = typeError $ ShouldEndInApplicationOfTheDatatype t
+ constr n s v = do
+ v <- reduce v
+ case ignoreSharing v of
+ Pi _ (NoAbs _ b) -> constrT n b
+ Pi a b -> underAbstraction a b $ constrT (n + 1)
+ Def d vs
+ | d == q -> checkParams n =<< reduce (take nofPars vs)
+ -- we only check the parameters
+ _ -> bad $ El s v
+
+ bad t = typeError $ ShouldEndInApplicationOfTheDatatype t
-}
constrT :: Nat -> Type -> TCM [Int]
constrT n t = do
- t <- reduce t
- case ignoreSharing $ unEl t of
- Pi _ (NoAbs _ b) -> constrT n b
- Pi a b -> underAbstraction a b $ constrT (n + 1)
+ t <- reduce t
+ case ignoreSharing $ unEl t of
+ Pi _ (NoAbs _ b) -> constrT n b
+ Pi a b -> underAbstraction a b $ constrT (n + 1)
-- OR: addCxtString (absName b) a $ constrT (n + 1) (absBody b)
- Def d es | d == q -> do
+ Def d es | d == q -> do
let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
(pars, ixs) <- normalise $ splitAt nofPars vs
-- check that the constructor parameters are the data parameters
@@ -354,26 +354,26 @@ constructs nofPars t q = constrT 0 t
when (any (< 0) nl) __IMPOSSIBLE__
when (any (>= nofPars) nl) __IMPOSSIBLE__
return nl
- _ -> typeError $ ShouldEndInApplicationOfTheDatatype t
+ _ -> typeError $ ShouldEndInApplicationOfTheDatatype t
- checkParams n vs = zipWithM_ sameVar vs ps
- where
+ checkParams n vs = zipWithM_ sameVar vs ps
+ where
nvs = size vs
- ps = genericTake nvs $ downFrom (n + nvs)
+ ps = genericTake nvs $ downFrom (n + nvs)
- sameVar arg i
+ sameVar arg i
-- skip irrelevant parameters
| isIrrelevant arg = return ()
- | otherwise = do
- t <- typeOfBV i
- equalTerm t (unArg arg) (var i)
+ | otherwise = do
+ t <- typeOfBV i
+ equalTerm t (unArg arg) (var i)
-- return the parameters (numbered 0,1,...,size pars-1 from left to right)
-- that occur relevantly in the indices
nonLinearParams n pars ixs =
-- compute the free de Bruijn indices in the data indices
-- ALT: Ignore all sorts?
- let fv = freeVars' FreeConf{ fcIgnoreSorts = IgnoreInAnnotations } ixs
+ let fv = freeVarsIgnore IgnoreInAnnotations ixs
-- keep relevant ones, convert to de Bruijn levels
-- note: xs is descending list
xs = map ((n-1) -) $ VarSet.toList $ relevantVars fv
@@ -388,15 +388,15 @@ forceData d (El s0 t) = liftTCM $ do
t' <- reduce t
d <- canonicalName d
case ignoreSharing t' of
- Def d' _
- | d == d' -> return $ El s0 t'
- | otherwise -> fail $ "wrong datatype " ++ show d ++ " != " ++ show d'
- MetaV m vs -> do
- Defn {defType = t, theDef = Datatype{dataSort = s}} <- getConstInfo d
- ps <- newArgsMeta t
- noConstraints $ leqType (El s0 t') (El s (Def d ps)) -- TODO: need equalType?
- reduce $ El s0 t'
- _ -> typeError $ ShouldBeApplicationOf (El s0 t) d
+ Def d' _
+ | d == d' -> return $ El s0 t'
+ | otherwise -> fail $ "wrong datatype " ++ show d ++ " != " ++ show d'
+ MetaV m vs -> do
+ Defn {defType = t, theDef = Datatype{dataSort = s}} <- getConstInfo d
+ ps <- newArgsMeta t
+ noConstraints $ leqType (El s0 t') (El s (Def d ps)) -- TODO: need equalType?
+ reduce $ El s0 t'
+ _ -> typeError $ ShouldBeApplicationOf (El s0 t) d
-}
-- | Is the type coinductive? Returns 'Nothing' if the answer cannot
diff --git a/src/full/Agda/TypeChecking/Rules/Decl.hs b/src/full/Agda/TypeChecking/Rules/Decl.hs
index 3f9385a..4999b74 100644
--- a/src/full/Agda/TypeChecking/Rules/Decl.hs
+++ b/src/full/Agda/TypeChecking/Rules/Decl.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Rules.Decl where
@@ -47,21 +47,23 @@ import Agda.TypeChecking.Rewriting
import Agda.TypeChecking.SizedTypes.Solve
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
+import Agda.TypeChecking.Unquote
import Agda.TypeChecking.Rules.Term
import Agda.TypeChecking.Rules.Data ( checkDataDef )
import Agda.TypeChecking.Rules.Record ( checkRecDef )
-import Agda.TypeChecking.Rules.Def ( checkFunDef )
+import Agda.TypeChecking.Rules.Def ( checkFunDef, useTerPragma )
import Agda.TypeChecking.Rules.Builtin ( bindBuiltin )
import Agda.Termination.TermCheck
-import Agda.Utils.Size
+import qualified Agda.Utils.HashMap as HMap
import Agda.Utils.Maybe
import Agda.Utils.Monad
-import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.Pretty (prettyShow)
+import Agda.Utils.Size
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Type check a sequence of declarations.
@@ -86,8 +88,8 @@ checkDecl d = traceCall (SetRange (getRange d)) $ do
let -- What kind of final checks/computations should be performed
-- if we're not inside a mutual block?
none m = m >> return Nothing
- meta m = m >> return (Just (return []))
- mutual i ds m = m >>= return . Just . mutualChecks i ds
+ meta m = m >> return (Just (return ()))
+ mutual i ds m = m >>= return . Just . mutualChecks i d ds
impossible m = m >> return __IMPOSSIBLE__
-- We're definitely inside a mutual block.
@@ -124,46 +126,19 @@ checkDecl d = traceCall (SetRange (getRange d)) $ do
-- highlighting purposes.
A.UnquoteDecl mi i x e -> checkUnquoteDecl mi i x e
- unlessM (isJust . envMutualBlock <$> ask) $ do
- -- The termination errors are not returned, but used for highlighting.
- termErrs <- caseMaybe finalChecks (return []) $ \ theMutualChecks -> do
+ unlessM (isJust <$> asks envMutualBlock) $ do
+
+ -- Syntax highlighting.
+ highlight_ d
+
+ -- Post-typing checks.
+ whenJust finalChecks $ \ theMutualChecks -> do
solveSizeConstraints
- wakeupConstraints_ -- solve emptyness constraints
+ wakeupConstraints_ -- solve emptiness constraints
freezeMetas
theMutualChecks
- -- Syntax highlighting.
- let highlight d = generateAndPrintSyntaxInfo d (Full termErrs)
- reimburseTop Bench.Typing $ billTop Bench.Highlighting $ case d of
- A.Axiom{} -> highlight d
- A.Field{} -> __IMPOSSIBLE__
- A.Primitive{} -> highlight d
- A.Mutual{} -> highlight d
- A.Apply{} -> highlight d
- A.Import{} -> highlight d
- A.Pragma{} -> highlight d
- A.ScopedDecl{} -> return ()
- A.FunDef{} -> __IMPOSSIBLE__
- A.DataDef{} -> __IMPOSSIBLE__
- A.DataSig{} -> __IMPOSSIBLE__
- A.Open{} -> highlight d
- A.PatternSynDef{} -> highlight d
- A.UnquoteDecl{} -> highlight d
- A.Section i x tel _ -> highlight (A.Section i x tel [])
- -- Each block in the section has already been highlighted,
- -- all that remains is the module declaration.
- A.RecSig{} -> highlight d
- A.RecDef i x ind c ps tel cs ->
- highlight (A.RecDef i x ind c [] tel (fields cs))
- -- The telescope and all record module declarations except
- -- for the fields have already been highlighted.
- where
- fields (A.ScopedDecl _ ds1 : ds2) = fields ds1 ++ fields ds2
- fields (d at A.Field{} : ds) = d : fields ds
- fields (_ : ds) = fields ds
- fields [] = []
-
where
unScope (A.ScopedDecl scope ds) = setScope scope >> unScope d
unScope d = return d
@@ -184,47 +159,54 @@ checkDecl d = traceCall (SetRange (getRange d)) $ do
abstract ConcreteDef = inConcreteMode
abstract AbstractDef = inAbstractMode
- -- Some checks that should be run at the end of a mutual
- -- block (or non-mutual record declaration). The set names
- -- contains the names defined in the mutual block.
- mutualChecks i ds names = do
- -- Andreas, 2014-04-11: instantiate metas in definition types
- mapM_ instantiateDefinitionType $ Set.toList names
- -- Andreas, 2013-02-27: check termination before injectivity,
- -- to avoid making the injectivity checker loop.
- termErrs <- case d of
- A.UnquoteDecl{} -> checkTermination_ $ A.Mutual i ds
- _ -> checkTermination_ d
- checkPositivity_ names
- checkCoinductiveRecords ds
- -- Andreas, 2012-09-11: Injectivity check stores clauses
- -- whose 'Relevance' is affected by polarity computation,
- -- so do it here.
- checkInjectivity_ names
- checkProjectionLikeness_ names
- return termErrs
-
- checkUnquoteDecl mi i x e = do
- reportSDoc "tc.unquote.decl" 20 $ text "Checking unquoteDecl" <+> prettyTCM x
- fundef <- primAgdaFunDef
- v <- checkExpr e $ El (mkType 0) fundef
- reportSDoc "tc.unquote.decl" 20 $ text "unquoteDecl: Checked term"
- UnQFun a cs <- unquote v
+-- Some checks that should be run at the end of a mutual
+-- block (or non-mutual record declaration). The set names
+-- contains the names defined in the mutual block.
+mutualChecks :: Info.MutualInfo -> A.Declaration -> [A.Declaration] -> Set QName -> TCM ()
+mutualChecks i d ds names = do
+ -- Andreas, 2014-04-11: instantiate metas in definition types
+ mapM_ instantiateDefinitionType $ Set.toList names
+ -- Andreas, 2013-02-27: check termination before injectivity,
+ -- to avoid making the injectivity checker loop.
+ checkTermination_ d
+ checkPositivity_ names
+ checkCoinductiveRecords ds
+ -- Andreas, 2012-09-11: Injectivity check stores clauses
+ -- whose 'Relevance' is affected by polarity computation,
+ -- so do it here.
+ checkInjectivity_ names
+ checkProjectionLikeness_ names
+
+type FinalChecks = Maybe (TCM ())
+
+checkUnquoteDecl :: Info.MutualInfo -> Info.DefInfo -> QName -> A.Expr -> TCM FinalChecks
+checkUnquoteDecl mi i x e = do
+ reportSDoc "tc.unquote.decl" 20 $ text "Checking unquoteDecl" <+> prettyTCM x
+ fundef <- primAgdaFunDef
+ v <- checkExpr e $ El (mkType 0) fundef
+ reportSDoc "tc.unquote.decl" 20 $ text "unquoteDecl: Checked term"
+ uv <- runUnquoteM $ unquote v
+ case uv of
+ Left err -> typeError $ UnquoteFailed err
+ Right (UnQFun a cs) -> do
reportSDoc "tc.unquote.decl" 20 $
vcat $ text "unquoteDecl: Unquoted term"
: [ nest 2 $ text (show c) | c <- cs ]
-- Add x to signature, otherwise reification gets unhappy.
- addConstant x $ defaultDefn defaultArgInfo x a emptyFunction
+ addConstant x =<< do
+ useTerPragma $ defaultDefn defaultArgInfo x a emptyFunction
a <- reifyUnquoted a
reportSDoc "tc.unquote.decl" 10 $
vcat [ text "unquoteDecl" <+> prettyTCM x <+> text "-->"
, prettyTCM x <+> text ":" <+> prettyA a ]
- cs <- mapM (reifyUnquoted . QNamed x) cs
+ tel <- getContextTelescope
+ let tel' = replaceEmptyName "r" $ killRange tel
+ cs <- mapM (reifyUnquoted . QNamed x . abstract tel) cs
reportSDoc "tc.unquote.decl" 10 $ vcat $ map prettyA cs
let ds = [ A.Axiom A.FunSig i defaultArgInfo x a -- TODO other than defaultArg
, A.FunDef i x NotDelayed cs ]
xs <- checkMutual mi ds
- return $ Just $ mutualChecks mi ds xs
+ return $ Just $ mutualChecks mi (A.Mutual mi ds) ds xs
-- | Instantiate all metas in 'Definition' associated to 'QName'. -- Makes sense after freezing metas.
-- Some checks, like free variable analysis, are not in 'TCM', -- so they will be more precise (see issue 1099) after meta instantiation.
@@ -253,20 +235,51 @@ instantiateDefinitionType q = do
-- def <- instantiateFull def
-- modifySignature $ updateDefinition q $ const def
-
--- | Termination check a declaration and return a list of termination errors.
-checkTermination_ :: A.Declaration -> TCM [TerminationError]
+-- | Highlight a declaration.
+highlight_ :: A.Declaration -> TCM ()
+highlight_ d = do
+ let highlight d = generateAndPrintSyntaxInfo d Full
+ reimburseTop Bench.Typing $ billTop Bench.Highlighting $ case d of
+ A.Axiom{} -> highlight d
+ A.Field{} -> __IMPOSSIBLE__
+ A.Primitive{} -> highlight d
+ A.Mutual{} -> highlight d
+ A.Apply{} -> highlight d
+ A.Import{} -> highlight d
+ A.Pragma{} -> highlight d
+ A.ScopedDecl{} -> return ()
+ A.FunDef{} -> __IMPOSSIBLE__
+ A.DataDef{} -> __IMPOSSIBLE__
+ A.DataSig{} -> __IMPOSSIBLE__
+ A.Open{} -> highlight d
+ A.PatternSynDef{} -> highlight d
+ A.UnquoteDecl{} -> highlight d
+ A.Section i x tel _ -> highlight (A.Section i x tel [])
+ -- Each block in the section has already been highlighted,
+ -- all that remains is the module declaration.
+ A.RecSig{} -> highlight d
+ A.RecDef i x ind c ps tel cs ->
+ highlight (A.RecDef i x ind c [] tel (fields cs))
+ -- The telescope and all record module declarations except
+ -- for the fields have already been highlighted.
+ where
+ fields (A.ScopedDecl _ ds1 : ds2) = fields ds1 ++ fields ds2
+ fields (d at A.Field{} : ds) = d : fields ds
+ fields (_ : ds) = fields ds
+ fields [] = []
+
+-- | Termination check a declaration.
+checkTermination_ :: A.Declaration -> TCM ()
checkTermination_ d = reimburseTop Bench.Typing $ billTop Bench.Termination $ do
reportSLn "tc.decl" 20 $ "checkDecl: checking termination..."
- ifNotM (optTerminationCheck <$> pragmaOptions) (return []) $ {- else -} do
+ whenM (optTerminationCheck <$> pragmaOptions) $ do
case d of
-- Record module definitions should not be termination-checked twice.
- A.RecDef {} -> return []
+ A.RecDef {} -> return ()
_ -> disableDestructiveUpdate $ do
- termErrs <- {- nubList <$> -} termDecl d
- modify $ \st ->
- st { stTermErrs = Fold.foldl' (|>) (stTermErrs st) termErrs }
- return termErrs
+ termErrs <- termDecl d
+ unless (null termErrs) $
+ typeError $ TerminationCheckFailed termErrs
-- | Check a set of mutual names for positivity.
checkPositivity_ :: Set QName -> TCM ()
@@ -353,8 +366,8 @@ checkAxiom funSig i info0 x e = do
]
-- Not safe. See Issue 330
-- t <- addForcingAnnotations t
- addConstant x $
- defaultDefn info x t $
+ addConstant x =<< do
+ useTerPragma $ defaultDefn info x t $
case funSig of
A.FunSig -> emptyFunction
A.NoFunSig -> Axiom -- NB: used also for data and record type sigs
@@ -375,21 +388,18 @@ checkPrimitive i x e =
(_, PrimImpl t' pf) <- lookupPrimitiveFunctionQ x
t <- isType_ e
noConstraints $ equalType t t'
- let s = show $ nameConcrete $ qnameName x
+ let s = prettyShow $ qnameName x
bindPrimitive s pf
addConstant x $
defaultDefn defaultArgInfo x t $
Primitive (Info.defAbstract i) s [] Nothing
- where
- nameString (Name _ x _ _) = show x
-
-- | Check a pragma.
checkPragma :: Range -> A.Pragma -> TCM ()
checkPragma r p =
traceCall (CheckPragma r p) $ case p of
- A.BuiltinPragma x e -> bindBuiltin x e
- A.RewritePragma q -> addRewriteRule q
+ A.BuiltinPragma x e -> bindBuiltin x e
+ A.RewritePragma q -> addRewriteRule q
A.CompiledTypePragma x hs -> do
def <- getConstInfo x
case theDef def of
@@ -481,7 +491,7 @@ checkPragma r p =
case theDef def of
Function{} -> markStatic x
_ -> typeError $ GenericError "STATIC directive only works on functions"
- A.OptionsPragma{} -> typeError $ GenericError $ "OPTIONS pragma only allowed at beginning of file, before top module declaration"
+ A.OptionsPragma{} -> typeError $ GenericError $ "OPTIONS pragma only allowed at beginning of file, before top module declaration"
A.EtaPragma r -> do
unlessM (isJust <$> isRecord r) $
typeError $ GenericError $ "ETA pragma is only applicable to records"
@@ -504,7 +514,8 @@ checkMutual i ds = inMutualBlock $ do
(text "Checking mutual block" <+> text (show blockId) <> text ":") :
map (nest 2 . prettyA) ds
- mapM_ checkDecl ds
+ local (\e -> e { envTerminationCheck = () <$ Info.mutualTermCheck i }) $
+ mapM_ checkDecl ds
lookupMutualBlock =<< currentOrFreshMutualBlock
@@ -515,10 +526,10 @@ checkTypeSignature (A.ScopedDecl scope ds) = do
mapM_ checkTypeSignature ds
checkTypeSignature (A.Axiom funSig i info x e) =
case Info.defAccess i of
- PublicAccess -> inConcreteMode $ checkAxiom funSig i info x e
- PrivateAccess -> inAbstractMode $ checkAxiom funSig i info x e
+ PublicAccess -> inConcreteMode $ checkAxiom funSig i info x e
+ PrivateAccess -> inAbstractMode $ checkAxiom funSig i info x e
OnlyQualified -> __IMPOSSIBLE__
-checkTypeSignature _ = __IMPOSSIBLE__ -- type signatures are always axioms
+checkTypeSignature _ = __IMPOSSIBLE__ -- type signatures are always axioms
-- | Type check a module.
checkSection :: Info.ModuleInfo -> ModuleName -> A.Telescope -> [A.Declaration] -> TCM ()
@@ -682,7 +693,7 @@ checkSectionApplication' i m1 (A.RecordModuleIFS x) rd rm = do
-- , nest 2 $ text "args =" <+> text (show args)
]
when (tel == EmptyTel) $
- typeError $ GenericError $ show name ++ " is not a parameterised section"
+ typeError $ GenericError $ show (qnameToConcrete name) ++ " is not a parameterised section"
addCtxTel telInst $ do
vs <- freeVarsToApply name
diff --git a/src/full/Agda/TypeChecking/Rules/Def.hs b/src/full/Agda/TypeChecking/Rules/Def.hs
index 0007c76..4ddfd50 100644
--- a/src/full/Agda/TypeChecking/Rules/Def.hs
+++ b/src/full/Agda/TypeChecking/Rules/Def.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Rules.Def where
@@ -7,7 +7,7 @@ import Prelude hiding (mapM)
import Control.Arrow ((***))
import Control.Applicative
import Control.Monad.State hiding (forM, mapM)
-import Control.Monad.Error hiding (forM, mapM)
+import Control.Monad.Reader hiding (forM, mapM)
import Data.Function
import Data.List hiding (sort)
@@ -49,11 +49,13 @@ import Agda.TypeChecking.Rules.Term ( checkExpr, inferExpr, infer
import Agda.TypeChecking.Rules.LHS ( checkLeftHandSide, LHSResult(..) )
import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls )
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
+import Agda.Utils.Lens
import Agda.Utils.Size
import Agda.Utils.Permutation
import Agda.Utils.Monad
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -140,6 +142,7 @@ checkAlias t' ai delayed i name e = do
, funTerminates = Nothing
, funExtLam = Nothing
, funWith = Nothing
+ , funCopatternLHS = False
}
reportSDoc "tc.def.alias" 20 $ text "checkAlias: leaving"
@@ -238,8 +241,10 @@ checkFunDef' t ai delayed extlam with i name cs =
]
-- Add the definition
- addConstant name $
- defaultDefn ai name t $
+ addConstant name =<< do
+ -- If there was a pragma for this definition, we can set the
+ -- funTerminates field directly.
+ useTerPragma $ defaultDefn ai name t $
Function
{ funClauses = cs
, funCompiled = Just cc
@@ -253,6 +258,7 @@ checkFunDef' t ai delayed extlam with i name cs =
, funTerminates = Nothing
, funExtLam = extlam
, funWith = with
+ , funCopatternLHS = isCopatternLHS cs
}
-- Andreas 2012-02-13: postpone polarity computation until after positivity check
@@ -265,93 +271,27 @@ checkFunDef' t ai delayed extlam with i name cs =
where
npats = size . clausePats
-{- BEGIN RETIRING implicit argument insertion
-
-{- | Ensure that all clauses have the same number of trailing implicits.
-Example:
-
-@
- test : Bool → {A B : Set} → Set
- test true {A} = A
- test false {B = B} = B
-@
-
- at trailingImplicits@ patches these clauses to
-
-@
- test : Bool → {A B : Set} → Set
- test true {A} {_} = A
- test false {_} {B = B} = B
-@
+-- | Set 'funTerminates' according to termination info in 'TCEnv',
+-- which comes from a possible termination pragma.
+useTerPragma :: Definition -> TCM Definition
+useTerPragma def at Defn{ defName = name, theDef = fun at Function{}} = do
+ tc <- asks envTerminationCheck
+ let terminates = case tc of
+ NonTerminating -> Just False
+ Terminating -> Just True
+ _ -> Nothing
+ reportSLn "tc.fundef" 30 $ unlines $
+ [ "funTerminates of " ++ show name ++ " set to " ++ show terminates
+ , " tc = " ++ show tc
+ ]
+ return $ def { theDef = fun { funTerminates = terminates }}
+useTerPragma def = return def
-such that the arity of the clauses of @test@ is uniform.
--}
--- TODO: how does this work with copatterns/flex arity?
-trailingImplicits :: Type -> [A.SpineClause] -> TCM [A.SpineClause]
-trailingImplicits t [] = __IMPOSSIBLE__
--- Andreas, 2013-10-01: don't do anything if there are projection copatterns
-trailingImplicits t cs | hasProjP cs = return cs
- where
- hasProjP = any (any (isJust . A.isProjP) . A.spLhsPats . A.clauseLHS)
-trailingImplicits t cs@(c:_) = do
- pps@((ps,ips):_) <- mapM splitTrailingImplicits cs
- -- compute the trailing implicits from type t
- TelV tel t0 <- telView t
- let -- number of non-hidden patterns
- nh = genericLength $ filter ((NotHidden ==) . getHiding) ps
- -- drop nh non-hidden domains from t
- l = dropNonHidden nh $ telToList tel
- -- take the hidden domains immediately after the dropped stuff
- is = takeWhile ((NotHidden /=) . getHiding) l
- itel = telFromList is
- -- get the trailing implicit patterns
- ipss = map snd pps
- -- complete the implicit pattern lists
- ipss <- mapM (\ ps -> insertImplicitPatterns DontExpandLast ps itel) ipss
- let longest = head $ sortBy (compare `on` ((0-) . length)) ipss
- pps' = zip (map fst pps) ipss
- return $ zipWith (patchUpTrailingImplicits longest) pps' cs
-
--- | @dropNonHidden n tel@ drops @n@ non-hidden domains from @tel@,
--- including all hidden domains that come before the @n at th non-hidden one.
-dropNonHidden :: Nat -> [I.Dom (String, Type)] -> [I.Dom (String, Type)]
-dropNonHidden 0 l = l
-dropNonHidden n l = case dropWhile ((NotHidden /=) . getHiding) l of
- [] -> [] -- or raise a type checking error "too many arguments in lhs"
- (_:l) -> dropNonHidden (n-1) l
-
--- | @splitTrailingImplicits c@ returns the patterns of clause @c@
--- as pair @(ps, ips)@ where @ips@ are the trailing implicit patterns
--- and @ps@ is the rest.
-splitTrailingImplicits :: A.SpineClause -> TCM (A.Patterns, A.Patterns)
-splitTrailingImplicits (A.Clause (A.SpineLHS _ _ _ wps@(_ : _)) _ _) =
- typeError $ UnexpectedWithPatterns wps
-splitTrailingImplicits (A.Clause (A.SpineLHS _ _ aps []) _ _) = do
- let (ips, ps) = span isHidden $ reverse aps
- return (reverse ps, reverse ips)
-
--- | @patchUpTrailingImplicits should (ps, is) c@ takes a clause @c@ whose
--- patterns are split into @(ps, is)@ where @is@ are the trailing
--- implicit patterns and @ps@ the rest. @is@ has already been patched
--- with omitted implicit patterns (which can occur if named implicit patterns
--- are there originally). @should@ is an extension of @is at .
--- The returned clause contains an extension of @is@ by new wildcards
--- to match @should at .
-patchUpTrailingImplicits :: A.Patterns -> (A.Patterns, A.Patterns) -> A.SpineClause -> A.SpineClause
-patchUpTrailingImplicits should (ps, is) c | length is >= length should = c
-patchUpTrailingImplicits should (ps, is) (A.Clause (A.SpineLHS i x aps []) rhs0 wh) =
- let imp = hide $ defaultArg $ Named Nothing $ A.ImplicitP $ Info.patNoRange
- imps = replicate (length should - length is) imp
- in A.Clause (A.SpineLHS i x (ps ++ is ++ imps) []) rhs0 wh
-patchUpTrailingImplicits _ _ _ = __IMPOSSIBLE__
-
--- END RETIRING implicit argument insertion -}
-- | Insert some patterns in the in with-clauses LHS of the given RHS
insertPatterns :: [A.Pattern] -> A.RHS -> A.RHS
insertPatterns pats (A.WithRHS aux es cs) = A.WithRHS aux es (map insertToClause cs)
where insertToClause (A.Clause (A.LHS i lhscore ps) rhs ds)
--- = A.Clause (A.LHS i x (aps ++ map (Arg NotHidden . unnamed) pats) (ps)) (insertPatterns pats rhs) ds
= A.Clause (A.LHS i lhscore (pats ++ ps)) (insertPatterns pats rhs) ds
insertPatterns pats (A.RewriteRHS qs eqs rhs wh) = A.RewriteRHS qs eqs (insertPatterns pats rhs) wh
insertPatterns pats rhs = rhs
@@ -376,17 +316,7 @@ data WithFunctionProblem
}
-- | Type check a function clause.
-{-
-checkClause :: Type -> A.Clause -> TCM Clause
-checkClause t c@(A.Clause (A.LHS i (A.LHSProj{}) []) rhs0 wh) =
- typeError $ NotImplemented "type checking definitions by copatterns"
-checkClause t c@(A.Clause (A.LHS i (A.LHSHead x aps) []) rhs0 wh) =
--}
checkClause :: Type -> A.SpineClause -> TCM Clause
-{-
-checkClause t c@(A.Clause lhs rhs0 wh) = do
- let A.SpineLHS i x aps withPats = A.lhsToSpine lhs
--}
checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
unless (null withPats) $
typeError $ UnexpectedWithPatterns withPats
@@ -433,7 +363,7 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
-- 1. rewriting with a reflexive equality to happen rarely,
-- 2. especially with ?-holes in the rewrite expression
-- 3. and a large overall number of ?s.
- let sameIP = (==) `on` stInteractionPoints
+ let sameIP = (==) `on` (^.stInteractionPoints)
when (sameIP st st') $ put st
handleRHS $ A.RewriteRHS names eqs rhs wh
@@ -446,21 +376,6 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
equality <- primEqualityName
Con reflCon [] <- ignoreSharing <$> primRefl
- -- Andreas, 2014-05-17 Issue 1110:
- -- Rewriting with REFL has no effect, but gives an
- -- incomprehensible error message about the generated
- -- with clause. Thus, we rather do simply nothing if
- -- rewriting with REFL is attempted.
-
- -- OBSOLETE:
- -- let isRefl v = isRefl' . ignoreSharing =<< reduce v
- -- isRefl' (Con c _) | c == reflCon = return True
- -- isRefl' (Lam h t) = isRefl $ unAbs t
- -- isRefl' (DontCare t) = isRefl t
- -- isRefl' _ = return False
-
- -- ifM (isRefl proof) recurse $ {- else -} do
-
-- Check that the type is actually an equality (lhs ≡ rhs)
-- and extract lhs, rhs, and their type.
@@ -509,8 +424,8 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
-- is defined by induction on eqs.
(A.RewriteRHS names eqs (insertPatterns pats rhs) inner)
outer]
- pats = [A.DotP patNoRange underscore, -- rewriteToExpr,
- A.ConP cinfo (AmbQ [conName reflCon]) []]
+ pats = [ A.DotP patNoRange underscore
+ , A.ConP cinfo (AmbQ [conName reflCon]) []]
reportSDoc "tc.rewrite.top" 25 $ vcat
[ text "rewrite"
, text " from = " <+> prettyTCM rewriteFromExpr
@@ -528,15 +443,18 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
]
reportSDoc "tc.with.top" 30 $
prettyA c
+ reportSDoc "tc.with.top" 20 $ do
+ m <- currentModule
+ nfv <- getModuleFreeVars m
+ sep [ text "with function module:" <+>
+ prettyList (map prettyTCM $ mnameToList m)
+ , text $ "free variables: " ++ show nfv
+ ]
+
-- Infer the types of the with expressions
- vas <- mapM inferExprForWith es
- (vs0, as) <- instantiateFull (unzip vas)
+ (vs0, as) <- unzip <$> mapM inferExprForWith es
(vs, as) <- normalise (vs0, as)
- -- Invent a clever name for the with function
- m <- currentModule
- reportSDoc "tc.with.top" 20 $ text "with function module:" <+> prettyList (map prettyTCM $ mnameToList m)
-
-- Split the telescope into the part needed to type the with arguments
-- and all the other stuff
let fv = allVars $ freeVars (vs, as)
@@ -561,17 +479,11 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
]
-- Create the body of the original function
-{- OLD
- ctx <- getContextTelescope
- let n = size ctx
- m = size delta
- -- All the context variables
- us = [ Arg h r (var i) | (i, Arg h r _) <- zip [n - 1,n - 2..0] $ telToList ctx ]
--}
+
-- All the context variables
us <- getContextArgs
- let n = size us
- m = size delta
+ let n = size us
+ m = size delta
-- First the variables bound outside this definition
(us0, us1') = genericSplitAt (n - m) us
-- Then permute the rest and grab those needed to for the with arguments
@@ -584,12 +496,13 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
-- and Δ₁ ⊢ vs : as
(vs, as) <- do
let -- We know that as does not depend on Δ₂
- rho = parallelS (replicate (size delta2) __IMPOSSIBLE__)
+ rho = compactS __IMPOSSIBLE__ (replicate (size delta2) Nothing)
return $ applySubst rho $ renameP (reverseP perm') (vs, as)
-- Andreas, 2013-02-26 add with-name to signature for printing purposes
- addConstant aux (Defn defaultArgInfo aux typeDontCare [] [] [] 0 noCompiledRep [] Nothing emptyFunction)
+ addConstant aux =<< do
+ useTerPragma $ Defn defaultArgInfo aux typeDontCare [] [] [] 0 noCompiledRep [] Nothing emptyFunction
-- Andreas, 2013-02-26 separate msgs to see which goes wrong
reportSDoc "tc.with.top" 20 $
@@ -607,17 +520,6 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
reportSDoc "tc.with.top" 20 $
text " body" <+> (addCtxTel delta $ prettyTCM $ mkBody v)
-{-
- reportSDoc "tc.with.top" 20 $ vcat
- [ text " with arguments" <+> do escapeContext (size delta2) $ prettyList (map prettyTCM vs)
- , text " types" <+> do escapeContext (size delta2) $ prettyList (map prettyTCM as)
- , text "with function call" <+> prettyTCM v
- , text " context" <+> (prettyTCM =<< getContextTelescope)
- , text " delta" <+> do escapeContext (size delta) $ prettyTCM delta
- , text " fv" <+> text (show fv)
- , text " body" <+> (addCtxTel delta $ prettyTCM $ mkBody v)
- ]
--}
gamma <- maybe (typeError $ NotImplemented "with clauses for functions with unfolding arity") return mgamma
return (mkBody v, WithFunction x aux gamma delta1 delta2 vs as t' ps perm' perm finalPerm cs)
in handleRHS rhs0
@@ -642,9 +544,7 @@ checkClause t c@(A.Clause (A.SpineLHS i x aps withPats) rhs0 wh) = do
, clauseBody = body
, clauseType = Just trhs
}
-{-
-checkClause t (A.Clause (A.LHS _ _ ps@(_ : _)) _ _) = typeError $ UnexpectedWithPatterns ps
--}
+
checkWithFunction :: WithFunctionProblem -> TCM ()
checkWithFunction NoWithFunction = return ()
@@ -674,6 +574,10 @@ checkWithFunction (WithFunction f aux gamma delta1 delta2 vs as b qs perm' perm
reportSLn "tc.with.top" 20 "created with display form"
-- Generate the type of the with function
+ delta1 <- normalise delta1 -- Issue 1332: checkInternal is picky about argInfo
+ -- but module application is sloppy.
+ -- We normalise to get rid of Def's coming
+ -- from module applications.
candidateType <- withFunctionType delta1 vs as delta2 b
reportSDoc "tc.with.type" 10 $ sep [ text "candidate type:", nest 2 $ prettyTCM candidateType ]
reportSDoc "tc.with.type" 50 $ sep [ text "candidate type:", nest 2 $ text $ show candidateType ]
@@ -720,7 +624,8 @@ checkWithFunction (WithFunction f aux gamma delta1 delta2 vs as b qs perm' perm
, prettyList $ map prettyTCM ts
, prettyTCM dt
]
- addConstant aux (Defn defaultArgInfo aux auxType [] [] [df] 0 noCompiledRep [] Nothing emptyFunction)
+ addConstant aux =<< do
+ useTerPragma $ Defn defaultArgInfo aux auxType [] [] [df] 0 noCompiledRep [] Nothing emptyFunction
-- solveSizeConstraints -- Andreas, 2012-10-16 does not seem necessary
reportSDoc "tc.with.top" 10 $ sep
@@ -773,21 +678,3 @@ containsAbsurdPattern p = case p of
A.ConP _ _ ps -> any (containsAbsurdPattern . namedArg) ps
A.DefP _ _ _ -> False -- projection pattern
A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- False
-
-{- UNUSED
-actualConstructor :: QName -> TCM QName
-actualConstructor c = do
--- v <- constructorForm =<< normalise (Con c [])
- v <- constructorForm =<< getConTerm c
- case ignoreSharing v of
- Con c _ -> return $ conName c
- _ -> actualConstructor =<< stripLambdas v
- where
- stripLambdas v = case ignoreSharing v of
- Con c _ -> return c
- Lam info b -> do
- x <- freshName_ $ absName b
- addCtx x (Dom info $ sort Prop) $
- stripLambdas (absBody b)
- _ -> typeError $ GenericError $ "Not a constructor: " ++ show c
--}
diff --git a/src/full/Agda/TypeChecking/Rules/Def.hs-boot b/src/full/Agda/TypeChecking/Rules/Def.hs-boot
index 88dfe4a..3fe562f 100644
--- a/src/full/Agda/TypeChecking/Rules/Def.hs-boot
+++ b/src/full/Agda/TypeChecking/Rules/Def.hs-boot
@@ -7,5 +7,7 @@ import Agda.TypeChecking.Monad
import qualified Agda.Syntax.Internal as I
checkFunDef :: Delayed -> DefInfo -> QName -> [Clause] -> TCM ()
-checkFunDef' :: I.Type -> I.ArgInfo -> Delayed -> Maybe (Int,Int) -> Maybe QName -> DefInfo -> QName -> [Clause]
- -> TCM ()
+
+checkFunDef' :: I.Type -> I.ArgInfo -> Delayed -> Maybe (Int,Int) -> Maybe QName -> DefInfo -> QName -> [Clause] -> TCM ()
+
+useTerPragma :: Definition -> TCM Definition
diff --git a/src/full/Agda/TypeChecking/Rules/LHS.hs b/src/full/Agda/TypeChecking/Rules/LHS.hs
index 8fc1914..ed8d0a8 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS.hs
@@ -2,18 +2,20 @@
module Agda.TypeChecking.Rules.LHS where
+import Prelude hiding (mapM)
+
import Data.Maybe
import Control.Applicative
-import Control.Monad
-import Control.Monad.State
+import Control.Monad hiding (mapM)
+import Control.Monad.State hiding (mapM)
import Data.Traversable
import Agda.Interaction.Options
import Agda.Interaction.Options.Lenses
-import Agda.Syntax.Internal as I
+import Agda.Syntax.Internal as I hiding (Substitution)
import Agda.Syntax.Internal.Pattern
import Agda.Syntax.Abstract (IsProjP(..))
import qualified Agda.Syntax.Abstract as A
@@ -51,7 +53,7 @@ import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Size
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Compute the set of flexible patterns in a list of patterns. The result is
@@ -103,28 +105,60 @@ dotPatternInsts ps s as = dpi (map namedArg ps) (reverse s) as
_ -> __IMPOSSIBLE__
-instantiatePattern :: Substitution -> Permutation -> [I.NamedArg Pattern] -> [I.NamedArg Pattern]
+
+-- | In an internal pattern, replace some pattern variables
+-- by dot patterns, according to the given substitution.
+instantiatePattern
+ :: Substitution
+ -- ^ Partial substitution for the pattern variables,
+ -- given in order of the clause telescope,
+ -- (not in the order of occurrence in the patterns).
+ -> Permutation
+ -- ^ Map from the pattern variables to the telescope variables.
+ -> [I.NamedArg Pattern]
+ -- ^ Input patterns.
+ -> [I.NamedArg Pattern]
+ -- ^ Output patterns, with some @VarP@ replaced by @DotP@
+ -- according to the @Substitution at .
instantiatePattern sub perm ps
- | length sub /= length hps = error $ unlines [ "instantiatePattern:"
- , " sub = " ++ show sub
- , " perm = " ++ show perm
- , " ps = " ++ show ps
- ]
+ | length sub /= length hps = error $ unlines
+ [ "instantiatePattern:"
+ , " sub = " ++ show sub
+ , " perm = " ++ show perm
+ , " ps = " ++ show ps
+ ]
| otherwise = foldr merge ps $ zipWith inst (reverse sub) hps
where
+ -- For each pattern variable get a copy of the patterns
+ -- focusing on this variable.
+ -- Order them in the dependency (telescope) order.
hps = permute perm $ allHoles ps
+ -- If we do not want to substitute a variable, we
+ -- throw away the corresponding one-hole pattern.
inst Nothing hps = Nothing
+ -- If we want to substitute, we replace the variable
+ -- by the dot pattern.
inst (Just t) hps = Just $ plugHole (DotP t) hps
+ -- If we did not instantiate a variable, we can keep the original
+ -- patterns in this iteration.
merge Nothing ps = ps
+ -- Otherwise, we merge the changes in @qs@ into @ps at .
+ -- This means we walk simultaneously through @qs@ and @ps@
+ -- and expect them to be the same everywhere except that
+ -- a @q@ can be a @DotP@ and the corresponding @p@ a @VarP at .
+ -- In this case, we take the @DotP at .
+ -- Apparently, the other way round can also happen (why?).
merge (Just qs) ps = zipWith mergeA qs ps
where
mergeA a1 a2 = fmap (mergeP (namedArg a1) (namedArg a2) <$) a1
mergeP (DotP s) (DotP t)
| s == t = DotP s
| otherwise = __IMPOSSIBLE__
+ -- interesting cases:
mergeP (DotP t) (VarP _) = DotP t
mergeP (VarP _) (DotP t) = DotP t
+ -- the rest is homomorphical
mergeP (DotP _) _ = __IMPOSSIBLE__
mergeP _ (DotP _) = __IMPOSSIBLE__
mergeP (ConP c1 mt1 ps) (ConP c2 mt2 qs)
@@ -148,6 +182,41 @@ instantiatePattern sub perm ps
mergeP ProjP{} _ = __IMPOSSIBLE__
mergeP _ ProjP{} = __IMPOSSIBLE__
+
+-- | In an internal pattern, replace some pattern variables
+-- by dot patterns, according to the given substitution.
+instantiatePattern'
+ :: Substitution
+ -- ^ Partial substitution for the pattern variables,
+ -- given in order of the clause telescope,
+ -- (not in the order of occurrence in the patterns).
+ -> Permutation
+ -- ^ Map from the pattern variables to the telescope variables.
+ -> [I.NamedArg Pattern]
+ -- ^ Input patterns.
+ -> [I.NamedArg Pattern]
+ -- ^ Output patterns, with some @VarP@ replaced by @DotP@
+ -- according to the @Substitution at .
+instantiatePattern' sub perm ps = evalState (mapM goArg ps) 0
+ where
+ -- get a partial substitution from pattern variables to terms
+ sub' = inversePermute perm sub
+ -- get next pattern variable
+ next = do n <- get; put (n+1); return n
+ goArg = traverse goNamed
+ goNamed = traverse goPat
+ goPat p = case p of
+ VarP x -> replace p
+ DotP t -> replace p
+ ConP c mt ps -> ConP c mt <$> mapM goArg ps
+ LitP{} -> return p
+ ProjP{} -> return p
+ replace p = do
+ i <- next
+ return $ fromMaybe p $ DotP <$> sub' !! i
+
+
+
-- | Check if a problem is solved. That is, if the patterns are all variables.
isSolvedProblem :: Problem -> Bool
isSolvedProblem problem = null (restPats $ problemRest problem) &&
@@ -159,13 +228,6 @@ isSolvedProblem problem = null (restPats $ problemRest problem) &&
isSolved (A.ImplicitP _) = True
isSolved (A.AbsurdP _) = True
isSolved _ = False
-{-
- isVar (A.VarP _) = True
- isVar (A.WildP _) = True
- isVar (A.ImplicitP _) = True
- isVar (A.AbsurdP _) = True
- isVar _ = False
--}
-- | For each user-defined pattern variable in the 'Problem', check
-- that the corresponding data type (if any) does not contain a
@@ -314,6 +376,16 @@ data LHSResult = LHSResult
, lhsPermutation :: Permutation -- ^ The permutation from pattern vars to @Δ@.
}
+instance InstantiateFull LHSResult where
+ instantiateFull' (LHSResult mtel tel sub xs ps t perm) = LHSResult
+ <$> instantiateFull' mtel
+ <*> instantiateFull' tel
+ <*> instantiateFull' sub
+ <*> return xs
+ <*> instantiateFull' ps
+ <*> instantiateFull' t
+ <*> return perm
+
-- | Check a LHS. Main function.
--
-- @checkLeftHandSide a ps a ret@ checks that user patterns @ps@ eliminate
@@ -333,33 +405,35 @@ checkLeftHandSide
-- ^ Continuation.
-> TCM a
checkLeftHandSide c f ps a ret = do
- problem <- problemFromPats ps a
+ problem0 <- problemFromPats ps a
-- Andreas, 2013-03-15 deactivating the following test allows
-- flexible arity
-- unless (noProblemRest problem) $ typeError $ TooManyArgumentsInLHS a
- let mgamma = if noProblemRest problem then Just $ problemTel problem else Nothing
+ let mgamma = if noProblemRest problem0 then Just $ problemTel problem0 else Nothing
-- doing the splits:
- LHSState (Problem ps (perm, qs) delta rest) sigma dpi asb
- <- checkLHS $ LHSState problem idS [] []
+ LHSState problem@(Problem ps (perm, qs) delta rest) sigma dpi asb
+ <- checkLHS f $ LHSState problem0 idS [] []
unless (null $ restPats rest) $ typeError $ TooManyArgumentsInLHS a
- let b' = restType rest
+ noShadowingOfConstructors c problem
noPatternMatchingOnCodata qs
reportSDoc "tc.lhs.top" 10 $
vcat [ text "checked lhs:"
- , nest 2 $ vcat
- [ text "ps = " <+> fsep (map prettyA ps)
- , text "perm = " <+> text (show perm)
- , text "delta = " <+> prettyTCM delta
- , text "dpi = " <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi)
- , text "asb = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb)
+ , nest 2 $ vcat
+ [ text "ps = " <+> fsep (map prettyA ps)
+ , text "perm = " <+> text (show perm)
+ , text "delta = " <+> prettyTCM delta
+ , text "dpi = " <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi)
+ , text "asb = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb)
, text "qs = " <+> text (show qs)
- ]
+ ]
]
+
+ let b' = restType rest
bindLHSVars (filter (isNothing . isProjP) ps) delta $ bindAsPatterns asb $ do
reportSDoc "tc.lhs.top" 10 $ text "bound pattern variables"
reportSDoc "tc.lhs.top" 10 $ nest 2 $ text "type = " <+> prettyTCM b'
@@ -368,338 +442,337 @@ checkLeftHandSide c f ps a ret = do
mapM_ checkDotPattern dpi
let rho = renamingR perm -- I'm not certain about this...
- Perm n _ = perm
- xs = [ stringToArgName $ "h" ++ show n | n <- [0..n - 1] ]
- applyRelevanceToContext (getRelevance b') $ do
- ret $ LHSResult mgamma delta rho xs qs b' perm
- where
- -- the loop: split at a variable in the problem until problem is solved
- checkLHS :: LHSState -> TCM LHSState
- checkLHS st@(LHSState problem sigma dpi asb) = do
- problem <- insertImplicitProblem problem -- inserting implicits no longer preserve solvedness
- if isSolvedProblem problem -- since we might insert eta expanded record patterns
- then do
- noShadowingOfConstructors c problem
- return $ st { lhsProblem = problem }
- else do
- unlessM (optPatternMatching <$> gets getPragmaOptions) $
- typeError $ GenericError $ "Pattern matching is disabled"
- sp <- splitProblem f problem
- reportSDoc "tc.lhs.split" 20 $ text "splitting completed"
- case sp of
- Left NothingToSplit -> do
- reportSLn "tc.lhs.split" 50 $ "checkLHS: nothing to split in problem " ++ show problem
- nothingToSplitError problem
- Left (SplitPanic err) -> do
- reportSLn "impossible" 10 $ "checkLHS: panic: " ++ err
- __IMPOSSIBLE__
-
- -- Split problem rest (projection pattern)
- Right (SplitRest projPat projType) -> do
-
- -- Compute the new problem
- let Problem ps1 (iperm, ip) delta (ProblemRest (p:ps2) b) = problem
- -- ps' = ps1 ++ [p]
- ps' = ps1 -- drop the projection pattern (already splitted)
- rest = ProblemRest ps2 (projPat $> projType)
- ip' = ip ++ [fmap (Named Nothing . ProjP) projPat]
- problem' = Problem ps' (iperm, ip') delta rest
- -- Jump the trampolin
- st' <- updateProblemRest (LHSState problem' sigma dpi asb)
- -- If the field is irrelevant, we need to continue in irr. cxt.
- -- (see Issue 939).
- applyRelevanceToContext (getRelevance projPat) $ do
- checkLHS st'
-
-
- -- Split on literal pattern
- Right (Split p0 xs (Arg _ (LitFocus lit iph hix a)) p1) -> do
-
- -- plug the hole with a lit pattern
- let ip = plugHole (LitP lit) iph
- iperm = expandP hix 0 $ fst (problemOutPat problem)
-
- -- substitute the literal in p1 and sigma and dpi and asb
- let delta1 = problemTel p0
- delta2 = absApp (fmap problemTel p1) (Lit lit)
- rho = liftS (size delta2) $ singletonS (Lit lit)
- -- rho = [ var i | i <- [0..size delta2 - 1] ]
- -- ++ [ raise (size delta2) $ Lit lit ]
- -- ++ [ var i | i <- [size delta2 ..] ]
- sigma' = applySubst rho sigma
- dpi' = applySubst rho dpi
- asb0 = applySubst rho asb
- ip' = applySubst rho ip
- rest' = applySubst rho (problemRest problem)
-
- -- Compute the new problem
- let ps' = problemInPat p0 ++ problemInPat (absBody p1)
- delta' = abstract delta1 delta2
- problem' = Problem ps' (iperm, ip') delta' rest'
- asb' = raise (size delta2) (map (\x -> AsB x (Lit lit) a) xs) ++ asb0
- st' <- updateProblemRest (LHSState problem' sigma' dpi' asb')
- checkLHS st'
-
- -- Split on constructor pattern
- Right (Split p0 xs (Arg info
- ( Focus { focusCon = c
- , focusImplicit = impl
- , focusConArgs = qs
- , focusRange = r
- , focusOutPat = iph
- , focusHoleIx = hix
- , focusDatatype = d
- , focusParams = vs
- , focusIndices = ws
- , focusType = a
- }
- )) p1
- ) -> traceCall (CheckPattern (A.ConP (ConPatInfo impl $ PatRange r) (A.AmbQ [c]) qs)
- (problemTel p0)
- (El Prop $ Def d $ map Apply $ vs ++ ws)) $ do
-
- let delta1 = problemTel p0
- let typeOfSplitVar = Arg info a
-
- reportSDoc "tc.lhs.split" 10 $ sep
- [ text "checking lhs"
- , nest 2 $ text "tel =" <+> prettyTCM (problemTel problem)
- , nest 2 $ text "rel =" <+> (text $ show $ argInfoRelevance info)
- ]
+ xs = [ stringToArgName $ "h" ++ show n | n <- [0..permRange perm - 1] ]
+ lhsResult <- return $ LHSResult mgamma delta rho xs qs b' perm
+ applyRelevanceToContext (getRelevance b') $ ret lhsResult
+
+-- | The loop (tail-recursive): split at a variable in the problem until problem is solved
+checkLHS
+ :: Maybe QName -- ^ The name of the definition we are checking.
+ -> LHSState -- ^ The current state.
+ -> TCM LHSState -- ^ The final state after all splitting is completed
+checkLHS f st@(LHSState problem sigma dpi asb) = do
+
+ problem <- insertImplicitProblem problem
+ -- Note: inserting implicits no longer preserve solvedness,
+ -- since we might insert eta expanded record patterns.
+ if isSolvedProblem problem then return $ st { lhsProblem = problem } else do
+
+ unlessM (optPatternMatching <$> gets getPragmaOptions) $
+ typeError $ GenericError $ "Pattern matching is disabled"
+
+ sp <- splitProblem f problem
+ reportSDoc "tc.lhs.split" 20 $ text "splitting completed"
+ case sp of
+ Left NothingToSplit -> do
+ reportSLn "tc.lhs.split" 50 $ "checkLHS: nothing to split in problem " ++ show problem
+ nothingToSplitError problem
+ Left (SplitPanic err) -> do
+ reportSLn "impossible" 10 $ "checkLHS: panic: " ++ err
+ __IMPOSSIBLE__
+
+ -- Split problem rest (projection pattern)
+ Right (SplitRest projPat projType) -> do
+
+ -- Compute the new problem
+ let Problem ps1 (iperm, ip) delta (ProblemRest (p:ps2) b) = problem
+ -- ps' = ps1 ++ [p]
+ ps' = ps1 -- drop the projection pattern (already splitted)
+ rest = ProblemRest ps2 (projPat $> projType)
+ ip' = ip ++ [fmap (Named Nothing . ProjP) projPat]
+ problem' = Problem ps' (iperm, ip') delta rest
+ -- Jump the trampolin
+ st' <- updateProblemRest (LHSState problem' sigma dpi asb)
+ -- If the field is irrelevant, we need to continue in irr. cxt.
+ -- (see Issue 939).
+ applyRelevanceToContext (getRelevance projPat) $ do
+ checkLHS f st'
+
+ -- Split on literal pattern
+ Right (Split p0 xs (Arg _ (LitFocus lit iph hix a)) p1) -> do
+
+ -- plug the hole with a lit pattern
+ let ip = plugHole (LitP lit) iph
+ iperm = expandP hix 0 $ fst (problemOutPat problem)
+
+ -- substitute the literal in p1 and sigma and dpi and asb
+ let delta1 = problemTel p0
+ delta2 = absApp (fmap problemTel p1) (Lit lit)
+ rho = liftS (size delta2) $ singletonS (Lit lit)
+ -- rho = [ var i | i <- [0..size delta2 - 1] ]
+ -- ++ [ raise (size delta2) $ Lit lit ]
+ -- ++ [ var i | i <- [size delta2 ..] ]
+ sigma' = applySubst rho sigma
+ dpi' = applySubst rho dpi
+ asb0 = applySubst rho asb
+ ip' = applySubst rho ip
+ rest' = applySubst rho (problemRest problem)
+
+ -- Compute the new problem
+ let ps' = problemInPat p0 ++ problemInPat (absBody p1)
+ delta' = abstract delta1 delta2
+ problem' = Problem ps' (iperm, ip') delta' rest'
+ asb' = raise (size delta2) (map (\x -> AsB x (Lit lit) a) xs) ++ asb0
+ st' <- updateProblemRest (LHSState problem' sigma' dpi' asb')
+ checkLHS f st'
+
+ -- Split on constructor pattern
+ Right (Split p0 xs (Arg info
+ ( Focus { focusCon = c
+ , focusImplicit = impl
+ , focusConArgs = qs
+ , focusRange = r
+ , focusOutPat = iph
+ , focusHoleIx = hix
+ , focusDatatype = d
+ , focusParams = vs
+ , focusIndices = ws
+ , focusType = a
+ }
+ )) p1
+ ) -> traceCall (CheckPattern (A.ConP (ConPatInfo impl $ PatRange r) (A.AmbQ [c]) qs)
+ (problemTel p0)
+ (El Prop $ Def d $ map Apply $ vs ++ ws)) $ do
+
+ let delta1 = problemTel p0
+ let typeOfSplitVar = Arg info a
+
+ reportSDoc "tc.lhs.split" 10 $ sep
+ [ text "checking lhs"
+ , nest 2 $ text "tel =" <+> prettyTCM (problemTel problem)
+ , nest 2 $ text "rel =" <+> (text $ show $ argInfoRelevance info)
+ ]
- reportSDoc "tc.lhs.split" 15 $ sep
- [ text "split problem"
- , nest 2 $ vcat
- [ text "delta1 = " <+> prettyTCM delta1
- , text "typeOfSplitVar =" <+> prettyTCM typeOfSplitVar
- , text "focusOutPat =" <+> (text . show) iph
- , text "delta2 = " <+> prettyTCM (problemTel $ absBody p1)
- ]
- ]
+ reportSDoc "tc.lhs.split" 15 $ sep
+ [ text "split problem"
+ , nest 2 $ vcat
+ [ text "delta1 = " <+> prettyTCM delta1
+ , text "typeOfSplitVar =" <+> prettyTCM typeOfSplitVar
+ , text "focusOutPat =" <+> (text . show) iph
+ , text "delta2 = " <+> prettyTCM (problemTel $ absBody p1)
+ ]
+ ]
{-
- c <- conSrcCon . theDef <$> getConstInfo c
- Con c' [] <- ignoreSharing <$> (constructorForm =<< normalise (Con c []))
- c <- return $ c' `withRangeOf` c
+ c <- conSrcCon . theDef <$> getConstInfo c
+ Con c' [] <- ignoreSharing <$> (constructorForm =<< normalise (Con c []))
+ c <- return $ c' `withRangeOf` c
-}
- c <- (`withRangeOf` c) <$> getConForm c
- ca <- defType <$> getConInfo c
+ c <- (`withRangeOf` c) <$> getConForm c
+ ca <- defType <$> getConInfo c
- reportSDoc "tc.lhs.split" 20 $ nest 2 $ vcat
- [ text "ca =" <+> prettyTCM ca
- , text "vs =" <+> prettyList (map prettyTCM vs)
- ]
+ reportSDoc "tc.lhs.split" 20 $ nest 2 $ vcat
+ [ text "ca =" <+> prettyTCM ca
+ , text "vs =" <+> prettyList (map prettyTCM vs)
+ ]
- -- Lookup the type of the constructor at the given parameters
- let a = ca `piApply` vs
+ -- Lookup the type of the constructor at the given parameters
+ let a = ca `piApply` vs
- -- It will end in an application of the datatype
- (gamma', ca, d', us) <- do
- TelV gamma' ca@(El _ def) <- telView a
- let Def d' es = ignoreSharing def
- Just us = allApplyElims es
- return (gamma', ca, d', us)
+ -- It will end in an application of the datatype
+ (gamma', ca, d', us) <- do
+ TelV gamma' ca@(El _ def) <- telView a
+ let Def d' es = ignoreSharing def
+ Just us = allApplyElims es
+ return (gamma', ca, d', us)
- -- This should be the same datatype as we split on
- unless (d == d') $ typeError $ ShouldBeApplicationOf ca d'
+ -- This should be the same datatype as we split on
+ unless (d == d') $ typeError $ ShouldBeApplicationOf ca d'
-{-
- reportSDoc "tc.lhs.top" 20 $ nest 2 $ vcat
- [ text "gamma' =" <+> text (show gamma')
- ]
--}
+ -- reportSDoc "tc.lhs.top" 20 $ nest 2 $ vcat
+ -- [ text "gamma' =" <+> text (show gamma')
+ -- ]
- -- Andreas 2010-09-07 propagate relevance info to new vars
- gamma' <- return $ fmap (applyRelevance $ argInfoRelevance info) gamma'
-{-
- reportSDoc "tc.lhs.top" 20 $ nest 2 $ vcat
- [ text "gamma' =" <+> text (show gamma')
- ]
--}
- -- Insert implicit patterns
- qs' <- insertImplicitPatterns ExpandLast qs gamma'
-
- unless (size qs' == size gamma') $
- typeError $ WrongNumberOfConstructorArguments (conName c) (size gamma') (size qs')
-
- let gamma = useNamesFromPattern qs' gamma'
-
- -- Get the type of the datatype.
- da <- (`piApply` vs) . defType <$> getConstInfo d
-
- -- Compute the flexible variables
- flex <- flexiblePatterns (problemInPat p0 ++ qs')
-
- -- Compute the constructor indices by dropping the parameters
- let us' = drop (size vs) us
-
- reportSDoc "tc.lhs.top" 15 $ addCtxTel delta1 $
- sep [ text "preparing to unify"
- , nest 2 $ vcat
- [ text "c =" <+> prettyTCM c <+> text ":" <+> prettyTCM a
- , text "d =" <+> prettyTCM d <+> text ":" <+> prettyTCM da
- , text "gamma =" <+> prettyTCM gamma
- , text "gamma' =" <+> prettyTCM gamma'
- , text "vs =" <+> brackets (fsep $ punctuate comma $ map prettyTCM vs)
- , text "us' =" <+> brackets (fsep $ punctuate comma $ map prettyTCM us')
- , text "ws =" <+> brackets (fsep $ punctuate comma $ map prettyTCM ws)
- ]
- ]
-
- -- Unify constructor target and given type (in Δ₁Γ)
- sub0 <- addCtxTel (delta1 `abstract` gamma) $
- unifyIndices_ flex (raise (size gamma) da) us' (raise (size gamma) ws)
-
- -- We should substitute c ys for x in Δ₂ and sigma
- let ys = teleArgs gamma
- delta2 = absApp (raise (size gamma) $ fmap problemTel p1) (Con c ys)
- rho0 = liftS (size delta2) $ Con c ys :# raiseS (size gamma)
- -- rho0 = [ var i | i <- [0..size delta2 - 1] ]
- -- ++ [ raise (size delta2) $ Con c ys ]
- -- ++ [ var i | i <- [size delta2 + size gamma ..] ]
- sigma0 = applySubst rho0 sigma
- dpi0 = applySubst rho0 dpi
- asb0 = applySubst rho0 asb
- rest0 = applySubst rho0 (problemRest problem)
-
- reportSDoc "tc.lhs.top" 15 $ addCtxTel (delta1 `abstract` gamma) $ nest 2 $ vcat
- [ text "delta2 =" <+> prettyTCM delta2
- , text "sub0 =" <+> brackets (fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) sub0)
- ]
- reportSDoc "tc.lhs.top" 15 $ addCtxTel (delta1 `abstract` gamma `abstract` delta2) $
- nest 2 $ vcat
- [ text "dpi0 = " <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi0)
- , text "asb0 = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb0)
- ]
-
- -- Andreas, 2010-09-09, save the type a of record pattern.
- -- It is relative to delta1, but it should be relative to
- -- all variables which will be bound by patterns.
- -- Thus, it has to be raised by 1 (the "hole" variable)
- -- plus the length of delta2 (the variables coming after the hole).
- storedPatternType <- ifM (isJust <$> isRecord d)
- (return $ Just (impl, raise (1 + size delta2) typeOfSplitVar))
- (return $ Nothing)
-
- -- Plug the hole in the out pattern with c ys
- let ysp = map (argFromDom . fmap (namedVarP . fst)) $ telToList gamma
- ip = plugHole (ConP c storedPatternType ysp) iph
- ip0 = applySubst rho0 ip
-
- -- Δ₁Γ ⊢ sub0, we need something in Δ₁ΓΔ₂
- -- Also needs to be padded with Nothing's to have the right length.
- let pad n xs x = xs ++ replicate (max 0 $ n - size xs) x
- newTel = problemTel p0 `abstract` (gamma `abstract` delta2)
- sub = replicate (size delta2) Nothing ++
- pad (size delta1 + size gamma) (raise (size delta2) sub0) Nothing
-
- reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
- [ text "newTel =" <+> prettyTCM newTel
- , addCtxTel newTel $ text "sub =" <+> brackets (fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) sub)
- , text "ip =" <+> text (show ip)
- , text "ip0 =" <+> text (show ip0)
- ]
- reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
- [ text "rho0 =" <+> text (show rho0)
+ -- Andreas 2010-09-07 propagate relevance info to new vars
+ -- Andreas 2014-11-25 clear 'Forced' and 'Unused'
+ let updRel = ignoreForced . composeRelevance (getRelevance info)
+ gamma' <- return $ mapRelevance updRel <$> gamma'
+
+ -- Insert implicit patterns
+ qs' <- insertImplicitPatterns ExpandLast qs gamma'
+
+ unless (size qs' == size gamma') $
+ typeError $ WrongNumberOfConstructorArguments (conName c) (size gamma') (size qs')
+
+ let gamma = useNamesFromPattern qs' gamma'
+
+ -- Get the type of the datatype.
+ da <- (`piApply` vs) . defType <$> getConstInfo d
+
+ -- Compute the flexible variables
+ flex <- flexiblePatterns (problemInPat p0 ++ qs')
+
+ -- Compute the constructor indices by dropping the parameters
+ let us' = drop (size vs) us
+
+ reportSDoc "tc.lhs.top" 15 $ addCtxTel delta1 $
+ sep [ text "preparing to unify"
+ , nest 2 $ vcat
+ [ text "c =" <+> prettyTCM c <+> text ":" <+> prettyTCM a
+ , text "d =" <+> prettyTCM d <+> text ":" <+> prettyTCM da
+ , text "gamma =" <+> prettyTCM gamma
+ , text "gamma' =" <+> prettyTCM gamma'
+ , text "vs =" <+> brackets (fsep $ punctuate comma $ map prettyTCM vs)
+ , text "us' =" <+> brackets (fsep $ punctuate comma $ map prettyTCM us')
+ , text "ws =" <+> brackets (fsep $ punctuate comma $ map prettyTCM ws)
]
+ ]
+
+ -- Unify constructor target and given type (in Δ₁Γ)
+ sub0 <- addCtxTel (delta1 `abstract` gamma) $
+ unifyIndices_ flex (raise (size gamma) da) us' (raise (size gamma) ws)
+
+ -- We should substitute c ys for x in Δ₂ and sigma
+ let ys = teleArgs gamma
+ delta2 = absApp (raise (size gamma) $ fmap problemTel p1) (Con c ys)
+ rho0 = liftS (size delta2) $ Con c ys :# raiseS (size gamma)
+ -- rho0 = [ var i | i <- [0..size delta2 - 1] ]
+ -- ++ [ raise (size delta2) $ Con c ys ]
+ -- ++ [ var i | i <- [size delta2 + size gamma ..] ]
+ sigma0 = applySubst rho0 sigma
+ dpi0 = applySubst rho0 dpi
+ asb0 = applySubst rho0 asb
+ rest0 = applySubst rho0 (problemRest problem)
+
+ reportSDoc "tc.lhs.top" 15 $ addCtxTel (delta1 `abstract` gamma) $ nest 2 $ vcat
+ [ text "delta2 =" <+> prettyTCM delta2
+ , text "sub0 =" <+> brackets (fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) sub0)
+ ]
+ reportSDoc "tc.lhs.top" 15 $ addCtxTel (delta1 `abstract` gamma `abstract` delta2) $
+ nest 2 $ vcat
+ [ text "dpi0 = " <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi0)
+ , text "asb0 = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb0)
+ ]
+
+ -- Andreas, 2010-09-09, save the type a of record pattern.
+ -- It is relative to delta1, but it should be relative to
+ -- all variables which will be bound by patterns.
+ -- Thus, it has to be raised by 1 (the "hole" variable)
+ -- plus the length of delta2 (the variables coming after the hole).
+ storedPatternType <- ifM (isJust <$> isRecord d)
+ (return $ Just (impl, raise (1 + size delta2) typeOfSplitVar))
+ (return $ Nothing)
+
+ -- Plug the hole in the out pattern with c ys
+ let ysp = map (argFromDom . fmap (namedVarP . fst)) $ telToList gamma
+ ip = plugHole (ConP c storedPatternType ysp) iph
+ ip0 = applySubst rho0 ip
+
+ -- Δ₁Γ ⊢ sub0, we need something in Δ₁ΓΔ₂
+ -- Also needs to be padded with Nothing's to have the right length.
+ let pad n xs x = xs ++ replicate (max 0 $ n - size xs) x
+ newTel = problemTel p0 `abstract` (gamma `abstract` delta2)
+ sub = replicate (size delta2) Nothing ++
+ pad (size delta1 + size gamma) (raise (size delta2) sub0) Nothing
+
+ reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
+ [ text "newTel =" <+> prettyTCM newTel
+ , addCtxTel newTel $ text "sub =" <+> brackets (fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) sub)
+ , text "ip =" <+> text (show ip)
+ , text "ip0 =" <+> text (show ip0)
+ ]
+ reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
+ [ text "rho0 =" <+> text (show rho0)
+ ]
- -- Instantiate the new telescope with the given substitution
- (delta', perm, rho, instTypes) <- instantiateTel sub newTel
+ -- Instantiate the new telescope with the given substitution
+ (delta', perm, rho, instTypes) <- instantiateTel sub newTel
- reportSDoc "tc.lhs.inst" 12 $
- vcat [ sep [ text "instantiateTel"
- , nest 4 $ brackets $ fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) sub
- , nest 4 $ prettyTCM newTel
- ]
- , nest 2 $ text "delta' =" <+> prettyTCM delta'
- , nest 2 $ text "perm =" <+> text (show perm)
- , nest 2 $ text "itypes =" <+> fsep (punctuate comma $ map prettyTCM instTypes)
+ reportSDoc "tc.lhs.inst" 12 $
+ vcat [ sep [ text "instantiateTel"
+ , nest 4 $ brackets $ fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) sub
+ , nest 4 $ prettyTCM newTel
]
+ , nest 2 $ text "delta' =" <+> prettyTCM delta'
+ , nest 2 $ text "perm =" <+> text (show perm)
+ , nest 2 $ text "itypes =" <+> fsep (punctuate comma $ map prettyTCM instTypes)
+ ]
{- -- Andreas, 2010-09-09
- -- temporary error message to find non-id perms
- let sorted (Perm _ xs) = xs == List.sort xs
- unless (sorted (perm)) $ typeError $ GenericError $ "detected proper permutation " ++ show perm
+ -- temporary error message to find non-id perms
+ let sorted (Perm _ xs) = xs == List.sort xs
+ unless (sorted (perm)) $ typeError $ GenericError $ "detected proper permutation " ++ show perm
-}
- -- Compute the new dot pattern instantiations
- let ps0' = problemInPat p0 ++ qs' ++ problemInPat (absBody p1)
+ -- Compute the new dot pattern instantiations
+ let ps0' = problemInPat p0 ++ qs' ++ problemInPat (absBody p1)
- reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
- [ text "subst rho sub =" <+> brackets (fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) (applySubst rho sub))
- , text "ps0' =" <+> brackets (fsep $ punctuate comma $ map prettyA ps0')
- ]
+ reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
+ [ text "subst rho sub =" <+> brackets (fsep $ punctuate comma $ map (maybe (text "_") prettyTCM) (applySubst rho sub))
+ , text "ps0' =" <+> brackets (fsep $ punctuate comma $ map prettyA ps0')
+ ]
- newDpi <- dotPatternInsts ps0' (applySubst rho sub) instTypes
+ newDpi <- dotPatternInsts ps0' (applySubst rho sub) instTypes
- -- The final dpis and asbs are the new ones plus the old ones substituted by ρ
- let dpi' = applySubst rho dpi0 ++ newDpi
- asb' = applySubst rho $ asb0 ++ raise (size delta2) (map (\x -> AsB x (Con c ys) ca) xs)
+ -- The final dpis and asbs are the new ones plus the old ones substituted by ρ
+ let dpi' = applySubst rho dpi0 ++ newDpi
+ asb' = applySubst rho $ asb0 ++ raise (size delta2) (map (\x -> AsB x (Con c ys) ca) xs)
- reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
- [ text "dpi' = " <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi')
- , text "asb' = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb')
- ]
+ reportSDoc "tc.lhs.top" 15 $ nest 2 $ vcat
+ [ text "dpi' = " <+> brackets (fsep $ punctuate comma $ map prettyTCM dpi')
+ , text "asb' = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb')
+ ]
- -- Apply the substitution to the type
- let sigma' = applySubst rho sigma0
- rest' = applySubst rho rest0
+ -- Apply the substitution to the type
+ let sigma' = applySubst rho sigma0
+ rest' = applySubst rho rest0
- reportSDoc "tc.lhs.inst" 15 $
- nest 2 $ text "ps0 = " <+> brackets (fsep $ punctuate comma $ map prettyA ps0')
+ reportSDoc "tc.lhs.inst" 15 $
+ nest 2 $ text "ps0 = " <+> brackets (fsep $ punctuate comma $ map prettyA ps0')
- -- Permute the in patterns
- let ps' = permute perm ps0'
+ -- Permute the in patterns
+ let ps' = permute perm ps0'
- -- Compute the new permutation of the out patterns. This is the composition of
- -- the new permutation with the expansion of the old permutation to
- -- reflect the split.
- let perm' = expandP hix (size gamma) $ fst (problemOutPat problem)
- iperm' = perm `composeP` perm'
+ -- Compute the new permutation of the out patterns. This is the composition of
+ -- the new permutation with the expansion of the old permutation to
+ -- reflect the split.
+ let perm' = expandP hix (size gamma) $ fst (problemOutPat problem)
+ iperm' = perm `composeP` perm'
- -- Instantiate the out patterns
- let ip' = instantiatePattern sub perm' ip0
- newip = applySubst rho ip'
+ -- Instantiate the out patterns
+ let ip' = instantiatePattern sub perm' ip0
+ newip = applySubst rho ip'
- -- Construct the new problem
- let problem' = Problem ps' (iperm', newip) delta' rest'
+ -- Construct the new problem
+ let problem' = Problem ps' (iperm', newip) delta' rest'
- reportSDoc "tc.lhs.top" 12 $ sep
- [ text "new problem"
- , nest 2 $ vcat
- [ text "ps' = " <+> fsep (map prettyA ps')
- , text "delta' = " <+> prettyTCM delta'
- ]
- ]
+ reportSDoc "tc.lhs.top" 12 $ sep
+ [ text "new problem"
+ , nest 2 $ vcat
+ [ text "ps' = " <+> fsep (map prettyA ps')
+ , text "delta' = " <+> prettyTCM delta'
+ ]
+ ]
- reportSDoc "tc.lhs.top" 14 $ nest 2 $ vcat
- [ text "perm' =" <+> text (show perm')
- , text "iperm' =" <+> text (show iperm')
- ]
- reportSDoc "tc.lhs.top" 14 $ nest 2 $ vcat
- [ text "ip' =" <+> text (show ip')
- , text "newip =" <+> text (show newip)
- ]
+ reportSDoc "tc.lhs.top" 14 $ nest 2 $ vcat
+ [ text "perm' =" <+> text (show perm')
+ , text "iperm' =" <+> text (show iperm')
+ ]
+ reportSDoc "tc.lhs.top" 14 $ nest 2 $ vcat
+ [ text "ip' =" <+> text (show ip')
+ , text "newip =" <+> text (show newip)
+ ]
+
+ -- if rest type reduces,
+ -- extend the split problem by previously not considered patterns
+ st'@(LHSState problem'@(Problem ps' (iperm', ip') delta' rest')
+ sigma' dpi' asb')
+ <- updateProblemRest $ LHSState problem' sigma' dpi' asb'
+
+ reportSDoc "tc.lhs.top" 12 $ sep
+ [ text "new problem from rest"
+ , nest 2 $ vcat
+ [ text "ps' = " <+> fsep (map prettyA ps')
+ , text "delta' = " <+> prettyTCM delta'
+ , text "ip' =" <+> text (show ip')
+ , text "iperm' =" <+> text (show iperm')
+ ]
+ ]
+ -- Continue splitting
+ checkLHS f st'
- -- if rest type reduces,
- -- extend the split problem by previously not considered patterns
- st'@(LHSState problem'@(Problem ps' (iperm', ip') delta' rest')
- sigma' dpi' asb')
- <- updateProblemRest $ LHSState problem' sigma' dpi' asb'
-
- reportSDoc "tc.lhs.top" 12 $ sep
- [ text "new problem from rest"
- , nest 2 $ vcat
- [ text "ps' = " <+> fsep (map prettyA ps')
- , text "delta' = " <+> prettyTCM delta'
- , text "ip' =" <+> text (show ip')
- , text "iperm' =" <+> text (show iperm')
- ]
- ]
- -- Continue splitting
- checkLHS st'
--- Ensures that we are not performing pattern matching on codata.
+-- | Ensures that we are not performing pattern matching on codata.
noPatternMatchingOnCodata :: [I.NamedArg Pattern] -> TCM ()
noPatternMatchingOnCodata = mapM_ (check . namedArg)
diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs b/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs
index 3fb4cb0..c8b73d4 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.Rules.LHS.Implicit where
@@ -25,7 +25,7 @@ import Agda.TypeChecking.Rules.LHS.Problem
import Agda.Utils.Maybe
-#include "../../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Insert implicit patterns in a problem.
@@ -33,13 +33,13 @@ insertImplicitProblem :: Problem -> TCM Problem
insertImplicitProblem (Problem ps qs tel pr) = do
reportSDoc "tc.lhs.imp" 15 $
sep [ text "insertImplicits"
- , nest 2 $ text "ps = " <+> do brackets $ fsep $ punctuate comma $ map prettyA ps
- , nest 2 $ text "tel = " <+> prettyTCM tel
- ]
+ , nest 2 $ text "ps = " <+> do brackets $ fsep $ punctuate comma $ map prettyA ps
+ , nest 2 $ text "tel = " <+> prettyTCM tel
+ ]
ps' <- insertImplicitPatterns ExpandLast ps tel
reportSDoc "tc.lhs.imp" 15 $
sep [ text "insertImplicits finished"
- , nest 2 $ text "ps' = " <+> do brackets $ fsep $ punctuate comma $ map prettyA ps'
+ , nest 2 $ text "ps' = " <+> do brackets $ fsep $ punctuate comma $ map prettyA ps'
]
return $ Problem ps' qs tel pr
@@ -72,13 +72,17 @@ expandImplicitPattern' a p
return $ Just p'
| otherwise = return Nothing
+implicitP :: Named_ A.Pattern
implicitP = unnamed $ A.ImplicitP $ PatRange $ noRange
-- | Insert implicit patterns in a list of patterns.
-insertImplicitPatterns :: ExpandHidden -> [A.NamedArg A.Pattern] -> Telescope -> TCM [A.NamedArg A.Pattern]
-insertImplicitPatterns exh ps tel = insertImplicitPatternsT exh ps (telePi tel typeDontCare)
+insertImplicitPatterns :: ExpandHidden -> [A.NamedArg A.Pattern] ->
+ Telescope -> TCM [A.NamedArg A.Pattern]
+insertImplicitPatterns exh ps tel =
+ insertImplicitPatternsT exh ps (telePi tel typeDontCare)
-insertImplicitPatternsT :: ExpandHidden -> [A.NamedArg A.Pattern] -> Type -> TCM [A.NamedArg A.Pattern]
+insertImplicitPatternsT :: ExpandHidden -> [A.NamedArg A.Pattern] -> Type ->
+ TCM [A.NamedArg A.Pattern]
insertImplicitPatternsT DontExpandLast [] a = return []
insertImplicitPatternsT exh ps a = do
TelV tel b <- telViewUpTo' (-1) (not . visible) a
diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs b/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs
index 27b3f2b..cc05e25 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs
@@ -3,7 +3,7 @@
module Agda.TypeChecking.Rules.LHS.Instantiate where
import Agda.Syntax.Common
-import Agda.Syntax.Internal as I
+import Agda.Syntax.Internal as I hiding (Substitution)
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Views ( asView )
@@ -20,7 +20,7 @@ import Agda.Utils.List
import Agda.Utils.Permutation
import Agda.Utils.Size
-#include "../../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Instantiate a telescope with a substitution. Might reorder the telescope.
@@ -155,28 +155,28 @@ instantiateTel s tel = liftTCM $ do
mkSubst :: [Maybe Term] -> S.Substitution
mkSubst s = rho 0 s'
where s' = s
- rho i (Nothing : s) = var i :# rho (i + 1) s
- rho i (Just u : s) = u :# rho i s
- rho i [] = raiseS i
+ rho i (Nothing : s) = var i :# rho (i + 1) s
+ rho i (Just u : s) = u :# rho i s
+ rho i [] = raiseS i
-- | Produce a nice error message when splitting failed
nothingToSplitError :: Problem -> TCM a
nothingToSplitError (Problem ps _ tel pr) = splitError ps tel
where
- splitError [] EmptyTel = do
+ splitError [] EmptyTel = do
if null $ restPats pr then __IMPOSSIBLE__ else do
typeError $ GenericError $ "Arguments left we cannot split on. TODO: better error message"
- splitError (_:_) EmptyTel = __IMPOSSIBLE__
- splitError [] ExtendTel{} = __IMPOSSIBLE__
+ splitError (_:_) EmptyTel = __IMPOSSIBLE__
+ splitError [] ExtendTel{} = __IMPOSSIBLE__
splitError (p : ps) (ExtendTel a tel)
| isBad p = traceCall (CheckPattern (strip p) EmptyTel (unDom a)) $ case strip p of
- A.DotP _ e -> typeError $ UninstantiatedDotPattern e
- p -> typeError $ IlltypedPattern p (unDom a)
+ A.DotP _ e -> typeError $ UninstantiatedDotPattern e
+ p -> typeError $ IlltypedPattern p (unDom a)
| otherwise = underAbstraction a tel $ \tel -> splitError ps tel
where
- strip = snd . asView . namedArg
- isBad p = case strip p of
- A.DotP _ _ -> True
- A.ConP _ _ _ -> True
- A.LitP _ -> True
- _ -> False
+ strip = snd . asView . namedArg
+ isBad p = case strip p of
+ A.DotP _ _ -> True
+ A.ConP _ _ _ -> True
+ A.LitP _ -> True
+ _ -> False
diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs b/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs
index 140c186..1232dbe 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs
@@ -1,13 +1,13 @@
-- {-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
module Agda.TypeChecking.Rules.LHS.Problem where
-import Control.Monad.Error
-import Data.Monoid ( Monoid(mappend,mempty) )
+import Prelude hiding (null)
+
import Data.Foldable
import Data.Traversable
@@ -19,8 +19,10 @@ import Agda.Syntax.Internal.Pattern
import qualified Agda.Syntax.Abstract as A
import Agda.TypeChecking.Substitute as S
-import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Pretty hiding (empty)
+import Agda.Utils.Except ( Error(noMsg, strMsg) )
+import Agda.Utils.Null
import Agda.Utils.Permutation
type Substitution = [Maybe Term]
@@ -79,7 +81,7 @@ data Problem' p = Problem
-- | The permutation should permute @allHoles@ of the patterns to correspond to
-- the abstract patterns in the problem.
-type Problem = Problem' (Permutation, [I.NamedArg Pattern])
+type Problem = Problem' (Permutation, [I.NamedArg Pattern])
type ProblemPart = Problem' ()
-- | User patterns that could not be given a type yet.
@@ -127,15 +129,41 @@ data Focus
}
| LitFocus Literal OneHolePatterns Int Type
+-- | Result of 'splitProblem': Determines position for the next split.
data SplitProblem
- = Split ProblemPart [Name] (I.Arg Focus) (Abs ProblemPart)
- -- ^ Split on constructor pattern.
- -- The @[Name]@s give the as-bindings for the focus.
-
- | SplitRest { splitProjection :: I.Arg QName, splitRestType :: Type }
- -- ^ Split on projection pattern.
- -- The projection could be belonging to an irrelevant record field.
+ = -- | Split on constructor pattern.
+ Split
+ { splitLPats :: ProblemPart
+ -- ^ The typed user patterns left of the split position.
+ -- Invariant: @'problemRest' == empty at .
+ , splitAsNames :: [Name]
+ -- ^ The as-bindings for the focus.
+ , splitFocus :: I.Arg Focus
+ -- ^ How to split the variable at the split position.
+ , splitRPats :: Abs ProblemPart
+ -- ^ The typed user patterns right of the split position.
+ }
+
+ | -- | Split on projection pattern.
+ SplitRest
+ { splitProjection :: I.Arg QName
+ -- ^ The projection could be belonging to an irrelevant record field.
+ , splitRestType :: Type
+ }
+
+-- | Put a typed pattern on the very left of a @SplitProblem at .
+consSplitProblem
+ :: A.NamedArg A.Pattern -- ^ @p@ A pattern.
+ -> ArgName -- ^ @x@ The name of the argument (from its type).
+ -> I.Dom Type -- ^ @t@ Its type.
+ -> SplitProblem -- ^ The split problem, containing 'splitLPats' @ps;xs:ts at .
+ -> SplitProblem -- ^ The result, now containing 'splitLPats' @(p,ps);(x,xs):(t,ts)@.
+consSplitProblem p x dom s at SplitRest{} = s
+consSplitProblem p x dom s at Split{ splitLPats = ps } = s{ splitLPats = consProblem' ps }
+ where
+ consProblem' (Problem ps () tel pr) =
+ Problem (p:ps) () (ExtendTel dom $ Abs x tel) pr
data SplitError
= NothingToSplit
@@ -183,16 +211,11 @@ instance Error SplitError where
noMsg = NothingToSplit
strMsg = SplitPanic
--- | 'ProblemRest' is a right dominant monoid.
--- @pr1 \`mappend\` pr2 = pr2@ unless @pr2 = mempty@, then it is @pr1 at .
--- Basically, this means that the left 'ProblemRest' is discarded, so
--- use it wisely!
-instance Monoid ProblemRest where
- mempty = ProblemRest [] (defaultArg typeDontCare)
- mappend pr (ProblemRest [] _) = pr
- mappend _ pr = pr
-
-instance Monoid p => Monoid (Problem' p) where
- mempty = Problem [] mempty EmptyTel mempty
- Problem ps1 qs1 tel1 pr1 `mappend` Problem ps2 qs2 tel2 pr2 =
- Problem (ps1 ++ ps2) (mappend qs1 qs2) (abstract tel1 tel2) (mappend pr1 pr2)
+instance Null ProblemRest where
+ null = null . restPats
+ empty = ProblemRest { restPats = [], restType = defaultArg typeDontCare }
+
+instance Null a => Null (Problem' a) where
+ null p = null (problemInPat p) && null (problemRest p)
+ empty = Problem empty empty empty empty
+
diff --git a/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs b/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs
index 850cf48..272cff9 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Rules.LHS.ProblemRest where
@@ -19,7 +19,7 @@ import Agda.Utils.Functor (($>))
import Agda.Utils.Size
import Agda.Utils.Permutation
-#include "../../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- MOVED from LHS:
diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Split.hs b/src/full/Agda/TypeChecking/Rules/LHS/Split.hs
index 8b077ea..054f434 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS/Split.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS/Split.hs
@@ -1,18 +1,22 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Agda.TypeChecking.Rules.LHS.Split where
+module Agda.TypeChecking.Rules.LHS.Split
+ ( splitProblem
+ ) where
-import Control.Applicative
-import Control.Monad.Error
+import Prelude hiding (null)
+
+import Control.Applicative hiding (empty)
+import Control.Monad.Trans ( lift )
import Data.Maybe (fromMaybe)
-import Data.Monoid (mempty, mappend)
-import Data.List
+import Data.List hiding (null)
import Data.Traversable hiding (mapM, sequence)
import Agda.Interaction.Options
+import Agda.Interaction.Highlighting.Generate (storeDisambiguatedName)
import Agda.Syntax.Common
import Agda.Syntax.Literal
@@ -34,22 +38,29 @@ import Agda.TypeChecking.Free
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Patterns.Abstract
-import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Pretty hiding (empty)
import Agda.TypeChecking.Records
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Rules.LHS.Problem
+import Agda.Utils.Except
+ ( ExceptT
+ , MonadError(throwError)
+ , runExceptT
+ )
+
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.Tuple
import qualified Agda.Utils.Pretty as P
-#include "../../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Split a problem at the first constructor pattern which is
@@ -74,11 +85,11 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
, nest 2 $ text "perm =" <+> prettyTCM perm
, nest 2 $ text "tel =" <+> prettyTCM tel
]
- runErrorT $
+ runExceptT $
splitP ps (permute perm $ zip [0..] $ allHoles qs) tel
where
-- Result splitting
- splitRest :: ProblemRest -> ErrorT SplitError TCM SplitProblem
+ splitRest :: ProblemRest -> ExceptT SplitError TCM SplitProblem
splitRest (ProblemRest (p : ps) b) | Just f <- mf = do
let failure = lift $ typeError $ CannotEliminateWithPattern p $ unArg b
notProjP = lift $ typeError $ NotAProjectionPattern p
@@ -104,22 +115,6 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
-- It could be a meta, but since we cannot postpone lhs checking, we crash here.
caseMaybeM (lift $ isRecordType $ unArg b) notRecord $ \(r, vs, def) -> case def of
Record{ recFields = fs } -> do
- {- NO LONGER NEEDED, BUT KEEP
- -- normalize projection name (could be from a module app)
- d <- lift $ do
- v <- stripLambdas =<< normalise (Def d [])
- case v of
- Def d _ -> return d
- _ -> do
- reportSDoc "impossible" 10 $ sep
- [ text "unexpected result " <+> prettyTCM v
- , text $ "when normalizing projection " ++ show d
- ]
- reportSDoc "impossible" 50 $ sep
- [ text $ "raw: " ++ show v
- ]
- __IMPOSSIBLE__
- -}
lift $ reportSDoc "tc.lhs.split" 20 $ sep
[ text $ "we are of record type r = " ++ show r
, text "applied to parameters vs = " <+> prettyTCM vs
@@ -135,7 +130,7 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
let self = defaultArg $ Def f (map Apply fvs) `applyE` es
-- get the type of projection d applied to "self"
dType <- lift $ defType <$> getConstInfo d -- full type!
- -- dType <- lift $ typeOfConst d -- WRONG: we apply to parameters ourselves!!
+
lift $ reportSDoc "tc.lhs.split" 20 $ sep
[ text "we are self = " <+> prettyTCM (unArg self)
, text "being projected by dType = " <+> prettyTCM dType
@@ -145,66 +140,73 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
-- if there are no more patterns left in the problem rest, there is nothing to split:
splitRest _ = throwError $ NothingToSplit
- -- Stripping initial lambdas from a normalized term
- stripLambdas :: Term -> TCM Term
- stripLambdas v = case ignoreSharing v of
- Lam _ b -> addContext (absName b) $ stripLambdas (absBody b)
- v -> return v
-
-- | In @splitP aps iqs tel@,
-- @aps@ are the user patterns on which we are splitting (inPats),
-- @ips@ are the one-hole patterns of the current split state (outPats)
-- in one-to-one correspondence with the pattern variables
-- recorded in @tel at .
- splitP :: [A.NamedArg A.Pattern] -> [(Int, OneHolePatterns)] -> Telescope -> ErrorT SplitError TCM SplitProblem
+ splitP :: [A.NamedArg A.Pattern]
+ -> [(Int, OneHolePatterns)]
+ -> Telescope
+ -> ExceptT SplitError TCM SplitProblem
+
-- the next two cases violate the one-to-one correspondence of qs and tel
- splitP _ [] (ExtendTel _ _) = __IMPOSSIBLE__
- splitP _ (_:_) EmptyTel = __IMPOSSIBLE__
+ splitP _ [] (ExtendTel _ _) = __IMPOSSIBLE__
+ splitP _ (_:_) EmptyTel = __IMPOSSIBLE__
-- no more patterns? pull them from the rest
- splitP [] _ _ = splitRest pr
+ splitP [] _ _ = splitRest pr
-- patterns but no types for them? Impossible.
- splitP ps [] EmptyTel = __IMPOSSIBLE__
+ splitP ps [] EmptyTel = __IMPOSSIBLE__
+ -- (we can never have an ExtendTel without Abs)
+ splitP _ _ (ExtendTel _ NoAbs{}) = __IMPOSSIBLE__
+
-- pattern with type? Let's get to work:
- splitP (p : ps) ((i, q) : qs) tel0@(ExtendTel a tel) = do
+ splitP ps0@(p : ps) qs0@((i, q) : qs) tel0@(ExtendTel dom@(Dom ai a) xtel@(Abs x tel)) = do
+
liftTCM $ reportSDoc "tc.lhs.split" 30 $ sep
[ text "splitP looking at pattern"
- , nest 2 $ text "p =" <+> prettyA p
- , nest 2 $ text "a =" <+> prettyTCM a
+ , nest 2 $ text "p =" <+> prettyA p
+ , nest 2 $ text "dom =" <+> prettyTCM dom
]
- let tryAgain = splitP (p : ps) ((i, q) : qs) tel0
+
+ -- Possible reinvokations:
+ let -- 1. Redo this argument (after meta instantiation).
+ tryAgain = splitP ps0 qs0 tel0
+ -- 2. Try to split on next argument.
+ keepGoing = consSplitProblem p x dom <$> do
+ underAbstraction dom xtel $ \ tel -> splitP ps qs tel
+
p <- lift $ expandLitPattern p
case asView $ namedArg p of
-- Case: projection pattern. That's an error.
- --(_, p') | Just{} <- isProjP p' -> do
(_, A.DefP _ d ps) -> typeError $
if null ps
then CannotEliminateWithPattern p (telePi tel0 $ unArg $ restType pr)
else IllformedProjectionPattern $ namedArg p
- -- Case: literal pattern
- (xs, p@(A.LitP lit)) -> do
+
+ -- Case: literal pattern.
+ (xs, p@(A.LitP lit)) -> do
-- Note that, in the presence of --without-K, this branch is
-- based on the assumption that the types of literals are
-- not indexed.
-- Andreas, 2010-09-07 cannot split on irrelevant args
- when (unusableRelevance $ getRelevance a) $
- typeError $ SplitOnIrrelevant p a
- b <- lift $ litType lit
- ok <- lift $ do
- noConstraints (equalType (unDom a) b)
- return True
- `catchError` \_ -> return False
- if ok
- then return $
- Split mempty
- xs
- (argFromDom $ fmap (LitFocus lit q i) a)
- (fmap (\ tel -> Problem ps () tel __IMPOSSIBLE__) tel)
- else keepGoing
-
- -- Case: constructor pattern
- (xs, p@(A.ConP ci (A.AmbQ cs) args)) -> do
+ when (unusableRelevance $ getRelevance ai) $
+ typeError $ SplitOnIrrelevant p dom
+
+ -- Succeed if the split type is (already) equal to the type of the literal.
+ ifNotM (lift $ tryConversion $ equalType a =<< litType lit)
+ {- then -} keepGoing $
+ {- else -} return $ Split
+ { splitLPats = empty
+ , splitAsNames = xs
+ , splitFocus = Arg ai $ LitFocus lit q i a
+ , splitRPats = Abs x $ Problem ps () tel __IMPOSSIBLE__
+ }
+
+ -- Case: constructor pattern.
+ (xs, p@(A.ConP ci (A.AmbQ cs) args)) -> do
let tryInstantiate a'
| [c] <- cs = do
-- Type is blocked by a meta and constructor is unambiguous,
@@ -214,24 +216,27 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
dt <- defType <$> getConstInfo d
vs <- newArgsMeta dt
Sort s <- ignoreSharing . unEl <$> reduce (apply dt vs)
- (True <$ noConstraints (equalType a' (El s $ Def d $ map Apply vs)))
- `catchError` \_ -> return False
+ tryConversion $ equalType a' (El s $ Def d $ map Apply vs)
if ok then tryAgain else keepGoing
| otherwise = keepGoing
-- ifBlockedType reduces the type
- ifBlockedType (unDom a) (const tryInstantiate) $ \ a' -> do
- case ignoreSharing $ unEl a' of
+ ifBlockedType a (const tryInstantiate) $ \ a' -> do
+ case ignoreSharing $ unEl a' of
- -- Subcase: split type is a Def
- Def d es -> do
- def <- liftTCM $ theDef <$> getConstInfo d
+ -- Subcase: split type is a Def.
+ Def d es -> do
+
+ def <- liftTCM $ theDef <$> getConstInfo d
+
+ -- We cannot split on (shape-)irrelevant non-records.
+ -- Andreas, 2011-10-04 unless allowed by option
unless (defIsRecord def) $
- -- cannot split on irrelevant or non-strict things
- when (unusableRelevance $ getRelevance a) $ do
- -- Andreas, 2011-10-04 unless allowed by option
- allowed <- liftTCM $ optExperimentalIrrelevance <$> pragmaOptions
- unless allowed $ typeError $ SplitOnIrrelevant p a
+ when (unusableRelevance $ getRelevance ai) $
+ unlessM (liftTCM $ optExperimentalIrrelevance <$> pragmaOptions) $
+ typeError $ SplitOnIrrelevant p dom
+ -- Check that we are at record or data type and return
+ -- the number of parameters.
let mp = case def of
Datatype{dataPars = np} -> Just np
Record{recPars = np} -> Just np
@@ -240,7 +245,7 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
Nothing -> keepGoing
Just np -> do
let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- liftTCM $ traceCall (CheckPattern p EmptyTel (unDom a)) $ do -- TODO: wrong telescope
+ liftTCM $ traceCall (CheckPattern p EmptyTel a) $ do -- TODO: wrong telescope
-- Check that we construct something in the right datatype
c <- do
cs' <- mapM canonicalName cs
@@ -251,23 +256,23 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
_ -> __IMPOSSIBLE__
cs0 <- cons <$> getConstInfo d'
case [ c | (c, c') <- zip cs cs', elem c' cs0 ] of
- [c] -> return c
+ [c] -> do
+ -- If constructor pattern was ambiguous,
+ -- remember our choice for highlighting info.
+ when (length cs >= 2) $ storeDisambiguatedName c
+ return c
[] -> typeError $ ConstructorPatternInWrongDatatype (head cs) d
cs -> -- if there are more than one we give up (they might have different types)
typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d cs
-{-
- typeError $ GenericError $
- "Can't resolve overloaded constructors targeting the same datatype (" ++ show d ++ "):" ++
- unwords (map show cs)
--}
- let (pars, ixs) = genericSplitAt np vs
- reportSDoc "tc.lhs.split" 10 $
- vcat [ sep [ text "splitting on"
- , nest 2 $ fsep [ prettyA p, text ":", prettyTCM a ]
- ]
- , nest 2 $ text "pars =" <+> fsep (punctuate comma $ map prettyTCM pars)
- , nest 2 $ text "ixs =" <+> fsep (punctuate comma $ map prettyTCM ixs)
- ]
+
+ let (pars, ixs) = genericSplitAt np vs
+ reportSDoc "tc.lhs.split" 10 $ vcat
+ [ sep [ text "splitting on"
+ , nest 2 $ fsep [ prettyA p, text ":", prettyTCM dom ]
+ ]
+ , nest 2 $ text "pars =" <+> fsep (punctuate comma $ map prettyTCM pars)
+ , nest 2 $ text "ixs =" <+> fsep (punctuate comma $ map prettyTCM ixs)
+ ]
-- Andreas, 2013-03-22 fixing issue 279
-- To resolve ambiguous constructors, Agda always looks up
@@ -281,31 +286,18 @@ splitProblem mf (Problem ps (perm, qs) tel pr) = do
-- but the extra check here is non-invasive to the existing code.
checkParsIfUnambiguous cs d pars
- --whenM (optWithoutK <$> pragmaOptions) $
- -- wellFormedIndices a'
-
- return $ Split mempty
- xs
- (argFromDom $ fmap (Focus c (A.patImplicit ci) args (getRange p) q i d pars ixs) a)
- (fmap (\ tel -> Problem ps () tel __IMPOSSIBLE__) tel)
- -- Subcase: split type is not a Def
- _ -> keepGoing
- -- Case: neither literal nor constructor pattern
- p -> keepGoing
- where
- keepGoing = do
- r <- underAbstraction a tel $ \tel -> splitP ps qs tel
- case r of
- SplitRest{} -> return r
- Split p1 xs foc p2 -> do
- let p0 = Problem [p] () (ExtendTel a (EmptyTel <$ tel)) mempty
- return $ Split (mappend p0 p1) xs foc p2
-{- OLD
- keepGoing = do
- let p0 = Problem [p] () (ExtendTel a (EmptyTel <$ tel)) mempty
- Split p1 xs foc p2 <- underAbstraction a tel $ \tel -> splitP ps qs tel
- return $ Split (mappend p0 p1) xs foc p2
--}
+ return $ Split
+ { splitLPats = empty
+ , splitAsNames = xs
+ , splitFocus = Arg ai $ Focus c (A.patImplicit ci) args (getRange p) q i d pars ixs a
+ , splitRPats = Abs x $ Problem ps () tel __IMPOSSIBLE__
+ }
+ -- Subcase: split type is not a Def.
+ _ -> keepGoing
+
+ -- Case: neither literal nor constructor pattern.
+ _ -> keepGoing
+
-- | @checkParsIfUnambiguous [c] d pars@ checks that the data/record type
-- behind @c@ is has initial parameters (coming e.g. from a module instantiation)
@@ -327,150 +319,3 @@ checkParsIfUnambiguous [c] d pars = do
compareArgs [] t (Def d []) vs (take (length vs) pars)
_ -> __IMPOSSIBLE__
checkParsIfUnambiguous _ _ _ = return ()
-
--- | Takes a type, which must be a data or record type application,
--- and checks that the indices are constructors (or literals) applied
--- to distinct variables which do not occur free in the parameters.
--- For the purposes of this check parameters count as constructor
--- arguments; parameters are reconstructed from the given type.
---
--- Precondition: The type must be a data or record type application.
-
-wellFormedIndices :: Type -> TCM ()
-wellFormedIndices t = do
- t <- reduce t
-
- reportSDoc "tc.lhs.split.well-formed" 10 $
- fsep [ text "Checking if indices are well-formed:"
- , nest 2 $ prettyTCM t
- ]
-
- (pars, ixs) <- normalise =<< case ignoreSharing $ unEl t of
- Def d es -> do
- let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- def <- getConstInfo d
- typedArgs <- args `withTypesFrom` defType def
-
-{- OLD
- let noPars = case theDef def of
- Datatype { dataPars = n } -> n
- Record { recPars = n } -> n
- _ -> __IMPOSSIBLE__
- (pars, ixs) = genericSplitAt noPars typedArgs
- return (map fst pars, ixs)
--}
- -- Andreas, 2013-05-30:
- -- 1. treat non-linear parameters as indices
- -- 2. ignore big parameters
- let (noPars, smallPars, nonLinPars) = case theDef def of
- Datatype { dataPars = n, dataSmallPars = Perm _ sps, dataNonLinPars = nl }
- -> (n, sps, permPicks $ doDrop nl)
- Record { recPars = n } -> (n, [0..n-1], []) -- TODO: smallness for record pars
- _ -> __IMPOSSIBLE__
- (pars0, ixs0) = genericSplitAt noPars typedArgs
- -- Andreas, 2013-05-30 take only the small parameters
- pars = map (pars0 !!) (smallPars \\ nonLinPars)
- -- add the non-linear parameters to the indices
- ixs = map (pars0 !!) nonLinPars ++ ixs0
- return (map fst pars, ixs)
-
- _ -> __IMPOSSIBLE__
-
- mvs <- constructorApplications ixs
- vs <- case mvs of
- Nothing -> typeError $
- IndicesNotConstructorApplications (map fst ixs)
- Just vs -> return vs
-
- unless (fastDistinct vs) $
- typeError $ IndexVariablesNotDistinct vs (map fst ixs)
-
- case map fst $ filter snd $ zip vs (map (`freeIn` pars) vs) of
- [] -> return ()
- vs ->
- typeError $ IndicesFreeInParameters vs (map fst ixs) pars
-
- where
- -- | If the term consists solely of constructors (or literals)
- -- applied to variables (after parameter reconstruction), then the
- -- variables are returned, and otherwise nothing.
- constructorApplication :: Term
- -> Type -- ^ The term's type.
- -> TCM (Maybe [Nat])
- constructorApplication (Var x []) _ = return (Just [x])
- constructorApplication (Lit {}) _ = return (Just [])
- constructorApplication (Shared p) t = constructorApplication (derefPtr p) t
- constructorApplication (Con c conArgs) (El _ (Def d es)) = do
- let dataArgs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es
- conDef <- getConInfo c
- dataDef <- getConstInfo d
-
-{- OLD
- let noPars = case theDef dataDef of
- Datatype { dataPars = n } -> n
- Record { recPars = n } -> n
- _ -> __IMPOSSIBLE__
- pars = genericTake noPars dataArgs
- allArgs = pars ++ conArgs
-
- reportSDoc "tc.lhs.split.well-formed" 20 $
- fsep [ text "Reconstructed parameters:"
- , nest 2 $
- prettyTCM (Con c []) <+>
- text "(:" <+> prettyTCM (defType conDef) <> text ")" <+>
- text "<<" <+> prettyTCM pars <+> text ">>" <+>
- prettyTCM conArgs
- ]
-
- constructorApplications =<< allArgs `withTypesFrom` defType conDef
--}
-
- let (noPars, smallPars) = case theDef dataDef of
- Datatype { dataPars = n, dataSmallPars = Perm _ is }
- -> (n, is)
- Record { recPars = n } -> (n, [0..n-1])
- _ -> __IMPOSSIBLE__
-
- dataPars = take noPars dataArgs
-
- allArgs <- (dataPars ++ conArgs) `withTypesFrom` defType conDef
-
- -- skip big parameters during reconstruction
- let ixs = drop noPars allArgs
- pars = map (allArgs !!) smallPars
-
- reportSDoc "tc.lhs.split.well-formed" 20 $
- fsep [ text "Reconstructed parameters:"
- , nest 2 $
- prettyTCM (Con c []) <+>
- text "(:" <+> prettyTCM (defType conDef) <> text ")" <+>
- text "<<" <+> prettyTCM (map fst pars) <+> text ">>" <+>
- prettyTCM conArgs
- ]
-
- constructorApplications $ pars ++ ixs
-
- constructorApplication _ _ = return Nothing
-
- constructorApplications :: [(I.Arg Term, I.Dom Type)] -> TCM (Maybe [Nat])
- constructorApplications args = do
- xs <- mapM (\(e, t) -> do
- t <- reduce (unDom t)
- constructorApplication (unArg e) (ignoreSharingType t))
- args
- return (concat <$> sequence xs)
-
--- | @args \`withTypesFrom\` t@ returns the arguments @args@ paired up
--- with their types, taken from @t@, which is assumed to be a @length
--- args at -ary pi.
---
--- Precondition: @t@ has to start with @length args@ pis.
-
-withTypesFrom :: Args -> Type -> TCM [(I.Arg Term, I.Dom Type)]
-[] `withTypesFrom` _ = return []
-(arg : args) `withTypesFrom` t = do
- t <- reduce t
- case ignoreSharing $ unEl t of
- Pi a b -> ((arg, a) :) <$>
- args `withTypesFrom` absApp b (unArg arg)
- _ -> __IMPOSSIBLE__
diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs b/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs
index afd9118..e2a9166 100644
--- a/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs
+++ b/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs
@@ -1,27 +1,30 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.Rules.LHS.Unify where
+import Prelude hiding (null)
+
import Control.Arrow ((***))
import Control.Applicative hiding (empty)
import Control.Monad.State
import Control.Monad.Reader
-import Control.Monad.Error
import Control.Monad.Writer (WriterT(..), MonadWriter(..), Monoid(..))
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.List hiding (sort)
+import Data.List hiding (null, sort)
import Data.Typeable (Typeable)
import Data.Foldable (Foldable)
@@ -30,7 +33,7 @@ import Data.Traversable (Traversable,traverse)
import Agda.Interaction.Options (optInjectiveTypeConstructors)
import Agda.Syntax.Common
-import Agda.Syntax.Internal as I
+import Agda.Syntax.Internal as I hiding (Substitution)
import Agda.Syntax.Literal
import Agda.Syntax.Position
@@ -42,7 +45,8 @@ import Agda.TypeChecking.Constraints
import Agda.TypeChecking.DropArgs
import Agda.TypeChecking.Level (reallyUnLevelView)
import Agda.TypeChecking.Reduce
-import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Pretty hiding (empty)
+import qualified Agda.TypeChecking.Pretty as P
import Agda.TypeChecking.Substitute hiding (Substitution)
import qualified Agda.TypeChecking.Substitute as S
import Agda.TypeChecking.Telescope
@@ -55,11 +59,17 @@ import Agda.Interaction.Options (optInjectiveTypeConstructors, optWithoutK)
import Agda.TypeChecking.Rules.LHS.Problem
-- import Agda.TypeChecking.SyntacticEquality
+import Agda.Utils.Except
+ ( Error(noMsg, strMsg)
+ , MonadError(catchError, throwError)
+ )
+
import Agda.Utils.Maybe
-import Agda.Utils.Size
import Agda.Utils.Monad
+import Agda.Utils.Null
+import Agda.Utils.Size
-#include "../../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
newtype Unify a = U { unUnify :: ReaderT UnifyEnv (WriterT UnifyOutput (ExceptionT UnifyException (StateT UnifyState TCM))) a }
@@ -79,23 +89,25 @@ instance MonadReader TCEnv Unify where
instance HasConstInfo Unify where
getConstInfo = U . lift . lift . lift . lift . getConstInfo
+-- UnifyEnv
+------------------------------------------------------------------------
+
data UnifyMayPostpone = MayPostpone | MayNotPostpone
type UnifyEnv = UnifyMayPostpone
-emptyUEnv = MayPostpone
+
+emptyUEnv :: UnifyEnv
+emptyUEnv = MayPostpone
noPostponing :: Unify a -> Unify a
-noPostponing (U (ReaderT f)) = U . ReaderT . const $ f MayNotPostpone
+noPostponing = U . local (const MayNotPostpone) . unUnify
askPostpone :: Unify UnifyMayPostpone
-askPostpone = U . ReaderT $ return
+askPostpone = U $ ask
-- | Output the result of unification (success or maybe).
type UnifyOutput = Unifiable
-emptyUOutput :: UnifyOutput
-emptyUOutput = mempty
-
-- | Were two terms unifiable or did we have to postpone some equation such that we are not sure?
data Unifiable
= Definitely -- ^ Unification succeeded.
@@ -121,7 +133,7 @@ ifClean m t e = do
Possibly -> e
data Equality = Equal TypeHH Term Term
-type Sub = Map Nat Term
+type Sub = IntMap Term
data UnifyException
= ConstructorMismatch Type Term Term
@@ -134,11 +146,13 @@ instance Error UnifyException where
noMsg = strMsg ""
strMsg = GenericUnifyException
-data UnifyState = USt { uniSub :: Sub
- , uniConstr :: [Equality]
- }
+data UnifyState = USt
+ { uniSub :: Sub
+ , uniConstr :: [Equality]
+ }
-emptyUState = USt Map.empty []
+emptyUState :: UnifyState
+emptyUState = USt IntMap.empty []
-- | Throw-away error message.
projectionMismatch :: QName -> QName -> Unify a
@@ -156,8 +170,8 @@ instance Subst Equality where
applySubst rho (Equal a s t) =
Equal (applySubst rho a) (applySubst rho s) (applySubst rho t)
-onSub :: (Sub -> a) -> Unify a
-onSub f = U $ gets $ f . uniSub
+getSub :: Unify Sub
+getSub = U $ gets uniSub
modSub :: (Sub -> Sub) -> Unify ()
modSub f = U $ modify $ \s -> s { uniSub = f $ uniSub s }
@@ -246,19 +260,19 @@ occursCheck i u a = do
i |-> (u, a) = do
occursCheck i u a
liftTCM $ reportSDoc "tc.lhs.unify.assign" 15 $ prettyTCM (var i) <+> text ":=" <+> prettyTCM u
- modSub $ Map.insert i (killRange u)
+ modSub $ IntMap.insert i (killRange u)
-- Apply substitution to itself (issue 552)
- rho <- onSub id
+ rho <- getSub
rho' <- traverse ureduce rho
modSub $ const rho'
makeSubstitution :: Sub -> S.Substitution
makeSubstitution sub
- | Map.null sub = idS
- | otherwise = map val [0 .. highestIndex] ++# raiseS (highestIndex + 1)
+ | null sub = idS
+ | otherwise = map val [0 .. highestIndex] ++# raiseS (highestIndex + 1)
where
- highestIndex = fst $ Map.findMax sub
- val i = maybe (var i) id $ Map.lookup i sub
+ highestIndex = fst $ IntMap.findMax sub
+ val i = fromMaybe (var i) $ IntMap.lookup i sub
-- | Apply the current substitution on a term and reduce to weak head normal form.
class UReduce t where
@@ -266,7 +280,7 @@ class UReduce t where
instance UReduce Term where
ureduce u = doEtaContractImplicit $ do
- rho <- onSub makeSubstitution
+ rho <- makeSubstitution <$> getSub
-- Andreas, 2013-10-24 the following call to 'normalise' is problematic
-- (see issue 924). Instead, we only normalize if unifyAtomHH is undecided.
-- liftTCM $ etaContract =<< normalise (applySubst rho u)
@@ -329,13 +343,17 @@ flattenSubstitution s = foldr instantiate s is
instantiate :: Nat -> Substitution -> Substitution
instantiate i s = map (fmap $ inst i u) s
where
- Just u = s !! i
+ Just u = s !! i
+ -- @inst i u v@ replaces index @i@ in @v@ by @u@, without removing the index.
inst :: Nat -> Term -> Term -> Term
inst i u v = applySubst us v
where us = [var j | j <- [0..i - 1] ] ++# u :# raiseS (i + 1)
-data UnificationResult = Unifies Substitution | NoUnify Type Term Term | DontKnow TCErr
+data UnificationResult
+ = Unifies Substitution
+ | NoUnify Type Term Term
+ | DontKnow TCErr
-- | Are we in a homogeneous (one type) or heterogeneous (two types) situation?
data HomHet a
@@ -484,7 +502,7 @@ unifyIndices flex a us vs = liftTCM $ do
Right _ -> do
checkEqualities $ applySubst (makeSubstitution s) eqs
let n = maximum $ (-1) : flex'
- return $ Unifies $ flattenSubstitution [ Map.lookup i s | i <- [0..n] ]
+ return $ Unifies $ flattenSubstitution [ IntMap.lookup i s | i <- [0..n] ]
`catchError` \err -> case err of
TypeError _ (Closure {clValue = WithoutKError{}}) -> throwError err
_ -> return $ DontKnow err
@@ -513,9 +531,9 @@ unifyIndices flex a us vs = liftTCM $ do
unifyConstructorArgs a12 vs1 vs2 = do
liftTCM $ reportSDoc "tc.lhs.unify" 15 $ sep
[ text "unifyConstructorArgs"
- -- , nest 2 $ parens (prettyTCM tel0)
- , nest 2 $ prettyList $ map prettyTCM vs1
- , nest 2 $ prettyList $ map prettyTCM vs2
+ -- , nest 2 $ parens (prettyTCM tel0)
+ , nest 2 $ prettyList $ map prettyTCM vs1
+ , nest 2 $ prettyList $ map prettyTCM vs2
, nest 2 $ text "constructor type:" <+> prettyTCM a12
]
let n = genericLength vs1
@@ -540,10 +558,10 @@ unifyIndices flex a us vs = liftTCM $ do
unifyConArgs tel0@(ExtendTel a@(Dom _ bHH) tel) us0@(arg@(Arg _ u) : us) vs0@(Arg _ v : vs) = do
liftTCM $ reportSDoc "tc.lhs.unify" 15 $ sep
[ text "unifyConArgs"
- -- , nest 2 $ parens (prettyTCM tel0)
- , nest 2 $ prettyList $ map prettyTCM us0
- , nest 2 $ prettyList $ map prettyTCM vs0
- , nest 2 $ text "at telescope" <+> prettyTCM bHH <+> text "..."
+ -- , nest 2 $ parens (prettyTCM tel0)
+ , nest 2 $ prettyList $ map prettyTCM us0
+ , nest 2 $ prettyList $ map prettyTCM vs0
+ , nest 2 $ text "at telescope" <+> prettyTCM bHH <+> text "..."
]
liftTCM $ reportSDoc "tc.lhs.unify" 25 $
(text $ "tel0 = " ++ show tel0)
@@ -582,24 +600,24 @@ unifyIndices flex a us vs = liftTCM $ do
unifyElims a us0@(Apply arg@(Arg _ u) : us) vs0@(Apply (Arg _ v) : vs) = do
liftTCM $ reportSDoc "tc.lhs.unify" 15 $ sep
[ text "unifyElims"
- , nest 2 $ parens (prettyTCM a)
- , nest 2 $ prettyList $ map prettyTCM us0
- , nest 2 $ prettyList $ map prettyTCM vs0
+ , nest 2 $ parens (prettyTCM a)
+ , nest 2 $ prettyList $ map prettyTCM us0
+ , nest 2 $ prettyList $ map prettyTCM vs0
]
a <- ureduce a -- Q: reduce sufficient?
case ignoreSharing $ unEl a of
- Pi b _ -> do
+ Pi b _ -> do
-- Andreas, Ulf, 2011-09-08 (AIM XVI)
-- in case of dependent function type, we cannot postpone
-- unification of u and v, otherwise us or vs might be ill-typed
let dep = dependent $ unEl a
-- skip irrelevant parts
- unless (isIrrelevant b) $
+ unless (isIrrelevant b) $
(if dep then noPostponing else id) $
unify (unDom b) u v
arg <- traverse ureduce arg
- unifyElims (a `piApply` [arg]) us vs
- _ -> __IMPOSSIBLE__
+ unifyElims (a `piApply` [arg]) us vs
+ _ -> __IMPOSSIBLE__
where dependent (Pi _ NoAbs{}) = False
dependent (Pi b c) = 0 `relevantIn` absBody c
dependent (Shared p) = dependent (derefPtr p)
@@ -613,24 +631,24 @@ unifyIndices flex a us vs = liftTCM $ do
unifyArgs a us0@(arg@(Arg _ u) : us) vs0@(Arg _ v : vs) = do
liftTCM $ reportSDoc "tc.lhs.unify" 15 $ sep
[ text "unifyArgs"
- , nest 2 $ parens (prettyTCM a)
- , nest 2 $ prettyList $ map prettyTCM us0
- , nest 2 $ prettyList $ map prettyTCM vs0
+ , nest 2 $ parens (prettyTCM a)
+ , nest 2 $ prettyList $ map prettyTCM us0
+ , nest 2 $ prettyList $ map prettyTCM vs0
]
a <- ureduce a -- Q: reduce sufficient?
case ignoreSharing $ unEl a of
- Pi b _ -> do
+ Pi b _ -> do
-- Andreas, Ulf, 2011-09-08 (AIM XVI)
-- in case of dependent function type, we cannot postpone
-- unification of u and v, otherwise us or vs might be ill-typed
let dep = dependent $ unEl a
-- skip irrelevant parts
- unless (isIrrelevant b) $
+ unless (isIrrelevant b) $
(if dep then noPostponing else id) $
unify (unDom b) u v
arg <- traverse ureduce arg
- unifyArgs (a `piApply` [arg]) us vs
- _ -> __IMPOSSIBLE__
+ unifyArgs (a `piApply` [arg]) us vs
+ _ -> __IMPOSSIBLE__
where dependent (Pi _ NoAbs{}) = False
dependent (Pi b c) = 0 `relevantIn` absBody c
dependent (Shared p) = dependent (derefPtr p)
@@ -678,20 +696,20 @@ unifyIndices flex a us vs = liftTCM $ do
-> Term -> Term -> Unify ()
unifyHH aHH u v = do
liftTCM $ reportSDoc "tc.lhs.unify" 15 $
- sep [ text "unifyHH"
- , nest 2 $ (parens $ prettyTCM u) <+> text "=?="
- , nest 2 $ parens $ prettyTCM v
- , nest 2 $ text ":" <+> prettyTCM aHH
- ]
+ sep [ text "unifyHH"
+ , nest 2 $ (parens $ prettyTCM u) <+> text "=?="
+ , nest 2 $ parens $ prettyTCM v
+ , nest 2 $ text ":" <+> prettyTCM aHH
+ ]
u <- liftTCM . constructorForm =<< ureduce u
v <- liftTCM . constructorForm =<< ureduce v
aHH <- ureduce aHH
liftTCM $ reportSDoc "tc.lhs.unify" 25 $
- sep [ text "unifyHH (reduced)"
- , nest 2 $ (parens $ prettyTCM u) <+> text "=?="
- , nest 2 $ parens $ prettyTCM v
- , nest 2 $ text ":" <+> prettyTCM aHH
- ]
+ sep [ text "unifyHH (reduced)"
+ , nest 2 $ (parens $ prettyTCM u) <+> text "=?="
+ , nest 2 $ parens $ prettyTCM v
+ , nest 2 $ text ":" <+> prettyTCM aHH
+ ]
-- obtain the (== Size) function
isSizeName <- liftTCM isSizeNameTest
@@ -736,12 +754,12 @@ unifyIndices flex a us vs = liftTCM $ do
(|->?) = maybeAssign fallback
liftTCM $ reportSDoc "tc.lhs.unify" 15 $
- sep [ text "unifyAtom"
- , nest 2 $ prettyTCM u <> if flexibleTerm u then text " (flexible)" else empty
+ sep [ text "unifyAtom"
+ , nest 2 $ prettyTCM u <> if flexibleTerm u then text " (flexible)" else P.empty
, nest 2 $ text "=?="
- , nest 2 $ prettyTCM v <> if flexibleTerm v then text " (flexible)" else empty
- , nest 2 $ text ":" <+> prettyTCM aHH
- ]
+ , nest 2 $ prettyTCM v <> if flexibleTerm v then text " (flexible)" else P.empty
+ , nest 2 $ text ":" <+> prettyTCM aHH
+ ]
liftTCM $ reportSDoc "tc.lhs.unify" 60 $
text $ "aHH = " ++ show aHH
case (ignoreSharing u, ignoreSharing v) of
@@ -753,7 +771,7 @@ unifyIndices flex a us vs = liftTCM $ do
(_, Level l) -> do
v <- liftTCM $ reallyUnLevelView l
unifyAtomHH aHH u v tryAgain
- (Var i us, Var j vs) | i == j -> checkEqualityHH aHH u v
+ (Var i us, Var j vs) | i == j -> checkEqualityHH aHH u v
-- Andreas, 2013-03-05: the following flex/flex case is an attempt at
-- better dotting (see Issue811). Does not work perfectly, maybe the best choice
-- which variable to assign cannot made locally, but would need a look at the full
@@ -769,9 +787,9 @@ unifyIndices flex a us vs = liftTCM $ do
-- (in this order, see Problem.hs).
-- The comparison is total.
if fj >= fi then j |->? (u, a) else i |->? (v, a)
- (Var i [], _) | homogeneous && flexible i -> i |->? (v, a)
- (_, Var j []) | homogeneous && flexible j -> j |->? (u, a)
- (Con c us, Con c' vs)
+ (Var i [], _) | homogeneous && flexible i -> i |->? (v, a)
+ (_, Var j []) | homogeneous && flexible j -> j |->? (u, a)
+ (Con c us, Con c' vs)
| c == c' -> do
r <- liftTCM (dataOrRecordTypeHH' c aHH)
case r of
@@ -791,7 +809,7 @@ unifyIndices flex a us vs = liftTCM $ do
Nothing -> checkEqualityHH aHH u v
| otherwise -> constructorMismatchHH aHH u v
-- Definitions are ok as long as they can't reduce (i.e. datatypes/axioms)
- (Def d us, Def d' vs)
+ (Def d us, Def d' vs)
| d == d' -> do
-- d must be a data, record or axiom
def <- getConstInfo d
@@ -832,7 +850,7 @@ unifyIndices flex a us vs = liftTCM $ do
if ok then unify a u v
else addEquality a u v
- (Con c us, _) -> do
+ (Con c us, _) -> do
md <- isEtaRecordTypeHH aHH
case md of
Just (d, parsHH) -> do
@@ -842,7 +860,7 @@ unifyIndices flex a us vs = liftTCM $ do
unifyConstructorArgs bHH us vs
Nothing -> fallback
- (_, Con c vs) -> do
+ (_, Con c vs) -> do
md <- isEtaRecordTypeHH aHH
case md of
Just (d, parsHH) -> do
@@ -854,7 +872,7 @@ unifyIndices flex a us vs = liftTCM $ do
-- Andreas, 2011-05-30: If I put checkEquality below, then Issue81 fails
-- because there are definitions blocked by flexibles that need postponement
- _ -> fallback
+ _ -> fallback
unify :: Type -> Term -> Term -> Unify ()
diff --git a/src/full/Agda/TypeChecking/Rules/Record.hs b/src/full/Agda/TypeChecking/Rules/Record.hs
index 49943a4..d9b23dd 100644
--- a/src/full/Agda/TypeChecking/Rules/Record.hs
+++ b/src/full/Agda/TypeChecking/Rules/Record.hs
@@ -31,7 +31,7 @@ import Agda.Utils.Monad
import Agda.Interaction.Options
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -80,6 +80,8 @@ checkRecDef i name ind con ps contel fields =
reportSDoc "tc.rec" 15 $ text "checking fields"
-- WRONG: contype <- workOnTypes $ killRange <$> (instantiateFull =<< isType_ contel)
contype <- killRange <$> (instantiateFull =<< isType_ contel)
+ reportSDoc "tc.rec" 20 $ vcat
+ [ text "contype = " <+> prettyTCM contype ]
-- compute the field telescope (does not include record parameters)
let TelV ftel _ = telView' contype
@@ -94,9 +96,12 @@ checkRecDef i name ind con ps contel fields =
-- t = tel -> t0 where t0 must be a sort s
t0' <- normalise t0
s <- case ignoreSharing $ unEl t0' of
- Sort s -> return s
- _ -> typeError $ ShouldBeASort t0
+ Sort s -> return s
+ _ -> typeError $ ShouldBeASort t0
gamma <- getContextTelescope -- the record params (incl. module params)
+ reportSDoc "tc.rec" 20 $ vcat
+ [ text "gamma = " <+> inTopContext (prettyTCM gamma) ]
+
-- record type (name applied to parameters)
let rect = El s $ Def name $ map Apply $ teleArgs gamma
@@ -119,25 +124,30 @@ checkRecDef i name ind con ps contel fields =
let getName :: A.Declaration -> [A.Arg QName]
getName (A.Field _ x arg) = [x <$ arg]
- getName (A.ScopedDecl _ [f]) = getName f
- getName _ = []
+ getName (A.ScopedDecl _ [f]) = getName f
+ getName _ = []
fs = concatMap (convColor . getName) fields
- con = ConHead conName $ map unArg fs
+ -- indCo is what the user wrote: inductive/coinductive/Nothing.
+ -- We drop the Range.
indCo = rangedThing <$> ind
+ -- A constructor is inductive unless declared coinductive.
+ conInduction = fromMaybe Inductive indCo
+ haveEta = conInduction == Inductive
+ con = ConHead conName conInduction $ map unArg fs
reportSDoc "tc.rec" 30 $ text "record constructor is " <+> text (show con)
addConstant name $ defaultDefn defaultArgInfo name t0
- $ Record { recPars = 0
+ $ Record { recPars = 0
, recClause = Nothing
, recConHead = con
, recNamedCon = hasNamedCon
, recConType = contype -- addConstant adds params!
- , recFields = fs
+ , recFields = fs
, recTel = ftel -- addConstant adds params!
- , recAbstr = Info.defAbstract i
- , recEtaEquality = indCo /= Just CoInductive
- , recInduction = indCo
+ , recAbstr = Info.defAbstract i
+ , recEtaEquality = haveEta
+ , recInduction = indCo -- we retain the original user declaration, in case the record turns out to be recursive
-- determined by positivity checker:
, recRecursive = False
, recMutual = []
@@ -152,7 +162,7 @@ checkRecDef i name ind con ps contel fields =
, conSrcCon = con
, conData = name
, conAbstr = Info.defAbstract conInfo
- , conInd = fromMaybe Inductive indCo
+ , conInd = conInduction
}
-- Declare the constructor as eligible for instance search
@@ -199,9 +209,9 @@ checkRecDef i name ind con ps contel fields =
let -- name of record module
m = qnameToMName name
-- make record parameters hidden and non-stricts irrelevant
- htel = map hideAndRelParams $ telToList tel
+ htel = map hideAndRelParams $ telToList tel
info = setRelevance recordRelevance defaultArgInfo
- tel' = telFromList $ htel ++ [Dom info ("r", rect)]
+ tel' = telFromList $ htel ++ [Dom info ("r", rect)]
ext (Dom info (x, t)) = addCtx x (Dom info t)
-- Add the record section
@@ -214,17 +224,17 @@ checkRecDef i name ind con ps contel fields =
escapeContext (size tel) $ flip (foldr ext) ctx $
-- the record variable has the empty name by intention, see issue 208
underAbstraction (Dom info rect) (Abs "" ()) $ \_ -> do
- reportSDoc "tc.rec.def" 10 $ sep
- [ text "record section:"
- , nest 2 $ sep
+ reportSDoc "tc.rec.def" 10 $ sep
+ [ text "record section:"
+ , nest 2 $ sep
[ prettyTCM m <+> (inTopContext . prettyTCM =<< getContextTelescope)
, fsep $ punctuate comma $ map (text . show . getName) fields
]
- ]
+ ]
reportSDoc "tc.rec.def" 15 $ nest 2 $ vcat
[ text "field tel =" <+> escapeContext 1 (prettyTCM ftel)
]
- addSection m (size tel')
+ addSection m (size tel')
-- Check the types of the fields
-- Andreas, 2013-09-13 all module telescopes count as parameters to the record projections
@@ -276,15 +286,15 @@ checkRecordProjections m r con tel ftel fs = do
-- because then meta variables are created again.
-- Instead, we take the field type t from the field telescope.
reportSDoc "tc.rec.proj" 5 $ sep
- [ text "checking projection" <+> text (show x)
- , nest 2 $ vcat
- [ text "top =" <+> (inTopContext . prettyTCM =<< getContextTelescope)
+ [ text "checking projection" <+> text (show x)
+ , nest 2 $ vcat
+ [ text "top =" <+> (inTopContext . prettyTCM =<< getContextTelescope)
, text "tel =" <+> (inTopContext . prettyTCM $ tel)
- , text "ftel1 =" <+> prettyTCM ftel1
- , text "t =" <+> prettyTCM t
- , text "ftel2 =" <+> addCtxTel ftel1 (underAbstraction_ ftel2 prettyTCM)
- ]
- ]
+ , text "ftel1 =" <+> prettyTCM ftel1
+ , text "t =" <+> prettyTCM t
+ , text "ftel2 =" <+> addCtxTel ftel1 (underAbstraction_ ftel2 prettyTCM)
+ ]
+ ]
-- Andreas, 2010-09-09 The following comments are misleading, TODO: update
-- in fact, tel includes the variable of record type as last one
@@ -297,16 +307,16 @@ checkRecordProjections m r con tel ftel fs = do
{- what are the contexts?
- Γ, tel ⊢ t
- Γ, tel, r ⊢ vs
- Γ, tel, r, ftel₁ ⊢ raiseFrom (size ftel₁) 1 t
+ Γ, tel ⊢ t
+ Γ, tel, r ⊢ vs
+ Γ, tel, r, ftel₁ ⊢ raiseFrom (size ftel₁) 1 t
-}
-- The type of the projection function should be
-- {tel} -> (r : R Δ) -> t
-- where Δ = Γ, tel is the current context
let finalt = telePi (replaceEmptyName "r" tel) t
- projname = qualify m $ qnameName x
+ projname = qualify m $ qnameName x
projcall = Var 0 [Proj projname]
-- projcall = Def projname [defaultArg $ var 0]
rel = getRelevance ai
@@ -323,9 +333,9 @@ checkRecordProjections m r con tel ftel fs = do
ifM (return (rel == Irrelevant) `and2M` do not . optIrrelevantProjections <$> pragmaOptions) recurse $ do
reportSDoc "tc.rec.proj" 10 $ sep
- [ text "adding projection"
- , nest 2 $ prettyTCM projname <+> text ":" <+> inTopContext (prettyTCM finalt)
- ]
+ [ text "adding projection"
+ , nest 2 $ prettyTCM projname <+> text ":" <+> inTopContext (prettyTCM finalt)
+ ]
-- The body should be
-- P.xi {tel} (r _ .. x .. _) = x
@@ -359,17 +369,17 @@ checkRecordProjections m r con tel ftel fs = do
-- (rt) which should be R ptel
(ptel,[rt]) = splitAt (size tel - 1) $ telToList tel
projArgI = domInfo rt
- conp = defaultArg
- $ ConP con (Just (False, argFromDom $ fmap snd rt))
+ conp = defaultArg
+ $ ConP con (Just (False, argFromDom $ fmap snd rt))
[ Arg info $ unnamed $ VarP "x" | Dom info _ <- telToList ftel ]
- nobind 0 = id
- nobind n = Bind . Abs "_" . nobind (n - 1)
- body = nobind (size ftel1)
- $ Bind . Abs "x"
- $ nobind (size ftel2)
- $ Body $ bodyMod $ var (size ftel2)
+ nobind 0 = id
+ nobind n = Bind . Abs "_" . nobind (n - 1)
+ body = nobind (size ftel1)
+ $ Bind . Abs "x"
+ $ nobind (size ftel2)
+ $ Body $ bodyMod $ var (size ftel2)
cltel = ftel
- clause = Clause { clauseRange = getRange info
+ clause = Clause { clauseRange = getRange info
, clauseTel = killRange cltel
, clausePerm = idP $ size ftel
, namedClausePats = [Named Nothing <$> conp]
@@ -395,18 +405,18 @@ checkRecordProjections m r con tel ftel fs = do
}
reportSDoc "tc.rec.proj" 80 $ sep
- [ text "adding projection"
- , nest 2 $ prettyTCM projname <+> text (show clause)
- ]
+ [ text "adding projection"
+ , nest 2 $ prettyTCM projname <+> text (show clause)
+ ]
reportSDoc "tc.rec.proj" 70 $ sep
- [ text "adding projection"
- , nest 2 $ prettyTCM projname <+> text (show (clausePats clause)) <+> text "=" <+>
+ [ text "adding projection"
+ , nest 2 $ prettyTCM projname <+> text (show (clausePats clause)) <+> text "=" <+>
inTopContext (addCtxTel ftel (prettyTCM (clauseBody clause)))
- ]
+ ]
reportSDoc "tc.rec.proj" 10 $ sep
- [ text "adding projection"
- , nest 2 $ prettyTCM (QNamed projname clause)
- ]
+ [ text "adding projection"
+ , nest 2 $ prettyTCM (QNamed projname clause)
+ ]
-- Record patterns should /not/ be translated when the
-- projection functions are defined. Record pattern
@@ -420,7 +430,7 @@ checkRecordProjections m r con tel ftel fs = do
]
escapeContext (size tel) $ do
- addConstant projname $
+ addConstant projname $
(defaultDefn ai projname (killRange finalt)
Function { funClauses = [clause]
, funCompiled = Just cc
@@ -434,6 +444,7 @@ checkRecordProjections m r con tel ftel fs = do
, funTerminates = Just True
, funExtLam = Nothing
, funWith = Nothing
+ , funCopatternLHS = isCopatternLHS [clause]
})
{ defArgOccurrences = [StrictPos] }
computePolarity projname
diff --git a/src/full/Agda/TypeChecking/Rules/Term.hs b/src/full/Agda/TypeChecking/Rules/Term.hs
index ce9eaf3..451e3c4 100644
--- a/src/full/Agda/TypeChecking/Rules/Term.hs
+++ b/src/full/Agda/TypeChecking/Rules/Term.hs
@@ -1,17 +1,16 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TupleSections #-}
module Agda.TypeChecking.Rules.Term where
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Reader
-import Control.Monad.Error
import Data.Maybe
import Data.List hiding (sort)
@@ -19,6 +18,7 @@ import qualified Data.Map as Map
import Data.Traversable (sequenceA)
import Agda.Interaction.Options
+import Agda.Interaction.Highlighting.Generate (storeDisambiguatedName)
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Views as A
@@ -56,12 +56,19 @@ import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Rules.LHS (checkLeftHandSide, LHSResult(..))
+import Agda.TypeChecking.Unquote
import {-# SOURCE #-} Agda.TypeChecking.Empty (isEmptyType)
import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkSectionApplication)
-import {-# SOURCE #-} Agda.TypeChecking.Rules.Def (checkFunDef,checkFunDef')
+import {-# SOURCE #-} Agda.TypeChecking.Rules.Def (checkFunDef, checkFunDef', useTerPragma)
+
+import Agda.Utils.Except
+ ( Error(noMsg, strMsg)
+ , ExceptT
+ , MonadError(catchError, throwError)
+ , runExceptT
+ )
-import Agda.Utils.Fresh
import Agda.Utils.Functor (($>))
import Agda.Utils.Maybe
import Agda.Utils.Monad
@@ -69,7 +76,7 @@ import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -134,9 +141,9 @@ leqType_ t t' = workOnTypes $ leqType t t'
forcePi :: Hiding -> String -> Type -> TCM (Type, Constraints)
forcePi h name (El s t) =
- do t' <- reduce t
- case t' of
- Pi _ _ -> return (El s t', [])
+ do t' <- reduce t
+ case t' of
+ Pi _ _ -> return (El s t', [])
_ -> do
sa <- newSortMeta
sb <- newSortMeta
@@ -144,7 +151,7 @@ forcePi h name (El s t) =
a <- newTypeMeta sa
x <- freshName_ name
- let arg = Arg h Relevant a
+ let arg = Arg h Relevant a
b <- addCtx x arg $ newTypeMeta sb
let ty = El s' $ Pi arg (Abs (show x) b)
cs <- equalType (El s t') ty
@@ -162,7 +169,7 @@ checkTelescope_ [] ret = ret EmptyTel
checkTelescope_ (b : tel) ret =
checkTypedBindings_ b $ \tel1 ->
checkTelescope_ tel $ \tel2 ->
- ret $ abstract tel1 tel2
+ ret $ abstract tel1 tel2
-- | Check a typed binding and extends the context with the bound variables.
-- The telescope passed to the continuation is valid in the original context.
@@ -250,7 +257,6 @@ checkLambda (Arg info (A.TBind _ xs typ)) body target = do
let r = getRelevance info
r' = getRelevance arg -- relevance of function type
when (r == Irrelevant && r' /= r) $ typeError $ WrongIrrelevanceInLambda target
--- unless (getRelevance arg == r) $ typeError $ WrongIrrelevanceInLambda target
-- We only need to block the final term on the argument type
-- comparison. The body will be blocked if necessary. We still want to
-- compare the argument types first, so we spawn a new problem for that
@@ -278,7 +284,6 @@ checkAbsurdLambda i h e t = do
null . allMetas <$> instantiateFull a
| otherwise -> blockTerm t' $ do
isEmptyType (getRange i) a
--- return $ Lam info' absurdBody
-- Add helper function
top <- currentModule
aux <- qualify top <$> freshName_ (getRange i, absurdLambdaName)
@@ -315,6 +320,7 @@ checkAbsurdLambda i h e t = do
, funTerminates = Just True
, funExtLam = Nothing
, funWith = Nothing
+ , funCopatternLHS = False
}
-- Andreas 2012-01-30: since aux is lifted to toplevel
-- it needs to be applied to the current telescope (issue 557)
@@ -334,8 +340,9 @@ checkExtendedLambda i di qname cs e t = do
let info = setRelevance rel defaultArgInfo
-- Andreas, 2013-12-28: add extendedlambda as @Function@, not as @Axiom@;
-- otherwise, @addClause@ in @checkFunDef'@ fails (see issue 1009).
- addConstant qname $
- (defaultDefn info qname t emptyFunction) { defMutual = j }
+ addConstant qname =<< do
+ useTerPragma $
+ (defaultDefn info qname t emptyFunction) { defMutual = j }
reportSDoc "tc.term.exlam" 50 $
text "extended lambda's implementation \"" <> prettyTCM qname <>
text "\" has type: " $$ prettyTCM t -- <+> text " where clauses: " <+> text (show cs)
@@ -347,7 +354,7 @@ checkExtendedLambda i di qname cs e t = do
let (hid, notHid) = partition isHidden argsNoParam
abstract (A.defAbstract di) $ checkFunDef' t info NotDelayed
(Just (length hid, length notHid)) Nothing di qname cs
- reduce $ (Def qname [] `apply` args)
+ return $ Def qname $ map Apply args
where
-- Concrete definitions cannot use information about abstract things.
abstract ConcreteDef = inConcreteMode
@@ -370,15 +377,14 @@ checkRecordExpression fs e t = do
Def r es -> do
let ~(Just vs) = allApplyElims es
reportSDoc "tc.term.rec" 20 $ text $ " r = " ++ show r
-{-
- axs <- getRecordFieldNames r
- let xs = map unArg axs
- reportSDoc "tc.term.rec" 20 $ text $ " xs = " ++ show xs
- ftel <- getRecordFieldTypes r
- reportSDoc "tc.term.rec" 20 $ text " ftel= " <> prettyTCM ftel
- con <- getRecordConstructor r
- reportSDoc "tc.term.rec" 20 $ text $ " con = " ++ show con
--}
+
+ reportSDoc "tc.term.rec" 30 $ text " xs = " <> do
+ text =<< show . map unArg <$> getRecordFieldNames r
+ reportSDoc "tc.term.rec" 30 $ text " ftel= " <> do
+ prettyTCM =<< getRecordFieldTypes r
+ reportSDoc "tc.term.rec" 30 $ text " con = " <> do
+ text =<< show <$> getRecordConstructor r
+
def <- getRecordDef r
let axs = recordFieldNames def
xs = map unArg axs
@@ -493,21 +499,10 @@ checkLiteral lit t = do
t' <- litType lit
coerce (Lit lit) t' t
--- moved to TypeChecking.Monad.Builtin to avoid import cycles:
--- litType :: Literal -> TCM Type
-
---------------------------------------------------------------------------
-- * Terms
---------------------------------------------------------------------------
-{- MOVED to TC.Datatypes.getConForm
--- TODO: move somewhere suitable
-reduceCon :: QName -> TCM ConHead
-reduceCon x = do
- Con c [] <- ignoreSharing <$> (constructorForm =<< getConHead c)
- return c
--}
-
-- | @checkArguments' exph r args t0 t k@ tries @checkArguments exph args t0 t at .
-- If it succeeds, it continues @k@ with the returned results. If it fails,
-- it registers a postponed typechecking problem and returns the resulting new
@@ -518,7 +513,7 @@ checkArguments' ::
ExpandHidden -> ExpandInstances -> Range -> [I.NamedArg A.Expr] -> Type -> Type ->
(Args -> Type -> TCM Term) -> TCM Term
checkArguments' exph expIFS r args t0 t k = do
- z <- runErrorT $ checkArguments exph expIFS r args t0 t
+ z <- runExceptT $ checkArguments exph expIFS r args t0 t
case z of
Right (vs, t1) -> k vs t1
-- vs = evaluated args
@@ -543,9 +538,9 @@ checkExpr e t0 =
traceCall (CheckExprCall e t0) $ localScope $ doExpandLast $ shared <$> do
reportSDoc "tc.term.expr.top" 15 $
text "Checking" <+> sep
- [ fsep [ prettyTCM e, text ":", prettyTCM t0 ]
- , nest 2 $ text "at " <+> (text . show =<< getCurrentRange)
- ]
+ [ fsep [ prettyTCM e, text ":", prettyTCM t0 ]
+ , nest 2 $ text "at " <+> (text . show =<< getCurrentRange)
+ ]
reportSDoc "tc.term.expr.top.detailed" 80 $
text "Checking" <+> fsep [ prettyTCM e, text ":", text (show t0) ]
t <- reduce t0
@@ -553,44 +548,58 @@ checkExpr e t0 =
text " --> " <+> prettyTCM t
let scopedExpr (A.ScopedExpr scope e) = setScope scope >> scopedExpr e
- scopedExpr e = return e
+ scopedExpr e = return e
e <- scopedExpr e
case e of
- A.ScopedExpr scope e -> __IMPOSSIBLE__ -- setScope scope >> checkExpr e t
-
- -- Insert hidden lambda if appropriate
- _ | Pi (Dom info _) _ <- ignoreSharing $ unEl t
- , not (hiddenLambdaOrHole (getHiding info) e)
- , getHiding info /= NotHidden -> do
- x <- freshName r (argName t)
+ A.ScopedExpr scope e -> __IMPOSSIBLE__ -- setScope scope >> checkExpr e t
+
+ -- Insert hidden lambda if all of the following conditions are met:
+ -- type is a hidden function type, {x : A} -> B or {{x : A} -> B
+ _ | Pi (Dom info _) _ <- ignoreSharing $ unEl t
+ , let h = getHiding info
+ , notVisible h
+ -- expression is not a matching hidden lambda or question mark
+ , not (hiddenLambdaOrHole h e)
+ -> do
+ x <- freshName rx (argName t)
info <- reify info
reportSLn "tc.term.expr.impl" 15 $ "Inserting implicit lambda"
- checkExpr (A.Lam (A.ExprRange $ getRange e) (domainFree info x) e) t
- where
- r = case rStart $ getRange e of
- Nothing -> noRange
- Just pos -> posToRange pos pos
-
- hiddenLambdaOrHole h (A.AbsurdLam _ h') | h == h' = True
- hiddenLambdaOrHole h (A.ExtendedLam _ _ _ []) = False
- hiddenLambdaOrHole h (A.ExtendedLam _ _ _ cls) = any hiddenLHS cls
- hiddenLambdaOrHole h (A.Lam _ (A.DomainFree info' _) _) | h == getHiding info' = True
- hiddenLambdaOrHole h (A.Lam _ (A.DomainFull (A.TypedBindings _ (Arg info' _))) _)
- | h == getHiding info' = True
- hiddenLambdaOrHole _ A.QuestionMark{} = True
- hiddenLambdaOrHole _ _ = False
-
- hiddenLHS (A.Clause (A.LHS _ (A.LHSHead _ (a : _)) _) _ _) = elem (getHiding a) [Hidden, Instance]
+ checkExpr (A.Lam (A.ExprRange re) (domainFree info x) e) t
+ where
+ re = getRange e
+ rx = caseMaybe (rStart re) noRange $ \ pos -> posToRange pos pos
+
+ hiddenLambdaOrHole h e = case e of
+ A.AbsurdLam _ h' -> h == h'
+ A.ExtendedLam _ _ _ cls -> any hiddenLHS cls
+ A.Lam _ (A.DomainFree info' _) _ -> h == getHiding info'
+ A.Lam _ (A.DomainFull (A.TypedBindings _ (Arg info' _))) _
+ -> h == getHiding info'
+ A.QuestionMark{} -> True
+ _ -> False
+
+ hiddenLHS (A.Clause (A.LHS _ (A.LHSHead _ (a : _)) _) _ _) = notVisible a
hiddenLHS _ = False
-- a meta variable without arguments: type check directly for efficiency
- A.QuestionMark i ii -> checkMeta (newQuestionMark ii) t0 i -- Andreas, 2013-05-22 use unreduced type t0!
- A.Underscore i -> checkMeta (newValueMeta RunMetaOccursCheck) t0 i
+ A.QuestionMark i ii -> do
+ reportSDoc "tc.interaction" 20 $ sep
+ [ text "Found interaction point"
+ , text (show ii)
+ , text ":"
+ , prettyTCM t0
+ ]
+ reportSDoc "tc.interaction" 40 $ sep
+ [ text "Raw:"
+ , text (show t0)
+ ]
+ checkMeta (newQuestionMark ii) t0 i -- Andreas, 2013-05-22 use unreduced type t0!
+ A.Underscore i -> checkMeta (newValueMeta RunMetaOccursCheck) t0 i
- A.WithApp _ e es -> typeError $ NotImplemented "type checking of with application"
+ A.WithApp _ e es -> typeError $ NotImplemented "type checking of with application"
-- check |- Set l : t (requires universe polymorphism)
A.App i s (Arg ai l)
@@ -613,6 +622,7 @@ checkExpr e t0 =
A.App i q (Arg ai e)
| A.Quote _ <- unScope q, visible ai -> do
let quoted (A.Def x) = return x
+ quoted (A.Proj x) = return x
quoted (A.Con (AmbQ [x])) = return x
quoted (A.Con (AmbQ xs)) = typeError $ GenericError $ "quote: Ambigous name: " ++ show xs
quoted (A.ScopedExpr _ e) = quoted e
@@ -622,10 +632,11 @@ checkExpr e t0 =
coerce (quoteName x) ty t
| A.QuoteTerm _ <- unScope q ->
- do (et, _) <- inferExpr (namedThing e)
- q <- quoteTerm =<< normalise et
- ty <- el primAgdaTerm
+ do (et, _) <- inferExpr (namedThing e)
+ q <- quoteTerm =<< etaContract =<< normalise et
+ ty <- el primAgdaTerm
coerce q ty t
+
A.Quote _ -> typeError $ GenericError "quote must be applied to a defined name"
A.QuoteTerm _ -> typeError $ GenericError "quoteTerm must be applied to a term"
A.Unquote _ -> typeError $ GenericError "unquote must be applied to a term"
@@ -634,14 +645,14 @@ checkExpr e t0 =
A.ExtendedLam i di qname cs -> checkExtendedLambda i di qname cs e t
- A.Lam i (A.DomainFull (A.TypedBindings _ b)) e -> checkLambda (convColor b) e t
+ A.Lam i (A.DomainFull (A.TypedBindings _ b)) e -> checkLambda (convColor b) e t
- A.Lam i (A.DomainFree info x) e0 -> checkExpr (A.Lam i (domainFree info x) e0) t
+ A.Lam i (A.DomainFree info x) e0 -> checkExpr (A.Lam i (domainFree info x) e0) t
- A.Lit lit -> checkLiteral lit t
- A.Let i ds e -> checkLetBindings ds $ checkExpr e t
- A.Pi _ tel e -> do
- t' <- checkTelescope_ tel $ \tel -> do
+ A.Lit lit -> checkLiteral lit t
+ A.Let i ds e -> checkLetBindings ds $ checkExpr e t
+ A.Pi _ tel e -> do
+ t' <- checkTelescope_ tel $ \tel -> do
t <- instantiateFull =<< isType_ e
tel <- instantiateFull tel
return $ telePi tel t
@@ -651,25 +662,25 @@ checkExpr e t0 =
, nest 2 $ text "t =" <+> prettyTCM t'
, nest 2 $ text "cxt =" <+> (prettyTCM =<< getContextTelescope)
]
- coerce (unEl t') (sort s) t
- A.Fun _ (Arg info a) b -> do
- a' <- isType_ a
- b' <- isType_ b
- s <- reduce $ getSort a' `sLub` getSort b'
- coerce (Pi (convColor $ Dom info a') (NoAbs underscore b')) (sort s) t
- A.Set _ n -> do
+ coerce (unEl t') (sort s) t
+ A.Fun _ (Arg info a) b -> do
+ a' <- isType_ a
+ b' <- isType_ b
+ s <- reduce $ getSort a' `sLub` getSort b'
+ coerce (Pi (convColor $ Dom info a') (NoAbs underscore b')) (sort s) t
+ A.Set _ n -> do
n <- ifM typeInType (return 0) (return n)
- coerce (Sort $ mkType n) (sort $ mkType $ n + 1) t
- A.Prop _ -> do
+ coerce (Sort $ mkType n) (sort $ mkType $ n + 1) t
+ A.Prop _ -> do
typeError $ GenericError "Prop is no longer supported"
-- s <- ifM typeInType (return $ mkType 0) (return Prop)
- -- coerce (Sort Prop) (sort $ mkType 1) t
+ -- coerce (Sort Prop) (sort $ mkType 1) t
- A.Rec _ fs -> checkRecordExpression fs e t
+ A.Rec _ fs -> checkRecordExpression fs e t
A.RecUpdate ei recexpr fs -> checkRecordUpdate ei recexpr fs e t
- A.DontCare e -> -- resurrect vars
+ A.DontCare e -> -- resurrect vars
ifM ((Irrelevant ==) <$> asks envRelevance)
(dontCare <$> do applyRelevanceToContext Irrelevant $ checkExpr e t)
(internalError "DontCare may only appear in irrelevant contexts")
@@ -699,7 +710,7 @@ checkExpr e t0 =
blockTerm t $ coerce v ctxType t
A.ETel _ -> __IMPOSSIBLE__
- -- Application
+ -- Application
_ | Application hd args <- appView e -> checkApplication hd args e t
-- | @checkApplication hd args e t@ checks an application.
@@ -728,27 +739,21 @@ checkApplication hd args e t = do
cons <- mapM getConForm cs
reportSLn "tc.check.term" 40 $ " reduced: " ++ show cons
dcs <- zipWithM (\ c con -> (, setConName c con) . getData . theDef <$> getConInfo con) cs cons
-{-
- cs <- zip cs . zipWith setRange (map getRange cs) <$> mapM reduceCon cs
- reportSLn "tc.check.term" 40 $ " ranges after: " ++ show (getRange cs)
- reportSLn "tc.check.term" 40 $ " reduced: " ++ show cs
- dcs <- mapM (\(c0, c1) -> (getData /\ const c0) . theDef <$> getConstInfo c1) cs
--}
-- Type error
let badCon t = typeError $ DoesNotConstructAnElementOf (head cs) t
--- let badCon t = typeError $ DoesNotConstructAnElementOf (fst $ head cs) t
-
-- Lets look at the target type at this point
- let getCon = do
+ let getCon :: TCM (Maybe ConHead)
+ getCon = do
TelV tel t1 <- telView t
addCtxTel tel $ do
reportSDoc "tc.check.term.con" 40 $ nest 2 $
text "target type: " <+> prettyTCM t1
ifBlockedType t1 (\ m t -> return Nothing) $ \ t' ->
- (isDataOrRecord (unEl t') >>=) $ maybe (badCon t') $ \ d ->
+ caseMaybeM (isDataOrRecord $ unEl t') (badCon t') $ \ d ->
case [ c | (d', c) <- dcs, d == d' ] of
[c] -> do
reportSLn "tc.check.term" 40 $ " decided on: " ++ show c
+ storeDisambiguatedName $ conName c
return $ Just c
[] -> badCon $ t' $> Def d []
cs -> typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d $ map conName cs
@@ -762,7 +767,6 @@ checkApplication hd args e t = do
A.Con (AmbQ [c]) -> do
-- augment c with record fields, but do not revert to original name
con <- getOrigConHead c
--- con <- setConName c . conSrcCon . theDef <$> getConstInfo c
checkConstructorApplication e t con $ map convColor args
-- Subcase: pattern synonym
@@ -774,7 +778,7 @@ checkApplication hd args e t = do
-- over the ones we haven't.
let meta r = A.Underscore $ A.emptyMetaInfo{ A.metaRange = r } -- TODO: name suggestion
case A.insertImplicitPatSynArgs meta (getRange n) ns args of
- Nothing -> typeError $ GenericError $ "Bad arguments to pattern synonym " ++ show n
+ Nothing -> typeError $ BadArgumentsToPatternSynonym n
Just (s, ns) -> do
let p' = A.patternToExpr p
e' = A.lambdaLiftExpr (map unArg ns) (A.substExpr s p')
@@ -790,12 +794,16 @@ checkApplication hd args e t = do
checkHeadApplication e t e $ map convColor args
where
unquoteTerm qv = do
- v <- unquote =<< checkExpr qv =<< el primAgdaTerm
- e <- reifyUnquoted (v :: Term)
- reportSDoc "tc.unquote.term" 10 $
- vcat [ text "unquote" <+> prettyTCM qv
- , nest 2 $ text "-->" <+> prettyA e ]
- return (killRange e)
+ qv <- checkExpr qv =<< el primAgdaTerm
+ mv <- runUnquoteM $ unquote qv
+ case mv of
+ Left err -> typeError $ UnquoteFailed err
+ Right v -> do
+ e <- reifyUnquoted (v :: Term)
+ reportSDoc "tc.unquote.term" 10 $
+ vcat [ text "unquote" <+> prettyTCM qv
+ , nest 2 $ text "-->" <+> prettyA e ]
+ return (killRange e)
-- Subcase: defined symbol or variable.
_ -> checkHeadApplication e t hd $ map convColor args
@@ -811,7 +819,7 @@ domainFree info x =
{ A.metaRange = r
, A.metaScope = emptyScopeInfo
, A.metaNumber = Nothing
- , A.metaNameSuggestion = show x
+ , A.metaNameSuggestion = show $ A.nameConcrete x
}
---------------------------------------------------------------------------
@@ -820,37 +828,9 @@ domainFree info x =
checkMeta :: (Type -> TCM Term) -> Type -> A.MetaInfo -> TCM Term
checkMeta newMeta t i = fst <$> checkOrInferMeta newMeta (Just t) i
-{-
-checkMeta newMeta t i = do
- case A.metaNumber i of
- Nothing -> do
- setScope (A.metaScope i)
- v <- newMeta t
- setValueMetaName v (A.metaNameSuggestion i)
- return v
- -- Rechecking an existing metavariable
- Just n -> do
- let v = MetaV (MetaId n) []
- t' <- jMetaType . mvJudgement <$> lookupMeta (MetaId n)
- coerce v t' t
--}
inferMeta :: (Type -> TCM Term) -> A.MetaInfo -> TCM (Args -> Term, Type)
inferMeta newMeta i = mapFst apply <$> checkOrInferMeta newMeta Nothing i
-{-
-inferMeta newMeta i =
- case A.metaNumber i of
- Nothing -> do
- setScope (A.metaScope i)
- t <- workOnTypes $ newTypeMeta_
- v <- newMeta t
- return (apply v, t)
- -- Rechecking an existing metavariable
- Just n -> do
- let v = MetaV (MetaId n)
- t' <- jMetaType . mvJudgement <$> lookupMeta (MetaId n)
- return (v, t')
--}
-- | Type check a meta variable.
-- If its type is not given, we return its type, or a fresh one, if it is a new meta.
@@ -877,6 +857,15 @@ checkOrInferMeta newMeta mt i = do
-- * Applications
---------------------------------------------------------------------------
+inferHeadDef :: QName -> TCM (Args -> Term, Type)
+inferHeadDef x = do
+ proj <- isProjection x
+ let app =
+ case proj of
+ Nothing -> \ f args -> return $ Def f $ map Apply args
+ Just p -> \ f args -> return $ projDropPars p `apply` args
+ mapFst apply <$> inferDef app x
+
-- | Infer the type of a head thing (variable, function symbol, or constructor).
-- We return a function that applies the head to arguments.
-- This is because in case of a constructor we want to drop the parameters.
@@ -888,34 +877,8 @@ inferHead e = do
when (unusableRelevance $ getRelevance a) $
typeError $ VariableIsIrrelevant x
return (apply u, unDom a)
- (A.Def x) -> do
- proj <- isProjection x
- case proj of
- Nothing -> do
- (u, a) <- inferDef (\ f args -> return $ Def f $ map Apply args) x
- return (apply u, a)
- Just Projection{ projDropPars = proj } -> do
-{- MOVED to Rules/Record.hs and ProjectionLike.hs
- Just Projection{ projIndex = n, projProper, projDropPars = proj } -> do
- reportSDoc "tc.term.proj" 10 $ sep
- [ text "building projection" <+> prettyTCM x
- , nest 2 $ parens (text "ctx =" <+> (text . show =<< do
- size <$> freeVarsToApply x))
- , nest 2 $ parens (text "n =" <+> text (show n))
- , nest 2 $ parens (text "m =" <+> (text . show =<< getDefFreeVars x))
- ]
- let is | n == 0 = __IMPOSSIBLE__
- | otherwise = genericReplicate (n - 1) defaultArgInfo -- TODO: hiding
- names = [ s ++ [c] | s <- "" : names, c <- ['a'..'z'] ]
- -- Andreas, 2013-10-19
- -- proper projections are postfix, projection-like defs are prefix
- core | projProper = (Lam defaultArgInfo $ Abs "r" $ Var 0 [Proj x])
- | otherwise = Def x []
- -- leading lambdas are to ignore parameter applications
- proj = foldr (\ (i, s) -> Lam i . NoAbs s) core (zip is names)
--}
- (u, a) <- inferDef (\ f vs -> return $ proj `apply` vs) x
- return (apply u, a)
+ (A.Def x) -> inferHeadDef x
+ (A.Proj x) -> inferHeadDef x
(A.Con (AmbQ [c])) -> do
-- Constructors are polymorphic internally.
@@ -1132,7 +1095,7 @@ checkHeadApplication e t hd args = do
-- The name of the fresh function.
i <- fresh :: TCM Int
- let name = filter (/= '_') (show $ A.qnameName c) ++ "-" ++ show i
+ let name = filter (/= '_') (show $ A.nameConcrete $ A.qnameName c) ++ "-" ++ show i
c' <- setRange (getRange c) <$>
liftM2 qualify (killRange <$> currentModule)
(freshName_ name)
@@ -1148,9 +1111,11 @@ checkHeadApplication e t hd args = do
-- If we are in irrelevant position, add definition irrelevantly.
-- TODO: is this sufficient?
rel <- asks envRelevance
- addConstant c' (Defn (setRelevance rel defaultArgInfo)
- c' t [] [] (defaultDisplayForm c')
- i noCompiledRep [] Nothing $ emptyFunction)
+ addConstant c' =<< do
+ let ai = setRelevance rel defaultArgInfo
+ useTerPragma $
+ Defn ai c' t [] [] (defaultDisplayForm c') i noCompiledRep [] Nothing $
+ emptyFunction
-- Define and type check the fresh function.
ctx <- getContext >>= mapM (\d -> flip Dom (unDom d) <$> reify (domInfo d))
@@ -1190,18 +1155,15 @@ checkHeadApplication e t hd args = do
expandLast <- asks envExpandLast
checkArguments' expandLast ExpandInstanceArguments (getRange hd) args t0 t $ \vs t1 -> do
coerce (f vs) t1 t
- -- -- try to remove projection redexes -- fails succeed/Issue286
- -- v <- onlyReduceProjections $ reduce $ f vs
- -- coerce v t1 t
-- Stupid ErrorT!
instance Error (a, b, c) where
strMsg _ = __IMPOSSIBLE__
noMsg = __IMPOSSIBLE__
-traceCallE :: Error e => (Maybe r -> Call) -> ErrorT e TCM r -> ErrorT e TCM r
+traceCallE :: Error e => (Maybe r -> Call) -> ExceptT e TCM r -> ExceptT e TCM r
traceCallE call m = do
- z <- lift $ traceCall call' $ runErrorT m
+ z <- lift $ traceCall call' $ runExceptT m
case z of
Right e -> return e
Left err -> throwError err
@@ -1216,7 +1178,7 @@ traceCallE call m = do
-- type @t0'@ (which should be a subtype of @t1@) and any constraints @cs@
-- that have to be solved for everything to be well-formed.
checkArguments :: ExpandHidden -> ExpandInstances -> Range -> [I.NamedArg A.Expr] -> Type -> Type ->
- ErrorT (Args, [I.NamedArg A.Expr], Type) TCM (Args, Type)
+ ExceptT (Args, [I.NamedArg A.Expr], Type) TCM (Args, Type)
-- Case: no arguments, do not insert trailing hidden arguments: We are done.
checkArguments DontExpandLast DontExpandInstanceArguments _ [] t0 t1 = return ([], t0)
@@ -1314,7 +1276,7 @@ checkArguments exh expandIFS r args0@(arg@(Arg info e) : args) t0 t1 =
-- | Check that a list of arguments fits a telescope.
checkArguments_ :: ExpandHidden -> Range -> [I.NamedArg A.Expr] -> Telescope -> TCM Args
checkArguments_ exh r args tel = do
- z <- runErrorT $ checkArguments exh ExpandInstanceArguments r args (telePi tel $ sort Prop) (sort Prop)
+ z <- runExceptT $ checkArguments exh ExpandInstanceArguments r args (telePi tel $ sort Prop) (sort Prop)
case z of
Right (args, _) -> return args
Left _ -> __IMPOSSIBLE__
@@ -1327,7 +1289,7 @@ inferExpr :: A.Expr -> TCM (Term, Type)
inferExpr e = case e of
_ | Application hd args <- appView e, defOrVar hd -> traceCall (InferExpr e) $ do
(f, t0) <- inferHead hd
- res <- runErrorT $ checkArguments DontExpandLast ExpandInstanceArguments (getRange hd) (map convColor args) t0 (sort Prop)
+ res <- runExceptT $ checkArguments DontExpandLast ExpandInstanceArguments (getRange hd) (map convColor args) t0 (sort Prop)
case res of
Right (vs, t1) -> return (f vs, t1)
Left t1 -> fallback -- blocked on type t1
@@ -1341,6 +1303,7 @@ inferExpr e = case e of
defOrVar :: A.Expr -> Bool
defOrVar A.Var{} = True
defOrVar A.Def{} = True
+defOrVar A.Proj{} = True
defOrVar (A.ScopedExpr _ e) = defOrVar e
defOrVar _ = False
@@ -1374,12 +1337,31 @@ inferOrCheck e mt = case e of
return (v,t)
-}
+-- | Check whether a de Bruijn index is bound by a module telescope.
+isModuleFreeVar :: Int -> TCM Bool
+isModuleFreeVar i = do
+ nfv <- getModuleFreeVars =<< currentModule
+ n <- getContextSize
+ -- The first de Bruijn index that points to a module
+ -- free variable.
+ let firstModuleVar = n - nfv
+ when (firstModuleVar < 0) __IMPOSSIBLE__
+ return $ i >= firstModuleVar
+
-- | Infer the type of an expression, and if it is of the form
-- @{tel} -> D vs@ for some datatype @D@ then insert the hidden
-- arguments. Otherwise, leave the type polymorphic.
inferExprForWith :: A.Expr -> TCM (Term, Type)
-inferExprForWith e = do
- (v, t) <- inferExpr e
+inferExprForWith e = traceCall (InferExpr e) $ do
+ -- With wants type and term fully instantiated!
+ (v, t) <- instantiateFull =<< inferExpr e
+ v0 <- reduce v
+ -- Andreas 2014-11-06, issue 1342.
+ -- Check that we do not `with` on a module parameter!
+ case ignoreSharing v0 of
+ Var i [] -> whenM (isModuleFreeVar i) $ typeError $ WithOnFreeVariable e
+ _ -> return ()
+ -- Possibly insert hidden arguments.
TelV tel t0 <- telViewUpTo' (-1) ((NotHidden /=) . getHiding) t
case ignoreSharing $ unEl t0 of
Def d vs -> do
@@ -1468,7 +1450,6 @@ checkLetBinding b@(A.LetPatBind i p e) ret =
checkLetBinding (A.LetApply i x modapp rd rm) ret = do
-- Any variables in the context that doesn't belong to the current
-- module should go with the new module.
- -- fv <- getDefFreeVars =<< (qnameFromList . mnameToList) <$> currentModule
fv <- getModuleFreeVars =<< currentModule
n <- getContextSize
let new = n - fv
diff --git a/src/full/Agda/TypeChecking/Rules/Term.hs-boot b/src/full/Agda/TypeChecking/Rules/Term.hs-boot
index d1d4ede..f166ac3 100644
--- a/src/full/Agda/TypeChecking/Rules/Term.hs-boot
+++ b/src/full/Agda/TypeChecking/Rules/Term.hs-boot
@@ -6,14 +6,14 @@ import Agda.Syntax.Internal
-- import Agda.Syntax.Common hiding (Arg, Dom, NamedArg)
import Agda.Syntax.Position
import Agda.TypeChecking.Monad.Base
-import Control.Monad.Error (ErrorT)
+import Agda.Utils.Except ( ExceptT )
isType_ :: A.Expr -> TCM Type
checkExpr :: A.Expr -> Type -> TCM Term
checkArguments :: ExpandHidden -> ExpandInstances -> Range -> [NamedArg A.Expr] -> Type -> Type ->
- ErrorT (Args, [NamedArg A.Expr], Type) TCM (Args, Type)
+ ExceptT (Args, [NamedArg A.Expr], Type) TCM (Args, Type)
checkArguments' :: ExpandHidden -> ExpandInstances -> Range -> [NamedArg A.Expr] -> Type -> Type ->
(Args -> Type -> TCM Term) -> TCM Term
diff --git a/src/full/Agda/TypeChecking/Serialise.hs b/src/full/Agda/TypeChecking/Serialise.hs
index e3b3f71..ed6cd48 100644
--- a/src/full/Agda/TypeChecking/Serialise.hs
+++ b/src/full/Agda/TypeChecking/Serialise.hs
@@ -1,11 +1,15 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-{-# OPTIONS_GHC -O2 #-}
+-- Andreas, Makoto, Francesco 2014-10-15 AIM XX:
+-- -O2 does not have any noticable effect on runtime
+-- but sabotages cabal repl with -Werror
+-- (due to a conflict with --interactive warning)
+-- {-# OPTIONS_GHC -O2 #-}
-- | Structure-sharing serialisation of Agda interface files.
@@ -22,18 +26,19 @@ module Agda.TypeChecking.Serialise
where
import Control.Applicative
+import Control.Arrow (first, second)
+import Control.DeepSeq
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State.Strict
-import Control.Monad.Error
import Data.Array.IArray
import Data.Word
import qualified Data.ByteString.Lazy as L
import Data.Hashable
import qualified Data.HashTable.IO as H
import Data.Int (Int32)
-import Data.IORef
+import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
@@ -65,7 +70,7 @@ import qualified Agda.Interaction.Highlighting.Precise as HP
import Agda.Interaction.FindFile
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
-import Agda.TypeChecking.Monad.Benchmark (billTo)
+import Agda.TypeChecking.Monad.Benchmark (billSub, billTo)
import Agda.TypeChecking.Monad
import Agda.TypeChecking.CompiledClause
@@ -73,21 +78,39 @@ import Agda.TypeChecking.CompiledClause
import Agda.Utils.BiMap (BiMap)
import qualified Agda.Utils.BiMap as BiMap
-import Agda.Utils.FileName
-import Agda.Utils.Permutation
import Agda.Utils.HashMap (HashMap)
import Agda.Utils.Hash
import qualified Agda.Utils.HashMap as HMap
+import Agda.Utils.FileName
+import Agda.Utils.IORef
+import Agda.Utils.Lens
+import Agda.Utils.Monad
+import Agda.Utils.Permutation
+
+import Agda.Utils.Except ( ExceptT, MonadError(throwError), runExceptT )
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+-- | Compatibility with @bytestring < 0.10@ which does not implement
+-- @instance NFData@, to support @ghc <= 7.4 at .
+--
+-- Note that we only @deepSeq@ for the purpose of correct benchmarking.
+-- Thus, a simply non-forcing @return@ would be a possible implementation.
+
+returnForcedByteString :: Monad m => L.ByteString -> m L.ByteString
+#if MIN_VERSION_bytestring(0,10,0)
+returnForcedByteString bs = return $!! bs
+#else
+returnForcedByteString bs = return $! bs
+#endif
+
-- Note that the Binary instance for Int writes 64 bits, but throws
-- away the 32 high bits when reading (at the time of writing, on
-- 32-bit machines). Word64 does not have these problems.
currentInterfaceVersion :: Word64
-currentInterfaceVersion = 20140828 * 10 + 0
+currentInterfaceVersion = 20141018 * 10 + 0
-- | Constructor tag (maybe omitted) and argument indices.
@@ -106,19 +129,63 @@ type HashTable k v = H.CuckooHashTable k v
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).
+data FreshAndReuse = FreshAndReuse
+ { farFresh :: !Int32 -- ^ Number of hash map misses.
+ , farReuse :: !Int32 -- ^ Number of hash map hits.
+ }
+
+farEmpty :: FreshAndReuse
+farEmpty = FreshAndReuse 0 0
+
+lensFresh :: Lens' Int32 FreshAndReuse
+lensFresh f r = f (farFresh r) <&> \ i -> r { farFresh = i }
+
+lensReuse :: Lens' Int32 FreshAndReuse
+lensReuse f r = f (farReuse r) <&> \ i -> r { farReuse = i }
+
-- | State of the the encoder.
-data Dict = Dict{ nodeD :: !(HashTable Node Int32)
- , stringD :: !(HashTable String Int32)
- , integerD :: !(HashTable Integer Int32)
- , doubleD :: !(HashTable Double Int32)
- , termD :: !(HashTable (Ptr Term) Int32)
- , nodeC :: !(IORef Int32) -- counters for fresh indexes
- , stringC :: !(IORef Int32)
- , integerC :: !(IORef Int32)
- , doubleC :: !(IORef Int32)
- , sharingStats :: !(IORef (Int32, Int32))
- , fileMod :: !SourceToModule
- }
+data Dict = Dict
+ { nodeD :: !(HashTable Node Int32)
+ , stringD :: !(HashTable String Int32)
+ , integerD :: !(HashTable Integer Int32)
+ , doubleD :: !(HashTable Double Int32)
+ , termD :: !(HashTable (Ptr Term) Int32)
+ , nodeC :: !(IORef FreshAndReuse) -- counters for fresh indexes
+ , stringC :: !(IORef FreshAndReuse)
+ , integerC :: !(IORef FreshAndReuse)
+ , doubleC :: !(IORef FreshAndReuse)
+ , termC :: !(IORef FreshAndReuse)
+ , stats :: !(HashTable String Int32)
+ , collectStats :: Bool
+ -- ^ If @True@ collect in @stats@ the quantities of
+ -- calls to @icode@ for each @Typeable a at .
+ , fileMod :: !SourceToModule
+ }
+
+-- | Creates an empty dictionary.
+emptyDict
+ :: Bool
+ -- ^ Collect statistics for @icode@ calls?
+ -> SourceToModule
+ -- ^ Maps file names to the corresponding module names.
+ -- Must contain a mapping for every file name that is later encountered.
+ -> IO Dict
+emptyDict collectStats fileMod = Dict
+ <$> H.new
+ <*> H.new
+ <*> H.new
+ <*> H.new
+ <*> H.new
+ <*> newIORef farEmpty
+ <*> newIORef farEmpty
+ <*> newIORef farEmpty
+ <*> newIORef farEmpty
+ <*> newIORef farEmpty
+ <*> H.new
+ <*> pure collectStats
+ <*> pure fileMod
-- | Universal type, wraps everything.
data U = forall a . Typeable a => U !a
@@ -149,7 +216,7 @@ type S a = ReaderT Dict IO a
-- 'TCM' is not used because the associated overheads would make
-- decoding slower.
-type R a = ErrorT TypeError (StateT St IO) a
+type R a = ExceptT TypeError (StateT St IO) a
-- | Throws an error which is suitable when the data stream is
-- malformed.
@@ -158,31 +225,69 @@ malformed :: R a
malformed = throwError $ GenericError "Malformed input."
class Typeable a => EmbPrj a where
- icode :: a -> S Int32 -- ^ Serialization.
+ icode :: a -> S Int32 -- ^ Serialization (wrapper).
+ icod_ :: a -> S Int32 -- ^ Serialization (worker).
value :: Int32 -> R a -- ^ Deserialization.
+ icode a = do
+ tickICode a
+ icod_ a
+
+-- | Increase entry for @a@ in 'stats'.
+tickICode :: forall a. Typeable a => a -> S ()
+tickICode _ = whenM (asks collectStats) $ do
+ let key = "icode " ++ show (typeOf (undefined :: a))
+ hmap <- asks stats
+ liftIO $ do
+ n <- fromMaybe 0 <$> H.lookup hmap key
+ H.insert hmap key $! n + 1
+
-- | Encodes something. To ensure relocatability file paths in
-- positions are replaced with module names.
encode :: EmbPrj a => a -> TCM L.ByteString
encode a = do
+ collectStats <- hasVerbosity "profile.serialize" 20
fileMod <- sourceToModule
- newD@(Dict nD sD iD dD _ _ _ _ _ stats _) <- liftIO $ emptyDict fileMod
+ newD@(Dict nD sD iD dD _ nC sC iC dC tC stats _ _) <- liftIO $
+ emptyDict collectStats fileMod
root <- liftIO $ runReaderT (icode a) newD
nL <- benchSort $ l nD
sL <- benchSort $ l sD
iL <- benchSort $ l iD
dL <- benchSort $ l dD
- (shared, total) <- liftIO $ readIORef stats
- let x = B.encode currentInterfaceVersion `L.append`
- G.compress (B.encode (root, nL, sL, iL, dL))
+ -- Record reuse statistics.
verboseS "profile.sharing" 10 $ do
- tickN "pointers (reused)" $ fromIntegral shared
- tickN "pointers" $ fromIntegral total
+ statistics "pointers" tC
+ verboseS "profile.serialize" 10 $ do
+ statistics "Integer" iC
+ statistics "String" sC
+ statistics "Double" dC
+ statistics "Node" nC
+ when collectStats $ do
+ stats <- Map.fromList . map (second toInteger) <$> do
+ liftIO $ H.toList stats
+ modifyStatistics $ Map.union stats
+ -- Encode hashmaps and root, and compress.
+ bits1 <- billSub [ Bench.Serialization, Bench.BinaryEncode ] $
+ returnForcedByteString $ B.encode (root, nL, sL, iL, dL)
+ let compressParams = G.defaultCompressParams
+ { G.compressLevel = G.bestSpeed
+ , G.compressStrategy = G.huffmanOnlyStrategy
+ }
+ cbits <- billSub [ Bench.Serialization, Bench.Compress ] $
+ returnForcedByteString $ G.compressWith compressParams bits1
+ let x = B.encode currentInterfaceVersion `L.append` cbits
return x
where
l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h
benchSort = billTo [Bench.Serialization, Bench.Sort] . liftIO
+ statistics :: String -> IORef FreshAndReuse -> TCM ()
+ statistics kind ioref = do
+ FreshAndReuse fresh reused <- liftIO $ readIORef ioref
+ tickN (kind ++ " (fresh)") $ fromIntegral fresh
+ tickN (kind ++ " (reused)") $ fromIntegral reused
+
-- encode :: EmbPrj a => a -> TCM L.ByteString
-- encode a = do
@@ -220,7 +325,7 @@ runGetState g s n = feed (B.runGetIncremental g) (L.toChunks s)
decode :: EmbPrj a => L.ByteString -> TCM (Maybe a)
decode s = do
- mf <- stModuleToSource <$> get
+ mf <- use stModuleToSource
incs <- getIncludeDirs
-- Note that B.runGetState and G.decompress can raise errors if the
@@ -245,12 +350,12 @@ decode s = do
st <- St (ar nL) (ar sL) (ar iL) (ar dL)
<$> liftIO H.new
<*> return mf <*> return incs
- (r, st) <- runStateT (runErrorT (value r)) st
+ (r, st) <- runStateT (runExceptT (value r)) st
return (Just (modFile st), r)
case mf of
Nothing -> return ()
- Just mf -> modify $ \s -> s { stModuleToSource = mf }
+ Just mf -> stModuleToSource .= mf
case r of
Right x -> return (Just x)
@@ -298,15 +403,15 @@ decodeFile :: FilePath -> TCM (Maybe Interface)
decodeFile f = decodeInterface =<< liftIO (L.readFile f)
instance EmbPrj String where
- icode = icodeX stringD stringC
+ icod_ = icodeString
value i = (! i) `fmap` gets stringE
instance EmbPrj Integer where
- icode = icodeX integerD integerC
+ icod_ = icodeInteger
value i = (! i) `fmap` gets integerE
instance EmbPrj Word64 where
- icode i = icode2' (int32 q) (int32 r)
+ icod_ i = icode2' (int32 q) (int32 r)
where (q, r) = quotRem i (2^32)
int32 :: Word64 -> Int32
int32 = fromIntegral
@@ -315,52 +420,52 @@ instance EmbPrj Word64 where
n = 2^32
instance EmbPrj Int32 where
- icode i = return i
+ icod_ i = return i
value i = return i
instance EmbPrj Int where
- icode i = return (fromIntegral i)
+ icod_ i = return (fromIntegral i)
value i = return (fromIntegral i)
instance EmbPrj Char where
- icode c = return (fromIntegral $ fromEnum c)
+ icod_ c = return (fromIntegral $ fromEnum c)
value i = return (toEnum $ fromInteger $ toInteger i)
instance EmbPrj Double where
- icode = icodeX doubleD doubleC
+ icod_ = icodeDouble
value i = (! i) `fmap` gets doubleE
instance EmbPrj () where
- icode () = icode0'
+ icod_ () = icode0'
value = vcase valu where valu [] = valu0 ()
valu _ = malformed
instance (EmbPrj a, EmbPrj b) => EmbPrj (a, b) where
- icode (a, b) = icode2' a b
+ icod_ (a, b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 (,) a b
valu _ = malformed
instance (EmbPrj a, EmbPrj b, EmbPrj c) => EmbPrj (a, b, c) where
- icode (a, b, c) = icode3' a b c
+ icod_ (a, b, c) = icode3' a b c
value = vcase valu where valu [a, b, c] = valu3 (,,) a b c
valu _ = malformed
instance EmbPrj a => EmbPrj (Maybe a) where
- icode Nothing = icode0'
- icode (Just x) = icode1' x
+ icod_ Nothing = icode0'
+ icod_ (Just x) = icode1' x
value = vcase valu where valu [] = valu0 Nothing
valu [x] = valu1 Just x
valu _ = malformed
instance EmbPrj Bool where
- icode True = icode0'
- icode False = icode0 0
+ icod_ True = icode0'
+ icod_ False = icode0 0
value = vcase valu where valu [] = valu0 True
valu [0] = valu0 False
valu _ = malformed
instance EmbPrj AbsolutePath where
- icode file = do
+ icod_ file = do
mm <- Map.lookup file <$> asks fileMod
case mm of
Just m -> icode m
@@ -377,19 +482,19 @@ instance EmbPrj AbsolutePath where
Right f -> return f
instance EmbPrj Position where
- icode (P.Pn file pos line col) = icode4' file pos line col
+ icod_ (P.Pn file pos line col) = icode4' file pos line col
value = vcase valu
where
valu [f, p, l, c] = valu4 P.Pn f p l c
valu _ = malformed
instance EmbPrj TopLevelModuleName where
- icode (TopLevelModuleName a) = icode1' a
+ icod_ (TopLevelModuleName a) = icode1' a
value = vcase valu where valu [a] = valu1 TopLevelModuleName a
valu _ = malformed
instance EmbPrj a => EmbPrj [a] where
- icode xs = icodeN =<< mapM icode xs
+ icod_ xs = icodeN =<< mapM icode xs
value = vcase (mapM value)
-- icode [] = icode0'
-- icode (x : xs) = icode2' x xs
@@ -398,63 +503,63 @@ instance EmbPrj a => EmbPrj [a] where
-- valu _ = malformed
instance (Ord a, Ord b, EmbPrj a, EmbPrj b) => EmbPrj (BiMap a b) where
- icode m = icode (BiMap.toList m)
+ icod_ m = icode (BiMap.toList m)
value m = BiMap.fromList <$> value m
instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where
- icode m = icode (Map.toList m)
+ icod_ m = icode (Map.toList m)
value m = Map.fromList `fmap` value m
instance (Ord a, EmbPrj a) => EmbPrj (Set a) where
- icode s = icode (Set.toList s)
+ icod_ s = icode (Set.toList s)
value s = Set.fromList `fmap` value s
instance EmbPrj P.Interval where
- icode (P.Interval p q) = icode2' p q
+ icod_ (P.Interval p q) = icode2' p q
value = vcase valu where valu [p, q] = valu2 P.Interval p q
valu _ = malformed
instance EmbPrj Range where
- icode (P.Range is) = icode1' is
+ icod_ (P.Range is) = icode1' is
value = vcase valu where valu [is] = valu1 P.Range is
valu _ = malformed
instance EmbPrj HR.Range where
- icode (HR.Range a b) = icode2' a b
+ icod_ (HR.Range a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 HR.Range a b
valu _ = malformed
instance EmbPrj C.Name where
- icode (C.NoName a b) = icode2 0 a b
- icode (C.Name r xs) = icode2' r xs
+ icod_ (C.NoName a b) = icode2 0 a b
+ icod_ (C.Name r xs) = icode2' r xs
value = vcase valu where valu [0, a, b] = valu2 C.NoName a b
valu [r, xs] = valu2 C.Name r xs
valu _ = malformed
instance EmbPrj NamePart where
- icode Hole = icode0'
- icode (Id a) = icode1' a
+ icod_ Hole = icode0'
+ icod_ (Id a) = icode1' a
value = vcase valu where valu [] = valu0 Hole
valu [a] = valu1 Id a
valu _ = malformed
instance EmbPrj C.QName where
- icode (Qual a b) = icode2' a b
- icode (C.QName a ) = icode1' a
+ icod_ (Qual a b) = icode2' a b
+ icod_ (C.QName a ) = icode1' a
value = vcase valu where valu [a, b] = valu2 Qual a b
valu [a] = valu1 C.QName a
valu _ = malformed
instance EmbPrj Scope where
- icode (Scope a b c d e) = icode5' a b c d e
+ icod_ (Scope a b c d e) = icode5' a b c d e
value = vcase valu where valu [a, b, c, d, e] = valu5 Scope a b c d e
valu _ = malformed
instance EmbPrj NameSpaceId where
- icode PublicNS = icode0'
- icode PrivateNS = icode0 1
- icode ImportedNS = icode0 2
- icode OnlyQualifiedNS = icode0 3
+ icod_ PublicNS = icode0'
+ icod_ PrivateNS = icode0 1
+ icod_ ImportedNS = icode0 2
+ icod_ OnlyQualifiedNS = icode0 3
value = vcase valu where valu [] = valu0 PublicNS
valu [1] = valu0 PrivateNS
valu [2] = valu0 ImportedNS
@@ -462,44 +567,44 @@ instance EmbPrj NameSpaceId where
valu _ = malformed
instance EmbPrj Access where
- icode PrivateAccess = icode0 0
- icode PublicAccess = icode0'
- icode OnlyQualified = icode0 2
+ icod_ PrivateAccess = icode0 0
+ icod_ PublicAccess = icode0'
+ icod_ OnlyQualified = icode0 2
value = vcase valu where valu [0] = valu0 PrivateAccess
valu [] = valu0 PublicAccess
valu [2] = valu0 OnlyQualified
valu _ = malformed
instance EmbPrj NameSpace where
- icode (NameSpace a b) = icode2' a b
+ icod_ (NameSpace a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 NameSpace a b
valu _ = malformed
instance EmbPrj WhyInScope where
- icode Defined = icode0'
- icode (Opened a b) = icode2 0 a b
- icode (Applied a b) = icode2 1 a b
+ icod_ Defined = icode0'
+ icod_ (Opened a b) = icode2 0 a b
+ icod_ (Applied a b) = icode2 1 a b
value = vcase valu where valu [] = valu0 Defined
valu [0, a, b] = valu2 Opened a b
valu [1, a, b] = valu2 Applied a b
valu _ = malformed
instance EmbPrj AbstractName where
- icode (AbsName a b c) = icode3' a b c
+ icod_ (AbsName a b c) = icode3' a b c
value = vcase valu where valu [a, b, c] = valu3 AbsName a b c
valu _ = malformed
instance EmbPrj AbstractModule where
- icode (AbsModule a b) = icode2' a b
+ icod_ (AbsModule a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 AbsModule a b
valu _ = malformed
instance EmbPrj KindOfName where
- icode DefName = icode0'
- icode ConName = icode0 1
- icode FldName = icode0 2
- icode PatternSynName = icode0 3
- icode QuotableName = icode0 4
+ icod_ DefName = icode0'
+ icod_ ConName = icode0 1
+ icod_ FldName = icode0 2
+ icod_ PatternSynName = icode0 3
+ icod_ QuotableName = icode0 4
value = vcase valu where valu [] = valu0 DefName
valu [1] = valu0 ConName
valu [2] = valu0 FldName
@@ -508,85 +613,93 @@ instance EmbPrj KindOfName where
valu _ = malformed
instance EmbPrj Agda.Syntax.Fixity.Fixity where
- icode (LeftAssoc a b) = icode2 0 a b
- icode (RightAssoc a b) = icode2 1 a b
- icode (NonAssoc a b) = icode2' a b
+ icod_ (LeftAssoc a b) = icode2 0 a b
+ icod_ (RightAssoc a b) = icode2 1 a b
+ icod_ (NonAssoc a b) = icode2' a b
value = vcase valu where valu [0, a, b] = valu2 LeftAssoc a b
valu [1, a, b] = valu2 RightAssoc a b
valu [a, b] = valu2 NonAssoc a b
valu _ = malformed
instance EmbPrj Agda.Syntax.Fixity.Fixity' where
- icode (Fixity' a b) = icode2' a b
+ icod_ (Fixity' a b) = icode2' a b
value = vcase valu where valu [a,b] = valu2 Fixity' a b
valu _ = malformed
instance EmbPrj GenPart where
- icode (BindHole a) = icode1 0 a
- icode (NormalHole a) = icode1 1 a
- icode (IdPart a) = icode1' a
- value = vcase valu where valu [0, a] = valu1 BindHole a
- valu [1, a] = valu1 NormalHole a
- valu [a] = valu1 IdPart a
- valu _ = malformed
+ icod_ (BindHole a) = icode1 0 a
+ icod_ (NormalHole a) = icode1 1 a
+ icod_ (IdPart a) = icode1' a
+ value = vcase valu where valu [0, a] = valu1 BindHole a
+ valu [1, a] = valu1 NormalHole a
+ valu [a] = valu1 IdPart a
+ valu _ = malformed
instance EmbPrj A.QName where
- icode (A.QName a b) = icode2' a b
+ icod_ (A.QName a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 A.QName a b
valu _ = malformed
instance EmbPrj A.AmbiguousQName where
- icode (A.AmbQ a) = icode a
+ icod_ (A.AmbQ a) = icode a
value n = A.AmbQ `fmap` value n
instance EmbPrj A.ModuleName where
- icode (A.MName a) = icode a
+ icod_ (A.MName a) = icode a
value n = A.MName `fmap` value n
instance EmbPrj A.Name where
- icode (A.Name a b c d) = icode4' a b c d
+ icod_ (A.Name a b c d) = icode4' a b c d
value = vcase valu where valu [a, b, c, d] = valu4 A.Name a b c d
valu _ = malformed
instance (EmbPrj s, EmbPrj t) => EmbPrj (Named s t) where
- icode (Named a b) = icode2' a b
+ icod_ (Named a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 Named a b
valu _ = malformed
instance EmbPrj a => EmbPrj (Ranged a) where
- icode (Ranged r x) = icode2' r x
+ icod_ (Ranged r x) = icode2' r x
value = vcase valu where valu [r, x] = valu2 Ranged r x
valu _ = malformed
+instance EmbPrj LocalVar where
+ icod_ (LocalVar a) = icode1' a
+ icod_ (ShadowedVar a b) = icode2' a b
+ value = vcase valu where valu [a] = valu1 LocalVar a
+ valu [a, b] = valu2 ShadowedVar a b
+ valu _ = malformed
+
-- Only used for pattern synonyms
instance EmbPrj A.Expr where
- icode (A.Var n) = icode1 0 n
- icode (A.Def n) = icode1 1 n
- icode (A.Con ns) = icode1 2 ns
- icode (A.Lit l) = icode1 3 l
- icode (A.QuestionMark{}) = icode0 4
- icode (A.Underscore _) = icode0 5
- icode (A.App _ a b) = icode2 6 a b
- icode (A.WithApp _ a b) = icode2 7 a b
- icode (A.Lam _ a b) = icode2 8 a b
- icode (A.AbsurdLam _ a) = icode1 9 a
- icode (A.ExtendedLam _ _ _ _) = __IMPOSSIBLE__
- icode (A.Pi _ a b) = icode2 11 a b
- icode (A.Fun _ a b) = icode2 12 a b
- icode (A.Set _ a) = icode1 13 a
- icode (A.Prop _) = icode0 14
- icode (A.Let _ _ _) = __IMPOSSIBLE__
- icode (A.ETel a) = icode1 16 a
- icode (A.Rec _ a) = icode1 17 a
- icode (A.RecUpdate _ a b) = icode2 18 a b
- icode (A.ScopedExpr a b) = icode2 19 a b
- icode (A.QuoteGoal _ a b) = icode2 20 a b
- icode (A.QuoteContext _ a b) = icode2 21 a b
- icode (A.Quote _) = icode0 22
- icode (A.QuoteTerm _) = icode0 23
- icode (A.Unquote _) = icode0 24
- icode (A.DontCare a) = icode1 25 a
- icode (A.PatternSyn a) = icode1 26 a
+ icod_ (A.Var n) = icode1 0 n
+ icod_ (A.Def n) = icode1 1 n
+ icod_ (A.Con ns) = icode1 2 ns
+ icod_ (A.Lit l) = icode1 3 l
+ icod_ (A.QuestionMark{}) = icode0 4
+ icod_ (A.Underscore _) = icode0 5
+ icod_ (A.App _ a b) = icode2 6 a b
+ icod_ (A.WithApp _ a b) = icode2 7 a b
+ icod_ (A.Lam _ a b) = icode2 8 a b
+ icod_ (A.AbsurdLam _ a) = icode1 9 a
+ icod_ (A.ExtendedLam _ _ _ _) = __IMPOSSIBLE__
+ icod_ (A.Pi _ a b) = icode2 11 a b
+ icod_ (A.Fun _ a b) = icode2 12 a b
+ icod_ (A.Set _ a) = icode1 13 a
+ icod_ (A.Prop _) = icode0 14
+ icod_ (A.Let _ _ _) = __IMPOSSIBLE__
+ icod_ (A.ETel a) = icode1 16 a
+ icod_ (A.Rec _ a) = icode1 17 a
+ icod_ (A.RecUpdate _ a b) = icode2 18 a b
+ icod_ (A.ScopedExpr a b) = icode2 19 a b
+ icod_ (A.QuoteGoal _ a b) = icode2 20 a b
+ icod_ (A.QuoteContext _ a b) = icode2 21 a b
+ icod_ (A.Quote _) = icode0 22
+ icod_ (A.QuoteTerm _) = icode0 23
+ icod_ (A.Unquote _) = icode0 24
+ icod_ (A.DontCare a) = icode1 25 a
+ icod_ (A.PatternSyn a) = icode1 26 a
+ icod_ (A.Proj a) = icode1 27 a
value = vcase valu
where
@@ -615,21 +728,22 @@ instance EmbPrj A.Expr where
valu [24] = valu0 (A.Unquote i)
valu [25, a] = valu1 A.DontCare a
valu [26, a] = valu1 A.PatternSyn a
+ valu [27, a] = valu1 A.Proj a
valu _ = malformed
i = ExprRange noRange
instance EmbPrj A.Pattern where
- icode (A.VarP a) = icode1 0 a
- icode (A.ConP _ a b) = icode2 1 a b
- icode (A.DefP _ a b) = icode2 2 a b
- icode (A.WildP _) = icode0 3
- icode (A.AsP _ a b) = icode2 4 a b
- icode (A.DotP _ a) = icode1 5 a
- icode (A.AbsurdP _) = icode0 6
- icode (A.LitP a) = icode1 7 a
- icode (A.ImplicitP _) = icode0 8
- icode (A.PatternSynP _ a b) = icode2 9 a b
+ icod_ (A.VarP a) = icode1 0 a
+ icod_ (A.ConP _ a b) = icode2 1 a b
+ icod_ (A.DefP _ a b) = icode2 2 a b
+ icod_ (A.WildP _) = icode0 3
+ icod_ (A.AsP _ a b) = icode2 4 a b
+ icod_ (A.DotP _ a) = icode1 5 a
+ icod_ (A.AbsurdP _) = icode0 6
+ icod_ (A.LitP a) = icode1 7 a
+ icod_ (A.ImplicitP _) = icode0 8
+ icod_ (A.PatternSynP _ a b) = icode2 9 a b
value = vcase valu
where
@@ -648,18 +762,18 @@ instance EmbPrj A.Pattern where
i = patNoRange
instance EmbPrj A.LamBinding where
- icode (A.DomainFree i e) = icode2 0 i e
- icode (A.DomainFull a) = icode1 1 a
+ icod_ (A.DomainFree i e) = icode2 0 i e
+ icod_ (A.DomainFull a) = icode1 1 a
value = vcase valu where valu [0, i, e] = valu2 A.DomainFree i e
valu [1, a] = valu1 A.DomainFull a
valu _ = malformed
instance EmbPrj A.LetBinding where
- icode (A.LetBind _ a b c d) = icode4 0 a b c d
- icode (A.LetPatBind _ a b ) = icode2 1 a b
- icode (A.LetApply _ _ _ _ _) = icode0 2
- icode (A.LetOpen _ _) = icode0 2
+ icod_ (A.LetBind _ a b c d) = icode4 0 a b c d
+ icod_ (A.LetPatBind _ a b ) = icode2 1 a b
+ icod_ (A.LetApply _ _ _ _ _) = icode0 2
+ icod_ (A.LetOpen _ _) = icode0 2
value = vcase valu
where
@@ -670,100 +784,100 @@ instance EmbPrj A.LetBinding where
valu _ = malformed
instance EmbPrj A.TypedBindings where
- icode (A.TypedBindings a b) = icode2' a b
+ icod_ (A.TypedBindings a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 A.TypedBindings a b
valu _ = malformed
instance EmbPrj A.TypedBinding where
- icode (A.TBind a b c) = icode3 0 a b c
- icode (A.TLet a b) = icode2 1 a b
+ icod_ (A.TBind a b c) = icode3 0 a b c
+ icod_ (A.TLet a b) = icode2 1 a b
value = vcase valu where valu [0, a, b, c] = valu3 A.TBind a b c
valu [1, a, b] = valu2 A.TLet a b
valu _ = malformed
instance EmbPrj c => EmbPrj (Agda.Syntax.Common.ArgInfo c) where
- icode (ArgInfo h r cs) = icode3' h r cs
+ icod_ (ArgInfo h r cs) = icode3' h r cs
value = vcase valu where valu [h, r, cs] = valu3 ArgInfo h r cs
valu _ = malformed
instance EmbPrj NameId where
- icode (NameId a b) = icode2' a b
+ icod_ (NameId a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 NameId a b
valu _ = malformed
instance EmbPrj Signature where
- icode (Sig a b) = icode2' a b
+ icod_ (Sig a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 Sig a b
valu _ = malformed
instance (Eq k, Hashable k, EmbPrj k, EmbPrj v) => EmbPrj (HashMap k v) where
- icode m = icode (HMap.toList m)
+ icod_ m = icode (HMap.toList m)
value m = HMap.fromList `fmap` value m
instance EmbPrj Section where
- icode (Section a b) = icode2' a b
+ icod_ (Section a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 Section a b
valu _ = malformed
instance EmbPrj Telescope where
- icode EmptyTel = icode0'
- icode (ExtendTel a b) = icode2' a b
+ icod_ EmptyTel = icode0'
+ icod_ (ExtendTel a b) = icode2' a b
value = vcase valu where valu [] = valu0 EmptyTel
valu [a, b] = valu2 ExtendTel a b
valu _ = malformed
instance EmbPrj Permutation where
- icode (Perm a b) = icode2' a b
+ icod_ (Perm a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 Perm a b
valu _ = malformed
instance EmbPrj a => EmbPrj (Drop a) where
- icode (Drop a b) = icode2' a b
+ icod_ (Drop a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 Drop a b
valu _ = malformed
instance EmbPrj a => EmbPrj (Elim' a) where
- icode (Apply a) = icode1' a
- icode (Proj a) = icode1 0 a
+ icod_ (Apply a) = icode1' a
+ icod_ (Proj a) = icode1 0 a
value = vcase valu where valu [a] = valu1 Apply a
valu [0, a] = valu1 Proj a
valu _ = malformed
instance (EmbPrj a, EmbPrj c) => EmbPrj (Agda.Syntax.Common.Arg c a) where
- icode (Arg i e) = icode2' i e
+ icod_ (Arg i e) = icode2' i e
value = vcase valu where valu [i, e] = valu2 Arg i e
valu _ = malformed
instance (EmbPrj a, EmbPrj c) => EmbPrj (Agda.Syntax.Common.Dom c a) where
- icode (Dom i e) = icode2' i e
+ icod_ (Dom i e) = icode2' i e
value = vcase valu where valu [i, e] = valu2 Dom i e
valu _ = malformed
instance EmbPrj Agda.Syntax.Common.Induction where
- icode Inductive = icode0'
- icode CoInductive = icode0 1
+ icod_ Inductive = icode0'
+ icod_ CoInductive = icode0 1
value = vcase valu where valu [] = valu0 Inductive
valu [1] = valu0 CoInductive
valu _ = malformed
instance EmbPrj Agda.Syntax.Common.Hiding where
- icode Hidden = icode0 0
- icode NotHidden = icode0'
- icode Instance = icode0 2
+ icod_ Hidden = icode0 0
+ icod_ NotHidden = icode0'
+ icod_ Instance = icode0 2
value = vcase valu where valu [0] = valu0 Hidden
valu [] = valu0 NotHidden
valu [2] = valu0 Instance
valu _ = malformed
instance EmbPrj Agda.Syntax.Common.Relevance where
- icode Relevant = icode0'
- icode Irrelevant = icode0 1
- icode Forced = icode0 2
- icode NonStrict = icode0 3
- icode UnusedArg = icode0 4
+ icod_ Relevant = icode0'
+ icod_ Irrelevant = icode0 1
+ icod_ Forced = icode0 2
+ icod_ NonStrict = icode0 3
+ icod_ UnusedArg = icode0 4
value = vcase valu where valu [] = valu0 Relevant
valu [1] = valu0 Irrelevant
valu [2] = valu0 Forced
@@ -772,42 +886,44 @@ instance EmbPrj Agda.Syntax.Common.Relevance where
valu _ = malformed
instance EmbPrj I.ConHead where
- icode (ConHead a b) = icode2' a b
- value = vcase valu where valu [a, b] = valu2 ConHead a b
- valu _ = malformed
+ icod_ (ConHead a b c) = icode3' a b c
+ value = vcase valu where valu [a, b, c] = valu3 ConHead a b c
+ valu _ = malformed
instance EmbPrj I.Type where
- icode (El a b) = icode2' a b
+ icod_ (El a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 El a b
valu _ = malformed
instance (EmbPrj a) => EmbPrj (I.Abs a) where
- icode (NoAbs a b) = icode2 0 a b
- icode (Abs a b) = icode2' a b
+ icod_ (NoAbs a b) = icode2 0 a b
+ icod_ (Abs a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 Abs a b
valu [0, a, b] = valu2 NoAbs a b
valu _ = malformed
instance EmbPrj I.Term where
- icode (Var a b) = icode2 0 a b
- icode (Lam a b) = icode2 1 a b
- icode (Lit a ) = icode1 2 a
- icode (Def a b) = icode2 3 a b
- icode (Con a b) = icode2 4 a b
- icode (Pi a b) = icode2 5 a b
- icode (Sort a ) = icode1 7 a
- icode (MetaV a b) = __IMPOSSIBLE__
- icode ExtLam{} = __IMPOSSIBLE__
- icode (DontCare a ) = icode1 8 a
- icode (Level a ) = icode1 9 a
- icode (Shared p) = do
+ icod_ (Var a b) = icode2 0 a b
+ icod_ (Lam a b) = icode2 1 a b
+ icod_ (Lit a ) = icode1 2 a
+ icod_ (Def a b) = icode2 3 a b
+ icod_ (Con a b) = icode2 4 a b
+ icod_ (Pi a b) = icode2 5 a b
+ icod_ (Sort a ) = icode1 7 a
+ icod_ (MetaV a b) = __IMPOSSIBLE__
+ icod_ ExtLam{} = __IMPOSSIBLE__
+ icod_ (DontCare a ) = icode1 8 a
+ icod_ (Level a ) = icode1 9 a
+ icod_ (Shared p) = do
h <- asks termD
mi <- liftIO $ H.lookup h p
- st <- asks sharingStats
+ st <- asks termC
case mi of
- Just i -> liftIO $ modifyIORef st (\(a, b) -> ((,) $! a + 1) b) >> return i
+ Just i -> liftIO $ do
+ modifyIORef' st $ over lensReuse (+ 1)
+ return i
Nothing -> do
- liftIO $ modifyIORef st (\(a, b) -> (,) a $! b + 1)
+ liftIO $ modifyIORef' st $ over lensFresh (+1)
n <- icode (derefPtr p)
liftIO $ H.insert h p n
return n
@@ -827,42 +943,42 @@ instance EmbPrj I.Term where
valu _ = malformed
instance EmbPrj Level where
- icode (Max a) = icode1' a
+ icod_ (Max a) = icode1' a
value = vcase valu where valu [a] = valu1 Max a
valu _ = malformed
instance EmbPrj PlusLevel where
- icode (ClosedLevel a) = icode1' a
- icode (Plus a b) = icode2' a b
+ icod_ (ClosedLevel a) = icode1' a
+ icod_ (Plus a b) = icode2' a b
value = vcase valu where valu [a] = valu1 ClosedLevel a
valu [a, b] = valu2 Plus a b
valu _ = malformed
instance EmbPrj LevelAtom where
- icode (NeutralLevel a) = icode1' a
- icode (UnreducedLevel a) = icode1 1 a
- icode MetaLevel{} = __IMPOSSIBLE__
- icode BlockedLevel{} = __IMPOSSIBLE__
+ icod_ (NeutralLevel a) = icode1' a
+ icod_ (UnreducedLevel a) = icode1 1 a
+ icod_ MetaLevel{} = __IMPOSSIBLE__
+ icod_ BlockedLevel{} = __IMPOSSIBLE__
value = vcase valu where valu [a] = valu1 NeutralLevel a
valu [1, a] = valu1 UnreducedLevel a
valu _ = malformed
instance EmbPrj I.Sort where
- icode (Type a ) = icode1' a
- icode Prop = icode1 1 ()
- icode Inf = icode1 4 ()
- icode (DLub a b) = __IMPOSSIBLE__
+ icod_ (Type a ) = icode1' a
+ icod_ Prop = icode1 1 ()
+ icod_ Inf = icode1 4 ()
+ icod_ (DLub a b) = __IMPOSSIBLE__
value = vcase valu where valu [a] = valu1 Type a
valu [1, _] = valu0 Prop
valu [4, _] = valu0 Inf
valu _ = malformed
instance EmbPrj Agda.Syntax.Literal.Literal where
- icode (LitInt a b) = icode2' a b
- icode (LitFloat a b) = icode2 1 a b
- icode (LitString a b) = icode2 2 a b
- icode (LitChar a b) = icode2 3 a b
- icode (LitQName a b) = icode2 5 a b
+ icod_ (LitInt a b) = icode2' a b
+ icod_ (LitFloat a b) = icode2 1 a b
+ icod_ (LitString a b) = icode2 2 a b
+ icod_ (LitChar a b) = icode2 3 a b
+ icod_ (LitQName a b) = icode2 5 a b
value = vcase valu where valu [a, b] = valu2 LitInt a b
valu [1, a, b] = valu2 LitFloat a b
valu [2, a, b] = valu2 LitString a b
@@ -871,25 +987,25 @@ instance EmbPrj Agda.Syntax.Literal.Literal where
valu _ = malformed
instance EmbPrj DisplayForm where
- icode (Display a b c) = icode3' a b c
+ icod_ (Display a b c) = icode3' a b c
value = vcase valu where valu [a, b, c] = valu3 Display a b c
valu _ = malformed
instance EmbPrj a => EmbPrj (Open a) where
- icode (OpenThing a b) = icode2' a b
+ icod_ (OpenThing a b) = icode2' a b
value = vcase valu where valu [a, b] = valu2 OpenThing a b
valu _ = malformed
instance EmbPrj CtxId where
- icode (CtxId a) = icode a
+ icod_ (CtxId a) = icode a
value n = CtxId `fmap` value n
instance EmbPrj DisplayTerm where
- icode (DTerm a ) = icode1' a
- icode (DDot a ) = icode1 1 a
- icode (DCon a b) = icode2 2 a b
- icode (DDef a b) = icode2 3 a b
- icode (DWithApp a b c) = icode3 4 a b c
+ icod_ (DTerm a ) = icode1' a
+ icod_ (DDot a ) = icode1 1 a
+ icod_ (DCon a b) = icode2 2 a b
+ icod_ (DDef a b) = icode2 3 a b
+ icod_ (DWithApp a b c) = icode3 4 a b c
value = vcase valu where valu [a] = valu1 DTerm a
valu [1, a] = valu1 DDot a
valu [2, a, b] = valu2 DCon a b
@@ -898,34 +1014,34 @@ instance EmbPrj DisplayTerm where
valu _ = malformed
instance EmbPrj MutualId where
- icode (MutId a) = icode a
+ icod_ (MutId a) = icode a
value n = MutId `fmap` value n
instance EmbPrj Definition where
- icode (Defn rel a b c d e f g h i j) = icode11' rel a (P.killRange b) c d e f g h i j
+ icod_ (Defn rel a b c d e f g h i j) = icode11' rel a (P.killRange b) c d e f g h i j
value = vcase valu where valu [rel, a, b, c, d, e, f, g, h, i, j] = valu11 Defn rel a b c d e f g h i j
valu _ = malformed
instance EmbPrj RewriteRule where
- icode (RewriteRule a b c d e) = icode5' a b c d e
+ icod_ (RewriteRule a b c d e) = icode5' a b c d e
value = vcase valu where valu [a, b, c, d, e] = valu5 RewriteRule a b c d e
valu _ = malformed
instance EmbPrj Projection where
- icode (Projection a b c d e) = icode5' a b c d e
+ icod_ (Projection a b c d e) = icode5' a b c d e
value = vcase valu where valu [a, b, c, d, e] = valu5 Projection a b c d e
valu _ = malformed
instance EmbPrj HaskellExport where
- icode (HsExport a b) = icode2' a b
+ icod_ (HsExport a b) = icode2' a b
value = vcase valu where
valu [a,b] = valu2 HsExport a b
valu _ = malformed
instance EmbPrj HaskellRepresentation where
- icode (HsType a) = icode1' a
- icode (HsDefn a b) = icode2' a b
+ icod_ (HsType a) = icode1' a
+ icod_ (HsDefn a b) = icode2' a b
value = vcase valu where
valu [a] = valu1 HsType a
@@ -933,22 +1049,22 @@ instance EmbPrj HaskellRepresentation where
valu _ = malformed
instance EmbPrj JS.Exp where
- icode (JS.Self) = icode0 0
- icode (JS.Local i) = icode1 1 i
- icode (JS.Global i) = icode1 2 i
- icode (JS.Undefined) = icode0 3
- icode (JS.String s) = icode1 4 s
- icode (JS.Char c) = icode1 5 c
- icode (JS.Integer n) = icode1 6 n
- icode (JS.Double d) = icode1 7 d
- icode (JS.Lambda n e) = icode2 8 n e
- icode (JS.Object o) = icode1 9 o
- icode (JS.Apply e es) = icode2 10 e es
- icode (JS.Lookup e l) = icode2 11 e l
- icode (JS.If e f g) = icode3 12 e f g
- icode (JS.BinOp e op f) = icode3 13 e op f
- icode (JS.PreOp op e) = icode2 14 op e
- icode (JS.Const i) = icode1 15 i
+ icod_ (JS.Self) = icode0 0
+ icod_ (JS.Local i) = icode1 1 i
+ icod_ (JS.Global i) = icode1 2 i
+ icod_ (JS.Undefined) = icode0 3
+ icod_ (JS.String s) = icode1 4 s
+ icod_ (JS.Char c) = icode1 5 c
+ icod_ (JS.Integer n) = icode1 6 n
+ icod_ (JS.Double d) = icode1 7 d
+ icod_ (JS.Lambda n e) = icode2 8 n e
+ icod_ (JS.Object o) = icode1 9 o
+ icod_ (JS.Apply e es) = icode2 10 e es
+ icod_ (JS.Lookup e l) = icode2 11 e l
+ icod_ (JS.If e f g) = icode3 12 e f g
+ icod_ (JS.BinOp e op f) = icode3 13 e op f
+ icod_ (JS.PreOp op e) = icode2 14 op e
+ icod_ (JS.Const i) = icode1 15 i
value = vcase valu where valu [0] = valu0 JS.Self
valu [1, a] = valu1 JS.Local a
valu [2, a] = valu1 JS.Global a
@@ -968,22 +1084,22 @@ instance EmbPrj JS.Exp where
valu _ = malformed
instance EmbPrj JS.LocalId where
- icode (JS.LocalId l) = icode l
+ icod_ (JS.LocalId l) = icode l
value n = JS.LocalId `fmap` value n
instance EmbPrj JS.GlobalId where
- icode (JS.GlobalId l) = icode l
+ icod_ (JS.GlobalId l) = icode l
value n = JS.GlobalId `fmap` value n
instance EmbPrj JS.MemberId where
- icode (JS.MemberId l) = icode l
+ icod_ (JS.MemberId l) = icode l
value n = JS.MemberId `fmap` value n
instance EmbPrj Polarity where
- icode Covariant = icode0'
- icode Contravariant = icode0 1
- icode Invariant = icode0 2
- icode Nonvariant = icode0 3
+ icod_ Covariant = icode0'
+ icod_ Contravariant = icode0 1
+ icod_ Invariant = icode0 2
+ icod_ Nonvariant = icode0 3
value = vcase valu where
valu [] = valu0 Covariant
@@ -993,12 +1109,12 @@ instance EmbPrj Polarity where
valu _ = malformed
instance EmbPrj Occurrence where
- icode StrictPos = icode0'
- icode Mixed = icode0 1
- icode Unused = icode0 2
- icode GuardPos = icode0 3
- icode JustPos = icode0 4
- icode JustNeg = icode0 5
+ icod_ StrictPos = icode0'
+ icod_ Mixed = icode0 1
+ icod_ Unused = icode0 2
+ icod_ GuardPos = icode0 3
+ icod_ JustPos = icode0 4
+ icod_ JustNeg = icode0 5
value = vcase valu where
valu [] = valu0 StrictPos
@@ -1010,20 +1126,20 @@ instance EmbPrj Occurrence where
valu _ = malformed
instance EmbPrj CompiledRepresentation where
- icode (CompiledRep a b c d) = icode4' a b c d
+ icod_ (CompiledRep a b c d) = icode4' a b c d
value = vcase valu where valu [a, b, c, d] = valu4 CompiledRep a b c d
valu _ = malformed
instance EmbPrj Defn where
- icode Axiom = icode0 0
- icode (Function a b c d e f g h i j k l) = icode12 1 a b c d e f g h i j k l
- icode (Datatype a b c d e f g h i j) = icode10 2 a b c d e f g h i j
- icode (Record a b c d e f g h i j k l) = icode12 3 a b c d e f g h i j k l
- icode (Constructor a b c d e) = icode5 4 a b c d e
- icode (Primitive a b c d) = icode4 5 a b c d
+ icod_ Axiom = icode0 0
+ icod_ (Function a b c d e f g h i j k l m) = icode13 1 a b c d e f g h i j k l m
+ icod_ (Datatype a b c d e f g h i j) = icode10 2 a b c d e f g h i j
+ icod_ (Record a b c d e f g h i j k l) = icode12 3 a b c d e f g h i j k l
+ icod_ (Constructor a b c d e) = icode5 4 a b c d e
+ icod_ (Primitive a b c d) = icode4 5 a b c d
value = vcase valu where
valu [0] = valu0 Axiom
- valu [1, a, b, c, d, e, f, g, h, i, j, k, l] = valu12 Function a b c d e f g h i j k l
+ valu [1, a, b, c, d, e, f, g, h, i, j, k, l, m] = valu13 Function a b c d e f g h i j k l m
valu [2, a, b, c, d, e, f, g, h, i, j] = valu10 Datatype a b c d e f g h i j
valu [3, a, b, c, d, e, f, g, h, i, j, k, l] = valu12 Record a b c d e f g h i j k l
valu [4, a, b, c, d, e] = valu5 Constructor a b c d e
@@ -1031,23 +1147,23 @@ instance EmbPrj Defn where
valu _ = malformed
instance EmbPrj a => EmbPrj (WithArity a) where
- icode (WithArity a b) = icode2' a b
+ icod_ (WithArity a b) = icode2' a b
value = vcase valu where
valu [a, b] = valu2 WithArity a b
valu _ = malformed
instance EmbPrj a => EmbPrj (Case a) where
- icode (Branches a b c) = icode3' a b c
+ icod_ (Branches a b c) = icode3' a b c
value = vcase valu where
valu [a, b, c] = valu3 Branches a b c
valu _ = malformed
instance EmbPrj CompiledClauses where
- icode Fail = icode0'
- icode (Done a b) = icode2' a (P.killRange b)
- icode (Case a b) = icode2 2 a b
+ icod_ Fail = icode0'
+ icod_ (Done a b) = icode2' a (P.killRange b)
+ icod_ (Case a b) = icode2 2 a b
value = vcase valu where
valu [] = valu0 Fail
@@ -1056,55 +1172,55 @@ instance EmbPrj CompiledClauses where
valu _ = malformed
instance EmbPrj FunctionInverse where
- icode NotInjective = icode0'
- icode (Inverse a) = icode1' a
+ icod_ NotInjective = icode0'
+ icod_ (Inverse a) = icode1' a
value = vcase valu where valu [] = valu0 NotInjective
valu [a] = valu1 Inverse a
valu _ = malformed
instance EmbPrj TermHead where
- icode SortHead = icode0'
- icode PiHead = icode0 1
- icode (ConsHead a) = icode1 2 a
+ icod_ SortHead = icode0'
+ icod_ PiHead = icode0 1
+ icod_ (ConsHead a) = icode1 2 a
value = vcase valu where valu [] = valu0 SortHead
valu [1] = valu0 PiHead
valu [2, a] = valu1 ConsHead a
valu _ = malformed
instance EmbPrj Agda.Syntax.Common.IsAbstract where
- icode AbstractDef = icode0 0
- icode ConcreteDef = icode0'
+ icod_ AbstractDef = icode0 0
+ icod_ ConcreteDef = icode0'
value = vcase valu where valu [0] = valu0 AbstractDef
valu [] = valu0 ConcreteDef
valu _ = malformed
instance EmbPrj I.Clause where
- icode (Clause a b c d e f) = icode6' a b c d e f
+ icod_ (Clause a b c d e f) = icode6' a b c d e f
value = vcase valu where valu [a, b, c, d, e, f] = valu6 Clause a b c d e f
valu _ = malformed
instance EmbPrj I.ClauseBody where
- icode (Body a) = icode1 0 a
- icode (Bind a) = icode1' a
- icode NoBody = icode0'
+ icod_ (Body a) = icode1 0 a
+ icod_ (Bind a) = icode1' a
+ icod_ NoBody = icode0'
value = vcase valu where valu [0, a] = valu1 Body a
valu [a] = valu1 Bind a
valu [] = valu0 NoBody
valu _ = malformed
instance EmbPrj Delayed where
- icode Delayed = icode0 0
- icode NotDelayed = icode0'
+ icod_ Delayed = icode0 0
+ icod_ NotDelayed = icode0'
value = vcase valu where valu [0] = valu0 Delayed
valu [] = valu0 NotDelayed
valu _ = malformed
instance EmbPrj I.Pattern where
- icode (VarP a ) = icode1' a
- icode (ConP a b c) = icode3' a b c
- icode (LitP a ) = icode1 2 a
- icode (DotP a ) = icode1 3 a
- icode (ProjP a ) = icode1 4 a
+ icod_ (VarP a ) = icode1' a
+ icod_ (ConP a b c) = icode3' a b c
+ icod_ (LitP a ) = icode1 2 a
+ icod_ (DotP a ) = icode1 3 a
+ icod_ (ProjP a ) = icode1 4 a
value = vcase valu where valu [a] = valu1 VarP a
valu [a, b, c] = valu3 ConP a b c
valu [2, a] = valu1 LitP a
@@ -1113,23 +1229,23 @@ instance EmbPrj I.Pattern where
valu _ = malformed
instance EmbPrj a => EmbPrj (Builtin a) where
- icode (Prim a) = icode1' a
- icode (Builtin a) = icode1 1 a
+ icod_ (Prim a) = icode1' a
+ icod_ (Builtin a) = icode1 1 a
value = vcase valu where valu [a] = valu1 Prim a
valu [1, a] = valu1 Builtin a
valu _ = malformed
instance EmbPrj HP.NameKind where
- icode HP.Bound = icode0'
- icode (HP.Constructor a) = icode1 1 a
- icode HP.Datatype = icode0 2
- icode HP.Field = icode0 3
- icode HP.Function = icode0 4
- icode HP.Module = icode0 5
- icode HP.Postulate = icode0 6
- icode HP.Primitive = icode0 7
- icode HP.Record = icode0 8
- icode HP.Argument = icode0 9
+ icod_ HP.Bound = icode0'
+ icod_ (HP.Constructor a) = icode1 1 a
+ icod_ HP.Datatype = icode0 2
+ icod_ HP.Field = icode0 3
+ icod_ HP.Function = icode0 4
+ icod_ HP.Module = icode0 5
+ icod_ HP.Postulate = icode0 6
+ icod_ HP.Primitive = icode0 7
+ icod_ HP.Record = icode0 8
+ icod_ HP.Argument = icode0 9
value = vcase valu where
valu [] = valu0 HP.Bound
@@ -1145,13 +1261,13 @@ instance EmbPrj HP.NameKind where
valu _ = malformed
instance EmbPrj HP.Aspect where
- icode HP.Comment = icode0 0
- icode HP.Keyword = icode0 1
- icode HP.String = icode0 2
- icode HP.Number = icode0 3
- icode HP.Symbol = icode0'
- icode HP.PrimitiveType = icode0 5
- icode (HP.Name mk b) = icode2 6 mk b
+ icod_ HP.Comment = icode0 0
+ icod_ HP.Keyword = icode0 1
+ icod_ HP.String = icode0 2
+ icod_ HP.Number = icode0 3
+ icod_ HP.Symbol = icode0'
+ icod_ HP.PrimitiveType = icode0 5
+ icod_ (HP.Name mk b) = icode2 6 mk b
value = vcase valu where
valu [0] = valu0 HP.Comment
@@ -1164,13 +1280,13 @@ instance EmbPrj HP.Aspect where
valu _ = malformed
instance EmbPrj HP.OtherAspect where
- icode HP.Error = icode0 0
- icode HP.DottedPattern = icode0'
- icode HP.UnsolvedMeta = icode0 2
- icode HP.TerminationProblem = icode0 3
- icode HP.IncompletePattern = icode0 4
- icode HP.TypeChecks = icode0 5
- icode HP.UnsolvedConstraint = icode0 6
+ icod_ HP.Error = icode0 0
+ icod_ HP.DottedPattern = icode0'
+ icod_ HP.UnsolvedMeta = icode0 2
+ icod_ HP.TerminationProblem = icode0 3
+ icod_ HP.IncompletePattern = icode0 4
+ icod_ HP.TypeChecks = icode0 5
+ icod_ HP.UnsolvedConstraint = icode0 6
value = vcase valu where
valu [0] = valu0 HP.Error
@@ -1182,24 +1298,24 @@ instance EmbPrj HP.OtherAspect where
valu [6] = valu0 HP.UnsolvedConstraint
valu _ = malformed
-instance EmbPrj HP.MetaInfo where
- icode (HP.MetaInfo a b c d) = icode4' a b c d
+instance EmbPrj HP.Aspects where
+ icod_ (HP.Aspects a b c d) = icode4' a b c d
value = vcase valu where
- valu [a, b, c, d] = valu4 HP.MetaInfo a b c d
+ valu [a, b, c, d] = valu4 HP.Aspects a b c d
valu _ = malformed
instance EmbPrj Precedence where
- icode TopCtx = icode0'
- icode FunctionSpaceDomainCtx = icode0 1
- icode (LeftOperandCtx a) = icode1 2 a
- icode (RightOperandCtx a) = icode1 3 a
- icode FunctionCtx = icode0 4
- icode ArgumentCtx = icode0 5
- icode InsideOperandCtx = icode0 6
- icode WithFunCtx = icode0 7
- icode WithArgCtx = icode0 8
- icode DotPatternCtx = icode0 9
+ icod_ TopCtx = icode0'
+ icod_ FunctionSpaceDomainCtx = icode0 1
+ icod_ (LeftOperandCtx a) = icode1 2 a
+ icod_ (RightOperandCtx a) = icode1 3 a
+ icod_ FunctionCtx = icode0 4
+ icod_ ArgumentCtx = icode0 5
+ icod_ InsideOperandCtx = icode0 6
+ icod_ WithFunCtx = icode0 7
+ icod_ WithArgCtx = icode0 8
+ icod_ DotPatternCtx = icode0 9
value = vcase valu
where
valu [] = valu0 TopCtx
@@ -1215,19 +1331,19 @@ instance EmbPrj Precedence where
valu _ = malformed
instance EmbPrj ScopeInfo where
- icode (ScopeInfo a b c d) = icode4' a b c d
+ icod_ (ScopeInfo a b c d) = icode4' a b c d
value = vcase valu where valu [a, b, c, d] = valu4 ScopeInfo a b c d
valu _ = malformed
instance EmbPrj HP.CompressedFile where
- icode (HP.CompressedFile f) = icode1' f
+ icod_ (HP.CompressedFile f) = icode1' f
value = vcase valu
where
valu [f] = valu1 HP.CompressedFile f
valu _ = malformed
instance EmbPrj Interface where
- icode (Interface a b c d e f g h i j k) = icode11' a b c d e f g h i j k
+ icod_ (Interface a b c d e f g h i j k) = icode11' a b c d e f g h i j k
value = vcase valu
where
valu [a, b, c, d, e, f, g, h, i, j, k] = valu11 Interface a b c d e f g h i j k
@@ -1235,58 +1351,145 @@ instance EmbPrj Interface where
-- This is used for the Epic compiler backend
instance EmbPrj Epic.EInterface where
- icode (Epic.EInterface a b c d e f g h) = icode8' a b c d e f g h
+ icod_ (Epic.EInterface a b c d e f g h) = icode8' a b c d e f g h
value = vcase valu where
valu [a, b, c, d, e, f, g, h] = valu8 Epic.EInterface a b c d e f g h
valu _ = malformed
instance EmbPrj Epic.InjectiveFun where
- icode (Epic.InjectiveFun a b) = icode2' a b
+ icod_ (Epic.InjectiveFun a b) = icode2' a b
value = vcase valu where
valu [a,b] = valu2 Epic.InjectiveFun a b
valu _ = malformed
instance EmbPrj Epic.Relevance where
- icode Epic.Irr = icode0 0
- icode Epic.Rel = icode0 1
+ icod_ Epic.Irr = icode0 0
+ icod_ Epic.Rel = icode0 1
value = vcase valu where valu [0] = valu0 Epic.Irr
valu [1] = valu0 Epic.Rel
valu _ = malformed
instance EmbPrj Epic.Forced where
- icode Epic.Forced = icode0 0
- icode Epic.NotForced = icode0 1
+ icod_ Epic.Forced = icode0 0
+ icod_ Epic.NotForced = icode0 1
value = vcase valu where valu [0] = valu0 Epic.Forced
valu [1] = valu0 Epic.NotForced
valu _ = malformed
instance EmbPrj Epic.Tag where
- icode (Epic.Tag a) = icode1 0 a
- icode (Epic.PrimTag a) = icode1 1 a
+ icod_ (Epic.Tag a) = icode1 0 a
+ icod_ (Epic.PrimTag a) = icode1 1 a
value = vcase valu
where
valu [0, a] = valu1 Epic.Tag a
valu [1, a] = valu1 Epic.PrimTag a
valu _ = malformed
-icodeX :: (Eq k, Hashable k) =>
- (Dict -> HashTable k Int32) -> (Dict -> IORef Int32) ->
- k -> S Int32
+-- Specializing icodeX leads to Warning like
+-- src/full/Agda/TypeChecking/Serialise.hs:1297:1: Warning:
+-- RULE left-hand side too complicated to desugar
+-- case cobox_aQY5 of _ [Occ=Dead] { ghc-prim:GHC.Types.Eq# cobox ->
+-- icodeX @ String $dEq_aQY3 $dHashable_aQY4
+-- }
+--
+-- type ICodeX k
+-- = (Dict -> HashTable k Int32)
+-- -> (Dict -> IORef Int32)
+-- -> k -> S Int32
+-- {-# SPECIALIZE icodeX :: ICodeX String #-}
+-- {-# SPECIALIZE icodeX :: ICodeX Integer #-}
+-- {-# SPECIALIZE icodeX :: ICodeX Double #-}
+-- {-# SPECIALIZE icodeX :: ICodeX Node #-}
+
+-- Andreas, 2014-10-16 AIM XX:
+-- Inlining this increases Serialization time by 10%
+-- Makoto's theory: code size increase might lead to
+-- instruction cache misses.
+-- {-# INLINE icodeX #-}
+icodeX :: (Eq k, Hashable k)
+ => (Dict -> HashTable k Int32)
+ -> (Dict -> IORef FreshAndReuse)
+ -> k -> S Int32
icodeX dict counter key = do
d <- asks dict
c <- asks counter
liftIO $ do
mi <- H.lookup d key
case mi of
- Just i -> return i
+ Just i -> do
+ modifyIORef' c $ over lensReuse (+1)
+ return i
+ Nothing -> do
+ fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)
+ H.insert d key fresh
+ return fresh
+
+-- Instead of inlining icodeX, we manually specialize it to
+-- its four uses: Integer, String, Double, Node.
+-- Not a great gain (hardly noticeable), but not harmful.
+
+icodeInteger :: Integer -> S Int32
+icodeInteger key = do
+ d <- asks integerD
+ c <- asks integerC
+ liftIO $ do
+ mi <- H.lookup d key
+ case mi of
+ Just i -> do
+ modifyIORef' c $ over lensReuse (+1)
+ return i
+ Nothing -> do
+ fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)
+ H.insert d key fresh
+ return fresh
+
+icodeDouble :: Double -> S Int32
+icodeDouble key = do
+ d <- asks doubleD
+ c <- asks doubleC
+ liftIO $ do
+ mi <- H.lookup d key
+ case mi of
+ Just i -> do
+ modifyIORef' c $ over lensReuse (+1)
+ return i
+ Nothing -> do
+ fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)
+ H.insert d key fresh
+ return fresh
+
+icodeString :: String -> S Int32
+icodeString key = do
+ d <- asks stringD
+ c <- asks stringC
+ liftIO $ do
+ mi <- H.lookup d key
+ case mi of
+ Just i -> do
+ modifyIORef' c $ over lensReuse (+1)
+ return i
+ Nothing -> do
+ fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)
+ H.insert d key fresh
+ return fresh
+
+icodeN :: Node -> S Int32
+icodeN key = do
+ d <- asks nodeD
+ c <- asks nodeC
+ liftIO $ do
+ mi <- H.lookup d key
+ case mi of
+ Just i -> do
+ modifyIORef' c $ over lensReuse (+1)
+ return i
Nothing -> do
- fresh <- readIORef c
+ fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1)
H.insert d key fresh
- writeIORef c $! fresh + 1
return fresh
-icodeN :: [Int32] -> S Int32
-icodeN = icodeX nodeD nodeC
+-- icodeN :: [Int32] -> S Int32
+-- icodeN = icodeX nodeD nodeC
{-# INLINE vcase #-}
-- | @vcase value ix@ decodes thing represented by @ix :: Int32@
@@ -1310,6 +1513,91 @@ vcase valu = \ix -> do
liftIO $ H.insert memo (ix, aTyp) (U v)
return v
+-- Andreas, Makoto, AIM XX (2014-10-15):
+-- No performance gain for INLINE here (neutral / slighly negative).
+--
+-- {-# INLINE icode0 #-}
+-- {-# INLINE icode1 #-}
+-- {-# INLINE icode2 #-}
+-- {-# INLINE icode3 #-}
+-- {-# INLINE icode4 #-}
+-- {-# INLINE icode5 #-}
+-- {-# INLINE icode6 #-}
+-- {-# INLINE icode7 #-}
+-- {-# INLINE icode8 #-}
+-- {-# INLINE icode9 #-}
+-- {-# INLINE icode10 #-}
+-- {-# INLINE icode11 #-}
+-- {-# INLINE icode12 #-}
+-- {-# INLINE icode13 #-}
+-- {-# INLINE icode14 #-}
+
+icode0 :: Int32 -> S Int32
+
+icode1 :: EmbPrj a => Int32 -> a -> S Int32
+
+icode2 :: (EmbPrj a, EmbPrj b) =>
+ Int32 -> a -> b ->
+ S Int32
+
+icode3 :: (EmbPrj a, EmbPrj b, EmbPrj c) =>
+ Int32 -> a -> b -> c ->
+ S Int32
+
+icode4 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d) =>
+ Int32 -> a -> b -> c -> d ->
+ S Int32
+
+icode5 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e) =>
+ Int32 -> a -> b -> c -> d -> e ->
+ S Int32
+
+icode6 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f) =>
+ Int32 -> a -> b -> c -> d -> e -> f ->
+ S Int32
+
+icode7 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g ->
+ S Int32
+
+icode8 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h ->
+ S Int32
+
+icode9 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i ->
+ S Int32
+
+icode10 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j ->
+ S Int32
+
+icode11 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k ->
+ S Int32
+
+icode12 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l ->
+ S Int32
+
+icode13 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l
+ , EmbPrj m ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m ->
+ S Int32
+
+icode14 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l
+ , EmbPrj m, EmbPrj n ) =>
+ Int32 -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n ->
+ S Int32
+
icode0 tag = icodeN [tag]
icode1 tag a = icodeN . (tag :) =<< sequence [icode a]
icode2 tag a b = icodeN . (tag :) =<< sequence [icode a, icode b]
@@ -1326,6 +1614,92 @@ icode12 tag a b c d e f g h i j k l = icodeN . (tag :) =<< sequence [icode a, ic
icode13 tag a b c d e f g h i j k l m = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m]
icode14 tag a b c d e f g h i j k l m n = icodeN . (tag :) =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m, icode n]
+
+-- Andreas, Makoto, AIM XX (2014-10-15):
+-- No performance gain for INLINE here (neutral / slighly negative).
+--
+-- {-# INLINE icode0' #-}
+-- {-# INLINE icode1' #-}
+-- {-# INLINE icode2' #-}
+-- {-# INLINE icode3' #-}
+-- {-# INLINE icode4' #-}
+-- {-# INLINE icode5' #-}
+-- {-# INLINE icode6' #-}
+-- {-# INLINE icode7' #-}
+-- {-# INLINE icode8' #-}
+-- {-# INLINE icode9' #-}
+-- {-# INLINE icode10' #-}
+-- {-# INLINE icode11' #-}
+-- {-# INLINE icode12' #-}
+-- {-# INLINE icode13' #-}
+-- {-# INLINE icode14' #-}
+
+icode0' :: S Int32
+
+icode1' :: EmbPrj a => a -> S Int32
+
+icode2' :: (EmbPrj a, EmbPrj b) =>
+ a -> b ->
+ S Int32
+
+icode3' :: (EmbPrj a, EmbPrj b, EmbPrj c) =>
+ a -> b -> c ->
+ S Int32
+
+icode4' :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d) =>
+ a -> b -> c -> d ->
+ S Int32
+
+icode5' :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e) =>
+ a -> b -> c -> d -> e ->
+ S Int32
+
+icode6' :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f) =>
+ a -> b -> c -> d -> e -> f ->
+ S Int32
+
+icode7' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g ) =>
+ a -> b -> c -> d -> e -> f -> g ->
+ S Int32
+
+icode8' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h ) =>
+ a -> b -> c -> d -> e -> f -> g -> h ->
+ S Int32
+
+icode9' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i ) =>
+ a -> b -> c -> d -> e -> f -> g -> h -> i ->
+ S Int32
+
+icode10' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j ) =>
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j ->
+ S Int32
+
+icode11' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k ) =>
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k ->
+ S Int32
+
+icode12' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l ) =>
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l ->
+ S Int32
+
+icode13' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l
+ , EmbPrj m ) =>
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m ->
+ S Int32
+
+icode14' :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l
+ , EmbPrj m, EmbPrj n ) =>
+ a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n ->
+ S Int32
+
icode0' = icodeN []
icode1' a = icodeN =<< sequence [icode a]
icode2' a b = icodeN =<< sequence [icode a, icode b]
@@ -1342,6 +1716,85 @@ icode12' a b c d e f g h i j k l = icodeN =<< sequence [icode a, icode b, icode
icode13' a b c d e f g h i j k l m = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m]
icode14' a b c d e f g h i j k l m n = icodeN =<< sequence [icode a, icode b, icode c, icode d, icode e, icode f, icode g, icode h, icode i, icode j, icode k, icode l, icode m, icode n]
+valu0 :: a -> R a
+
+valu1 :: EmbPrj a => (a -> b) -> Int32 -> R b
+
+valu2 :: (EmbPrj a, EmbPrj b) =>
+ (a -> b -> c) ->
+ Int32 -> Int32 ->
+ R c
+
+valu3 :: (EmbPrj a, EmbPrj b, EmbPrj c) =>
+ (a -> b -> c -> d) ->
+ Int32 -> Int32 -> Int32 ->
+ R d
+
+valu4 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d) =>
+ (a -> b -> c -> d -> e) ->
+ Int32 -> Int32 -> Int32 -> Int32 ->
+ R e
+
+valu5 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e) =>
+ (a -> b -> c -> d -> e -> f) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R f
+
+valu6 :: (EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f) =>
+ (a -> b -> c -> d -> e -> f -> g) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R g
+
+valu7 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R h
+
+valu8 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R i
+
+valu9 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R j
+
+valu10 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R k
+
+valu11 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R l
+
+valu12 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R m
+
+valu13 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l
+ , EmbPrj m ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R n
+
+valu14 :: ( EmbPrj a, EmbPrj b, EmbPrj c, EmbPrj d, EmbPrj e, EmbPrj f
+ , EmbPrj g, EmbPrj h, EmbPrj i, EmbPrj j, EmbPrj k, EmbPrj l
+ , EmbPrj m, EmbPrj n ) =>
+ (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> m -> n -> o) ->
+ Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 ->
+ R o
+
valu0 z = return z
valu1 z a = valu0 z `ap` value a
valu2 z a b = valu1 z a `ap` value b
@@ -1357,23 +1810,3 @@ valu11 z a b c d e f g h i j k = valu10 z a b c d e f g h i j `ap` value k
valu12 z a b c d e f g h i j k l = valu11 z a b c d e f g h i j k `ap` value l
valu13 z a b c d e f g h i j k l m = valu12 z a b c d e f g h i j k l `ap` value m
valu14 z a b c d e f g h i j k l m n = valu13 z a b c d e f g h i j k l m `ap` value n
-
--- | Creates an empty dictionary.
-
-emptyDict :: SourceToModule
- -- ^ Maps file names to the corresponding module names.
- -- Must contain a mapping for every file name that is
- -- later encountered.
- -> IO Dict
-emptyDict fileMod = Dict
- <$> H.new
- <*> H.new
- <*> H.new
- <*> H.new
- <*> H.new
- <*> newIORef 0
- <*> newIORef 0
- <*> newIORef 0
- <*> newIORef 0
- <*> newIORef (0, 0)
- <*> return fileMod
diff --git a/src/full/Agda/TypeChecking/SizedTypes.hs b/src/full/Agda/TypeChecking/SizedTypes.hs
index 8400367..a1be345 100644
--- a/src/full/Agda/TypeChecking/SizedTypes.hs
+++ b/src/full/Agda/TypeChecking/SizedTypes.hs
@@ -1,10 +1,8 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.SizedTypes where
-import Control.Monad.Error
-
import Data.Function
import Data.List
import qualified Data.Map as Map
@@ -24,14 +22,16 @@ import Agda.TypeChecking.Telescope
import {-# SOURCE #-} Agda.TypeChecking.Conversion
import {-# SOURCE #-} Agda.TypeChecking.Constraints
-import qualified Agda.Utils.Warshall as W
+import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../undefined.h"
+import qualified Agda.Utils.Warshall as W
+
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -358,7 +358,7 @@ computeSizeConstraint c =
(b, m) <- sizeExpr v
return $ Just $ Leq a (m - n) b
`catchError` \ err -> case err of
- PatternErr _ -> return Nothing
+ PatternErr{} -> return Nothing
_ -> throwError err
_ -> __IMPOSSIBLE__
@@ -506,10 +506,9 @@ oldSolver metas cs = do
term (W.SizeVar j n) | j < ar = plus (var $ ar - j - 1) n
term _ = __IMPOSSIBLE__
- lam _ v = Lam defaultArgInfo $ Abs "s" v -- hiding does not matter
-
- -- convert size expression to term and abstract
- v = flip (foldr lam) [0..ar-1] $ term e
+ tel = replicate ar $ defaultArg "s"
+ -- convert size expression to term
+ v = term e
reportSDoc "tc.size.solve" 20 $ sep
[ text (show m) <+> text ":="
@@ -520,7 +519,7 @@ oldSolver metas cs = do
let isInf (W.SizeConst W.Infinite) = True
isInf _ = False
unlessM ((isJust <$> isInteractionMeta m) `and2M` return (isInf e)) $
- assignTerm m v
+ 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
index a622848..1db4933 100644
--- a/src/full/Agda/TypeChecking/SizedTypes/Solve.hs
+++ b/src/full/Agda/TypeChecking/SizedTypes/Solve.hs
@@ -1,10 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
-- | Solving size constraints under hypotheses.
--
@@ -56,8 +56,7 @@
module Agda.TypeChecking.SizedTypes.Solve where
-import Control.Monad.Error
-
+import Control.Monad ( forM )
import Data.Foldable (Foldable, foldMap)
import Data.Function
import Data.List
@@ -90,6 +89,7 @@ import Agda.TypeChecking.SizedTypes.Utils
import Agda.TypeChecking.SizedTypes.WarshallSolver as Size
import Agda.Utils.Cluster
+import Agda.Utils.Except ( MonadError(catchError) )
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.List
@@ -98,7 +98,7 @@ import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Solve size constraints involving hypotheses.
diff --git a/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs b/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs
index a5e3b9e..37ca8a7 100644
--- a/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs
+++ b/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs
@@ -1,12 +1,12 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
-- | Syntax of size expressions and constraints.
@@ -106,7 +106,7 @@ getPolarity pols x = Map.findWithDefault Least x pols
-- | Partial substitution from flexible variables to size expression.
type Solution rigid flex = Map flex (SizeExpr' rigid flex)
-emptySolution = Map.empty
+-- emptySolution = Map.empty
-- | Executing a substitution.
class Substitute r f a where
diff --git a/src/full/Agda/TypeChecking/SizedTypes/Tests.hs b/src/full/Agda/TypeChecking/SizedTypes/Tests.hs
index b44deed..3c171c7 100644
--- a/src/full/Agda/TypeChecking/SizedTypes/Tests.hs
+++ b/src/full/Agda/TypeChecking/SizedTypes/Tests.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Agda.TypeChecking.SizedTypes.Tests where
@@ -45,16 +43,20 @@ instance AsWeightRelation Label where
eval (Label cmp w) x y = eval cmp x (y `plus` w)
eval LInf _ _ = True
-prop_MeetSound (l :: Label) l' x y =
+prop_MeetSound :: Label -> Label -> Weight -> Weight -> Property
+prop_MeetSound l l' x y =
eval l x y && eval l' x y ==> eval (meet l l') x y
-prop_MeetComplete (l :: Label) l' x y =
+prop_MeetComplete :: Label -> Label -> Weight -> Weight -> Property
+prop_MeetComplete l l' x y =
eval (meet l l') x y ==> eval l x y && eval l' x y
-prop_ComposeSound (l1 :: Label) l2 x y z =
+prop_ComposeSound :: Label -> Label -> Weight -> Weight -> Weight -> Property
+prop_ComposeSound l1 l2 x y z =
eval l1 x y && eval l2 y z ==> eval (compose l1 l2) x z
-prop_ComposeComplete (l1 :: Label) l2 k z = let x = Offset k in
+prop_ComposeComplete :: Label -> Label -> Int -> Weight -> Property
+prop_ComposeComplete l1 l2 k z = let x = Offset k in
eval (compose l1 l2) x z ==>
let y = z + toWeight l2
in eval l1 x y -- && eval l2 y z -- does not hold for l2 = \infty
@@ -70,39 +72,83 @@ prop_ComposeComplete (l1 :: Label) l2 k z = let x = Offset k in
-- * Generic properties
-propCommutative o x y = x `o` y == y `o` x
+propCommutative :: Eq b => (a -> a -> b) -> a -> a -> Bool
+propCommutative o x y = x `o` y == y `o` x
+
+propAssociative :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool
propAssociative o x y z = x `o` (y `o` z) == (x `o` y) `o` z
-propIdempotent o x = (x `o` x) == x
-propUnit o u x = u `o` x == x && x `o` u == x
-propZero o z x = z `o` x == z && x `o` z == z
-propDistL o p x y z = x `o` (y `p` z) == (x `o` y) `p` (x `o` z)
-propDistR o p x y z = (x `p` y) `o` z == (x `o` z) `p` (y `o` z)
+
+propIdempotent :: Eq a => (a -> a -> a) -> a -> Bool
+propIdempotent o x = (x `o` x) == x
+
+propUnit :: Eq a => (a -> a -> a) -> a -> a -> Bool
+propUnit o u x = u `o` x == x && x `o` u == x
+
+propZero :: Eq a => (a -> a -> a) -> a -> a -> Bool
+propZero o z x = z `o` x == z && x `o` z == z
+
+propDistL :: Eq b => (a -> b -> b) -> (b -> b -> b) -> a -> b -> b -> Bool
+propDistL o p x y z = x `o` (y `p` z) == (x `o` y) `p` (x `o` z)
+
+propDistR :: Eq a => (a -> b -> a) -> (a -> a -> a) -> a -> a -> b -> Bool
+propDistR o p x y z = (x `p` y) `o` z == (x `o` z) `p` (y `o` z)
+
+propDistributive :: Eq a =>
+ (a -> a -> a) -> (a -> a -> a) -> a -> a -> a -> Bool
propDistributive o p x y z = propDistL o p x y z && propDistR o p x y z
-propSemiLattice o x y z = propCommutative o x y && propAssociative o x y z && propIdempotent o x
+propSemiLattice :: Eq a => (a -> a -> a) -> a -> a -> a -> Bool
+propSemiLattice o x y z =
+ propCommutative o x y && propAssociative o x y z && propIdempotent o x
+
+propBoundedSemiLattice :: Eq a => (a -> a -> a) -> a -> a -> a -> a -> Bool
propBoundedSemiLattice o u x y z = propSemiLattice o x y z && propUnit o u x
-propMonoid o u x y z = propAssociative o x y z && propUnit o u x
+
+propMonoid :: Eq a => (a -> a -> a) -> a -> a -> a -> a -> Bool
+propMonoid o u x y z = propAssociative o x y z && propUnit o u x
+
+propDioid :: Eq a =>
+ (a -> a -> a) -> a -> (a -> a -> a) -> a -> a -> a -> a -> Bool
propDioid p n o u x y z = propBoundedSemiLattice p n x y z
&& propMonoid o u x y z
&& propDistributive o p x y z
&& propZero o n x
-- | Properties of 'Dioid' class.
+propDioid_Gen :: Dioid a => a -> a -> a -> Bool
propDioid_Gen = propDioid meet top compose unitCompose
-- | @Weight@ instance.
-prop_Dioid_Weight x y z = propDioid_Gen (x :: Weight) y z
+prop_Dioid_Weight :: Weight -> Weight -> Weight -> Bool
+prop_Dioid_Weight x y z = propDioid_Gen x y z
-- | @Label@ instance.
-prop_SemiLattice_Label x y z = propSemiLattice meet (x :: Label) y z
-prop_Unit_Label x = propUnit meet top (x :: Label)
-prop_BoundedSemiLattice_Label x y z = propBoundedSemiLattice meet top (x :: Label) y z
-prop_Monoid_Label x y z = propMonoid compose unitCompose (x :: Label) y z
-prop_DistL_Label x y z = propDistL compose meet (x :: Label) y z
-prop_DistR_Label x y z = propDistR compose meet (x :: Label) y z
-prop_Dist_Label x y z = propDistributive compose meet (x :: Label) y z
-prop_Zero_Label x = propZero compose top (x :: Label)
-prop_Dioid_Label x y z = propDioid_Gen (x :: Label) y z
+prop_SemiLattice_Label :: Label -> Label -> Label -> Bool
+prop_SemiLattice_Label x y z = propSemiLattice meet x y z
+
+prop_Unit_Label :: Label -> Bool
+prop_Unit_Label x = propUnit meet top x
+
+prop_BoundedSemiLattice_Label :: Label -> Label -> Label -> Bool
+prop_BoundedSemiLattice_Label x y z = propBoundedSemiLattice meet top x y z
+
+prop_Monoid_Label :: Label -> Label -> Label -> Bool
+prop_Monoid_Label x y z = propMonoid compose unitCompose x y z
+
+prop_DistL_Label :: Label -> Label -> Label -> Bool
+prop_DistL_Label x y z = propDistL compose meet x y z
+
+prop_DistR_Label :: Label -> Label -> Label -> Bool
+prop_DistR_Label x y z = propDistR compose meet x y z
+
+prop_Dist_Label :: Label -> Label -> Label -> Bool
+prop_Dist_Label x y z = propDistributive compose meet x y z
+
+prop_Zero_Label :: Label -> Bool
+prop_Zero_Label x = propZero compose top x
+
+prop_Dioid_Label :: Label -> Label -> Label -> Bool
+prop_Dioid_Label x y z = propDioid_Gen x y z
------------------------------------------------------------------------
-- * All tests
diff --git a/src/full/Agda/TypeChecking/SizedTypes/Utils.hs b/src/full/Agda/TypeChecking/SizedTypes/Utils.hs
index ed188da..e030d3e 100644
--- a/src/full/Agda/TypeChecking/SizedTypes/Utils.hs
+++ b/src/full/Agda/TypeChecking/SizedTypes/Utils.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE NoMonomorphismRestriction,
- MultiParamTypeClasses #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
module Agda.TypeChecking.SizedTypes.Utils where
@@ -8,11 +7,14 @@ import Data.Functor
import qualified Debug.Trace as Debug
import Agda.Utils.Function
+debug :: Bool
debug = False
+
+trace :: String -> a -> a
trace s = applyWhen debug $ Debug.trace s
-traceM s = trace s $ pure ()
-($>) = flip (<$)
+traceM :: Applicative f => String -> f ()
+traceM s = trace s $ pure ()
class Eq a => Top a where
top :: a
diff --git a/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs b/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs
index 3f1f09e..5934a83 100644
--- a/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs
+++ b/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Agda.TypeChecking.SizedTypes.WarshallSolver where
@@ -32,7 +32,7 @@ import Agda.Utils.Graph.AdjacencyMap.Unidirectional
-- (Edge'(..), allNodes, emptyGraph, insertEdge, graphToList, graphFromList, nodes, lookupEdge, outgoing, incoming, diagonal, transClos)
import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
type Graph r f a = Graph.Graph (Node r f) (Node r f) a
@@ -41,13 +41,23 @@ type Key r f = Edge' r f ()
type Nodes r f = Graph.Nodes (Node r f)
type LabelledEdge r f = Edge' r f Label
-src = Graph.source
+src :: Edge s t e -> s
+src = Graph.source
+
+dest :: Edge s t e -> t
dest = Graph.target
+lookupEdge :: (Ord s, Ord t) => Graph.Graph s t e -> s -> t -> Maybe e
lookupEdge g s t = Graph.lookup s t g
+
+graphToList :: (Ord s, Ord t) => Graph.Graph s t e -> [Edge s t e]
graphToList = Graph.toList
+
+graphFromList :: (Ord s, Ord t) => [Edge s t e] -> Graph.Graph s t e
graphFromList = Graph.fromList
+insertEdge :: (Ord s, Ord t, MeetSemiLattice e, Top e) =>
+ Edge s t e -> Graph.Graph s t e -> Graph.Graph s t e
insertEdge e g
| isTop (label e) = g
| otherwise = Graph.insertEdgeWith meet e g
@@ -291,6 +301,7 @@ instance (Show r, Show f, Show a, Ord r, Ord f, Dioid a) => Dioid (Edge' r f a)
-- | A graph forest.
type Graphs r f a = [Graph r f a]
+emptyGraphs :: Graphs r f a
emptyGraphs = []
-- | Split a list of graphs @gs@ into those that mention node @n@ and those that do not.
@@ -547,6 +558,7 @@ instance Plus (SizeExpr' r f) Label (SizeExpr' r f) where
-- | Lower or upper bound for a flexible variable
type Bound r f = Map f (Set (SizeExpr' r f))
+emptyBound :: Bound r f
emptyBound = Map.empty
data Bounds r f = Bounds
@@ -636,10 +648,11 @@ largest hg ns
Return these edges as a map from target notes to a list of edges.
We assume the graph is reflexive-transitive.
-}
-commonSuccs :: (Ord r, Ord f, Dioid a) => Graph r f a -> [Node r f] -> Map (Node r f) [Edge' r f a]
-commonSuccs hg srcs = intersectAll $ map (buildmap . outgoing hg) srcs
+commonSuccs :: (Ord r, Ord f, Dioid a) =>
+ Graph r f a -> [Node r f] -> Map (Node r f) [Edge' r f a]
+commonSuccs hg srcs = intersectAll $ map (buildmap . outgoing hg) srcs
where
- buildmap = Map.fromList . map (\ e -> (dest e, [e]))
+ buildmap = Map.fromList . map (\ e -> (dest e, [e]))
intersectAll [] = Map.empty
intersectAll (m:ms) = foldl (Map.intersectionWith (++)) m ms
@@ -656,7 +669,8 @@ commonPreds hg tgts = intersectAll $ map (buildmap . incoming hg) tgts
intersectAll (m:ms) = foldl (Map.intersectionWith (++)) m ms
-- | Compute the sup of two different rigids or a rigid and a constant.
-lub' :: forall r f . (Ord r, Ord f, Show r, Show f) => HypGraph r f -> (Node r f, Offset) -> (Node r f, Offset) -> Maybe (SizeExpr' r f)
+lub' :: forall r f . (Ord r, Ord f, Show r, Show f) =>
+ HypGraph r f -> (Node r f, Offset) -> (Node r f, Offset) -> Maybe (SizeExpr' r f)
lub' hg (node1, n) (node2, m) = do
let sucs = commonSuccs hg [node1, node2]
sucNodes = smallest hg $ Map.keys sucs
@@ -884,6 +898,7 @@ verifySolution hg cs sol = do
-- * Tests
+testSuccs :: Ord f => Map (Node [Char] f) [Edge' [Char] f Label]
testSuccs = commonSuccs hg [n1,n2]
where
n1 = NodeRigid "i"
@@ -899,7 +914,9 @@ testSuccs = commonSuccs hg [n1,n2]
, Graph.Edge n2 n4 $ Label Le 5
, Graph.Edge n2 n5 $ Label Le 6
]
+
-- testLub = smallest hg $ Map.keys $ commonSuccs hg [n1,n2] --
+testLub :: (Show f, Ord f) => Maybe (SizeExpr' [Char] f)
testLub = lub hg (Rigid "i" 0) (Rigid "j" 2)
where
n1 = NodeRigid "i"
diff --git a/src/full/Agda/TypeChecking/Substitute.hs b/src/full/Agda/TypeChecking/Substitute.hs
index a199ec3..4ac769a 100644
--- a/src/full/Agda/TypeChecking/Substitute.hs
+++ b/src/full/Agda/TypeChecking/Substitute.hs
@@ -1,16 +1,19 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE OverlappingInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
-module Agda.TypeChecking.Substitute where
+module Agda.TypeChecking.Substitute
+ ( module Agda.TypeChecking.Substitute
+ , Substitution(..)
+ ) where
-import Control.Arrow ((***))
+import Control.Arrow ((***), first, second)
import Data.Function
import Data.Functor
@@ -30,13 +33,15 @@ import Agda.TypeChecking.Monad.Base as Base
import Agda.TypeChecking.Free as Free
import Agda.TypeChecking.CompiledClause
+import Agda.Utils.Empty
+import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
---------------------------------------------------------------------------
@@ -62,7 +67,7 @@ instance Apply Term where
Con c args -> conApp c args es
Lam _ b ->
case es of
- Apply a : es0 -> absApp b (unArg a) `applyE` es0
+ Apply a : es0 -> lazyAbsApp b (unArg a) `applyE` es0
_ -> __IMPOSSIBLE__
MetaV x es' -> MetaV x (es' ++ es)
Shared p -> Shared $ applyE p es
@@ -79,29 +84,29 @@ instance Apply Term where
canProject :: QName -> Term -> Maybe (Arg Term)
canProject f v =
case ignoreSharing v of
- (Con (ConHead _ fs) vs) -> do
+ (Con (ConHead _ _ fs) vs) -> do
i <- elemIndex f fs
- mhead (drop i vs)
+ headMaybe (drop i vs)
_ -> Nothing
-- | Eliminate a constructed term.
conApp :: ConHead -> Args -> Elims -> Term
-conApp ch args [] = Con ch args
-conApp ch args (Apply a : es) = conApp ch (args ++ [a]) es
-conApp ch@(ConHead c fs) args (Proj f : es) =
+conApp ch args [] = Con ch args
+conApp ch args (Apply a : es) = conApp ch (args ++ [a]) es
+conApp ch@(ConHead c _ fs) args (Proj f : es) =
let failure = flip trace __IMPOSSIBLE__ $
"conApp: constructor " ++ show c ++
" with fields " ++ show fs ++
" projected by " ++ show f
i = maybe failure id $ elemIndex f fs
- v = maybe failure argToDontCare $ mhead $ drop i args
+ v = maybe failure argToDontCare $ headMaybe $ drop i args
in applyE v es
{-
i = maybe failure id $ elemIndex f $ map unArg fs
- v = maybe failure unArg $ mhead $ drop i args
+ v = maybe failure unArg $ headMaybe $ drop i args
-- Andreas, 2013-10-20 see Issue543a:
-- protect result of irrelevant projection.
- r = maybe __IMPOSSIBLE__ getRelevance $ mhead $ drop i fs
+ r = maybe __IMPOSSIBLE__ getRelevance $ headMaybe $ drop i fs
u | Irrelevant <- r = DontCare v
| otherwise = v
in applyE v es
@@ -142,7 +147,7 @@ instance Apply a => Apply (Ptr a) where
instance Subst a => Apply (Tele a) where
apply tel [] = tel
apply EmptyTel _ = __IMPOSSIBLE__
- apply (ExtendTel _ tel) (t : ts) = absApp tel (unArg t) `apply` ts
+ apply (ExtendTel _ tel) (t : ts) = lazyAbsApp tel (unArg t) `apply` ts
instance Apply Definition where
apply (Defn info x t pol occ df m c rew inst d) args =
@@ -268,12 +273,12 @@ instance Apply FunctionInverse where
instance Apply ClauseBody where
apply b [] = b
- apply (Bind b) (a:args) = absApp b (unArg a) `apply` args
+ apply (Bind b) (a:args) = lazyAbsApp b (unArg a) `apply` args
apply (Body v) args = Body $ v `apply` args
apply NoBody _ = NoBody
applyE b [] = b
- applyE (Bind b) (Apply a : es) = absApp b (unArg a) `applyE` es
+ applyE (Bind b) (Apply a : es) = lazyAbsApp b (unArg a) `applyE` es
applyE (Bind b) (Proj{} : es) = __IMPOSSIBLE__
applyE (Body v) es = Body $ v `applyE` es
applyE NoBody _ = NoBody
@@ -331,7 +336,7 @@ instance Abstract Permutation where
-- reduction.
piApply :: Type -> Args -> Type
piApply t [] = t
-piApply (El _ (Pi _ b)) (a:args) = absApp b (unArg a) `piApply` args
+piApply (El _ (Pi _ b)) (a:args) = lazyAbsApp b (unArg a) `piApply` args
piApply (El s (Shared p)) args = piApply (El s $ derefPtr p) args
piApply t args =
trace ("piApply t = " ++ show t ++ "\n args = " ++ show args) __IMPOSSIBLE__
@@ -342,21 +347,21 @@ piApply t args =
-- | @(abstract args v) `apply` args --> v[args]@.
class Abstract t where
- abstract :: Telescope -> t -> t
+ abstract :: Telescope -> t -> t
instance Abstract Term where
- abstract = teleLam
+ abstract = teleLam
instance Abstract Type where
- abstract = telePi_
+ abstract = telePi_
instance Abstract Sort where
- abstract EmptyTel s = s
- abstract _ s = __IMPOSSIBLE__
+ abstract EmptyTel s = s
+ abstract _ s = __IMPOSSIBLE__
instance Abstract Telescope where
- abstract EmptyTel tel = tel
- abstract (ExtendTel arg tel') tel = ExtendTel arg $ fmap (`abstract` tel) tel'
+ EmptyTel `abstract` tel = tel
+ ExtendTel arg xtel `abstract` tel = ExtendTel arg $ xtel <&> (`abstract` tel)
instance Abstract Definition where
abstract tel (Defn info x t pol occ df m c rews inst d) =
@@ -472,27 +477,7 @@ abstractArgs args x = abstract tel x
-- * Explicit substitutions
---------------------------------------------------------------------------
--- | Substitutions.
-
-infixr 4 :#
-data Substitution
-
- = IdS -- Γ ⊢ IdS : Γ
-
- | EmptyS -- Γ ⊢ EmptyS : ()
-
- -- Γ ⊢ ρ : Δ
- | Wk !Int Substitution -- -------------------
- -- Γ, Ψ ⊢ Wk |Ψ| ρ : Δ
-
- -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ
- | Term :# Substitution -- ---------------------
- -- Γ ⊢ u :# ρ : Δ, A
-
- -- Γ ⊢ ρ : Δ
- | Lift !Int Substitution -- -------------------------
- -- Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ
- deriving (Eq, Ord, Show)
+-- See Syntax.Internal for the definition.
idS :: Substitution
idS = IdS
@@ -506,8 +491,13 @@ wkS n rho = Wk n rho
raiseS :: Int -> Substitution
raiseS n = wkS n idS
+consS :: Term -> Substitution -> Substitution
+consS (Var n []) (Wk m rho)
+ | n + 1 == m = wkS (m - 1) (liftS 1 rho)
+consS u rho = seq u (u :# rho)
+
singletonS :: Term -> Substitution
-singletonS u = u :# idS
+singletonS u = consS u idS
liftS :: Int -> Substitution -> Substitution
liftS 0 rho = rho
@@ -516,13 +506,14 @@ liftS k (Lift n rho) = Lift (n + k) rho
liftS k rho = Lift k rho
dropS :: Int -> Substitution -> Substitution
-dropS 0 rho = rho
-dropS n IdS = raiseS n
-dropS n (Wk m rho) = wkS m (dropS n rho)
-dropS n (u :# rho) = dropS (n - 1) rho
-dropS n (Lift 0 rho) = __IMPOSSIBLE__
-dropS n (Lift m rho) = wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho
-dropS n EmptyS = __IMPOSSIBLE__
+dropS 0 rho = rho
+dropS n IdS = raiseS n
+dropS n (Wk m rho) = wkS m (dropS n rho)
+dropS n (u :# rho) = dropS (n - 1) rho
+dropS n (Strengthen _ rho) = dropS (n - 1) rho
+dropS n (Lift 0 rho) = __IMPOSSIBLE__
+dropS n (Lift m rho) = wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho
+dropS n EmptyS = __IMPOSSIBLE__
-- | @applySubst (ρ `composeS` σ) v == applySubst ρ (applySubst σ v)@
composeS :: Substitution -> Substitution -> Substitution
@@ -531,6 +522,7 @@ composeS IdS sgm = sgm
composeS rho EmptyS = EmptyS
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 (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))
@@ -539,22 +531,32 @@ composeS rho (Lift n sgm) = lookupS rho 0 :# composeS rho (wkS 1 (liftS (n - 1)
-- Γ ⊢ σ : Δ
-- Γ ⊢ δ : Θσ
splitS :: Int -> Substitution -> (Substitution, Substitution)
-splitS 0 rho = (rho, EmptyS)
-splitS n (u :# rho) = id *** (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)
-splitS n (Lift m rho) = wkS 1 *** liftS 1 $ splitS (n - 1) (liftS (m - 1) rho)
-splitS n EmptyS = __IMPOSSIBLE__
+splitS 0 rho = (rho, EmptyS)
+splitS n (u :# rho) = second (u :#) $ splitS (n - 1) rho
+splitS n (Strengthen err rho) = second (Strengthen err) $ splitS (n - 1) rho
+splitS n (Lift 0 _) = __IMPOSSIBLE__
+splitS n (Wk m rho) = wkS m *** wkS m $ splitS n rho
+splitS n IdS = (raiseS n, liftS n EmptyS)
+splitS n (Lift m rho) = wkS 1 *** liftS 1 $ splitS (n - 1) (liftS (m - 1) rho)
+splitS n EmptyS = __IMPOSSIBLE__
infixr 4 ++#
(++#) :: [Term] -> Substitution -> Substitution
-us ++# rho = foldr (:#) rho us
+us ++# rho = foldr consS rho us
+
+prependS :: Empty -> [Maybe Term] -> Substitution -> Substitution
+prependS err us rho = foldr f rho us
+ where
+ f Nothing rho = Strengthen err rho
+ f (Just u) rho = consS u rho
parallelS :: [Term] -> Substitution
parallelS us = us ++# idS
+compactS :: Empty -> [Maybe Term] -> Substitution
+compactS err us = prependS err us idS
+
lookupS :: Substitution -> Nat -> Term
lookupS rho i = case rho of
IdS -> var i
@@ -564,6 +566,10 @@ lookupS rho i = case rho of
u :# rho | i == 0 -> u
| i < 0 -> __IMPOSSIBLE__
| otherwise -> lookupS rho (i - 1)
+ Strengthen err rho
+ | i == 0 -> absurd err
+ | i < 0 -> __IMPOSSIBLE__
+ | otherwise -> lookupS rho (i - 1)
Lift n rho | i < n -> var i
| otherwise -> raise n $ lookupS rho (i - n)
EmptyS -> __IMPOSSIBLE__
@@ -593,6 +599,9 @@ raiseFrom n k = applySubst (liftS n $ raiseS k)
subst :: Subst t => Term -> t -> t
subst u t = substUnder 0 u t
+strengthen :: Subst t => Empty -> t -> t
+strengthen err = applySubst (compactS err [Nothing])
+
substUnder :: Subst t => Nat -> Term -> t -> t
substUnder n u = applySubst (liftS n (singletonS u))
@@ -761,6 +770,9 @@ telToList (ExtendTel arg tel) = fmap (absName tel,) arg : telToList (absBody tel
-- Andreas, 2013-12-14: This would work also for 'NoAbs',
-- since 'absBody' raises.
+telToArgs :: Telescope -> [Arg ArgName]
+telToArgs tel = [ Common.Arg (domInfo d) (fst $ unDom d) | d <- telToList tel ]
+
-- | Turn a typed binding @(x1 .. xn : A)@ into a telescope.
bindsToTel' :: (Name -> a) -> [Name] -> Dom Type -> ListTel' a
bindsToTel' f [] t = []
@@ -782,6 +794,9 @@ mkPi (Common.Dom info (x, a)) b = el $ Pi (Common.Dom info a) (mkAbs x b)
where
el = El $ dLub (getSort a) (Abs x (getSort b)) -- dLub checks x freeIn
+mkLam :: Arg ArgName -> Term -> Term
+mkLam a v = Lam (argInfo a) (Abs (unArg a) v)
+
telePi' :: (Abs Type -> Abs Type) -> Telescope -> Type -> Type
telePi' reAbs = telePi where
telePi EmptyTel t = t
@@ -812,7 +827,7 @@ telePi_ (ExtendTel u tel) t = el $ Pi u b
-}
teleLam :: Telescope -> Term -> Term
-teleLam EmptyTel t = t
+teleLam EmptyTel t = t
teleLam (ExtendTel u tel) t = Lam (domInfo u) $ flip teleLam t <$> tel
-- | Performs void ('noAbs') abstraction over telescope.
@@ -834,10 +849,11 @@ dLub s1 (NoAbs _ s2) = sLub s1 s2
dLub s1 b@(Abs _ s2) = case occurrence 0 $ freeVars s2 of
Flexible -> DLub s1 b
Irrelevantly -> DLub s1 b
- NoOccurrence -> sLub s1 (absApp b __IMPOSSIBLE__)
+ NoOccurrence -> sLub s1 (noabsApp __IMPOSSIBLE__ b)
-- Free.Unused -> sLub s1 (absApp b __IMPOSSIBLE__) -- triggers Issue784
Free.Unused -> DLub s1 b
StronglyRigid -> Inf
+ Unguarded -> Inf
WeaklyRigid -> Inf
---------------------------------------------------------------------------
@@ -845,11 +861,23 @@ dLub s1 b@(Abs _ s2) = case occurrence 0 $ freeVars s2 of
-- and things we couldn't do before we could define 'absBody'
---------------------------------------------------------------------------
--- | Instantiate an abstraction
+-- | Instantiate an abstraction. Strict in the term.
absApp :: Subst t => Abs t -> Term -> t
absApp (Abs _ v) u = subst u v
absApp (NoAbs _ v) _ = v
+-- | Instantiate an abstraction. Lazy in the term, which allow it to be
+-- __IMPOSSIBLE__ in the case where the variable shouldn't be used but we
+-- cannot use 'noabsApp'. Used in Apply.
+lazyAbsApp :: Subst t => Abs t -> Term -> t
+lazyAbsApp (Abs _ v) u = applySubst (u :# IdS) v
+lazyAbsApp (NoAbs _ v) _ = v
+
+-- | Instantiate an abstraction that doesn't use its argument.
+noabsApp :: Subst t => Empty -> Abs t -> t
+noabsApp err (Abs _ v) = strengthen err v
+noabsApp _ (NoAbs _ v) = v
+
absBody :: Subst t => Abs t -> t
absBody (Abs _ v) = v
absBody (NoAbs _ v) = raise 1 v
@@ -926,6 +954,9 @@ instance GetBody Clause where
deriving instance (Subst a, Eq a) => Eq (Tele a)
deriving instance (Subst a, Ord a) => Ord (Tele a)
+deriving instance Eq Substitution
+deriving instance Ord Substitution
+
deriving instance Eq Sort
deriving instance Ord Sort
deriving instance Eq Type
@@ -1098,6 +1129,7 @@ levelTm l =
Max [Plus 0 l] -> unLevelAtom l
_ -> Level l
+unLevelAtom :: LevelAtom -> Term
unLevelAtom (MetaLevel x es) = MetaV x es
unLevelAtom (NeutralLevel v) = v
unLevelAtom (UnreducedLevel v) = v
@@ -1108,15 +1140,17 @@ unLevelAtom (BlockedLevel _ v) = v
---------------------------------------------------------------------------
instance Sized Substitution where
- size IdS = 1
- size EmptyS = 1
- size (Wk _ rho) = 1 + size rho
- size (t :# rho) = 1 + size t + size rho
- size (Lift _ rho) = 1 + size rho
+ size IdS = 1
+ size EmptyS = 1
+ size (Wk _ rho) = 1 + size rho
+ size (t :# rho) = 1 + size t + size rho
+ size (Strengthen _ rho) = 1 + size rho
+ size (Lift _ rho) = 1 + size rho
instance KillRange Substitution where
- killRange IdS = IdS
- killRange EmptyS = EmptyS
- killRange (Wk n rho) = killRange1 (Wk n) rho
- killRange (t :# rho) = killRange2 (:#) t rho
- killRange (Lift n rho) = killRange1 (Lift n) rho
+ killRange IdS = IdS
+ killRange EmptyS = EmptyS
+ killRange (Wk n rho) = killRange1 (Wk n) rho
+ killRange (t :# rho) = killRange2 (:#) t rho
+ killRange (Strengthen err rho) = killRange1 (Strengthen err) rho
+ killRange (Lift n rho) = killRange1 (Lift n) rho
diff --git a/src/full/Agda/TypeChecking/SyntacticEquality.hs b/src/full/Agda/TypeChecking/SyntacticEquality.hs
index ccefa6c..7e0f152 100644
--- a/src/full/Agda/TypeChecking/SyntacticEquality.hs
+++ b/src/full/Agda/TypeChecking/SyntacticEquality.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeSynonymInstances #-}
-- | A syntactic equality check that takes meta instantiations into account,
@@ -31,7 +31,7 @@ import Agda.TypeChecking.Substitute
import Agda.Utils.Monad (ifM)
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Syntactic equality check for terms.
diff --git a/src/full/Agda/TypeChecking/Telescope.hs b/src/full/Agda/TypeChecking/Telescope.hs
index d4cb8dc..7c746c4 100644
--- a/src/full/Agda/TypeChecking/Telescope.hs
+++ b/src/full/Agda/TypeChecking/Telescope.hs
@@ -20,9 +20,9 @@ import Agda.Utils.Permutation
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.VarSet (VarSet)
-import qualified Agda.Utils.VarSet as Set
+import qualified Agda.Utils.VarSet as VarSet
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
data OutputTypeName
@@ -59,9 +59,9 @@ renameP p = applySubst (renaming p)
renaming :: Permutation -> Substitution
renaming p = gamma'
where
- n = size p
- gamma = permute (reverseP $ invertP $ reverseP p) $ map var [0..]
- gamma' = gamma ++# raiseS n
+ n = size p
+ gamma = safePermute (reverseP $ invertP (-1) $ reverseP p) $ map var [0..]
+ gamma' = prependS __IMPOSSIBLE__ gamma (raiseS n)
-- | If @permute π : [a]Γ -> [a]Δ@, then @substs (renamingR π) : Term Δ -> Term Γ@
renamingR :: Permutation -> Substitution
@@ -69,7 +69,7 @@ renamingR p@(Perm n _) = permute (reverseP p) (map var [0..]) ++# raiseS n
-- | Flatten telescope: (Γ : Tel) -> [Type Γ]
flattenTel :: Telescope -> [Dom Type]
-flattenTel EmptyTel = []
+flattenTel EmptyTel = []
flattenTel (ExtendTel a tel) = raise (size tel + 1) a : flattenTel (absBody tel)
-- | Order a flattened telescope in the correct dependeny order: Γ ->
@@ -91,7 +91,7 @@ reorderTel_ tel = case reorderTel tel of
-- | Unflatten: turns a flattened telescope into a proper telescope. Must be
-- properly ordered.
unflattenTel :: [ArgName] -> [Dom Type] -> Telescope
-unflattenTel [] [] = EmptyTel
+unflattenTel [] [] = EmptyTel
unflattenTel (x : xs) (a : tel) = ExtendTel a' (Abs x tel')
where
tel' = unflattenTel xs tel
@@ -113,24 +113,33 @@ teleArgs tel = [ Common.Arg info (var i) | (i, Common.Dom info _) <- zip (downFr
-- | A telescope split in two.
data SplitTel = SplitTel
- { firstPart :: Telescope
- , secondPart :: Telescope
- , splitPerm :: Permutation
- }
+ { firstPart :: Telescope
+ , secondPart :: Telescope
+ , splitPerm :: Permutation
+ -- ^ The permutation takes us from the original telescope to
+ -- @firstPart ++ secondPart at .
+ }
-- | Split a telescope into the part that defines the given variables and the
-- part that doesn't.
-splitTelescope :: VarSet -> Telescope -> SplitTel
+--
+-- See 'Agda.TypeChecking.Tests.prop_splitTelescope'.
+splitTelescope
+ :: VarSet -- ^ A set of de Bruijn indices.
+ -> Telescope -- ^ Original telescope.
+ -> SplitTel -- ^ @firstPart@ mentions the given variables, @secondPart@ not.
splitTelescope fv tel = SplitTel tel1 tel2 perm
where
names = teleNames tel
ts0 = flattenTel tel
-
n = size tel
-- We start with a rough split into fv and the rest. This will most likely
-- not be correct so we patch it up later with reorderTel.
- is = map (n - 1 -) $ filter (< n) $ reverse $ Set.toList fv
+
+ -- Convert given de Bruijn indices into ascending list of de Bruijn levels.
+ is = map (n - 1 -) $ dropWhile (>= n) $ VarSet.toDescList fv
+ -- Compute the complement (de Bruijn levels not mentioned in @fv@).
isC = [0..n - 1] \\ is
perm0 = Perm n $ is ++ isC
@@ -146,9 +155,8 @@ splitTelescope fv tel = SplitTel tel1 tel2 perm
tel' = unflattenTel (permute perm names) ts2
- Perm _ js = perm
- m = genericLength $ takeWhile (`notElem` is) (reverse js)
- (tel1, tel2) = telFromList -*- telFromList $ genericSplitAt (n - m) $ telToList tel'
+ m = length $ takeWhile (`notElem` is) $ reverse $ permPicks perm
+ (tel1, tel2) = telFromList -*- telFromList $ splitAt (n - m) $ telToList tel'
telView :: Type -> TCM TelView
telView = telViewUpTo (-1)
diff --git a/src/full/Agda/TypeChecking/Test/Generators.hs b/src/full/Agda/TypeChecking/Test/Generators.hs
index 7ab10de..dbd1ddc 100644
--- a/src/full/Agda/TypeChecking/Test/Generators.hs
+++ b/src/full/Agda/TypeChecking/Test/Generators.hs
@@ -1,9 +1,9 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
module Agda.TypeChecking.Test.Generators where
@@ -25,22 +25,22 @@ import Agda.Utils.QuickCheck hiding (Args)
import Agda.Utils.TestHelpers
import qualified Agda.Utils.VarSet as Set
-#include "../../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
data TermConfiguration = TermConf
- { tcDefinedNames :: [QName]
+ { tcDefinedNames :: [QName]
, tcConstructorNames :: [QName]
, tcProjectionNames :: [QName]
- , tcFreeVariables :: [Nat]
- , tcLiterals :: UseLiterals
- , tcFrequencies :: Frequencies
- , tcFixSize :: Maybe Int
- -- ^ Maximum size of the generated element. When @Nothing@ this value
- -- is initialized from the 'Test.QuickCheck.size' parameter.
- , tcIsType :: Bool
- -- ^ When this is true no lambdas, literals, or constructors are
- -- generated
+ , tcFreeVariables :: [Nat]
+ , tcLiterals :: UseLiterals
+ , tcFrequencies :: Frequencies
+ , tcFixSize :: Maybe Int
+ -- ^ Maximum size of the generated element. When @Nothing@ this value
+ -- is initialized from the 'Test.QuickCheck.size' parameter.
+ , tcIsType :: Bool
+ -- ^ When this is true no lambdas, literals, or constructors are
+ -- generated
}
deriving Show
@@ -56,11 +56,11 @@ data TermFreqs = TermFreqs
{ varFreq :: Int
, defFreq :: Int
, conFreq :: Int
- , litFreq :: Int
+ , litFreq :: Int
, sortFreq :: Int
- , lamFreq :: Int
- , piFreq :: Int
- , funFreq :: Int
+ , lamFreq :: Int
+ , piFreq :: Int
+ , funFreq :: Int
}
deriving Show
@@ -84,17 +84,17 @@ data SortFreqs = SortFreqs
defaultFrequencies :: Frequencies
defaultFrequencies = Freqs
- { termFreqs = TermFreqs { varFreq = 24, defFreq = 8, conFreq = 8, litFreq = 1, sortFreq = 2, lamFreq = 10, piFreq = 5, funFreq = 5 }
+ { termFreqs = TermFreqs { varFreq = 24, defFreq = 8, conFreq = 8, litFreq = 1, sortFreq = 2, lamFreq = 10, piFreq = 5, funFreq = 5 }
, elimFreqs = ElimFreqs { applyFreq = 9, projFreq = 1 }
, hiddenFreqs = HiddenFreqs { hiddenFreq = 1, notHiddenFreq = 5 }
- , sortFreqs = SortFreqs { setFreqs = [3, 1], propFreq = 1 }
+ , sortFreqs = SortFreqs { setFreqs = [3, 1], propFreq = 1 }
}
noProp :: TermConfiguration -> TermConfiguration
noProp conf = conf { tcFrequencies = fq { sortFreqs = sfq { propFreq = 0 } } }
where
- fq = tcFrequencies conf
- sfq = sortFreqs fq
+ fq = tcFrequencies conf
+ sfq = sortFreqs fq
data UseLiterals = UseLit
{ useLitInt :: Bool
@@ -138,9 +138,9 @@ makeConfiguration ds cs ps vs = TermConf
, tcProjectionNames = projs
, tcFreeVariables = List.sort $ List.nub vs
, tcFrequencies = defaultFrequencies
- , tcLiterals = noLiterals
- , tcFixSize = Nothing
- , tcIsType = False
+ , tcLiterals = noLiterals
+ , tcFixSize = Nothing
+ , tcIsType = False
}
where
(defs, cons, projs) = flip evalState 0 $ do
@@ -150,22 +150,22 @@ makeConfiguration ds cs ps vs = TermConf
mkName s = do
n <- tick
return $ QName { qnameModule = MName []
- , qnameName = Name
- { nameId = NameId n 1
- , nameConcrete = C.Name noRange [C.Id s]
- , nameBindingSite = noRange
- , nameFixity = defaultFixity'
- }
- }
+ , qnameName = Name
+ { nameId = NameId n 1
+ , nameConcrete = C.Name noRange [C.Id s]
+ , nameBindingSite = noRange
+ , nameFixity = defaultFixity'
+ }
+ }
class GenC a where
genC :: TermConfiguration -> Gen a
-newtype YesType a = YesType { unYesType :: a }
-newtype NoType a = NoType { unNoType :: a }
-newtype VarName = VarName { unVarName :: Nat }
-newtype DefName = DefName { unDefName :: QName }
-newtype ConName = ConName { unConName :: ConHead }
+newtype YesType a = YesType { unYesType :: a }
+newtype NoType a = NoType { unNoType :: a }
+newtype VarName = VarName { unVarName :: Nat }
+newtype DefName = DefName { unDefName :: QName }
+newtype ConName = ConName { unConName :: ConHead }
newtype ProjName = ProjName { unProjName :: QName }
newtype SizedList a = SizedList { unSizedList :: [a] }
@@ -194,7 +194,7 @@ instance GenC Hiding where
genC conf = frequency [ (hideF, return Hidden), (nohideF, return NotHidden) ]
where
HiddenFreqs {hiddenFreq = hideF, notHiddenFreq = nohideF } =
- hiddenFreqs $ tcFrequencies conf
+ hiddenFreqs $ tcFrequencies conf
instance (GenC c, GenC a) => GenC (Common.Arg c a) where
genC conf = (\ (h, a) -> Arg (setHiding h defaultArgInfo) a) <$> genC conf
@@ -211,7 +211,7 @@ instance GenC a => GenC (Elim' a) where
, (projF, Proj . unProjName <$> genC conf) ]
where
ElimFreqs {applyFreq = applyF, projFreq = projF } =
- elimFreqs $ tcFrequencies conf
+ elimFreqs $ tcFrequencies conf
instance GenC DefName where
genC conf = DefName <$> do elements $ tcDefinedNames conf
@@ -245,12 +245,12 @@ instance GenC Integer where
instance GenC Literal where
genC conf = oneof (concat $ zipWith gen useLits
- [ uncurry LitInt <$> genC conf
- , uncurry LitFloat <$> genC conf
- , uncurry LitString <$> genC conf
- , uncurry LitChar <$> genC conf
- ]
- )
+ [ uncurry LitInt <$> genC conf
+ , uncurry LitFloat <$> genC conf
+ , uncurry LitString <$> genC conf
+ , uncurry LitChar <$> genC conf
+ ]
+ )
where
useLits = map ($ tcLiterals conf) [ useLitInt, useLitFloat, useLitString, useLitChar ]
@@ -270,15 +270,15 @@ instance GenC Term where
genC conf = case tcFixSize conf of
Nothing -> sized $ \n -> genC $ fixSizeConf n conf
Just n | n <= 0 -> genLeaf
- | otherwise -> frequency
- [ (varF, genVar $ genElims conf)
- , (defF, genDef $ genElims conf)
- , (conF, genCon $ genArgs conf)
- , (litF, Lit <$> genC conf)
- , (sortF, Sort <$> genC conf)
- , (lamF, genLam)
- , (piF, genPi)
- ]
+ | otherwise -> frequency
+ [ (varF, genVar $ genElims conf)
+ , (defF, genDef $ genElims conf)
+ , (conF, genCon $ genArgs conf)
+ , (litF, Lit <$> genC conf)
+ , (sortF, Sort <$> genC conf)
+ , (lamF, genLam)
+ , (piF, genPi)
+ ]
where
defs = tcDefinedNames conf
cons = tcConstructorNames conf
@@ -288,15 +288,15 @@ instance GenC Term where
useLits = map ($ tcLiterals conf) [ useLitInt, useLitFloat, useLitString, useLitChar ]
varF | null vars = 0
- | otherwise = freq (varFreq . termFreqs)
+ | otherwise = freq (varFreq . termFreqs)
defF | null defs = 0
- | otherwise = freq (defFreq . termFreqs)
+ | otherwise = freq (defFreq . termFreqs)
conF | null cons || isType = 0
- | otherwise = freq (conFreq . termFreqs)
+ | otherwise = freq (conFreq . termFreqs)
litF | or useLits && not isType = freq (litFreq . termFreqs)
- | otherwise = 0
+ | otherwise = 0
lamF | isType = 0
- | otherwise = freq (lamFreq . termFreqs)
+ | otherwise = freq (lamFreq . termFreqs)
sortF = freq (sortFreq . termFreqs)
piF = freq (piFreq . termFreqs)
@@ -311,16 +311,16 @@ instance GenC Term where
genDef args = Def <$> elements defs <*> args
genCon :: Gen Args -> Gen Term
- genCon args = Con <$> (flip ConHead [] <$> elements cons) <*> args
+ genCon args = Con <$> ((\ c -> ConHead c Inductive []) <$> elements cons) <*> args
genLeaf :: Gen Term
genLeaf = frequency
- [ (varF, genVar $ return [])
- , (defF, genDef $ return [])
- , (conF, genCon $ return [])
- , (litF, Lit <$> genC conf)
- , (sortF, Sort <$> genC conf)
- ]
+ [ (varF, genVar $ return [])
+ , (defF, genDef $ return [])
+ , (conF, genCon $ return [])
+ , (litF, Lit <$> genC conf)
+ , (sortF, Sort <$> genC conf)
+ ]
-- | Only generates default configurations. Names and free variables varies.
genConf :: Gen TermConfiguration
@@ -353,7 +353,7 @@ instance ShrinkC a b => ShrinkC (NoType a) b where
noShrink (NoType x) = noShrink x
instance ShrinkC a b => ShrinkC [a] [b] where
- noShrink = map noShrink
+ noShrink = map noShrink
shrinkC conf xs = noShrink (removeChunks xs) ++ shrinkOne xs
where
-- Code stolen from Test.QuickCheck.Arbitrary
@@ -395,12 +395,12 @@ instance ShrinkC DefName QName where
noShrink = unDefName
instance ShrinkC ConName ConHead where
- shrinkC conf (ConName (ConHead{conName = c})) = map (flip ConHead []) $ takeWhile (/= c) $ tcConstructorNames conf
+ shrinkC conf (ConName (ConHead{conName = c})) = map (\ c -> ConHead c Inductive []) $ takeWhile (/= c) $ tcConstructorNames conf
noShrink = unConName
instance ShrinkC Literal Literal where
shrinkC _ (LitInt _ 0) = []
- shrinkC conf l = LitInt noRange 0 : case l of
+ shrinkC conf l = LitInt noRange 0 : case l of
LitInt r n -> LitInt r <$> shrink n
LitString r s -> LitString r <$> shrinkC conf s
LitChar r c -> LitChar r <$> shrinkC conf c
@@ -410,7 +410,7 @@ instance ShrinkC Literal Literal where
instance ShrinkC Char Char where
shrinkC _ 'a' = []
- shrinkC _ _ = ['a']
+ shrinkC _ _ = ['a']
noShrink = id
instance ShrinkC Hiding Hiding where
@@ -453,7 +453,7 @@ instance ShrinkC Sort Sort where
noShrink = id
instance ShrinkC Telescope Telescope where
- shrinkC conf EmptyTel = []
+ shrinkC conf EmptyTel = []
shrinkC conf (ExtendTel a tel) =
killAbs tel : (uncurry ExtendTel <$> shrinkC conf (a, tel))
noShrink = id
@@ -465,19 +465,19 @@ instance ShrinkC Type Type where
instance ShrinkC Term Term where
shrinkC conf (DontCare _) = []
shrinkC conf (Sort Prop) = []
- shrinkC conf t = filter validType $ case ignoreSharing t of
+ shrinkC conf t = filter validType $ case ignoreSharing t of
Var i es -> map unArg (argsFromElims es) ++
- (uncurry Var <$> shrinkC conf (VarName i, NoType es))
+ (uncurry Var <$> shrinkC conf (VarName i, NoType es))
Def d es -> map unArg (argsFromElims es) ++
- (uncurry Def <$> shrinkC conf (DefName d, NoType es))
+ (uncurry Def <$> shrinkC conf (DefName d, NoType es))
Con c args -> map unArg args ++
- (uncurry Con <$> shrinkC conf (ConName c, NoType args))
- Lit l -> Lit <$> shrinkC conf l
+ (uncurry Con <$> shrinkC conf (ConName c, NoType args))
+ Lit l -> Lit <$> shrinkC conf l
Level l -> [] -- TODO
Lam info b -> killAbs b : ((\(h,x) -> Lam (setHiding h defaultArgInfo) x)
<$> shrinkC conf (argInfoHiding info, b))
Pi a b -> unEl (unDom a) : unEl (killAbs b) :
- (uncurry Pi <$> shrinkC conf (a, b))
+ (uncurry Pi <$> shrinkC conf (a, b))
Sort s -> Sort <$> shrinkC conf s
MetaV m es -> map unArg (argsFromElims es) ++
(MetaV m <$> shrinkC conf (NoType es))
@@ -486,12 +486,12 @@ instance ShrinkC Term Term where
ExtLam _ _ -> __IMPOSSIBLE__
where
validType t
- | not (tcIsType conf) = True
- | otherwise = case t of
- Con _ _ -> False
- Lam _ _ -> False
- Lit _ -> False
- _ -> True
+ | not (tcIsType conf) = True
+ | otherwise = case t of
+ Con _ _ -> False
+ Lam _ _ -> False
+ Lit _ -> False
+ _ -> True
noShrink = id
killAbs :: KillVar a => Abs a -> a
@@ -503,17 +503,17 @@ class KillVar a where
instance KillVar Term where
killVar i t = case ignoreSharing t of
- Var j args | j == i -> DontCare (Var j [])
- | j > i -> Var (j - 1) $ killVar i args
- | otherwise -> Var j $ killVar i args
- Def c args -> Def c $ killVar i args
- Con c args -> Con c $ killVar i args
- Lit l -> Lit l
+ Var j args | j == i -> DontCare (Var j [])
+ | j > i -> Var (j - 1) $ killVar i args
+ | otherwise -> Var j $ killVar i args
+ Def c args -> Def c $ killVar i args
+ Con c args -> Con c $ killVar i args
+ Lit l -> Lit l
Level l -> Level l -- TODO
- Sort s -> Sort s
- Lam h b -> Lam h $ killVar i b
- Pi a b -> uncurry Pi $ killVar i (a, b)
- MetaV m args -> MetaV m $ killVar i args
+ Sort s -> Sort s
+ Lam h b -> Lam h $ killVar i b
+ Pi a b -> uncurry Pi $ killVar i (a, b)
+ MetaV m args -> MetaV m $ killVar i args
DontCare mv -> DontCare $ killVar i mv
Shared{} -> __IMPOSSIBLE__
ExtLam _ _ -> __IMPOSSIBLE__
@@ -522,7 +522,7 @@ instance KillVar Type where
killVar i (El s t) = El s $ killVar i t
instance KillVar Telescope where
- killVar i EmptyTel = EmptyTel
+ killVar i EmptyTel = EmptyTel
killVar i (ExtendTel a tel) = uncurry ExtendTel $ killVar i (a, tel)
instance KillVar a => KillVar (Elim' a) where
diff --git a/src/full/Agda/TypeChecking/Tests.hs b/src/full/Agda/TypeChecking/Tests.hs
index 99c93cb..da0c511 100644
--- a/src/full/Agda/TypeChecking/Tests.hs
+++ b/src/full/Agda/TypeChecking/Tests.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Agda.TypeChecking.Tests where
import qualified Agda.Utils.VarSet as Set
@@ -11,6 +13,9 @@ import Agda.Utils.Size
import Agda.Utils.Permutation
import Agda.Utils.TestHelpers
+#include "undefined.h"
+import Agda.Utils.Impossible
+
---------------------------------------------------------------------------
-- * Tests for "Agda.Utils.Permutation"
---------------------------------------------------------------------------
@@ -46,7 +51,7 @@ prop_reorderTelStable conf =
-- | The result of splitting a telescope is well-scoped.
prop_splitTelescopeScope :: TermConfiguration -> Property
prop_splitTelescopeScope conf =
- forAll (genC conf) $ \tel ->
+ forAll (genC conf) $ \tel ->
forAll (listOfElements [0..size tel - 1]) $ \vs ->
let SplitTel tel1 tel2 perm = splitTelescope (Set.fromList vs) tel
tel' = telFromList (telToList tel1 ++ telToList tel2)
@@ -55,21 +60,21 @@ prop_splitTelescopeScope conf =
-- | The permutation generated when splitting a telescope preserves scoping.
prop_splitTelescopePermScope :: TermConfiguration -> Property
prop_splitTelescopePermScope conf =
- forAllShrink (genC conf) (shrinkC conf) $ \tel ->
+ forAllShrink (genC conf) (shrinkC conf) $ \tel ->
forAllShrink (listOfElements [0..size tel - 1]) shrink $ \vs ->
let SplitTel tel1 tel2 perm = splitTelescope (Set.fromList vs) tel
conf1 = extendWithTelConf tel1 conf
conf2 = conf1 { tcFreeVariables = map (size tel2 +) (tcFreeVariables conf1) }
conf' = conf { tcFreeVariables = map (size tel +) (tcFreeVariables conf) ++ vs }
in forAllShrink (genC conf') (shrinkC conf') $ \t ->
- isWellScoped conf2 (applySubst (renamingR $ invertP perm) (t :: Term))
+ isWellScoped conf2 (applySubst (renamingR $ invertP __IMPOSSIBLE__ perm) (t :: Term))
{-
-- | The permutation generated when splitting a telescope correctly translates
-- between the old and the new telescope.
prop_splitTelescopePermInv :: TermConfiguration -> Property
prop_splitTelescopePermInv conf =
- forAll (wellScopedTel conf) $ \tel ->
+ forAll (wellScopedTel conf) $ \tel ->
forAll (listOfElements [0..size tel - 1]) $ \vs ->
let SplitTel tel1 tel2 perm = splitTelescope (Set.fromList vs) tel
tel' = telFromList (telToList tel1 ++ telToList tel2)
@@ -77,8 +82,8 @@ prop_splitTelescopePermInv conf =
conf2 = extendWithTelConf tel' conf
in forAll (wellScopedTerm conf1) $ \t1 ->
forAll (wellScopedTerm conf2) $ \t2 ->
- let t1' = rename (invertP perm) $ rename perm t1
- t2' = rename perm $ rename (invertP perm) t2
+ let t1' = rename (invertP __IMPOSSIBLE__ perm) $ rename perm t1
+ t2' = rename perm $ rename (invertP __IMPOSSIBLE__ perm) t2
in t1 == t1' && t2 == t2'
-}
diff --git a/src/full/Agda/TypeChecking/Unquote.hs b/src/full/Agda/TypeChecking/Unquote.hs
new file mode 100644
index 0000000..aacc343
--- /dev/null
+++ b/src/full/Agda/TypeChecking/Unquote.hs
@@ -0,0 +1,403 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Agda.TypeChecking.Unquote where
+
+import Control.Applicative
+import Control.Monad.State (evalState, get, put)
+import Control.Monad.Writer (execWriterT, tell)
+import Control.Monad.Trans (lift)
+
+import Data.Char
+import Data.Maybe (fromMaybe)
+import Data.Traversable (traverse)
+
+import Agda.Syntax.Common
+import Agda.Syntax.Internal as I
+import Agda.Syntax.Literal
+import Agda.Syntax.Position
+import Agda.Syntax.Translation.InternalToAbstract
+
+import Agda.TypeChecking.CompiledClause
+import Agda.TypeChecking.Datatypes ( getConHead )
+import Agda.TypeChecking.DropArgs
+import Agda.TypeChecking.Free
+import Agda.TypeChecking.Level
+import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Monad.Builtin
+import Agda.TypeChecking.Monad.Exception
+import Agda.TypeChecking.Pretty
+import Agda.TypeChecking.Reduce
+import Agda.TypeChecking.Reduce.Monad
+import Agda.TypeChecking.Substitute
+
+import Agda.Utils.Except
+import Agda.Utils.Impossible
+import Agda.Utils.Monad ( ifM )
+import Agda.Utils.Permutation ( Permutation(Perm) )
+import Agda.Utils.String ( Str(Str), unStr )
+import Agda.Utils.VarSet (VarSet)
+import qualified Agda.Utils.VarSet as Set
+
+#include "undefined.h"
+
+agdaTermType :: TCM Type
+agdaTermType = El (mkType 0) <$> primAgdaTerm
+
+qNameType :: TCM Type
+qNameType = El (mkType 0) <$> primQName
+
+type UnquoteM = ExceptionT UnquoteError TCM
+
+runUnquoteM :: UnquoteM a -> TCM (Either UnquoteError a)
+runUnquoteM = runExceptionT
+
+isCon :: ConHead -> TCM Term -> UnquoteM Bool
+isCon con tm = do t <- lift tm
+ case ignoreSharing t of
+ Con con' _ -> return (con == con')
+ _ -> return False
+
+{-unquoteFailedGeneric :: String -> UnquoteM a
+unquoteFailedGeneric msg = typeError . GenericError $ "Unable to unquote the " ++ msg
+
+unquoteFailed :: String -> String -> Term -> TCM a
+unquoteFailed kind msg t = do doc <- prettyTCM t
+ unquoteFailedGeneric $ "term (" ++ show doc ++ ") of type " ++ kind ++ ".\nReason: " ++ msg ++ "."
+-}
+class Unquote a where
+ unquote :: Term -> UnquoteM a
+
+unquoteH :: Unquote a => I.Arg Term -> UnquoteM a
+unquoteH a | isHidden a && isRelevant a =
+ unquote $ unArg a
+unquoteH a = throwException $ BadVisibility "hidden" a
+
+unquoteN :: Unquote a => I.Arg Term -> UnquoteM a
+unquoteN a | notHidden a && isRelevant a =
+ unquote $ unArg a
+unquoteN a = throwException $ BadVisibility "visible" a
+
+choice :: Monad m => [(m Bool, m a)] -> m a -> m a
+choice [] dflt = dflt
+choice ((mb, mx) : mxs) dflt = ifM mb mx $ choice mxs dflt
+
+ensureDef :: QName -> UnquoteM QName
+ensureDef x = do
+ i <- (theDef <$> getConstInfo x) `catchError` \_ -> return Axiom -- for recursive unquoteDecl
+ case i of
+ Constructor{} -> do
+ def <- lift $ prettyTCM =<< primAgdaTermDef
+ con <- lift $ prettyTCM =<< primAgdaTermCon
+ throwException $ ConInsteadOfDef x (show def) (show con)
+ _ -> return x
+
+ensureCon :: QName -> UnquoteM QName
+ensureCon x = do
+ i <- (theDef <$> getConstInfo x) `catchError` \_ -> return Axiom -- for recursive unquoteDecl
+ case i of
+ Constructor{} -> return x
+ _ -> do
+ def <- lift $ prettyTCM =<< primAgdaTermDef
+ con <- lift $ prettyTCM =<< primAgdaTermCon
+ throwException $ DefInsteadOfCon x (show def) (show con)
+
+pickName :: Type -> String
+pickName a =
+ case unEl a of
+ Pi{} -> "f"
+ Sort{} -> "A"
+ Def d _ | c:_ <- show (qnameName d),
+ isAlpha c -> [toLower c]
+ _ -> "_"
+
+instance Unquote I.ArgInfo where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [h,r] -> do
+ choice
+ [(c `isCon` primArgArgInfo, ArgInfo <$> unquoteN h <*> unquoteN r <*> return [])]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "ArgInfo" t
+
+instance Unquote a => Unquote (I.Arg a) where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [info,x] -> do
+ choice
+ [(c `isCon` primArgArg, Arg <$> unquoteN info <*> unquoteN x)]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Arg" t
+
+-- Andreas, 2013-10-20: currently, post-fix projections are not part of the
+-- quoted syntax.
+instance Unquote a => Unquote (Elim' a) where
+ unquote t = Apply <$> unquote t
+
+instance Unquote Integer where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Lit (LitInt _ n) -> return n
+ _ -> throwException $ NotALiteral "Integer" t
+
+instance Unquote Double where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Lit (LitFloat _ x) -> return x
+ _ -> throwException $ NotALiteral "Float" t
+
+instance Unquote Char where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Lit (LitChar _ x) -> return x
+ _ -> throwException $ NotALiteral "Char" t
+
+instance Unquote Str where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Lit (LitString _ x) -> return (Str x)
+ _ -> throwException $ NotALiteral "String" t
+
+instance Unquote a => Unquote [a] where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [x,xs] -> do
+ choice
+ [(c `isCon` primCons, (:) <$> unquoteN x <*> unquoteN xs)]
+ __IMPOSSIBLE__
+ Con c [] -> do
+ choice
+ [(c `isCon` primNil, return [])]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "List" t
+
+instance Unquote Hiding where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [] -> do
+ choice
+ [(c `isCon` primHidden, return Hidden)
+ ,(c `isCon` primInstance, return Instance)
+ ,(c `isCon` primVisible, return NotHidden)]
+ __IMPOSSIBLE__
+ Con c vs -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Hiding" t
+
+instance Unquote Relevance where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [] -> do
+ choice
+ [(c `isCon` primRelevant, return Relevant)
+ ,(c `isCon` primIrrelevant, return Irrelevant)]
+ __IMPOSSIBLE__
+ Con c vs -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Relevance" t
+
+instance Unquote QName where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Lit (LitQName _ x) -> return x
+ _ -> throwException $ NotALiteral "QName" t
+
+instance Unquote ConHead where
+ unquote t = lift . getConHead =<< ensureCon =<< unquote t
+
+instance Unquote a => Unquote (Abs a) where
+ unquote t = Abs "_" <$> unquote t
+
+instance Unquote Sort where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [] -> do
+ choice
+ [(c `isCon` primAgdaSortUnsupported, pure $ Type $ Max [Plus 0 $ UnreducedLevel $ hackReifyToMeta])]
+ __IMPOSSIBLE__
+ Con c [u] -> do
+ choice
+ [(c `isCon` primAgdaSortSet, Type <$> unquoteN u)
+ ,(c `isCon` primAgdaSortLit, Type . levelMax . (:[]) . ClosedLevel <$> unquoteN u)]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Sort" t
+
+instance Unquote Level where
+ unquote l = Max . (:[]) . Plus 0 . UnreducedLevel <$> unquote l
+
+instance Unquote Type where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [s, u] -> do
+ choice
+ [(c `isCon` primAgdaTypeEl, El <$> unquoteN s <*> unquoteN u)]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Type" t
+
+instance Unquote Literal where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [x] ->
+ choice
+ [ (c `isCon` primAgdaLitNat, LitInt noRange <$> unquoteN x)
+ , (c `isCon` primAgdaLitFloat, LitFloat noRange <$> unquoteN x)
+ , (c `isCon` primAgdaLitChar, LitChar noRange <$> unquoteN x)
+ , (c `isCon` primAgdaLitString, LitString noRange . unStr <$> unquoteN x)
+ , (c `isCon` primAgdaLitQName, LitQName noRange <$> unquoteN x) ]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Literal" t
+
+instance Unquote Term where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [] ->
+ choice
+ [(c `isCon` primAgdaTermUnsupported, pure hackReifyToMeta)]
+ __IMPOSSIBLE__
+
+ Con c [x] -> do
+ choice
+ [ (c `isCon` primAgdaTermSort, Sort <$> unquoteN x)
+ , (c `isCon` primAgdaTermLit, Lit <$> unquoteN x) ]
+ __IMPOSSIBLE__
+
+ Con c [x, y] ->
+ choice
+ [ (c `isCon` primAgdaTermVar, Var <$> (fromInteger <$> unquoteN x) <*> unquoteN y)
+ , (c `isCon` primAgdaTermCon, Con <$> unquoteN x <*> unquoteN y)
+ , (c `isCon` primAgdaTermDef, Def <$> (ensureDef =<< unquoteN x) <*> unquoteN y)
+ , (c `isCon` primAgdaTermLam, Lam <$> (flip setHiding defaultArgInfo <$> unquoteN x) <*> unquoteN y)
+ , (c `isCon` primAgdaTermPi, mkPi <$> (domFromArg <$> unquoteN x) <*> unquoteN y)
+ , (c `isCon` primAgdaTermExtLam, mkExtLam <$> unquoteN x <*> unquoteN y) ]
+ __IMPOSSIBLE__
+ where
+ mkExtLam = ExtLam
+ mkPi a (Abs _ b) = Pi a (Abs x b)
+ where x | 0 `freeIn` b = pickName (unDom a)
+ | otherwise = "_"
+ mkPi _ NoAbs{} = __IMPOSSIBLE__
+
+ Con{} -> __IMPOSSIBLE__
+ Lit{} -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Term" t
+
+instance Unquote Pattern where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [] -> do
+ choice
+ [ (c `isCon` primAgdaPatVar, pure (VarP "x"))
+ , (c `isCon` primAgdaPatAbsurd, pure (VarP "()"))
+ , (c `isCon` primAgdaPatDot, pure (DotP hackReifyToMeta))
+ ] __IMPOSSIBLE__
+ Con c [x] -> do
+ choice
+ [ (c `isCon` primAgdaPatProj, ProjP <$> unquoteN x)
+ , (c `isCon` primAgdaPatLit, LitP <$> unquoteN x) ]
+ __IMPOSSIBLE__
+ Con c [x, y] -> do
+ choice
+ [ (c `isCon` primAgdaPatCon, flip ConP Nothing <$> unquoteN x <*> (map (fmap unnamed) <$> unquoteN y)) ]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Pattern" t
+
+data UnquotedFunDef = UnQFun Type [Clause]
+
+instance Unquote Clause where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [x] -> do
+ choice
+ [ (c `isCon` primAgdaClauseAbsurd, mkClause Nothing <$> unquoteN x) ]
+ __IMPOSSIBLE__
+ Con c [x, y] -> do
+ choice
+ [ (c `isCon` primAgdaClauseClause, checkClause =<< mkClause . Just <$> unquoteN y <*> unquoteN x) ]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Clause" t
+ where
+ mkClause :: Maybe Term -> [I.Arg Pattern] -> I.Clause
+ mkClause b ps0 =
+ Clause { clauseRange = noRange
+ , clauseTel = dummyTel n'
+ , clausePerm = Perm n vs
+ , namedClausePats = ps
+ , clauseBody = mkBody n b
+ , clauseType = Nothing }
+ where
+ ps = map (fmap unnamed) ps0
+ n = vars True ps -- with dot patterns
+ n' = vars False ps -- without dot patterns
+ dummyTel 0 = EmptyTel
+ dummyTel n = ExtendTel (defaultDom typeDontCare) (Abs "x" $ dummyTel (n - 1))
+ mkBody 0 b = maybe NoBody Body b
+ mkBody n b = Bind $ Abs "x" $ mkBody (n - 1) b
+ vars d ps = sum $ map (vars' d . namedArg) ps
+ vars' d (ConP _ _ ps) = vars d ps
+ vars' d VarP{} = 1
+ vars' d DotP{} = if d then 1 else 0
+ vars' d LitP{} = 0
+ vars' d ProjP{} = 0
+
+ vs = evalState (execWriterT $ mapM_ (computePerm . namedArg) ps) 0
+ next = do n <- get; put (n + 1); return n
+
+ computePerm (ConP _ _ ps) = mapM_ (computePerm . namedArg) ps
+ computePerm VarP{} = tell . (:[]) =<< next
+ computePerm DotP{} = () <$ next
+ computePerm LitP{} = return ()
+ computePerm ProjP{} = return ()
+
+ checkClause :: I.Clause -> UnquoteM I.Clause
+ checkClause cl at Clause{ clausePerm = Perm n vs , clauseBody = body } = do
+ let freevs = allVars $ freeVars $ fromMaybe __IMPOSSIBLE__ $ getBody body
+ propervs = Set.fromList $ map ((n-1)-) vs
+ dottedvs = Set.difference (Set.fromList [0..n-1]) propervs
+ offending = Set.intersection freevs dottedvs
+ Agda.TypeChecking.Monad.reportSDoc "tc.unquote.clause.dotvars" 30 $ vcat
+ [ text $ "checkClause "
+ , nest 2 $ text $ "free vars: " ++ show freevs
+ , nest 2 $ text $ "dotted vars: " ++ show dottedvs
+ , nest 2 $ text $ "offending vars: " ++ show offending
+ ]
+ if Set.null offending
+ then return cl
+ else throwException $ RhsUsesDottedVar (Set.toList offending) t
+
+instance Unquote UnquotedFunDef where
+ unquote t = do
+ t <- lift $ reduce t
+ case ignoreSharing t of
+ Con c [x, y] -> do
+ choice
+ [ (c `isCon` primAgdaFunDefCon, UnQFun <$> unquoteN x <*> unquoteN y) ]
+ __IMPOSSIBLE__
+ Con c _ -> __IMPOSSIBLE__
+ _ -> throwException $ NotAConstructor "Pattern" t
+
+reifyUnquoted :: Reify a e => a -> TCM e
+reifyUnquoted = nowReifyingUnquoted . disableDisplayForms . withShowAllArguments . reify
diff --git a/src/full/Agda/TypeChecking/With.hs b/src/full/Agda/TypeChecking/With.hs
index 7bb4c74..67485bf 100644
--- a/src/full/Agda/TypeChecking/With.hs
+++ b/src/full/Agda/TypeChecking/With.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Agda.TypeChecking.With where
@@ -35,7 +35,7 @@ import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- showPat moved to TypeChecking.Pretty as prettyTCM instance
@@ -377,7 +377,7 @@ withDisplayForm f aux delta1 delta2 n qs perm@(Perm m _) lhsPerm = do
patsToTerms :: Permutation -> [I.NamedArg Pattern] -> [I.Arg DisplayTerm]
patsToTerms perm ps = evalState (toTerms ps) xs
where
- xs = permute (invertP perm) $ downFrom (size perm)
+ xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm)
tick = do x : xs <- get; put xs; return x
toTerms :: [I.NamedArg Pattern] -> State [Nat] [I.Arg DisplayTerm]
@@ -388,7 +388,7 @@ patsToTerms perm ps = evalState (toTerms ps) xs
ProjP d -> __IMPOSSIBLE__ -- TODO: convert spine to non-spine ... DDef d . defaultArg
VarP _ -> DTerm . var <$> tick
DotP t -> DDot t <$ tick
- ConP c _ ps -> DCon (conName c) <$> toTerms ps
+ ConP c _ ps -> DCon c <$> toTerms ps
LitP l -> return $ DTerm (Lit l)
{- OLD
diff --git a/src/full/Agda/Utils/AssocList.hs b/src/full/Agda/Utils/AssocList.hs
new file mode 100644
index 0000000..962c213
--- /dev/null
+++ b/src/full/Agda/Utils/AssocList.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Additional functions for association lists.
+
+module Agda.Utils.AssocList where
+
+import Prelude hiding (lookup)
+
+import Control.Applicative
+
+import Data.Functor
+import qualified Data.List as List
+
+import Agda.Utils.Tuple
+
+#include "undefined.h"
+import Agda.Utils.Impossible
+
+-- | A finite map, represented as a set of pairs.
+--
+-- Invariant: at most one value per key.
+type AssocList k v = [(k,v)]
+
+-- | O(n).
+-- Reexport 'List.lookup'.
+lookup :: Eq k => k -> AssocList k v -> Maybe v
+lookup = List.lookup
+
+-- | O(n).
+-- Get the domain (list of keys) of the finite map.
+keys :: AssocList k v -> [k]
+keys = map fst
+
+-- | O(1).
+-- Add a new binding.
+-- Assumes the binding is not yet in the list.
+insert :: k -> v -> AssocList k v -> AssocList k v
+insert k v = ((k,v) :)
+
+-- | O(n).
+-- Update the value at a key.
+-- The key must be in the domain of the finite map.
+-- Otherwise, an internal error is raised.
+update :: Eq k => k -> v -> AssocList k v -> AssocList k v
+update k v = updateAt k $ const v
+
+-- | O(n).
+-- Update the value at a key with a certain function.
+-- The key must be in the domain of the finite map.
+-- Otherwise, an internal error is raised.
+updateAt :: Eq k => k -> (v -> v) -> AssocList k v -> AssocList k v
+updateAt k f = loop where
+ loop [] = __IMPOSSIBLE__
+ loop (p@(k',v) : ps)
+ | k == k' = (k, f v) : ps
+ | otherwise = p : loop ps
+
+-- | O(n).
+-- Map over an association list, preserving the order.
+mapWithKey :: (k -> v -> v) -> AssocList k v -> AssocList k v
+mapWithKey f = map $ \ (k,v) -> (k, f k v)
+
+-- | O(n).
+-- If called with a effect-producing function, violation of the invariant
+-- could matter here (duplicating effects).
+mapWithKeyM :: (Functor m, Applicative m) => (k -> v -> m v) -> AssocList k v -> m (AssocList k v)
+mapWithKeyM f = mapM $ \ (k,v) -> (k,) <$> f k v
+ where
+ -- mapM is applicative!
+ mapM g [] = pure []
+ mapM g (x : xs) = (:) <$> g x <*> mapM g xs
+
+-- | O(n).
+-- Named in analogy to 'Data.Map.mapKeysMonotonic'.
+-- To preserve the invariant, it is sufficient that the key
+-- transformation is injective (rather than monotonic).
+mapKeysMonotonic :: (k -> k') -> AssocList k v -> AssocList k' v
+mapKeysMonotonic f = map $ mapFst f
diff --git a/src/full/Agda/Utils/Bag.hs b/src/full/Agda/Utils/Bag.hs
new file mode 100644
index 0000000..8e38cc8
--- /dev/null
+++ b/src/full/Agda/Utils/Bag.hs
@@ -0,0 +1,217 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | A simple overlay over Data.Map to manage unordered sets with duplicates.
+
+module Agda.Utils.Bag where
+
+import Prelude hiding (null, map)
+
+import Control.Applicative hiding (empty)
+import Text.Show.Functions ()
+
+import Data.Foldable (Foldable(foldMap))
+import Data.Functor.Identity
+import qualified Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Traversable as Trav
+
+import Agda.Utils.Functor
+import Agda.Utils.QuickCheck
+
+#include "undefined.h"
+import Agda.Utils.Impossible
+
+-- | A set with duplicates.
+-- Faithfully stores elements which are equal with regard to (==).
+newtype Bag a = Bag { bag :: Map a [a] }
+ deriving (Eq, Ord)
+ -- The list contains all occurrences of @a@ (not just the duplicates!).
+ -- Hence the invariant: the list is never empty!
+ --
+ -- This is slightly wasteful, but much easier to implement
+ -- in terms of Map as the alternative, which is to store
+ -- only the duplicates in the list.
+ -- See, e.g., implementation of 'union' which would be impossible
+ -- to do in the other representation. We would need a
+ -- 'Map.unionWithKey' that passes us *both* keys.
+ -- But Map works under the assumption that Eq for keys is identity,
+ -- it does not honor information in keys that goes beyond Ord.
+
+------------------------------------------------------------------------
+-- * Query
+------------------------------------------------------------------------
+
+null :: Bag a -> Bool
+null = Map.null . bag
+
+size :: Bag a -> Int
+size = getSum . foldMap (Sum . length) . bag
+
+-- | @bag ! a@ finds all elements equal to @a at .
+(!) :: Ord a => Bag a -> a -> [a]
+Bag b ! a = Map.findWithDefault [] a b
+
+member :: Ord a => a -> Bag a -> Bool
+member a = not . notMember a
+
+notMember :: Ord a => a -> Bag a -> Bool
+notMember a b = List.null (b ! a)
+
+-- | Return the multiplicity of the given element.
+count :: Ord a => a -> Bag a -> Int
+count a b = length (b ! a)
+
+------------------------------------------------------------------------
+-- * Construction
+------------------------------------------------------------------------
+
+empty :: Bag a
+empty = Bag $ Map.empty
+
+singleton :: a -> Bag a
+singleton a = Bag $ Map.singleton a [a]
+
+union :: Ord a => Bag a -> Bag a -> Bag a
+union (Bag b) (Bag c) = Bag $ Map.unionWith (++) b c
+
+unions :: Ord a => [Bag a] -> Bag a
+unions = Bag . Map.unionsWith (++) . List.map bag
+
+-- | @insert a b = union b (singleton a)@
+insert :: Ord a => a -> Bag a -> Bag a
+insert a = Bag . Map.insertWith (++) a [a] . bag
+
+-- | @fromList = unions . map singleton@
+fromList :: Ord a => [a] -> Bag a
+fromList = Bag . Map.fromListWith (++) . List.map (\ a -> (a,[a]))
+
+------------------------------------------------------------------------
+-- * Destruction
+------------------------------------------------------------------------
+
+-- | Returns the elements of the bag, grouped by equality (==).
+groups :: Bag a -> [[a]]
+groups = Map.elems . bag
+
+-- | Returns the bag, with duplicates.
+toList :: Bag a -> [a]
+toList = concat . groups
+
+-- | Returns the bag without duplicates.
+keys :: Bag a -> [a]
+keys = Map.keys . bag
+-- Works because of the invariant!
+-- keys = catMaybes . map headMaybe . Map.elems . bag
+-- -- Map.keys does not work, as zero copies @(a,[])@
+-- -- should count as not present in the bag.
+
+-- | Returns the bag, with duplicates.
+elems :: Bag a -> [a]
+elems = toList
+
+toAscList :: Bag a -> [a]
+toAscList = toList
+
+------------------------------------------------------------------------
+-- * Traversal
+------------------------------------------------------------------------
+
+map :: (Ord a, Ord b) => (a -> b) -> Bag a -> Bag b
+map f = Bag . Map.fromListWith (++) . List.map ff . Map.elems . bag
+ where
+ ff (a : as) = (b, b : List.map f as) where b = f a
+ ff [] = __IMPOSSIBLE__
+
+traverse :: forall a b m . (Applicative m, Ord b) => (a -> m b) -> Bag a -> m (Bag b)
+traverse f = (Bag . Map.fromListWith (++)) <.> Trav.traverse trav . Map.elems . bag
+ where
+ trav :: [a] -> m (b, [b])
+ trav (a : as) = (\ b bs -> (b, b:bs)) <$> f a <*> Trav.traverse f as
+ trav [] = __IMPOSSIBLE__
+
+------------------------------------------------------------------------
+-- * Instances
+------------------------------------------------------------------------
+
+instance Show a => Show (Bag a) where
+ showsPrec _ (Bag b) = ("Agda.Utils.Bag.Bag (" ++) . showsPrec 0 b . (')':)
+
+instance Ord a => Monoid (Bag a) where
+ mempty = empty
+ mappend = union
+ mconcat = unions
+
+instance Foldable Bag where
+ foldMap f = foldMap f . toList
+
+-- not a Functor (only works for 'Ord'ered types)
+-- not Traversable (only works for 'Ord'ered types)
+
+------------------------------------------------------------------------
+-- * Properties
+------------------------------------------------------------------------
+
+instance (Ord a, Arbitrary a) => Arbitrary (Bag a) where
+ arbitrary = fromList <$> arbitrary
+
+prop_count_empty :: Ord a => a -> Bool
+prop_count_empty a = count a empty == 0
+
+prop_count_singleton :: Ord a => a -> Bool
+prop_count_singleton a = count a (singleton a) == 1
+
+prop_count_insert :: Ord a => a -> Bag a -> Bool
+prop_count_insert a b = count a (insert a b) == 1 + count a b
+
+prop_size_union :: Ord a => Bag a -> Bag a -> Bool
+prop_size_union b c = size (b `union` c) == size b + size c
+
+prop_size_fromList :: Ord a => [a] -> Bool
+prop_size_fromList l = size (fromList l) == length l
+
+prop_fromList_toList :: Ord a => Bag a -> Bool
+prop_fromList_toList b = fromList (toList b) == b
+
+prop_toList_fromList :: Ord a => [a] -> Bool
+prop_toList_fromList l = toList (fromList l) == List.sort l
+
+prop_keys_fromList :: Ord a => [a] -> Bool
+prop_keys_fromList l = keys (fromList l) == Set.toList (Set.fromList l)
+
+prop_nonempty_groups :: Bag a -> Bool
+prop_nonempty_groups b = all (not . List.null) $ groups b
+
+prop_map_id :: Ord a => Bag a -> Bool
+prop_map_id b = map id b == b
+
+prop_map_compose :: (Ord a, Ord b, Ord c) =>
+ (b -> c) -> (a -> b) -> Bag a -> Bool
+prop_map_compose f g b = map f (map g b) == map (f . g) b
+
+prop_traverse_id :: Ord a => Bag a -> Bool
+prop_traverse_id b = traverse Identity b == Identity b
+
+------------------------------------------------------------------------
+-- * All tests
+------------------------------------------------------------------------
+
+-- Template Haskell hack to make the following $quickCheckAll work
+-- under ghc-7.8.
+return [] -- KEEP!
+
+-- | All tests as collected by 'quickCheckAll'.
+--
+-- Using 'quickCheckAll' is convenient and superior to the manual
+-- enumeration of tests, since the name of the property is
+-- added automatically.
+
+tests :: IO Bool
+tests = do
+ putStrLn "Agda.Utils.Favorites"
+ $quickCheckAll
diff --git a/src/full/Agda/Utils/BiMap.hs b/src/full/Agda/Utils/BiMap.hs
index 12824f1..4a70302 100644
--- a/src/full/Agda/Utils/BiMap.hs
+++ b/src/full/Agda/Utils/BiMap.hs
@@ -1,11 +1,11 @@
--- | Finite bijections (implemented as a pair of maps).
-
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Finite bijections (implemented as a pair of maps).
module Agda.Utils.BiMap where
@@ -89,6 +89,7 @@ instance (Ord a, Ord b, Arbitrary a, Arbitrary b) => Arbitrary (BiMap a b) where
-- * Properties
------------------------------------------------------------------------
+prop_BiMap_invariant :: (Ord a, Ord b) => BiMap a b -> Bool
prop_BiMap_invariant (BiMap t u) =
Map.toAscList t == List.sort (List.map swap (Map.toList u))
diff --git a/src/full/Agda/Utils/Char.hs b/src/full/Agda/Utils/Char.hs
index 56985a6..ae181b4 100644
--- a/src/full/Agda/Utils/Char.hs
+++ b/src/full/Agda/Utils/Char.hs
@@ -1,14 +1,54 @@
-
module Agda.Utils.Char where
import Data.Char
+-- | Convert a character in @'0'..'9'@ into the corresponding digit @0..9 at .
+
decDigit :: Char -> Int
decDigit c = ord c - ord '0'
+-- | Convert a character in @'0'..'9','A'..'F','a'..'f'@
+-- into the corresponding digit @0..15 at .
+
hexDigit :: Char -> Int
-hexDigit c | isDigit c = decDigit c
- | otherwise = ord (toLower c) - ord 'a' + 10
+hexDigit c | isDigit c = decDigit c
+ | otherwise = ord (toLower c) - ord 'a' + 10
+
+-- | Convert a character in @'0'..'7'@ into the corresponding digit @0..7 at .
octDigit :: Char -> Int
octDigit = decDigit
+
+------------------------------------------------------------------------
+-- * Unicode exploration
+------------------------------------------------------------------------
+
+-- | Unicode characters are divided into letters, numbers, marks,
+-- punctuation, symbols, separators (including spaces) and others
+-- (including control characters).
+--
+-- These are the tests that 'Data.Char' offers
+data UnicodeTest
+ = IsControl | IsSpace
+ | IsLower | IsUpper | IsAlpha | IsAlphaNum | IsPrint
+ | IsDigit | IsOctDigit | IsHexDigit
+ | IsLetter | IsMark | IsNumber | IsPunctuation | IsSymbol | IsSeparator
+ deriving (Eq, Ord, Show)
+
+-- | Test names paired with their implementation.
+unicodeTests :: [(UnicodeTest, Char -> Bool)]
+unicodeTests =
+ [ (IsControl, isControl), (IsSpace, isSpace)
+ , (IsLower, isLower), (IsUpper, isUpper), (IsAlpha, isAlpha)
+ , (IsAlphaNum, isAlphaNum)
+ , (IsPrint, isPrint)
+ , (IsDigit, isDigit), (IsOctDigit, isOctDigit), (IsHexDigit, isHexDigit)
+ , (IsLetter, isLetter), (IsMark, isMark)
+ , (IsNumber, isNumber), (IsPunctuation, isPunctuation), (IsSymbol, isSymbol)
+ , (IsSeparator, isSeparator)
+ ]
+
+-- | Find out which tests a character satisfies.
+testChar :: Char -> [UnicodeTest]
+testChar c = map fst $ filter (($ c) . snd) unicodeTests
+
diff --git a/src/full/Agda/Utils/Cluster.hs b/src/full/Agda/Utils/Cluster.hs
index 0167e52..f72229f 100644
--- a/src/full/Agda/Utils/Cluster.hs
+++ b/src/full/Agda/Utils/Cluster.hs
@@ -1,7 +1,6 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
+-- {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- {-# LANGUAGE TupleSections #-}
-- | Create clusters of non-overlapping things.
@@ -18,11 +17,12 @@ import Data.Equivalence.Monad
import Data.Char
import Data.Functor
-import qualified Data.IntMap as Map
+import qualified Data.IntMap as IntMap
import Data.List
import Test.QuickCheck
import Test.QuickCheck.All
+import Test.QuickCheck.Function
import Text.Show.Functions
-- | Characteristic identifiers.
@@ -30,23 +30,25 @@ type C = Int
-- | Given a function @f :: a -> (C,[C])@ which returns a non-empty list of
-- characteristics @C@ of @a@, partition a list of @a at s into groups
--- that share at least one characteristics.
-cluster :: forall a. (a -> (C,[C])) -> [a] -> [[a]]
+-- such that each element in a group shares at least one characteristic
+-- with at least one other element of the group.
+cluster :: (a -> (C,[C])) -> [a] -> [[a]]
cluster f as = cluster' $ map (\ a -> (a, f a)) as
-- | Partition a list of @a at s paired with a non-empty list of
--- characteristics $C$ into groups that share at least one
--- characteristics.
-cluster' :: forall a. [(a,(C,[C]))] -> [[a]]
+-- 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,(C,[C]))] -> [[a]]
cluster' acs = runEquivM id const $ do
-- Construct the equivalence classes of characteristics.
- forM acs $ \ (_,(c,cs)) -> equateAll $ c:cs
+ forM_ acs $ \ (_,(c,cs)) -> equateAll $ c:cs
-- Pair each element with its class.
- cas <- forM acs $ \ (a,(c,_)) -> (`Map.singleton` [a]) <$> classDesc c
+ cas <- forM acs $ \ (a,(c,_)) -> (`IntMap.singleton` [a]) <$> classDesc c
-- Create a map from class to elements.
- let m = Map.unionsWith (++) cas
+ let m = IntMap.unionsWith (++) cas
-- Return the values of the map
- return $ Map.elems m
+ return $ IntMap.elems m
------------------------------------------------------------------------
-- * Properties
@@ -55,29 +57,80 @@ cluster' acs = runEquivM id const $ do
-- instance Show (Int -> (C, [C])) where
-- show f = "function " ++ show (map (\ x -> (x, f x)) [-10..10])
+-- Fundamental properties: soundness and completeness
+
+-- | Not too many clusters. (Algorithm equated all it could.)
+--
+-- Each element in a cluster shares a characteristic with at least one
+-- other element in the same cluster.
+prop_cluster_complete :: Fun Int (C, [C]) -> [Int] -> Bool
+prop_cluster_complete (Fun _ f) as =
+ (`all` cluster f as) $ \ cl ->
+ (`all` cl) $ \ a ->
+ let csa = uncurry (:) $ f a in
+ let cl' = delete a cl in
+ -- Either a is the single element of the cluster, or it shares a characteristic c
+ -- with some other element b of the same cluster.
+ null cl' || not (null [ (b,c) | b <- cl', c <- uncurry (:) (f b), c `elem` csa ])
+
+-- | Not too few clusters. (Algorithm did not equate too much.)
+--
+-- Elements of different clusters share no characteristics.
+prop_cluster_sound :: Fun Int (C, [C]) -> [Int] -> Bool
+prop_cluster_sound (Fun _ f) as =
+ (`all` [ (c, d) | let cs = cluster f as, c <- cs, d <- cs, c /= d]) $ \ (c, d) ->
+ (`all` c) $ \ a ->
+ (`all` d) $ \ b ->
+ null $ (uncurry (:) $ f a) `intersect` (uncurry (:) $ f b)
+
+neToList :: (a, [a]) -> [a]
+neToList = uncurry (:)
+
+isSingleton, exactlyTwo, atLeastTwo :: [a] -> Bool
isSingleton x = length x == 1
exactlyTwo x = length x == 2
atLeastTwo x = length x >= 2
+prop_cluster_empty :: Bool
prop_cluster_empty =
null (cluster (const (0,[])) [])
-prop_cluster_permutation f (as :: [Int]) =
+prop_cluster_permutation :: Fun Int (C, [C]) -> [Int] -> Bool
+prop_cluster_permutation (Fun _ f) as =
sort as == sort (concat (cluster f as))
+prop_cluster_single :: a -> [a] -> Bool
prop_cluster_single a as =
isSingleton $ cluster (const (0,[])) $ (a:as)
-prop_cluster_idem f a as =
+prop_cluster_idem :: Fun a (C, [C]) -> a -> [a] -> Bool
+prop_cluster_idem (Fun _ f) a as =
isSingleton $ cluster f $ head $ cluster f (a:as)
-prop_two_clusters (as :: [Int]) =
+prop_two_clusters :: [Int] -> Bool
+prop_two_clusters as =
atLeastTwo $ cluster (\ x -> (x, [x])) (-1:1:as)
+-- | An example.
+--
+-- "anabel" is related to "babel" (common letter 'a' in 2-letter prefix)
+-- which is related to "bond" (common letter 'b').
+--
+-- "hurz", "furz", and "kurz" are all related (common letter 'u').
+test :: [[String]]
test = cluster (\ (x:y:_) -> (ord x,[ord y]))
["anabel","bond","babel","hurz","furz","kurz"]
-test1 = cluster (\ (x:y:_) -> (ord x,[]))
- ["anabel","bond","babel","hurz","furz","kurz"]
+
+prop_test :: Bool
+prop_test = test == [["anabel","bond","babel"],["hurz","furz","kurz"]]
+
+-- | Modified example (considering only the first letter).
+test1 :: [[String]]
+test1 = cluster (\ (x:_:_) -> (ord x,[]))
+ ["anabel","bond","babel","hurz","furz","kurz"]
+
+prop_test1 :: Bool
+prop_test1 = test1 == [["anabel"],["bond","babel"],["furz"],["hurz"],["kurz"]]
------------------------------------------------------------------------
-- * All tests
diff --git a/src/full/Agda/Utils/Either.hs b/src/full/Agda/Utils/Either.hs
index 3037d73..d7075a2 100644
--- a/src/full/Agda/Utils/Either.hs
+++ b/src/full/Agda/Utils/Either.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------
-- | Utilities for the 'Either' type
------------------------------------------------------------------------
@@ -8,6 +6,7 @@ module Agda.Utils.Either
( whileLeft, caseEitherM
, mapEither, mapLeft, mapRight
, isLeft, isRight
+ , fromLeft, fromRight
, allRight
, tests
) where
@@ -17,9 +16,6 @@ import Control.Applicative
import Agda.Utils.QuickCheck
import Agda.Utils.TestHelpers
-#include "../undefined.h"
-import Agda.Utils.Impossible
-
-- | Loop while we have an exception.
whileLeft :: Monad m => (a -> Either b c) -> (a -> b -> m a) -> (a -> c -> m d) -> a -> m d
@@ -30,10 +26,10 @@ whileLeft test left right = loop where
Right c -> right a c
-- | Monadic version of 'either' with a different argument ordering.
+
caseEitherM :: Monad m => m (Either a b) -> (a -> m c) -> (b -> m c) -> m c
caseEitherM mm f g = either f g =<< mm
-
-- | 'Either' is a bifunctor.
mapEither :: (a -> c) -> (b -> d) -> Either a b -> Either c d
@@ -50,17 +46,25 @@ mapRight :: (b -> d) -> Either a b -> Either a d
mapRight = mapEither id
-- | Returns 'True' iff the argument is @'Right' x@ for some @x at .
-
+-- Note: from @base >= 4.7.0.0@ already present in @Data.Either at .
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight (Left _) = False
-- | Returns 'True' iff the argument is @'Left' x@ for some @x at .
-
+-- Note: from @base >= 4.7.0.0@ already present in @Data.Either at .
isLeft :: Either a b -> Bool
isLeft (Right _) = False
isLeft (Left _) = True
+-- | Analogue of 'Data.Maybe.fromMaybe'.
+fromLeft :: (b -> a) -> Either a b -> a
+fromLeft = either id
+
+-- | Analogue of 'Data.Maybe.fromMaybe'.
+fromRight :: (a -> b) -> Either a b -> b
+fromRight f = either f id
+
-- | Returns @'Just' <input with tags stripped>@ if all elements are
-- to the right, and otherwise 'Nothing'.
--
@@ -77,48 +81,13 @@ allRight [] = Just []
allRight (Left _ : _ ) = Nothing
allRight (Right b : xs) = (b:) <$> allRight xs
+prop_allRight :: Eq b => [Either t b] -> Bool
prop_allRight xs =
allRight xs ==
if all isRight xs then
- Just (map fromRight xs)
+ Just $ map (\ (Right x) -> x) xs
else
Nothing
- where
- fromRight (Right x) = x
- fromRight (Left _) = __IMPOSSIBLE__
-
-{- Andreas, 2012-12-01 I do not know why it makes sense to copy
- the input (only extra work for the garbage collector...
- So I disable the code below...
-
--- | Returns @'Right' <input with tags stripped>@ if all elements are
--- to the right, and otherwise @Left <input>@:
---
--- @
--- allRight xs ==
--- if all isRight xs then
--- Right (map (\(Right x) -> x) xs)
--- else
--- Left xs
--- @
-
-allRight :: [Either a b] -> Either [Either a b] [b]
-allRight [] = Right []
-allRight xs@(Left _ : _) = Left xs
-allRight (Right b : xs) = case allRight xs of
- Left xs -> Left (Right b : xs)
- Right bs -> Right (b : bs)
-
-prop_allRight xs =
- allRight xs ==
- if all isRight xs then
- Right (map fromRight xs)
- else
- Left xs
- where
- fromRight (Right x) = x
- fromRight (Left _) = __IMPOSSIBLE__
--}
------------------------------------------------------------------------
-- All tests
diff --git a/src/full/Agda/Utils/Empty.hs b/src/full/Agda/Utils/Empty.hs
new file mode 100644
index 0000000..2ae574a
--- /dev/null
+++ b/src/full/Agda/Utils/Empty.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE EmptyDataDecls #-}
+
+-- | An empty type with some useful instances.
+module Agda.Utils.Empty where
+
+import Agda.Utils.Impossible
+
+#include "undefined.h"
+
+data Empty
+
+instance Eq Empty where
+ _ == _ = True
+
+instance Ord Empty where
+ compare _ _ = EQ
+
+instance Show Empty where
+ showsPrec p _ = showParen (p > 9) $ showString "error \"Agda.Utils.Empty.Empty\""
+
+absurd :: Empty -> a
+absurd e = seq e __IMPOSSIBLE__
+
diff --git a/src/full/Agda/Utils/Except.hs b/src/full/Agda/Utils/Except.hs
new file mode 100644
index 0000000..f2c3107
--- /dev/null
+++ b/src/full/Agda/Utils/Except.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
+------------------------------------------------------------------------------
+-- | Wrapper for Control.Monad.Except from the mtl package
+------------------------------------------------------------------------------
+
+module Agda.Utils.Except
+ ( Error(noMsg, strMsg)
+ , ExceptT
+ , mkExceptT
+ , MonadError(catchError, throwError)
+ , runExceptT
+ ) where
+
+------------------------------------------------------------------------
+#if MIN_VERSION_mtl(2,2,1)
+-- New mtl, reexport ExceptT, define class Error for backward compat.
+------------------------------------------------------------------------
+
+import Control.Monad.Except
+
+-- | We cannot define data constructors synonymous, so we define the
+-- @mkExceptT@ function to be used instead of the data constructor
+-- @ExceptT at .
+mkExceptT :: m (Either e a) -> ExceptT e m a
+mkExceptT = ExceptT
+
+-- From Control.Monad.Trans.Error of transformers 0.3.0.0.
+
+class Error a where
+ noMsg :: a
+ strMsg :: String -> a
+
+ noMsg = strMsg ""
+ strMsg _ = noMsg
+
+-- | A string can be thrown as an error.
+instance Error String where
+ strMsg = id
+
+------------------------------------------------------------------------
+#else
+-- Old mtl, need to define ExceptT from ErrorT
+------------------------------------------------------------------------
+
+import Control.Monad.Error
+
+type ExceptT = ErrorT
+
+-- | We cannot define data constructors synonymous, so we define the
+-- @mkExceptT@ function to be used instead of the data constructor
+-- @ErrorT at .
+mkExceptT :: m (Either e a) -> ExceptT e m a
+mkExceptT = ErrorT
+
+-- | 'runExcept' function using mtl 2.1.*.
+runExceptT :: ExceptT e m a -> m (Either e a)
+runExceptT = runErrorT
+
+#endif
diff --git a/src/full/Agda/Utils/Favorites.hs b/src/full/Agda/Utils/Favorites.hs
index 2a290b1..317e262 100644
--- a/src/full/Agda/Utils/Favorites.hs
+++ b/src/full/Agda/Utils/Favorites.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
-- | Maintaining a list of favorites of some partially ordered type.
-- Only the best elements are kept.
@@ -39,7 +39,7 @@ import Agda.Utils.QuickCheck
import Agda.Utils.TestHelpers
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | A list of incomparable favorites.
@@ -151,12 +151,15 @@ instance PartialOrd a => Monoid (Favorites a) where
instance (PartialOrd a, Arbitrary a) => Arbitrary (Favorites a) where
arbitrary = fromList <$> arbitrary
+property_null_empty :: Bool
property_null_empty = null empty
+property_not_null_singleton :: a -> Bool
property_not_null_singleton = not . null . singleton
-- Remember: less is better!
+prop_compareWithFavorites :: ISet -> Favorites ISet -> Bool
prop_compareWithFavorites a at ISet{} as =
case compareWithFavorites a as of
Dominates dominated notDominated ->
diff --git a/src/full/Agda/Utils/FileName.hs b/src/full/Agda/Utils/FileName.hs
index 94a7d6f..626a573 100644
--- a/src/full/Agda/Utils/FileName.hs
+++ b/src/full/Agda/Utils/FileName.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-| Operations on file names. -}
@@ -30,7 +30,7 @@ import Data.Typeable (Typeable)
import Agda.Utils.TestHelpers
import Agda.Utils.QuickCheck
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Paths which are known to be absolute.
@@ -75,6 +75,11 @@ mkAbsolute f
AbsolutePath $ ByteString.pack $ dropTrailingPathSeparator $ normalise f
| otherwise = __IMPOSSIBLE__
+#if mingw32_HOST_OS
+prop_mkAbsolute :: FilePath -> Property
+#else
+prop_mkAbsolute :: FilePath -> Bool
+#endif
prop_mkAbsolute f =
let path = rootPath ++ f
in
@@ -83,6 +88,7 @@ prop_mkAbsolute f =
#endif
absolutePathInvariant $ mkAbsolute $ path
+rootPath :: FilePath
#if mingw32_HOST_OS
rootPath = joinDrive "C:" [pathSeparator]
#else
@@ -148,6 +154,7 @@ instance Arbitrary AbsolutePath where
------------------------------------------------------------------------
-- All tests
+tests :: IO Bool
tests = runTests "Agda.Utils.FileName"
[ quickCheck' absolutePathInvariant
, quickCheck' prop_mkAbsolute
diff --git a/src/full/Agda/Utils/Fresh.hs b/src/full/Agda/Utils/Fresh.hs
deleted file mode 100644
index 95d8740..0000000
--- a/src/full/Agda/Utils/Fresh.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-
-{-| A common interface for monads which allow some kind of fresh name
- generation.
--}
-module Agda.Utils.Fresh where
-
-import Control.Monad.State
-import Control.Monad.Reader
-
-class HasFresh i a where
- nextFresh :: a -> (i,a)
-
-fresh :: (HasFresh i s, MonadState s m) => m i
-fresh =
- do (i,s) <- gets nextFresh
- put s
- return i
-
-withFresh :: (HasFresh i e, MonadReader e m) => (i -> m a) -> m a
-withFresh ret =
- do (i,e) <- asks nextFresh
- local (const e) $ ret i
diff --git a/src/full/Agda/Utils/Function.hs b/src/full/Agda/Utils/Function.hs
index b27997d..1f0bcdf 100644
--- a/src/full/Agda/Utils/Function.hs
+++ b/src/full/Agda/Utils/Function.hs
@@ -1,24 +1,55 @@
+{-# LANGUAGE TupleSections #-}
module Agda.Utils.Function where
+-- | Repeat something while a condition on some state is true.
+-- Return the last state (including the changes of the last
+-- transition, even if the condition became false then).
+
+repeatWhile :: (a -> (Bool, a)) -> a -> a
+repeatWhile f = loop where
+ loop a = if again then loop a' else a'
+ where (again, a') = f a
+
+-- | Monadic version of 'repeatWhile'.
+repeatWhileM :: (Monad m) => (a -> m (Bool, a)) -> a -> m a
+repeatWhileM f = loop where
+ loop a = do
+ (again, a') <- f a
+ if again then loop a' else return a'
+
-- | A version of the trampoline function.
--
-- The usual function iterates @f :: a -> Maybe a@ as long
-- as @Just{}@ is returned, and returns the last value of @a@
-- upon @Nothing at .
--
--- @usualTrampoline f = trampoline $ \ a -> maybe (False,a) (True,) (f a)@.
-trampoline :: (a -> (Bool, a)) -> a -> a
+-- @usualTrampoline f = trampolineWhile $ \ a -> maybe (False,a) (True,) (f a)@.
+--
+-- @trampolineWhile@ is very similar to @repeatWhile@, only that
+-- it discards the state on which the condition went @False@,
+-- and returns the last state on which the condition was @True at .
+trampolineWhile :: (a -> (Bool, a)) -> a -> a
+trampolineWhile f = repeatWhile $ \ a ->
+ let (again, a') = f a
+ in (again,) $ if again then a' else a
+
+-- | Monadic version of 'trampolineWhile'.
+trampolineWhileM :: (Monad m) => (a -> m (Bool, a)) -> a -> m a
+trampolineWhileM f = repeatWhileM $ \ a -> do
+ (again, a') <- f a
+ return $ (again,) $ if again then a' else a
+
+-- | More general trampoline, which allows some final computation
+-- from iteration state @a@ into result type @b at .
+trampoline :: (a -> Either b a) -> a -> b
trampoline f = loop where
- loop a = if again then loop a' else a'
- where (again, a') = f a
+ loop a = either id loop $ f a
-- | Monadic version of 'trampoline'.
-trampolineM :: (Monad m) => (a -> m (Bool, a)) -> a -> m a
+trampolineM :: Monad m => (a -> m (Either b a)) -> a -> m b
trampolineM f = loop where
- loop a = do
- (again, a') <- f a
- if again then loop a' else return a'
+ loop a = either return loop =<< f a
-- | Iteration to fixed-point.
--
diff --git a/src/full/Agda/Utils/Functor.hs b/src/full/Agda/Utils/Functor.hs
index 724a04e..621e970 100644
--- a/src/full/Agda/Utils/Functor.hs
+++ b/src/full/Agda/Utils/Functor.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
-- | Utilities for functors.
@@ -13,6 +14,12 @@ import Data.Functor.Identity
import Data.Functor.Compose
import Data.Functor.Constant
+-- ASR (15 October 2014): See issue 1304.
+#if !MIN_VERSION_transformers(0,4,1)
+instance Eq a => Eq (Identity a) where
+ Identity x == Identity x' = x == x'
+#endif
+
infixr 4 $>
($>) :: Functor f => f a -> b -> f b
@@ -29,6 +36,12 @@ infixr 9 <.>
for :: Functor m => m a -> (a -> b) -> m b
for = flip fmap
+infix 4 <&>
+
+-- | Infix version of 'for'.
+(<&>) :: Functor m => m a -> (a -> b) -> m b
+(<&>) = for
+
-- | A decoration is a functor that is traversable into any functor.
--
-- The 'Functor' superclass is given because of the limitations
diff --git a/src/full/Agda/Utils/Geniplate.hs b/src/full/Agda/Utils/Geniplate.hs
index d8c88f6..ecac3fe 100644
--- a/src/full/Agda/Utils/Geniplate.hs
+++ b/src/full/Agda/Utils/Geniplate.hs
@@ -11,12 +11,15 @@ module Agda.Utils.Geniplate
import Data.Generics.Geniplate
import Data.Map (Map)
+import qualified Language.Haskell.TH as TH
+
import qualified Agda.Syntax.Abstract.Name as A
import qualified Agda.Syntax.Concrete.Name as C
import qualified Agda.Syntax.Scope.Base as S
-- | Types which Geniplate should not descend into.
+dontDescendInto :: [TH.TypeQ]
dontDescendInto =
[ [t| String |]
, [t| A.QName |]
@@ -32,6 +35,7 @@ dontDescendInto =
-- 'universeBi' functions neither descend into the types in
-- 'dontDescendInto', nor into the types in the list argument.
+instanceUniverseBiT' :: [TH.TypeQ] -> TH.TypeQ -> TH.Q [TH.Dec]
instanceUniverseBiT' ts p =
instanceUniverseBiT (ts ++ dontDescendInto) p
@@ -39,5 +43,6 @@ instanceUniverseBiT' ts p =
-- 'transformBiM' functions neither descend into the types in
-- 'dontDescendInto', nor into the types in the list argument.
+instanceTransformBiMT' :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ -> TH.Q [TH.Dec]
instanceTransformBiMT' ts p =
instanceTransformBiMT (ts ++ dontDescendInto) p
diff --git a/src/full/Agda/Utils/Graph/AdjacencyMap.hs b/src/full/Agda/Utils/Graph/AdjacencyMap.hs
index 3e914e9..444fb02 100644
--- a/src/full/Agda/Utils/Graph/AdjacencyMap.hs
+++ b/src/full/Agda/Utils/Graph/AdjacencyMap.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE TupleSections, DeriveFunctor, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
-- | Directed graphs (can of course simulate undirected graphs).
--
@@ -128,6 +130,7 @@ nodes g = Map.keysSet (unGraph g)
fromNodes :: Ord n => [n] -> Graph n e
fromNodes = Graph . Map.fromList . map (, Map.empty)
+prop_nodes_fromNodes :: Ord n => [n] -> Bool
prop_nodes_fromNodes ns = nodes (fromNodes ns) == Set.fromList ns
-- | Constructs a graph from a list of edges. O(e)
@@ -278,6 +281,7 @@ transitiveClosure g = List.foldl' extend g $ sccs' g
Just es -> Graph $ Map.singleton a $ Map.map (otimes w) es
Nothing -> empty
+prop_transitiveClosure :: (Eq e, SemiRing e, Ord n) => Graph n e -> Property
prop_transitiveClosure g = label sccInfo $
transitiveClosure g == transitiveClosure1 g
where
diff --git a/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs b/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs
index 8db1060..ed73e66 100644
--- a/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs
+++ b/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs
@@ -1,5 +1,8 @@
-{-# LANGUAGE TupleSections, DoAndIfThenElse,
- DeriveFunctor, GeneralizedNewtypeDeriving, FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
-- | Directed graphs (can of course simulate undirected graphs).
--
@@ -67,7 +70,7 @@ import Data.Set (Set)
import Agda.Utils.Function (iterateUntil)
import Agda.Utils.Functor (for)
-import Agda.Utils.List (mhead)
+import Agda.Utils.List (headMaybe)
import Agda.Utils.QuickCheck as QuickCheck
import Agda.Utils.SemiRing
import Agda.Utils.TestHelpers
@@ -157,6 +160,7 @@ lookup s t (Graph g) = Map.lookup t =<< Map.lookup s g
neighbours :: (Ord s, Ord t) => s -> Graph s t e -> [(t, e)]
neighbours s (Graph g) = maybe [] Map.assocs $ Map.lookup s g
+prop_neighbours :: (Ord s, Ord t, Eq e) => s -> Graph s t e -> Bool
prop_neighbours s g =
neighbours s g == map (\ (Edge s t e) -> (t, e)) (edgesFrom g [s])
@@ -204,6 +208,7 @@ nodes = allNodes . computeNodes
fromNodes :: Ord n => [n] -> Graph n n e
fromNodes ns = Graph $ Map.fromList $ map (, Map.empty) ns
+prop_nodes_fromNodes :: Ord n => [n] -> Bool
prop_nodes_fromNodes ns = sourceNodes (fromNodes ns) == Set.fromList ns
-- | Constructs a graph from a list of edges. O(e log n)
@@ -222,7 +227,7 @@ fromListWith f = List.foldl' (flip (insertEdgeWith f)) empty
-- | Convert a graph into a list of edges. O(e)
-toList :: (Ord s, Ord t) => Graph s t e -> [Edge s t e]
+toList :: (Ord s, Ord t) => Graph s t e -> [Edge s t e]
toList (Graph g) = [ Edge s t a | (s,m) <- Map.assocs g, (t,a) <- Map.assocs m ]
-- | Empty graph (no nodes, no edges).
@@ -246,12 +251,14 @@ insertEdge (Edge s t e) = insert s t e
-- | Insert an edge, possibly combining @old@ edge weight with @new@ weight by
-- given function @f@ into @f new old at .
-insertWith :: (Ord s, Ord t) => (e -> e -> e) -> s -> t -> e -> Graph s t e -> Graph s t e
+insertWith :: (Ord s, Ord t) =>
+ (e -> e -> e) -> s -> t -> e -> Graph s t e -> Graph s t e
insertWith f s t e (Graph g) = Graph (Map.alter (Just . ins) s g)
where ins Nothing = Map.singleton t e
ins (Just m) = Map.insertWith f t e m
-insertEdgeWith :: (Ord s, Ord t) => (e -> e -> e) -> Edge s t e -> Graph s t e -> Graph s t e
+insertEdgeWith :: (Ord s, Ord t) =>
+ (e -> e -> e) -> Edge s t e -> Graph s t e -> Graph s t e
insertEdgeWith f (Edge s t e) = insertWith f s t e
-- | Left-biased union.
@@ -259,7 +266,8 @@ insertEdgeWith f (Edge s t e) = insertWith f s t e
union :: (Ord s, Ord t) => Graph s t e -> Graph s t e -> Graph s t e
union = unionWith $ \ left right -> left
-unionWith :: (Ord s, Ord t) => (e -> e -> e) -> Graph s t e -> Graph s t e -> Graph s t e
+unionWith :: (Ord s, Ord t) =>
+ (e -> e -> e) -> Graph s t e -> Graph s t e -> Graph s t e
unionWith f (Graph g) (Graph g') = Graph $ Map.unionWith (Map.unionWith f) g g'
unions ::(Ord s, Ord t) => [Graph s t e] -> Graph s t e
@@ -268,7 +276,8 @@ unions = unionsWith $ \ left right -> left
unionsWith :: (Ord s, Ord t) => (e -> e -> e) -> [Graph s t e] -> Graph s t e
unionsWith f = List.foldl' (unionWith f) empty
-prop_insertWith :: (Eq e, Ord s, Ord t) => (e -> e -> e) -> s -> t -> e -> Graph s t e -> Bool
+prop_insertWith :: (Eq e, Ord s, Ord t) =>
+ (e -> e -> e) -> s -> t -> e -> Graph s t e -> Bool
prop_insertWith f s t e g =
insertWith f s t e g == unionWith (flip f) g (singleton s t e)
@@ -448,6 +457,7 @@ transitiveClosure g = List.foldl' extend g $ sccs' g
-- | Correctness of the optimized algorithm that proceeds by SCC.
+prop_transitiveClosure :: (Eq e, SemiRing e, Ord n) => Graph n n e -> Property
prop_transitiveClosure g = QuickCheck.label sccInfo $
transitiveClosure g == transitiveClosure1 g
where
@@ -461,7 +471,7 @@ prop_transitiveClosure g = QuickCheck.label sccInfo $
--
-- The path must satisfy the given predicate @good :: e -> Bool at .
findPath :: (SemiRing e, Ord n) => (e -> Bool) -> n -> n -> Graph n n e -> Maybe e
-findPath good a b g = mhead $ filter good $ allPaths good a b g
+findPath good a b g = headMaybe $ filter good $ allPaths good a b g
-- | @allPaths classify a b g@ returns a list of pathes (accumulated edge weights)
-- from node @a@ to node @b@ in @g at .
@@ -524,6 +534,7 @@ type G = Graph N N E
newtype N = N (Positive Int)
deriving (Arbitrary, Eq, Ord)
+n :: Int -> N
n = N . Positive
instance Show N where
diff --git a/src/full/Agda/Utils/HashMap.hs b/src/full/Agda/Utils/HashMap.hs
index c901f24..35bce49 100644
--- a/src/full/Agda/Utils/HashMap.hs
+++ b/src/full/Agda/Utils/HashMap.hs
@@ -1,4 +1,3 @@
-
module Agda.Utils.HashMap
( module HashMap ) where
diff --git a/src/full/Agda/Utils/IO/UTF8.hs b/src/full/Agda/Utils/IO/UTF8.hs
index 7ab15d0..f782fac 100644
--- a/src/full/Agda/Utils/IO/UTF8.hs
+++ b/src/full/Agda/Utils/IO/UTF8.hs
@@ -9,7 +9,22 @@ module Agda.Utils.IO.UTF8
import qualified System.IO as IO
import Control.Applicative
-import Agda.Utils.Unicode
+-- | Converts many character sequences which may be interpreted as
+-- line or paragraph separators into '\n'.
+
+convertLineEndings :: String -> String
+-- ASCII:
+convertLineEndings ('\x000D' : '\x000A' : s) = '\n' : convertLineEndings s -- CR LF
+convertLineEndings ('\x000A' : s) = '\n' : convertLineEndings s -- LF (Line feed)
+convertLineEndings ('\x000D' : s) = '\n' : convertLineEndings s -- CR (Carriage return)
+convertLineEndings ('\x000C' : s) = '\n' : convertLineEndings s -- FF (Form feed)
+-- Unicode:
+convertLineEndings ('\x0085' : s) = '\n' : convertLineEndings s -- NEXT LINE
+convertLineEndings ('\x2028' : s) = '\n' : convertLineEndings s -- LINE SEPARATOR
+convertLineEndings ('\x2029' : s) = '\n' : convertLineEndings s -- PARAGRAPH SEPARATOR
+-- Not a line ending:
+convertLineEndings (c : s) = c : convertLineEndings s
+convertLineEndings "" = ""
-- | Reads a UTF8-encoded text file and converts all Unicode line
-- endings into '\n'.
diff --git a/src/full/Agda/Utils/IORef.hs b/src/full/Agda/Utils/IORef.hs
new file mode 100644
index 0000000..6877e1a
--- /dev/null
+++ b/src/full/Agda/Utils/IORef.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE CPP #-}
+
+-- | Provides @Data.IORef.modifyIORef'@ for @base < 4.6 at .
+
+module Agda.Utils.IORef
+ ( module Data.IORef
+ , module Agda.Utils.IORef
+ ) where
+
+import Data.IORef
+
+#if !MIN_VERSION_base(4,6,0)
+
+-- | Strict version of 'modifyIORef'.
+--
+-- /Since: 4.6.0.0/
+modifyIORef' :: IORef a -> (a -> a) -> IO ()
+modifyIORef' ref f = do
+ x <- readIORef ref
+ writeIORef ref $! f x
+
+#endif
+
+-- | Read 'IORef', modify it strictly, and return old value.
+readModifyIORef' :: IORef a -> (a -> a) -> IO a
+readModifyIORef' ref f = do
+ x <- readIORef ref
+ writeIORef ref $! f x
+ return x
diff --git a/src/full/Agda/Utils/Lens.hs b/src/full/Agda/Utils/Lens.hs
new file mode 100644
index 0000000..75820af
--- /dev/null
+++ b/src/full/Agda/Utils/Lens.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- | A cut-down implementation of lenses, with names taken from
+-- Edward Kmett's lens package.
+
+module Agda.Utils.Lens
+ ( module Agda.Utils.Lens
+ , (<&>) -- reexported from Agda.Utils.Functor
+ ) where
+
+import Control.Monad.State
+import Control.Monad.Reader
+
+import Data.Functor.Constant
+import Data.Functor.Identity
+
+import Agda.Utils.Functor ((<&>))
+
+-- * Type-preserving lenses.
+
+-- | Van Laarhoven style homogeneous lenses.
+-- Mnemoic: "Lens inner outer".
+type Lens' i o = forall f. Functor f => (i -> f i) -> o -> f o
+
+
+-- * Elementary lens operations.
+
+infixl 8 ^.
+-- | Get inner part @i@ of structure @o@ as designated by @Lens' i o at .
+(^.) :: o -> Lens' i o -> i
+o ^. l = getConstant $ l Constant o
+
+-- | Set inner part @i@ of structure @o@ as designated by @Lens' i o at .
+set :: Lens' i o -> i -> o -> o
+set l = over l . const
+
+-- | Modify inner part @i@ of structure @o@ using a function @i -> i at .
+over :: Lens' i o -> (i -> i) -> o -> o
+over l f o = runIdentity $ l (Identity . f) o
+
+
+-- * State accessors and modifiers.
+
+-- | Read a part of the state.
+use :: MonadState o m => Lens' i o -> m i
+use l = gets (^. l)
+
+infix 4 .=
+-- | Write a part of the state.
+(.=) :: MonadState o m => Lens' i o -> i -> m ()
+l .= i = modify $ set l i
+
+infix 4 %=
+-- | Modify a part of the state.
+(%=) :: MonadState o m => Lens' i o -> (i -> i) -> m ()
+l %= f = modify $ over l f
+
+
+-- * Read-only state accessors and modifiers.
+
+-- | Ask for part of read-only state.
+view :: MonadReader o m => Lens' i o -> m i
+view l = asks (^. l)
+
+-- | Modify a part of the state in a subcomputation.
+locally :: MonadReader o m => Lens' i o -> (i -> i) -> m a -> m a
+locally l = local . over l
+
diff --git a/src/full/Agda/Utils/Lens/Examples.hs b/src/full/Agda/Utils/Lens/Examples.hs
new file mode 100644
index 0000000..ccae1b0
--- /dev/null
+++ b/src/full/Agda/Utils/Lens/Examples.hs
@@ -0,0 +1,18 @@
+-- | Examples how to use 'Agda.Utils.Lens'.
+
+module Agda.Utils.Lens.Examples where
+
+import Agda.Utils.Functor
+import Agda.Utils.Lens
+
+data Record a b = Record
+ { field1 :: a
+ , field2 :: b
+ }
+
+-- | (View source:) This is how you implement a lens for a record field.
+lensField1 :: Lens' a (Record a b)
+lensField1 f r = f (field1 r) <&> \ a -> r { field1 = a }
+
+lensField2 :: Lens' b (Record a b)
+lensField2 f r = f (field2 r) <&> \ b -> r { field2 = b }
diff --git a/src/full/Agda/Utils/List.hs b/src/full/Agda/Utils/List.hs
index 28e9d21..4910e09 100644
--- a/src/full/Agda/Utils/List.hs
+++ b/src/full/Agda/Utils/List.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TemplateHaskell #-}
{-| Utitlity functions on lists.
@@ -10,24 +10,50 @@ import Data.Functor ((<$>))
import Data.Function
import Data.List
import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
import qualified Data.Set as Set
import Text.Show.Functions ()
import Test.QuickCheck
import Test.QuickCheck.All
+import Agda.Utils.Bag (Bag)
+import qualified Agda.Utils.Bag as Bag
import Agda.Utils.TestHelpers
-- import Agda.Utils.QuickCheck -- Andreas, 2014-04-27 Inconvenient
-- because cabal-only CPP directive
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
+-- | Case distinction for lists, with list first.
+-- Cf. 'Agda.Utils.Null.ifNull'.
+caseList :: [a] -> b -> (a -> [a] -> b) -> b
+caseList [] n c = n
+caseList (x:xs) n c = c x xs
+
+-- | Case distinction for lists, with list last.
+listCase :: b -> (a -> [a] -> b) -> [a] -> b
+listCase n c [] = n
+listCase n c (x:xs) = c x xs
+
-- | Head function (safe).
-mhead :: [a] -> Maybe a
-mhead [] = Nothing
-mhead (x:_) = Just x
+headMaybe :: [a] -> Maybe a
+headMaybe = listToMaybe
+
+-- | Head function (safe). Returns a value on empty lists.
+--
+-- > headWithDefault 42 [] = 42
+-- > headWithDefault 42 [1,2,3] = 1
+headWithDefault :: a -> [a] -> a
+headWithDefault def = fromMaybe def . headMaybe
+
+-- | Last element (safe).
+lastMaybe :: [a] -> Maybe a
+lastMaybe [] = Nothing
+lastMaybe xs = Just $ last xs
-- | Opposite of cons @(:)@, safe.
uncons :: [a] -> Maybe (a, [a])
@@ -143,12 +169,12 @@ preOrSuffix (a:as) (b:bs)
wordsBy :: (a -> Bool) -> [a] -> [[a]]
wordsBy p xs = yesP xs
where
- yesP xs = noP (dropWhile p xs)
+ yesP xs = noP (dropWhile p xs)
- noP [] = []
- noP xs = ys : yesP zs
- where
- (ys,zs) = break p xs
+ noP [] = []
+ noP xs = ys : yesP zs
+ where
+ (ys,zs) = break p xs
-- | Chop up a list in chunks of a given length.
chop :: Int -> [a] -> [[a]]
@@ -167,13 +193,13 @@ holes (x:xs) = (x, xs) : map (id -*- (x:)) (holes xs)
sorted :: Ord a => [a] -> Bool
sorted [] = True
-sorted xs = and $ zipWith (<=) (init xs) (tail xs)
+sorted xs = and $ zipWith (<=) xs (tail xs)
-- | Check whether all elements in a list are distinct from each
-- other. Assumes that the 'Eq' instance stands for an equivalence
-- relation.
distinct :: Eq a => [a] -> Bool
-distinct [] = True
+distinct [] = True
distinct (x:xs) = x `notElem` xs && distinct xs
-- | An optimised version of 'distinct'.
@@ -192,6 +218,14 @@ allEqual :: Eq a => [a] -> Bool
allEqual [] = True
allEqual (x : xs) = all (== x) xs
+-- | Returns an (arbitrary) representative for each list element
+-- that occurs more than once.
+duplicates :: Ord a => [a] -> [a]
+duplicates = mapMaybe dup . Bag.groups . Bag.fromList
+ where
+ dup (a : _ : _) = Just a
+ dup _ = Nothing
+
-- | A variant of 'groupBy' which applies the predicate to consecutive
-- pairs.
@@ -289,17 +323,23 @@ zipWithTails f (x : xs) (y : ys) = (f x y : zs , as , bs)
where (zs , as , bs) = zipWithTails f xs ys
-}
--- | Efficient version of nub that sorts the list first. The tag function is
--- assumed to be cheap. If it isn't pair up the elements with their tags and
--- call uniqBy fst (or snd).
-uniqBy :: Ord b => (a -> b) -> [a] -> [a]
-uniqBy tag =
- map head
- . groupBy ((==) `on` tag)
- . sortBy (compare `on` tag)
+-- | Efficient version of nub that sorts the list via a search tree ('Data.Map').
+uniqOn :: Ord b => (a -> b) -> [a] -> [a]
+uniqOn key = Map.elems . Map.fromList . map (\ a -> (key a, a))
+
+-- Andreas, 2014-10-09 RETIRED, the Map version is simpler,
+-- and possibly more efficient (discards duplicates early).
+-- -- | Efficient version of nub that sorts the list first. The tag function is
+-- -- assumed to be cheap. If it isn't pair up the elements with their tags and
+-- -- call uniqOn fst (or snd).
+-- uniqOn :: Ord b => (a -> b) -> [a] -> [a]
+-- uniqOn tag =
+-- map head
+-- . groupBy ((==) `on` tag)
+-- . sortBy (compare `on` tag)
-prop_uniqBy :: [Integer] -> Bool
-prop_uniqBy xs = sort (nub xs) == uniqBy id xs
+prop_uniqOn :: [Integer] -> Bool
+prop_uniqOn xs = sort (nub xs) == uniqOn id xs
-- | Compute the common suffix of two lists.
commonSuffix :: Eq a => [a] -> [a] -> [a]
@@ -346,5 +386,5 @@ tests = do
-- , quickCheck' prop_extractNthElement
-- , quickCheck' prop_genericElemIndex
-- , quickCheck' prop_zipWith'
--- , quickCheck' prop_uniqBy
+-- , quickCheck' prop_uniqOn
-- ]
diff --git a/src/full/Agda/Utils/Map.hs b/src/full/Agda/Utils/Map.hs
index 411b5db..f82a009 100644
--- a/src/full/Agda/Utils/Map.hs
+++ b/src/full/Agda/Utils/Map.hs
@@ -9,7 +9,7 @@ import Data.Traversable
import Agda.Utils.Tuple
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- * Monadic map operations
@@ -21,22 +21,22 @@ data EitherOrBoth a b = L a | B a b | R b
unionWithM :: (Ord k, Functor m, Monad m) => (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM f m1 m2 = fromList <$> mapM combine (toList m)
where
- m = unionWith both (map L m1) (map R m2)
+ m = unionWith both (map L m1) (map R m2)
- both (L a) (R b) = B a b
- both _ _ = __IMPOSSIBLE__
+ both (L a) (R b) = B a b
+ both _ _ = __IMPOSSIBLE__
- combine (k, B a b) = (,) k <$> f a b
- combine (k, L a) = return (k, a)
- combine (k, R b) = return (k, b)
+ combine (k, B a b) = (,) k <$> f a b
+ combine (k, L a) = return (k, a)
+ combine (k, R b) = return (k, b)
insertWithKeyM :: (Ord k, Monad m) => (k -> a -> a -> m a) -> k -> a -> Map k a -> m (Map k a)
insertWithKeyM clash k x m =
case lookup k m of
- Just y -> do
- z <- clash k x y
- return $ insert k z m
- Nothing -> return $ insert k x m
+ Just y -> do
+ z <- clash k x y
+ return $ insert k z m
+ Nothing -> return $ insert k x m
-- * Non-monadic map operations
---------------------------------------------------------------------------
diff --git a/src/full/Agda/Utils/Maybe.hs b/src/full/Agda/Utils/Maybe.hs
index 027335f..7c586f1 100644
--- a/src/full/Agda/Utils/Maybe.hs
+++ b/src/full/Agda/Utils/Maybe.hs
@@ -73,7 +73,7 @@ caseMaybeM mm err f = maybeM err f mm
ifJustM :: Monad m => m (Maybe a) -> (a -> m b) -> m b -> m b
ifJustM mm = flip (caseMaybeM mm)
--- | A more telling name for 'Traversable.forM' for the 'Maybe' collection type.
+-- | A more telling name for 'Traversable.forM_' for the 'Maybe' collection type.
-- Or: 'caseMaybe' without the 'Nothing' case.
whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust m k = caseMaybe m (return ()) k
diff --git a/src/full/Agda/Utils/Maybe/Strict.hs b/src/full/Agda/Utils/Maybe/Strict.hs
index aaa2629..75d8213 100644
--- a/src/full/Agda/Utils/Maybe/Strict.hs
+++ b/src/full/Agda/Utils/Maybe/Strict.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
#if __GLASGOW_HASKELL__ >= 706
@@ -6,7 +6,7 @@
#endif
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
diff --git a/src/full/Agda/Utils/Monad.hs b/src/full/Agda/Utils/Monad.hs
index 7d174ed..69808c7 100644
--- a/src/full/Agda/Utils/Monad.hs
+++ b/src/full/Agda/Utils/Monad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
module Agda.Utils.Monad
@@ -9,9 +9,8 @@ module Agda.Utils.Monad
)
where
-import Prelude hiding (concat)
+import Prelude hiding (concat)
import Control.Monad hiding (mapM, forM)
-import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Writer
import Control.Applicative
@@ -19,20 +18,25 @@ import Data.Traversable as Trav hiding (for, sequence)
import Data.Foldable as Fold
import Data.Maybe
+import Agda.Utils.Except
+ ( Error(noMsg, strMsg)
+ , MonadError(catchError, throwError)
+ )
+
import Agda.Utils.List
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- Conditionals and monads ------------------------------------------------
-- | @when_@ is just @Control.Monad.when@ with a more general type.
when_ :: Monad m => Bool -> m a -> m ()
-when_ b m = when b $ do m >> return ()
+when_ b m = when b $ m >> return ()
-- | @unless_@ is just @Control.Monad.unless@ with a more general type.
unless_ :: Monad m => Bool -> m a -> m ()
-unless_ b m = unless b $ do m >> return ()
+unless_ b m = unless b $ m >> return ()
whenM :: Monad m => m Bool -> m a -> m ()
whenM c m = c >>= (`when_` m)
@@ -45,8 +49,8 @@ unlessM c m = c >>= (`unless_` m)
-- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c m m' =
- do b <- c
- if b then m else m'
+ do b <- c
+ if b then m else m'
-- | @ifNotM mc = ifM (not <$> mc)@
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
@@ -113,13 +117,13 @@ mapMaybeM :: (Monad m, Functor m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f xs = catMaybes <$> Trav.mapM f xs
-- | A monadic version of @'dropWhile' :: (a -> Bool) -> [a] -> [a]@.
-dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
+dropWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM p [] = return []
dropWhileM p (x : xs) = ifM (p x) (dropWhileM p xs) (return (x : xs))
-- Error monad ------------------------------------------------------------
--- | To simulate @MaybeT@ by @'ErrorT'@.
+-- | To simulate @MaybeT@ by @ExceptT at .
instance Error () where
noMsg = ()
@@ -134,21 +138,10 @@ first `finally` after = do
Left e -> throwError e
Right r -> return r
--- | Bracket for the 'Error' class.
-
-bracket :: (Error e, MonadError e m)
- => m a -- ^ Acquires resource. Run first.
- -> (a -> m c) -- ^ Releases resource. Run last.
- -> (a -> m b) -- ^ Computes result. Run in-between.
- -> m b
-bracket acquire release compute = do
- resource <- acquire
- compute resource `finally` release resource
-
-- State monad ------------------------------------------------------------
-- | Bracket without failure. Typically used to preserve state.
-bracket_ :: (Monad m)
+bracket_ :: Monad m
=> m a -- ^ Acquires resource. Run first.
-> (a -> m c) -- ^ Releases resource. Run last.
-> m b -- ^ Computes result. Run in-between.
@@ -160,21 +153,32 @@ bracket_ acquire release compute = do
return result
-- | Restore state after computation.
-localState :: (MonadState s m) => m a -> m a
+localState :: MonadState s m => m a -> m a
localState = bracket_ get put
-- Read -------------------------------------------------------------------
readM :: (Error e, MonadError e m, Read a) => String -> m a
readM s = case reads s of
- [(x,"")] -> return x
- _ ->
+ [(x,"")] -> return x
+ _ ->
throwError $ strMsg $ "readM: parse error string " ++ s
+-- RETIRED STUFF ----------------------------------------------------------
+{- RETIRED, ASR, 09 September 2014. Not used.
+-- | Bracket for the 'Error' class.
--- RETIRED STUFF ----------------------------------------------------------
+-- bracket :: (Error e, MonadError e m)
+-- => m a -- ^ Acquires resource. Run first.
+-- -> (a -> m c) -- ^ Releases resource. Run last.
+-- -> (a -> m b) -- ^ Computes result. Run in-between.
+-- -> m b
+-- bracket acquire release compute = do
+-- resource <- acquire
+-- compute resource `finally` release resource
+-}
{- RETIRED, Andreas, 2012-04-30. Not used.
concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]
@@ -184,7 +188,7 @@ concatMapM f xs = concat <$> traverse f xs
-- the force to be effective. For the 'IO' monad you do.
forceM :: Monad m => [a] -> m ()
forceM xs = do () <- length xs `seq` return ()
- return ()
+ return ()
commuteM :: (Traversable f, Applicative m) => f (m a) -> m (f a)
commuteM = traverse id
diff --git a/src/full/Agda/Utils/Null.hs b/src/full/Agda/Utils/Null.hs
index a501e83..89959fa 100644
--- a/src/full/Agda/Utils/Null.hs
+++ b/src/full/Agda/Utils/Null.hs
@@ -8,6 +8,8 @@ import Control.Monad
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as ByteString
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
@@ -16,6 +18,8 @@ import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set
+import Agda.Utils.Bag (Bag)
+import qualified Agda.Utils.Bag as Bag
import Agda.Utils.Functor
import Agda.Utils.Monad
@@ -24,6 +28,14 @@ class Null a where
null :: a -> Bool
-- ^ Satisfying @null empty == True at .
+instance Null () where
+ empty = ()
+ null _ = True
+
+instance (Null a, Null b) => Null (a,b) where
+ empty = (empty, empty)
+ null (a,b) = null a && null b
+
instance Null ByteString where
empty = ByteString.empty
null = ByteString.null
@@ -32,6 +44,14 @@ instance Null [a] where
empty = []
null = List.null
+instance Null (Bag a) where
+ empty = Bag.empty
+ null = Bag.null
+
+instance Null (IntMap a) where
+ empty = IntMap.empty
+ null = IntMap.null
+
instance Null (Map k a) where
empty = Map.empty
null = Map.null
diff --git a/src/full/Agda/Utils/PartialOrd.hs b/src/full/Agda/Utils/PartialOrd.hs
index 426aba2..0c7826a 100644
--- a/src/full/Agda/Utils/PartialOrd.hs
+++ b/src/full/Agda/Utils/PartialOrd.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell #-}
module Agda.Utils.PartialOrd where
@@ -105,6 +105,8 @@ orPO _ _ = POAny
-- @seqPO@ is associative, commutative, and idempotent.
-- @seqPO@ has dominant element @POAny@ and neutral element (unit) @POEQ at .
+seqPO :: PartialOrdering -> PartialOrdering -> PartialOrdering
+
seqPO POAny _ = POAny -- Shortcut if no information on first.
seqPO POEQ p = p -- No need to look at second if first is neutral.
@@ -204,8 +206,8 @@ instance PartialOrd a => PartialOrd (Maybe a) where
instance (PartialOrd a, PartialOrd b) => PartialOrd (Either a b) where
comparable mx my = case (mx, my) of
(Left x, Left y) -> comparable x y
- (Left x, Right y) -> POAny
- (Right x, Left y) -> POAny
+ (Left _, Right _) -> POAny
+ (Right _, Left _) -> POAny
(Right x, Right y) -> comparable x y
-- | Pointwise partial ordering for tuples.
@@ -311,91 +313,118 @@ instance Arbitrary ISet where
arbitrary = ISet . Inclusion . Set.fromList <$> listOf (choose (0, 8))
-- | Any two elements are 'related' in the way 'comparable' computes.
+prop_comparable_related :: ISet -> ISet -> Bool
prop_comparable_related (ISet a) (ISet b) =
related a o b where o = comparable a b
-- | @flip comparable a b == oppPO (comparable a b)@
+prop_oppPO :: ISet -> ISet -> Bool
prop_oppPO (ISet a) (ISet b) =
comparable a b == oppPO (comparable b a)
-- | Auxiliary function: lists to sets = sorted duplicate-free lists.
+sortUniq :: [Ordering] -> [Ordering]
sortUniq = Set.toAscList . Set.fromList
-- | 'leqPO' is inclusion of the associated 'Ordering' sets.
+prop_leqPO_sound :: PartialOrdering -> PartialOrdering -> Bool
prop_leqPO_sound p q =
(p `leqPO` q) == null (toOrderings p \\ toOrderings q)
-- | 'orPO' amounts to the union of the associated 'Ordering' sets.
-- Except that 'orPO POLT POGT == POAny' which should also include 'POEQ'.
+prop_orPO_sound :: PartialOrdering -> PartialOrdering -> Bool
prop_orPO_sound p q =
(p `orPO` q) == fromOrderings (toOrderings p ++ toOrderings q)
-- | 'orPO' is associative.
+prop_associative_orPO :: PartialOrdering -> PartialOrdering ->
+ PartialOrdering -> Bool
prop_associative_orPO = associative orPO
-- | 'orPO' is commutative.
+prop_commutative_orPO :: PartialOrdering -> PartialOrdering -> Bool
prop_commutative_orPO = commutative orPO
-- | 'orPO' is idempotent.
+prop_idempotent_orPO :: PartialOrdering -> Bool
prop_idempotent_orPO = idempotent orPO
-- | The dominant element wrt. 'orPO' is 'POAny'.
+prop_zero_orPO :: PartialOrdering -> Bool
prop_zero_orPO = isZero POAny orPO
-- | Soundness of 'seqPO'.
--
-- As QuickCheck test, this property is inefficient, see 'prop_seqPO'.
+property_seqPO :: ISet -> PartialOrdering -> ISet -> PartialOrdering ->
+ ISet -> Property
property_seqPO (ISet a) o (ISet b) p (ISet c) =
related a o b && related b p c ==> related a (seqPO o p) c
-- | A more efficient way of stating soundness of 'seqPO'.
+prop_seqPO :: ISet -> ISet -> ISet -> Bool
prop_seqPO (ISet a) (ISet b) (ISet c) = related a o c
where o = comparable a b `seqPO` comparable b c
-- | The unit of 'seqPO' is 'POEQ'.
+prop_identity_seqPO :: PartialOrdering -> Bool
prop_identity_seqPO = identity POEQ seqPO
-- | The zero of 'seqPO' is 'POAny'.
+prop_zero_seqPO :: PartialOrdering -> Bool
prop_zero_seqPO = isZero POAny seqPO
-- | 'seqPO' is associative.
+prop_associative_seqPO :: PartialOrdering -> PartialOrdering ->
+ PartialOrdering -> Bool
prop_associative_seqPO = associative seqPO
-- | 'seqPO' is also commutative.
+prop_commutative_seqPO :: PartialOrdering -> PartialOrdering -> Bool
prop_commutative_seqPO = commutative seqPO
-- | 'seqPO' is idempotent.
+prop_idempotent_seqPO :: PartialOrdering -> Bool
prop_idempotent_seqPO = idempotent seqPO
-- | 'seqPO' distributes over 'orPO'.
+prop_distributive_seqPO_orPO :: PartialOrdering -> PartialOrdering ->
+ PartialOrdering -> Bool
prop_distributive_seqPO_orPO = distributive seqPO orPO
-- | The result of 'toOrderings' is a sorted list without duplicates.
+prop_sorted_toOrderings :: PartialOrdering -> Bool
prop_sorted_toOrderings p =
sortUniq os == os where os = toOrderings p
-- | From 'Ordering' to 'PartialOrdering' and back is the identity.
+prop_toOrderings_after_fromOrdering :: Ordering -> Bool
prop_toOrderings_after_fromOrdering o =
toOrderings (fromOrdering o) == [o]
-- | From 'PartialOrdering' to 'Orderings' and back is the identity.
+prop_fromOrderings_after_toOrderings :: PartialOrdering -> Bool
prop_fromOrderings_after_toOrderings p =
fromOrderings (toOrderings p) == p
-- | From 'Orderings' to 'PartialOrdering' and back is the identity.
-- Except for @[LT,GT]@ which is a non-canonical representative of 'POAny'.
+prop_toOrderings_after_fromOrderings :: NonEmptyList Ordering -> Bool
prop_toOrderings_after_fromOrderings (NonEmpty os) =
Set.fromList os `Set.isSubsetOf`
Set.fromList (toOrderings (fromOrderings os))
-- | Pairs are related iff both components are related.
-
+prop_related_pair :: ISet -> ISet -> ISet -> ISet -> PartialOrdering -> Bool
prop_related_pair (ISet x1) (ISet x2) (ISet y1) (ISet y2) o =
related (x1,x2) o (y1,y2) == (related x1 o y1 && related x2 o y2)
-- | Comparing 'PartialOrdering's amounts to compare their representation as
-- 'Ordering' sets.
+prop_comparable_PartialOrdering :: PartialOrdering -> PartialOrdering -> Bool
+
prop_comparable_PartialOrdering p q =
comparable p q == comparable (to p) (to q)
where to = Inclusion . toOrderings
diff --git a/src/full/Agda/Utils/Permutation.hs b/src/full/Agda/Utils/Permutation.hs
index b19f89a..0237cdc 100644
--- a/src/full/Agda/Utils/Permutation.hs
+++ b/src/full/Agda/Utils/Permutation.hs
@@ -1,13 +1,18 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Utils.Permutation where
import Prelude hiding (drop)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
import Data.List hiding (drop)
import qualified Data.List as List
import Data.Maybe
@@ -16,10 +21,11 @@ import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
import Data.Typeable (Typeable)
-import Agda.Utils.Size
+import Agda.Utils.Functor
import Agda.Utils.List ((!!!))
+import Agda.Utils.Size
-#include "../undefined.h"
+#include "undefined.h"
import Agda.Utils.Impossible
-- | Partial permutations. Examples:
@@ -55,9 +61,40 @@ instance Sized Permutation where
-- Agda typing:
-- @permute (Perm {m} n is) : Vec A m -> Vec A n@
permute :: Permutation -> [a] -> [a]
-permute (Perm _ is) xs = map (xs !!!!) is
+permute p xs = map (fromMaybe __IMPOSSIBLE__) (safePermute p xs)
+
+safePermute :: Permutation -> [a] -> [Maybe a]
+safePermute (Perm _ is) xs = map (xs !!!!) is
where
- xs !!!! n = fromMaybe __IMPOSSIBLE__ (xs !!! n)
+ xs !!!! n | n < 0 = Nothing
+ | otherwise = xs !!! n
+
+-- | Invert a Permutation on a partial finite int map.
+-- @inversePermute perm f = f'@
+-- such that @permute perm f' = f@
+--
+-- Example, with map represented as @[Maybe a]@:
+-- @
+-- f = [Nothing, Just a, Just b ]
+-- perm = Perm 4 [3,0,2]
+-- f' = [ Just a , Nothing , Just b , Nothing ]
+-- @
+-- Zipping @perm@ with @f@ gives @[(0,a),(2,b)]@, after compression
+-- with @catMaybes at . This is an @IntMap@ which can easily
+-- written out into a substitution again.
+
+class InversePermute a b where
+ inversePermute :: Permutation -> a -> b
+
+instance InversePermute [Maybe a] [(Int,a)] where
+ inversePermute (Perm n is) = catMaybes . zipWith (\ i ma -> (i,) <$> ma) is
+
+instance InversePermute [Maybe a] (IntMap a) where
+ inversePermute p = IntMap.fromList . inversePermute p
+
+instance InversePermute [Maybe a] [Maybe a] where
+ inversePermute p@(Perm n _) = tabulate . inversePermute p
+ where tabulate m = for [0..n-1] $ \ i -> IntMap.lookup i m
-- | Identity permutation.
idP :: Int -> Permutation
@@ -93,12 +130,13 @@ composeP p1 (Perm n xs) = Perm n $ permute p1 xs
== permute (Perm xs) (permute (Perm ys) zs)
-}
-invertP :: Permutation -> Permutation
-invertP p@(Perm n xs) = Perm (size xs) $ map inv [0..n - 1]
+-- | @invertP err p@ is the inverse of @p@ where defined,
+-- otherwise defaults to @err at .
+-- @composeP p (invertP err p) == p@
+invertP :: Int -> Permutation -> Permutation
+invertP err p@(Perm n xs) = Perm (size xs) $ map inv [0..n - 1]
where
- inv x = case findIndex (x ==) xs of
- Just y -> fromIntegral y
- Nothing -> error $ "invertP: non-surjective permutation " ++ show p
+ inv x = fromMaybe err (findIndex (x ==) xs)
-- | Turn a possible non-surjective permutation into a surjective permutation.
compactP :: Permutation -> Permutation
@@ -130,8 +168,8 @@ expandP :: Int -> Int -> Permutation -> Permutation
expandP i n (Perm m xs) = Perm (m + n - 1) $ concatMap expand xs
where
expand j
- | j == i = [i..i + n - 1]
- | j < i = [j]
+ | j == i = [i..i + n - 1]
+ | j < i = [j]
| otherwise = [j + n - 1]
-- | Stable topologic sort. The first argument decides whether its first
@@ -140,7 +178,7 @@ topoSort :: (a -> a -> Bool) -> [a] -> Maybe Permutation
topoSort parent xs = fmap (Perm (size xs)) $ topo g
where
nodes = zip [0..] xs
- g = [ (n, parents x) | (n, x) <- nodes ]
+ g = [ (n, parents x) | (n, x) <- nodes ]
parents x = [ n | (n, y) <- nodes, parent y x ]
topo :: Eq node => [(node, [node])] -> Maybe [node]
@@ -148,13 +186,15 @@ topoSort parent xs = fmap (Perm (size xs)) $ topo g
topo g = case xs of
[] -> fail "cycle detected"
x : _ -> do
- ys <- topo $ remove x g
- return $ x : ys
+ ys <- topo $ remove x g
+ return $ x : ys
where
- xs = [ x | (x, []) <- g ]
- remove x g = [ (y, filter (/= x) ys) | (y, ys) <- g, x /= y ]
+ xs = [ x | (x, []) <- g ]
+ remove x g = [ (y, filter (/= x) ys) | (y, ys) <- g, x /= y ]
+------------------------------------------------------------------------
-- * Drop (apply) and undrop (abstract)
+------------------------------------------------------------------------
-- | Delayed dropping which allows undropping.
data Drop a = Drop
@@ -184,3 +224,7 @@ instance DoDrop Permutation where
Perm (n + m) $ [0..m-1] ++ map (+ m) (List.drop k xs)
where m = -k
unDrop m = dropMore (-m) -- allow picking up more than dropped
+
+------------------------------------------------------------------------
+-- * Properties, see 'Agda.Utils.Permutation.Tests'
+------------------------------------------------------------------------
diff --git a/src/full/Agda/Utils/Permutation/Tests.hs b/src/full/Agda/Utils/Permutation/Tests.hs
new file mode 100644
index 0000000..eaf80c6
--- /dev/null
+++ b/src/full/Agda/Utils/Permutation/Tests.hs
@@ -0,0 +1,117 @@
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Agda.Utils.Permutation.Tests (tests) where
+
+import Data.Functor
+import Data.List as List
+import Data.Maybe
+
+import Test.QuickCheck
+import Test.QuickCheck.All
+
+import Agda.Utils.Permutation
+
+------------------------------------------------------------------------
+-- * Properties
+------------------------------------------------------------------------
+
+instance Arbitrary Permutation where
+ arbitrary = do
+ is <- nub . map getNonNegative <$> arbitrary
+ NonNegative n <- arbitrary
+ return $ Perm (if null is then n else maximum is + n + 1) is
+
+data ComposablePermutations = ComposablePermutations Permutation Permutation
+ deriving (Eq, Show)
+
+instance Arbitrary ComposablePermutations where
+ arbitrary = do
+ p2@(Perm n is) <- arbitrary
+ let m = length is
+ p1 <- Perm m . filter (< m) . map getNonNegative <$> arbitrary
+ return $ ComposablePermutations p1 p2
+
+type A = Int
+
+-- | Extend a list by indefinitely many elements.
+withStream :: Testable b
+ => ([a] -> b) -- ^ Stream function.
+ -> [a] -- ^ Initial segment.
+ -> a -- ^ Default element, appended ad infinitum.
+ -> b
+withStream k as a = k $ as ++ repeat a
+
+-- | Apply a permutation to a list which might be too short.
+-- Silently discard picks that go beyond the list's boundaries.
+permutePartial :: Permutation -> [a] -> [a]
+permutePartial perm xs =
+ catMaybes $ permute perm $ map Just xs ++ repeat Nothing
+ -- Note: we have to add @Nothing at s to make @permute@ total.
+
+-- | @perm([0..n-1]) == perm@
+prop_permute_id_r :: Permutation -> Bool
+prop_permute_id_r perm@(Perm n picks) =
+ permute perm [0..] == picks
+
+-- | @idP(xs) == xs@
+prop_permute_id_l :: Int -> [A] -> A -> Bool
+prop_permute_id_l n = withStream $ \ xs ->
+ permute (idP n) xs == take n xs
+
+-- | @takeP n perm = perm . take n@
+prop_takeP :: Int -> Permutation -> [A] -> A -> Bool
+prop_takeP n perm = withStream $ \ xs ->
+ permute (takeP n perm) xs == permutePartial perm (take n xs)
+ -- Note: we have to add @Nothing at s to make @permute@ total.
+
+-- | @(droppedP perm)(xs) = xs \\ perm(xs)@
+prop_droppedP :: Permutation -> [A] -> A -> Bool
+prop_droppedP perm@(Perm n _) = withStream $ \ xs -> let xs' = take n xs in
+ sort (permute (droppedP perm) xs') == sort (xs' \\ permute perm xs')
+
+-- | @(p1 ∘ p2)(xs) = p1(p2(xs))@
+prop_composeP :: ComposablePermutations -> [A] -> A -> Bool
+prop_composeP (ComposablePermutations p1 p2) = withStream $ \ xs ->
+ permute (composeP p1 p2) xs == permutePartial p1 (permute p2 xs)
+
+-- | @p ∘ p⁻¹ ∘ p = p@
+prop_invertP_left :: Permutation -> Int -> [A] -> A -> Bool
+prop_invertP_left p err = withStream $ \ xs -> let ys = permute p xs in
+ permute p (permute (invertP err p) ys) == ys
+
+-- NOT QUITE RIGHT YET:
+-- -- | @p⁻1 ∘ p ∘ p⁻¹ = p⁻¹@
+-- prop_invertP_right :: Permutation -> Int -> [A] -> A -> Bool
+-- prop_invertP_right p err = withStream $ \ xs ->
+-- let pinv = invertP err p
+-- ys = permute pinv xs
+-- in permute pinv (permute p ys) == ys
+
+-- | @reverseP p = reverse . p . reverse@
+prop_reverseP :: Permutation -> [A] -> A -> Bool
+prop_reverseP p@(Perm n _) = withStream $ \ xs0 -> let xs = take n xs0 in
+ permute (reverseP p) xs == reverse (permute p (reverse xs))
+
+-- | @permute p . inversePermute p = id@
+prop_inversePermute :: Permutation -> [Maybe A] -> Maybe A -> Bool
+prop_inversePermute p@(Perm _ is) = withStream $ \ xs0 ->
+ let xs = take (length is) xs0
+ ys = inversePermute p xs
+ in permute p ys == xs
+
+-- Template Haskell hack to make the following $quickCheckAll work
+-- under ghc-7.8.
+return [] -- KEEP!
+
+-- | All tests as collected by 'quickCheckAll'.
+tests :: IO Bool
+tests = do
+ putStrLn "Agda.Utils.Permutation"
+ $quickCheckAll
diff --git a/src/full/Agda/Utils/Pointer.hs b/src/full/Agda/Utils/Pointer.hs
index 6168bbf..0fe4fbb 100644
--- a/src/full/Agda/Utils/Pointer.hs
+++ b/src/full/Agda/Utils/Pointer.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+
module Agda.Utils.Pointer
( Ptr, newPtr, derefPtr, setPtr
, updatePtr, updatePtrM
diff --git a/src/full/Agda/Utils/Pretty.hs b/src/full/Agda/Utils/Pretty.hs
index 8618e5b..c06b1ef 100644
--- a/src/full/Agda/Utils/Pretty.hs
+++ b/src/full/Agda/Utils/Pretty.hs
@@ -1,3 +1,6 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+
{-| Pretty printing functions.
-}
module Agda.Utils.Pretty
@@ -6,21 +9,55 @@ module Agda.Utils.Pretty
) where
import Data.Function
+import Data.Int ( Int32 )
import Text.PrettyPrint hiding (TextDetails(Str))
-instance Eq Doc where
- (==) = (==) `on` render
+-- * Pretty class
+
+-- | While 'Show' is for rendering data in Haskell syntax,
+-- 'Pretty' is for displaying data to the world, i.e., the
+-- user and the environment.
+--
+-- Atomic data has no inner document structure, so just
+-- implement 'pretty' as @pretty a = text $ ... a ... at .
class Pretty a where
- pretty :: a -> Doc
- prettyPrec :: Int -> a -> Doc
+ pretty :: a -> Doc
+ prettyPrec :: Int -> a -> Doc
+
+ pretty = prettyPrec 0
+ prettyPrec = const pretty
+
+-- | Use instead of 'show' when printing to world.
+
+prettyShow :: Pretty a => a -> String
+prettyShow = render . pretty
+
+-- * Pretty instances
- pretty = prettyPrec 0
- prettyPrec = const pretty
+instance Pretty Int where
+ pretty = text . show
+
+instance Pretty Int32 where
+ pretty = text . show
+
+instance Pretty Integer where
+ pretty = text . show
+
+instance Pretty Char where
+ pretty c = text [c]
+
+instance Pretty String where
+ pretty = text
instance Pretty Doc where
pretty = id
+-- * 'Doc' utilities
+
+instance Eq Doc where
+ (==) = (==) `on` render
+
pwords :: String -> [Doc]
pwords = map text . words
diff --git a/src/full/Agda/Utils/ReadP.hs b/src/full/Agda/Utils/ReadP.hs
index eab570e..ca34f9f 100644
--- a/src/full/Agda/Utils/ReadP.hs
+++ b/src/full/Agda/Utils/ReadP.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE MagicHash, Rank2Types, DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE Rank2Types #-}
+
-----------------------------------------------------------------------------
-- |
@@ -190,7 +193,7 @@ run _ _ = []
-- | Run a parser on a list of tokens. Returns the list of complete matches.
parse :: ReadP t a -> [t] -> [a]
parse p ts = case complete p of
- R f -> map fst $ run (f return) ts
+ R f -> map fst $ run (f return) ts
get :: ReadP t t
-- ^ Consumes and returns the next character.
@@ -426,7 +429,7 @@ run' _ s = Right s
parse' :: ReadP t a -> [t] -> Either a [t]
parse' p ts = case complete p of
- R f -> run' (f return) ts
+ R f -> run' (f return) ts
-- ---------------------------------------------------------------------------
-- QuickCheck properties that hold for the combinators
@@ -489,10 +492,10 @@ Here follow the properties:
> prop_Gather s =
> forAll readPWithoutReadS $ \p ->
> readP_to_S (gather p) s =~
-> [ ((pre,x::Int),s')
-> | (x,s') <- readP_to_S p s
-> , let pre = take (length s - length s') s
-> ]
+> [ ((pre,x::Int),s')
+> | (x,s') <- readP_to_S p s
+> , let pre = take (length s - length s') s
+> ]
>
> prop_String_Yes this s =
> readP_to_S (string this) (this ++ s) =~
diff --git a/src/full/Agda/Utils/SemiRing.hs b/src/full/Agda/Utils/SemiRing.hs
index 554308f..8c730f1 100644
--- a/src/full/Agda/Utils/SemiRing.hs
+++ b/src/full/Agda/Utils/SemiRing.hs
@@ -1,4 +1,3 @@
-
module Agda.Utils.SemiRing where
class SemiRing a where
diff --git a/src/full/Agda/Utils/Size.hs b/src/full/Agda/Utils/Size.hs
index da8bdca..9e09576 100644
--- a/src/full/Agda/Utils/Size.hs
+++ b/src/full/Agda/Utils/Size.hs
@@ -1,17 +1,41 @@
+module Agda.Utils.Size
+ ( Sized(..)
+ , SizedThing(..)
+ , sizeThing
+ ) where
-module Agda.Utils.Size ( Sized(..) ) where
+import Prelude hiding (null)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
-import Data.List
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+import qualified Data.List as List
+
+import Agda.Utils.Null
+
+-- | The size of an object.
+--
+-- For collections, it returns the length of the collection,
+-- not the overall size including the elements.
class Sized a where
size :: Integral n => a -> n
instance Sized [a] where
- size = genericLength
+ size = List.genericLength
+
+instance Sized (IntMap a) where
+ size = fromIntegral . IntMap.size
+
+instance Sized IntSet where
+ size = fromIntegral . IntSet.size
instance Sized (Map k a) where
size = fromIntegral . Map.size
@@ -19,6 +43,26 @@ instance Sized (Map k a) where
instance Sized (Set a) where
size = fromIntegral . Set.size
-instance Sized a => Sized (Maybe a) where
- size Nothing = 1
- size (Just a) = size a
+instance Sized (Seq a) where
+ size = fromIntegral . Seq.length
+
+
+-- | Thing decorated with its size.
+-- The thing should fit into main memory, thus, the size is an @Int at .
+
+data SizedThing a = SizedThing
+ { theSize :: !Int
+ , sizedThing :: a
+ }
+
+-- | Cache the size of an object.
+sizeThing :: Sized a => a -> SizedThing a
+sizeThing a = SizedThing (size a) a
+
+-- | Return the cached size.
+instance Sized (SizedThing a) where
+ size = fromIntegral . theSize
+
+instance Null a => Null (SizedThing a) where
+ empty = SizedThing 0 empty
+ null = null . sizedThing
diff --git a/src/full/Agda/Utils/String.hs b/src/full/Agda/Utils/String.hs
index 587a5f7..ec17ce9 100644
--- a/src/full/Agda/Utils/String.hs
+++ b/src/full/Agda/Utils/String.hs
@@ -53,10 +53,11 @@ addFinalNewLine s | last s == '\n' = s
indent :: Integral i => i -> String -> String
indent i = unlines . map (genericReplicate i ' ' ++) . lines
-newtype Str = Str { getStr :: String }
+newtype Str = Str { unStr :: String }
+ deriving Eq
instance Show Str where
- show = getStr
+ show = unStr
-- | Show a number using comma to separate powers of 1,000.
diff --git a/src/full/Agda/Utils/Suffix.hs b/src/full/Agda/Utils/Suffix.hs
index 6ca3266..9206152 100644
--- a/src/full/Agda/Utils/Suffix.hs
+++ b/src/full/Agda/Utils/Suffix.hs
@@ -1,11 +1,13 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
module Agda.Utils.Suffix where
import Data.Char
-#include "../undefined.h"
+import Agda.Utils.Function
+
+#include "undefined.h"
import Agda.Utils.Impossible
------------------------------------------------------------------------
@@ -38,13 +40,24 @@ fromSubscriptDigit d
------------------------------------------------------------------------
-- Suffices
-data Suffix = NoSuffix | Prime Int | Index Int | Subscript Int
+-- | Classification of identifier variants.
+
+data Suffix
+ = NoSuffix
+ | Prime Int -- ^ Identifier ends in @Int@ many primes.
+ | Index Int -- ^ Identifier ends in number @Int@ (ordinary digits).
+ | Subscript Int -- ^ Identifier ends in number @Int@ (subscript digits).
+-- | Increase the suffix by one. If no suffix yet, put a subscript @1 at .
+
+nextSuffix :: Suffix -> Suffix
nextSuffix NoSuffix = Subscript 1
nextSuffix (Prime i) = Prime $ i + 1
nextSuffix (Index i) = Index $ i + 1
nextSuffix (Subscript i) = Subscript $ i + 1
+-- | Parse suffix.
+
suffixView :: String -> (String, Suffix)
suffixView s
| (ps@(_:_), s') <- span (=='\'') rs = (reverse s', Prime $ length ps)
@@ -55,8 +68,21 @@ suffixView s
| otherwise = (s, NoSuffix)
where rs = reverse s
+-- | Print suffix.
+
addSuffix :: String -> Suffix -> String
addSuffix s NoSuffix = s
addSuffix s (Prime n) = s ++ replicate n '\''
addSuffix s (Index i) = s ++ show i
addSuffix s (Subscript i) = s ++ map toSubscriptDigit (show i)
+
+-- | Add first available @Suffix@ to a name.
+
+nameVariant
+ :: (String -> Bool) -- ^ Is the given name already taken?
+ -> String -- ^ Name of which we want an available variant.
+ -> String -- ^ Name extended by suffix that is not taken already.
+nameVariant taken x = addSuffix x $ trampoline step $ Prime 0
+ where
+ -- if the current suffix is taken, repeat with next suffix, else done
+ step s = if taken (addSuffix x s) then Right (nextSuffix s) else Left s
diff --git a/src/full/Agda/Utils/Time.hs b/src/full/Agda/Utils/Time.hs
index 7d9145f..76dc9d7 100644
--- a/src/full/Agda/Utils/Time.hs
+++ b/src/full/Agda/Utils/Time.hs
@@ -1,11 +1,19 @@
{-# LANGUAGE CPP #-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
+{-# OPTIONS_GHC -fno-warn-identities #-}
+#endif
+-- To avoid warning on derived Integral instance for CPUTime
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
-- | Time-related utilities.
module Agda.Utils.Time
( ClockTime
, getClockTime
, measureTime
+ , CPUTime(..)
) where
import Control.Monad.Trans
@@ -17,6 +25,9 @@ import qualified Data.Time
import qualified System.Time
#endif
+import Agda.Utils.Pretty
+import Agda.Utils.String
+
-- | Timestamps.
type ClockTime =
@@ -36,13 +47,22 @@ getClockTime =
System.Time.getClockTime
#endif
-type Picoseconds = Integer
+-- | CPU time in pico (10^-12) seconds.
+
+newtype CPUTime = CPUTime Integer
+ deriving (Eq, Show, Ord, Num, Real, Enum, Integral)
+
+-- | Print CPU time in milli (10^-3) seconds.
+
+instance Pretty CPUTime where
+ pretty (CPUTime ps) =
+ text $ showThousandSep (div ps 1000000000) ++ "ms"
-- | Measure the time of a computation. Returns the
-measureTime :: MonadIO m => m a -> m (a, Picoseconds)
+measureTime :: MonadIO m => m a -> m (a, CPUTime)
measureTime m = do
start <- liftIO $ getCPUTime
x <- m
stop <- liftIO $ getCPUTime
- return (x, stop - start)
+ return (x, CPUTime $ stop - start)
diff --git a/src/full/Agda/Utils/Trie.hs b/src/full/Agda/Utils/Trie.hs
index 59232ac..80506f6 100644
--- a/src/full/Agda/Utils/Trie.hs
+++ b/src/full/Agda/Utils/Trie.hs
@@ -1,10 +1,10 @@
--- | Strict tries (based on 'Data.Map.Strict' and 'Agda.Utils.Maybe.Strict').
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
+
+-- | Strict tries (based on 'Data.Map.Strict' and 'Agda.Utils.Maybe.Strict').
module Agda.Utils.Trie
( Trie
@@ -140,6 +140,7 @@ modelPath ks (Model xs) =
$ nubBy ((==) `on` fst)
$ filter (flip isPrefixOf ks . fst) xs
+prop_path :: [Key] -> Model -> Property
prop_path ks m =
collect (length $ modelPath ks m) $
lookupPath ks (modelToTrie m) == modelPath ks m
diff --git a/src/full/Agda/Utils/Tuple.hs b/src/full/Agda/Utils/Tuple.hs
index bfe7fcf..d829354 100644
--- a/src/full/Agda/Utils/Tuple.hs
+++ b/src/full/Agda/Utils/Tuple.hs
@@ -1,4 +1,8 @@
-{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
module Agda.Utils.Tuple where
diff --git a/src/full/Agda/Utils/Unicode.hs b/src/full/Agda/Utils/Unicode.hs
deleted file mode 100644
index f15642c..0000000
--- a/src/full/Agda/Utils/Unicode.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-
-module Agda.Utils.Unicode
- ( isUnicodeId
- , convertLineEndings
- ) where
-
-import Data.Char
-
--- Unicode ----------------------------------------------------------------
-
-isUnicodeId :: Char -> Bool
-isUnicodeId c = isPrint c && not (isAscii c)
-
--- | Converts many character sequences which may be interpreted as
--- line or paragraph separators into '\n'.
-
-convertLineEndings :: String -> String
-convertLineEndings ('\x000D' : '\x000A' : s) = '\n' : convertLineEndings s
-convertLineEndings ('\x000A' : s) = '\n' : convertLineEndings s
-convertLineEndings ('\x000D' : s) = '\n' : convertLineEndings s
-convertLineEndings ('\x0085' : s) = '\n' : convertLineEndings s
-convertLineEndings ('\x000C' : s) = '\n' : convertLineEndings s
-convertLineEndings ('\x2028' : s) = '\n' : convertLineEndings s
-convertLineEndings ('\x2029' : s) = '\n' : convertLineEndings s
-convertLineEndings (c : s) = c : convertLineEndings s
-convertLineEndings "" = ""
diff --git a/src/full/Agda/Utils/Update.hs b/src/full/Agda/Utils/Update.hs
index d7fce1f..c1962da 100644
--- a/src/full/Agda/Utils/Update.hs
+++ b/src/full/Agda/Utils/Update.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Agda.Utils.Update
( Change
, MonadChange(..)
diff --git a/src/full/Agda/Utils/VarSet.hs b/src/full/Agda/Utils/VarSet.hs
index 36afb74..1e063a4 100644
--- a/src/full/Agda/Utils/VarSet.hs
+++ b/src/full/Agda/Utils/VarSet.hs
@@ -1,18 +1,29 @@
+{-# LANGUAGE CPP #-}
-- | Var field implementation of sets of (small) natural numbers.
+
module Agda.Utils.VarSet
( VarSet
- , union, unions, member, empty, delete, singleton, fromList, toList, isSubsetOf, Set.null
+ , union, unions, member, empty, delete, singleton
+ , fromList, toList, toDescList
+ , isSubsetOf, IntSet.null
+ , intersection, difference
, Agda.Utils.VarSet.subtract
)
where
-import Data.IntSet as Set
+import Data.IntSet (IntSet)
+import Data.IntSet as IntSet
-type VarSet = Set.IntSet
+type VarSet = IntSet
subtract :: Int -> VarSet -> VarSet
-subtract n s = Set.map (Prelude.subtract n) s
+subtract n = IntSet.map (Prelude.subtract n)
+
+#if !MIN_VERSION_containers(0,5,0)
+toDescList :: VarSet -> [Int]
+toDescList = reverse . toList
+#endif
{-
import Data.Bits
diff --git a/src/full/Agda/Utils/Warshall.hs b/src/full/Agda/Utils/Warshall.hs
index 1634ef6..97b69c3 100644
--- a/src/full/Agda/Utils/Warshall.hs
+++ b/src/full/Agda/Utils/Warshall.hs
@@ -115,8 +115,9 @@ instance Show Node where
show (Rigid (RConst Infinite)) = "#"
show (Rigid (RConst (Finite n))) = show n
+infinite :: Rigid -> Bool
infinite (RConst Infinite) = True
-infinite _ = False
+infinite _ = False
-- | @isBelow r w r'@
-- checks, if @r@ and @r'@ are connected by @w@ (meaning @w@ not infinite),
@@ -145,6 +146,7 @@ instance Show Constraint where
type Constraints = [Constraint]
+emptyConstraints :: Constraints
emptyConstraints = []
-- graph (matrix) ------------------------------------------------
@@ -158,6 +160,7 @@ data Graph = Graph
}
-- | The empty graph: no nodes, edges are all undefined (infinity weight).
+initGraph :: Graph
initGraph = Graph Map.empty Map.empty Map.empty 0 (\ x y -> Infinite)
-- | The Graph Monad, for constructing a graph iteratively.
@@ -236,7 +239,10 @@ instance (Show a, Show b, Show c) => Show (LegendMatrix a b c) where
-- which is either a constant or a @v + n@ for a rigid variable @v at .
type Solution = Map Int SizeExpr
+emptySolution :: Solution
emptySolution = Map.empty
+
+extendSolution :: Solution -> Int -> SizeExpr -> Solution
extendSolution subst k v = Map.insert k v subst
data SizeExpr = SizeVar RigidId Int -- ^ e.g. x + 5
@@ -455,6 +461,7 @@ edges g = do
return (i, j, e)
-- | Check that no edges get longer when completing a graph.
+prop_smaller :: Nat -> Property
prop_smaller n' =
forAll (genGraph_ n) $ \g ->
let g' = warshallG g in
@@ -466,21 +473,30 @@ prop_smaller n' =
Nothing =< _ = False
Just x =< y = x <= y
+newEdge :: Nat -> Nat -> Distance -> AdjList Nat Distance ->
+ AdjList Nat Distance
newEdge i j e = Map.insertWith (++) i [(j, e)]
-genPath :: Nat -> Nat -> Nat -> AdjList Nat Distance -> Gen (AdjList Nat Distance)
+genPath :: Nat -> Nat -> Nat -> AdjList Nat Distance ->
+ Gen (AdjList Nat Distance)
genPath n i j g = do
es <- listOf $ (,) <$> node <*> edge
v <- edge
return $ addPath i (es ++ [(j, v)]) g
where
+ edge :: Gen Distance
edge = Dist <$> natural
+
+ node :: Gen Nat
node = choose (0, n - 1)
- addPath _ [] g = g
- addPath i ((j, v):es) g =
- newEdge i j v $ addPath j es g
+
+ addPath :: Nat -> [(Nat, Distance)] -> AdjList Nat Distance ->
+ AdjList Nat Distance
+ addPath _ [] g = g
+ addPath i ((j, v):es) g = newEdge i j v $ addPath j es g
-- | Check that all transitive edges are added.
+prop_path :: Nat -> Property
prop_path n' =
forAll (genGraph_ n) $ \g ->
forAll (two $ choose (0, n - 1)) $ \(i, j) ->
@@ -495,6 +511,7 @@ mapNodes f = Map.map f' . Map.mapKeys f
f' es = [ (f n, e) | (n,e) <- es ]
-- | Check that no edges are added between components.
+prop_disjoint :: Nat -> Property
prop_disjoint n' =
forAll (two $ genGraph_ n) $ \(g1, g2) ->
let g = Map.union (mapNodes Left g1) (mapNodes Right g2)
@@ -507,6 +524,7 @@ prop_disjoint n' =
isLeft = either (const True) (const False)
isRight = not . isLeft
+prop_stable :: Nat -> Property
prop_stable n' =
forAll (genGraph_ n) $ \g ->
let g' = warshallG g in
diff --git a/src/full/Agda/Version.hs b/src/full/Agda/Version.hs
index 2965ad7..28413df 100644
--- a/src/full/Agda/Version.hs
+++ b/src/full/Agda/Version.hs
@@ -1,4 +1,3 @@
-
module Agda.Version where
import Data.Version
diff --git a/src/full/Agda/undefined.h b/src/full/undefined.h
similarity index 100%
rename from src/full/Agda/undefined.h
rename to src/full/undefined.h
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/agda.git
More information about the Pkg-haskell-commits
mailing list