summaryrefslogtreecommitdiff
path: root/src/full
diff options
context:
space:
mode:
Diffstat (limited to 'src/full')
-rw-r--r--src/full/Agda/Auto/Auto.hs22
-rw-r--r--src/full/Agda/Auto/CaseSplit.hs1
-rw-r--r--src/full/Agda/Auto/Convert.hs135
-rw-r--r--src/full/Agda/Auto/NarrowingSearch.hs5
-rw-r--r--src/full/Agda/Auto/SearchControl.hs2
-rw-r--r--src/full/Agda/Auto/Syntax.hs1
-rw-r--r--src/full/Agda/Auto/Typecheck.hs2
-rw-r--r--src/full/Agda/Benchmarking.hs14
-rw-r--r--src/full/Agda/Compiler/CallCompiler.hs6
-rw-r--r--src/full/Agda/Compiler/Common.hs4
-rw-r--r--src/full/Agda/Compiler/Epic/Compiler.hs5
-rw-r--r--src/full/Agda/Compiler/Epic/Forcing.hs9
-rw-r--r--src/full/Agda/Compiler/Epic/FromAgda.hs5
-rw-r--r--src/full/Agda/Compiler/Epic/Injection.hs24
-rw-r--r--src/full/Agda/Compiler/Epic/Interface.hs31
-rw-r--r--src/full/Agda/Compiler/Epic/Primitive.hs2
-rw-r--r--src/full/Agda/Compiler/Epic/Static.hs13
-rw-r--r--src/full/Agda/Compiler/HaskellTypes.hs2
-rw-r--r--src/full/Agda/Compiler/JS/Case.hs127
-rw-r--r--src/full/Agda/Compiler/JS/Compiler.hs533
-rw-r--r--src/full/Agda/Compiler/JS/Parser.hs185
-rw-r--r--src/full/Agda/Compiler/JS/Pretty.hs30
-rw-r--r--src/full/Agda/Compiler/JS/Syntax.hs13
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Compiler.hs283
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot2
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Encode.hs77
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Misc.hs59
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Pretty.hs218
-rw-r--r--src/full/Agda/Compiler/MAlonzo/Primitives.hs87
-rw-r--r--src/full/Agda/Compiler/ToTreeless.hs60
-rw-r--r--src/full/Agda/Compiler/Treeless/AsPatterns.hs83
-rw-r--r--src/full/Agda/Compiler/Treeless/Builtin.hs24
-rw-r--r--src/full/Agda/Compiler/Treeless/Compare.hs7
-rw-r--r--src/full/Agda/Compiler/Treeless/DelayCoinduction.hs69
-rw-r--r--src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs79
-rw-r--r--src/full/Agda/Compiler/Treeless/Erase.hs68
-rw-r--r--src/full/Agda/Compiler/Treeless/GuardsToPrims.hs10
-rw-r--r--src/full/Agda/Compiler/Treeless/Identity.hs102
-rw-r--r--src/full/Agda/Compiler/Treeless/Pretty.hs14
-rw-r--r--src/full/Agda/Compiler/Treeless/Simplify.hs83
-rw-r--r--src/full/Agda/Compiler/Treeless/Subst.hs19
-rw-r--r--src/full/Agda/Compiler/Treeless/Uncase.hs3
-rw-r--r--src/full/Agda/Compiler/Treeless/Unused.hs13
-rw-r--r--src/full/Agda/Compiler/UHC/Bridge.hs2
-rw-r--r--src/full/Agda/Compiler/UHC/CompileState.hs11
-rw-r--r--src/full/Agda/Compiler/UHC/Compiler.hs29
-rw-r--r--src/full/Agda/Compiler/UHC/FromAgda.hs24
-rw-r--r--src/full/Agda/Compiler/UHC/Primitives.hs14
-rw-r--r--src/full/Agda/Compiler/UHC/Smashing.hs164
-rw-r--r--src/full/Agda/Interaction/BasicOps.hs150
-rw-r--r--src/full/Agda/Interaction/CommandLine.hs8
-rw-r--r--src/full/Agda/Interaction/EmacsCommand.hs29
-rw-r--r--src/full/Agda/Interaction/EmacsTop.hs34
-rw-r--r--src/full/Agda/Interaction/Exceptions.hs21
-rw-r--r--src/full/Agda/Interaction/FindFile.hs116
-rw-r--r--src/full/Agda/Interaction/FindFile.hs-boot7
-rw-r--r--src/full/Agda/Interaction/Highlighting/Emacs.hs12
-rw-r--r--src/full/Agda/Interaction/Highlighting/Generate.hs75
-rw-r--r--src/full/Agda/Interaction/Highlighting/LaTeX.hs166
-rw-r--r--src/full/Agda/Interaction/Highlighting/Precise.hs186
-rw-r--r--src/full/Agda/Interaction/Highlighting/Range.hs40
-rw-r--r--src/full/Agda/Interaction/Imports.hs560
-rw-r--r--src/full/Agda/Interaction/InteractionTop.hs347
-rw-r--r--src/full/Agda/Interaction/Library.hs20
-rw-r--r--src/full/Agda/Interaction/Library/Parse.hs6
-rw-r--r--src/full/Agda/Interaction/MakeCase.hs253
-rw-r--r--src/full/Agda/Interaction/Options.hs84
-rw-r--r--src/full/Agda/Interaction/Response.hs6
-rw-r--r--src/full/Agda/Interaction/SearchAbout.hs6
-rw-r--r--src/full/Agda/Main.hs50
-rw-r--r--src/full/Agda/Syntax/Abstract.hs275
-rw-r--r--src/full/Agda/Syntax/Abstract/Copatterns.hs55
-rw-r--r--src/full/Agda/Syntax/Abstract/Name.hs52
-rw-r--r--src/full/Agda/Syntax/Abstract/Pretty.hs1
-rw-r--r--src/full/Agda/Syntax/Abstract/Views.hs33
-rw-r--r--src/full/Agda/Syntax/Common.hs188
-rw-r--r--src/full/Agda/Syntax/Concrete.hs66
-rw-r--r--src/full/Agda/Syntax/Concrete/Definitions.hs1034
-rw-r--r--src/full/Agda/Syntax/Concrete/Generic.hs4
-rw-r--r--src/full/Agda/Syntax/Concrete/Name.hs57
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators.hs101
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators/Parser.hs101
-rw-r--r--src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs100
-rw-r--r--src/full/Agda/Syntax/Concrete/Pretty.hs53
-rw-r--r--src/full/Agda/Syntax/Fixity.hs37
-rw-r--r--src/full/Agda/Syntax/IdiomBrackets.hs48
-rw-r--r--src/full/Agda/Syntax/Info.hs10
-rw-r--r--src/full/Agda/Syntax/Internal.hs326
-rw-r--r--src/full/Agda/Syntax/Internal/Defs.hs9
-rw-r--r--src/full/Agda/Syntax/Internal/Generic.hs12
-rw-r--r--src/full/Agda/Syntax/Internal/Names.hs18
-rw-r--r--src/full/Agda/Syntax/Internal/Pattern.hs104
-rw-r--r--src/full/Agda/Syntax/Internal/SanityCheck.hs72
-rw-r--r--src/full/Agda/Syntax/Literal.hs27
-rw-r--r--src/full/Agda/Syntax/Parser.hs151
-rw-r--r--src/full/Agda/Syntax/Parser/LexActions.hs2
-rw-r--r--src/full/Agda/Syntax/Parser/Lexer.x23
-rw-r--r--src/full/Agda/Syntax/Parser/Literate.hs219
-rw-r--r--src/full/Agda/Syntax/Parser/LookAhead.hs1
-rw-r--r--src/full/Agda/Syntax/Parser/Monad.hs113
-rw-r--r--src/full/Agda/Syntax/Parser/Parser.y121
-rw-r--r--src/full/Agda/Syntax/Parser/Tokens.hs6
-rw-r--r--src/full/Agda/Syntax/Position.hs275
-rw-r--r--src/full/Agda/Syntax/Scope/Base.hs29
-rw-r--r--src/full/Agda/Syntax/Scope/Monad.hs197
-rw-r--r--src/full/Agda/Syntax/Translation/AbstractToConcrete.hs142
-rw-r--r--src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs454
-rw-r--r--src/full/Agda/Syntax/Translation/InternalToAbstract.hs961
-rw-r--r--src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs44
-rw-r--r--src/full/Agda/Syntax/Treeless.hs49
-rw-r--r--src/full/Agda/Termination/CallGraph.hs58
-rw-r--r--src/full/Agda/Termination/CallMatrix.hs104
-rw-r--r--src/full/Agda/Termination/Inlining.hs83
-rw-r--r--src/full/Agda/Termination/Monad.hs45
-rw-r--r--src/full/Agda/Termination/Order.hs208
-rw-r--r--src/full/Agda/Termination/RecCheck.hs5
-rw-r--r--src/full/Agda/Termination/Semiring.hs67
-rw-r--r--src/full/Agda/Termination/SparseMatrix.hs312
-rw-r--r--src/full/Agda/Termination/TermCheck.hs255
-rw-r--r--src/full/Agda/Termination/Termination.hs198
-rw-r--r--src/full/Agda/Tests.hs75
-rw-r--r--src/full/Agda/TypeChecking/Abstract.hs11
-rw-r--r--src/full/Agda/TypeChecking/CheckInternal.hs17
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause.hs26
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause/Compile.hs127
-rw-r--r--src/full/Agda/TypeChecking/CompiledClause/Match.hs50
-rw-r--r--src/full/Agda/TypeChecking/Constraints.hs50
-rw-r--r--src/full/Agda/TypeChecking/Conversion.hs160
-rw-r--r--src/full/Agda/TypeChecking/Coverage.hs327
-rw-r--r--src/full/Agda/TypeChecking/Coverage/Match.hs302
-rw-r--r--src/full/Agda/TypeChecking/Coverage/SplitTree.hs22
-rw-r--r--src/full/Agda/TypeChecking/Datatypes.hs20
-rw-r--r--src/full/Agda/TypeChecking/DisplayForm.hs55
-rw-r--r--src/full/Agda/TypeChecking/DropArgs.hs19
-rw-r--r--src/full/Agda/TypeChecking/Empty.hs2
-rw-r--r--src/full/Agda/TypeChecking/Errors.hs306
-rw-r--r--src/full/Agda/TypeChecking/EtaContract.hs14
-rw-r--r--src/full/Agda/TypeChecking/Forcing.hs5
-rw-r--r--src/full/Agda/TypeChecking/Free.hs224
-rw-r--r--src/full/Agda/TypeChecking/Free/Lazy.hs57
-rw-r--r--src/full/Agda/TypeChecking/Free/Old.hs29
-rw-r--r--src/full/Agda/TypeChecking/Free/Tests.hs118
-rw-r--r--src/full/Agda/TypeChecking/Implicit.hs60
-rw-r--r--src/full/Agda/TypeChecking/Injectivity.hs36
-rw-r--r--src/full/Agda/TypeChecking/InstanceArguments.hs145
-rw-r--r--src/full/Agda/TypeChecking/Irrelevance.hs32
-rw-r--r--src/full/Agda/TypeChecking/Level.hs93
-rw-r--r--src/full/Agda/TypeChecking/LevelConstraints.hs61
-rw-r--r--src/full/Agda/TypeChecking/MetaVars.hs268
-rw-r--r--src/full/Agda/TypeChecking/MetaVars.hs-boot8
-rw-r--r--src/full/Agda/TypeChecking/MetaVars/Mention.hs3
-rw-r--r--src/full/Agda/TypeChecking/MetaVars/Occurs.hs52
-rw-r--r--src/full/Agda/TypeChecking/Monad.hs2
-rw-r--r--src/full/Agda/TypeChecking/Monad/Base.hs759
-rw-r--r--src/full/Agda/TypeChecking/Monad/Benchmark.hs2
-rw-r--r--src/full/Agda/TypeChecking/Monad/Builtin.hs52
-rw-r--r--src/full/Agda/TypeChecking/Monad/Caching.hs1
-rw-r--r--src/full/Agda/TypeChecking/Monad/Closure.hs12
-rw-r--r--src/full/Agda/TypeChecking/Monad/Constraints.hs32
-rw-r--r--src/full/Agda/TypeChecking/Monad/Context.hs160
-rw-r--r--src/full/Agda/TypeChecking/Monad/Env.hs7
-rw-r--r--src/full/Agda/TypeChecking/Monad/Exception.hs3
-rw-r--r--src/full/Agda/TypeChecking/Monad/Local.hs40
-rw-r--r--src/full/Agda/TypeChecking/Monad/MetaVars.hs122
-rw-r--r--src/full/Agda/TypeChecking/Monad/Mutual.hs67
-rw-r--r--src/full/Agda/TypeChecking/Monad/Open.hs1
-rw-r--r--src/full/Agda/TypeChecking/Monad/Options.hs69
-rw-r--r--src/full/Agda/TypeChecking/Monad/Sharing.hs1
-rw-r--r--src/full/Agda/TypeChecking/Monad/Signature.hs387
-rw-r--r--src/full/Agda/TypeChecking/Monad/Signature.hs-boot9
-rw-r--r--src/full/Agda/TypeChecking/Monad/SizedTypes.hs9
-rw-r--r--src/full/Agda/TypeChecking/Monad/State.hs47
-rw-r--r--src/full/Agda/TypeChecking/Monad/Trace.hs16
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Abstract.hs8
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Match.hs109
-rw-r--r--src/full/Agda/TypeChecking/Patterns/Match.hs-boot14
-rw-r--r--src/full/Agda/TypeChecking/Polarity.hs17
-rw-r--r--src/full/Agda/TypeChecking/Positivity.hs232
-rw-r--r--src/full/Agda/TypeChecking/Positivity/Occurrence.hs170
-rw-r--r--src/full/Agda/TypeChecking/Positivity/Tests.hs27
-rw-r--r--src/full/Agda/TypeChecking/Pretty.hs174
-rw-r--r--src/full/Agda/TypeChecking/Pretty.hs-boot1
-rw-r--r--src/full/Agda/TypeChecking/Primitive.hs143
-rw-r--r--src/full/Agda/TypeChecking/ProjectionLike.hs63
-rw-r--r--src/full/Agda/TypeChecking/Quote.hs79
-rw-r--r--src/full/Agda/TypeChecking/ReconstructParameters.hs8
-rw-r--r--src/full/Agda/TypeChecking/RecordPatterns.hs56
-rw-r--r--src/full/Agda/TypeChecking/Records.hs217
-rw-r--r--src/full/Agda/TypeChecking/Records.hs-boot4
-rw-r--r--src/full/Agda/TypeChecking/Reduce.hs318
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Fast.hs534
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Fast.hs-boot8
-rw-r--r--src/full/Agda/TypeChecking/Reduce/Monad.hs17
-rw-r--r--src/full/Agda/TypeChecking/Rewriting.hs252
-rw-r--r--src/full/Agda/TypeChecking/Rewriting.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs387
-rw-r--r--src/full/Agda/TypeChecking/Rules/Builtin.hs52
-rw-r--r--src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs35
-rw-r--r--src/full/Agda/TypeChecking/Rules/Data.hs59
-rw-r--r--src/full/Agda/TypeChecking/Rules/Decl.hs254
-rw-r--r--src/full/Agda/TypeChecking/Rules/Decl.hs-boot6
-rw-r--r--src/full/Agda/TypeChecking/Rules/Def.hs336
-rw-r--r--src/full/Agda/TypeChecking/Rules/Def.hs-boot4
-rw-r--r--src/full/Agda/TypeChecking/Rules/Display.hs16
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS.hs389
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/AsPatterns.hs117
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs15
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs9
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Problem.hs88
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs34
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Split.hs142
-rw-r--r--src/full/Agda/TypeChecking/Rules/LHS/Unify.hs584
-rw-r--r--src/full/Agda/TypeChecking/Rules/Record.hs191
-rw-r--r--src/full/Agda/TypeChecking/Rules/Term.hs727
-rw-r--r--src/full/Agda/TypeChecking/Serialise.hs5
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Base.hs1
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Abstract.hs12
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Common.hs60
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Compilers.hs2
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs2
-rw-r--r--src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs139
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes.hs3
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Solve.hs411
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Syntax.hs23
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Tests.hs145
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/Utils.hs1
-rw-r--r--src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs53
-rw-r--r--src/full/Agda/TypeChecking/Substitute.hs643
-rw-r--r--src/full/Agda/TypeChecking/Substitute/Class.hs256
-rw-r--r--src/full/Agda/TypeChecking/Substitute/DeBruijn.hs54
-rw-r--r--src/full/Agda/TypeChecking/Substitute/Pattern.hs43
-rw-r--r--src/full/Agda/TypeChecking/SyntacticEquality.hs14
-rw-r--r--src/full/Agda/TypeChecking/Telescope.hs73
-rw-r--r--src/full/Agda/TypeChecking/Telescope.hs-boot2
-rw-r--r--src/full/Agda/TypeChecking/Test/Generators.hs558
-rw-r--r--src/full/Agda/TypeChecking/Tests.hs98
-rw-r--r--src/full/Agda/TypeChecking/Unquote.hs131
-rw-r--r--src/full/Agda/TypeChecking/With.hs270
-rw-r--r--src/full/Agda/Utils/AssocList.hs1
-rw-r--r--src/full/Agda/Utils/Bag.hs72
-rw-r--r--src/full/Agda/Utils/Benchmark.hs35
-rw-r--r--src/full/Agda/Utils/BiMap.hs32
-rw-r--r--src/full/Agda/Utils/Cluster.hs105
-rw-r--r--src/full/Agda/Utils/Either.hs23
-rw-r--r--src/full/Agda/Utils/Empty.hs1
-rw-r--r--src/full/Agda/Utils/Environment.hs38
-rw-r--r--src/full/Agda/Utils/Except.hs4
-rw-r--r--src/full/Agda/Utils/Favorites.hs68
-rw-r--r--src/full/Agda/Utils/FileName.hs57
-rw-r--r--src/full/Agda/Utils/Function.hs1
-rw-r--r--src/full/Agda/Utils/Functor.hs1
-rw-r--r--src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs36
-rw-r--r--src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional/Tests.hs362
-rw-r--r--src/full/Agda/Utils/Hash.hs11
-rw-r--r--src/full/Agda/Utils/Haskell/Syntax.hs110
-rw-r--r--src/full/Agda/Utils/Lens.hs1
-rw-r--r--src/full/Agda/Utils/List.hs175
-rw-r--r--src/full/Agda/Utils/ListT.hs13
-rw-r--r--src/full/Agda/Utils/ListT/Tests.hs47
-rw-r--r--src/full/Agda/Utils/Maybe/Strict.hs22
-rw-r--r--src/full/Agda/Utils/Memo.hs38
-rw-r--r--src/full/Agda/Utils/Monad.hs16
-rw-r--r--src/full/Agda/Utils/Null.hs1
-rw-r--r--src/full/Agda/Utils/Parser/MemoisedCPS.hs273
-rw-r--r--src/full/Agda/Utils/Parser/ReadP.hs2
-rw-r--r--src/full/Agda/Utils/PartialOrd.hs173
-rw-r--r--src/full/Agda/Utils/Permutation.hs22
-rw-r--r--src/full/Agda/Utils/Permutation/Tests.hs117
-rw-r--r--src/full/Agda/Utils/Pretty.hs6
-rw-r--r--src/full/Agda/Utils/QuickCheck.hs16
-rw-r--r--src/full/Agda/Utils/Singleton.hs3
-rw-r--r--src/full/Agda/Utils/Suffix.hs1
-rw-r--r--src/full/Agda/Utils/TestHelpers.hs169
-rw-r--r--src/full/Agda/Utils/Trie.hs76
-rw-r--r--src/full/Agda/Utils/Tuple.hs4
-rw-r--r--src/full/Agda/Utils/Warshall.hs115
-rw-r--r--src/full/Agda/VersionCommit.hs25
277 files changed, 14732 insertions, 12865 deletions
diff --git a/src/full/Agda/Auto/Auto.hs b/src/full/Agda/Auto/Auto.hs
index 390e69d..281fb43 100644
--- a/src/full/Agda/Auto/Auto.hs
+++ b/src/full/Agda/Auto/Auto.hs
@@ -1,9 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
module Agda.Auto.Auto (auto) where
@@ -71,7 +66,7 @@ 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.Proj _ qname) = Just (False, head $ I.unAmbQ qname)
getName (A.Con qname) = Just (True, head $ I.unAmbQ qname)
getName _ = Nothing
@@ -127,8 +122,7 @@ auto ii rng argstr = do
-- Get the meta variable for the interaction point we are trying to fill.
-- Add the @autohints@ for that meta to the hints collection.
mi <- lookupInteractionId ii
- --thisdefinfo <- catchError (liftM Just $ findClause mi) (\_ -> return Nothing)
- thisdefinfo <- findClauseDeep mi
+ thisdefinfo <- findClauseDeep ii
ehints <- (ehints ++) <$> do autohints hintmode mi $ fmap fst3 thisdefinfo
-- If @thisdefinfo /= Nothing@ get the its type (normalized).
@@ -322,7 +316,7 @@ auto ii rng argstr = do
case lookup mi riis of
Nothing ->
-- catchError
- (giveExpr mi expr >> return (Nothing, Nothing))
+ (giveExpr Nothing mi expr >> return (Nothing, Nothing))
-- (const retry)
-- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))
Just ii' -> do ae <- give ii' Nothing expr
@@ -375,10 +369,11 @@ auto ii rng argstr = do
cls'' <- forM cls' $ \ (I.Clause _ tel ps body t catchall) -> 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 ps body t catchall
- pcs <- withInteractionId ii $ mapM prettyA cls''
+ ps <- addContext tel $ normalise ps
+ body <- etaContract body
+ liftM modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange tel ps body t catchall
+ moduleTel <- lookupSection (AN.qnameModule def)
+ pcs <- withInteractionId ii $ inTopContext $ addContext moduleTel $ mapM prettyA cls''
ticks <- liftIO $ readIORef ticks
@@ -466,6 +461,7 @@ autohints AHMModule mi (Just def) = do
c <- getConstInfo n
case theDef c of
Axiom{} -> return True
+ AbstractDefn{} -> return True
Function{} -> return True
_ -> return False
diff --git a/src/full/Agda/Auto/CaseSplit.hs b/src/full/Agda/Auto/CaseSplit.hs
index 5720314..44466e6 100644
--- a/src/full/Agda/Auto/CaseSplit.hs
+++ b/src/full/Agda/Auto/CaseSplit.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.CaseSplit where
diff --git a/src/full/Agda/Auto/Convert.hs b/src/full/Agda/Auto/Convert.hs
index 2548785..33007b0 100644
--- a/src/full/Agda/Auto/Convert.hs
+++ b/src/full/Agda/Auto/Convert.hs
@@ -1,15 +1,13 @@
{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-
module Agda.Auto.Convert where
import Control.Applicative hiding (getConst, Const(..))
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
+import Data.Maybe
+import Data.Traversable (traverse)
import Control.Monad.State
import Agda.Syntax.Concrete (exprFieldA)
@@ -20,16 +18,15 @@ import qualified Agda.Syntax.Abstract.Name as AN
import qualified Agda.Syntax.Abstract as A
import qualified Agda.Syntax.Position as SP
import qualified Agda.TypeChecking.Monad.Base as MB
-import Agda.TypeChecking.Monad.State (getImportedSignature)
-import Agda.TypeChecking.Monad.Signature (getConstInfo, getDefFreeVars)
+import Agda.TypeChecking.Monad.Signature (getConstInfo, getDefFreeVars, ignoreAbstractMode)
import Agda.Utils.Permutation (Permutation(Perm), permute, takeP, compactP)
import Agda.TypeChecking.Level (reallyUnLevelView)
import Agda.TypeChecking.Monad.Base (mvJudgement, mvPermutation, getMetaInfo, ctxEntry, envContext, clEnv)
-import Agda.TypeChecking.Monad.MetaVars (lookupMeta, withMetaInfo)
+import Agda.TypeChecking.Monad.MetaVars (lookupMeta, withMetaInfo, lookupInteractionPoint)
import Agda.TypeChecking.Monad.Context (getContextArgs)
import Agda.TypeChecking.Monad.Constraints (getAllConstraints)
-import Agda.TypeChecking.Substitute (piApply, applySubst)
-import Agda.TypeChecking.Telescope (piApplyM, renamingR)
+import Agda.TypeChecking.Substitute (piApply, applySubst, renamingR)
+import Agda.TypeChecking.Telescope (piApplyM)
import qualified Agda.TypeChecking.Substitute as I (absBody)
import Agda.TypeChecking.Reduce (Normalise, normalise, instantiate)
import Agda.TypeChecking.EtaContract (etaContract)
@@ -37,6 +34,8 @@ import Agda.TypeChecking.Monad.Builtin (constructorForm)
import Agda.TypeChecking.Free (freeIn)
import qualified Agda.Utils.HashMap as HMap
+import Agda.Interaction.MakeCase (getClauseForIP)
+
import Agda.Auto.NarrowingSearch
import Agda.Auto.Syntax
@@ -109,6 +108,7 @@ tomy imi icns typs = do
return (Def narg clauses' Nothing Nothing, [])
(cont, projfcns2) <- case defn of
MB.Axiom {} -> return (Postulate, [])
+ MB.AbstractDefn -> return (Postulate, [])
MB.Function {MB.funClauses = clauses} -> clausesToDef clauses
-- MB.Primitive {MB.primClauses = []} -> throwError $ strMsg "Auto: Primitive functions are not supported" -- Andreas, 2013-06-17 breaks interaction/AutoMisc
MB.Primitive {MB.primClauses = clauses} -> clausesToDef clauses
@@ -298,18 +298,25 @@ tomyClauses (cl:cls) = do
Nothing -> cls'
tomyClause :: I.Clause -> TOM (Maybe ([Pat O], MExp O))
-tomyClause cl@(I.Clause {I.clauseBody = body}) = do
- let pats = I.clausePats cl
+tomyClause cl = do
+ let -- Jesper, 2016-07-28: I can't figure out if this should be the old or new
+ -- clause body (i.e. relative to the positions of pattern variables or
+ -- relative to the clauseTel). Both options pass the test suite, so I
+ -- have the impression it doesn't actually matter.
+ -- ALTERNATIVE CODE:
+ -- perm = fromMaybe __IMPOSSIBLE__ $ IP.clausePerm cl
+ -- body = applySubst (renamingR perm) $ I.clauseBody cl
+ body = I.clauseBody cl
+ pats = I.clausePats cl
pats' <- mapM tomyPat $ IP.unnumberPatVars pats
- body' <- tomyBody body
+ body' <- traverse tomyExp =<< lift (norm body)
return $ case body' of
- Just (body', _) -> Just (pats', body')
- Nothing -> Nothing
-
+ Just body' -> Just (pats', body')
+ Nothing -> Nothing
tomyPat :: Common.Arg I.Pattern -> TOM (Pat O)
tomyPat p = case Common.unArg p of
- I.ProjP _ -> lift $ copatternsNotImplemented
+ I.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
@@ -322,19 +329,6 @@ tomyPat p = case Common.unArg p of
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
- return $ Just (t', 0)
-tomyBody (I.Bind (I.Abs _ b)) = do
- res <- tomyBody b
- return $ case res of
- Nothing -> Nothing
- Just (b', i) -> Just (b', i + 1)
-tomyBody (I.Bind (I.NoAbs _ b)) = tomyBody b
-tomyBody I.NoBody = return Nothing
-
weaken :: Int -> MExp O -> MExp O
weaken _ e@(Meta m) = e
weaken i (NotM e) =
@@ -398,7 +392,7 @@ tomyExp v0 =
c <- getConst False name TMAll
as' <- tomyExps as
return $ NotM $ App Nothing (NotM OKVal) (Const c) as'
- I.Con con as -> do
+ I.Con con ci as -> do
let name = I.conName con
c <- getConst True name TMAll
as' <- tomyExps as
@@ -453,7 +447,7 @@ fmExp m (I.Lam _ b) = fmExp m (I.unAbs b)
fmExp m (I.Lit _) = False
fmExp m (I.Level (I.Max as)) = any (fmLevel m) as
fmExp m (I.Def _ as) = fmExps m $ I.argsFromElims as
-fmExp m (I.Con _ as) = fmExps m as
+fmExp m (I.Con _ ci as) = fmExps m as
fmExp m (I.Pi x y) = fmType m (Common.unDom x) || fmType m (I.unAbs y)
fmExp m (I.Sort _) = False
fmExp m (I.MetaV mid _) = mid == m
@@ -481,7 +475,9 @@ cnvh info = case Common.getHiding info of
Common.Hidden -> Hidden
icnvh :: FMode -> Common.ArgInfo
-icnvh h = (Common.setHiding h' Common.defaultArgInfo)
+icnvh h = Common.setHiding h' $
+ Common.setOrigin Common.Inserted $
+ Common.defaultArgInfo
where
h' = case h of
NotHidden -> Common.NotHidden
@@ -518,7 +514,7 @@ frommyExp (NotM e) =
frommyExps n as v
-}
(ndrop, h) = case iscon of
- Just n -> (n, \ q -> I.Con (I.ConHead q Common.Inductive [])) -- TODO: restore fields
+ Just n -> (n, \ q -> I.Con (I.ConHead q Common.Inductive []) Common.ConOSystem) -- TODO: restore fields
Nothing -> (0, \ f vs -> I.Def f $ map I.Apply vs)
frommyExps ndrop as (h name [])
Lam hid (Abs mid t) -> do
@@ -567,7 +563,7 @@ frommyExps ndrop (NotM as) trm =
ALConPar _ -> __IMPOSSIBLE__
where
addend x (I.Var h xs) = I.Var h (xs ++ [I.Apply x])
- addend x (I.Con h xs) = I.Con h (xs ++ [x])
+ addend x (I.Con h ci xs) = I.Con h ci (xs ++ [x])
addend x (I.Def h xs) = I.Def h (xs ++ [I.Apply x])
addend x (I.Shared p) = addend x (I.derefPtr p)
addend _ _ = __IMPOSSIBLE__
@@ -591,7 +587,8 @@ modifyAbstractExpr = f
f e = e
modifyAbstractClause :: A.Clause -> A.Clause
-modifyAbstractClause (A.Clause lhs (A.RHS e) decls catchall) = A.Clause lhs (A.RHS (modifyAbstractExpr e)) decls catchall
+modifyAbstractClause (A.Clause lhs dots (A.RHS e mc) decls catchall) =
+ A.Clause lhs dots (A.RHS (modifyAbstractExpr e) mc) decls catchall
modifyAbstractClause cl = cl
-- ---------------------------------
@@ -667,7 +664,7 @@ frommyClause (ids, pats, mrhs) = do
cnvps n (_ : _) = __IMPOSSIBLE__
cnvp (HI hid p) = do
p' <- case p of
- CSPatVar v -> return (I.VarP $ let HI _ (Id n, _) = ids !! v in n)
+ CSPatVar v -> return (I.varP $ let HI _ (Id n, _) = ids !! v in n)
CSPatConApp c ps -> do
cdef <- lift $ readIORef c
let (Just ndrop, name) = cdorigin cdef
@@ -682,19 +679,14 @@ frommyClause (ids, pats, mrhs) = do
return $ Common.Arg (icnvh hid) $ Common.unnamed p' -- TODO: recover names
ps <- cnvps 0 pats
body <- case mrhs of
- Nothing -> return $ I.NoBody
- Just e -> do
- e' <- frommyExp e {- renm e -} -- renaming before adding to clause below
- let r 0 = I.Body e'
- r n = I.Bind $ I.Abs "h" $ r (n - 1)
- e'' = r nv
- return e''
+ Nothing -> return $ Nothing
+ Just e -> Just <$> frommyExp e
let cperm = Perm nv perm
return $ I.Clause
{ I.clauseRange = SP.noRange
, I.clauseTel = tel
- , I.namedClausePats = IP.numberPatVars cperm $ applySubst (renamingR $ compactP cperm) ps
- , I.clauseBody = applySubst (renamingR cperm) <$> body
+ , I.namedClausePats = IP.numberPatVars __IMPOSSIBLE__ cperm $ applySubst (renamingR $ compactP cperm) ps
+ , I.clauseBody = body
, I.clauseType = Nothing -- TODO: compute clause type
, I.clauseCatchall = False
}
@@ -706,14 +698,6 @@ contains_constructor = any f
CSPatConApp{} -> True
_ -> False
-
-etaContractBody :: I.ClauseBody -> MB.TCM I.ClauseBody
-etaContractBody (I.NoBody) = return I.NoBody
-etaContractBody (I.Body b) = etaContract b >>= \b -> return (I.Body b)
-etaContractBody (I.Bind (I.Abs id b)) = etaContractBody b >>= \b -> return (I.Bind (I.Abs id b))
-etaContractBody (I.Bind (I.NoAbs x b)) = I.Bind . I.NoAbs x <$> etaContractBody b
-
-
-- ---------------------------------
freeIn :: Nat -> MExp o -> Bool
@@ -751,39 +735,16 @@ negtype ee = f (0 :: Int)
-- ---------------------------------------
-findClauseDeep :: I.MetaId -> MB.TCM (Maybe (AN.QName, I.Clause, Bool))
-findClauseDeep m = do
- sig <- getImportedSignature
- let res = do
- def <- HMap.elems $ sig ^. MB.sigDefinitions
- MB.Function{MB.funClauses = cs} <- [MB.theDef def]
- c <- cs
- unless (peelbinds False findMeta $ I.clauseBody c) []
- return (MB.defName def, c, peelbinds __IMPOSSIBLE__ toplevel $ I.clauseBody c)
- return $ case res of
- [] -> Nothing
- r:_ -> Just r -- TODO: with pattern matching lambdas we might get more than one hit, which to choose?
+findClauseDeep :: Common.InteractionId -> MB.TCM (Maybe (AN.QName, I.Clause, Bool))
+findClauseDeep ii = ignoreAbstractMode $ do -- Andreas, 2016-09-04, issue #2162
+ MB.InteractionPoint { MB.ipClause = ipCl} <- lookupInteractionPoint ii
+ (f, clauseNo) <- case ipCl of
+ MB.IPClause f clauseNo _ -> return (f, clauseNo)
+ MB.IPNoClause -> MB.typeError $ MB.GenericError $
+ "Cannot apply the auto tactic here, we are not in a function clause"
+ (_, c, _) <- getClauseForIP f clauseNo
+ return $ Just (f, c, maybe __IMPOSSIBLE__ toplevel $ I.clauseBody c)
where
- peelbinds d f = r
- where r b = case b of
- I.Bind b -> r $ I.absBody b
- I.NoBody -> d
- I.Body e -> f e
- findMeta e =
- case I.ignoreSharing e of
- I.Var _ es -> findMetas $ I.argsFromElims es
- I.Lam _ b -> findMeta (I.absBody b)
- I.Lit{} -> False
- 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 (Common.unDom it) || findMetat (I.unAbs ot)
- I.Sort{} -> False
- I.MetaV m' _ -> m == m'
- I.DontCare _ -> False
- I.Shared{} -> __IMPOSSIBLE__
- findMetas = any (findMeta . Common.unArg)
- findMetat (I.El _ e) = findMeta e
toplevel e =
case I.ignoreSharing e of
I.MetaV{} -> True
@@ -821,7 +782,7 @@ matchType cdfv tctx ctyp ttyp = trmodps cdfv ctyp
(I.Lam hid1 b1, I.Lam hid2 b2) | hid1 == hid2 -> f (nl + 1) n c (I.absBody b1) (I.absBody b2)
(I.Lit lit1, I.Lit lit2) | lit1 == lit2 -> c (n + 1)
(I.Def n1 as1, I.Def n2 as2) | n1 == n2 -> fes nl (n + 1) c as1 as2
- (I.Con n1 as1, I.Con n2 as2) | n1 == n2 -> fs nl (n + 1) c as1 as2
+ (I.Con n1 _ as1, I.Con n2 _ as2) | n1 == n2 -> fs nl (n + 1) c as1 as2
(I.Pi (Common.Dom info1 it1) ot1, I.Pi (Common.Dom info2 it2) ot2) | Common.argInfoHiding info1 == Common.argInfoHiding info2 -> ft nl n (\n -> ft (nl + 1) n c (I.absBody ot1) (I.absBody ot2)) it1 it2
(I.Sort{}, I.Sort{}) -> c n -- sloppy
_ -> Nothing
@@ -831,6 +792,6 @@ matchType cdfv tctx ctyp ttyp = trmodps cdfv ctyp
_ -> 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.Proj _ f : es1, I.Proj _ f' : es2) | f == f' -> fes nl n c es1 es2
(I.Apply (Common.Arg info1 e1) : es1, I.Apply (Common.Arg info2 e2) : es2) | Common.argInfoHiding info1 == Common.argInfoHiding info2 -> f nl n (\n -> fes nl n c es1 es2) e1 e2
_ -> Nothing
diff --git a/src/full/Agda/Auto/NarrowingSearch.hs b/src/full/Agda/Auto/NarrowingSearch.hs
index e4e0b42..3affdfb 100644
--- a/src/full/Agda/Auto/NarrowingSearch.hs
+++ b/src/full/Agda/Auto/NarrowingSearch.hs
@@ -1,9 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.NarrowingSearch where
diff --git a/src/full/Agda/Auto/SearchControl.hs b/src/full/Agda/Auto/SearchControl.hs
index 3061ac1..bcce7a5 100644
--- a/src/full/Agda/Auto/SearchControl.hs
+++ b/src/full/Agda/Auto/SearchControl.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
diff --git a/src/full/Agda/Auto/Syntax.hs b/src/full/Agda/Auto/Syntax.hs
index 2f997e0..c23178c 100644
--- a/src/full/Agda/Auto/Syntax.hs
+++ b/src/full/Agda/Auto/Syntax.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ExistentialQuantification #-}
module Agda.Auto.Syntax where
diff --git a/src/full/Agda/Auto/Typecheck.hs b/src/full/Agda/Auto/Typecheck.hs
index f4284f0..5d0b103 100644
--- a/src/full/Agda/Auto/Typecheck.hs
+++ b/src/full/Agda/Auto/Typecheck.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Auto.Typecheck where
diff --git a/src/full/Agda/Benchmarking.hs b/src/full/Agda/Benchmarking.hs
index 850624d..b06da0e 100644
--- a/src/full/Agda/Benchmarking.hs
+++ b/src/full/Agda/Benchmarking.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE IncoherentInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
#if __GLASGOW_HASKELL__ <= 708
@@ -67,12 +65,14 @@ data Phase
-- ^ Subphase for 'Termination'.
| ModuleName
-- ^ Subphase for 'Import'.
+ | BuildInterface
+ -- ^ Subphase for 'Serialization'.
| Sort
- -- ^ Subphase for 'Serialize'.
+ -- ^ Subphase for 'Serialization'.
| BinaryEncode
- -- ^ Subphase for 'Serialize'.
+ -- ^ Subphase for 'Serialization'.
| Compress
- -- ^ Subphase for 'Serialize'.
+ -- ^ Subphase for 'Serialization'.
| Operators
-- ^ Subphase for 'Parsing'.
| Free
@@ -81,6 +81,10 @@ data Phase
-- ^ Subphase for 'Typing': occurs check for solving metas.
| CheckLHS
-- ^ Subphase for 'Typing': checking the LHS
+ | CheckRHS
+ -- ^ Subphase for 'Typing': checking the RHS
+ | TypeSig
+ -- ^ Subphase for 'Typing': checking a type signature
| UnifyIndices
-- ^ Subphase for 'CheckLHS': unification of the indices
| InverseScopeLookup
diff --git a/src/full/Agda/Compiler/CallCompiler.hs b/src/full/Agda/Compiler/CallCompiler.hs
index ae6173a..f8fec60 100644
--- a/src/full/Agda/Compiler/CallCompiler.hs
+++ b/src/full/Agda/Compiler/CallCompiler.hs
@@ -42,7 +42,7 @@ callCompiler doCall cmd args =
Nothing -> return ()
Just errors -> typeError (CompilationError errors)
else
- reportSLn "" 1 $ "NOT calling: " ++ intercalate " " (cmd : args)
+ reportSLn "compile.cmd" 1 $ "NOT calling: " ++ intercalate " " (cmd : args)
-- | Generalisation of @callCompiler@ where the raised exception is
-- returned.
@@ -53,7 +53,7 @@ callCompiler'
-- ^ Command-line arguments.
-> TCM (Maybe String)
callCompiler' cmd args = do
- reportSLn "" 1 $ "Calling: " ++ intercalate " " (cmd : args)
+ reportSLn "compile.cmd" 1 $ "Calling: " ++ intercalate " " (cmd : args)
(_, out, err, p) <-
liftIO $ createProcess
(proc cmd args) { std_err = CreatePipe
@@ -68,7 +68,7 @@ callCompiler' cmd args = do
-- The handle should be in text mode.
liftIO $ hSetBinaryMode out False
progressInfo <- liftIO $ hGetContents out
- mapM_ (reportSLn "" 1) $ lines progressInfo
+ mapM_ (reportSLn "compile.output" 1) $ lines progressInfo
errors <- liftIO $ case err of
Nothing -> __IMPOSSIBLE__
diff --git a/src/full/Agda/Compiler/Common.hs b/src/full/Agda/Compiler/Common.hs
index cadeac7..b01b5f4 100644
--- a/src/full/Agda/Compiler/Common.hs
+++ b/src/full/Agda/Compiler/Common.hs
@@ -44,7 +44,7 @@ import Agda.Utils.Pretty
import Agda.Utils.Impossible
data IsMain = IsMain | NotMain
- deriving (Eq)
+ deriving (Eq, Show)
doCompile :: IsMain -> Interface -> (IsMain -> Interface -> TCM ()) -> TCM ()
doCompile isMain i f = do
@@ -65,7 +65,7 @@ doCompile isMain i f = do
mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i)
mapM_ (comp NotMain) imps
lift $ setInterface i
- lift $ f NotMain i
+ lift $ f isMain i
modify (Set.insert $ iModuleName i)
setInterface :: Interface -> TCM ()
diff --git a/src/full/Agda/Compiler/Epic/Compiler.hs b/src/full/Agda/Compiler/Epic/Compiler.hs
index bbf5d1e..a83fb2d 100644
--- a/src/full/Agda/Compiler/Epic/Compiler.hs
+++ b/src/full/Agda/Compiler/Epic/Compiler.hs
@@ -125,13 +125,13 @@ compileModule i = do
uptodate <- liftIO $ isNewerThan eifFile ifile
(eif, imps') <- case uptodate of
True -> do
- lift $ reportSLn "" 1 $
+ lift $ reportSLn "compile.epic" 2 $
(prettyShow . iModuleName) i ++ " : no compilation is needed."
eif <- readEInterface eifFile
modify $ \s -> s { curModule = eif }
return (eif, Set.insert file imps)
False -> do
- lift $ reportSLn "" 1 $
+ lift $ reportSLn "compile.epic" 1 $
"Compiling: " ++ (prettyShow . iModuleName) i
resetNameSupply
initialAnalysis i
@@ -182,6 +182,7 @@ initialAnalysis inter = do
case defEpicDef def of
Nothing -> putDelayed q True
_ -> return ()
+ AbstractDefn -> __IMPOSSIBLE__
_ -> return ()
idPrint :: String -> (a -> Compile TCM b) -> a -> Compile TCM b
diff --git a/src/full/Agda/Compiler/Epic/Forcing.hs b/src/full/Agda/Compiler/Epic/Forcing.hs
index 41992f5..18b5394 100644
--- a/src/full/Agda/Compiler/Epic/Forcing.hs
+++ b/src/full/Agda/Compiler/Epic/Forcing.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
module Agda.Compiler.Epic.Forcing where
@@ -141,7 +140,7 @@ insertTele er n ins term (ExtendTel x xs) = do
-- TODO: restore fields in ConHead
mkCon :: QName -> Int -> Term
-mkCon c n = I.Con (I.ConHead c Inductive []) $ map (defaultArg . I.var) $ downFrom n
+mkCon c n = I.Con (I.ConHead c Inductive []) ConOSystem $ map (defaultArg . I.var) $ downFrom n
unifyI :: Telescope -> FlexibleVars -> Type -> Args -> Args -> Compile TCM [Maybe Term]
unifyI tele flex typ a1 a2 = lift $ typeError $ NotImplemented "using the new unification algorithm for forcing"
@@ -285,7 +284,7 @@ replaceForced (vars,uvars) tele (fvar : fvars) unif e = do
buildTerm :: Var -> Nat -> Term -> Compile TCM (Expr -> Expr, Var)
buildTerm var idx (I.Shared p) = buildTerm var idx $ I.derefPtr p
buildTerm var idx (I.Var i _) | idx == i = return (id, var)
-buildTerm var idx (I.Con con args) = do
+buildTerm var idx (I.Con con _ args) = do
let c = I.conName con
vs <- replicateM (length args) newName
(pos , arg) <- fromMaybe __IMPOSSIBLE__ <$> findPosition idx (map (Just . unArg) args)
@@ -308,7 +307,7 @@ findPosition var ts = (listToMaybe . catMaybes <$>) . forM (zip [0..] ts) $ \ (n
pred :: Term -> Compile TCM Bool
pred t = case I.ignoreSharing t of
I.Var i _ | var == i -> return True
- I.Con c args -> do
+ I.Con c _ args -> do
forc <- getForcedArgs $ I.conName c
or <$> mapM (pred . unArg) (notForced forc args)
- _ -> return False
+ _ -> return False
diff --git a/src/full/Agda/Compiler/Epic/FromAgda.hs b/src/full/Agda/Compiler/Epic/FromAgda.hs
index 2daca59..59eb401 100644
--- a/src/full/Agda/Compiler/Epic/FromAgda.hs
+++ b/src/full/Agda/Compiler/Epic/FromAgda.hs
@@ -48,7 +48,7 @@ translateDefn msharp (n, defini) =
let projArgs = projectionArgs f
cc = fromMaybe __IMPOSSIBLE__ $ funCompiled f
ccs <- reverseCCBody projArgs <$> normaliseStatic cc
- let len = (+ projArgs) . length . clausePats . head . funClauses $ f
+ let len = (+ projArgs) . length . namedClausePats . head . funClauses $ f
toEta = arity (defType defini) - len
-- forcing <- lift $ gets (optForcing . stPersistentOptions)
lift $ reportSDoc "epic.fromagda" 5 $ text "compiling fun:" <+> prettyTCM n
@@ -82,6 +82,7 @@ translateDefn msharp (n, defini) =
-- Hopefully they are defined!
let ar = arity $ defType defini
return <$> mkFun n n' (primName p) ar
+ AbstractDefn -> __IMPOSSIBLE__
where
mkFun q = mkFunGen q apps ("primitive: " ++)
mkCon q tag ari = do
@@ -245,7 +246,7 @@ substTerm env term = case T.ignoreSharing $ T.unSpine term of
return $ case del of
True -> Lazy f
False -> f
- T.Con c args -> do
+ T.Con c ci args -> do
let con = unqname $ conName c
apps con <$> mapM (substTerm env . unArg) args
T.Shared p -> substTerm env $ derefPtr p
diff --git a/src/full/Agda/Compiler/Epic/Injection.hs b/src/full/Agda/Compiler/Epic/Injection.hs
index 780a9ed..0712379 100644
--- a/src/full/Agda/Compiler/Epic/Injection.hs
+++ b/src/full/Agda/Compiler/Epic/Injection.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.Epic.Injection where
@@ -98,13 +96,14 @@ patternToTerm :: Nat -> Pattern -> Term
patternToTerm n p = case p of
VarP v -> var n
DotP t -> t
- ConP c typ args -> Con c $ zipWith (\ arg t -> arg {unArg = t}) args
+ ConP c typ args -> Con c ci $ zipWith (\ arg t -> arg {unArg = t}) args
$ snd
$ foldr (\ arg (n, ts) -> (n + nrBinds arg, patternToTerm n arg : ts))
(n , [])
$ map namedArg args
+ where ci = fromConPatternInfo typ
LitP l -> Lit l
- ProjP d -> Def d [] -- Andreas, 2012-10-31 that might not be enought to get a term from list of patterns (TODO)
+ ProjP _ d -> Def d [] -- Andreas, 2012-10-31 that might not be enought to get a term from list of patterns (TODO)
nrBinds :: Num i => Pattern -> i
nrBinds p = case p of
@@ -140,19 +139,20 @@ isInjectiveHere nam idx clause = do
, text ("argumentNo=" ++ show idx)
-- , prettyTCM (clausePats clause)
]
- case getBody clause of
+ case compiledClauseBody clause of
Nothing -> return emptyC
Just body -> do
- let t = patternToTerm idxR $ unArg $ fromMaybe __IMPOSSIBLE__ $
- unnumberPatVars (clausePats clause) !!! idx
+ let vars = unnumberPatVars $ namedClausePats clause
+ let t = patternToTerm idxR $ namedArg $ fromMaybe __IMPOSSIBLE__ $
+ vars !!! idx
t' = applySubst (substForDot $ namedClausePats clause) t
- idxR = sum . map (nrBinds . unArg) . genericDrop (idx + 1) $ unnumberPatVars $ clausePats clause
+ idxR = sum . map (nrBinds . namedArg) . drop (idx + 1) $ vars
body' <- lift $ reduce body
lift $ reportSLn "epic.injection" 40 "reduced body"
injFs <- gets (injectiveFuns . importedModules)
lift $ reportSLn "epic.injection" 40 "calculated injFs"
res <- (t' <: body') `runReaderT` (Map.insert nam (InjectiveFun idx
- (length (clausePats clause))) injFs)
+ (length (namedClausePats clause))) injFs)
lift $ reportSDoc "epic.injection" 20 $ vcat
[ text "isInjective:" <+> text (show nam)
, text "at Index :" <+> text (show idx)
@@ -258,7 +258,7 @@ instance Injectible a => Injectible [a] where
instance Injectible a => Injectible (Elim' a) where
e1 <: e2 =
case (e1, e2) of
- (Proj f1 , Proj f2 ) | f1 == f2 -> return $ Just []
+ (Proj _ f1, Proj _ f2) | f1==f2 -> return $ Just []
(Apply a1, Apply a2) -> a1 <: a2
_ -> return Nothing
@@ -290,7 +290,7 @@ instance Injectible Term where
Just (Apply a) -> t1 <: unArg a
(Var i1 es1, Var i2 es2) | i1 == i2 -> es1 <: es2
(Def q1 es1, Def q2 es2) | q1 == q2 -> es1 <: es2
- (Con con1 args1, Con con2 args2) -> do
+ (Con con1 _ args1, Con con2 _ args2) -> do
let c1 = conName con1
c2 = conName con2
args1' <- flip notForced args1 <$> do lift . getForcedArgs $ c1
@@ -313,7 +313,7 @@ instance Injectible Term where
args1' <- map unArg <$> mapM (lift . lift . reduce) args1
args2' <- map unArg <$> mapM (lift . lift . reduce) args2
unionConstraints <$> zipWithM (\a b -> (a <: b)) args1' args2'
- (Con con1 args1, Con con2 args2) -> do
+ (Con con1 _ args1, Con con2 _ args2) -> do
let c1 = conName con1
c2 = conName con2
args1' <- map unArg <$> flip notForced args1 <$> getForcedArgs c1
diff --git a/src/full/Agda/Compiler/Epic/Interface.hs b/src/full/Agda/Compiler/Epic/Interface.hs
index c37ab6c..5ada952 100644
--- a/src/full/Agda/Compiler/Epic/Interface.hs
+++ b/src/full/Agda/Compiler/Epic/Interface.hs
@@ -8,7 +8,7 @@ import Control.Monad
import Data.Function
import Data.Map(Map)
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend)
import Data.Set (Set)
import Data.Typeable ( Typeable )
@@ -60,6 +60,21 @@ data EInterface = EInterface
, injectiveFuns :: Map QName InjectiveFun
} deriving (Typeable, Show)
+instance Semigroup EInterface where
+ x <> y = EInterface
+ { constrTags = comb constrTags
+ , definitions = comb definitions
+ , defDelayed = comb defDelayed
+ , conArity = comb conArity
+ , mainName = mainName x `mplus` mainName y
+ , relevantArgs = comb relevantArgs
+ , forcedArgs = comb forcedArgs
+ , injectiveFuns = comb injectiveFuns
+ }
+ where
+ comb :: Semigroup a => (EInterface -> a) -> a
+ comb f = ((<>) `on` f) x y
+
instance Monoid EInterface where
mempty = EInterface
{ constrTags = mempty
@@ -71,16 +86,4 @@ instance Monoid EInterface where
, forcedArgs = mempty
, injectiveFuns = mempty
}
- mappend x y = EInterface
- { constrTags = comb constrTags
- , definitions = comb definitions
- , defDelayed = comb defDelayed
- , conArity = comb conArity
- , mainName = mainName x `mplus` mainName y
- , relevantArgs = comb relevantArgs
- , forcedArgs = comb forcedArgs
- , injectiveFuns = comb injectiveFuns
- }
- where
- comb :: Monoid a => (EInterface -> a) -> a
- comb f = (mappend `on` f) x y
+ mappend = (<>)
diff --git a/src/full/Agda/Compiler/Epic/Primitive.hs b/src/full/Agda/Compiler/Epic/Primitive.hs
index 69277ca..6f7409c 100644
--- a/src/full/Agda/Compiler/Epic/Primitive.hs
+++ b/src/full/Agda/Compiler/Epic/Primitive.hs
@@ -102,7 +102,7 @@ getBuiltins =
defName :: T.Term -> QName
defName v = case T.ignoreSharing v of
T.Def q [] -> q
- T.Con q [] -> T.conName q
+ T.Con q ci [] -> T.conName q
_ -> __IMPOSSIBLE__
-- | Translation to primitive integer functions
diff --git a/src/full/Agda/Compiler/Epic/Static.hs b/src/full/Agda/Compiler/Epic/Static.hs
index 626dc36..62d9d8a 100644
--- a/src/full/Agda/Compiler/Epic/Static.hs
+++ b/src/full/Agda/Compiler/Epic/Static.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-- | Find the places where the builtin static is used and do some normalisation
-- there.
@@ -57,11 +56,12 @@ etaExpand :: Term -> Compile TCM Term
etaExpand def@(Def n ts) = do
defs <- lift $ use $ stImports . sigDefinitions
let f = maybe __IMPOSSIBLE__ theDef (HM.lookup n defs)
- len = length . clausePats . head . funClauses $ f
+ len = length . namedClausePats . head . funClauses $ f
toEta :: Num a => a
toEta = fromIntegral $ len - length ts
term = raise toEta def `applys` map var (downFrom toEta)
- return $ foldr (\ v t -> Lam defaultArgInfo (Abs v t)) term $ replicate toEta "staticVar"
+ info = setOrigin Inserted defaultArgInfo
+ return $ foldr (\ v t -> Lam info (Abs v t)) term $ replicate toEta "staticVar"
etaExpand x = return x
class Evaluate a where
@@ -99,7 +99,7 @@ instance Evaluate Term where
]
]
return f
- Con c args -> Con c <$> evaluate args
+ Con c ci args -> Con c ci <$> evaluate args
Pi arg abs -> return term
Sort s -> return term
MetaV i args -> return term
@@ -116,7 +116,4 @@ instance Evaluate Term where
isStatic :: QName -> Compile TCM Bool
isStatic q = do
defs <- lift $ use $ stImports . sigDefinitions
- return $ case fmap theDef $ HM.lookup q defs of
- Nothing -> False
- Just (f@Function{}) -> funStatic f
- Just _ -> False
+ return $ maybe False (^. theDefLens . funStatic) $ HM.lookup q defs
diff --git a/src/full/Agda/Compiler/HaskellTypes.hs b/src/full/Agda/Compiler/HaskellTypes.hs
index 9e3730b..96b1e4c 100644
--- a/src/full/Agda/Compiler/HaskellTypes.hs
+++ b/src/full/Agda/Compiler/HaskellTypes.hs
@@ -105,7 +105,7 @@ haskellType t = fromType t
underAbstraction a b $ \b ->
hsForall <$> getHsVar 0 <*> (hsFun hsA <$> fromType b)
else hsFun <$> fromType (unDom a) <*> fromType (noabsApp __IMPOSSIBLE__ b)
- Con c args -> hsApp <$> getHsType (conName c) <*> fromArgs args
+ Con c ci args -> hsApp <$> getHsType (conName c) <*> fromArgs args
Lam{} -> err
Level{} -> return hsUnit
Lit{} -> return hsUnit
diff --git a/src/full/Agda/Compiler/JS/Case.hs b/src/full/Agda/Compiler/JS/Case.hs
deleted file mode 100644
index 22e708c..0000000
--- a/src/full/Agda/Compiler/JS/Case.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module Agda.Compiler.JS.Case where
-
-import Prelude hiding ( null )
-import Data.Map ( Map, empty, null, mapWithKey, fromListWith, unionWith )
-import Data.List ( genericLength, genericTake, intercalate )
-
-import Agda.Syntax.Common ( Nat )
-
-import Agda.Compiler.JS.Pretty ( Pretty, pretty, pretties )
-import Agda.Compiler.JS.Syntax
- ( Exp(Undefined,Local,Lambda,Object,Apply),
- LocalId(LocalId), MemberId )
-import Agda.Compiler.JS.Substitution ( shiftFrom )
-
-#include "undefined.h"
-import Agda.Utils.Impossible ( Impossible(Impossible), throwImpossible )
-
--- ECMAScript doesn't support pattern-mathching case, so
--- we translate to a visitor pattern. We use a decision-tree
--- translation, as that seems to fit visitor objects better.
-
-data Case = Case { pats :: [Patt], body :: Exp }
- deriving (Show)
-
-instance Pretty Case where
- pretty n i (Case ps e) =
- intercalate " " (pretties n i ps) ++ " -> " ++ pretty (n + numVars ps) i e
-
--- Not handling literal patterns yet
--- Note that all patterns introduce binders, in depth-first prefix order,
--- for example Tagged l [ VarPatt , VarPatt ] should be thought
--- of as "x2 @ l (x1, x0)".
-
-data Patt =
- VarPatt |
- Tagged Tag [Patt]
- deriving (Show)
-
-instance Pretty Patt where
- pretty n i VarPatt = "x"
- pretty n i (Tagged (Tag l _ _) ps) =
- "(" ++ intercalate " " (pretty n i l : pretties n i ps) ++ ")"
-
--- With each tag, we record its name, and the names of the
--- other constructors of the datatype (e.g. we'd represent
--- zero as Tag "zero" ["suc","zero"]). We also record the
--- the function which accepts a visitor (by default Apply,
--- but can be over-ridden by the FFI).
-
-data Tag = Tag MemberId [MemberId] (Exp -> [Exp] -> Exp)
-
-instance Show Tag where
- show (Tag i is _) = show i
-
--- Number of bound variables in a pattern
-
-numVars :: [Patt] -> Nat
-numVars = sum . map numVars'
-
-numVars' :: Patt -> Nat
-numVars' (VarPatt) = 1
-numVars' (Tagged l ps) = 1 + numVars ps
-
--- Compile a case statement to a function
--- in lambda n cs, n is the number of parameters
-
-lambda :: [Case] -> Exp
-lambda [] = Undefined
-lambda (c:cs) = lambda' 0 0 (genericLength (pats c)) (c:cs)
-
--- In lambda' l m n cs,
--- l is the number of free variables,
--- m is the number of already read parameters, with m <= l, and
--- n is the number of unread parameters.
--- Each case should be of the form (Case ps e) where ps has length m+n.
--- e can have (l - m + #bv ps) variables free.
--- lambda' l m n cs can have l variables free.
-
-lambda' :: Nat -> Nat -> Nat -> [Case] -> Exp
-lambda' l m n [] = Undefined
-lambda' l 0 0 (c : cs) = body c
-lambda' l 0 n cs = Lambda 1 (lambda' (l+1) 1 (n-1) cs)
-lambda' l m n cs =
- case null ts of
- True -> lambda' l (m-1) n (map pop cs)
- False -> visit cs (Local (LocalId (m-1))) [Object (mapWithKey (match l (m-1) n cs) ts)]
- where
- ts = tags cs
-
--- Pop cases
-
-pop :: Case -> Case
-pop (Case (VarPatt : ps) e) = (Case ps e)
-pop _ = __IMPOSSIBLE__
-
--- Cases which match a given tag/arity
-
-match :: Nat -> Nat -> Nat -> [Case] -> MemberId -> Nat -> Exp
-match l m n cs t x = Lambda x (lambda' (l + x) (m + x) n (concat (map (refine t x) cs)))
-
--- Refine a case statement by a given tag/arity
-
-refine :: MemberId -> Nat -> Case -> [Case]
-refine t x (Case (VarPatt : qs) e) =
- [Case (genericTake x (repeat VarPatt) ++ qs) (shiftFrom (numVars qs) x e)]
-refine t x (Case (Tagged (Tag u _ _) ps : qs) e) | t == u =
- [Case (ps ++ qs) e]
-refine _ _ _ = []
-
--- Extract the visit function
-
-visit :: [Case] -> Exp -> [Exp] -> Exp
-visit (Case (Tagged (Tag _ _ v) _ : _) _ : _ ) = v
-visit (Case (VarPatt : _) _ : cs) = visit cs
-visit _ = Apply
-
--- Extract the list of possible tags, and their arity.
-
-tags :: [Case] -> Map MemberId Nat
-tags = foldl (unionWith max) empty . map tag
-
-tag :: Case -> Map MemberId Nat
-tag (Case (Tagged (Tag t us _) ps : qs) e) =
- fromListWith max ((t, genericLength ps) : [ (u, 0) | u <- us ])
-tag _ = empty
diff --git a/src/full/Agda/Compiler/JS/Compiler.hs b/src/full/Agda/Compiler/JS/Compiler.hs
index 658966f..0d0a938 100644
--- a/src/full/Agda/Compiler/JS/Compiler.hs
+++ b/src/full/Agda/Compiler/JS/Compiler.hs
@@ -1,13 +1,15 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE NamedFieldPuns #-}
module Agda.Compiler.JS.Compiler where
import Prelude hiding ( null, writeFile )
+import Control.Applicative
import Control.Monad.Reader ( liftIO )
+import Control.Monad.Trans
import Data.List ( intercalate, genericLength, partition )
import Data.Maybe ( isJust )
import Data.Set ( Set, null, insert, difference, delete )
+import Data.Traversable (traverse)
import Data.Map ( fromList, elems )
import qualified Data.Set as Set
import qualified Data.Map as Map
@@ -17,7 +19,7 @@ import System.FilePath ( splitFileName, (</>) )
import Agda.Interaction.FindFile ( findFile, findInterfaceFile )
import Agda.Interaction.Imports ( isNewerThan )
import Agda.Interaction.Options ( optCompileDir )
-import Agda.Syntax.Common ( Nat, unArg, namedArg )
+import Agda.Syntax.Common ( Nat, unArg, namedArg, NameId(..) )
import Agda.Syntax.Concrete.Name ( projectRoot )
import Agda.Syntax.Abstract.Name
( ModuleName(MName), QName,
@@ -25,50 +27,45 @@ import Agda.Syntax.Abstract.Name
mnameToList, qnameName, qnameModule, isInModule, nameId )
import Agda.Syntax.Internal
( Name, Args, Type,
- 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),
- unSpine, allApplyElims,
conName,
- derefPtr,
- toTopLevelModuleName, clausePats, clauseBody, arity, unEl, unAbs )
-import Agda.Syntax.Internal.Pattern ( unnumberPatVars )
-import Agda.TypeChecking.Substitute ( absBody )
+ toTopLevelModuleName, arity, unEl, unAbs, nameFixity )
import Agda.Syntax.Literal ( Literal(LitNat,LitFloat,LitString,LitChar,LitQName,LitMeta) )
+import Agda.Syntax.Fixity
+import qualified Agda.Syntax.Treeless as T
+import Agda.TypeChecking.Substitute ( absBody )
import Agda.TypeChecking.Level ( reallyUnLevelView )
-import Agda.TypeChecking.Monad
- ( TCM, Definition(Defn), Interface,
- JSCode, Defn(Record,Datatype,Constructor,Primitive,Function,Axiom),
- Projection(Projection), projProper, projFromType, projIndex,
- iModuleName, iImportedModules, theDef, getConstInfo,
- ignoreAbstractMode, miInterface, getVisitedModules,
- defName, defType, funClauses, funProjection, projectionArgs,
- dataPars, dataCons,
- conPars, conData,
- recConHead, recFields, recNamedCon,
- localTCState,
- typeError, TypeError(NotImplemented),
- defJSDef )
+import Agda.TypeChecking.Monad hiding (Global, Local)
+import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Monad.Options ( setCommandLineOptions, commandLineOptions, reportSLn )
import Agda.TypeChecking.Reduce ( instantiateFull, normalise )
+import Agda.TypeChecking.Substitute (TelV(..))
+import Agda.TypeChecking.Telescope
+import Agda.TypeChecking.Pretty
import Agda.Utils.FileName ( filePath )
import Agda.Utils.Function ( iterate' )
+import Agda.Utils.Maybe
import Agda.Utils.Monad ( (<$>), (<*>), ifM )
import Agda.Utils.Pretty (prettyShow)
+import qualified Agda.Utils.Pretty as P
+import Agda.Utils.IO.Directory
import Agda.Utils.IO.UTF8 ( writeFile )
import qualified Agda.Utils.HashMap as HMap
+
import Agda.Compiler.Common
- ( curDefs, curIF, curMName, setInterface, repl, inCompilerEnv,
- IsMain (..), doCompile )
+import Agda.Compiler.ToTreeless
+import Agda.Compiler.Treeless.DelayCoinduction
+import Agda.Compiler.Treeless.EliminateLiteralPatterns
+import Agda.Compiler.Treeless.GuardsToPrims
import Agda.Compiler.JS.Syntax
- ( Exp(Self,Local,Global,Undefined,String,Char,Integer,Double,Lambda,Object,Apply,Lookup),
+ ( Exp(Self,Local,Global,Undefined,String,Char,Integer,Double,Lambda,Object,Apply,Lookup,If,BinOp,PlainJS),
LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId), Export(Export), Module(Module),
modName, expName, uses )
import Agda.Compiler.JS.Substitution
( curriedLambda, curriedApply, emp, subst, apply )
-import Agda.Compiler.JS.Case ( Tag(Tag), Case(Case), Patt(VarPatt,Tagged), lambda )
-import Agda.Compiler.JS.Pretty ( pretty )
+import qualified Agda.Compiler.JS.Pretty as JSPretty
+
+import Paths_Agda
#include "undefined.h"
import Agda.Utils.Impossible ( Impossible(Impossible), throwImpossible )
@@ -79,19 +76,21 @@ import Agda.Utils.Impossible ( Impossible(Impossible), throwImpossible )
compilerMain :: Interface -> TCM ()
compilerMain mainI = inCompilerEnv mainI $ do
- doCompile IsMain mainI $ \_ -> compile
+ doCompile IsMain mainI $ do
+ compile
+ copyRTEModules
-compile :: Interface -> TCM ()
-compile i = do
+compile :: IsMain -> Interface -> TCM ()
+compile isMain i = do
ifM uptodate noComp $ do
yesComp
- writeModule =<< curModule
+ writeModule =<< curModule isMain
where
uptodate = liftIO =<< (isNewerThan <$> outFile_ <*> ifile)
ifile = maybe __IMPOSSIBLE__ filePath <$>
(findInterfaceFile . toTopLevelModuleName =<< curMName)
- noComp = reportSLn "" 1 . (++ " : no compilation is needed.") . prettyShow =<< curMName
- yesComp = reportSLn "" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<
+ noComp = reportSLn "compile.js" 2 . (++ " : no compilation is needed.") . prettyShow =<< curMName
+ yesComp = reportSLn "compile.js" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<
sequence [prettyShow <$> curMName, ifile, outFile_] :: TCM ()
--------------------------------------------------
@@ -125,17 +124,13 @@ jsMember n =
global' :: QName -> TCM (Exp,[MemberId])
global' q = do
i <- iModuleName <$> curIF
- is <- filter (isInModule q) <$> map (iModuleName . miInterface) <$> elems <$> getVisitedModules
- case is of
- [] -> __IMPOSSIBLE__
- _ -> let
- seg = maximum (map (length . mnameToList) is)
- ms = mnameToList (qnameModule q)
- m = MName (take seg ms)
- ls = map jsMember (drop seg ms ++ [qnameName q])
- in case (m == i) of
- True -> return (Self, ls)
- False -> return (Global (jsMod m), ls)
+ modNm <- topLevelModuleName (qnameModule q)
+ let
+ qms = mnameToList $ qnameModule q
+ nm = map jsMember (drop (length $ mnameToList modNm) qms ++ [qnameName q])
+ if modNm == i
+ then return (Self, nm)
+ else return (Global (jsMod modNm), nm)
global :: QName -> TCM (Exp,[MemberId])
global q = do
@@ -174,13 +169,15 @@ reorder' defs (e : es) =
False -> reorder' defs (insertAfter us e es)
isTopLevelValue :: Export -> Bool
-isTopLevelValue (Export _ e) = case e of
+isTopLevelValue (Export _ isCoind e) = case e of
+ _ | isCoind -> False
Lambda{} -> False
_ -> True
isEmptyObject :: Export -> Bool
-isEmptyObject (Export _ e) = case e of
+isEmptyObject (Export _ _ e) = case e of
Object m -> Map.null m
+ Lambda{} -> True
_ -> False
insertAfter :: Set [MemberId] -> Export -> [Export] -> [Export]
@@ -192,246 +189,156 @@ insertAfter us e (f:fs) | otherwise = f : insertAfter (delete (expName f) us) e
-- Main compiling clauses
--------------------------------------------------
-curModule :: TCM Module
-curModule = do
+curModule :: IsMain -> TCM Module
+curModule isMain = do
+ kit <- coinductionKit
m <- (jsMod <$> curMName)
is <- map jsMod <$> (map fst . iImportedModules <$> curIF)
- es <- mapM definition =<< (HMap.toList <$> curDefs)
- return (Module m (reorder es))
+ es <- catMaybes <$> (mapM (definition kit) =<< (sortDefs <$> curDefs))
+ return $ Module m (reorder es) main
+ where
+ main = case isMain of
+ IsMain -> Just $ Apply (Lookup Self $ MemberId "main") [Lambda 1 emp]
+ NotMain -> Nothing
-definition :: (QName,Definition) -> TCM Export
-definition (q,d) = do
+definition :: Maybe CoinductionKit -> (QName,Definition) -> TCM (Maybe Export)
+definition kit (q,d) = do
+ reportSDoc "compile.js" 10 $ text "compiling def:" <+> prettyTCM q
(_,ls) <- global q
d <- instantiateFull d
- e <- defn q ls (defType d) (defJSDef d) (theDef d)
- return (Export ls e)
-
-defn :: QName -> [MemberId] -> Type -> Maybe JSCode -> Defn -> TCM Exp
-defn q ls t (Just e) Axiom =
- return e
-defn q ls t Nothing Axiom = do
- t <- normalise t
- s <- isSingleton t
- case s of
- -- Inline and eta-expand postulates of singleton type
- Just e ->
- return (curriedLambda (arity t) e)
- -- Everything else we leave undefined
- Nothing ->
- return Undefined
-defn q ls t (Just e) (Function {}) =
- return e
-defn q ls t Nothing (Function { funProjection = proj, funClauses = cls }) = do
- t <- normalise t
- s <- isSingleton t
- cs <- mapM clause cls
- case s of
- -- Inline and eta-expand expressions of singleton type
- Just e ->
- return (curriedLambda (arity t) e)
- Nothing -> case proj of
- Just Projection{ projProper, projFromType = p, projIndex = i } -> do
- -- Andreas, 2013-05-20: whether a projection is proper is now stored.
- if isJust projProper then
- -- For projections from records we use a field lookup
- return (curriedLambda (numPars cls)
- (Lookup (Local (LocalId 0)) (last ls)))
- else
- -- For anything else we generate code, after adding (i-1) dummy lambdas
- return (dummyLambda (i-1) (lambda cs))
-{- OLD way of finding out whether a projection is proper (ie. from record)
- d <- getConstInfo p
- case theDef d of
- -- For projections from records we use a field lookup
- Record { recFields = flds } | q `elem` map unArg flds ->
- return (curriedLambda (numPars cls)
- (Lookup (Local (LocalId 0)) (last ls)))
- _ ->
- -- For anything else we generate code, after adding (i-1) dummy lambdas
- return (dummyLambda (i-1) (lambda cs))
--}
- Nothing ->
- return (lambda cs)
-defn q ls t (Just e) (Primitive {}) =
- return e
-defn q ls t _ (Primitive {}) =
- return Undefined
-defn q ls t _ (Datatype {}) =
- return emp
-defn q ls t (Just e) (Constructor {}) =
- return e
-defn q ls t _ (Constructor { conData = p, conPars = nc }) = do
- np <- return (arity t - nc)
- d <- getConstInfo p
+
+ definition' kit q d (defType d) ls
+
+definition' :: Maybe CoinductionKit -> QName -> Definition -> Type -> [MemberId] -> TCM (Maybe Export)
+definition' kit q d t ls =
case theDef d of
- Record { recFields = flds } ->
- return (curriedLambda np (Object (fromList
- ( (last ls , Lambda 1
- (Apply (Lookup (Local (LocalId 0)) (last ls))
- [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))
- : (zip [ jsMember (qnameName (unArg fld)) | fld <- flds ]
- [ Local (LocalId (np - i)) | i <- [1 .. np] ])))))
- _ ->
- return (curriedLambda (np + 1)
- (Apply (Lookup (Local (LocalId 0)) (last ls))
- [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))
-defn q ls t _ (Record {}) =
- return emp
-
--- Number of params in a function declaration
-
-numPars :: [Clause] -> Nat
-numPars [] = 0
-numPars (c : _) = genericLength (clausePats c)
-
--- One clause in a function definition
-
-clause :: Clause -> TCM Case
-clause c = do
- let pats = unnumberPatVars $ clausePats c
- ps <- mapM (pattern . unArg) pats
- (av,bv,es) <- return (mapping (map unArg pats))
- e <- body (clauseBody c)
- return (Case ps (subst av es e))
-
--- Mapping from Agda variables to JS variables in a pattern.
--- If mapping ps = (av,bv,es) then av is the number of Agda variables,
--- bv is the number of JS variables, and es is a list of expressions,
--- where es[i] is the JS variable corresponding to Agda variable i.
-
-mapping :: [Pattern] -> (Nat,Nat,[Exp])
-mapping = foldr mapping' (0,0,[])
-
-mapping' :: Pattern -> (Nat,Nat,[Exp]) -> (Nat,Nat,[Exp])
-mapping' (ProjP _) (av,bv,es) =
- __IMPOSSIBLE__
-mapping' (VarP _) (av,bv,es) = (av+1, bv+1, Local (LocalId bv) : es)
-mapping' (DotP _) (av,bv,es) = (av+1, bv+1, Local (LocalId bv) : es)
-mapping' (ConP _ _ ps) (av,bv,es) = (av',bv'+1,es') where
- (av',bv',es') = foldr mapping' (av,bv,es) (map namedArg ps)
-mapping' (LitP _) (av,bv,es) = (av, bv+1, es)
-
--- Not doing literal patterns yet
-
-pattern :: Pattern -> TCM Patt
-pattern (ProjP _) = typeError $ NotImplemented $ "Compilation of copatterns"
-pattern (ConP c _ ps) = do
- l <- tag $ conName c
- ps <- mapM (pattern . namedArg) ps
- return (Tagged l ps)
-pattern _ = return VarPatt
-
-tag :: QName -> TCM Tag
-tag q = do
- l <- visitorName q
- c <- getConstInfo q
- case theDef c of
- (Constructor { conData = p }) -> do
+ -- coinduction
+ Constructor{} | Just q == (nameOfSharp <$> kit) -> do
+ ret $ Lambda 1 $ local 0
+ Function{} | Just q == (nameOfFlat <$> kit) -> do
+ ret $ Lambda 1 $ Apply (local 0) [Integer 0]
+
+ Axiom | Just e <- defJSDef d -> plainJS e
+ Axiom | otherwise -> ret Undefined
+
+ Function{} | Just e <- defJSDef d -> plainJS e
+ Function{} | otherwise -> do
+ isInfVal <- outputIsInf kit t
+
+ reportSDoc "compile.js" 5 $ text "compiling fun:" <+> prettyTCM q
+ caseMaybeM (toTreeless q) (pure Nothing) $ \ treeless -> do
+ funBody <- eliminateLiteralPatterns $ convertGuards $ treeless
+ funBody' <- delayCoinduction funBody t
+ reportSDoc "compile.js" 30 $ text " compiled treeless fun:" <+> pretty funBody'
+ funBody'' <- compileTerm funBody'
+ reportSDoc "compile.js" 30 $ text " compiled JS fun:" <+> (text . show) funBody''
+ return $ Just $ Export ls isInfVal funBody''
+
+ Primitive{primName = p} | p `Set.member` primitives ->
+ plainJS $ "agdaRTS." ++ p
+ Primitive{} | Just e <- defJSDef d -> plainJS e
+ Primitive{} | otherwise -> ret Undefined
+
+ Datatype{} -> ret emp
+ Record{} -> return Nothing
+
+ Constructor{} | Just e <- defJSDef d -> plainJS e
+ Constructor{conData = p, conPars = nc} | otherwise -> do
+ np <- return (arity t - nc)
d <- getConstInfo p
- case (defJSDef d, theDef d) of
- (Just e, Datatype { dataCons = qs }) -> do
- ls <- mapM visitorName qs
- return (Tag l ls (\ x xs -> apply e (x:xs)))
- (Nothing, Datatype { dataCons = qs }) -> do
- ls <- mapM visitorName qs
- return (Tag l ls Apply)
- (Just e, Record {}) -> do
- return (Tag l [l] (\ x xs -> apply e (x:xs)))
- (Nothing, Record {}) -> do
- return (Tag l [l] Apply)
- _ -> __IMPOSSIBLE__
- _ -> __IMPOSSIBLE__
+ case theDef d of
+ Record { recFields = flds } ->
+ ret (curriedLambda np (Object (fromList
+ ( (last ls , Lambda 1
+ (Apply (Lookup (Local (LocalId 0)) (last ls))
+ [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))
+ : (zip [ jsMember (qnameName (unArg fld)) | fld <- flds ]
+ [ Local (LocalId (np - i)) | i <- [1 .. np] ])))))
+ _ ->
+ ret (curriedLambda (np + 1)
+ (Apply (Lookup (Local (LocalId 0)) (last ls))
+ [ Local (LocalId (np - i)) | i <- [0 .. np-1] ]))
+
+ AbstractDefn -> __IMPOSSIBLE__
+ where
+ ret = return . Just . Export ls False
+ plainJS = return . Just . Export ls False . PlainJS
-visitorName :: QName -> TCM MemberId
-visitorName q = do (m,ls) <- global q; return (last ls)
-body :: ClauseBody -> TCM Exp
-body (Body e) = term e
-body (Bind b) = body (unAbs b)
-body (NoBody) = return Undefined
-
-term :: Term -> TCM Exp
-term v = do
- case unSpine v of
- (Var i es) -> do
- let Just as = allApplyElims es
- e <- return (Local (LocalId i))
- es <- args 0 as
- return (curriedApply e es)
- (Lam _ at) -> Lambda 1 <$> term (absBody at)
- (Lit l) -> return (literal l)
- (Level l) -> term =<< reallyUnLevelView l
- (Shared p) -> term $ derefPtr p
- (Def q es) -> do
- let Just as = allApplyElims es
+compileTerm :: T.TTerm -> TCM Exp
+compileTerm term = do
+ case term of
+ T.TVar x -> return $ Local $ LocalId x
+ T.TDef q -> do
d <- getConstInfo q
case theDef d of
-- Datatypes and records are erased
Datatype {} -> return (String "*")
Record {} -> return (String "*")
- _ -> case defJSDef d of
- -- Inline functions with an FFI definition
- Just e -> do
- es <- args (projectionArgs $ theDef d) as
- return (curriedApply e es)
- Nothing -> do
- t <- normalise (defType d)
- s <- isSingleton t
- case s of
- -- Inline and eta-expand singleton types
- Just e ->
- return (curriedLambda (arity t) e)
- -- Everything else we leave non-inline
- Nothing -> do
- e <- qname q
- es <- args (projectionArgs $ theDef d) as
- return (curriedApply e es)
- (Con con as) -> do
- let q = conName con
+ _ -> qname q
+ T.TApp t xs -> curriedApply <$> compileTerm t <*> mapM compileTerm xs
+ T.TLam t -> Lambda 1 <$> compileTerm t
+ -- TODO This is not a lazy let, but it should be...
+ T.TLet t e -> apply <$> (Lambda 1 <$> compileTerm e) <*> traverse compileTerm [t]
+ T.TLit l -> return $ literal l
+ T.TCon q -> do
d <- getConstInfo q
- case defJSDef d of
- -- Inline functions with an FFI definition
- Just e -> do
- es <- args 0 as
- return (curriedApply e es)
- -- Everything else we leave non-inline
- Nothing -> do
- e <- qname q
- es <- args 0 as
- return (curriedApply e es)
- (Pi _ _) -> return (String "*")
- (Sort _) -> return (String "*")
- (MetaV _ _) -> return (Undefined)
- (DontCare _) -> return (Undefined)
-
--- Check to see if a type is a singleton, and if so, return its only
--- member. Singleton types are of the form T1 -> ... -> Tn -> T where
--- T is either a record with no fields, a datatype with one
--- no-argument constructor, a datatype with no constructors,
--- or (since this is a type-erasing translation) Set.
-
-isSingleton :: Type -> TCM (Maybe Exp)
-isSingleton t = case unEl t of
- Pi _ b -> isSingleton (unAbs b)
- Sort _ -> return (Just (String "*"))
- Def q as -> do
- d <- getConstInfo q
- case (theDef d) of
- Datatype { dataPars = np, dataCons = [] } ->
- return (Just Undefined)
- Datatype { dataPars = np, dataCons = [p] } -> do
- c <- getConstInfo p
- case (arity (defType c) == np) of
- True -> Just <$> qname p
- False -> return (Nothing)
- Record { recConHead = con, recFields = [] } ->
- Just <$> qname (conName con)
- _ -> return (Nothing)
- _ -> return (Nothing)
-
-args :: Int -> Args -> TCM [Exp]
-args n as = (replicate n Undefined ++) <$>
- mapM (term . unArg) as
+ qname q
+ T.TCase sc (T.CTData dt) def alts -> do
+ dt <- getConstInfo dt
+ alts' <- traverse compileAlt alts
+ let obj = Object $ Map.fromList alts'
+ case (theDef dt, defJSDef dt) of
+ (_, Just e) -> do
+ return $ apply (PlainJS e) [Local (LocalId sc), obj]
+ (Record{}, _) -> do
+ memId <- visitorName $ recCon $ theDef dt
+ return $ apply (Lookup (Local $ LocalId sc) memId) [obj]
+ (Datatype{}, _) -> do
+ return $ curriedApply (Local (LocalId sc)) [obj]
+ _ -> __IMPOSSIBLE__
+ T.TCase _ _ _ _ -> __IMPOSSIBLE__
+
+ T.TPrim p -> return $ compilePrim p
+ T.TUnit -> unit
+ T.TSort -> unit
+ T.TErased -> unit
+ T.TError T.TUnreachable -> return Undefined
+
+ where
+ unit = return $ Integer 0
+
+compilePrim :: T.TPrim -> Exp
+compilePrim p =
+ case p of
+ T.PIf -> curriedLambda 3 $ If (local 2) (local 1) (local 0)
+ T.PEqI -> binOp "agdaRTS.uprimIntegerEqual"
+ T.PEqF -> binOp "agdaRTS.uprimFloatEquality"
+ T.PEqQ -> binOp "agdaRTS.uprimQNameEquality"
+ p | T.isPrimEq p -> curriedLambda 2 $ BinOp (local 1) "===" (local 0)
+ T.PGeq -> binOp "agdaRTS.uprimIntegerGreaterOrEqualThan"
+ T.PLt -> binOp "agdaRTS.uprimIntegerLessThan"
+ T.PAdd -> binOp "agdaRTS.uprimIntegerPlus"
+ T.PSub -> binOp "agdaRTS.uprimIntegerMinus"
+ T.PMul -> binOp "agdaRTS.uprimIntegerMultiply"
+ T.PSeq -> binOp "agdaRTS.primSeq"
+ _ -> __IMPOSSIBLE__
+ where binOp js = curriedLambda 2 $ apply (PlainJS js) [local 1, local 0]
+
+
+compileAlt :: T.TAlt -> TCM (MemberId, Exp)
+compileAlt a = case a of
+ T.TACon con ar body -> do
+ memId <- visitorName con
+ body <- Lambda ar <$> compileTerm body
+ return (memId, body)
+ _ -> __IMPOSSIBLE__
+
+visitorName :: QName -> TCM MemberId
+visitorName q = do (m,ls) <- global q; return (last ls)
+
+local :: Nat -> Exp
+local = Local . LocalId
qname :: QName -> TCM Exp
qname q = do
@@ -439,15 +346,38 @@ qname q = do
return (foldl Lookup e ls)
literal :: Literal -> Exp
-literal (LitNat _ x) = Integer x
-literal (LitFloat _ x) = Double x
-literal (LitString _ x) = String x
-literal (LitChar _ x) = Char x
-literal (LitQName _ x) = String (show x)
-literal LitMeta{} = __IMPOSSIBLE__
+literal l = case l of
+ (LitNat _ x) -> Integer x
+ (LitFloat _ x) -> Double x
+ (LitString _ x) -> String x
+ (LitChar _ x) -> Char x
+ (LitQName _ x) -> litqname x
+ LitMeta{} -> __IMPOSSIBLE__
+
+litqname :: QName -> Exp
+litqname q =
+ Object $ Map.fromList
+ [ (mem "id", Integer $ fromIntegral n)
+ , (mem "moduleId", Integer $ fromIntegral m)
+ , (mem "name", String $ show q)
+ , (mem "fixity", litfixity fx)]
+ where
+ mem = MemberId
+ NameId n m = nameId $ qnameName q
+ fx = theFixity $ nameFixity $ qnameName q
+
+ litfixity :: Fixity -> Exp
+ litfixity fx = Object $ Map.fromList
+ [ (mem "assoc", litAssoc $ fixityAssoc fx)
+ , (mem "prec", litPrec $ fixityLevel fx)]
+
+ -- TODO this will probably not work well together with the necessary FFI bindings
+ litAssoc NonAssoc = String "NonAssoc"
+ litAssoc LeftAssoc = String "LeftAssoc"
+ litAssoc RightAssoc = String "RightAssoc"
-dummyLambda :: Int -> Exp -> Exp
-dummyLambda n = iterate' n (Lambda 0)
+ litPrec Unrelated = String "Unrelated"
+ litPrec (Related l) = Integer l
--------------------------------------------------
-- Writing out an ECMAScript module
@@ -456,14 +386,7 @@ dummyLambda n = iterate' n (Lambda 0)
writeModule :: Module -> TCM ()
writeModule m = do
out <- outFile (modName m)
- liftIO (writeFile out (pretty 0 0 m))
-
-compileDir :: TCM FilePath
-compileDir = do
- mdir <- optCompileDir <$> commandLineOptions
- case mdir of
- Just dir -> return dir
- Nothing -> __IMPOSSIBLE__
+ liftIO (writeFile out (JSPretty.pretty 0 0 m))
outFile :: GlobalId -> TCM FilePath
outFile m = do
@@ -478,3 +401,37 @@ outFile_ :: TCM FilePath
outFile_ = do
m <- curMName
outFile (jsMod m)
+
+
+copyRTEModules :: TCM ()
+copyRTEModules = do
+ dataDir <- lift getDataDir
+ let srcDir = dataDir </> "JS"
+ (lift . copyDirContent srcDir) =<< compileDir
+
+-- | Primitives implemented in the JS Agda RTS.
+primitives :: Set String
+primitives = Set.fromList
+ [ "primExp"
+ , "primFloatDiv"
+ , "primFloatEquality"
+ , "primFloatNumericalEquality"
+ , "primFloatNumericalLess"
+ , "primFloatNegate"
+ , "primFloatMinus"
+ , "primFloatPlus"
+ , "primFloatSqrt"
+ , "primFloatTimes"
+ , "primNatMinus"
+ , "primShowFloat"
+ , "primShowInteger"
+ , "primSin"
+ , "primCos"
+ , "primTan"
+ , "primASin"
+ , "primACos"
+ , "primATan"
+ , "primATan2"
+ , "primShowQName"
+ , "primQNameEquality"
+ ]
diff --git a/src/full/Agda/Compiler/JS/Parser.hs b/src/full/Agda/Compiler/JS/Parser.hs
deleted file mode 100644
index 74d04cd..0000000
--- a/src/full/Agda/Compiler/JS/Parser.hs
+++ /dev/null
@@ -1,185 +0,0 @@
-module Agda.Compiler.JS.Parser where
-
--- This is a simple parser for the ECMAScript FFI, which parses a
--- subset of ECMAscript expressions. We do this so that we can
--- optimize code that contains FFI expressions, for example
--- {-# COMPILED_JS _+_ function (x) { return function (y) { return x+y; }; } #-}
--- will generate ECMAScript "1 + 2" from Agda "1 + 2".
-
-import Prelude hiding ( exp, lookup )
-import Data.List ( genericLength )
-import Data.Char ( isLetter, isAlphaNum, isDigit )
-import Data.Map ( Map, fromList, union, empty )
-import qualified Data.Map as M
-
-import Agda.Utils.Parser.ReadP
- ( ReadP, (+++), (<++), between, char, choice, look, many,
- munch, munch1, parse', pfail, satisfy, sepBy, string, skipSpaces )
-
-import Agda.Syntax.Common ( Nat )
-import Agda.Compiler.JS.Syntax
- ( LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId),
- Exp(Local,Global,Undefined,String,Integer,Lambda,Apply,Object,Lookup,If,BinOp,PreOp,Const) )
-
-type Parser = ReadP Char
-
-identifier :: Parser String
-identifier = do
- c <- satisfy isLetter
- cs <- munch isAlphaNum
- skipSpaces
- return (c : cs)
-
-wordBoundary :: Parser ()
-wordBoundary = do
- cs <- look
- case cs of
- (c:_) | isAlphaNum c -> pfail
- _ -> return ()
-
-token :: String -> Parser ()
-token s = string s >> wordBoundary >> skipSpaces
-
-punct :: Char -> Parser ()
-punct c = char c >> skipSpaces
-
-parened :: Parser a -> Parser a
-parened = between (punct '(') (punct ')')
-
-braced :: Parser a -> Parser a
-braced = between (punct '{') (punct '}')
-
-bracketed :: Parser a -> Parser a
-bracketed = between (punct '[') (punct ']')
-
-quoted :: Parser a -> Parser a
-quoted = between (char '"') (punct '"')
-
-stringLit :: Parser Exp
-stringLit = do s <- stringStr; return (String s)
-
-stringStr :: Parser String
-stringStr = quoted (many stringChr)
-
-stringChr :: Parser Char
-stringChr = satisfy (`notElem` "\\\"") +++ escChr
-
--- Not handling all escape sequences
-escChr :: Parser Char
-escChr = char '\\' >> (
- (char 'n' >> return '\n') +++
- (char 'r' >> return '\r') +++
- (char 't' >> return '\t') +++
- (char '"' >> return '"') +++
- (char '\\' >> return '\\')
- )
-
--- Not handling all integer constants
-intLit :: Parser Exp
-intLit = do s <- munch1 isDigit; skipSpaces; return (Integer (read s))
-
-undef :: Parser Exp
-undef = token "undefined" >> return Undefined
-
-localid :: (Map String Nat) -> Parser Exp
-localid m = do
- s <- identifier
- case M.lookup s m of
- Nothing -> return (Const s)
- Just i -> return (Local (LocalId i))
-
-globalid :: Parser Exp
-globalid = do
- token "require"
- i <- parened (quoted (sepBy (munch1 isAlphaNum) (char '.')))
- return (Global (GlobalId i))
-
-preop :: Parser String
-preop = do
- op <- choice (map string [ "+", "-", "!" ])
- skipSpaces
- return op
-
-binop :: Parser String
-binop = do
- op <- choice (map string [
- "<", ">", "<=", ">=", "==", "===", "<<", ">>",
- "<<<", ">>>", "!=", "!==", "+", "-", "*", "%", "/",
- "&", "&&", "|", "||", "^"
- ])
- skipSpaces
- return op
-
-field :: (Map String Nat) -> Parser (MemberId,Exp)
-field m = do
- l <- stringStr
- punct ':'
- e <- exp m
- return (MemberId l, e)
-
-object :: (Map String Nat) -> Parser Exp
-object m = do
- o <- braced (sepBy (field m) (punct ','))
- return (Object (fromList o))
-
-function :: (Map String Nat) -> Parser Exp
-function m = do
- token "function"
- xs <- parened (sepBy identifier (punct ','))
- n <- return (genericLength xs)
- m' <- return (union (fromList (zip xs [n-1,n-2..0])) (M.map (+n) m))
- e <- bracedBlock m'
- return (Lambda n e)
-
-bracedBlock :: (Map String Nat) -> Parser Exp
-bracedBlock m = braced (returnBlock m +++ ifBlock m +++ bracedBlock m)
-
-returnBlock :: (Map String Nat) -> Parser Exp
-returnBlock m = between (token "return") (punct ';') (exp m)
-
-ifBlock :: (Map String Nat) -> Parser Exp
-ifBlock m = do
- token "if"
- e <- parened (exp m)
- f <- bracedBlock m
- token "else"
- g <- (ifBlock m +++ bracedBlock m)
- return (If e f g)
-
-exp0 :: (Map String Nat) -> Parser Exp
-exp0 m = function m <++ undef <++ globalid <++ localid m <++
- object m <++ stringLit <++ intLit <++ parened (exp m)
-
-exp1 :: (Map String Nat) -> Parser Exp
-exp1 m =
- (do op <- preop; e <- exp1 m; return (PreOp op e)) <++
- (exp0 m)
-
-exp2 :: (Map String Nat) -> Parser Exp
-exp2 m = exp1 m >>= exp2' m
-
--- Not handling operator fixity or precedence
-exp2' :: (Map String Nat) -> Exp -> Parser Exp
-exp2' m e =
- (do es <- parened (sepBy (exp m) (punct ',')); exp2' m (Apply e es)) <++
- (do i <- bracketed stringStr; exp2' m (Lookup e (MemberId i))) <++
- (do punct '.'; i <- identifier; exp2' m (Lookup e (MemberId i))) <++
- (do op <- binop; f <- exp0 m; exp2' m (BinOp e op f)) <++
- (return e)
-
-exp3 :: (Map String Nat) -> Parser Exp
-exp3 m = exp2 m >>= exp3' m
-
-exp3' :: (Map String Nat) -> Exp -> Parser Exp
-exp3' m e =
- (do punct '?'; f <- exp2 m; punct ':'; g <- exp2 m; return (If e f g)) <++
- (return e)
-
-exp :: (Map String Nat) -> Parser Exp
-exp = exp3
-
-topLevel :: Parser Exp
-topLevel = skipSpaces >> exp empty
-
-parse :: String -> Either Exp String
-parse = parse' topLevel
diff --git a/src/full/Agda/Compiler/JS/Pretty.hs b/src/full/Agda/Compiler/JS/Pretty.hs
index 648bfbb..e715e39 100644
--- a/src/full/Agda/Compiler/JS/Pretty.hs
+++ b/src/full/Agda/Compiler/JS/Pretty.hs
@@ -7,10 +7,7 @@ import Data.Map ( Map, toAscList, empty, null )
import Agda.Syntax.Common ( Nat )
-import Agda.Compiler.JS.Syntax
- ( Exp(Self,Local,Global,Undefined,String,Char,Integer,Double,Lambda,Object,Apply,Lookup,If,BinOp,PreOp,Const),
- LocalId(LocalId), GlobalId(GlobalId), MemberId(MemberId), Module(Module), Export(Export),
- globals )
+import Agda.Compiler.JS.Syntax hiding (exports)
-- Pretty-print a lambda-calculus expression as ECMAScript.
@@ -73,7 +70,7 @@ instance Pretty Exp where
pretty n i (Undefined) = "undefined"
pretty n i (String s) = "\"" ++ unescapes s ++ "\""
pretty n i (Char c) = "\"" ++ unescape c ++ "\""
- pretty n i (Integer x) = show x
+ pretty n i (Integer x) = "agdaRTS.primIntegerFromString(\"" ++ show x ++ "\")"
pretty n i (Double x) = show x
pretty n i (Lambda x e) =
"function (" ++
@@ -89,6 +86,7 @@ instance Pretty Exp where
pretty n i (PreOp op e) = "(" ++ op ++ " " ++ pretty n i e ++ ")"
pretty n i (BinOp e op f) = "(" ++ pretty n i e ++ " " ++ op ++ " " ++ pretty n i f ++ ")"
pretty n i (Const c) = c
+ pretty n i (PlainJS js) = "(" ++ js ++ ")"
block :: Nat -> Int -> Exp -> String
block n i (If e f g) = "{" ++ br (i+1) ++ block' n (i+1) (If e f g) ++ br i ++ "}"
@@ -103,16 +101,20 @@ modname (GlobalId ms) = "\"" ++ intercalate "." ms ++ "\""
exports :: Nat -> Int -> Set [MemberId] -> [Export] -> String
exports n i lss [] = ""
-exports n i lss (Export ls e : es) | member (init ls) lss =
+exports n i lss (Export ls _ e : es) | member (init ls) lss =
"exports[" ++ intercalate "][" (pretties n i ls) ++ "] = " ++ pretty n (i+1) e ++ ";" ++ br i ++
exports n i (insert ls lss) es
-exports n i lss (Export ls e : es) | otherwise =
- exports n i lss (Export (init ls) (Object empty) : Export ls e : es)
+exports n i lss (Export ls isCoind e : es) | otherwise =
+ exports n i lss (Export (init ls) False (Object empty) : Export ls isCoind e : es)
instance Pretty Module where
- pretty n i (Module m es) =
- "define([" ++ intercalate "," ("\"exports\"" : map modname js) ++ "]," ++
- "function(" ++ intercalate "," ("exports" : pretties n i js) ++ ") {" ++ br (i+1) ++
- exports n (i+1) (singleton []) es ++
- "});" ++ br i
- where js = toList (globals es)
+ pretty n i (Module m es ex) =
+ imports ++ br i
+ ++ exports n i (singleton []) es ++ br i
+ ++ maybe "" (pretty n i) ex
+ where
+ js = toList (globals es)
+ imports = unlines $
+ ["var agdaRTS = require(\"agda-rts\");"] ++
+ ["var " ++ pretty n (i+1) e ++ " = require(" ++ modname e ++ ");"
+ | e <- js]
diff --git a/src/full/Agda/Compiler/JS/Syntax.hs b/src/full/Agda/Compiler/JS/Syntax.hs
index bcbaf7c..50556de 100644
--- a/src/full/Agda/Compiler/JS/Syntax.hs
+++ b/src/full/Agda/Compiler/JS/Syntax.hs
@@ -27,7 +27,8 @@ data Exp =
If Exp Exp Exp |
BinOp Exp String Exp |
PreOp String Exp |
- Const String
+ Const String |
+ PlainJS String -- ^ Arbitrary JS code.
deriving (Typeable, Show)
-- Local identifiers are named by De Bruijn indices.
@@ -46,10 +47,10 @@ newtype MemberId = MemberId String
-- The top-level compilation unit is a module, which names
-- the GId of its exports, and a list of definitions
-data Export = Export { expName :: [MemberId], defn :: Exp }
+data Export = Export { expName :: [MemberId], isCoind :: Bool, defn :: Exp }
deriving (Typeable, Show)
-data Module = Module { modName :: GlobalId, exports :: [Export] }
+data Module = Module { modName :: GlobalId, exports :: [Export], postscript :: Maybe Exp }
deriving (Typeable, Show)
-- Note that modules are allowed to be recursive, via the Self expression,
@@ -79,7 +80,7 @@ instance Uses Exp where
uses e = empty
instance Uses Export where
- uses (Export ls e) = uses e
+ uses (Export _ _ e) = uses e
-- All global ids
@@ -104,7 +105,7 @@ instance Globals Exp where
globals _ = empty
instance Globals Export where
- globals (Export ls e) = globals e
+ globals (Export _ _ e) = globals e
instance Globals Module where
- globals (Module m es) = globals es
+ globals (Module m es _) = globals es
diff --git a/src/full/Agda/Compiler/MAlonzo/Compiler.hs b/src/full/Agda/Compiler/MAlonzo/Compiler.hs
index 7e5eb79..5368700 100644
--- a/src/full/Agda/Compiler/MAlonzo/Compiler.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Compiler.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Agda.Compiler.MAlonzo.Compiler where
@@ -14,7 +12,7 @@ import Control.Monad.Reader hiding (mapM_, forM_, mapM, forM, sequence)
import Control.Monad.State hiding (mapM_, forM_, mapM, forM, sequence)
import Data.Generics.Geniplate
-import Data.Foldable hiding (any, foldr, sequence_)
+import Data.Foldable hiding (any, all, foldr, sequence_)
import Data.Function
import qualified Data.List as List
import Data.Map (Map)
@@ -24,10 +22,9 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable hiding (for)
-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 Numeric.IEEE
+
+import qualified Agda.Utils.Haskell.Syntax as HS
import System.Directory (createDirectoryIfMissing)
import System.FilePath hiding (normalise)
@@ -39,12 +36,14 @@ import Agda.Compiler.MAlonzo.Pretty
import Agda.Compiler.MAlonzo.Primitives
import Agda.Compiler.ToTreeless
import Agda.Compiler.Treeless.Unused
+import Agda.Compiler.Treeless.Erase
import Agda.Interaction.FindFile
import Agda.Interaction.Imports
import Agda.Interaction.Options
import Agda.Syntax.Common
+import Agda.Syntax.Fixity
import qualified Agda.Syntax.Abstract.Name as A
import qualified Agda.Syntax.Concrete.Name as C
import Agda.Syntax.Internal as I
@@ -71,7 +70,7 @@ import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
-import Agda.Utils.Pretty (prettyShow)
+import Agda.Utils.Pretty (prettyShow, Pretty)
import qualified Agda.Utils.IO.UTF8 as UTF8
import qualified Agda.Utils.HashMap as HMap
import Agda.Utils.Singleton
@@ -96,12 +95,12 @@ compile i = do
yesComp
writeModule =<< decl <$> curHsMod <*> (definitions =<< curDefs) <*> imports
where
- decl mn ds imp = HS.Module dummy mn [] Nothing Nothing imp (map fakeDecl (reverse $ iHaskellCode i) ++ ds)
+ decl mn ds imp = HS.Module mn [] imp (map fakeDecl (reverse $ iHaskellCode i) ++ ds)
uptodate = liftIO =<< (isNewerThan <$> outFile_ <*> ifile)
ifile = maybe __IMPOSSIBLE__ filePath <$>
(findInterfaceFile . toTopLevelModuleName =<< curMName)
- noComp = reportSLn "" 1 . (++ " : no compilation is needed.") . show . A.mnameToConcrete =<< curMName
- yesComp = reportSLn "" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<
+ noComp = reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . show . A.mnameToConcrete =<< curMName
+ yesComp = reportSLn "compile.ghc" 1 . (`repl` "Compiling <<0>> in <<1>> to <<2>>") =<<
sequence [show . A.mnameToConcrete <$> curMName, ifile, outFile_] :: TCM ()
--------------------------------------------------
@@ -118,23 +117,20 @@ imports = (++) <$> hsImps <*> imps where
getHaskellImports
unqualRTE :: HS.ImportDecl
- unqualRTE = HS.ImportDecl dummy mazRTE False False False Nothing Nothing $ Just $
-#if MIN_VERSION_haskell_src_exts(1,17,0)
- (False, [HS.IVar $ HS.Ident x | x <- [mazCoerceName, mazErasedName]])
-#else
- (False, [HS.IVar HS.NoNamespace $ HS.Ident x | x <- [mazCoerceName, mazErasedName]])
-#endif
+ unqualRTE = HS.ImportDecl mazRTE False $ Just $
+ (False, [ HS.IVar $ HS.Ident x
+ | x <- [mazCoerceName, mazErasedName] ++
+ map treelessPrimName [T.PAdd, T.PSub, T.PMul, T.PQuot, T.PRem, T.PGeq, T.PLt, T.PEqI, T.PEqF] ])
imps :: TCM [HS.ImportDecl]
imps = List.map decl . uniq <$>
((++) <$> importsForPrim <*> (List.map mazMod <$> mnames))
decl :: HS.ModuleName -> HS.ImportDecl
- decl m = HS.ImportDecl dummy m True False False Nothing Nothing Nothing
+ decl m = HS.ImportDecl m True Nothing
mnames :: TCM [ModuleName]
- mnames = (++) <$> (Set.elems <$> use stImportedModules)
- <*> (List.map fst . iImportedModules <$> curIF)
+ mnames = Set.elems <$> use stImportedModules
uniq :: [HS.ModuleName] -> [HS.ModuleName]
uniq = List.map head . List.group . List.sort
@@ -173,11 +169,11 @@ definition kit (Defn UnusedArg _ _ _ _ _ _ _ _) = __IMPOSSIBLE__
definition kit (Defn NonStrict _ _ _ _ _ _ _ _) = __IMPOSSIBLE__
-}
definition kit Defn{defArgInfo = info, defName = q} | isIrrelevant info = do
- reportSDoc "malonzo.definition" 10 $
+ reportSDoc "compile.ghc.definition" 10 $
text "Not compiling" <+> prettyTCM q <> text "."
return []
definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef = d} = do
- reportSDoc "malonzo.definition" 10 $ vcat
+ reportSDoc "compile.ghc.definition" 10 $ vcat
[ text "Compiling" <+> prettyTCM q <> text ":"
, nest 2 $ text (show d)
]
@@ -197,11 +193,11 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
a = ihname "a" 0
b = ihname "a" 1
vars = [a, b]
- return [ HS.TypeDecl dummy infT
+ return [ HS.TypeDecl infT
(List.map HS.UnkindedVar vars)
(HS.TyVar b)
- , HS.FunBind [HS.Match dummy infV
- (List.map HS.PVar vars) Nothing
+ , HS.FunBind [HS.Match infV
+ (List.map HS.PVar vars)
(HS.UnGuardedRhs HS.unit_con)
emptyBinds]
]
@@ -209,11 +205,10 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
let sharp = unqhname "d" q
x = ihname "x" 0
return $
- [ HS.TypeSig dummy [sharp] $ fakeType $
+ [ HS.TypeSig [sharp] $ fakeType $
"forall a. a -> a"
- , HS.FunBind [HS.Match dummy sharp
+ , HS.FunBind [HS.Match sharp
[HS.PVar x]
- Nothing
(HS.UnGuardedRhs (HS.Var (HS.UnQual x)))
emptyBinds]
]
@@ -221,11 +216,10 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
let flat = unqhname "d" q
x = ihname "x" 0
return $
- [ HS.TypeSig dummy [flat] $ fakeType $
+ [ HS.TypeSig [flat] $ fakeType $
"forall a. a -> a"
- , HS.FunBind [HS.Match dummy flat
+ , HS.FunBind [HS.Match flat
[HS.PVar x]
- Nothing
(HS.UnGuardedRhs (HS.Var (HS.UnQual x)))
emptyBinds]
]
@@ -239,14 +233,16 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
| Just (HsType ty) <- compiledHaskell compiled -> do
ccscov <- ifM (noCheckCover q) (return []) $ do
ccs <- List.concat <$> mapM checkConstructorType cs
- cov <- checkCover q ty np cs
+ cov <- checkCover q ty (np + ni) cs
return $ ccs ++ cov
return $ tvaldecl q (dataInduction d) 0 (np + ni) [] (Just __IMPOSSIBLE__) ++ ccscov
Datatype{ dataPars = np, dataIxs = ni, dataClause = cl, dataCons = cs } -> do
+ computeErasedConstructorArgs q
(ars, cds) <- unzip <$> mapM condecl cs
return $ tvaldecl q (dataInduction d) (List.maximum (np:ars) - np) (np + ni) cds cl
Constructor{} -> return []
Record{ recClause = cl, recConHead = con, recFields = flds } -> do
+ computeErasedConstructorArgs q
let c = conName con
let noFields = length flds
let ar = I.arity ty
@@ -255,6 +251,7 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
-- Nothing -> return $ cdecl q noFields
-- Just c -> snd <$> condecl c
return $ tvaldecl q Inductive noFields ar [cd] cl
+ AbstractDefn -> __IMPOSSIBLE__
where
function :: Maybe HaskellExport -> TCM [HS.Decl] -> TCM [HS.Decl]
function mhe fun = do
@@ -263,10 +260,10 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
Nothing -> return ccls
Just (HsExport t name) -> do
let tsig :: HS.Decl
- tsig = HS.TypeSig dummy [HS.Ident name] (fakeType t)
+ tsig = HS.TypeSig [HS.Ident name] (fakeType t)
def :: HS.Decl
- def = HS.FunBind [HS.Match dummy (HS.Ident name) [] Nothing (HS.UnGuardedRhs (hsVarUQ $ dname q)) emptyBinds]
+ def = HS.FunBind [HS.Match (HS.Ident name) [] (HS.UnGuardedRhs (hsVarUQ $ dname q)) emptyBinds]
return ([tsig,def] ++ ccls)
functionViaTreeless :: QName -> TCM [HS.Decl]
@@ -280,15 +277,15 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
let (ps, b) = lamView e
lamView e =
case stripTopCoerce e of
- HS.Lambda _ ps b -> (ps, b)
+ HS.Lambda ps b -> (ps, b)
b -> ([], b)
- stripTopCoerce (HS.Lambda i ps b) = HS.Lambda i ps $ stripTopCoerce b
+ stripTopCoerce (HS.Lambda ps b) = HS.Lambda ps $ stripTopCoerce b
stripTopCoerce e =
case hsAppView e of
[c, e] | c == mazCoerce -> e
_ -> e
- funbind f ps b = HS.FunBind [HS.Match dummy f ps Nothing (HS.UnGuardedRhs b) emptyBinds]
+ funbind f ps b = HS.FunBind [HS.Match f ps (HS.UnGuardedRhs b) emptyBinds]
-- The definition of the non-stripped function
(ps0, _) <- lamView <$> closedTerm (foldr ($) T.TErased $ replicate (length used) T.TLam)
@@ -300,25 +297,20 @@ definition kit Defn{defName = q, defType = ty, defCompiledRep = compiled, theDef
else [ funbind (dname q) ps b ]
mkwhere :: [HS.Decl] -> [HS.Decl]
- mkwhere (HS.FunBind [m0, HS.Match _ dn ps mt rhs emptyBinds] :
- fbs@(_:_)) =
- [HS.FunBind [m0, HS.Match dummy dn ps mt rhs bindsAux]]
+ mkwhere (HS.FunBind [m0, HS.Match dn ps rhs emptyBinds] : fbs@(_:_)) =
+ [HS.FunBind [m0, HS.Match dn ps rhs bindsAux]]
where
-#if MIN_VERSION_haskell_src_exts(1,17,0)
bindsAux :: Maybe HS.Binds
bindsAux = Just $ HS.BDecls fbs
-#else
- bindsAux :: HS.Binds
- bindsAux = HS.BDecls fbs
-#endif
+
mkwhere fbs = fbs
fbWithType :: HaskellType -> HS.Exp -> [HS.Decl]
fbWithType ty e =
- [ HS.TypeSig dummy [unqhname "d" q] $ fakeType ty ] ++ fb e
+ [ HS.TypeSig [unqhname "d" q] $ fakeType ty ] ++ fb e
fb :: HS.Exp -> [HS.Decl]
- fb e = [HS.FunBind [HS.Match dummy (unqhname "d" q) [] Nothing
+ fb e = [HS.FunBind [HS.Match (unqhname "d" q) []
(HS.UnGuardedRhs $ e) emptyBinds]]
axiomErr :: HS.Exp
@@ -367,8 +359,8 @@ intros n cont = freshNames n $ \xs ->
checkConstructorType :: QName -> TCM [HS.Decl]
checkConstructorType q = do
Just (HsDefn ty hs) <- compiledHaskell . defCompiledRep <$> getConstInfo q
- return [ HS.TypeSig dummy [unqhname "check" q] $ fakeType ty
- , HS.FunBind [HS.Match dummy (unqhname "check" q) [] Nothing
+ return [ HS.TypeSig [unqhname "check" q] $ fakeType ty
+ , HS.FunBind [HS.Match (unqhname "check" q) []
(HS.UnGuardedRhs $ fakeExp hs) emptyBinds]
]
@@ -376,19 +368,19 @@ checkCover :: QName -> HaskellType -> Nat -> [QName] -> TCM [HS.Decl]
checkCover q ty n cs = do
let tvs = [ "a" ++ show i | i <- [1..n] ]
makeClause c = do
- (a, _) <- conArityAndPars c
+ a <- erasedArity c
Just (HsDefn _ hsc) <- compiledHaskell . defCompiledRep <$> getConstInfo c
let pat = HS.PApp (HS.UnQual $ HS.Ident hsc) $ replicate a HS.PWildCard
- return $ HS.Alt dummy pat (HS.UnGuardedRhs $ HS.unit_con) emptyBinds
+ return $ HS.Alt pat (HS.UnGuardedRhs $ HS.unit_con) emptyBinds
cs <- mapM makeClause cs
let rhs = case cs of
[] -> fakeExp "()" -- There is no empty case statement in Haskell
_ -> HS.Case (HS.Var $ HS.UnQual $ HS.Ident "x") cs
- return [ HS.TypeSig dummy [unqhname "cover" q] $ fakeType $ unwords (ty : tvs) ++ " -> ()"
- , HS.FunBind [HS.Match dummy (unqhname "cover" q) [HS.PVar $ HS.Ident "x"]
- Nothing (HS.UnGuardedRhs rhs) emptyBinds]
+ return [ HS.TypeSig [unqhname "cover" q] $ fakeType $ unwords (ty : tvs) ++ " -> ()"
+ , HS.FunBind [HS.Match (unqhname "cover" q) [HS.PVar $ HS.Ident "x"]
+ (HS.UnGuardedRhs rhs) emptyBinds]
]
closedTerm :: T.TTerm -> TCM HS.Exp
@@ -404,13 +396,32 @@ term tm0 = case tm0 of
return $ hsVarUQ x
T.TApp (T.TDef f) ts -> do
used <- lift $ getCompiledArgUse f
- if any not used && length ts >= length used
- then do
+ let given = length ts
+ needed = length used
+ missing = drop given used
+ if any not used
+ then if any not missing then term (etaExpand (needed - given) tm0) else do
f <- lift $ HS.Var <$> xhqn "du" f -- used stripped function
f `apps` [ t | (t, True) <- zip ts $ used ++ repeat True ]
else do
t' <- term (T.TDef f)
t' `apps` ts
+ T.TApp (T.TCon c) ts -> do
+ kit <- lift coinductionKit
+ if Just c == (nameOfSharp <$> kit)
+ then do
+ t' <- HS.Var <$> lift (xhqn "d" c)
+ apps t' ts
+ else do
+ (ar, _) <- lift $ conArityAndPars c
+ erased <- lift $ getErasedConArgs c
+ let missing = drop (length ts) erased
+ notErased = not
+ case all notErased missing of
+ False -> term $ etaExpand (length missing) tm0
+ True -> do
+ f <- lift $ HS.Con <$> conhqn c
+ f `apps` [ t | (t, False) <- zip ts erased ]
T.TApp t ts -> do
t' <- term t
t' `apps` ts
@@ -428,18 +439,14 @@ term tm0 = case tm0 of
sc' <- term (T.TVar sc)
alts' <- traverse (alt sc) alts
def' <- term def
- let defAlt = HS.Alt dummy HS.PWildCard (HS.UnGuardedRhs def') emptyBinds
+ let defAlt = HS.Alt HS.PWildCard (HS.UnGuardedRhs def') emptyBinds
return $ HS.Case (hsCast sc') (alts' ++ [defAlt])
- T.TLit l -> lift $ literal l
+ T.TLit l -> return $ literal l
T.TDef q -> do
HS.Var <$> (lift $ xhqn "d" q)
- T.TCon q -> do
- kit <- lift coinductionKit
- if Just q == (nameOfSharp <$> kit)
- then HS.Var <$> lift (xhqn "d" q)
- else hsCast' . HS.Con <$> lift (conhqn q)
+ T.TCon q -> term (T.TApp (T.TCon q) [])
T.TPrim p -> return $ compilePrim p
T.TUnit -> return HS.unit_con
T.TSort -> return HS.unit_con
@@ -447,62 +454,75 @@ term tm0 = case tm0 of
T.TError e -> return $ case e of
T.TUnreachable -> rtmUnreachableError
where apps = foldM (\ h a -> HS.App h <$> term a)
+ etaExpand n t =
+ foldr (const T.TLam)
+ (T.mkTApp (raise n t) [T.TVar i | i <- [n - 1, n - 2..0]])
+ (replicate n ())
+
compilePrim :: T.TPrim -> HS.Exp
-compilePrim s =
- case s of
- T.PQuot -> fakeExp "(Prelude.quot :: Integer -> Integer -> Integer)"
- T.PRem -> fakeExp "(Prelude.rem :: Integer -> Integer -> Integer)"
- T.PSub -> fakeExp "((Prelude.-) :: Integer -> Integer -> Integer)"
- T.PAdd -> fakeExp "((Prelude.+) :: Integer -> Integer -> Integer)"
- T.PMul -> fakeExp "((Prelude.*) :: Integer -> Integer -> Integer)"
- T.PGeq -> fakeExp "((Prelude.>=) :: Integer -> Integer -> Bool)"
- T.PLt -> fakeExp "((Prelude.<) :: Integer -> Integer -> Bool)"
- T.PEq -> fakeExp "((Prelude.==) :: Integer -> Integer -> Bool)"
- T.PSeq -> HS.Var (hsName "seq")
- -- primitives only used by GuardsToPrims transformation, which MAlonzo doesn't use
- T.PIf -> __IMPOSSIBLE__
+compilePrim s = HS.Var $ hsName $ treelessPrimName s
alt :: Int -> T.TAlt -> CC HS.Alt
alt sc a = do
case a of
- T.TACon {} -> do
- intros (T.aArity a) $ \xs -> do
- hConNm <- lift $ conhqn $ T.aCon a
- mkAlt (HS.PApp hConNm $ map HS.PVar xs)
+ T.TACon {T.aCon = c} -> do
+ intros (T.aArity a) $ \ xs -> do
+ erased <- lift $ getErasedConArgs c
+ hConNm <- lift $ conhqn c
+ mkAlt (HS.PApp hConNm $ map HS.PVar [ x | (x, False) <- zip xs erased ])
T.TAGuard g b -> do
g <- term g
b <- term b
- return $ HS.Alt dummy HS.PWildCard
- (HS.GuardedRhss [HS.GuardedRhs dummy [HS.Qualifier g] b])
+ return $ HS.Alt HS.PWildCard
+ (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier g] b])
emptyBinds
- T.TALit { T.aLit = (LitQName _ q) } -> mkAlt (litqnamepat q)
- T.TALit { T.aLit = (LitString _ s) , T.aBody = b } -> do
- b <- term b
+ T.TALit { T.aLit = LitQName _ q } -> mkAlt (litqnamepat q)
+ T.TALit { T.aLit = l@LitFloat{}, T.aBody = b } -> mkGuarded (treelessPrimName T.PEqF) (literal l) b
+ T.TALit { T.aLit = LitString _ s , T.aBody = b } -> mkGuarded "(==)" (litString s) b
+ T.TALit {} -> mkAlt (HS.PLit $ hslit $ T.aLit a)
+ where
+ mkGuarded eq lit b = do
+ b <- term b
sc <- term (T.TVar sc)
let guard =
- HS.Var (HS.UnQual (HS.Ident "(==)")) `HS.App`
- sc`HS.App`
- litString s
- return $ HS.Alt dummy HS.PWildCard
- (HS.GuardedRhss [HS.GuardedRhs dummy [HS.Qualifier guard] b])
+ HS.Var (HS.UnQual (HS.Ident eq)) `HS.App`
+ sc `HS.App` lit
+ return $ HS.Alt HS.PWildCard
+ (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier guard] b])
emptyBinds
- T.TALit {} -> mkAlt (HS.PLit HS.Signless $ hslit $ T.aLit a)
- where
+
mkAlt :: HS.Pat -> CC HS.Alt
mkAlt pat = do
body' <- term $ T.aBody a
- return $ HS.Alt dummy pat (HS.UnGuardedRhs $ hsCast body') emptyBinds
+ return $ HS.Alt pat (HS.UnGuardedRhs $ hsCast body') emptyBinds
-literal :: Literal -> TCM HS.Exp
+literal :: Literal -> HS.Exp
literal l = case l of
- LitNat _ _ -> return $ typed "Integer"
- LitFloat _ _ -> return $ typed "Double"
- LitQName _ x -> return $ litqname x
- LitString _ s -> return $ litString s
- _ -> return $ l'
- where l' = HS.Lit $ hslit l
- typed = HS.ExpTypeSig dummy l' . HS.TyCon . rtmQual
+ LitNat _ _ -> typed "Integer"
+ LitFloat _ x -> floatExp x "Double"
+ LitQName _ x -> litqname x
+ LitString _ s -> litString s
+ _ -> l'
+ where
+ l' = HS.Lit $ hslit l
+ typed = HS.ExpTypeSig l' . HS.TyCon . rtmQual
+
+ -- ASR (2016-09-14): See Issue #2169.
+ -- Ulf, 2016-09-28: and #2218.
+ floatExp :: Double -> String -> HS.Exp
+ floatExp x s
+ | isNegativeZero x = rte "negativeZero"
+ | isNegativeInf x = rte "negativeInfinity"
+ | isInfinite x = rte "positiveInfinity"
+ | isNegativeNaN x = rte "negativeNaN"
+ | isNaN x = rte "positiveNaN"
+ | otherwise = typed s
+
+ rte = HS.Var . HS.Qual mazRTE . HS.Ident
+
+ isNegativeInf x = isInfinite x && x < 0.0
+ isNegativeNaN x = isNaN x && not (identicalIEEE x (0.0 / 0.0))
hslit :: Literal -> HS.Literal
hslit l = case l of LitNat _ x -> HS.Int x
@@ -519,26 +539,47 @@ litString s =
litqname :: QName -> HS.Exp
litqname x =
- HS.Con (HS.Qual mazRTE $ HS.Ident "QName") `HS.App`
- hsTypedInt n `HS.App`
- hsTypedInt m `HS.App`
- HS.Lit (HS.String $ show x )
+ rteCon "QName" `apps`
+ [ hsTypedInt n
+ , hsTypedInt m
+ , HS.Lit $ HS.String $ show x
+ , rteCon "Fixity" `apps`
+ [ litAssoc (fixityAssoc fx)
+ , litPrec (fixityLevel fx) ] ]
where
+ apps = foldl HS.App
+ rteCon name = HS.Con $ HS.Qual mazRTE $ HS.Ident name
NameId n m = nameId $ qnameName x
+ fx = theFixity $ nameFixity $ qnameName x
+
+ litAssoc NonAssoc = rteCon "NonAssoc"
+ litAssoc LeftAssoc = rteCon "LeftAssoc"
+ litAssoc RightAssoc = rteCon "RightAssoc"
+
+ litPrec Unrelated = rteCon "Unrelated"
+ litPrec (Related l) = rteCon "Related" `HS.App` hsTypedInt l
litqnamepat :: QName -> HS.Pat
litqnamepat x =
HS.PApp (HS.Qual mazRTE $ HS.Ident "QName")
- [ HS.PLit HS.Signless (HS.Int n)
- , HS.PLit HS.Signless (HS.Int m)
- , HS.PWildCard]
+ [ HS.PLit (HS.Int $ fromIntegral n)
+ , HS.PLit (HS.Int $ fromIntegral m)
+ , HS.PWildCard, HS.PWildCard ]
where
NameId n m = nameId $ qnameName x
+erasedArity :: QName -> TCM Nat
+erasedArity q = do
+ (ar, _) <- conArityAndPars q
+ erased <- length . filter id <$> getErasedConArgs q
+ return (ar - erased)
+
condecl :: QName -> TCM (Nat, HS.ConDecl)
condecl q = do
(ar, np) <- conArityAndPars q
- return $ (ar + np, cdecl q ar)
+ erased <- length . filter id <$> getErasedConArgs q
+ let ar' = ar - erased
+ return $ (ar' + np, cdecl q ar')
cdecl :: QName -> Nat -> HS.ConDecl
cdecl q n = HS.ConDecl (unqhname "C" q)
@@ -549,10 +590,8 @@ tvaldecl :: QName
-- ^ Is the type inductive or coinductive?
-> Nat -> Nat -> [HS.ConDecl] -> Maybe Clause -> [HS.Decl]
tvaldecl q ind ntv npar cds cl =
- HS.FunBind [HS.Match dummy vn pvs Nothing
- (HS.UnGuardedRhs HS.unit_con) emptyBinds] :
- maybe [HS.DataDecl dummy kind [] tn tvs
- (List.map (HS.QualConDecl dummy [] []) cds) []]
+ HS.FunBind [HS.Match vn pvs (HS.UnGuardedRhs HS.unit_con) emptyBinds] :
+ maybe [HS.DataDecl kind tn tvs cds []]
(const []) cl
where
(tn, vn) = (unqhname "T" q, unqhname "d" q)
@@ -563,7 +602,6 @@ tvaldecl q ind ntv npar cds cl =
-- single argument are translated into newtypes.
kind = case (ind, cds) of
(Inductive, [HS.ConDecl _ [_]]) -> HS.NewType
- (Inductive, [HS.RecDecl _ [_]]) -> HS.NewType
_ -> HS.DataType
infodecl :: QName -> [HS.Decl] -> [HS.Decl]
@@ -581,7 +619,7 @@ hsCast = addcast . go where
addcast es = foldl HS.App mazCoerce es
-- this need to be extended if you generate other kinds of exps.
go (HS.App e1 e2 ) = go e1 ++ [hsCast e2]
- go (HS.Lambda _ ps e) = [ HS.Lambda dummy ps (hsCast e) ]
+ go (HS.Lambda _ ps e) = [ HS.Lambda ps (hsCast e) ]
go e = [e]
-}
@@ -590,7 +628,7 @@ hsCast e = hsCoerce (hsCast' e)
hsCast' :: HS.Exp -> HS.Exp
hsCast' (HS.InfixApp e1 op e2) = hsCoerce $ HS.InfixApp (hsCast' e1) op (hsCast' e2)
-hsCast' (HS.Lambda _ ps e) = HS.Lambda dummy ps $ hsCast' e
+hsCast' (HS.Lambda ps e) = HS.Lambda ps $ hsCast' e
hsCast' (HS.Let bs e) = HS.Let bs $ hsCast' e
hsCast' (HS.Case sc alts) = HS.Case (hsCast' sc) (map (hsMapAlt hsCast') alts)
hsCast' e =
@@ -601,7 +639,7 @@ hsCast' e =
-- We still have to coerce function applications in arguments to coerced
-- functions.
hsCastApp :: HS.Exp -> HS.Exp
-hsCastApp (HS.Lambda i ps b) = HS.Lambda i ps (hsCastApp b)
+hsCastApp (HS.Lambda ps b) = HS.Lambda ps (hsCastApp b)
hsCastApp (HS.Case sc bs) = HS.Case (hsCastApp sc) (map (hsMapAlt hsCastApp) bs)
hsCastApp (HS.InfixApp e1 op e2) = HS.InfixApp (hsCastApp e1) op (hsCastApp e2)
hsCastApp e =
@@ -611,7 +649,7 @@ hsCastApp e =
-- No coercion for literal integers
hsCoerce :: HS.Exp -> HS.Exp
-hsCoerce e@(HS.ExpTypeSig _ (HS.Lit (HS.Int{})) _) = e
+hsCoerce e@(HS.ExpTypeSig (HS.Lit (HS.Int{})) _) = e
hsCoerce (HS.Case sc alts) = HS.Case sc (map (hsMapAlt hsCoerce) alts)
hsCoerce (HS.Let bs e) = HS.Let bs $ hsCoerce e
hsCoerce e =
@@ -630,13 +668,13 @@ copyRTEModules = do
(lift . copyDirContent srcDir) =<< compileDir
writeModule :: HS.Module -> TCM ()
-writeModule (HS.Module l m ps w ex imp ds) = do
+writeModule (HS.Module m ps imp ds) = do
-- Note that GHC assumes that sources use ASCII or UTF-8.
out <- outFile m
liftIO $ UTF8.writeFile out $ prettyPrint $
- HS.Module l m (p : ps) w ex imp ds
+ HS.Module m (p : ps) imp ds
where
- p = HS.LanguagePragma dummy $ List.map HS.Ident $
+ p = HS.LanguagePragma $ List.map HS.Ident $
[ "EmptyDataDecls"
, "ExistentialQuantification"
, "ScopedTypeVariables"
@@ -645,8 +683,7 @@ writeModule (HS.Module l m ps w ex imp ds) = do
]
-outFile' :: (HS.Pretty a, TransformBi HS.ModuleName (Wrap a)) =>
- a -> TCM (FilePath, FilePath)
+outFile' :: Pretty a => a -> TCM (FilePath, FilePath)
outFile' m = do
mdir <- compileDir
let (fdir, fn) = splitFileName $ repldot pathSeparator $
diff --git a/src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot b/src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot
index ddc049a..7bb1027 100644
--- a/src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot
+++ b/src/full/Agda/Compiler/MAlonzo/Compiler.hs-boot
@@ -1,6 +1,6 @@
module Agda.Compiler.MAlonzo.Compiler where
-import qualified Language.Haskell.Exts.Syntax as HS
+import qualified Agda.Utils.Haskell.Syntax as HS
import Agda.Syntax.Treeless (TTerm)
import Agda.TypeChecking.Monad (TCM)
diff --git a/src/full/Agda/Compiler/MAlonzo/Encode.hs b/src/full/Agda/Compiler/MAlonzo/Encode.hs
index 57b9576..7b804b2 100644
--- a/src/full/Agda/Compiler/MAlonzo/Encode.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Encode.hs
@@ -4,28 +4,15 @@
module Agda.Compiler.MAlonzo.Encode
( encodeModuleName
- , tests
) where
import Data.Char
import Data.Function
import Data.List
-import qualified Language.Haskell.Exts.Syntax as HS
-import Test.QuickCheck
+import qualified Agda.Utils.Haskell.Syntax as HS
import Agda.Compiler.MAlonzo.Misc
-import Agda.Utils.QuickCheck
-import Agda.Utils.TestHelpers
-
--- | Can the character be used in a Haskell module name part
--- (@conid@)? This function is more restrictive than what the Haskell
--- report allows.
-
-isModChar :: Char -> Bool
-isModChar c =
- isLower c || isUpper c || isDigit c || c == '_' || c == '\''
-
-- | Haskell module names have to satisfy the Haskell (including the
-- hierarchical module namespace extension) lexical syntax:
--
@@ -80,65 +67,3 @@ encodeModuleName (HS.ModuleName s) = HS.ModuleName $ case stripPrefix mazstr s o
enc c r | isOK c = c : r
| otherwise = escapeChar : shows (fromEnum c) (escapeChar : r)
-
--- 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
- s1 == s2
- else
- True
-
-prop_encodeModuleName_OK :: M -> Bool
-prop_encodeModuleName_OK (M s') =
- s ~= unM (encodeModuleName (HS.ModuleName s))
- where
- s = mazstr ++ "." ++ s'
-
- "" ~= "" = True
- ('.' : s) ~= ('.' : s') = s ~= s'
- s ~= (c : s') = isUpper c && all isModChar s1' &&
- dropWhile (/= '.') s ~= s2'
- where (s1', s2') = span (/= '.') s'
- _ ~= _ = False
-
- unM (HS.ModuleName s) = s
-
-prop_encodeModuleName_preserved :: M -> Property
-prop_encodeModuleName_preserved (M m) =
- shouldBePreserved m ==>
- encodeModuleName (HS.ModuleName m) == HS.ModuleName m
- where
- shouldBePreserved m =
- not (m == mazstr || (mazstr ++ ".") `isPrefixOf` m)
-
--- | Agda module names. Used to test 'encodeModuleName'.
-
-newtype M = M String deriving (Show)
-
-instance Arbitrary M where
- arbitrary = do
- ms <- choose (0, 2)
- m <- vectorOf ms namePart
- return $ M (intercalate "." m)
- where
- namePart =
- oneof [ return mazstr
- , do cs <- choose (1, 2)
- vectorOf cs (elements "a_AQZ0'-∀")
- ]
-
-------------------------------------------------------------------------
--- All tests
-
--- | All the properties.
-
-tests :: IO Bool
-tests = runTests "Agda.Compiler.MAlonzo.Encode"
- [ quickCheck' prop_encodeModuleName_injective
- , quickCheck' prop_encodeModuleName_OK
- , quickCheck' prop_encodeModuleName_preserved
- ]
diff --git a/src/full/Agda/Compiler/MAlonzo/Misc.hs b/src/full/Agda/Compiler/MAlonzo/Misc.hs
index 1fa3650..0557e4f 100644
--- a/src/full/Agda/Compiler/MAlonzo/Misc.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Misc.hs
@@ -3,12 +3,13 @@
module Agda.Compiler.MAlonzo.Misc where
import Control.Monad.State (gets)
+import Data.Char
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 qualified Agda.Utils.Haskell.Syntax as HS
import Agda.Compiler.Common
@@ -81,9 +82,11 @@ conhqn :: QName -> TCM HS.QName
conhqn q = do
cq <- canonicalName q
def <- getConstInfo cq
+ cname <- xhqn "C" cq -- Do this even if it has custom compiledHaskell code
+ -- to make sure we get the import.
case (compiledHaskell (defCompiledRep def), theDef def) of
(Just (HsDefn _ hs), Constructor{}) -> return $ hsName hs
- _ -> xhqn "C" cq
+ _ -> return cname
-- qualify name s by the module of builtin b
bltQual :: String -> String -> TCM HS.QName
@@ -107,16 +110,12 @@ hsPrimOpApp op e e1 = HS.InfixApp e (hsPrimOp op) e1
hsInt :: Integer -> HS.Exp
hsInt n = HS.Lit (HS.Int n)
-hsTypedInt :: Integer -> HS.Exp
-hsTypedInt n = HS.ExpTypeSig dummy (HS.Lit (HS.Int n)) (HS.TyCon (hsName "Integer"))
-
-hspLet :: HS.Pat -> HS.Exp -> HS.Exp -> HS.Exp
-hspLet p e b =
- HS.Let (HS.BDecls [HS.PatBind dummy p (HS.UnGuardedRhs e) emptyBinds]) b
+hsTypedInt :: Integral a => a -> HS.Exp
+hsTypedInt n = HS.ExpTypeSig (HS.Lit (HS.Int $ fromIntegral n)) (HS.TyCon (hsName "Integer"))
hsLet :: HS.Name -> HS.Exp -> HS.Exp -> HS.Exp
hsLet x e b =
- HS.Let (HS.BDecls [HS.FunBind [HS.Match dummy x [] Nothing (HS.UnGuardedRhs e) emptyBinds]]) b
+ HS.Let (HS.BDecls [HS.FunBind [HS.Match x [] (HS.UnGuardedRhs e) emptyBinds]]) b
hsVarUQ :: HS.Name -> HS.Exp
hsVarUQ = HS.Var . HS.UnQual
@@ -130,18 +129,17 @@ hsAppView = reverse . view
hsOpToExp :: HS.QOp -> HS.Exp
hsOpToExp (HS.QVarOp x) = HS.Var x
-hsOpToExp (HS.QConOp x) = HS.Con x
hsLambda :: [HS.Pat] -> HS.Exp -> HS.Exp
-hsLambda ps (HS.Lambda i ps1 e) = HS.Lambda i (ps ++ ps1) e
-hsLambda ps e = HS.Lambda dummy ps e
+hsLambda ps (HS.Lambda ps1 e) = HS.Lambda (ps ++ ps1) e
+hsLambda ps e = HS.Lambda ps e
hsMapAlt :: (HS.Exp -> HS.Exp) -> HS.Alt -> HS.Alt
-hsMapAlt f (HS.Alt i p rhs wh) = HS.Alt i p (hsMapRHS f rhs) wh
+hsMapAlt f (HS.Alt p rhs wh) = HS.Alt p (hsMapRHS f rhs) wh
hsMapRHS :: (HS.Exp -> HS.Exp) -> HS.Rhs -> HS.Rhs
hsMapRHS f (HS.UnGuardedRhs def) = HS.UnGuardedRhs (f def)
-hsMapRHS f (HS.GuardedRhss es) = HS.GuardedRhss [ HS.GuardedRhs i g (f e) | HS.GuardedRhs i g e <- es ]
+hsMapRHS f (HS.GuardedRhss es) = HS.GuardedRhss [ HS.GuardedRhs g (f e) | HS.GuardedRhs g e <- es ]
--------------------------------------------------
-- Hard coded module names
@@ -151,7 +149,7 @@ mazstr :: String
mazstr = "MAlonzo.Code"
mazName :: Name
-mazName = mkName_ dummy mazstr
+mazName = mkName_ __IMPOSSIBLE__ mazstr
mazMod' :: String -> HS.ModuleName
mazMod' s = HS.ModuleName $ mazstr ++ "." ++ s
@@ -207,10 +205,7 @@ unsafeCoerceMod = HS.ModuleName "Unsafe.Coerce"
--------------------------------------------------
fakeD :: HS.Name -> String -> HS.Decl
-fakeD v s = HS.FunBind [ HS.Match dummy v [] Nothing
- (HS.UnGuardedRhs $ hsVarUQ $ HS.Ident $ s)
- emptyBinds
- ]
+fakeD v s = HS.FunBind [HS.Match v [] (HS.UnGuardedRhs $ fakeExp s) emptyBinds]
fakeDS :: String -> String -> HS.Decl
fakeDS = fakeD . HS.Ident
@@ -219,25 +214,29 @@ fakeDQ :: QName -> String -> HS.Decl
fakeDQ = fakeD . unqhname "d"
fakeType :: String -> HS.Type
-fakeType = HS.TyVar . HS.Ident
+fakeType = HS.FakeType
fakeExp :: String -> HS.Exp
-fakeExp = HS.Var . HS.UnQual . HS.Ident
+fakeExp = HS.FakeExp
fakeDecl :: String -> HS.Decl
-fakeDecl s = HS.TypeSig dummy [HS.Ident (s ++ " {- OMG hack")] (HS.TyVar $ HS.Ident "-}")
-
-dummy :: a
-dummy = error "MAlonzo : this dummy value should not have been eval'ed."
+fakeDecl = HS.FakeDecl
--------------------------------------------------
-- Auxiliary definitions
--------------------------------------------------
-#if MIN_VERSION_haskell_src_exts(1,17,0)
emptyBinds :: Maybe HS.Binds
emptyBinds = Nothing
-#else
-emptyBinds :: HS.Binds
-emptyBinds = HS.BDecls []
-#endif
+
+--------------------------------------------------
+-- Utilities for Haskell modules names
+--------------------------------------------------
+
+-- | Can the character be used in a Haskell module name part
+-- (@conid@)? This function is more restrictive than what the Haskell
+-- report allows.
+
+isModChar :: Char -> Bool
+isModChar c =
+ isLower c || isUpper c || isDigit c || c == '_' || c == '\''
diff --git a/src/full/Agda/Compiler/MAlonzo/Pretty.hs b/src/full/Agda/Compiler/MAlonzo/Pretty.hs
index db08a8d..ed90092 100644
--- a/src/full/Agda/Compiler/MAlonzo/Pretty.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Pretty.hs
@@ -1,7 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
------------------------------------------------------------------------
-- Pretty-printing of Haskell modules
@@ -10,27 +7,208 @@
module Agda.Compiler.MAlonzo.Pretty where
import Data.Generics.Geniplate
-import qualified Language.Haskell.Exts.Pretty as Pretty
-import qualified Language.Haskell.Exts.Syntax as HS
+import qualified Agda.Utils.Haskell.Syntax as HS
+import Text.PrettyPrint (empty)
import Agda.Compiler.MAlonzo.Encode
+import Agda.Utils.Pretty
+import Agda.Utils.Impossible
--- | Encodes module names just before pretty-printing.
+#include "undefined.h"
-prettyPrint :: (Pretty.Pretty a, TransformBi HS.ModuleName (Wrap a)) =>
- a -> String
-prettyPrint = Pretty.prettyPrint .
- unwrap .
- transformBi encodeModuleName .
- Wrap
+prettyPrint :: Pretty a => a -> String
+prettyPrint = show . pretty
--- | A wrapper type used to avoid orphan instances.
+instance Pretty HS.Module where
+ pretty (HS.Module m pragmas imps decls) =
+ vcat [ vcat $ map pretty pragmas
+ , text "module" <+> pretty m <+> text "where"
+ , text ""
+ , vcat $ map pretty imps
+ , text ""
+ , vcat $ map pretty decls ]
-newtype Wrap a = Wrap { unwrap :: a }
+instance Pretty HS.ModulePragma where
+ pretty (HS.LanguagePragma ps) =
+ text "{-#" <+> text "LANGUAGE" <+> fsep (punctuate comma $ map pretty ps) <+> text "#-}"
--- Some TransformBiT instances.
+instance Pretty HS.ImportDecl where
+ pretty HS.ImportDecl{ HS.importModule = m
+ , HS.importQualified = q
+ , HS.importSpecs = specs } =
+ hsep [ text "import"
+ , if q then text "qualified" else empty
+ , pretty m
+ , maybe empty prSpecs specs ]
+ where prSpecs (hide, specs) =
+ hsep [ if hide then text "hiding" else empty
+ , parens $ fsep $ punctuate comma $ map pretty specs ]
+
+instance Pretty HS.ImportSpec where
+ pretty (HS.IVar x) = pretty x
+
+instance Pretty HS.Decl where
+ pretty d = case d of
+ HS.TypeDecl f xs t ->
+ sep [ text "type" <+> pretty f <+> fsep (map pretty xs) <+> text "="
+ , nest 2 $ pretty t ]
+ HS.DataDecl newt d xs cons derv ->
+ sep [ pretty newt <+> pretty d <+> fsep (map pretty xs)
+ , nest 2 $ if null cons then empty
+ else text "=" <+> fsep (punctuate (text " |") $ map pretty cons)
+ , nest 2 $ prDeriving derv ]
+ where
+ prDeriving [] = empty
+ prDeriving ds = text "deriving" <+> parens (fsep $ punctuate comma $ map prDer ds)
+ prDer (d, ts) = pretty (foldl HS.TyApp (HS.TyCon d) ts)
+ HS.TypeSig fs t ->
+ sep [ hsep (punctuate comma (map pretty fs)) <+> text "::"
+ , nest 2 $ pretty t ]
+ HS.FunBind ms -> vcat $ map pretty ms
+ HS.FakeDecl s -> text s
+
+instance Pretty HS.ConDecl where
+ pretty (HS.ConDecl c ts) = pretty c <+> fsep (map (prettyPrec 10) ts)
+
+instance Pretty HS.Match where
+ pretty (HS.Match f ps rhs wh) =
+ prettyWhere wh $
+ sep [ pretty f <+> fsep (map (prettyPrec 10) ps)
+ , nest 2 $ prettyRhs "=" rhs ]
+
+prettyWhere :: Maybe HS.Binds -> Doc -> Doc
+prettyWhere Nothing doc = doc
+prettyWhere (Just b) doc =
+ vcat [ doc, nest 2 $ sep [ text "where", nest 2 $ pretty b ] ]
+
+instance Pretty HS.Pat where
+ prettyPrec pr pat =
+ case pat of
+ HS.PVar x -> pretty x
+ HS.PLit l -> pretty l
+ HS.PAsPat x p -> mparens (pr > 10) $ pretty x <> text "@" <> prettyPrec 11 p
+ HS.PWildCard -> text "_"
+ HS.PBangPat p -> text "!" <> prettyPrec 11 p
+ HS.PApp c ps -> mparens (pr > 9) $ pretty c <+> hsep (map (prettyPrec 10) ps)
+ HS.PatTypeSig p t -> mparens (pr > 0) $ sep [ pretty p <+> text "::", nest 2 $ pretty t ]
+ HS.PIrrPat p -> mparens (pr > 10) $ text "~" <> prettyPrec 11 p
+
+prettyRhs :: String -> HS.Rhs -> Doc
+prettyRhs eq (HS.UnGuardedRhs e) = text eq <+> pretty e
+prettyRhs eq (HS.GuardedRhss rhss) = vcat $ map (prettyGuardedRhs eq) rhss
+
+prettyGuardedRhs :: String -> HS.GuardedRhs -> Doc
+prettyGuardedRhs eq (HS.GuardedRhs ss e) =
+ sep [ text "|" <+> sep (punctuate comma $ map pretty ss) <+> text eq
+ , nest 2 $ pretty e ]
+
+instance Pretty HS.Binds where
+ pretty (HS.BDecls ds) = vcat $ map pretty ds
+
+instance Pretty HS.DataOrNew where
+ pretty HS.DataType = text "data"
+ pretty HS.NewType = text "newtype"
+
+instance Pretty HS.TyVarBind where
+ pretty (HS.UnkindedVar x) = pretty x
+
+instance Pretty HS.Type where
+ prettyPrec pr t =
+ case t of
+ HS.TyForall xs t ->
+ mparens (pr > 0) $
+ sep [ text "forall" <+> fsep (map pretty xs) <> text "."
+ , nest 2 $ pretty t ]
+ HS.TyFun a b ->
+ mparens (pr > 4) $
+ sep [ prettyPrec 5 a <+> text "->", prettyPrec 4 b ]
+ HS.TyCon c -> pretty c
+ HS.TyVar x -> pretty x
+ t@HS.TyApp{} ->
+ sep [ prettyPrec 9 f
+ , nest 2 $ fsep $ map (prettyPrec 10) ts ]
+ where
+ f : ts = appView t []
+ appView (HS.TyApp a b) as = appView a (b : as)
+ appView t as = t : as
+ HS.FakeType s -> text s
+
+instance Pretty HS.Stmt where
+ pretty (HS.Qualifier e) = pretty e
+ pretty (HS.Generator p e) = sep [ pretty p <+> text "<-", nest 2 $ pretty e ]
+
+instance Pretty HS.Literal where
+ pretty (HS.Int n) = integer n
+ pretty (HS.Frac x) = double (fromRational x)
+ pretty (HS.Char c) = text (show c)
+ pretty (HS.String s) = text (show s)
+
+instance Pretty HS.Exp where
+ prettyPrec pr e =
+ case e of
+ HS.Var x -> pretty x
+ HS.Con c -> pretty c
+ HS.Lit l -> pretty l
+ HS.InfixApp a qop b -> mparens (pr > 0) $
+ sep [ prettyPrec 1 a
+ , pretty qop <+> prettyPrec 1 b ]
+ HS.App{} -> mparens (pr > 9) $
+ sep [ prettyPrec 9 f
+ , nest 2 $ fsep $ map (prettyPrec 10) es ]
+ where
+ f : es = appView e []
+ appView (HS.App f e) es = appView f (e : es)
+ appView f es = f : es
+ HS.Lambda ps e -> mparens (pr > 0) $
+ sep [ text "\\" <+> fsep (map (prettyPrec 10) ps) <+> text "->"
+ , nest 2 $ pretty e ]
+ HS.Let bs e -> mparens (pr > 0) $
+ sep [ text "let" <+> pretty bs <+> text "in"
+ , pretty e ]
+ HS.If a b c -> mparens (pr > 0) $
+ sep [ text "if" <+> pretty a
+ , nest 2 $ text "then" <+> pretty b
+ , nest 2 $ text "else" <+> prettyPrec 1 c ]
+ HS.Case e bs -> mparens (pr > 0) $
+ vcat [ text "case" <+> pretty e <+> text "of"
+ , nest 2 $ vcat $ map pretty bs ]
+ HS.ExpTypeSig e t -> mparens (pr > 0) $
+ sep [ pretty e <+> text "::"
+ , nest 2 $ pretty t ]
+ HS.NegApp exp -> parens $ text "-" <> pretty exp
+ HS.FakeExp s -> text s
+
+instance Pretty HS.Alt where
+ pretty (HS.Alt pat rhs wh) =
+ prettyWhere wh $
+ sep [ pretty pat, nest 2 $ prettyRhs "->" rhs ]
+
+instance Pretty HS.ModuleName where
+ pretty m = text s
+ where HS.ModuleName s = encodeModuleName m
+
+instance Pretty HS.QName where
+ pretty q = mparens (isOperator q) (prettyQName q)
+
+instance Pretty HS.Name where
+ pretty (HS.Ident s) = text s
+ pretty (HS.Symbol s) = text s
+
+instance Pretty HS.QOp where
+ pretty (HS.QVarOp x)
+ | isOperator x = prettyQName x
+ | otherwise = text "`" <> prettyQName x <> text "`"
+
+isOperator :: HS.QName -> Bool
+isOperator q =
+ case q of
+ HS.Qual _ x -> isOp x
+ HS.UnQual x -> isOp x
+ where
+ isOp HS.Symbol{} = True
+ isOp HS.Ident{} = False
+
+prettyQName :: HS.QName -> Doc
+prettyQName (HS.Qual m x) = pretty m <> text "." <> pretty x
+prettyQName (HS.UnQual x) = pretty x
-instanceTransformBiT [ [t| String |] ] [t| (HS.ModuleName, Wrap HS.Exp) |]
-instanceTransformBiT [ [t| String |] ] [t| (HS.ModuleName, Wrap HS.Module) |]
-instanceTransformBiT [ [t| String |] ] [t| (HS.ModuleName, Wrap HS.ModuleName) |]
-instanceTransformBiT [ [t| String |] ] [t| (HS.ModuleName, Wrap HS.QName) |]
diff --git a/src/full/Agda/Compiler/MAlonzo/Primitives.hs b/src/full/Agda/Compiler/MAlonzo/Primitives.hs
index 5ea52b0..f6c4c73 100644
--- a/src/full/Agda/Compiler/MAlonzo/Primitives.hs
+++ b/src/full/Agda/Compiler/MAlonzo/Primitives.hs
@@ -6,7 +6,7 @@ import Control.Monad.State
import Data.Char
import Data.List as L
import Data.Map as M
-import qualified Language.Haskell.Exts.Syntax as HS
+import qualified Agda.Utils.Haskell.Syntax as HS
import Agda.Compiler.Common
import Agda.Compiler.ToTreeless
@@ -15,6 +15,7 @@ import Agda.Compiler.MAlonzo.Misc
import Agda.Compiler.MAlonzo.Pretty
import Agda.Syntax.Common
import Agda.Syntax.Internal
+import Agda.Syntax.Treeless
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Monad.Builtin
import Agda.TypeChecking.Primitive
@@ -59,28 +60,47 @@ checkTypeOfMain q ty ret
[prettyTCM io] ++ pwords " A, for some A. The given type is" ++ [prettyTCM ty]
typeError $ GenericError $ show err
where
- mainAlias = HS.FunBind [HS.Match dummy mainLHS [] Nothing mainRHS emptyBinds ]
+ mainAlias = HS.FunBind [HS.Match mainLHS [] mainRHS emptyBinds ]
mainLHS = HS.Ident "main"
mainRHS = HS.UnGuardedRhs $ HS.Var $ HS.UnQual $ unqhname "d" q
+treelessPrimName :: TPrim -> String
+treelessPrimName p =
+ case p of
+ PQuot -> "quotInt"
+ PRem -> "remInt"
+ PSub -> "subInt"
+ PAdd -> "addInt"
+ PMul -> "mulInt"
+ PGeq -> "geqInt"
+ PLt -> "ltInt"
+ PEqI -> "eqInt"
+ PEqF -> "eqFloat"
+ -- MAlonzo uses literal patterns, so we don't need equality for the other primitive types
+ PEqC -> __IMPOSSIBLE__
+ PEqS -> __IMPOSSIBLE__
+ PEqQ -> __IMPOSSIBLE__
+ PSeq -> "seq"
+ -- primitives only used by GuardsToPrims transformation, which MAlonzo doesn't use
+ PIf -> __IMPOSSIBLE__
+
-- Haskell modules to be imported for BUILT-INs
importsForPrim :: TCM [HS.ModuleName]
importsForPrim =
fmap (++ [HS.ModuleName "Data.Text"]) $
xForPrim $
L.map (\(s, ms) -> (s, return (L.map HS.ModuleName ms))) $
- [ "CHAR" |-> ["Data.Char"]
- , "primIsDigit" |-> ["Data.Char"]
- , "primIsLower" |-> ["Data.Char"]
- , "primIsDigit" |-> ["Data.Char"]
- , "primIsAlpha" |-> ["Data.Char"]
- , "primIsSpace" |-> ["Data.Char"]
- , "primIsAscii" |-> ["Data.Char"]
- , "primIsLatin1" |-> ["Data.Char"]
- , "primIsPrint" |-> ["Data.Char"]
- , "primIsHexDigit" |-> ["Data.Char"]
- , "primToUpper" |-> ["Data.Char"]
- , "primToLower" |-> ["Data.Char"]
+ [ "CHAR" |-> ["Data.Char"]
+ , "primIsAlpha" |-> ["Data.Char"]
+ , "primIsAscii" |-> ["Data.Char"]
+ , "primIsDigit" |-> ["Data.Char"]
+ , "primIsHexDigit" |-> ["Data.Char"]
+ , "primIsLatin1" |-> ["Data.Char"]
+ , "primIsLower" |-> ["Data.Char"]
+ , "primIsPrint" |-> ["Data.Char"]
+ , "primIsSpace" |-> ["Data.Char"]
+ , "primToLower" |-> ["Data.Char"]
+ , "primToUpper" |-> ["Data.Char"]
]
where (|->) = (,)
@@ -91,8 +111,9 @@ xForPrim table = do
qs <- HMap.keys <$> curDefs
bs <- toList <$> gets stBuiltinThings
let getName (Builtin (Def q _)) = q
- getName (Builtin (Con q _)) = conName q
+ getName (Builtin (Con q _ _)) = conName q
getName (Builtin (Shared p)) = getName (Builtin $ derefPtr p)
+ getName (Builtin (Lam _ b)) = getName (Builtin $ unAbs b)
getName (Builtin _) = __IMPOSSIBLE__
getName (Prim (PrimFun q _ _)) = q
concat <$> sequence [ maybe (return []) id $ L.lookup s table
@@ -132,18 +153,17 @@ primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $
-- Floating point functions
, "primNatToFloat" |-> return "(fromIntegral :: Integer -> Double)"
- , "primFloatPlus" |-> return "((+) :: Double -> Double -> Double)"
- , "primFloatMinus" |-> return "((-) :: Double -> Double -> Double)"
- , "primFloatTimes" |-> return "((*) :: Double -> Double -> Double)"
- , "primFloatDiv" |-> return "((/) :: Double -> Double -> Double)"
- , "primFloatEquality" |-> return "((\\ x y -> if isNaN x && isNaN y then True else x == y) :: Double -> Double -> Bool)"
- , "primFloatLess" |-> return (unwords
- [ "((\\ x y ->"
- , "let isNegInf z = z < 0 && isInfinite z in"
- , "if isNegInf y then False else"
- , "if isNegInf x then True else"
- , "if isNaN x then True else"
- , "x < y) :: Double -> Double -> Bool)" ])
+ , "primFloatPlus" |-> return "((+) :: Double -> Double -> Double)"
+ , "primFloatMinus" |-> return "((-) :: Double -> Double -> Double)"
+ , "primFloatTimes" |-> return "((*) :: Double -> Double -> Double)"
+ , "primFloatNegate" |-> return "(negate :: Double -> Double)"
+ , "primFloatDiv" |-> return "((/) :: Double -> Double -> Double)"
+ -- ASR (2016-09-14). We use bitwise equality for comparing Double
+ -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove
+ -- a contradiction (see Issue #2169).
+ , "primFloatEquality" |-> return "MAlonzo.RTE.eqFloat"
+ , "primFloatNumericalEquality" |-> return "MAlonzo.RTE.eqNumFloat"
+ , "primFloatNumericalLess" |-> return "MAlonzo.RTE.ltNumFloat"
, "primFloatSqrt" |-> return "(sqrt :: Double -> Double)"
, "primRound" |-> return "(round :: Double -> Integer)"
, "primFloor" |-> return "(floor :: Double -> Integer)"
@@ -151,7 +171,13 @@ primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $
, "primExp" |-> return "(exp :: Double -> Double)"
, "primLog" |-> return "(log :: Double -> Double)"
, "primSin" |-> return "(sin :: Double -> Double)"
- , "primShowFloat" |-> return "(Data.Text.pack . (\\ x -> if isNegativeZero x then \"0.0\" else show x) :: Double -> Data.Text.Text)"
+ , "primCos" |-> return "(cos :: Double -> Double)"
+ , "primTan" |-> return "(tan :: Double -> Double)"
+ , "primASin" |-> return "(asin :: Double -> Double)"
+ , "primACos" |-> return "(acos :: Double -> Double)"
+ , "primATan" |-> return "(atan :: Double -> Double)"
+ , "primATan2" |-> return "(atan2 :: Double -> Double -> Double)"
+ , "primShowFloat" |-> return "(Data.Text.pack . show :: Double -> Data.Text.Text)"
-- Character functions
, "primCharEquality" |-> rel "(==)" "Char"
@@ -174,12 +200,13 @@ primBody s = maybe unimplemented (either (hsVarUQ . HS.Ident) id <$>) $
, "primStringFromList" |-> return "Data.Text.pack"
, "primStringAppend" |-> binAsis "Data.Text.append" "Data.Text.Text"
, "primStringEquality" |-> rel "(==)" "Data.Text.Text"
- , "primShowString" |-> return "Data.Text.unpack"
+ , "primShowString" |-> return "id"
-- Reflection
, "primQNameEquality" |-> rel "(==)" "MAlonzo.RTE.QName"
, "primQNameLess" |-> rel "(<)" "MAlonzo.RTE.QName"
, "primShowQName" |-> return "Data.Text.pack . MAlonzo.RTE.qnameString"
+ , "primQNameFixity" |-> return "MAlonzo.RTE.qnameFixity"
, "primMetaEquality" |-> rel "(==)" "Integer"
, "primMetaLess" |-> rel "(<)" "Integer"
, "primShowMeta" |-> return "\\ x -> Data.Text.pack (\"_\" ++ show (x :: Integer))"
@@ -223,7 +250,7 @@ noCheckCover q = (||) <$> isBuiltin q builtinNat <*> isBuiltin q builtinInteger
pconName :: String -> TCM String
pconName s = toS . ignoreSharing =<< getBuiltin s where
- toS (Con q _) = prettyPrint <$> conhqn (conName q)
+ toS (Con q _ _) = prettyPrint <$> conhqn (conName q)
toS (Lam _ t) = toS (unAbs t)
toS _ = mazerror $ "pconName" ++ s
diff --git a/src/full/Agda/Compiler/ToTreeless.hs b/src/full/Agda/Compiler/ToTreeless.hs
index c68e227..dde788f 100644
--- a/src/full/Agda/Compiler/ToTreeless.hs
+++ b/src/full/Agda/Compiler/ToTreeless.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.ToTreeless
( toTreeless
@@ -32,6 +30,8 @@ import Agda.Compiler.Treeless.Erase
import Agda.Compiler.Treeless.Uncase
import Agda.Compiler.Treeless.Pretty
import Agda.Compiler.Treeless.Unused
+import Agda.Compiler.Treeless.AsPatterns
+import Agda.Compiler.Treeless.Identity
import Agda.Syntax.Common
import Agda.TypeChecking.Monad as TCM
@@ -43,6 +43,7 @@ import qualified Agda.Utils.HashMap as HMap
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
+import Agda.Utils.Lens
import qualified Agda.Utils.Pretty as P
#include "undefined.h"
@@ -69,6 +70,14 @@ toTreeless' q =
-- functions, since that would risk inlining to fail.
ccToTreeless q cc
+-- | Does not require the name to refer to a function.
+cacheTreeless :: QName -> TCM ()
+cacheTreeless q = do
+ def <- theDef <$> getConstInfo q
+ case def of
+ Function{} -> () <$ toTreeless' q
+ _ -> return ()
+
ccToTreeless :: QName -> CC.CompiledClauses -> TCM C.TTerm
ccToTreeless q cc = do
let pbody b = pbody' "" b
@@ -87,6 +96,10 @@ ccToTreeless q cc = do
reportSDoc "treeless.opt.erase" (30 + v) $ text "-- after erasure" $$ pbody body
body <- caseToSeq body
reportSDoc "treeless.opt.uncase" (30 + v) $ text "-- after uncase" $$ pbody body
+ body <- recoverAsPatterns body
+ reportSDoc "treeless.opt.aspat" (30 + v) $ text "-- after @-pattern recovery" $$ pbody body
+ body <- detectIdentityFunctions q body
+ reportSDoc "treeless.opt.id" (30 + v) $ text "-- after identity function detection" $$ pbody body
body <- simplifyTTerm body
reportSDoc "treeless.opt.simpl" (30 + v) $ text "-- after third simplification" $$ pbody body
body <- eraseTerms q body
@@ -158,13 +171,17 @@ casetree cc = do
CC.Done xs v -> lambdasUpTo (length xs) $ do
v <- lift $ putAllowedReductions [ProjectionReductions, CopatternReductions] $ normalise v
substTerm v
- CC.Case (Arg _ n) (CC.Branches True conBrs _ _) -> lambdasUpTo n $ do
+ CC.Case _ (CC.Branches True _ _ Just{}) -> __IMPOSSIBLE__
+ -- Andreas, 2016-06-03, issue #1986: Ulf: "no catch-all for copatterns!"
+ -- lift $ do
+ -- typeError . GenericDocError =<< do
+ -- text "Not yet implemented: compilation of copattern matching with catch-all clause"
+ CC.Case (Arg _ n) (CC.Branches True conBrs _ Nothing) -> lambdasUpTo n $ do
mkRecord =<< traverse casetree (CC.content <$> conBrs)
CC.Case (Arg _ n) (CC.Branches False conBrs litBrs catchAll) -> lambdasUpTo (n + 1) $ do
if Map.null conBrs && Map.null litBrs then do
-- there are no branches, just return default
- fromMaybe C.tUnreachable
- <$> (fmap C.TVar <$> asks ccCatchAll)
+ fromCatchAll
else do
caseTy <- case (Map.keys conBrs, Map.keys litBrs) of
((c:_), []) -> do
@@ -173,18 +190,21 @@ casetree cc = do
return $ C.CTData dtNm
([], (LitChar _ _):_) -> return C.CTChar
([], (LitString _ _):_) -> return C.CTString
+ ([], (LitFloat _ _):_) -> return C.CTFloat
([], (LitQName _ _):_) -> return C.CTQName
_ -> __IMPOSSIBLE__
updateCatchAll catchAll $ do
x <- lookupLevel n <$> asks ccCxt
- -- normally, Agda should make sure that a pattern match is total,
- -- so we set the default to unreachable if no default has been provided.
- def <- fromMaybe C.tUnreachable
- <$> (fmap C.TVar <$> asks ccCatchAll)
+ def <- fromCatchAll
C.TCase x caseTy def <$> do
br1 <- conAlts n conBrs
br2 <- litAlts n litBrs
return (br1 ++ br2)
+ where
+ -- normally, Agda should make sure that a pattern match is total,
+ -- so we set the default to unreachable if no default has been provided.
+ fromCatchAll :: CC C.TTerm
+ fromCatchAll = maybe C.tUnreachable C.TVar <$> asks ccCatchAll
commonArity :: CC.CompiledClauses -> Int
commonArity cc =
@@ -283,7 +303,7 @@ mkRecord fs = lift $ do
recConFromProj :: QName -> TCM I.ConHead
recConFromProj q = do
caseMaybeM (isProjection q) __IMPOSSIBLE__ $ \ proj -> do
- let d = projFromType proj
+ let d = unArg $ projFromType proj
getRecordConstructor d
@@ -308,7 +328,7 @@ substTerm term = normaliseStatic term >>= \ term ->
I.Def q es -> do
let args = fromMaybe __IMPOSSIBLE__ $ I.allApplyElims es
maybeInlineDef q args
- I.Con c args -> do
+ I.Con c ci args -> do
c' <- lift $ canonicalName $ I.conName c
C.mkTApp (C.TCon c') <$> substArgs args
I.Shared _ -> __IMPOSSIBLE__ -- the ignoreSharing fun should already take care of this
@@ -326,12 +346,12 @@ normaliseStatic v = pure v
maybeInlineDef :: I.QName -> I.Args -> CC C.TTerm
maybeInlineDef q vs =
ifM (lift $ alwaysInline q) doinline $ do
+ lift $ cacheTreeless q
def <- lift $ getConstInfo q
case theDef def of
- Function{ funInline = inline }
- | inline -> doinline
+ fun@Function{}
+ | fun ^. funInline -> doinline
| otherwise -> do
- _ <- lift $ toTreeless' q
used <- lift $ getCompiledArgUse q
let substUsed False _ = pure C.TErased
substUsed True arg = substArg arg
@@ -345,5 +365,13 @@ substArgs :: [Arg I.Term] -> CC [C.TTerm]
substArgs = traverse substArg
substArg :: Arg I.Term -> CC C.TTerm
-substArg x | isIrrelevant x = return C.TErased
- | otherwise = substTerm (unArg x)
+substArg x | erasable x = return C.TErased
+ | otherwise = substTerm (unArg x)
+ where
+ erasable x =
+ case getRelevance x of
+ Irrelevant -> True
+ NonStrict -> True
+ UnusedArg -> True
+ Forced{} -> False -- TODO: would like this to be True
+ Relevant -> False
diff --git a/src/full/Agda/Compiler/Treeless/AsPatterns.hs b/src/full/Agda/Compiler/Treeless/AsPatterns.hs
new file mode 100644
index 0000000..8b5c11e
--- /dev/null
+++ b/src/full/Agda/Compiler/Treeless/AsPatterns.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE CPP #-}
+module Agda.Compiler.Treeless.AsPatterns (recoverAsPatterns) where
+
+import Control.Applicative
+import Control.Monad.Reader
+import Data.Monoid
+
+import Agda.Syntax.Treeless
+import Agda.Syntax.Literal
+import Agda.TypeChecking.Substitute
+import Agda.Compiler.Treeless.Subst
+import Agda.Compiler.Treeless.Compare
+
+import Agda.Utils.Impossible
+#include "undefined.h"
+
+data AsPat = AsPat Int QName [Int] -- x@(c ys)
+ deriving (Show)
+
+wk :: Int -> AsPat -> AsPat
+wk n (AsPat x c ys) = AsPat (n + x) c (map (n +) ys)
+
+type S = Reader [AsPat]
+
+runS :: S a -> a
+runS m = runReader m []
+
+underBinds :: Int -> S a -> S a
+underBinds 0 = id
+underBinds n = local (map $ wk n)
+
+bindAsPattern :: AsPat -> S a -> S a
+bindAsPattern p = local (p :)
+
+lookupAsPattern :: QName -> [TTerm] -> S TTerm
+lookupAsPattern c vs
+ | Just xs <- allVars vs = do
+ ps <- ask
+ case [ x | AsPat x c' ys <- ps, c == c', xs == ys ] of
+ x : _ -> pure $ TVar x
+ _ -> pure $ mkTApp (TCon c) vs
+ | otherwise = pure $ mkTApp (TCon c) vs
+ where
+ allVars = mapM getVar
+ getVar (TVar x) = Just x
+ getVar _ = Nothing -- what about erased?
+
+-- | We lose track of @-patterns in the internal syntax. This pass puts them
+-- back.
+recoverAsPatterns :: Monad m => TTerm -> m TTerm
+recoverAsPatterns t = return $ runS (recover t)
+
+recover :: TTerm -> S TTerm
+recover t =
+ case t of
+ TApp f vs -> do
+ f <- recover f
+ vs <- mapM recover vs
+ tApp f vs
+ TLam b -> TLam <$> underBinds 1 (recover b)
+ TCon{} -> tApp t [] -- need to recover nullary constructors as well (to make deep @-patterns work)
+ TLet v b -> TLet <$> recover v <*> underBinds 1 (recover b)
+ TCase x ct d bs -> TCase x ct <$> recover d <*> mapM (recoverAlt x) bs
+ TLit{} -> pure t
+ TVar{} -> pure t
+ TPrim{} -> pure t
+ TDef{} -> pure t
+ TUnit{} -> pure t
+ TSort{} -> pure t
+ TErased{} -> pure t
+ TError{} -> pure t
+
+recoverAlt :: Int -> TAlt -> S TAlt
+recoverAlt x b =
+ case b of
+ TACon c n b -> TACon c n <$> underBinds n (bindAsPattern (AsPat (x + n) c [n - 1, n - 2..0]) $ recover b)
+ TAGuard g b -> TAGuard <$> recover g <*> recover b
+ TALit l b -> TALit l <$> recover b
+
+tApp :: TTerm -> [TTerm] -> S TTerm
+tApp (TCon c) vs = lookupAsPattern c vs
+tApp f vs = pure $ mkTApp f vs
+
diff --git a/src/full/Agda/Compiler/Treeless/Builtin.hs b/src/full/Agda/Compiler/Treeless/Builtin.hs
index cdb479c..c7eec51 100644
--- a/src/full/Agda/Compiler/Treeless/Builtin.hs
+++ b/src/full/Agda/Compiler/Treeless/Builtin.hs
@@ -15,9 +15,6 @@
--
-- Ulf, 2015-10-30: Guards are actually a better primitive. Fixed that.
{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts #-}
module Agda.Compiler.Treeless.Builtin (translateBuiltins) where
import Control.Applicative
@@ -64,7 +61,7 @@ builtinKit =
<*> isB def builtinNatEquals
<*> isP pf "primForce"
where
- con (I.Con c _) = pure $ I.conName c
+ con (I.Con c _ _) = pure $ I.conName c
con _ = Nothing
def (I.Def d _) = pure d
def _ = Nothing
@@ -93,7 +90,7 @@ transform BuiltinKit{..} = tr
TDef f | isPlus f -> TPrim PAdd
| isTimes f -> TPrim PMul
| isLess f -> TPrim PLt
- | isEqual f -> TPrim PEq
+ | isEqual f -> TPrim PEqI
-- Note: Don't do this for builtinNatMinus! PSub is integer minus and
-- builtin minus is monus. The simplifier will do it if it can see
-- that it won't underflow.
@@ -115,7 +112,7 @@ transform BuiltinKit{..} = tr
e | Just (i, e) <- plusKView e -> tNegPlusK (i + 1) e
e -> tNegPlusK 1 e
- TCase e t d bs -> TCase e t (tr d) $ concatMap trAlt bs
+ TCase e t d bs -> TCase e (caseType t bs) (tr d) $ concatMap trAlt bs
where
trAlt b = case b of
TACon c 0 b | isZero c -> [TALit (LitNat noRange 0) (tr b)]
@@ -125,8 +122,10 @@ transform BuiltinKit{..} = tr
TCase 0 _ d bs' -> map sucBranch bs' ++ [nPlusKAlt 1 d]
b -> [nPlusKAlt 1 b]
where
- sucBranch (TALit (LitNat r i) b) = TALit (LitNat r (i + 1)) $ applySubst (str __IMPOSSIBLE__) b
- sucBranch alt | Just (k, b) <- nPlusKView alt = nPlusKAlt (k + 1) $ applySubst (liftS 1 $ str __IMPOSSIBLE__) b
+ sucBranch (TALit (LitNat r i) b) = TALit (LitNat r (i + 1)) $ TLet (tInt i) b
+ sucBranch alt | Just (k, b) <- nPlusKView alt =
+ nPlusKAlt (k + 1) $ TLet (tOp PAdd (TVar 0) (tInt 1)) $
+ applySubst ([TVar 1, TVar 0] ++# wkS 2 idS) b
sucBranch _ = __IMPOSSIBLE__
nPlusKAlt k b = TAGuard (tOp PGeq (TVar e) (tInt k)) $
@@ -179,8 +178,15 @@ transform BuiltinKit{..} = tr
TLam b -> TLam (tr b)
TApp a bs -> TApp (tr a) (map tr bs)
TLet e b -> TLet (tr e) (tr b)
+
+ caseType t (TACon c _ _ : _)
+ | isZero c = CTNat
+ | isSuc c = CTNat
+ | isPos c = CTInt
+ | isNegSuc c = CTInt
+ caseType t _ = t
+
nPlusKView (TAGuard (TApp (TPrim PGeq) [TVar 0, (TLit (LitNat _ k))])
(TLet (TApp (TPrim PSub) [TVar 0, (TLit (LitNat _ j))]) b))
| k == j = Just (k, b)
nPlusKView _ = Nothing
-
diff --git a/src/full/Agda/Compiler/Treeless/Compare.hs b/src/full/Agda/Compiler/Treeless/Compare.hs
index b2336eb..cb056cf 100644
--- a/src/full/Agda/Compiler/Treeless/Compare.hs
+++ b/src/full/Agda/Compiler/Treeless/Compare.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.Treeless.Compare (equalTerms) where
import Agda.Syntax.Treeless
@@ -46,7 +45,11 @@ applyPrim PRem a b | b /= 0 = Just (rem a b)
| otherwise = Nothing
applyPrim PGeq _ _ = Nothing
applyPrim PLt _ _ = Nothing
-applyPrim PEq _ _ = Nothing
+applyPrim PEqI _ _ = Nothing
+applyPrim PEqF _ _ = Nothing
+applyPrim PEqC _ _ = Nothing
+applyPrim PEqS _ _ = Nothing
+applyPrim PEqQ _ _ = Nothing
applyPrim PIf _ _ = Nothing
applyPrim PSeq _ _ = Nothing
diff --git a/src/full/Agda/Compiler/Treeless/DelayCoinduction.hs b/src/full/Agda/Compiler/Treeless/DelayCoinduction.hs
new file mode 100644
index 0000000..6ed21e4
--- /dev/null
+++ b/src/full/Agda/Compiler/Treeless/DelayCoinduction.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE CPP #-}
+-- | Inserts an additional lambda into all coinductive auxiliary definitions (== target type Inf XX). E.g.:
+--
+-- f : A -> B -> C -> Inf A
+-- f = \a b c -> body
+-- is converted to
+-- f = \a b c _ -> body
+--
+-- Assumes that flat/sharp are implemented as follows:
+--
+-- flat = \x -> x
+-- sharp = \x -> x ()
+
+module Agda.Compiler.Treeless.DelayCoinduction where
+
+import Control.Applicative
+
+import Agda.Syntax.Internal (Type)
+import Agda.Syntax.Abstract.Name (QName)
+import Agda.Syntax.Treeless
+
+import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Monad.Builtin
+import Agda.TypeChecking.Primitive
+import Agda.TypeChecking.Reduce ( instantiateFull, normalise )
+import Agda.TypeChecking.Substitute hiding (underLambdas)
+import Agda.TypeChecking.Telescope
+
+import Agda.Compiler.Treeless.Subst
+
+import Agda.Utils.Impossible
+
+#include "undefined.h"
+
+delayCoinduction :: TTerm -> Type -> TCM TTerm
+delayCoinduction t ty = do
+ kit <- coinductionKit
+ case kit of
+ Just kit -> transform kit t ty
+ Nothing -> return t
+
+
+transform :: CoinductionKit -> TTerm -> Type -> TCM TTerm
+transform kit t ty = do
+ isInf <- outputIsInf (Just kit) ty
+ if isInf then do
+ ty <- normalise ty
+ TelV tel _ <- telView ty
+ -- insert additional lambda
+ return $ underLambdas (length $ telToList tel) (TLam . raise 1) t
+ else
+ return t
+
+
+outputIsInf :: Maybe CoinductionKit -> Type -> TCM Bool
+outputIsInf kit ty = do
+ ty <- normalise ty
+ tn <- getOutputTypeName ty
+ case tn of
+ OutputTypeName tn -> return $ Just tn == (nameOfInf <$> kit)
+ _ -> return False
+
+
+underLambdas :: Int -> (TTerm -> TTerm) -> TTerm -> TTerm
+underLambdas n cont v = loop n v where
+ loop 0 v = cont v
+ loop n v = case v of
+ TLam b -> TLam $ loop (n-1) b
+ _ -> __IMPOSSIBLE__
diff --git a/src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs b/src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs
new file mode 100644
index 0000000..9c4f4b3
--- /dev/null
+++ b/src/full/Agda/Compiler/Treeless/EliminateLiteralPatterns.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE CPP #-}
+-- | Converts case matches on literals to if cascades with equality comparisons.
+module Agda.Compiler.Treeless.EliminateLiteralPatterns where
+
+import Control.Applicative
+import Data.List
+import Data.Maybe
+
+import Agda.Syntax.Abstract.Name (QName)
+import Agda.Syntax.Treeless
+import Agda.Syntax.Literal
+import qualified Agda.Syntax.Internal as I
+
+import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Monad.Builtin
+import Agda.TypeChecking.Primitive
+import Agda.TypeChecking.Substitute
+
+import Agda.Compiler.Treeless.Subst
+
+import Agda.Utils.Impossible
+
+#include "undefined.h"
+
+eliminateLiteralPatterns :: TTerm -> TCM TTerm
+eliminateLiteralPatterns t = do
+ kit <- BuiltinKit <$> getBuiltinName builtinNat <*> getBuiltinName builtinInteger
+ return $ transform kit t
+
+data BuiltinKit = BuiltinKit
+ { nat :: Maybe QName
+ , int :: Maybe QName
+ }
+
+transform :: BuiltinKit -> TTerm -> TTerm
+transform kit = tr
+ where
+ tr :: TTerm -> TTerm
+ tr t = case t of
+ TCase sc t def alts | t `elem` [CTChar, CTString, CTQName, CTNat, CTInt, CTFloat] ->
+ foldr litAlt (tr def) alts
+ where
+ litAlt :: TAlt -> TTerm -> TTerm
+ litAlt (TALit l body) cont =
+ tIfThenElse
+ (tOp (eqFromLit l) (TLit l) (TVar sc))
+ (tr body)
+ cont
+ litAlt _ _ = __IMPOSSIBLE__
+ TCase sc t@(CTData dt) def alts -> TCase sc t (tr def) (map trAlt alts)
+ where
+ trAlt a = a { aBody = tr (aBody a) }
+ TCase _ _ _ _ -> __IMPOSSIBLE__
+
+ TVar{} -> t
+ TDef{} -> t
+ TCon{} -> t
+ TPrim{} -> t
+ TLit{} -> t
+ TUnit{} -> t
+ TSort{} -> t
+ TErased{} -> t
+ TError{} -> t
+
+ TLam b -> TLam (tr b)
+ TApp a bs -> TApp (tr a) (map tr bs)
+ TLet e b -> TLet (tr e) (tr b)
+
+ isCaseOn (CTData dt) xs = dt `elem` catMaybes (map ($ kit) xs)
+ isCaseOn _ _ = False
+
+ eqFromLit :: Literal -> TPrim
+ eqFromLit x = case x of
+ LitNat _ _ -> PEqI
+ LitFloat _ _ -> PEqF
+ LitString _ _ -> PEqS
+ LitChar _ _ -> PEqC
+ LitQName _ _ -> PEqQ
+ _ -> __IMPOSSIBLE__
diff --git a/src/full/Agda/Compiler/Treeless/Erase.hs b/src/full/Agda/Compiler/Treeless/Erase.hs
index c0e0bba..6b40b29 100644
--- a/src/full/Agda/Compiler/Treeless/Erase.hs
+++ b/src/full/Agda/Compiler/Treeless/Erase.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
-module Agda.Compiler.Treeless.Erase (eraseTerms) where
+module Agda.Compiler.Treeless.Erase (eraseTerms, computeErasedConstructorArgs) where
import Control.Arrow ((&&&), (***), first, second)
import Control.Applicative
@@ -33,6 +33,7 @@ import Agda.Utils.Monad
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.Memo
+import qualified Agda.Utils.Pretty as P
#include "undefined.h"
@@ -50,6 +51,12 @@ type E = StateT ESt TCM
runE :: E a -> TCM a
runE m = evalStateT m (ESt Map.empty Map.empty)
+-- | Takes the name of the data/record type.
+computeErasedConstructorArgs :: QName -> TCM ()
+computeErasedConstructorArgs d = do
+ cs <- getConstructors d
+ runE $ mapM_ getFunInfo cs
+
eraseTerms :: QName -> TTerm -> TCM TTerm
eraseTerms q = runE . eraseTop q
where
@@ -93,7 +100,7 @@ eraseTerms q = runE . eraseTop q
_ -> erase $ subst 0 TErased b
else tLet e <$> erase b
TCase x t d bs -> do
- d <- erase d
+ d <- ifM (isComplete t bs) (pure tUnreachable) (erase d)
bs <- mapM eraseAlt bs
tCase x t d bs
@@ -135,12 +142,32 @@ eraseTerms q = runE . eraseTop q
eraseAlt a = case a of
TALit l b -> TALit l <$> erase b
- TACon c a b -> TACon c a <$> erase b
+ TACon c a b -> do
+ rs <- map erasableR . fst <$> getFunInfo c
+ let sub = foldr (\ e -> if e then (TErased :#) . wkS 1 else liftS 1) idS $ reverse rs
+ TACon c a <$> erase (applySubst sub b)
TAGuard g b -> TAGuard <$> erase g <*> erase b
+-- | Doesn't have any type information (other than the name of the data type),
+-- so we can't do better than checking if all constructors are present.
+isComplete :: CaseType -> [TAlt] -> E Bool
+isComplete (CTData d) bs = do
+ cs <- lift $ getConstructors d
+ return $ length cs == length [ b | b@TACon{} <- bs ]
+isComplete _ _ = pure False
+
data TypeInfo = Empty | Erasable | NotErasable
deriving (Eq, Show)
+sumTypeInfo :: [TypeInfo] -> TypeInfo
+sumTypeInfo is = foldr plus Empty is
+ where
+ plus Empty r = r
+ plus r Empty = r
+ plus Erasable r = r
+ plus r Erasable = r
+ plus NotErasable NotErasable = NotErasable
+
erasableR :: Relevance -> Bool
erasableR Relevant = False
erasableR Forced{} = False -- TODO: should be True but need to transform clauses
@@ -159,13 +186,22 @@ getFunInfo :: QName -> E FunInfo
getFunInfo q = memo (funMap . key q) $ getInfo q
where
getInfo q = do
- (rs, t) <- lift $ do
- (tel, t) <- typeWithoutParams q
- return (map getRelevance tel, t)
+ (rs, t) <- do
+ (tel, t) <- lift $ typeWithoutParams q
+ is <- mapM (getTypeInfo . snd . dget) tel
+ return (zipWith (mkR . getRelevance) tel is, t)
h <- if isAbsurdLambdaName q then pure Erasable else getTypeInfo t
lift $ reportSLn "treeless.opt.erase.info" 50 $ "type info for " ++ show q ++ ": " ++ show rs ++ " -> " ++ show h
+ lift $ setErasedConArgs q $ map erasableR rs
return (rs, h)
+ -- Treat empty or erasable arguments as NonStrict (and thus erasable)
+ mkR :: Relevance -> TypeInfo -> Relevance
+ mkR Irrelevant _ = Irrelevant
+ mkR r NotErasable = r
+ mkR _ Empty = NonStrict
+ mkR _ Erasable = NonStrict
+
telListView :: Type -> TCM (ListTel, Type)
telListView t = do
TelV tel t <- telView t
@@ -181,17 +217,18 @@ typeWithoutParams q = do
first (drop d) <$> telListView (defType def)
getTypeInfo :: Type -> E TypeInfo
-getTypeInfo t = do
- (tel, t) <- lift $ telListView t
+getTypeInfo t0 = do
+ (tel, t) <- lift $ telListView t0
et <- case ignoreSharing $ I.unEl t of
I.Def d _ -> typeInfo d
Sort{} -> return Erasable
_ -> return NotErasable
is <- mapM (getTypeInfo . snd . dget) tel
- let e | et == Empty = Empty
- | any (== Empty) is = Erasable
+ let e | any (== Empty) is = Erasable
+ | null is = et -- TODO: guard should really be "all inhabited is"
+ | et == Empty = Erasable
| otherwise = et
- lift $ reportSDoc "treeless.opt.erase.type" 50 $ prettyTCM t <+> text ("is " ++ show e)
+ lift $ reportSDoc "treeless.opt.erase.type" 50 $ prettyTCM t0 <+> text ("is " ++ show e)
return e
where
typeInfo :: QName -> E TypeInfo
@@ -208,6 +245,11 @@ getTypeInfo t = do
is <- mapM (getTypeInfo . snd . dget) ts
let er = and [ erasable i || erasableR r | (i, r) <- zip is rs ]
return $ if er then Erasable else NotErasable
- Just [] -> return Empty
- _ -> return NotErasable
+ Just [] -> return Empty
+ Just (_:_:_) -> return NotErasable
+ Nothing ->
+ case I.theDef def of
+ I.Function{ funClauses = cs } ->
+ sumTypeInfo <$> mapM (maybe (return Empty) (getTypeInfo . El Prop) . clauseBody) cs
+ _ -> return NotErasable
diff --git a/src/full/Agda/Compiler/Treeless/GuardsToPrims.hs b/src/full/Agda/Compiler/Treeless/GuardsToPrims.hs
index 06adcf5..54ed27f 100644
--- a/src/full/Agda/Compiler/Treeless/GuardsToPrims.hs
+++ b/src/full/Agda/Compiler/Treeless/GuardsToPrims.hs
@@ -25,13 +25,17 @@ convertGuards :: TTerm -> TTerm
convertGuards = tr
where
tr t = case t of
- TCase sc t def alts -> TCase sc t def' (fmap trAlt otherAlts)
+ TCase sc t def alts ->
+ if null otherAlts
+ then
+ def'
+ else
+ TCase sc t def' (fmap trAlt otherAlts)
where
(plusAlts, otherAlts) = splitAlts alts
guardedAlt :: TAlt -> TTerm -> TTerm
- guardedAlt (TAGuard g body) cont =
- TApp (TPrim PIf) [tr g, tr body, cont]
+ guardedAlt (TAGuard g body) cont = tIfThenElse (tr g) (tr body) (tr cont)
guardedAlt _ _ = __IMPOSSIBLE__
def' = foldr guardedAlt (tr def) plusAlts
diff --git a/src/full/Agda/Compiler/Treeless/Identity.hs b/src/full/Agda/Compiler/Treeless/Identity.hs
new file mode 100644
index 0000000..4ec88e8
--- /dev/null
+++ b/src/full/Agda/Compiler/Treeless/Identity.hs
@@ -0,0 +1,102 @@
+
+module Agda.Compiler.Treeless.Identity
+ ( detectIdentityFunctions ) where
+
+import Control.Applicative
+import Data.Foldable (foldMap)
+import Data.Semigroup
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.List
+
+import Agda.Syntax.Treeless
+import Agda.TypeChecking.Substitute
+import Agda.TypeChecking.Monad
+import Agda.Utils.Lens
+
+detectIdentityFunctions :: QName -> TTerm -> TCM TTerm
+detectIdentityFunctions q t =
+ case isIdentity q t of
+ Nothing -> return t
+ Just (n, k) -> do
+ markInline q
+ def <- theDef <$> getConstInfo q
+ return $ mkTLam n $ TVar k
+
+-- If isIdentity f t = Just (n, k) then
+-- f = t is equivalent to f = λ xₙ₋₁ .. x₀ → xk
+isIdentity :: QName -> TTerm -> Maybe (Int, Int)
+isIdentity q t =
+ trivialIdentity q t <|> recursiveIdentity q t
+
+-- Does the function recurse on an argument, rebuilding the same value again.
+recursiveIdentity :: QName -> TTerm -> Maybe (Int, Int)
+recursiveIdentity q t =
+ case b of
+ TCase x _ (TError TUnreachable) bs
+ | all (identityBranch x) bs -> pure (n, x)
+ _ -> empty -- TODO: lets?
+ where
+ (n, b) = tLamView t
+
+ identityBranch _ TALit{} = False
+ identityBranch _ TAGuard{} = False
+ identityBranch x (TACon c a b) =
+ case b of
+ TApp (TCon c') args -> c == c' && identityArgs a args
+ TVar y -> y == x + a -- from @-pattern recovery
+ _ -> False -- TODO: nested cases
+ where
+ identityArgs a args =
+ length args == a && and (zipWith match (reverse args) [0..])
+
+ proj x args = reverse args !! x
+
+ match TErased _ = True
+ match (TVar z) y = z == y
+ match (TApp (TDef f) args) y = f == q && length args == n && match (proj x args) y
+ match _ _ = False
+
+data IdentityIn = IdIn [Int]
+
+notId :: IdentityIn
+notId = IdIn []
+
+instance Semigroup IdentityIn where
+ IdIn xs <> IdIn ys = IdIn $ intersect xs ys
+
+-- Does the function always return one of its arguments unchanged (possibly
+-- through recursive calls).
+trivialIdentity :: QName -> TTerm -> Maybe (Int, Int)
+trivialIdentity q t =
+ case go 0 b of
+ IdIn [x] -> pure (n, x)
+ IdIn [] -> Nothing
+ IdIn (_:_:_) -> Nothing -- only happens for empty functions (which will never be called)
+ where
+ (n, b) = tLamView t
+
+ go :: Int -> TTerm -> IdentityIn
+ go k t =
+ case t of
+ TVar x | x >= k -> IdIn [x - k]
+ | otherwise -> notId
+ TLet _ b -> go (k + 1) b
+ TCase _ _ d bs -> sconcat (go k d :| map (goAlt k) bs)
+ TApp (TDef f) args
+ | f == q -> IdIn [ y | (TVar x, y) <- zip (reverse args) [0..], y + k == x ]
+ TApp{} -> notId
+ TLam{} -> notId
+ TLit{} -> notId
+ TDef{} -> notId
+ TCon{} -> notId
+ TPrim{} -> notId
+ TUnit{} -> notId
+ TSort{} -> notId
+ TErased{} -> notId
+ TError{} -> notId
+
+ goAlt :: Int -> TAlt -> IdentityIn
+ goAlt k (TALit _ b) = go k b
+ goAlt k (TAGuard _ b) = go k b
+ goAlt k (TACon _ n b) = go (k + n) b
+
diff --git a/src/full/Agda/Compiler/Treeless/Pretty.hs b/src/full/Agda/Compiler/Treeless/Pretty.hs
index 0ef54f0..c716f53 100644
--- a/src/full/Agda/Compiler/Treeless/Pretty.hs
+++ b/src/full/Agda/Compiler/Treeless/Pretty.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -60,7 +58,11 @@ opName PQuot = "quot"
opName PRem = "rem"
opName PGeq = ">="
opName PLt = "<"
-opName PEq = "=="
+opName PEqI = "==I"
+opName PEqF = "==F"
+opName PEqS = "==S"
+opName PEqC = "==C"
+opName PEqQ = "==Q"
opName PIf = "if_then_else_"
opName PSeq = "seq"
@@ -72,7 +74,7 @@ isInfix op =
PSub -> l 6
PGeq -> non 4
PLt -> non 4
- PEq -> non 4
+ p | isPrimEq p -> non 4
_ -> Nothing
where
l n = Just (n, n, n + 1)
@@ -128,9 +130,9 @@ pTerm t = case t of
first ((x, e) :) <$> bindName x (pLets bs b)
TCase x _ def alts -> paren 0 $
- (\ sc alts def ->
+ (\ sc alts defd ->
sep [ text "case" <+> sc <+> text "of"
- , nest 2 $ vcat (alts ++ [ text "_ →" <+> def ]) ]
+ , nest 2 $ vcat (alts ++ [ text "_ →" <+> defd | null alts || def /= TError TUnreachable ]) ]
) <$> pTerm' 0 (TVar x)
<*> mapM pAlt alts
<*> pTerm' 0 def
diff --git a/src/full/Agda/Compiler/Treeless/Simplify.hs b/src/full/Agda/Compiler/Treeless/Simplify.hs
index 6ead31f..be09bb3 100644
--- a/src/full/Agda/Compiler/Treeless/Simplify.hs
+++ b/src/full/Agda/Compiler/Treeless/Simplify.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.Treeless.Simplify (simplifyTTerm) where
import Control.Arrow (first, second, (***))
@@ -79,7 +77,7 @@ simplifyTTerm t = do
simplify :: FunctionKit -> TTerm -> S TTerm
simplify FunctionKit{..} = simpl
where
- simpl t = rewrite' t >>= \ t -> case t of
+ simpl = rewrite' >=> unchainCase >=> \ t -> case t of
TDef{} -> pure t
TPrim{} -> pure t
@@ -108,9 +106,10 @@ simplify FunctionKit{..} = simpl
TCase x t d bs -> do
v <- lookupVar x
- let (lets, u) = letView v
+ let (lets, u) = tLetView v
case u of -- TODO: also for literals
- _ | Just (c, as) <- conView u -> simpl $ matchCon lets c as d bs
+ _ | Just (c, as) <- conView u -> simpl $ matchCon lets c as d bs
+ | Just (k, TVar y) <- plusKView u -> simpl . mkLets lets . TCase y t d =<< mapM (matchPlusK y x k) bs
TCase y t1 d1 bs1 -> simpl $ mkLets lets $ TCase y t1 (distrDef case1 d1) $
map (distrCase case1) bs1
where
@@ -142,8 +141,18 @@ simplify FunctionKit{..} = simpl
conView (TApp (TCon c) as) = Just (c, as)
conView e = Nothing
- letView (TLet e b) = first (e :) $ letView b
- letView e = ([], e)
+ -- Collapse chained cases (case x of bs -> vs; _ -> case x of bs' -> vs' ==>
+ -- case x of bs -> vs; bs' -> vs')
+ unchainCase :: TTerm -> S TTerm
+ unchainCase e@(TCase x t d bs) = do
+ let (lets, u) = tLetView d
+ k = length lets
+ return $ case u of
+ TCase y _ d' bs' | x + k == y ->
+ mkLets lets $ TCase y t d' $ raise k bs ++ bs'
+ _ -> e
+ unchainCase e = return e
+
mkLets es b = foldr TLet b es
@@ -157,6 +166,14 @@ simplify FunctionKit{..} = simpl
mkLet _ [] b = b
mkLet i (a : as) b = TLet (raise i a) $ mkLet (i + 1) as b
+ -- Simplify let y = x + k in case y of j -> u; _ | g[y] -> v
+ -- to let y = x + k in case x of j - k -> u; _ | g[x + k] -> v
+ matchPlusK :: Int -> Int -> Integer -> TAlt -> S TAlt
+ matchPlusK x y k (TALit (LitNat r j) b) = return $ TALit (LitNat r (j - k)) b
+ matchPlusK x y k (TAGuard g b) = flip TAGuard b <$> simpl (applySubst (inplaceS y (tPlusK k (TVar x))) g)
+ matchPlusK x y k TACon{} = __IMPOSSIBLE__
+ matchPlusK x y k TALit{} = __IMPOSSIBLE__
+
simplPrim (TApp f@TPrim{} args) = do
args <- mapM simpl args
inlined <- mapM inline args
@@ -178,11 +195,15 @@ simplify FunctionKit{..} = simpl
| Just (PAdd, k, u) <- constArithView u,
Just (PAdd, j, v) <- constArithView v,
k == j = tOp PLt u v
- simplPrim' (TApp (TPrim PEq) [u, v])
+ simplPrim' (TApp (TPrim op) [u, v])
+ | elem op [PGeq, PLt, PEqI]
+ , Just (PAdd, k, u) <- constArithView u
+ , Just j <- intView v = TApp (TPrim op) [u, tInt (j - k)]
+ simplPrim' (TApp (TPrim PEqI) [u, v])
| Just (op1, k, u) <- constArithView u,
Just (op2, j, v) <- constArithView v,
op1 == op2, k == j,
- elem op1 [PAdd, PSub] = tOp PEq u v
+ elem op1 [PAdd, PSub] = tOp PEqI u v
simplPrim' (TApp (TPrim PMul) [u, v])
| Just 0 <- intView u = tInt 0
| Just 0 <- intView v = tInt 0
@@ -254,22 +275,54 @@ simplify FunctionKit{..} = simpl
maybeMinusToPrim f es = tApp f es
tLet (TVar x) b = subst 0 (TVar x) b
+ tLet e (TVar 0) = e
tLet e b = TLet e b
tCase :: Int -> CaseType -> TTerm -> [TAlt] -> S TTerm
+ tCase x t d [] = pure d
tCase x t d bs
| isUnreachable d =
case reverse bs' of
[] -> pure d
- TALit _ b : as -> pure $ tCase' x t b (reverse as)
- TAGuard _ b : as -> pure $ tCase' x t b (reverse as)
- TACon c a b : _ -> pure $ tCase' x t d bs'
- | otherwise = pure $ TCase x t d bs'
+ TALit _ b : as -> tCase x t b (reverse as)
+ TAGuard _ b : as -> tCase x t b (reverse as)
+ TACon c a b : _ -> tCase' x t d bs'
+ | otherwise = do
+ d' <- lookupIfVar d
+ case d' of
+ TCase y _ d bs'' | x == y ->
+ tCase x t d (bs' ++ filter noOverlap bs'')
+ _ -> tCase' x t d bs'
where
bs' = filter (not . isUnreachable) bs
- tCase' x t d [] = d
- tCase' x t d bs = TCase x t d bs
+ lookupIfVar (TVar i) = lookupVar i
+ lookupIfVar t = pure t
+
+ noOverlap b = not $ any (overlapped b) bs'
+ overlapped (TACon c _ _) (TACon c' _ _) = c == c'
+ overlapped (TALit l _) (TALit l' _) = l == l'
+ overlapped _ _ = False
+
+ -- | Drop unreachable cases for Nat and Int cases.
+ pruneLitCases :: Int -> CaseType -> TTerm -> [TAlt] -> S TTerm
+ pruneLitCases x CTNat d bs =
+ case complete bs [] Nothing of
+ Just bs' -> tCase x CTNat tUnreachable bs'
+ Nothing -> return $ TCase x CTNat d bs
+ where
+ complete bs small (Just upper)
+ | null $ [0..upper - 1] \\ small = Just []
+ complete (b@(TALit (LitNat _ n) _) : bs) small upper =
+ (b :) <$> complete bs (n : small) upper
+ complete (b@(TAGuard (TApp (TPrim PGeq) [TVar y, TLit (LitNat _ j)]) _) : bs) small upper | x == y =
+ (b :) <$> complete bs small (Just $ maybe j (min j) upper)
+ complete _ _ _ = Nothing
+ pruneLitCases x CTInt d bs = return $ TCase x CTInt d bs -- TODO
+ pruneLitCases x t d bs = return $ TCase x t d bs
+
+ tCase' x t d [] = return d
+ tCase' x t d bs = pruneLitCases x t d bs
tApp :: TTerm -> [TTerm] -> S TTerm
tApp (TLet e b) es = TLet e <$> underLet e (tApp b (raise 1 es))
diff --git a/src/full/Agda/Compiler/Treeless/Subst.hs b/src/full/Agda/Compiler/Treeless/Subst.hs
index 56068a4..8d823df 100644
--- a/src/full/Agda/Compiler/Treeless/Subst.hs
+++ b/src/full/Agda/Compiler/Treeless/Subst.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -7,7 +6,7 @@ module Agda.Compiler.Treeless.Subst where
import Control.Applicative
import qualified Data.Map as Map
import Data.Map (Map)
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, All(..), Any(..))
import Data.Maybe
import Agda.Syntax.Treeless
@@ -15,9 +14,9 @@ import Agda.Syntax.Internal (Substitution'(..))
import Agda.TypeChecking.Substitute
instance DeBruijn TTerm where
- debruijnVar = TVar
- debruijnView (TVar i) = Just i
- debruijnView _ = Nothing
+ deBruijnVar = TVar
+ deBruijnView (TVar i) = Just i
+ deBruijnView _ = Nothing
instance Subst TTerm TTerm where
applySubst IdS t = t
@@ -49,10 +48,10 @@ instance Subst TTerm TAlt where
applySubst rho (TAGuard g b) = TAGuard (applySubst rho g) (applySubst rho b)
newtype UnderLambda = UnderLambda Any
- deriving (Eq, Ord, Show, Monoid)
+ deriving (Eq, Ord, Show, Semigroup, Monoid)
newtype SeqArg = SeqArg All
- deriving (Eq, Ord, Show, Monoid)
+ deriving (Eq, Ord, Show, Semigroup, Monoid)
data Occurs = Occurs Int UnderLambda SeqArg
deriving (Eq, Ord, Show)
@@ -66,9 +65,12 @@ inSeq (Occurs n l _) = Occurs n l mempty
underLambda :: Occurs -> Occurs
underLambda o = o <> Occurs 0 (UnderLambda $ Any True) mempty
+instance Semigroup Occurs where
+ Occurs a k s <> Occurs b l t = Occurs (a + b) (k <> l) (s <> t)
+
instance Monoid Occurs where
mempty = Occurs 0 mempty mempty
- mappend (Occurs a k s) (Occurs b l t) = Occurs (a + b) (k <> l) (s <> t)
+ mappend = (<>)
class HasFree a where
freeVars :: a -> Map Int Occurs
@@ -121,4 +123,3 @@ instance HasFree TAlt where
TACon _ i b -> freeVars (Binder i b)
TALit _ b -> freeVars b
TAGuard g b -> freeVars (g, b)
-
diff --git a/src/full/Agda/Compiler/Treeless/Uncase.hs b/src/full/Agda/Compiler/Treeless/Uncase.hs
index 2f13674..68aa509 100644
--- a/src/full/Agda/Compiler/Treeless/Uncase.hs
+++ b/src/full/Agda/Compiler/Treeless/Uncase.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.Compiler.Treeless.Uncase (caseToSeq) where
import Control.Applicative
@@ -65,5 +64,5 @@ uncase t = case t of
-- Primitive operations are already strict
tApp (TPrim PSeq) [_, b@(TApp (TPrim op) _)]
- | op `elem` [PAdd, PSub, PMul, PLt, PEq, PGeq, PRem, PQuot] = b
+ | op `elem` [PAdd, PSub, PMul, PLt, PGeq, PRem, PQuot] || isPrimEq op = b
tApp f es = TApp f es
diff --git a/src/full/Agda/Compiler/Treeless/Unused.hs b/src/full/Agda/Compiler/Treeless/Unused.hs
index d338bbb..04145de 100644
--- a/src/full/Agda/Compiler/Treeless/Unused.hs
+++ b/src/full/Agda/Compiler/Treeless/Unused.hs
@@ -18,7 +18,7 @@ import Agda.Compiler.Treeless.Pretty
usedArguments :: QName -> TTerm -> TCM [Bool]
usedArguments q t = computeUnused q b (replicate n False)
- where (n, b) = lamView t
+ where (n, b) = tLamView t
computeUnused :: QName -> TTerm -> [Bool] -> TCM [Bool]
computeUnused q t used = do
@@ -59,9 +59,9 @@ computeUnused q t used = do
underBinders n = Set.filter (>= 0) . Set.mapMonotonic (subtract n)
stripUnusedArguments :: [Bool] -> TTerm -> TTerm
-stripUnusedArguments used t = unlamView m $ applySubst rho b
+stripUnusedArguments used t = mkTLam m $ applySubst rho b
where
- (n, b) = lamView t
+ (n, b) = tLamView t
m = length $ filter id used'
used' = reverse $ take n $ used ++ repeat True
rho = computeSubst used'
@@ -69,10 +69,3 @@ stripUnusedArguments used t = unlamView m $ applySubst rho b
computeSubst (True : bs) = liftS 1 $ computeSubst bs
computeSubst [] = idS
-lamView :: TTerm -> (Int, TTerm)
-lamView (TLam b) = first succ $ lamView b
-lamView t = (0, t)
-
-unlamView :: Int -> TTerm -> TTerm
-unlamView 0 t = t
-unlamView n t = TLam $ unlamView (n - 1) t
diff --git a/src/full/Agda/Compiler/UHC/Bridge.hs b/src/full/Agda/Compiler/UHC/Bridge.hs
index 6405db8..5859274 100644
--- a/src/full/Agda/Compiler/UHC/Bridge.hs
+++ b/src/full/Agda/Compiler/UHC/Bridge.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Exports the UHC API, and provides dummy
diff --git a/src/full/Agda/Compiler/UHC/CompileState.hs b/src/full/Agda/Compiler/UHC/CompileState.hs
index 2b46dcc..96651bc 100644
--- a/src/full/Agda/Compiler/UHC/CompileState.hs
+++ b/src/full/Agda/Compiler/UHC/CompileState.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Contains the state monad that the compiler works in and some functions
@@ -40,8 +38,8 @@ import Data.Char
#if __GLASGOW_HASKELL__ <= 708
import Control.Applicative
-import Data.Monoid
#endif
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend)
import Agda.Compiler.UHC.MagicTypes
import Agda.Syntax.Internal
@@ -71,10 +69,13 @@ data CoreMeta = CoreMeta
, coreExports :: [CExport] -- ^ UHC core exports
}
+instance Semigroup CoreMeta where
+ CoreMeta a b c <> CoreMeta r s t =
+ CoreMeta (Map.union a r) (Map.unionWith (++) b s) (c ++ t)
+
instance Monoid CoreMeta where
mempty = CoreMeta mempty mempty []
- mappend (CoreMeta a b c) (CoreMeta r s t) =
- CoreMeta (Map.union a r) (Map.unionWith (++) b s) (c ++ t)
+ mappend = (<>)
-- | Stuff we need in our compiler
data CompileState = CompileState
diff --git a/src/full/Agda/Compiler/UHC/Compiler.hs b/src/full/Agda/Compiler/UHC/Compiler.hs
index 2ad8c34..1a480db 100644
--- a/src/full/Agda/Compiler/UHC/Compiler.hs
+++ b/src/full/Agda/Compiler/UHC/Compiler.hs
@@ -1,12 +1,15 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-- | UHC compiler backend, main entry point.
--- In the long term, it would be nice if we could use e.g. shake to build individual Agda modules. The problem with that is that
--- some parts need to be in the TCM Monad, which doesn't easily work in shake. We would need a way to extract the information
--- out of the TCM monad, so that we can pass it to the compilation function without pulling in the TCM Monad. Another minor
--- problem might be error reporting?
+-- In the long term, it would be nice if we could use e.g. shake to
+-- build individual Agda modules. The problem with that is that some
+-- parts need to be in the TCM Monad, which doesn't easily work in
+-- shake. We would need a way to extract the information out of the
+-- TCM monad, so that we can pass it to the compilation function
+-- without pulling in the TCM Monad. Another minor problem might be
+-- error reporting?
+
module Agda.Compiler.UHC.Compiler(compilerMain) where
#if __GLASGOW_HASKELL__ <= 708
@@ -118,7 +121,7 @@ compileModule i = do
then imports
else agdaPrimInter : imports
- reportSLn "" 1 $
+ reportSLn "compile.uhc" 1 $
"Compiling: " ++ show (iModuleName i)
code <- compileDefns modNm (map iModuleName imports') i
crFile <- corePath modNm
@@ -155,7 +158,7 @@ compileDefns modNm curModImps iface = do
crMod <- FAgda.fromAgdaModule modNm curModImps iface
- reportSLn "uhc" 10 $ "Done generating Core for \"" ++ show modNm ++ "\"."
+ reportSLn "compile.uhc" 10 $ "Done generating Core for \"" ++ show modNm ++ "\"."
return crMod
writeCoreFile :: String -> UB.CModule -> TCM ()
@@ -165,11 +168,11 @@ writeCoreFile f cmod = do
-- dump textual core, useful for debugging.
when useTextual (do
let f' = replaceExtension f ".dbg.tcr"
- reportSLn "uhc" 10 $ "Writing textual core to \"" ++ show f' ++ "\"."
+ reportSLn "compile.uhc" 10 $ "Writing textual core to \"" ++ show f' ++ "\"."
liftIO $ putPPFile f' (UB.printModule defaultEHCOpts cmod) 200
)
- reportSLn "uhc" 10 $ "Writing binary core to \"" ++ show f ++ "\"."
+ reportSLn "compile.uhc" 10 $ "Writing binary core to \"" ++ show f ++ "\"."
liftIO $ putSerializeFile f cmod
-- | Create the UHC Core main file, which calls the Agda main function
@@ -194,8 +197,12 @@ runUHCMain mainInfo = do
liftIO . setCurrentDirectory =<< compileDir
- -- TODO drop the RTS args as soon as we don't need the additional memory anymore
- callUHC1 $ ["--pkg-hide-all", "--pkg-expose=uhcbase", "--pkg-expose=base"
+ -- TODO drop the RTS args as soon as we don't need the additional
+ -- memory anymore
+ callUHC1 $ [ "--pkg-hide-all"
+ , "--pkg-expose=uhcbase"
+ , "--pkg-expose=base"
+ , "UHC/Agda/double.c"
] ++ extraOpts ++ allFps ++ ["+RTS", "-K50m", "-RTS"]
callUHC1 :: [String] -> TCM ()
diff --git a/src/full/Agda/Compiler/UHC/FromAgda.hs b/src/full/Agda/Compiler/UHC/FromAgda.hs
index 2ec81aa..f1130f8 100644
--- a/src/full/Agda/Compiler/UHC/FromAgda.hs
+++ b/src/full/Agda/Compiler/UHC/FromAgda.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE PatternGuards #-}
-- | Convert from Agda's internal representation to UHC Core via Treeless.
--
@@ -77,7 +75,7 @@ fromAgdaModule modNm curModImps iface = do
let defs = sortDefs $ iSignature iface ^. sigDefinitions
runCompileT modNm (do
- lift $ reportSLn "uhc" 10 "Translate datatypes..."
+ lift $ reportSLn "compile.uhc" 10 "Translate datatypes..."
funs' <- concat <$> mapM translateDefn defs
let funs = mkLetRec funs' (mkInt opts 0)
@@ -119,14 +117,14 @@ translateDefn (n, defini) = do
(\x -> [x]) <$> mkIdentityFun n "coind-flat" 0
f@(Function{}) | otherwise -> do
let ty = (defType defini)
- lift $ reportSDoc "uhc.fromagda" 5 $ text "compiling fun:" <+> prettyTCM n
- lift $ reportSDoc "uhc.fromagda" 15 $ text "type:" <+> (text . show) ty
+ lift $ reportSDoc "compile.uhc.fromagda" 5 $ text "compiling fun:" <+> prettyTCM n
+ lift $ reportSDoc "compile.uhc.fromagda" 15 $ text "type:" <+> (text . show) ty
caseMaybeM (lift $ toTreeless n) (pure []) $ \ treeless -> do
funBody <- convertGuards <$> lift (normalizeNames treeless)
- lift $ reportSDoc "uhc.fromagda" 30 $ text " compiled treeless fun:" <+> (text . show) funBody
+ lift $ reportSDoc "compile.uhc.fromagda" 30 $ text " compiled treeless fun:" <+> (text . show) funBody
funBody' <- runTT $ compileTerm funBody
- lift $ reportSDoc "uhc.fromagda" 30 $ text " compiled UHC Core fun:" <+> (text . show) funBody'
+ lift $ reportSDoc "compile.uhc.fromagda" 30 $ text " compiled UHC Core fun:" <+> (text . show) funBody'
addExports [crName]
return [mkBind1 crName funBody']
@@ -181,6 +179,7 @@ translateDefn (n, defini) = do
(Just expr) -> do
expr' <- expr
return [mkBind1 crName expr']
+ AbstractDefn -> __IMPOSSIBLE__
where
-- | Produces an identity function, optionally ignoring the first n arguments.
mkIdentityFun :: QName
@@ -279,8 +278,9 @@ compileTerm term = do
C.CTChar -> mkVar $ primFunNm "primCharEquality"
C.CTString -> mkVar $ primFunNm "primStringEquality"
C.CTQName -> mkVar $ primFunNm "primQNameEquality"
- C.CTData nm | isNat builtinKit' nm -> mkVar $ primFunNm "primIntegerEquality"
- C.CTData nm | isInt builtinKit' nm -> mkVar $ primFunNm "primIntegerEquality"
+ C.CTFloat -> mkVar $ primFunNm "primFloatEquality"
+ C.CTNat -> mkVar $ primFunNm "primIntegerEquality"
+ C.CTInt -> mkVar $ primFunNm "primIntegerEquality"
_ -> __IMPOSSIBLE__
C.TUnit -> unit
@@ -344,7 +344,8 @@ litToCore (LitChar _ c) = mkChar c
-- we have the same semantics as MAlonzo.
litToCore (LitFloat _ f) = mkApp (mkVar $ primFunNm "primMkFloat") [mkString opts (show f)]
litToCore (LitQName _ q) = mkApp (mkVar $ primFunNm "primMkQName")
- [mkInteger opts n, mkInteger opts m, mkString opts $ P.prettyShow q]
+ [mkInteger opts $ fromIntegral n, mkInteger opts $ fromIntegral m,
+ mkString opts $ P.prettyShow q]
where NameId n m = nameId $ qnameName q
litToCore LitMeta{} = __IMPOSSIBLE__
@@ -365,8 +366,9 @@ compilePrim C.PMul = mkVar $ primFunNm "primIntegerTimes"
compilePrim C.PIf = mkVar $ primFunNm "primIfThenElse"
compilePrim C.PGeq = mkVar $ primFunNm "primIntegerGreaterOrEqual"
compilePrim C.PLt = mkVar $ primFunNm "primIntegerLess"
-compilePrim C.PEq = mkVar $ primFunNm "primIntegerEquality"
+compilePrim p | C.isPrimEq p = mkVar $ primFunNm "primIntegerEquality"
compilePrim C.PSeq = mkVar $ primFunNm "primSeq"
+compilePrim _ = __IMPOSSIBLE__
createMainModule :: ModuleName -> HsName -> CModule
diff --git a/src/full/Agda/Compiler/UHC/Primitives.hs b/src/full/Agda/Compiler/UHC/Primitives.hs
index c2aff71..78ca53d 100644
--- a/src/full/Agda/Compiler/UHC/Primitives.hs
+++ b/src/full/Agda/Compiler/UHC/Primitives.hs
@@ -74,11 +74,13 @@ primFunctions = M.fromList $
-- Float
, "primShowFloat"
, "primFloatEquality"
- , "primFloatLess"
+ , "primFloatNumericalEquality"
+ , "primFloatNumericalLess"
, "primNatToFloat"
, "primFloatPlus"
, "primFloatMinus"
, "primFloatTimes"
+ , "primFloatNegate"
, "primFloatDiv"
, "primFloatSqrt"
, "primRound"
@@ -87,10 +89,18 @@ primFunctions = M.fromList $
, "primExp"
, "primLog"
, "primSin"
+ , "primCos"
+ , "primTan"
+ , "primASin"
+ , "primACos"
+ , "primATan"
+ , "primATan"
+ , "primATan2"
-- Reflection
, "primQNameEquality"
, "primQNameLess"
, "primShowQName"
+ , "primQNameFixity"
, "primMetaEquality"
, "primMetaLess"
, "primShowMeta"
@@ -102,7 +112,7 @@ primFunctions = M.fromList $
-- lookup refl constructor
bt <- fromMaybe __IMPOSSIBLE__ <$> (lift $ getBuiltin' builtinRefl)
let reflNm = case T.ignoreSharing bt of
- (T.Con conHd []) -> T.conName conHd
+ (T.Con conHd _ []) -> T.conName conHd
_ -> __IMPOSSIBLE__
mkVar <$> getConstrFun reflNm
diff --git a/src/full/Agda/Compiler/UHC/Smashing.hs b/src/full/Agda/Compiler/UHC/Smashing.hs
deleted file mode 100644
index 2763e15..0000000
--- a/src/full/Agda/Compiler/UHC/Smashing.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-
-
-{-# LANGUAGE CPP #-}
-
--- DISABLED - NOT USED ANYMORE
-
--- | Smash functions which return something that can be inferred
--- (something of a type with only one element)
-
-module Agda.Compiler.UHC.Smashing where
-
-import Control.Monad.State
-import Control.Monad.Trans.Maybe
-
-import Data.List
-import Data.Maybe
-
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-import Agda.Syntax.Common
-import Agda.Syntax.Internal as SI
-import Agda.TypeChecking.Monad
-import Agda.TypeChecking.Substitute
-import Agda.TypeChecking.Telescope
-import Agda.TypeChecking.Pretty
-import Agda.TypeChecking.Reduce
-
---import Agda.Compiler.UHC.AuxAST as AA
---import Agda.Compiler.UHC.Transform
---import Agda.Compiler.UHC.Naming
-
-import Agda.Utils.Lens
-
-#if __GLASGOW_HASKELL__ <= 708
-import Agda.Utils.Monad
-#endif
-
-import Agda.Utils.Size
-import qualified Agda.Utils.HashMap as HM
-
-#include "undefined.h"
-import Agda.Utils.Impossible
-
-{-
-type SmashT m = FreshNameT (TransformT m)
-
-defnPars :: Integral n => Defn -> n
-defnPars (Record {recPars = p}) = fromIntegral p
-defnPars (Constructor {conPars = p}) = fromIntegral p
-defnPars _ = 0
-
-smash'em :: Transform
-smash'em amod = do
- fs' <- smashFuns (xmodFunDefs amod)
- return $ (amod { xmodFunDefs = fs' })
-
--- | Main function, smash as much as possible
-smashFuns :: [Fun] -> TransformT TCM [Fun]
-smashFuns funs = do
- defs <- (sigDefinitions <$> use stImports)
- funs' <- evalFreshNameT "nl.uu.agda.smashing" $ forM funs $ \f -> case f of
- AA.Fun{} -> case xfunQName f >>= flip HM.lookup defs of
-
- Just (def@(Defn {theDef = (Function { funSmashable = True })})) -> do
- reportSLn "uhc.smashing" 10 $ "running on:" ++ (show (xfunQName f))
- minfered <- runMaybeT $ smashable (length (xfunArgs f) + defnPars (theDef def)) (defType def)
- case minfered of
- Just infered -> do
- reportSDoc "smashing" 5 $ vcat
- [ prettyTCM (defName def) <+> text "is smashable"]
- return f { xfunExpr = infered
- , xfunInline = True
- , xfunComment = xfunComment f ++ " [SMASHED]"
- }
- Nothing -> return f
- _ -> do
- reportSDoc "uhc.smashing" 10 $ vcat
- [ (text . show) f <+> text " was not found or is not eligible for smashing."]
- return f
- _ -> do
- reportSLn "uhc.smashing" 10 $ "smashing!"
- return f
- return funs'
-
-fail' :: Monad m => MaybeT m a
-fail' = fail ""
-
-(+++) :: Telescope -> Telescope -> Telescope
-xs +++ ys = unflattenTel names $ map (raise (size ys)) (flattenTel xs) ++ flattenTel ys
- where names = teleNames xs ++ teleNames ys
-
--- | Can a datatype be inferred? If so, return the only possible value.
-inferable :: Set QName -> QName -> [SI.Arg Term] -> MaybeT (SmashT TCM) Expr
-inferable visited dat _ | dat `Set.member` visited = fail'
-inferable visited dat args = do
- reportSLn "uhc.smashing" 10 $ " inferring:" ++ (show dat)
- defs <- sigDefinitions <$> use stImports
- let def = fromMaybe __IMPOSSIBLE__ $ HM.lookup dat defs
- case theDef def of
- d@Datatype{} -> do
- case dataCons d of
- [c] -> inferableArgs c (dataPars d)
- _ -> fail'
- r@Record{} -> inferableArgs (recCon r) (recPars r)
- (Function{ funSmashable = True }) -> do
- term <- liftTCM $ normalise $ Def dat $ map SI.Apply args
- inferableTerm visited' term
- d -> do
- reportSLn "uhc.smashing" 10 $ " failed (inferable): " ++ (show d)
- fail'
- where
- inferableArgs :: QName -> Nat -> MaybeT (SmashT TCM) Expr
- inferableArgs c pars = do
- reportSLn "uhc.smashing" 10 $ " inferring args for: " ++ show c
- defs <- sigDefinitions <$> use stImports
- let def = fromMaybe __IMPOSSIBLE__ $ HM.lookup c defs
- TelV tel _ <- liftTCM $ telView (defType def `apply` genericTake pars args)
- reportSDoc "uhc.smashing" 10 $ nest 2 $ vcat
- [ text "inferableArgs!"
- , text "tele" <+> prettyTCM tel
- , text "constr:" <+> prettyTCM c
- ]
- conFun <- lift $ lift $ getConstrFun c
- (apps1 conFun <$>) $ forM (flattenTel tel) (inferableTerm visited' . unEl . unDom)
- visited' = Set.insert dat visited
-
-inferableTerm :: Set QName -> Term -> MaybeT (SmashT TCM) Expr
-inferableTerm visited t = do
- case ignoreSharing t of
- Def q es ->
- case allApplyElims es of
- Just vs -> inferable visited q vs
- Nothing -> fail'
- Pi _ b -> do
- t' <- inferableTerm visited (unEl $ unAbs b)
- lift $ buildLambda 1 t'
- Sort {} -> return AA.UNIT
- t' -> do
- reportSLn "uhc.smashing" 10 $ " failed to infer: " ++ show t'
- fail'
-
--- | Find the only possible value for a certain type. If we fail return Nothing
-smashable :: Int -> Type -> MaybeT (SmashT TCM) Expr
-smashable origArity typ = do
- TelV tele retType <- liftTCM $ telView typ
- retType' <- return retType
-
- inf <- inferableTerm Set.empty (unEl retType')
- reportSDoc "uhc.smashing" 10 $ nest 2 $ vcat
- [ text "Result is"
- , text "inf: " <+> (text . show) inf
- , text "type: " <+> prettyTCM retType'
- ]
- lift $ buildLambda (size tele - origArity) inf
-
-buildLambda :: Int -> Expr -> SmashT TCM Expr
-buildLambda n e | n <= 0 = return e
-buildLambda n e | otherwise = do
- v <- freshLocalName
- e' <- buildLambda (n - 1) e
- return $ AA.Lam v e'
-
--}
diff --git a/src/full/Agda/Interaction/BasicOps.hs b/src/full/Agda/Interaction/BasicOps.hs
index 640c910..3a27f58 100644
--- a/src/full/Agda/Interaction/BasicOps.hs
+++ b/src/full/Agda/Interaction/BasicOps.hs
@@ -1,10 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -29,10 +24,12 @@ import qualified Agda.Syntax.Concrete as C -- ToDo: Remove with instance of ToCo
import Agda.Syntax.Position
import Agda.Syntax.Abstract as A hiding (Open, Apply, Assign)
import Agda.Syntax.Abstract.Views as A
+import Agda.Syntax.Abstract.Pretty
import Agda.Syntax.Common
import Agda.Syntax.Info (ExprInfo(..),MetaInfo(..),emptyMetaInfo,exprNoRange)
import qualified Agda.Syntax.Info as Info
import Agda.Syntax.Internal as I
+import Agda.Syntax.Literal
import Agda.Syntax.Translation.InternalToAbstract
import Agda.Syntax.Translation.AbstractToConcrete
import Agda.Syntax.Translation.ConcreteToAbstract
@@ -42,6 +39,7 @@ import Agda.Syntax.Fixity(Precedence(..))
import Agda.Syntax.Parser
import Agda.TheTypeChecker
+import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Conversion
import Agda.TypeChecking.Monad as M hiding (MetaInfo)
import Agda.TypeChecking.MetaVars
@@ -55,8 +53,11 @@ import Agda.TypeChecking.Irrelevance (wakeIrrelevantVars)
import Agda.TypeChecking.Pretty (prettyTCM)
import Agda.TypeChecking.Free
import Agda.TypeChecking.CheckInternal
+import Agda.TypeChecking.SizedTypes.Solve
import qualified Agda.TypeChecking.Pretty as TP
+import Agda.Termination.TermCheck (termMutual)
+
import Agda.Utils.Except ( Error(strMsg), MonadError(catchError, throwError) )
import Agda.Utils.Functor
import Agda.Utils.Lens
@@ -75,7 +76,7 @@ import Agda.Utils.Impossible
parseExpr :: Range -> String -> TCM C.Expr
parseExpr rng s = do
- C.ExprWhere e wh <- liftIO $ parsePosString exprWhereParser pos s
+ C.ExprWhere e wh <- runPM $ parsePosString exprWhereParser pos s
unless (null wh) $ typeError $ GenericError $
"where clauses are not supported in holes"
return e
@@ -89,10 +90,10 @@ parseExprIn ii rng s = do
e <- parseExpr rng s
concreteToAbstract (clScope mi) e
-giveExpr :: MetaId -> Expr -> TCM Expr
+giveExpr :: Maybe InteractionId -> MetaId -> Expr -> TCM ()
-- When translator from internal to abstract is given, this function might return
-- the expression returned by the type checker.
-giveExpr mi e = do
+giveExpr mii mi e = do
mv <- lookupMeta mi
-- In the context (incl. signature) of the meta variable,
-- type check expression and assign meta
@@ -112,6 +113,7 @@ giveExpr mi e = do
TP.text "give: instantiated meta type =" TP.<+> prettyTCM t'
v <- checkExpr e t'
case mvInstantiation mv of
+
InstV xs v' -> unlessM ((Irrelevant ==) <$> asks envRelevance) $ do
reportSDoc "interaction.give" 20 $ TP.sep
[ TP.text "meta was already set to value v' = " TP.<+> prettyTCM v'
@@ -130,8 +132,34 @@ giveExpr mi e = do
[ 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
+
+ _ -> do -- updateMeta mi v
+ reportSLn "interaction.give" 20 "give: meta unassigned, assigning..."
+ args <- getContextArgs
+ nowSolvingConstraints $ assign DirEq mi args v
+
+ reportSDoc "interaction.give" 20 $ TP.text "give: meta variable updated!"
+ redoChecks mii
+ wakeupConstraints mi
+ solveSizeConstraints DontDefaultToInfty
+ -- Double check.
+ vfull <- instantiateFull v
+ checkInternal vfull t'
+
+-- | After a give, redo termination etc. checks for function which was complemented.
+redoChecks :: Maybe InteractionId -> TCM ()
+redoChecks Nothing = return ()
+redoChecks (Just ii) = do
+ reportSLn "interaction.give" 20 $
+ "give: redoing termination check for function surrounding " ++ show ii
+ ip <- lookupInteractionPoint ii
+ case ipClause ip of
+ IPNoClause -> return ()
+ IPClause f _ _ -> do
+ mb <- mutualBlockOf f
+ terErrs <- local (\ e -> e { envMutualBlock = Just mb }) $ termMutual []
+ unless (null terErrs) $ typeError $ TerminationCheckFailed terErrs
+ -- TODO redo positivity check!
-- | Try to fill hole by expression.
--
@@ -149,11 +177,10 @@ give ii mr e = liftTCM $ do
reportSDoc "interaction.give" 10 $ TP.text "giving expression" TP.<+> prettyTCM e
reportSDoc "interaction.give" 50 $ TP.text $ show $ deepUnscope e
-- Try to give mi := e
- _ <- catchError (giveExpr mi e) $ \ err -> case err of
+ catchError (giveExpr (Just ii) mi e) $ \ err -> case err of
-- Turn PatternErr into proper error:
- PatternErr{} -> do
- err <- withInteractionId ii $ TP.text "Failed to give" TP.<+> prettyTCM e
- typeError $ GenericError $ show err
+ PatternErr{} -> typeError . GenericDocError =<< do
+ withInteractionId ii $ TP.text "Failed to give" TP.<+> prettyTCM e
_ -> throwError err
removeInteractionPoint ii
return e
@@ -192,7 +219,7 @@ refine ii mr e = do
appMeta e = do
let rng = rightMargin r -- Andreas, 2013-05-01 conflate range to its right margin to ensure that appended metas are last in numbering. This fixes issue 841.
-- Make new interaction point
- ii <- registerInteractionPoint rng Nothing
+ ii <- registerInteractionPoint False rng Nothing
let info = Info.MetaInfo
{ Info.metaRange = rng
, Info.metaScope = scope { scopePrecedence = ArgumentCtx }
@@ -241,15 +268,35 @@ evalInMeta ii e =
data Rewrite = AsIs | Instantiated | HeadNormal | Simplified | Normalised
deriving (Read)
-normalForm :: Rewrite -> Type -> TCM Type
+normalForm :: (Reduce t, Simplify t, Normalise t) => Rewrite -> t -> TCM t
normalForm AsIs t = return t
normalForm Instantiated t = return t -- reify does instantiation
normalForm HeadNormal t = {- etaContract =<< -} reduce t
normalForm Simplified t = {- etaContract =<< -} simplify t
normalForm Normalised t = {- etaContract =<< -} normalise t
+data ComputeMode = DefaultCompute | IgnoreAbstract | UseShowInstance
+ deriving (Read, Eq)
+
+computeIgnoreAbstract :: ComputeMode -> Bool
+computeIgnoreAbstract DefaultCompute = False
+computeIgnoreAbstract IgnoreAbstract = True
+computeIgnoreAbstract UseShowInstance = True
+ -- UseShowInstance requires the result to be a string literal so respecting
+ -- abstract can only ever break things.
-data OutputForm a b = OutputForm Range ProblemId (OutputConstraint a b)
+computeWrapInput :: ComputeMode -> String -> String
+computeWrapInput UseShowInstance s = "show (" ++ s ++ ")"
+computeWrapInput _ s = s
+
+showComputed :: ComputeMode -> Expr -> TCM Doc
+showComputed UseShowInstance e =
+ case e of
+ A.Lit (LitString _ s) -> pure (text s)
+ _ -> (text "Not a string:" $$) <$> prettyATop e
+showComputed _ e = prettyATop e
+
+data OutputForm a b = OutputForm Range [ProblemId] (OutputConstraint a b)
deriving (Functor)
data OutputConstraint a b
@@ -295,13 +342,21 @@ outputFormId (OutputForm _ _ o) = out o
FindInScopeOF _ _ _ -> __IMPOSSIBLE__
instance Reify ProblemConstraint (Closure (OutputForm Expr Expr)) where
- reify (PConstr pids cl) = enterClosure cl $ \c -> buildClosure =<< (OutputForm (getRange c) (last pids) <$> reify c)
+ reify (PConstr pids cl) = enterClosure cl $ \c -> buildClosure =<< (OutputForm (getRange c) pids <$> reify c)
+
+reifyElimToExpr :: I.Elim -> TCM Expr
+reifyElimToExpr e = case e of
+ I.Apply v -> appl "apply" <$> reify v
+ I.Proj _o f -> appl "proj" <$> reify ((defaultArg $ I.Def f []) :: Arg Term)
+ where
+ appl :: String -> Arg Expr -> Expr
+ appl s v = A.App exprNoRange (A.Lit (LitString noRange s)) $ fmap unnamed v
instance Reify Constraint (OutputConstraint Expr Expr) where
reify (ValueCmp cmp t u v) = CmpInType cmp <$> reify t <*> reify u <*> reify v
reify (ElimCmp cmp t v es1 es2) =
- CmpElim cmp <$> reify t <*> reify es1
- <*> reify es2
+ CmpElim cmp <$> reify t <*> mapM reifyElimToExpr es1
+ <*> mapM reifyElimToExpr es2
reify (LevelCmp cmp t t') = CmpLevels cmp <$> reify t <*> reify t'
reify (TypeCmp cmp t t') = CmpTypes cmp <$> reify t <*> reify t'
reify (TelCmp a b cmp t t') = CmpTeles cmp <$> (ETel <$> reify t) <*> (ETel <$> reify t')
@@ -336,12 +391,11 @@ instance Reify Constraint (OutputConstraint Expr Expr) where
OfType tac <$> reify goal
Open{} -> __IMPOSSIBLE__
OpenIFS{} -> __IMPOSSIBLE__
- InstS{} -> __IMPOSSIBLE__
InstV{} -> __IMPOSSIBLE__
reify (FindInScope m _b mcands) = FindInScopeOF
<$> (reify $ MetaV m [])
<*> (reify =<< getMetaType m)
- <*> (forM (fromMaybe [] mcands) $ \ (Candidate tm ty eti) -> do
+ <*> (forM (fromMaybe [] mcands) $ \ (Candidate tm ty eti _) -> do
(,) <$> reify tm <*> reify ty)
reify (IsEmpty r a) = IsEmptyType <$> reify a
reify (CheckSizeLtSat a) = SizeLtSat <$> reify a
@@ -355,8 +409,8 @@ showComparison cmp = " " ++ prettyShow cmp ++ " "
instance (Show a,Show b) => Show (OutputForm a b) where
show o =
case o of
- OutputForm r 0 c -> show c ++ range r
- OutputForm r pid c -> "[" ++ prettyShow pid ++ "] " ++ show c ++ range r
+ OutputForm r [] c -> show c ++ range r
+ OutputForm r pids c -> show pids ++ " " ++ show c ++ range r
where
range r | null s = ""
| otherwise = " [ at " ++ s ++ " ]"
@@ -433,14 +487,14 @@ getConstraints = liftTCM $ do
cs <- forM cs $ \c -> do
cl <- reify c
enterClosure cl abstractToConcrete_
- ss <- mapM toOutputForm =<< getSolvedInteractionPoints True -- get all
+ ss <- mapM toOutputForm =<< getSolvedInteractionPoints True AsIs -- get all
return $ ss ++ cs
where
toOutputForm (ii, mi, e) = do
mv <- getMetaInfo <$> lookupMeta mi
withMetaInfo mv $ do
let m = QuestionMark emptyMetaInfo{ metaNumber = Just $ fromIntegral ii } ii
- abstractToConcrete_ $ OutputForm noRange 0 $ Assign m e
+ abstractToConcrete_ $ OutputForm noRange [] $ Assign m e
-- | @getSolvedInteractionPoints True@ returns all solutions,
-- even if just solved by another, non-interaction meta.
@@ -448,8 +502,8 @@ getConstraints = liftTCM $ do
-- @getSolvedInteractionPoints False@ only returns metas that
-- are solved by a non-meta.
-getSolvedInteractionPoints :: Bool -> TCM [(InteractionId, MetaId, Expr)]
-getSolvedInteractionPoints all = concat <$> do
+getSolvedInteractionPoints :: Bool -> Rewrite -> TCM [(InteractionId, MetaId, Expr)]
+getSolvedInteractionPoints all norm = concat <$> do
mapM solution =<< getInteractionIdsAndMetas
where
solution (i, m) = do
@@ -462,12 +516,11 @@ getSolvedInteractionPoints all = concat <$> do
v <- ignoreSharing <$> instantiate v
let isMeta = case v of MetaV{} -> True; _ -> False
if isMeta && not all then return [] else do
- e <- reify v
+ e <- reify =<< normalForm norm v
return [(i, m, ScopedExpr scope e)]
unsol = return []
case mvInstantiation mv of
InstV{} -> sol (MetaV m $ map Apply args)
- InstS{} -> sol (Level $ Max [Plus 0 $ MetaLevel m $ map Apply args])
Open{} -> unsol
OpenIFS{} -> unsol
BlockedConst{} -> unsol
@@ -522,7 +575,6 @@ typesOfHiddenMetas norm = liftTCM $ do
openAndImplicit is x m =
case mvInstantiation m of
M.InstV{} -> False
- M.InstS{} -> False
M.Open -> x `notElem` is
M.OpenIFS -> x `notElem` is -- OR: True !?
M.BlockedConst{} -> True
@@ -530,8 +582,9 @@ typesOfHiddenMetas norm = liftTCM $ do
metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr)
metaHelperType norm ii rng s = case words s of
- [] -> fail "C-c C-h expects an argument of the form f e1 e2 .. en"
+ [] -> failure
f : _ -> do
+ ensureName f
A.Application h args <- A.appView . getBody . deepUnscope <$> parseExprIn ii rng ("let " ++ f ++ " = _ in " ++ s)
withInteractionId ii $ do
cxtArgs <- getContextArgs
@@ -546,8 +599,29 @@ metaHelperType norm ii rng s = case words s of
(delta1, delta2, _, a', as', vs') = splitTelForWith tel a (map OtherType as) vs
a <- local (\e -> e { envPrintDomainFreePi = True }) $ do
reify =<< cleanupType arity args =<< normalForm norm =<< fst <$> withFunctionType delta1 vs' as' delta2 a'
+ reportSDoc "interaction.helper" 10 $ TP.vcat
+ [ TP.text "generating helper function"
+ , TP.nest 2 $ TP.text "tel = " TP.<+> inTopContext (prettyTCM tel)
+ , TP.nest 2 $ TP.text "a = " TP.<+> prettyTCM a
+ , TP.nest 2 $ TP.text "vs = " TP.<+> prettyTCM vs
+ , TP.nest 2 $ TP.text "as = " TP.<+> prettyTCM as
+ , TP.nest 2 $ TP.text "delta1 = " TP.<+> inTopContext (prettyTCM delta1)
+ , TP.nest 2 $ TP.text "delta2 = " TP.<+> inTopContext (addContext delta1 $ prettyTCM delta2)
+ , TP.nest 2 $ TP.text "a' = " TP.<+> inTopContext (addContext delta1 $ addContext delta2 $ prettyTCM a')
+ , TP.nest 2 $ TP.text "as' = " TP.<+> inTopContext (addContext delta1 $ prettyTCM as')
+ , TP.nest 2 $ TP.text "vs' = " TP.<+> inTopContext (addContext delta1 $ prettyTCM vs')
+ ]
return (OfType' h a)
where
+ failure = typeError $ GenericError $ "Expected an argument of the form f e1 e2 .. en"
+ ensureName f = do
+ ce <- parseExpr rng f
+ case ce of
+ C.Ident{} -> return ()
+ C.RawApp _ [C.Ident{}] -> return ()
+ _ -> do
+ reportSLn "interaction.helper" 10 $ "ce = " ++ show ce
+ failure
cleanupType arity args t = do
-- Get the arity of t
TelV ttel _ <- telView t
@@ -593,7 +667,7 @@ metaHelperType norm ii rng s = case words s of
onNamesTm f v = case v of
I.Var x es -> I.Var x <$> onNamesElims f es
I.Def q es -> I.Def q <$> onNamesElims f es
- I.Con c args -> I.Con c <$> onNamesArgs f args
+ I.Con c ci args -> I.Con c ci <$> onNamesArgs f args
I.Lam i b -> I.Lam i <$> onNamesAbs f onNamesTm b
I.Pi a b -> I.Pi <$> traverse (onNames f) a <*> onNamesAbs f onNames b
I.DontCare v -> I.DontCare <$> onNamesTm f v
@@ -706,10 +780,10 @@ introTactic pmLambda ii = do
I.Def d _ -> do
def <- getConstInfo d
case theDef def of
- Datatype{} -> addCtxTel tel' $ introData t
+ Datatype{} -> addContext tel' $ introData t
Record{ recNamedCon = name }
- | name -> addCtxTel tel' $ introData t
- | otherwise -> addCtxTel tel' $ introRec d
+ | name -> addContext tel' $ introData t
+ | otherwise -> addContext tel' $ introRec d
_ -> fallback
_ -> fallback
`catchError` \_ -> return []
@@ -720,7 +794,7 @@ introTactic pmLambda ii = do
showTCM v = show <$> prettyTCM v
- introFun tel = addCtxTel tel' $ do
+ introFun tel = addContext tel' $ do
reportSDoc "interaction.intro" 10 $ do TP.text "introFun" TP.<+> prettyTCM (telFromList tel)
imp <- showImplicitArguments
let okHiding0 h = imp || h == NotHidden
@@ -746,7 +820,7 @@ introTactic pmLambda ii = do
introData t = do
let tel = telFromList [defaultDom ("_", t)]
- pat = [defaultArg $ unnamed $ I.VarP (0,"c")]
+ pat = [defaultArg $ unnamed $ debruijnNamedVar "c" 0]
r <- splitLast CoInductive tel pat
case r of
Left err -> return []
diff --git a/src/full/Agda/Interaction/CommandLine.hs b/src/full/Agda/Interaction/CommandLine.hs
index d264bfd..dec157d 100644
--- a/src/full/Agda/Interaction/CommandLine.hs
+++ b/src/full/Agda/Interaction/CommandLine.hs
@@ -159,8 +159,8 @@ showMetas [] =
mapM_ (liftIO . putStrLn) =<< mapM showII interactionMetas
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
+ showII o = withInteractionId (outputFormId $ OutputForm noRange [] o) $ showA o
+ showM o = withMetaId (nmid $ outputFormId $ OutputForm noRange [] o) $ showA o
metaId (OfType i _) = i
metaId (JustType i) = i
@@ -188,7 +188,7 @@ metaParseExpr ii s =
let pos = case rStart r of
Nothing -> __IMPOSSIBLE__
Just pos -> pos
- e <- liftIO $ parsePosString exprParser pos s
+ e <- runPM $ parsePosString exprParser pos s
concreteToAbstract scope e
actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a
@@ -228,7 +228,7 @@ evalIn _ = liftIO $ putStrLn ":eval metaid expr"
parseExpr :: String -> TCM A.Expr
parseExpr s = do
- e <- liftIO $ parse exprParser s
+ e <- runPM $ parse exprParser s
localToAbstract e return
evalTerm :: String -> TCM (ExitCode a)
diff --git a/src/full/Agda/Interaction/EmacsCommand.hs b/src/full/Agda/Interaction/EmacsCommand.hs
index 3c2ae04..96eee10 100644
--- a/src/full/Agda/Interaction/EmacsCommand.hs
+++ b/src/full/Agda/Interaction/EmacsCommand.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
------------------------------------------------------------------------
-- | Code for instructing Emacs to do things
@@ -9,7 +8,9 @@ module Agda.Interaction.EmacsCommand
, response
, putResponse
, display_info'
+ , display_warning
, clearRunningInfo
+ , clearWarning
, displayRunningInfo
) where
@@ -60,19 +61,25 @@ response = (++ "\n") . map replaceNewLines . show . pretty
putResponse :: Lisp String -> IO ()
putResponse = putStr . response
--- | @display_info' append header content@ displays @content@ (with
--- header @header@) in some suitable way. If @append@ is @True@, then
--- the content is appended to previous content (if any), otherwise any
--- previous content is deleted.
+-- | @displayInBuffer buffername append header content@ displays @content@
+-- (with header @header@) in some suitable way in the buffer @buffername@.
+-- If @append@ is @True@, then the content is appended to previous content
+-- (if any), otherwise any previous content is deleted.
-display_info' :: Bool -> String -> String -> Lisp String
-display_info' append bufname content =
- L [ A "agda2-info-action"
- , A (quote bufname)
+displayInBuffer :: String -> Bool -> String -> String -> Lisp String
+displayInBuffer buffername append header content =
+ L [ A buffername
+ , A (quote header)
, A (quote content)
, A (if append then "t" else "nil")
]
+display_info' :: Bool -> String -> String -> Lisp String
+display_info' = displayInBuffer "agda2-info-action"
+
+display_warning :: String -> String -> Lisp String
+display_warning = displayInBuffer "agda2-warning-action" False
+
------------------------------------------------------------------------
-- Running info
@@ -87,6 +94,10 @@ clearRunningInfo :: Lisp String
clearRunningInfo =
display_info' False runningInfoBufferName ""
+-- | Clear the warning buffer
+clearWarning :: Lisp String
+clearWarning = L [ A "agda2-close-warning" ]
+
-- | Display running information about what the type-checker is up to.
displayRunningInfo :: String -> Lisp String
diff --git a/src/full/Agda/Interaction/EmacsTop.hs b/src/full/Agda/Interaction/EmacsTop.hs
index 62e32a5..f287745 100644
--- a/src/full/Agda/Interaction/EmacsTop.hs
+++ b/src/full/Agda/Interaction/EmacsTop.hs
@@ -1,5 +1,4 @@
-- {-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
module Agda.Interaction.EmacsTop
( mimicGHCi
@@ -28,7 +27,7 @@ import Agda.Interaction.EmacsCommand
import Agda.Interaction.Highlighting.Emacs
import Agda.Interaction.Options
-import Agda.Version
+import Agda.VersionCommit
----------------------------------
@@ -88,9 +87,34 @@ lispifyResponse (Resp_HighlightingInfo info modFile) =
lispifyResponse (Resp_DisplayInfo info) = return $ case info of
Info_CompilationOk -> f "The module was successfully compiled." "*Compilation result*"
Info_Constraints s -> f s "*Constraints*"
- Info_AllGoals s -> f s "*All Goals*"
+ Info_AllGoalsWarnings g w e -> f body ("*All" ++ title ++ "*")
+ where
+ isG = not $ null g
+ isW = not $ null w
+ isE = not $ null e
+ title = intercalate "," $ catMaybes
+ [ " Goals" <$ guard isG
+ , " Warnings" <$ guard isW
+ , " Errors" <$ guard isE
+ , " Done" <$ guard (not (isG || isW || isE))
+ ]
+ delimiter s = concat [ replicate 4 '\x2014'
+ , " ", s, " "
+ , replicate (54 - length s) '\x2014'
+ ]
+
+ body = intercalate "\n" $ catMaybes
+ [ g <$ guard isG
+ , delimiter "Warnings" <$ guard (isW && (isG || isE))
+ , w <$ guard isW
+ , delimiter "Errors" <$ guard (isE && (isG || isW))
+ , e <$ guard isE
+ ]
Info_Auto s -> f s "*Auto*"
Info_Error s -> f s "*Error*"
+ -- FNF: if Info_Warning comes back into use, the above should be
+ -- clearWarning : f s "*Error*"
+ --Info_Warning s -> [ display_warning "*Errors*" s ] -- FNF: currently unused
Info_Time s -> f (render s) "*Time*"
Info_NormalForm s -> f (render s) "*Normal Form*" -- show?
Info_InferredType s -> f (render s) "*Inferred Type*"
@@ -107,10 +131,12 @@ lispifyResponse (Resp_DisplayInfo info) = return $ case info of
]
]
Info_Intro s -> f (render s) "*Intro*"
- Info_Version -> f ("Agda version " ++ version) "*Agda Version*"
+ Info_Version -> f ("Agda version " ++ versionWithCommitInfo) "*Agda Version*"
where f content bufname = [ display_info' False bufname content ]
lispifyResponse Resp_ClearHighlighting = return [ L [ A "agda2-highlight-clear" ] ]
lispifyResponse Resp_ClearRunningInfo = return [ clearRunningInfo ]
+-- FNF: if Info_Warning comes back into use, the above should be
+-- return [ clearRunningInfo, clearWarning ]
lispifyResponse (Resp_RunningInfo n s)
| n <= 1 = return [ displayRunningInfo s ]
| otherwise = return [ L [A "agda2-verbose", A (quote s)] ]
diff --git a/src/full/Agda/Interaction/Exceptions.hs b/src/full/Agda/Interaction/Exceptions.hs
deleted file mode 100644
index 0c46e82..0000000
--- a/src/full/Agda/Interaction/Exceptions.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-| This module defines the exception handler.
--}
-module Agda.Interaction.Exceptions where
-
-import Prelude
-import Control.Exception as E
-
-import Agda.Syntax.Position
-import Agda.Syntax.Parser ( ParseError(..) )
-
-import Agda.Utils.Pretty
-
-handleParseException :: (ParseError -> IO a) -> ParseError -> IO a
-handleParseException crash e = crash e
-
--- | Note that 'failOnException' only catches 'ParseError's.
-
-failOnException :: (Range -> Doc -> IO a) -> IO a -> IO a
-failOnException h m = m `E.catch` handleParseException handler
- where
- handler x = h (getRange x) (pretty x)
diff --git a/src/full/Agda/Interaction/FindFile.hs b/src/full/Agda/Interaction/FindFile.hs
index bd64c03..2ffa1b6 100644
--- a/src/full/Agda/Interaction/FindFile.hs
+++ b/src/full/Agda/Interaction/FindFile.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
------------------------------------------------------------------------
-- | Functions which map between module names and file names.
--
@@ -13,31 +14,49 @@ module Agda.Interaction.FindFile
, findInterfaceFile
, checkModuleName
, moduleName', moduleName
- , tests
+ , rootNameModule
+ , replaceModuleExtension
) where
-import Control.Applicative
+import Prelude hiding (null)
+
+import Control.Applicative hiding (empty)
import Control.Monad
import Control.Monad.Trans
-import Data.List
+import Data.List hiding (null)
+import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import System.FilePath
+import Agda.Syntax.Common
import Agda.Syntax.Concrete
import Agda.Syntax.Parser
+import Agda.Syntax.Parser.Literate (literateExts, literateExtsShortList)
+import Agda.Syntax.Position
+
import Agda.TypeChecking.Monad.Base
+import Agda.TypeChecking.Monad.Trace
import Agda.TypeChecking.Monad.Benchmark (billTo)
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import {-# SOURCE #-} Agda.TypeChecking.Monad.Options (getIncludeDirs)
+
import Agda.Utils.Except
import Agda.Utils.FileName
import Agda.Utils.Lens
+import Agda.Utils.Null
+
+#include "undefined.h"
+import Agda.Utils.Impossible
-- | Converts an Agda file name to the corresponding interface file
-- name.
toIFile :: AbsolutePath -> AbsolutePath
-toIFile f = mkAbsolute (replaceExtension (filePath f) ".agdai")
+toIFile = replaceModuleExtension ".agdai"
+
+replaceModuleExtension :: String -> AbsolutePath -> AbsolutePath
+replaceModuleExtension ext@('.':_) = mkAbsolute . (++ ext) . dropAgdaExtension . filePath
+replaceModuleExtension ext = replaceModuleExtension ('.':ext)
-- | Errors which can arise when trying to find a source file.
--
@@ -98,18 +117,20 @@ findFile'' dirs m modFile =
case Map.lookup m modFile of
Just f -> return (Right f, modFile)
Nothing -> do
- files <- mapM absolute
- [ filePath dir </> file
- | dir <- dirs
- , file <- map (moduleNameToFileName m)
- [".agda", ".lagda"]
- ]
+ files <- fileList sourceFileExts
+ filesShortList <- fileList sourceFileExtsShortList
existingFiles <-
liftIO $ filterM (doesFileExistCaseSensitive . filePath) files
return $ case nub existingFiles of
- [] -> (Left (NotFound files), modFile)
+ [] -> (Left (NotFound filesShortList), modFile)
[file] -> (Right file, Map.insert m file modFile)
- files -> (Left (Ambiguous files), modFile)
+ files -> (Left (Ambiguous existingFiles), modFile)
+ where
+ fileList exts = mapM absolute
+ [ filePath dir </> file
+ | dir <- dirs
+ , file <- map (moduleNameToFileName m) exts
+ ]
-- | Finds the interface file corresponding to a given top-level
-- module name. The returned paths are absolute.
@@ -128,18 +149,25 @@ findInterfaceFile m = do
-- corresponding to the module name (according to the include path)
-- has to be the same as the given file name.
-checkModuleName :: TopLevelModuleName
- -- ^ The name of the module.
- -> AbsolutePath
- -- ^ The file from which it was loaded.
- -> TCM ()
-checkModuleName name file = do
- moduleShouldBeIn <- findFile' name
- case moduleShouldBeIn of
+checkModuleName
+ :: TopLevelModuleName
+ -- ^ The name of the module.
+ -> AbsolutePath
+ -- ^ The file from which it was loaded.
+ -> Maybe TopLevelModuleName
+ -- ^ The expected name, coming from an import statement.
+ -> TCM ()
+checkModuleName name file mexpected = do
+ findFile' name >>= \case
+
Left (NotFound files) -> typeError $
- ModuleNameDoesntMatchFileName name files
+ case mexpected of
+ Nothing -> ModuleNameDoesntMatchFileName name files
+ Just expected -> ModuleNameUnexpected name expected
+
Left (Ambiguous files) -> typeError $
- AmbiguousTopLevelModuleName name files
+ AmbiguousTopLevelModuleName name files
+
Right file' -> do
file <- liftIO $ absolute (filePath file)
if file === file' then
@@ -151,20 +179,42 @@ checkModuleName name file = do
--
-- Warning! Parses the whole file to get the module name out.
-- Use wisely!
+--
+-- No side effects! Only in 'TCM' to raise errors.
-moduleName' :: AbsolutePath -> TCM TopLevelModuleName
+moduleName' :: AbsolutePath -> TCM (Ranged TopLevelModuleName)
moduleName' file = billTo [Bench.ModuleName] $ do
- name <- topLevelModuleName <$> liftIO (parseFile' moduleParser file)
+ q <- runPM (parseFile' moduleParser file)
+ let name = topLevelModuleName q
case name of
TopLevelModuleName ["_"] -> do
- _ <- liftIO (parse moduleNameParser defaultName)
+ q <- runPM (parse moduleNameParser defaultName)
`catchError` \_ ->
typeError $
- GenericError $ "Invalid file name: " ++ show file ++ "."
- return $ TopLevelModuleName [defaultName]
- _ -> return name
+ GenericError $ "File name " ++ show file ++
+ " is invalid as it does not correspond to a valid module name."
+ return $ Ranged (getRange q) $ TopLevelModuleName [defaultName]
+ _ -> return $ Ranged (getRange q) name
where
- defaultName = rootName file
+ defaultName = rootNameModule file
+
+sourceFileExts :: [String]
+sourceFileExts = [".agda"] ++ literateExts
+
+sourceFileExtsShortList :: [String]
+sourceFileExtsShortList = [".agda"] ++ literateExtsShortList
+
+dropAgdaExtension :: String -> String
+dropAgdaExtension s = case catMaybes [ stripExtension ext s
+ | ext <- sourceFileExts ] of
+ [name] -> name
+ _ -> __IMPOSSIBLE__
+ where
+ stripExtension :: String -> String -> Maybe String
+ stripExtension e = fmap reverse . stripPrefix (reverse e) . reverse
+
+rootNameModule :: AbsolutePath -> String
+rootNameModule = dropAgdaExtension . snd . splitFileName . filePath
-- | A variant of 'moduleName'' which raises an error if the file name
-- does not match the module name.
@@ -174,6 +224,10 @@ moduleName' file = billTo [Bench.ModuleName] $ do
moduleName :: AbsolutePath -> TCM TopLevelModuleName
moduleName file = do
- m <- moduleName' file
- checkModuleName m file
+ Ranged r m <- moduleName' file
+ -- Andreas, 2016-07-11, issue 2092
+ -- The error range should be set to the file with the wrong module name
+ -- not the importing one (which would be the default).
+ (if null r then id else traceCall (SetRange r)) $
+ checkModuleName m file Nothing
return m
diff --git a/src/full/Agda/Interaction/FindFile.hs-boot b/src/full/Agda/Interaction/FindFile.hs-boot
index 9c922bd..03b1666 100644
--- a/src/full/Agda/Interaction/FindFile.hs-boot
+++ b/src/full/Agda/Interaction/FindFile.hs-boot
@@ -1,7 +1,10 @@
module Agda.Interaction.FindFile where
-import Data.Map (Map)
+import Agda.Syntax.Common (Ranged)
import Agda.Syntax.Concrete.Name (TopLevelModuleName)
+import Agda.TypeChecking.Monad.Base (TCM)
import Agda.Utils.FileName (AbsolutePath)
-type ModuleToSource = Map TopLevelModuleName AbsolutePath
+moduleName :: AbsolutePath -> TCM TopLevelModuleName
+moduleName' :: AbsolutePath -> TCM (Ranged TopLevelModuleName)
+checkModuleName :: TopLevelModuleName -> AbsolutePath -> Maybe TopLevelModuleName -> TCM ()
diff --git a/src/full/Agda/Interaction/Highlighting/Emacs.hs b/src/full/Agda/Interaction/Highlighting/Emacs.hs
index 12d1dcd..a9e2a04 100644
--- a/src/full/Agda/Interaction/Highlighting/Emacs.hs
+++ b/src/full/Agda/Interaction/Highlighting/Emacs.hs
@@ -4,7 +4,6 @@
module Agda.Interaction.Highlighting.Emacs
( lispifyHighlightingInfo
- , Agda.Interaction.Highlighting.Emacs.tests
) where
import Agda.Interaction.Highlighting.Precise
@@ -16,7 +15,6 @@ import Agda.TypeChecking.Monad
import Agda.Utils.FileName
import qualified Agda.Utils.IO.UTF8 as UTF8
import Agda.Utils.String
-import Agda.Utils.TestHelpers
import Control.Applicative
import qualified Control.Exception as E
@@ -110,13 +108,3 @@ lispifyHighlightingInfo h modFile = do
return $ L [ A "agda2-highlight-load-and-delete-action"
, A (quote f)
]
-
-------------------------------------------------------------------------
--- All tests
-
--- TODO: One could check that the show functions are invertible.
-
--- | All the properties.
-
-tests :: IO Bool
-tests = runTests "Agda.Interaction.Highlighting.Emacs" []
diff --git a/src/full/Agda/Interaction/Highlighting/Generate.hs b/src/full/Agda/Interaction/Highlighting/Generate.hs
index fb62574..558fa64 100644
--- a/src/full/Agda/Interaction/Highlighting/Generate.hs
+++ b/src/full/Agda/Interaction/Highlighting/Generate.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RelaxedPolyRec #-}
-- | Generates data used for precise syntax highlighting.
@@ -16,7 +14,6 @@ module Agda.Interaction.Highlighting.Generate
, computeUnsolvedMetaWarnings
, computeUnsolvedConstraints
, storeDisambiguatedName
- , Agda.Interaction.Highlighting.Generate.tests
) where
import Prelude hiding (null)
@@ -37,19 +34,21 @@ import qualified Data.IntMap as IntMap
import Data.Void
import Agda.Interaction.Response (Response(Resp_HighlightingInfo))
-import Agda.Interaction.Highlighting.Precise hiding (tests)
-import Agda.Interaction.Highlighting.Range hiding (tests)
+import Agda.Interaction.Highlighting.Precise
+import Agda.Interaction.Highlighting.Range
import qualified Agda.TypeChecking.Errors as E
import Agda.TypeChecking.MetaVars (isBlockedTerm)
import Agda.TypeChecking.Monad
hiding (MetaInfo, Primitive, Constructor, Record, Function, Datatype)
import qualified Agda.TypeChecking.Monad as M
+import Agda.TypeChecking.Positivity.Occurrence
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Concrete (FieldAssignment'(..))
import qualified Agda.Syntax.Common as Common
import qualified Agda.Syntax.Concrete as C
+import Agda.Syntax.Fixity
import qualified Agda.Syntax.Info as SI
import qualified Agda.Syntax.Internal as I
import qualified Agda.Syntax.Literal as L
@@ -58,13 +57,13 @@ import qualified Agda.Syntax.Parser.Tokens as T
import qualified Agda.Syntax.Position as P
import Agda.Utils.FileName
+import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.Maybe
import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Null
-import Agda.Utils.TestHelpers
import Agda.Utils.HashMap (HashMap)
import qualified Agda.Utils.HashMap as HMap
@@ -167,6 +166,8 @@ generateAndPrintSyntaxInfo decl hlLevel = do
Full{} -> generateConstructorInfo modMap file kinds decl
_ -> return mempty
+ warnInfo <- Fold.fold . map (warningHighlighting . tcWarning) <$> use stTCWarnings
+
let (from, to) = case P.rangeToInterval (P.getRange decl) of
Nothing -> __IMPOSSIBLE__
Just i -> ( fromIntegral $ P.posPos $ P.iStart i
@@ -183,6 +184,7 @@ generateAndPrintSyntaxInfo decl hlLevel = do
let syntaxInfo = compress (mconcat [ constructorInfo
, theRest modMap file
, nameInfo
+ , warnInfo
])
`mappend`
curTokens
@@ -223,7 +225,7 @@ generateAndPrintSyntaxInfo decl hlLevel = do
, Fold.foldMap getNamedArg $ universeBi decl
]
where
- bound n = nameToFile modMap file [] (A.nameConcrete n)
+ bound n = nameToFile modMap file [] (A.nameConcrete n) P.noRange
(\isOp -> mempty { aspect = Just $ Name (Just Bound) isOp })
(Just $ A.nameBindingSite n)
@@ -233,17 +235,17 @@ generateAndPrintSyntaxInfo decl hlLevel = do
macro n = nameToFileA modMap file n True $ \isOp ->
mempty { aspect = Just $ Name (Just Macro) isOp }
- field m n = nameToFile modMap file m n
+ field m n = nameToFile modMap file m n P.noRange
(\isOp -> mempty { aspect = Just $ Name (Just Field) isOp })
Nothing
asName n = nameToFile modMap file []
- n
+ n P.noRange
(\isOp -> mempty { aspect = Just $ Name (Just Module) isOp })
Nothing
mod isTopLevelModule n =
nameToFile modMap file []
- (A.nameConcrete n)
+ (A.nameConcrete n) P.noRange
(\isOp -> mempty { aspect = Just $ Name (Just Module) isOp })
(Just $ (if isTopLevelModule then P.beginningOfFile else id)
(A.nameBindingSite n))
@@ -281,7 +283,7 @@ generateAndPrintSyntaxInfo decl hlLevel = do
getPattern' :: A.Pattern' e -> File
getPattern' (A.VarP x) = bound x
getPattern' (A.AsP _ x _) = bound x
- getPattern' (A.DotP pi _) =
+ getPattern' (A.DotP pi _ _) =
singleton (rToR $ P.getRange pi)
(mempty { otherAspects = [DottedPattern] })
getPattern' (A.PatternSynP _ q _) = patsyn q
@@ -336,13 +338,13 @@ generateTokenInfo
:: AbsolutePath -- ^ The module to highlight.
-> TCM CompressedFile
generateTokenInfo file =
- liftIO $ tokenHighlighting <$> Pa.parseFile' Pa.tokensParser file
+ runPM $ tokenHighlighting <$> Pa.parseFile' Pa.tokensParser file
-- | Same as 'generateTokenInfo' but takes a string instead of a filename.
generateTokenInfoFromString :: P.Range -> String -> TCM CompressedFile
generateTokenInfoFromString r _ | r == P.noRange = return mempty
generateTokenInfoFromString r s = do
- liftIO $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s
+ runPM $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s
where
Just p = P.rStart r
@@ -422,10 +424,11 @@ nameKinds hlLevel decl = do
defnToKind M.Record{} = Record
defnToKind M.Constructor{ M.conInd = i } = Constructor i
defnToKind M.Primitive{} = Primitive
+ defnToKind M.AbstractDefn = __IMPOSSIBLE__
declToKind :: A.Declaration ->
HashMap A.QName NameKind -> HashMap A.QName NameKind
- declToKind (A.Axiom _ i _ q _)
+ declToKind (A.Axiom _ i _ _ q _)
| SI.defMacro i == Common.MacroDef = insert q Macro
| otherwise = insert q Postulate
declToKind (A.Field _ q _) = insert q Field -- Function
@@ -506,7 +509,7 @@ printErrorInfo e = printHighlightingInfo . compress =<< errorHighlighting e
errorHighlighting :: TCErr -> TCM File
-errorHighlighting (TypeError s cl@(Closure sig env scope (TerminationCheckFailed termErrs))) =
+errorHighlighting (TypeError s cl@Closure{ clValue = TerminationCheckFailed termErrs }) =
-- For termination errors, we keep the previous highlighting,
-- just additionally mark the bad calls.
return $ terminationErrorHighlighting termErrs
@@ -525,6 +528,15 @@ errorHighlighting e = do
}
return $ mconcat [ erase, error ]
+-- | Generate syntax highlighting for warnings.
+
+warningHighlighting :: Warning -> File
+warningHighlighting w = case w of
+ TerminationIssue terrs -> terminationErrorHighlighting terrs
+ NotStrictlyPositive d ocs -> positivityErrorHighlighting d ocs
+ _ -> mempty
+
+
-- | Generate syntax highlighting for termination errors.
terminationErrorHighlighting :: [TerminationError] -> File
@@ -536,6 +548,17 @@ terminationErrorHighlighting termErrs = functionDefs `mappend` callSites
callSites = Fold.foldMap (\r -> singleton (rToR r) m) $
concatMap (map M.callInfoRange . M.termErrCalls) termErrs
+-- | Generate syntax highlighting for not-strictly-positive inductive
+-- definitions.
+
+-- TODO: highlight also the problematic occurrences
+positivityErrorHighlighting :: I.QName -> OccursWhere -> File
+positivityErrorHighlighting q o = several (rToR <$> P.getRange q : rs) m
+ where
+ rs = case o of Unknown -> []; Known r _ -> [r]
+ m = mempty { otherAspects = [PositivityProblem] }
+
+
-- | Generates and prints syntax highlighting information for unsolved
-- meta-variables and certain unsolved constraints.
@@ -614,6 +637,8 @@ nameToFile :: SourceToModule
-- ^ The name qualifier (may be empty).
-> C.Name
-- ^ The base name.
+ -> P.Range
+ -- ^ The 'Range' of the name in its fixity declaration (if any).
-> (Bool -> Aspects)
-- ^ Meta information to be associated with the name.
-- The argument is 'True' iff the name is an operator.
@@ -622,7 +647,7 @@ nameToFile :: SourceToModule
-- meta information is extended with this information,
-- if possible.
-> File
-nameToFile modMap file xs x m mR =
+nameToFile modMap file xs x fr m mR =
-- We don't care if we get any funny ranges.
if all (== Strict.Just file) fileNames then
several (map rToR rs)
@@ -631,7 +656,7 @@ nameToFile modMap file xs x m mR =
mempty
where
fileNames = catMaybes $ map (fmap P.srcFile . P.rStart . P.getRange) (x : xs)
- rs = map P.getRange (x : xs)
+ rs = applyWhen (not $ null fr) (fr :) $ map P.getRange (x : xs)
mFilePos = do
r <- mR
P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r
@@ -659,8 +684,16 @@ nameToFileA modMap file x include m =
file
(concreteQualifier x)
(concreteBase x)
+ r
m
(if include then Just $ bindingSite x else Nothing)
+ where
+ -- Andreas, 2016-09-08, for issue #2140:
+ -- Range of name from fixity declaration:
+ fr = theNameRange $ A.nameFixity $ A.qnameName x
+ -- Somehow we import fixity ranges from other files, we should ignore them.
+ -- (I do not understand how we get them as they should not be serialized...)
+ r = if P.rangeFile fr == Strict.Just file then fr else P.noRange
concreteBase :: I.QName -> C.Name
concreteBase = A.nameConcrete . A.qnameName
@@ -678,11 +711,3 @@ storeDisambiguatedName q = whenJust (start $ P.getRange q) $ \ i ->
stDisambiguatedNames %= IntMap.insert i q
where
start r = fromIntegral . P.posPos <$> P.rStart' r
-
-------------------------------------------------------------------------
--- All tests
-
--- | All the properties.
-
-tests :: IO Bool
-tests = runTests "Agda.Interaction.Highlighting.Generate" []
diff --git a/src/full/Agda/Interaction/Highlighting/LaTeX.hs b/src/full/Agda/Interaction/Highlighting/LaTeX.hs
index 55efba5..529ba8c 100644
--- a/src/full/Agda/Interaction/Highlighting/LaTeX.hs
+++ b/src/full/Agda/Interaction/Highlighting/LaTeX.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
@@ -12,7 +13,7 @@ import Prelude hiding (log)
import Data.Char
import Data.Maybe
import Data.Function
-import Control.Monad.RWS
+import Control.Monad.RWS.Strict
import System.Directory
import System.FilePath
import Data.Text (Text)
@@ -26,11 +27,13 @@ import qualified Data.List as List
import Paths_Agda
+import Agda.Syntax.Abstract (toTopLevelModuleName)
import Agda.Syntax.Common
-import Agda.Syntax.Concrete (TopLevelModuleName, moduleNameParts)
+import Agda.Syntax.Concrete
+ (TopLevelModuleName, moduleNameParts, projectRoot)
import qualified Agda.Interaction.FindFile as Find
import Agda.Interaction.Highlighting.Precise
-import Agda.TypeChecking.Monad (TCM)
+import Agda.TypeChecking.Monad (TCM, Interface(..))
import qualified Agda.TypeChecking.Monad as TCM
import Agda.Interaction.Options
import Agda.Compiler.CallCompiler
@@ -54,20 +57,19 @@ type LaTeX = ExceptT String (RWST () Text State IO)
data State = State
{ tokens :: Tokens
- , column :: Int -- ^ Column number, used for polytable alignment.
- , indent :: Int -- ^ Indentation level, also for alignment.
- , indentPrev :: Int
- , inCode :: Bool -- ^ Keeps track of whether we are in a code
+ , column :: !Int -- ^ Column number, used for polytable alignment.
+ , indent :: !Int -- ^ Indentation level, also for alignment.
+ , indentPrev :: !Int
+ , inCode :: !Bool -- ^ Keeps track of whether we are in a code
-- block or not.
- , debugs :: [Debug] -- ^ Says what debug information should printed.
}
type Tokens = [Token]
data Token = Token
- { text :: Text
+ { text :: !Text
, info :: Aspects
- , position :: Int -- ^ Is not used currently, but could
+ , position :: !Int -- ^ Is not used currently, but could
-- potentially be used for hyperlinks as in
-- the HTML output?
}
@@ -76,6 +78,11 @@ data Token = Token
data Debug = MoveColumn | NonCode | Code | Spaces | Output
deriving (Eq, Show)
+-- | Says what debug information should printed.
+
+debugs :: [Debug]
+debugs = []
+
-- | Run function for the @LaTeX@ monad.
runLaTeX :: LaTeX a -> () -> State -> IO (Either String a, State, Text)
runLaTeX = runRWST . runExceptT
@@ -87,7 +94,6 @@ emptyState = State
, indent = 0
, indentPrev = 0
, inCode = False
- , debugs = []
}
------------------------------------------------------------------------
@@ -99,9 +105,9 @@ emptyState = State
isInfixOf' :: Text -> Text -> Maybe (Text, Text)
isInfixOf' needle haystack = go (T.tails haystack) 0
where
- go [] n = Nothing
- go ((T.stripPrefix needle -> Just suf) : xss) n = Just (T.take n haystack, suf)
- go (_ : xss) n = go xss (n + 1)
+ go [] !n = Nothing
+ go ((T.stripPrefix needle -> Just suf) : xss) n = Just (T.take n haystack, suf)
+ go (_ : xss) n = go xss (n + 1)
-- Same as above, but starts searching from the back rather than the
-- front.
@@ -214,8 +220,7 @@ unsetInCode :: LaTeX ()
unsetInCode = modify $ \s -> s { inCode = False }
logHelper :: Debug -> Text -> [String] -> LaTeX ()
-logHelper debug text extra = do
- debugs <- gets debugs
+logHelper debug text extra =
when (debug `elem` debugs) $ do
lift $ lift $ T.putStrLn $ T.pack (show debug ++ ": ") <+>
T.pack "'" <+> text <+> T.pack "' " <+>
@@ -277,10 +282,15 @@ cmdIndent :: Show a => a -> Text
cmdIndent i = cmdPrefix <+> T.pack "Indent" <+>
cmdArg (T.pack (show i)) <+> cmdArg T.empty
-infixl', infix', infixr' :: Text
-infixl' = T.pack "infixl"
-infix' = T.pack "infix"
-infixr' = T.pack "infixr"
+
+-- Andreas, 2016-09-08, issue #2140:
+-- The following special treatment of infix declarations seems
+-- superfluous (and does the wrong thing with the fix for #2140):
+
+-- infixl', infix', infixr' :: Text
+-- infixl' = T.pack "infixl"
+-- infix' = T.pack "infix"
+-- infixr' = T.pack "infixr"
------------------------------------------------------------------------
-- * Automaton.
@@ -327,10 +337,14 @@ code = do
unsetInCode
nonCode
- when (tok `elem` [ infixl', infix', infixr' ]) $ do
- output $ cmdPrefix <+> T.pack "Keyword" <+> cmdArg tok
- fixity
- code
+ -- Andreas, 2016-09-08, issue #2140:
+ -- The following special treatment of infix declarations seems
+ -- superfluous (and does the wrong thing with the fix for #2140):
+
+ -- when (tok `elem` [ infixl', infix', infixr' ]) $ do
+ -- output $ cmdPrefix <+> T.pack "Keyword" <+> cmdArg tok
+ -- fixity
+ -- code
when (isSpaces tok) $ do
spaces $ T.group tok
@@ -391,34 +405,39 @@ escape (T.uncons -> Just (c, s)) = T.pack (replace c) <+> escape s
_ -> [ c ]
escape _ = __IMPOSSIBLE__
--- | Fixity declarations need a special treatment. The operations in
--- declarations like:
---
--- infix num op1 op2 op3
---
--- are treated as comments and thus grouped together with the newlines
--- that follow, which results incorrect LaTeX output -- the following
--- state remedies the problem by breaking on newlines.
-fixity :: LaTeX ()
-fixity = do
- tok <- nextToken
- case T.breakOn (T.pack "\n") tok of
+-- Andreas, 2016-09-08, issue #2140:
+-- The following special treatment of infix declarations seems
+-- superfluous (and does the wrong thing with the fix for #2140):
+
+-- -- | Fixity declarations need a special treatment. The operations in
+-- -- declarations like:
+-- --
+-- -- infix num op1 op2 op3
+-- --
+-- -- are treated as comments and thus grouped together with the newlines
+-- -- that follow, which results incorrect LaTeX output -- the following
+-- -- state remedies the problem by breaking on newlines.
+-- fixity :: LaTeX ()
+-- fixity = do
+-- tok <- nextToken
- -- Spaces.
- (sps, nls) | nls == T.empty && isSpaces sps -> do
- spaces $ T.group sps
- fixity
+-- case T.breakOn (T.pack "\n") tok of
- -- Fixity level.
- (num, nls) | nls == T.empty -> do
- output $ cmdPrefix <+> T.pack "Number" <+> cmdArg num
- fixity
+-- -- Spaces.
+-- (sps, nls) | nls == T.empty && isSpaces sps -> do
+-- spaces $ T.group sps
+-- fixity
- -- Operations followed by newlines.
- (ops, nls) | otherwise -> do
- output $ (T.pack " " <+>) $ T.unwords $ map ((cmdPrefix <+> T.pack "FixityOp" <+>) . cmdArg . escape) $ T.words ops
- spaces (T.group nls)
+-- -- Fixity level.
+-- (num, nls) | nls == T.empty -> do
+-- output $ cmdPrefix <+> T.pack "Number" <+> cmdArg num
+-- fixity
+
+-- -- Operations followed by newlines.
+-- (ops, nls) | otherwise -> do
+-- output $ (T.pack " " <+>) $ T.unwords $ map ((cmdPrefix <+> T.pack "FixityOp" <+>) . cmdArg . escape) $ T.words ops
+-- spaces (T.group nls)
-- | Spaces are grouped before processed, because multiple consecutive
@@ -489,10 +508,35 @@ spaces (s@(T.uncons -> Just ('\n', _)) : ss) = do
output $ ptClose <+> T.replicate (T.length s) ptNL
spaces ss
--- Treat tabs as if they were spaces.
-spaces (s@(T.uncons -> Just ('\t', _)) : ss) =
- spaces $ T.replicate (T.length s) (T.singleton ' ') : ss
-spaces (_ : ss) = __IMPOSSIBLE__
+-- Treat tabs and non-standard spaces as if they were spaces
+-- [Issue_#2019].
+spaces (s@(T.uncons -> Just (c, _)) : ss)
+ | isSpace c && (c /= '\n') =
+ spaces $ T.replicate (T.length s) (T.singleton ' ') : ss
+ | otherwise = __IMPOSSIBLE__
+
+spaces (_ : ss) = __IMPOSSIBLE__
+
+-- Split multi-lines string literals into multiple string literals
+-- Isolating leading spaces for the alignment machinery to work
+-- properly
+stringLiteral :: Token -> Tokens
+stringLiteral t | aspect (info t) == Just String =
+ reverse $ snd $ foldl insertShifted (0, [])
+ $ concatMap leadingSpaces
+ $ List.intersperse (T.pack "\n")
+ $ T.lines (text t) where
+
+ leadingSpaces :: Text -> [Text]
+ leadingSpaces t = [pre, suf]
+ where (pre , suf) = T.span (== ' ') t
+
+ insertShifted :: (Int, Tokens) -> Text -> (Int, Tokens)
+ insertShifted (i, xs) x =
+ let tx = t { text = x, position = position t + i }
+ in (i + T.length x, tx : xs)
+
+stringLiteral t = [t]
------------------------------------------------------------------------
-- * Main.
@@ -500,14 +544,20 @@ spaces (_ : ss) = __IMPOSSIBLE__
defaultStyFile :: String
defaultStyFile = "agda.sty"
--- | The only exported function. It's (only) called in @Main.hs@.
-generateLaTeX :: TopLevelModuleName -> HighlightingInfo -> TCM ()
-generateLaTeX mod hi = do
+-- | The only exported function.
+generateLaTeX :: Interface -> TCM ()
+generateLaTeX i = do
+ let mod = toTopLevelModuleName $ iModuleName i
+ hi = iHighlighting i
options <- TCM.commandLineOptions
- -- There is a default directory given by 'defaultLaTeXDir'.
- let dir = optLaTeXDir options
+ dir <- case optGHCiInteraction options of
+ False -> return $ optLaTeXDir options
+ True -> do
+ sourceFile <- Find.findFile mod
+ return $ filePath (projectRoot sourceFile mod)
+ </> optLaTeXDir options
liftIO $ createDirectoryIfMissing True dir
TCM.reportSLn "latex" 1 $ unlines
@@ -548,6 +598,8 @@ toLaTeX source hi
= processTokens
+ . concatMap stringLiteral
+
-- Head the list (the grouped chars contain the same meta info) and
-- collect the characters into a string.
. map (\xs -> case xs of
diff --git a/src/full/Agda/Interaction/Highlighting/Precise.hs b/src/full/Agda/Interaction/Highlighting/Precise.hs
index f5a4122..74d5ab0 100644
--- a/src/full/Agda/Interaction/Highlighting/Precise.hs
+++ b/src/full/Agda/Interaction/Highlighting/Precise.hs
@@ -8,11 +8,13 @@ module Agda.Interaction.Highlighting.Precise
, NameKind(..)
, OtherAspect(..)
, Aspects(..)
- , File
+ , File(..)
, HighlightingInfo
-- ** Creation
, singleton
, several
+ -- ** Merging
+ , merge
-- ** Inspection
, smallestPos
, toMap
@@ -29,21 +31,19 @@ module Agda.Interaction.Highlighting.Precise
, selectC
-- ** Inspection
, smallestPosC
- -- * Tests
- , Agda.Interaction.Highlighting.Precise.tests
+ -- ** Merge
+ , mergeC
) where
-import Agda.Utils.TestHelpers
import Agda.Utils.String
-import Agda.Utils.List hiding (tests)
+import Agda.Utils.List
import Data.Maybe
import Data.List
import Data.Function
-import Data.Monoid
+import Data.Semigroup
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second)
import Control.Monad
-import Agda.Utils.QuickCheck
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Typeable (Typeable)
@@ -98,6 +98,7 @@ data OtherAspect
-- ^ Unsolved constraint not connected to meta-variable. This
-- could for instance be an emptyness constraint.
| TerminationProblem
+ | PositivityProblem
| IncompletePattern
-- ^ When this constructor is used it is probably a good idea to
-- include a 'note' explaining why the pattern is incomplete.
@@ -171,6 +172,9 @@ mergeAspects m1 m2 = Aspects
, definitionSite = (mplus `on` definitionSite) m1 m2
}
+instance Semigroup Aspects where
+ (<>) = mergeAspects
+
instance Monoid Aspects where
mempty = Aspects
{ aspect = Nothing
@@ -178,7 +182,7 @@ instance Monoid Aspects where
, note = Nothing
, definitionSite = Nothing
}
- mappend = mergeAspects
+ mappend = (<>)
-- | Merges files.
@@ -186,9 +190,12 @@ merge :: File -> File -> File
merge f1 f2 =
File { mapping = (IntMap.unionWith mappend `on` mapping) f1 f2 }
+instance Semigroup File where
+ (<>) = merge
+
instance Monoid File where
mempty = File { mapping = IntMap.empty }
- mappend = merge
+ mappend = (<>)
------------------------------------------------------------------------
-- Inspection
@@ -251,13 +258,6 @@ decompress =
map (\(r, m) -> [ (p, m) | p <- rangeToPositions r ]) .
ranges
-prop_compress :: File -> Bool
-prop_compress f =
- compressedFileInvariant c
- &&
- decompress c == f
- where c = compress f
-
-- | Clear any highlighting info for the given ranges. Used to make sure
-- unsolved meta highlighting overrides error highlighting.
noHighlightingInRange :: Ranges -> CompressedFile -> CompressedFile
@@ -279,18 +279,12 @@ 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] -> 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.
mergeC :: CompressedFile -> CompressedFile -> CompressedFile
@@ -320,13 +314,12 @@ 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))
+instance Semigroup CompressedFile where
+ (<>) = mergeC
instance Monoid CompressedFile where
mempty = CompressedFile []
- mappend = mergeC
+ mappend = (<>)
-- | @splitAtC p f@ splits the compressed file @f@ into @(f1, f2)@,
-- where all the positions in @f1@ are @< p@, and all the positions
@@ -347,17 +340,6 @@ 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) &&
- decompress (mergeC f1 f2) == decompress f
- where
- (f1, f2) = splitAtC p f
-
- positions = IntMap.keys . toMap . decompress
-
-
selectC :: P.Range -> CompressedFile -> CompressedFile
selectC r cf = cf'
where
@@ -371,133 +353,3 @@ selectC r cf = cf'
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
-
-------------------------------------------------------------------------
--- Generators
-
-instance Arbitrary Aspect where
- arbitrary =
- frequency [ (3, elements [ Comment, Keyword, String, Number
- , Symbol, PrimitiveType ])
- , (1, liftM2 Name (maybeGen arbitrary) arbitrary)
- ]
-
- shrink Name{} = [Comment]
- shrink _ = []
-
-instance CoArbitrary Aspect where
- coarbitrary Comment = variant 0
- coarbitrary Keyword = variant 1
- coarbitrary String = variant 2
- coarbitrary Number = variant 3
- coarbitrary Symbol = variant 4
- coarbitrary PrimitiveType = variant 5
- coarbitrary (Name nk b) =
- variant 6 . maybeCoGen coarbitrary nk . coarbitrary b
-
-instance Arbitrary NameKind where
- arbitrary = oneof $ [liftM Constructor arbitrary] ++
- map return [ Bound
- , Datatype
- , Field
- , Function
- , Module
- , Postulate
- , Primitive
- , Record
- ]
-
- shrink Constructor{} = [Bound]
- shrink _ = []
-
-instance CoArbitrary NameKind where
- coarbitrary Bound = variant 0
- coarbitrary (Constructor ind) = variant 1 . coarbitrary ind
- coarbitrary Datatype = variant 2
- coarbitrary Field = variant 3
- coarbitrary Function = variant 4
- coarbitrary Module = variant 5
- coarbitrary Postulate = variant 6
- coarbitrary Primitive = variant 7
- coarbitrary Record = variant 8
- coarbitrary Argument = variant 9
- coarbitrary Macro = variant 10
-
-instance Arbitrary OtherAspect where
- arbitrary = elements [minBound .. maxBound]
-
-instance CoArbitrary OtherAspect where
- coarbitrary = coarbitrary . fromEnum
-
-instance Arbitrary Aspects where
- arbitrary = do
- aspect <- arbitrary
- other <- arbitrary
- note <- maybeGen string
- defSite <- arbitrary
- return (Aspects { aspect = aspect, otherAspects = other
- , note = note, definitionSite = defSite })
- where string = listOfElements "abcdefABCDEF/\\.\"'@()åäö\n"
-
- 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 Aspects where
- coarbitrary (Aspects aspect otherAspects note defSite) =
- coarbitrary aspect .
- coarbitrary otherAspects .
- coarbitrary note .
- coarbitrary defSite
-
-instance Arbitrary File where
- arbitrary = fmap (File . IntMap.fromList) $ listOf arbitrary
- shrink = map (File . IntMap.fromList) . shrink . IntMap.toList . toMap
-
-instance CoArbitrary File where
- coarbitrary (File rs) = coarbitrary (IntMap.toAscList rs)
-
-instance Arbitrary CompressedFile where
- arbitrary = do
- rs <- (\ns1 ns2 -> toRanges $ sort $
- ns1 ++ concatMap (\n -> [n, succ n]) (ns2 :: [Int])) <$>
- arbitrary <*> arbitrary
- CompressedFile <$> mapM (\r -> (,) r <$> arbitrary) rs
- where
- toRanges (f : t : rs)
- | f == t = toRanges (t : rs)
- | otherwise = Range { from = f, to = t } :
- toRanges (case rs of
- f : rs | t == f -> rs
- _ -> rs)
- toRanges _ = []
-
- shrink (CompressedFile f) = CompressedFile <$> shrink f
-
-------------------------------------------------------------------------
--- All tests
-
--- | All the properties.
-
-tests :: IO Bool
-tests = runTests "Agda.Interaction.Highlighting.Precise"
- [ quickCheck' compressedFileInvariant
- , quickCheck' (all compressedFileInvariant . shrink)
- , quickCheck' (\r m -> compressedFileInvariant $ singletonC r m)
- , quickCheck' (\rs m -> compressedFileInvariant $ severalC rs m)
- , quickCheck' (\f1 f2 -> compressedFileInvariant $ mergeC f1 f2)
- , quickCheck' (\i f -> all compressedFileInvariant $
- (\(f1, f2) -> [f1, f2]) $
- splitAtC i f)
- , quickCheck' prop_compress
- , quickCheck' prop_singleton
- , quickCheck' prop_several
- , quickCheck' prop_merge
- , quickCheck' prop_splitAtC
- , quickCheck' prop_smallestPos
- ]
diff --git a/src/full/Agda/Interaction/Highlighting/Range.hs b/src/full/Agda/Interaction/Highlighting/Range.hs
index 0f04e1b..96d8c0a 100644
--- a/src/full/Agda/Interaction/Highlighting/Range.hs
+++ b/src/full/Agda/Interaction/Highlighting/Range.hs
@@ -14,7 +14,6 @@ module Agda.Interaction.Highlighting.Range
, rToR
, rangeToEndPoints
, minus
- , Agda.Interaction.Highlighting.Range.tests
) where
import Control.Applicative ((<$>))
@@ -23,8 +22,6 @@ import Data.Typeable (Typeable)
import qualified Agda.Syntax.Position as P
import Agda.Utils.List
-import Agda.Utils.TestHelpers
-import Agda.Utils.QuickCheck
-- | Character ranges. The first character in the file has position 1.
-- Note that the 'to' position is considered to be outside of the
@@ -81,9 +78,6 @@ rangeToPositions r = [from r .. to r - 1]
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'.
rToR :: P.Range -> Ranges
@@ -123,37 +117,3 @@ minus (Ranges rs1) (Ranges rs2) = Ranges (m rs1 rs2)
m (Range { from = from y, to = to x } : xs) (y:ys)
| 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
-
-------------------------------------------------------------------------
--- Generators
-
-instance Arbitrary Range where
- arbitrary = do
- [from, to] <- fmap sort $ vectorOf 2 positive
- return $ Range { from = from, to = to }
-
-instance CoArbitrary Range where
- coarbitrary (Range f t) = coarbitrary f . coarbitrary t
-
-instance Arbitrary Ranges where
- arbitrary = rToR <$> arbitrary
-
-------------------------------------------------------------------------
--- All tests
-
--- | All the properties.
-
-tests :: IO Bool
-tests = runTests "Agda.Interaction.Highlighting.Range"
- [ quickCheck' rangeInvariant
- , quickCheck' rangesInvariant
- , quickCheck' (rangesInvariant . rToR)
- , quickCheck' (\r1 r2 -> rangesInvariant $ r1 `minus` r2)
- , quickCheck' prop_rangesToPositions
- , quickCheck' prop_minus
- ]
diff --git a/src/full/Agda/Interaction/Imports.hs b/src/full/Agda/Interaction/Imports.hs
index 9dbc00a..eca6614 100644
--- a/src/full/Agda/Interaction/Imports.hs
+++ b/src/full/Agda/Interaction/Imports.hs
@@ -1,9 +1,4 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
+{-# LANGUAGE CPP #-}
{-| This module deals with finding imported modules and loading their
interface files.
@@ -16,8 +11,14 @@ import Control.Arrow
import Control.DeepSeq
import Control.Monad.Reader
import Control.Monad.State
+import Control.Monad.Trans.Maybe
import qualified Control.Exception as E
+#if __GLASGOW_HASKELL__ <= 708
+import Data.Foldable ( Foldable )
+import Data.Traversable ( Traversable, traverse )
+#endif
+
import Data.Function (on)
import qualified Data.Map as Map
import qualified Data.List as List
@@ -47,10 +48,12 @@ import Agda.Syntax.Internal
import Agda.TypeChecking.Errors
import Agda.TypeChecking.Reduce
+import Agda.TypeChecking.MetaVars ( openMetasToPostulates )
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Serialise
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Primitive
+import Agda.TypeChecking.Pretty as P
import Agda.TypeChecking.Rewriting (killCtxId)
import Agda.TypeChecking.DeadCode
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
@@ -68,6 +71,7 @@ import Agda.Interaction.Highlighting.Vim
import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.FileName
import Agda.Utils.Lens
+import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.IO.Binary
@@ -123,13 +127,13 @@ addImportedThings ::
Set String -> -- UHC backend imports
A.PatternSynDefns -> DisplayForms -> TCM ()
addImportedThings isig ibuiltin hsImports hsImportsUHC patsyns display = do
- stImports %= \imp -> unionSignatures [imp, over sigRewriteRules killCtxId isig]
- stImportedBuiltins %= \imp -> Map.union imp ibuiltin
- stHaskellImports %= \imp -> Set.union imp hsImports
- stHaskellImportsUHC %= \imp -> Set.union imp hsImportsUHC
- stPatternSynImports %= \imp -> Map.union imp patsyns
- stImportedDisplayForms %= \imp -> HMap.unionWith (++) imp display
- addSignatureInstances isig
+ stImports %= \ imp -> unionSignatures [imp, over sigRewriteRules killCtxId isig]
+ stImportedBuiltins %= \ imp -> Map.union imp ibuiltin
+ stHaskellImports %= \ imp -> Set.union imp hsImports
+ stHaskellImportsUHC %= \ imp -> Set.union imp hsImportsUHC
+ stPatternSynImports %= \ imp -> Map.union imp patsyns
+ stImportedDisplayForms %= \ imp -> HMap.unionWith (++) imp display
+ addImportedInstances isig
-- | Scope checks the given module. A proper version of the module
-- name (with correct definition sites) is returned.
@@ -149,11 +153,23 @@ scopeCheckImport x = do
let s = iScope i
return (iModuleName i `withRangesOfQ` mnameToConcrete x, s)
-data MaybeWarnings = NoWarnings | SomeWarnings Warnings
+data MaybeWarnings' a = NoWarnings | SomeWarnings a
+ deriving (Functor, Foldable, Traversable)
+type MaybeWarnings = MaybeWarnings' [TCWarning]
+
+applyFlagsToMaybeWarnings :: IgnoreFlags -> MaybeWarnings -> TCM MaybeWarnings
+applyFlagsToMaybeWarnings r mw = do
+ w' <- traverse (applyFlagsToTCWarnings r) mw
+ return $ if null w' then NoWarnings else w'
+
+instance Null a => Null (MaybeWarnings' a) where
+ empty = NoWarnings
+ null mws = case mws of
+ NoWarnings -> True
+ SomeWarnings ws -> null ws
hasWarnings :: MaybeWarnings -> Bool
-hasWarnings NoWarnings = False
-hasWarnings SomeWarnings{} = True
+hasWarnings = not . null
-- | If the module has already been visited (without warnings), then
-- its interface is returned directly. Otherwise the computation is
@@ -232,8 +248,13 @@ getInterface_ :: C.TopLevelModuleName -> TCM Interface
getInterface_ x = do
(i, wt) <- getInterface' x NotMainInterface
case wt of
- SomeWarnings w -> warningsToError w
+ SomeWarnings w -> tcWarningsToError (filter (notIM . tcWarning) w)
NoWarnings -> return i
+ -- filter out unsolved interaction points for imported module so
+ -- that we get the right error message (see test case Fail/Issue1296)
+ where notIM UnsolvedInteractionMetas{} = False
+ notIM _ = True
+
-- | A more precise variant of 'getInterface'. If warnings are
-- encountered then they are returned instead of being turned into
@@ -244,6 +265,7 @@ getInterface'
-> MainInterface
-- ^ If type checking is necessary,
-- should all state changes inflicted by 'createInterface' be preserved?
+ -- Yes, if we are the 'MainInterface'. No, if we are 'NotMainInterface'.
-> TCM (Interface, MaybeWarnings)
getInterface' x isMain = do
withIncreasedModuleNestingLevel $ do
@@ -261,8 +283,9 @@ getInterface' x isMain = do
uptodate <- Bench.billTo [Bench.Import] $ do
ignore <- ignoreInterfaces
- cached <- isCached file -- if it's cached ignoreInterfaces has no effect
- -- to avoid typechecking a file more than once
+ cached <- runMaybeT $ isCached x file
+ -- If it's cached ignoreInterfaces has no effect;
+ -- to avoid typechecking a file more than once.
sourceH <- liftIO $ hashFile file
ifaceH <-
case cached of
@@ -282,7 +305,9 @@ getInterface' x isMain = do
-- let maySkip = isMain == NotMainInterface
-- Andreas, 2015-07-13: Serialize iInsideScope again.
let maySkip = True
- if uptodate && maySkip then skip file else typeCheckThe file
+ if uptodate && maySkip
+ then getStoredInterface x file includeStateChanges
+ else typeCheck x file includeStateChanges
-- Ensure that the given module name matches the one in the file.
let topLevelName = toTopLevelModuleName $ iModuleName i
@@ -312,158 +337,219 @@ getInterface' x isMain = do
where
includeStateChanges = isMain == MainInterface
- isCached file = do
- let ifile = filePath $ toIFile file
- exist <- liftIO $ doesFileExistCaseSensitive ifile
- if not exist
- then return Nothing
- else do
- h <- fmap snd <$> getInterfaceFileHashes ifile
- mm <- getDecodedModule x
- return $ case mm of
- Just mi | Just (iFullHash mi) == h -> Just mi
- _ -> Nothing
-
- -- Formats the "Checking", "Finished" and "Skipping" messages.
- chaseMsg kind file = do
- nesting <- envModuleNestingLevel <$> ask
- let s = genericReplicate nesting ' ' ++ kind ++
- " " ++ prettyShow x ++
- case file of
- Nothing -> "."
- Just f -> " (" ++ f ++ ")."
- reportSLn "import.chase" 1 s
-
- skip file = do
- -- Examine the hash of the interface file. If it is different from the
- -- stored version (in stDecodedModules), or if there is no stored version,
- -- read and decode it. Otherwise use the stored version.
- let ifile = filePath $ toIFile file
- h <- fmap snd <$> getInterfaceFileHashes ifile
- mm <- getDecodedModule x
- (cached, mi) <- Bench.billTo [Bench.Deserialization] $ case mm of
- Just mi ->
- if Just (iFullHash mi) /= h
- then do dropDecodedModule x
- reportSLn "import.iface" 50 $ " cached hash = " ++ show (iFullHash mi)
- reportSLn "import.iface" 50 $ " stored hash = " ++ show h
- reportSLn "import.iface" 5 $ " file is newer, re-reading " ++ ifile
- (False,) <$> readInterface ifile
- else do reportSLn "import.iface" 5 $ " using stored version of " ++ ifile
- return (True, Just mi)
- Nothing -> do
- reportSLn "import.iface" 5 $ " no stored version, reading " ++ ifile
- (False,) <$> readInterface ifile
-
- -- Check that it's the right version
- case mi of
- Nothing -> do
- reportSLn "import.iface" 5 $ " bad interface, re-type checking"
- typeCheckThe file
- Just i -> do
-
- reportSLn "import.iface" 5 $ " imports: " ++ show (iImportedModules i)
-
- hs <- map iFullHash <$> mapM getInterface (map fst $ iImportedModules i)
-
- -- If any of the imports are newer we need to retype check
- if hs /= map snd (iImportedModules i)
- then do
- -- liftIO close -- Close the interface file. See above.
- typeCheckThe file
- else do
- unless cached $ chaseMsg "Skipping" (Just ifile)
- -- We set the pragma options of the skipped file here,
- -- because if the top-level file is skipped we want the
- -- pragmas to apply to interactive commands in the UI.
- mapM_ setOptionsFromPragma (iPragmaOptions i)
- return (False, (i, NoWarnings))
-
- typeCheckThe file = do
- unless includeStateChanges cleanCachedLog
- let withMsgs = bracket_
- (chaseMsg "Checking" $ Just $ filePath file)
- (const $ chaseMsg "Finished" Nothing)
-
- -- Do the type checking.
-
- if includeStateChanges then do
- r <- withMsgs $ createInterface file x
-
- -- Merge the signature with the signature for imported
- -- things.
- sig <- getSignature
- patsyns <- getPatternSyns
- display <- use stImportsDisplayForms
- addImportedThings sig Map.empty Set.empty Set.empty patsyns display
- setSignature emptySignature
- setPatternSyns Map.empty
-
- return (True, r)
- else do
- ms <- getImportPath
- nesting <- asks envModuleNestingLevel
- range <- asks envRange
- call <- asks envCall
- mf <- use stModuleToSource
- vs <- getVisitedModules
- ds <- getDecodedModules
- opts <- stPersistentOptions . stPersistentState <$> get
- isig <- getImportedSignature
- ibuiltin <- use stImportedBuiltins
- display <- use stImportsDisplayForms
- ipatsyns <- getPatternSynImports
- ho <- getInteractionOutputCallback
- -- Every interface is treated in isolation. Note: Changes
- -- to stDecodedModules are not preserved if an error is
- -- encountered in an imported module.
- -- Andreas, 2014-03-23: freshTCM spawns a new TCM computation
- -- with initial state and environment
- -- but on the same Benchmark accounts.
- r <- freshTCM $
- withImportPath ms $
- local (\e -> e { envModuleNestingLevel = nesting
- -- Andreas, 2014-08-18:
- -- Preserve the range of import statement
- -- for reporting termination errors in
- -- imported modules:
- , envRange = range
- , envCall = call
- }) $ do
- setDecodedModules ds
- setCommandLineOptions opts
- setInteractionOutputCallback ho
- stModuleToSource .= mf
- setVisitedModules vs
- addImportedThings isig ibuiltin Set.empty Set.empty ipatsyns display
-
- r <- withMsgs $ createInterface file x
- mf <- use stModuleToSource
- ds <- getDecodedModules
- return (r, do
- stModuleToSource .= mf
- setDecodedModules ds
- case r of
- (i, NoWarnings) -> storeDecodedModule i
- _ -> return ()
- )
-
- case r of
- Left err -> throwError err
- Right (r, update) -> do
- update
- case r of
- (_, NoWarnings) ->
- -- We skip the file which has just been type-checked to
- -- be able to forget some of the local state from
- -- checking the module.
- -- Note that this doesn't actually read the interface
- -- file, only the cached interface.
- skip file
- _ -> return (False, r)
-
--- | Print the highlighting information contained in the given
--- interface.
+-- | Check whether interface file exists and is in cache
+-- in the correct version (as testified by the interface file hash).
+
+isCached
+ :: C.TopLevelModuleName
+ -- ^ Module name of file we process.
+ -> AbsolutePath
+ -- ^ File we process.
+ -> MaybeT TCM Interface
+
+isCached x file = do
+ let ifile = filePath $ toIFile file
+
+ -- Make sure the file exists in the case sensitive spelling.
+ guardM $ liftIO $ doesFileExistCaseSensitive ifile
+
+ -- Check that we have cached the module.
+ mi <- MaybeT $ getDecodedModule x
+
+ -- Check that the interface file exists and return its hash.
+ h <- MaybeT $ fmap snd <$> getInterfaceFileHashes ifile
+
+ -- Make sure the hashes match.
+ guard $ iFullHash mi == h
+
+ return mi
+
+
+-- | Try to get the interface from interface file or cache.
+
+getStoredInterface
+ :: C.TopLevelModuleName
+ -- ^ Module name of file we process.
+ -> AbsolutePath
+ -- ^ File we process.
+ -> Bool
+ -- ^ If type checking is necessary,
+ -- should all state changes inflicted by 'createInterface' be preserved?
+ -- @True@, if we are the 'MainInterface'. @False@, if we are 'NotMainInterface'.
+ -> TCM (Bool, (Interface, MaybeWarnings))
+ -- ^ @Bool@ is: do we have to merge the interface?
+getStoredInterface x file includeStateChanges = do
+ -- If something goes wrong (interface outdated etc.)
+ -- we revert to fresh type checking.
+ let fallback = typeCheck x file includeStateChanges
+
+ -- Examine the hash of the interface file. If it is different from the
+ -- stored version (in stDecodedModules), or if there is no stored version,
+ -- read and decode it. Otherwise use the stored version.
+ let ifile = filePath $ toIFile file
+ h <- fmap snd <$> getInterfaceFileHashes ifile
+ mm <- getDecodedModule x
+ (cached, mi) <- Bench.billTo [Bench.Deserialization] $ case mm of
+ Just mi ->
+ if Just (iFullHash mi) /= h
+ then do
+ dropDecodedModule x
+ reportSLn "import.iface" 50 $ " cached hash = " ++ show (iFullHash mi)
+ reportSLn "import.iface" 50 $ " stored hash = " ++ show h
+ reportSLn "import.iface" 5 $ " file is newer, re-reading " ++ ifile
+ (False,) <$> readInterface ifile
+ else do
+ reportSLn "import.iface" 5 $ " using stored version of " ++ ifile
+ return (True, Just mi)
+ Nothing -> do
+ reportSLn "import.iface" 5 $ " no stored version, reading " ++ ifile
+ (False,) <$> readInterface ifile
+
+ -- Check that it's the right version
+ case mi of
+ Nothing -> do
+ reportSLn "import.iface" 5 $ " bad interface, re-type checking"
+ fallback
+ Just i -> do
+ reportSLn "import.iface" 5 $ " imports: " ++ show (iImportedModules i)
+
+ hs <- map iFullHash <$> mapM getInterface (map fst $ iImportedModules i)
+
+ -- If any of the imports are newer we need to retype check
+ if hs /= map snd (iImportedModules i)
+ then do
+ -- liftIO close -- Close the interface file. See above.
+ fallback
+ else do
+ unless cached $ chaseMsg "Skipping" x $ Just ifile
+ -- We set the pragma options of the skipped file here,
+ -- because if the top-level file is skipped we want the
+ -- pragmas to apply to interactive commands in the UI.
+ mapM_ setOptionsFromPragma (iPragmaOptions i)
+ return (False, (i, NoWarnings))
+
+-- | Run the type checker on a file and create an interface.
+--
+-- Mostly, this function calls 'createInterface'.
+-- But if it is not the main module we check,
+-- we do it in a fresh state, suitably initialize,
+-- in order to forget some state changes after successful type checking.
+
+typeCheck
+ :: C.TopLevelModuleName
+ -- ^ Module name of file we process.
+ -> AbsolutePath
+ -- ^ File we process.
+ -> Bool
+ -- ^ If type checking is necessary,
+ -- should all state changes inflicted by 'createInterface' be preserved?
+ -- @True@, if we are the 'MainInterface'. @False@, if we are 'NotMainInterface'.
+ -> TCM (Bool, (Interface, MaybeWarnings))
+ -- ^ @Bool@ is: do we have to merge the interface?
+typeCheck x file includeStateChanges = do
+ unless includeStateChanges cleanCachedLog
+ let withMsgs = bracket_
+ (chaseMsg "Checking" x $ Just $ filePath file)
+ (const $ do ws <- getAllWarnings' AllWarnings RespectFlags
+ let (we, wa) = classifyWarnings ws
+ unless (null wa) $ reportSDoc "warning" 1
+ $ P.vcat $ P.prettyTCM <$> wa
+ unless (not $ null we) $ chaseMsg "Finished" x Nothing)
+
+ -- Do the type checking.
+
+ if includeStateChanges then do
+ r <- withMsgs $ createInterface file x includeStateChanges
+
+ -- Merge the signature with the signature for imported
+ -- things.
+ reportSLn "import.iface" 40 $ "Merging with state changes included."
+ sig <- getSignature
+ patsyns <- getPatternSyns
+ display <- use stImportsDisplayForms
+ addImportedThings sig Map.empty Set.empty Set.empty patsyns display
+ setSignature emptySignature
+ setPatternSyns Map.empty
+
+ return (True, r)
+ else do
+ ms <- getImportPath
+ nesting <- asks envModuleNestingLevel
+ range <- asks envRange
+ call <- asks envCall
+ mf <- use stModuleToSource
+ vs <- getVisitedModules
+ ds <- getDecodedModules
+ opts <- stPersistentOptions . stPersistentState <$> get
+ isig <- use stImports
+ ibuiltin <- use stImportedBuiltins
+ display <- use stImportsDisplayForms
+ ipatsyns <- getPatternSynImports
+ ho <- getInteractionOutputCallback
+ -- Every interface is treated in isolation. Note: Changes
+ -- to stDecodedModules are not preserved if an error is
+ -- encountered in an imported module.
+ -- Andreas, 2014-03-23: freshTCM spawns a new TCM computation
+ -- with initial state and environment
+ -- but on the same Benchmark accounts.
+ r <- freshTCM $
+ withImportPath ms $
+ local (\e -> e { envModuleNestingLevel = nesting
+ -- Andreas, 2014-08-18:
+ -- Preserve the range of import statement
+ -- for reporting termination errors in
+ -- imported modules:
+ , envRange = range
+ , envCall = call
+ }) $ do
+ setDecodedModules ds
+ setCommandLineOptions opts
+ setInteractionOutputCallback ho
+ stModuleToSource .= mf
+ setVisitedModules vs
+ addImportedThings isig ibuiltin Set.empty Set.empty ipatsyns display
+
+ r <- withMsgs $ createInterface file x includeStateChanges
+ mf <- use stModuleToSource
+ ds <- getDecodedModules
+ return (r, do
+ stModuleToSource .= mf
+ setDecodedModules ds
+ case r of
+ (i, NoWarnings) -> storeDecodedModule i
+ _ -> return ()
+ )
+
+ case r of
+ Left err -> throwError err
+ Right (r, update) -> do
+ update
+ case r of
+ (_, NoWarnings) ->
+ -- We skip the file which has just been type-checked to
+ -- be able to forget some of the local state from
+ -- checking the module.
+ -- Note that this doesn't actually read the interface
+ -- file, only the cached interface.
+ getStoredInterface x file includeStateChanges
+ _ -> return (False, r)
+
+
+-- | Formats and outputs the "Checking", "Finished" and "Skipping" messages.
+
+chaseMsg
+ :: String -- ^ The prefix, like @Checking@, @Finished@, @Skipping@.
+ -> C.TopLevelModuleName -- ^ The module name.
+ -> Maybe String -- ^ Optionally: the file name.
+ -> TCM ()
+chaseMsg kind x file = do
+ indentation <- (`replicate` ' ') <$> asks envModuleNestingLevel
+ let maybeFile = caseMaybe file "." $ \ f -> " (" ++ f ++ ")."
+ reportSLn "import.chase" 1 $ concat $
+ [ indentation, kind, " ", prettyShow x, maybeFile ]
+
+
+-- | Print the highlighting information contained in the given interface.
highlightFromInterface
:: Interface
@@ -476,6 +562,7 @@ highlightFromInterface i file = do
" (read from interface)."
printHighlightingInfo (iHighlighting i)
+
readInterface :: FilePath -> TCM (Maybe Interface)
readInterface file = do
-- Decode the interface file
@@ -503,8 +590,7 @@ readInterface file = do
-- document.
_ -> throwError e
--- | Writes the given interface to the given file. Returns the file's
--- new modification time stamp, or 'Nothing' if the write failed.
+-- | Writes the given interface to the given file.
writeInterface :: FilePath -> Interface -> TCM ()
writeInterface file i = do
@@ -543,8 +629,9 @@ removePrivates si = si { scopeModules = restrictPrivate <$> scopeModules si }
createInterface
:: AbsolutePath -- ^ The file to type check.
-> C.TopLevelModuleName -- ^ The expected module name.
+ -> Bool
-> TCM (Interface, MaybeWarnings)
-createInterface file mname =
+createInterface file mname isMain =
local (\e -> e { envCurrentPath = Just file }) $ do
modFile <- use stModuleToSource
fileTokenInfo <- Bench.billTo [Bench.Highlighting] $
@@ -563,7 +650,7 @@ createInterface file mname =
-- Parsing.
(pragmas, top) <- Bench.billTo [Bench.Parsing] $
- liftIO $ parseFile' moduleParser file
+ runPM $ parseFile' moduleParser file
pragmas <- concat <$> concreteToAbstract_ pragmas
-- identity for top-level pragmas at the moment
@@ -576,7 +663,7 @@ createInterface file mname =
-- Scope checking.
reportSLn "import.iface.create" 7 $ "Starting scope checking."
topLevel <- Bench.billTo [Bench.Scoping] $
- concreteToAbstract_ (TopLevel file top)
+ concreteToAbstract_ (TopLevel file mname top)
reportSLn "import.iface.create" 7 $ "Finished scope checking."
let ds = topLevelDecls topLevel
@@ -643,10 +730,35 @@ createInterface file mname =
setScope scope
reportSLn "scope.top" 50 $ "SCOPE " ++ show scope
+ -- TODO: It would be nice if unsolved things were highlighted
+ -- after every mutual block.
+
+ openMetas <- getOpenMetas
+ unless (null openMetas) $ do
+ reportSLn "import.metas" 10 "We have unsolved metas."
+ reportSLn "import.metas" 10 . unlines =<< showOpenMetas
+
+ ifTopLevelAndHighlightingLevelIs NonInteractive $
+ printUnsolvedInfo
+
+ -- Andreas, 2016-08-03, issue #964
+ -- When open metas are allowed,
+ -- permanently freeze them now by turning them into postulates.
+ -- This will enable serialization.
+ -- savedMetaStore <- use stMetaStore
+ unless isMain $
+ whenM (optAllowUnsolved <$> pragmaOptions) $ do
+ withCurrentModule (scopeCurrent scope) $
+ openMetasToPostulates
+ -- Clear constraints as they might refer to what
+ -- they think are open metas.
+ stAwakeConstraints .= []
+ stSleepingConstraints .= []
+
-- Serialization.
reportSLn "import.iface.create" 7 $ "Starting serialization."
syntaxInfo <- use stSyntaxInfo
- i <- Bench.billTo [Bench.Serialization] $ do
+ i <- Bench.billTo [Bench.Serialization, Bench.BuildInterface] $ do
buildInterface file topLevel syntaxInfo previousHsImports previousHsImportsUHC options
reportSLn "tc.top" 101 $ concat $
@@ -658,31 +770,22 @@ createInterface file mname =
]
reportSLn "import.iface.create" 7 $ "Finished serialization."
- -- TODO: It would be nice if unsolved things were highlighted
- -- after every mutual block.
-
- openMetas <- getOpenMetas
- unless (null openMetas) $ do
- reportSLn "import.metas" 10 "We have unsolved metas."
- reportSLn "import.metas" 10 . unlines =<< showOpenMetas
- unsolvedMetas <- List.nub <$> mapM getMetaRange openMetas
- unsolvedConstraints <- getAllConstraints
- interactionPoints <- getInteractionPoints
+ mallWarnings <- getAllWarnings ErrorWarnings
+ $ if isMain then IgnoreFlags else RespectFlags
- ifTopLevelAndHighlightingLevelIs NonInteractive $
- printUnsolvedInfo
+ reportSLn "import.iface.create" 7 $ "Considering writing to interface file."
+ case mallWarnings of
+ SomeWarnings allWarnings -> return ()
+ NoWarnings -> Bench.billTo [Bench.Serialization] $ do
+ -- The file was successfully type-checked (and no warnings were
+ -- encountered), so the interface should be written out.
+ let ifile = filePath $ toIFile file
+ writeInterface ifile i
+ reportSLn "import.iface.create" 7 $ "Finished (or skipped) writing to interface file."
- reportSLn "import.iface.create" 7 $ "Starting writing to interface file."
- r <- if and [ null unsolvedMetas, null unsolvedConstraints, null interactionPoints ]
- then Bench.billTo [Bench.Serialization] $ do
- -- The file was successfully type-checked (and no warnings were
- -- encountered), so the interface should be written out.
- let ifile = filePath $ toIFile file
- writeInterface ifile i
- return (i, NoWarnings)
- else do
- return (i, SomeWarnings $ Warnings unsolvedMetas unsolvedConstraints)
- reportSLn "import.iface.create" 7 $ "Finished writing to interface file."
+ -- -- Restore the open metas, as we might continue in interaction mode.
+ -- Actually, we do not serialize the metas if checking the MainInterface
+ -- stMetaStore .= savedMetaStore
-- Profiling: Print statistics.
printStatistics 30 (Just mname) =<< getStatistics
@@ -694,7 +797,58 @@ createInterface file mname =
verboseS "profile" 1 $ do
reportSLn "import.iface" 5 $ "Accumulated statistics."
- return $ first constructIScope r
+ return $ first constructIScope (i, mallWarnings)
+
+-- | Collect all warnings that have accumulated in the state.
+-- Depending on the argument, we either respect the flags passed
+-- in by the user, or not (for instance when deciding if we are
+-- writing an interface file or not)
+
+data WhichWarnings = ErrorWarnings | AllWarnings
+ -- ^ order of constructors important for derived Ord instance
+ deriving (Eq, Ord)
+
+classifyWarning :: Warning -> WhichWarnings
+classifyWarning w = case w of
+ OldBuiltin{} -> AllWarnings
+ EmptyRewritePragma -> AllWarnings
+ TerminationIssue{} -> ErrorWarnings
+ NotStrictlyPositive{} -> ErrorWarnings
+ UnsolvedMetaVariables{} -> ErrorWarnings
+ UnsolvedInteractionMetas{} -> ErrorWarnings
+ UnsolvedConstraints{} -> ErrorWarnings
+ ParseWarning{} -> ErrorWarnings
+
+classifyWarnings :: [TCWarning] -> ([TCWarning], [TCWarning])
+classifyWarnings = partition $ (< AllWarnings) . classifyWarning . tcWarning
+
+getAllWarnings' :: WhichWarnings -> IgnoreFlags -> TCM [TCWarning]
+getAllWarnings' ww ifs = do
+ openMetas <- getOpenMetas
+ interactionMetas <- getInteractionMetas
+ let getUniqueMetas = fmap List.nub . mapM getMetaRange
+ unsolvedInteractions <- getUniqueMetas interactionMetas
+ unsolvedMetas <- getUniqueMetas (openMetas List.\\ interactionMetas)
+ unsolvedConstraints <- getAllConstraints
+ collectedTCWarnings <- use stTCWarnings
+
+ unsolved <- mapM warning_
+ [ UnsolvedInteractionMetas unsolvedInteractions
+ , UnsolvedMetaVariables unsolvedMetas
+ , UnsolvedConstraints unsolvedConstraints ]
+
+ fmap (filter ((<= ww) . classifyWarning . tcWarning))
+ $ applyFlagsToTCWarnings ifs $ reverse
+ $ unsolved ++ collectedTCWarnings
+
+getAllWarnings :: WhichWarnings -> IgnoreFlags -> TCM MaybeWarnings
+getAllWarnings ww ifs = do
+ allWarnings <- getAllWarnings' ww ifs
+ return $ if null allWarnings
+ -- Andreas, issue 964: not checking null interactionPoints
+ -- anymore; we want to serialize with open interaction points now!
+ then NoWarnings
+ else SomeWarnings allWarnings
-- constructIScope :: ScopeInfo -> Map ModuleName Scope
constructIScope :: Interface -> Interface
@@ -740,7 +894,7 @@ buildInterface file topLevel syntaxInfo previousHsImports previousHsImportsUHC p
-- Ulf, 2016-04-12:
-- Non-closed display forms are not applicable outside the module anyway,
-- and should be dead-code eliminated (#1928).
- display <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> use stImportsDisplayForms
+ display <- HMap.filter (not . null) . HMap.map (filter isGlobal) <$> use stImportsDisplayForms
-- TODO: Kill some ranges?
(display, sig) <- eliminateDeadCode display =<< getSignature
-- Andreas, 2015-02-09 kill ranges in pattern synonyms before
diff --git a/src/full/Agda/Interaction/InteractionTop.hs b/src/full/Agda/Interaction/InteractionTop.hs
index 4b68779..9f11ff9 100644
--- a/src/full/Agda/Interaction/InteractionTop.hs
+++ b/src/full/Agda/Interaction/InteractionTop.hs
@@ -1,12 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-cse #-}
@@ -49,6 +42,7 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Position
import Agda.Syntax.Parser
import Agda.Syntax.Common
+import Agda.Syntax.Literal
import Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Generic as C
import Agda.Syntax.Concrete.Pretty ()
@@ -67,13 +61,14 @@ import Agda.Interaction.SearchAbout
import Agda.Interaction.Response hiding (Function, ExtendedLambda)
import qualified Agda.Interaction.Response as R
import qualified Agda.Interaction.BasicOps as B
+import Agda.Interaction.BasicOps hiding (whyInScope)
import Agda.Interaction.Highlighting.Precise hiding (Postulate)
import qualified Agda.Interaction.Imports as Imp
import Agda.Interaction.Highlighting.Generate
+import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX
import qualified Agda.Interaction.Highlighting.Range as H
import Agda.Compiler.Common (IsMain (..))
-import qualified Agda.Compiler.Epic.Compiler as Epic
import qualified Agda.Compiler.MAlonzo.Compiler as MAlonzo
import qualified Agda.Compiler.JS.Compiler as JS
@@ -87,6 +82,7 @@ import Agda.Utils.Except
)
import Agda.Utils.FileName
+import Agda.Utils.Function
import Agda.Utils.Hash
import qualified Agda.Utils.HashMap as HMap
import Agda.Utils.Lens
@@ -144,6 +140,22 @@ initCommandState = CommandState
type CommandM = StateT CommandState TCM
+-- | Restore both 'TCState' and 'CommandState'.
+
+localStateCommandM :: CommandM a -> CommandM a
+localStateCommandM m = do
+ cSt <- get
+ tcSt <- lift $ get
+ x <- m
+ lift $ put tcSt
+ put cSt
+ return x
+
+-- | Restore 'TCState', do not touch 'CommandState'.
+
+liftLocalState :: TCM a -> CommandM a
+liftLocalState = lift . localState
+
-- | Build an opposite action to 'lift' for state monads.
revLift
@@ -168,6 +180,11 @@ commandMToIO ci_i = revLift runStateT lift $ \ct -> revLift runSafeTCM liftIO $
liftCommandMT :: (forall a . TCM a -> TCM a) -> CommandM a -> CommandM a
liftCommandMT f m = revLift runStateT lift $ f . ($ m)
+-- | Ditto, but restore state.
+
+liftCommandMTLocalState :: (forall a . TCM a -> TCM a) -> CommandM a -> CommandM a
+liftCommandMTLocalState f = liftCommandMT f . localStateCommandM
+
-- | Put a response by the callback function given by 'stInteractionOutputCallback'.
putResponse :: Response -> CommandM ()
@@ -212,8 +229,24 @@ handleCommand_ = handleCommand id (return ())
handleCommand :: (forall a. CommandM a -> CommandM a) -> CommandM () -> CommandM () -> CommandM ()
handleCommand wrap onFail cmd = handleNastyErrors $ wrap $ do
- res <- (`catchErr` (return . Just)) $ Nothing <$ cmd
- maybe (return ()) (\ e -> onFail >> handleErr e) res
+ tcSt <- lift get
+
+ -- -- Andreas, 2016-11-18 OLD CODE:
+ -- -- onFail and handleErr are executed in "new" command state (not TCState).
+ -- -- But it seems that if an exception is raised, it is identical to the old state,
+ -- -- see code for catchErr.
+ -- res <- (`catchErr` (return . Just)) $ Nothing <$ cmd
+ -- maybe (return ()) (\ e -> onFail >> handleErr e) res
+
+ -- Andreas, 2016-11-18 NEW CODE: execute onFail and handleErr in handler
+ -- which means (looking at catchErr) they run in state s rathern than s'.
+ -- Yet, it looks like s == s' in case the command failed.
+ cmd `catchErr` \ e -> do
+ onFail
+ handleErr e
+ -- Andreas, 2016-11-18, issue #2174
+ -- Reset TCState after error is handled, to get rid of metas created during failed command
+ lift $ put tcSt
where
-- Preserves state so we can do unsolved meta highlighting
@@ -237,16 +270,17 @@ handleCommand wrap onFail cmd = handleNastyErrors $ wrap $ do
-- error. Because this function may switch the focus to another file
-- the status information is also updated.
handleErr e = do
+ unsolvedNotOK <- lift $ not . optAllowUnsolved <$> pragmaOptions
meta <- lift $ computeUnsolvedMetaWarnings
constr <- lift $ computeUnsolvedConstraints
err <- lift $ errorHighlighting e
modFile <- lift $ use stModuleToSource
- let info = compress $ mconcat
+ let info = compress $ mconcat $
-- Errors take precedence over unsolved things.
- [err, meta, constr]
+ err : if unsolvedNotOK then [meta, constr] else []
s <- lift $ prettyError e
x <- lift $ optShowImplicit <$> use stPragmaOptions
- mapM_ putResponse $
+ unless (null s) $ mapM_ putResponse $
[ Resp_DisplayInfo $ Info_Error s ] ++
tellEmacsToJumpToError (getRange e) ++
[ Resp_HighlightingInfo info modFile ] ++
@@ -306,6 +340,9 @@ data Interaction' range
-- show those instead.
| Cmd_metas
+ -- | Display all warnings.
+ | Cmd_warnings
+
-- | Shows all the top-level names in the given module, along with
-- their types. Uses the top-level scope.
| Cmd_show_module_contents_toplevel
@@ -316,7 +353,10 @@ data Interaction' range
-- identifiers in their type.
| Cmd_search_about_toplevel B.Rewrite String
- | Cmd_solveAll
+ -- | Solve (all goals / the goal at point) whose values are determined by
+ -- the constraints.
+ | Cmd_solveAll B.Rewrite
+ | Cmd_solveOne B.Rewrite InteractionId range String
-- | Parse the given expression (as if it were defined at the
-- top-level of the current module) and infer its type.
@@ -326,7 +366,7 @@ data Interaction' range
-- | Parse and type check the given expression (as if it were defined
-- at the top-level of the current module) and normalise it.
- | Cmd_compute_toplevel Bool -- Ignore abstract?
+ | Cmd_compute_toplevel B.ComputeMode
String
------------------------------------------------------------------------
@@ -403,7 +443,7 @@ data Interaction' range
| Cmd_make_case InteractionId range String
- | Cmd_compute Bool -- Ignore abstract?
+ | Cmd_compute B.ComputeMode
InteractionId range String
| Cmd_why_in_scope InteractionId range String
@@ -519,14 +559,15 @@ interpret (Cmd_load m argv) =
cmd_load' m argv True $ \_ -> interpret Cmd_metas
interpret (Cmd_compile b file argv) =
- cmd_load' file argv False $ \(i, mw) -> do
+ cmd_load' file argv (b == LaTeX) $ \(i, mw) -> do
+ mw <- lift $ Imp.applyFlagsToMaybeWarnings RespectFlags mw
case mw of
Imp.NoWarnings -> do
lift $ case b of
- MAlonzo -> MAlonzo.compilerMain IsMain i
- MAlonzoNoMain -> MAlonzo.compilerMain NotMain i
- Epic -> Epic.compilerMain i
- JS -> JS.compilerMain i
+ GHC -> MAlonzo.compilerMain IsMain i
+ GHCNoMain -> MAlonzo.compilerMain NotMain i
+ JS -> JS.compilerMain i
+ LaTeX -> LaTeX.generateLaTeX i
display_info $ Info_CompilationOk
Imp.SomeWarnings w ->
display_info $ Info_Error $ unlines
@@ -538,11 +579,17 @@ interpret Cmd_constraints =
display_info . Info_Constraints . unlines . map show =<< lift B.getConstraints
interpret Cmd_metas = do -- CL.showMetas []
- ms <- lift $ showOpenMetas
- -- If we do not have open metas, but open constaints, display those.
- ifM (return (null ms) `and2M` do not . null <$> lift B.getConstraints)
- {-then-} (interpret Cmd_constraints)
- {-else-} (display_info $ Info_AllGoals $ unlines ms)
+ unsolvedNotOK <- lift $ not . optAllowUnsolved <$> pragmaOptions
+ ms <- lift showOpenMetas
+ (pwe, pwa) <- interpretWarnings
+ display_info $ Info_AllGoalsWarnings (unlines ms) pwa pwe
+
+interpret Cmd_warnings = do
+ -- Ulf, 2016-08-09: Warnings are now printed in the info buffer by Cmd_metas.
+ -- pws <- interpretWarnings
+ -- unless (null pwd) $ display_info $ Info_Warning pws
+ return ()
+
interpret (Cmd_show_module_contents_toplevel norm s) =
liftCommandMT B.atTopLevel $ showModuleContents norm noRange s
@@ -550,25 +597,27 @@ interpret (Cmd_show_module_contents_toplevel norm s) =
interpret (Cmd_search_about_toplevel norm s) =
liftCommandMT B.atTopLevel $ searchAbout norm noRange s
-interpret Cmd_solveAll = do
- out <- lift $ mapM lowr =<< B.getSolvedInteractionPoints False -- only solve metas which have a proper instantiation, i.e., not another meta
- putResponse $ Resp_SolveAll out
- where
- lowr (i, m, e) = do
- mi <- getMetaInfo <$> lookupMeta m
- e <- withMetaInfo mi $ lowerMeta <$> abstractToConcreteCtx TopCtx e
- return (i, e)
+interpret (Cmd_solveAll norm) = solveInstantiatedGoals norm Nothing
+interpret (Cmd_solveOne norm ii _ _) = solveInstantiatedGoals norm' (Just ii)
+ -- `solveOne` is called via `agda2-maybe-normalised` which does not use
+ -- AsIs < Simplified < Normalised but rather Simplified < Instantiated < Normalised
+ -- So we remap the Rewrite modifiers to match solveAll's behaviour.
+ -- NB: instantiate is called in getSolvedInteractionPoints no matter what.
+ where norm' = case norm of
+ Simplified -> AsIs
+ Instantiated -> Simplified
+ _ -> norm
interpret (Cmd_infer_toplevel norm s) =
parseAndDoAtToplevel (B.typeInCurrent norm) Info_InferredType s
-interpret (Cmd_compute_toplevel ignore s) =
- parseAndDoAtToplevel (allowNonTerminatingReductions .
- if ignore then ignoreAbstractMode . c
- else inConcreteMode . c)
- Info_NormalForm
- s
- where c = B.evalInCurrent
+interpret (Cmd_compute_toplevel cmode s) =
+ parseAndDoAtToplevel' action Info_NormalForm $ computeWrapInput cmode s
+ where
+ action = allowNonTerminatingReductions
+ . (if computeIgnoreAbstract cmode then ignoreAbstractMode else inConcreteMode)
+ . (B.showComputed cmode <=< B.evalInCurrent)
+
interpret (ShowImplicitArgs showImpl) = do
opts <- lift commandLineOptions
@@ -667,7 +716,7 @@ interpret (Cmd_auto ii rng s) = do
-- For highlighting, Resp_GiveAction needs to access
-- the @oldInteractionScope@s of the interaction points solved by Auto.
-- We dig them out from the state before Auto was invoked.
- insertOldInteractionScope ii =<< lift (localState (put st >> getInteractionScope ii))
+ insertOldInteractionScope ii =<< liftLocalState (put st >> getInteractionScope ii)
-- Andreas, 2014-07-07: NOT TRUE:
-- -- Andreas, 2014-07-05: The following should be obsolete,
-- -- as Auto has removed the interaction points already:
@@ -686,19 +735,19 @@ interpret (Cmd_auto ii rng s) = do
Right (Right s) -> give_gen ii rng s Refine
interpret (Cmd_context norm ii _ _) =
- display_info . Info_Context =<< lift (prettyContext norm False ii)
+ display_info . Info_Context =<< liftLocalState (prettyContext norm False ii)
interpret (Cmd_helper_function norm ii rng s) =
- display_info . Info_HelperFunction =<< lift (cmd_helper_function norm ii rng s)
+ display_info . Info_HelperFunction =<< liftLocalState (cmd_helper_function norm ii rng s)
interpret (Cmd_infer norm ii rng s) =
display_info . Info_InferredType
- =<< lift (B.withInteractionId ii
+ =<< liftLocalState (B.withInteractionId ii
(prettyATop =<< B.typeInMeta ii norm =<< B.parseExprIn ii rng s))
interpret (Cmd_goal_type norm ii _ _) =
display_info . Info_CurrentGoal
- =<< lift (B.withInteractionId ii $ prettyTypeOfMeta norm ii)
+ =<< liftLocalState (B.withInteractionId ii $ prettyTypeOfMeta norm ii)
interpret (Cmd_goal_type_context norm ii rng s) =
cmd_goal_type_context_and empty norm ii rng s
@@ -707,8 +756,8 @@ interpret (Cmd_goal_type_context_infer norm ii rng s) = do
-- In case of the empty expression to type, don't fail with
-- a stupid parse error, but just fall back to
-- Cmd_goal_type_context.
- have <- if all Char.isSpace s then return empty else do
- typ <- lift $ B.withInteractionId ii $
+ have <- if all Char.isSpace s then return empty else liftLocalState $ do
+ typ <- B.withInteractionId ii $
prettyATop =<< B.typeInMeta ii norm =<< B.parseExprIn ii rng s
return $ text "Have:" <+> typ
cmd_goal_type_context_and have norm ii rng s
@@ -723,11 +772,23 @@ interpret (Cmd_why_in_scope ii rng s) =
liftCommandMT (B.withInteractionId ii) $ whyInScope s
interpret (Cmd_make_case ii rng s) = do
- (casectxt , cs) <- lift $ makeCase ii rng s
+ (f, casectxt, cs) <- lift $ makeCase ii rng s
liftCommandMT (B.withInteractionId ii) $ do
hidden <- lift $ showImplicitArguments
- pcs <- lift $ mapM prettyA $ List.map (extlam_dropLLifted casectxt hidden) cs
- putResponse $ Resp_MakeCase (makeCaseVariant casectxt) (List.map (extlam_dropName casectxt . render) pcs)
+ tel <- lift $ lookupSection (qnameModule f) -- don't shadow the names in this telescope
+ let cs' :: [A.Clause] = List.map (extlam_dropLLifted casectxt hidden) cs
+ pcs :: [Doc] <- lift $ inTopContext $ addContext tel $ mapM prettyA cs'
+ let pcs' :: [String] = List.map (extlam_dropName casectxt . render) pcs
+ lift $ reportSDoc "interaction.case" 60 $ TCP.vcat
+ [ TCP.text "InteractionTop.Cmd_make_case"
+ , TCP.nest 2 $ TCP.vcat
+ [ TCP.text "cs = " TCP.<+> TCP.vcat (map prettyA cs)
+ , TCP.text "cs' = " TCP.<+> TCP.vcat (map prettyA cs')
+ , TCP.text "pcs = " TCP.<+> TCP.vcat (map return pcs)
+ , TCP.text "pcs' = " TCP.<+> TCP.vcat (map TCP.text pcs')
+ ]
+ ]
+ putResponse $ Resp_MakeCase (makeCaseVariant casectxt) pcs'
where
render = renderStyle (style { mode = OneLineMode })
@@ -750,31 +811,66 @@ interpret (Cmd_make_case ii rng s) = do
-- Drops pattern added to extended lambda functions when lambda lifting them
extlam_dropLLifted :: CaseContext -> Bool -> A.Clause -> A.Clause
extlam_dropLLifted Nothing _ x = x
- extlam_dropLLifted (Just (ExtLamInfo h nh)) hidden (A.Clause (A.LHS info A.LHSProj{} ps) rhs decl catchall) = __IMPOSSIBLE__
- extlam_dropLLifted (Just (ExtLamInfo h nh)) hidden (A.Clause (A.LHS info (A.LHSHead name nps) ps) rhs decl catchall)
+ extlam_dropLLifted _ _ (A.Clause (A.LHS _ A.LHSProj{} _) _ _ _ _) = __IMPOSSIBLE__
+ extlam_dropLLifted (Just (ExtLamInfo h nh)) hidden (A.Clause (A.LHS info (A.LHSHead name nps) ps) dots rhs decl catchall)
= let n = if hidden then h + nh else nh
in
- (A.Clause (A.LHS info (A.LHSHead name (drop n nps)) ps) rhs decl catchall)
+ (A.Clause (A.LHS info (A.LHSHead name (drop n nps)) ps) dots rhs decl catchall)
+
+interpret (Cmd_compute cmode ii rng s) = display_info . Info_NormalForm =<< do
+ liftLocalState $ do
+ e <- B.parseExprIn ii rng $ computeWrapInput cmode s
+ B.withInteractionId ii $ do
+ showComputed cmode =<< do applyWhen (computeIgnoreAbstract cmode) ignoreAbstractMode $ B.evalInCurrent e
-interpret (Cmd_compute ignore ii rng s) = do
- e <- lift $ B.parseExprIn ii rng s
- d <- lift $ B.withInteractionId ii $ do
- let c = B.evalInCurrent e
- v <- if ignore then ignoreAbstractMode c else c
- prettyATop v
- display_info $ Info_NormalForm d
interpret Cmd_show_version = display_info Info_Version
+-- | Show warnings
+interpretWarnings :: CommandM (String, String)
+interpretWarnings = do
+ mws <- lift $ Imp.getAllWarnings Imp.AllWarnings RespectFlags
+ case filter isNotMeta <$> mws of
+ Imp.SomeWarnings ws@(_:_) -> do
+ let (we, wa) = Imp.classifyWarnings ws
+ pwe <- lift $ prettyTCWarnings we
+ pwa <- lift $ prettyTCWarnings wa
+ return (pwe, pwa)
+ _ -> return ("", "")
+ where isNotMeta w = case tcWarning w of
+ UnsolvedInteractionMetas{} -> False
+ UnsolvedMetaVariables{} -> False
+ _ -> True
+
+
+-- | Solved goals already instantiated internally
+-- The second argument potentially limits it to one specific goal.
+solveInstantiatedGoals :: B.Rewrite -> Maybe InteractionId -> CommandM ()
+solveInstantiatedGoals norm mii = do
+ -- Andreas, 2016-10-23 issue #2280: throw away meta elims.
+ out <- lift $ local (\ e -> e { envPrintMetasBare = True }) $ do
+ sip <- B.getSolvedInteractionPoints False norm
+ -- only solve metas which have a proper instantiation, i.e., not another meta
+ maybe id (\ ii -> filter ((ii ==) . fst)) mii <$> mapM prt sip
+ putResponse $ Resp_SolveAll out
+ where
+ prt (i, m, e) = do
+ mi <- getMetaInfo <$> lookupMeta m
+ e <- withMetaInfo mi $ abstractToConcreteCtx TopCtx e
+ return (i, e)
+
+
-- | Print open metas nicely.
showOpenMetas :: TCM [String]
showOpenMetas = do
ims <- B.typesOfVisibleMetas B.AsIs
di <- forM ims $ \ i ->
- B.withInteractionId (B.outputFormId $ B.OutputForm noRange 0 i) $
+ B.withInteractionId (B.outputFormId $ B.OutputForm noRange [] i) $
showATop i
-- Show unsolved implicit arguments simplified.
- dh <- mapM showA' =<< B.typesOfHiddenMetas B.Simplified
+ unsolvedNotOK <- not . optAllowUnsolved <$> pragmaOptions
+ hms <- (guard unsolvedNotOK >>) <$> B.typesOfHiddenMetas B.Simplified
+ dh <- mapM showA' hms
return $ di ++ dh
where
metaId (B.OfType i _) = i
@@ -822,8 +918,8 @@ cmd_load' file argv unsolvedOK cmd = do
case z of
Left err -> lift $ typeError $ GenericError err
Right opts -> do
- lift $ TM.setCommandLineOptions' relativeTo $
- mapPragmaOptions (\ o -> o { optAllowUnsolved = unsolvedOK }) opts
+ let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o}
+ lift $ TM.setCommandLineOptions' relativeTo $ mapPragmaOptions update opts
displayStatus
-- Reset the state, preserving options and decoded modules. Note
@@ -863,10 +959,11 @@ withCurrentFile m = do
-- | Available backends.
-data Backend = MAlonzo
- | MAlonzoNoMain
- | Epic | JS
- deriving (Show, Read)
+data Backend = GHC
+ | GHCNoMain
+ | JS
+ | LaTeX
+ deriving (Show, Read, Eq)
data GiveRefine = Give | Refine | Intro
deriving (Eq, Show)
@@ -916,7 +1013,10 @@ give_gen ii rng s0 giveRefine = do
modifyTheInteractionPoints $ replace ii iis
-- print abstract expr
ce <- lift $ abstractToConcreteEnv (makeEnv scope) ae
- lift $ reportSLn "interaction.give" 30 $ "ce = " ++ show ce
+ lift $ reportSLn "interaction.give" 30 $ unlines
+ [ "ce = " ++ show ce
+ , "scopePrecedence = " ++ show (scopePrecedence scope)
+ ]
-- if the command was @Give@, use the literal user input;
-- Andreas, 2014-01-15, see issue 1020:
-- Refine could solve a goal by introducing the sole constructor
@@ -957,7 +1057,7 @@ highlightExpr e =
where
dummy = mkName_ (NameId 0 0) "dummy"
info = mkDefInfo (nameConcrete dummy) noFixity' PublicAccess ConcreteDef (getRange e)
- decl = A.Axiom NoFunSig info defaultArgInfo (qnameFromList [dummy]) e
+ decl = A.Axiom NoFunSig info defaultArgInfo Nothing (qnameFromList [dummy]) e
-- | Sorts interaction points based on their ranges.
@@ -987,8 +1087,8 @@ prettyContext norm rev ii = B.withInteractionId ii $ do
ctx <- B.contextOfMeta ii norm
es <- mapM (prettyATop . B.ofExpr) ctx
ns <- mapM (showATop . B.ofName) ctx
- let shuffle = if rev then reverse else id
- return $ align 10 $ filter (not . null. fst) $ shuffle $ zip ns (map (text ":" <+>) es)
+ return $ align 10 $ applyWhen rev reverse $
+ filter (not . null . fst) $ zip ns $ map (text ":" <+>) es
-- | Create type of application of new helper function that would solve the goal.
@@ -997,33 +1097,39 @@ cmd_helper_function norm ii r s = B.withInteractionId ii $ inTopContext $
prettyATop =<< B.metaHelperType norm ii r s
-- | Displays the current goal, the given document, and the current
--- context.
+-- context.
+--
+-- Should not modify the state.
cmd_goal_type_context_and :: Doc -> B.Rewrite -> InteractionId -> Range ->
String -> StateT CommandState (TCMT IO) ()
-cmd_goal_type_context_and doc norm ii _ _ = do
- goal <- lift $ B.withInteractionId ii $ prettyTypeOfMeta norm ii
- ctx <- lift $ prettyContext norm True ii
- display_info $ Info_GoalType
- (text "Goal:" <+> goal $+$
- doc $+$
- text (replicate 60 '\x2014') $+$
- ctx)
+cmd_goal_type_context_and doc norm ii _ _ = display_info . Info_GoalType =<< do
+ lift $ do
+ goal <- B.withInteractionId ii $ prettyTypeOfMeta norm ii
+ ctx <- prettyContext norm True ii
+ return $ vcat
+ [ text "Goal:" <+> goal
+ , doc
+ , text (replicate 60 '\x2014')
+ , ctx
+ ]
-- | Shows all the top-level names in the given module, along with
-- their types.
showModuleContents :: B.Rewrite -> Range -> String -> CommandM ()
-showModuleContents norm rng s = do
- (modules, types) <- lift $ B.moduleContents norm rng s
- types' <- lift $ forM types $ \ (x, t) -> do
- t <- TCP.prettyTCM t
- return (show x, text ":" <+> t)
- display_info $ Info_ModuleContents $
- text "Modules" $$
- nest 2 (vcat $ map (text . show) modules) $$
- text "Names" $$
- nest 2 (align 10 types')
+showModuleContents norm rng s = display_info . Info_ModuleContents =<< do
+ liftLocalState $ do
+ (modules, types) <- B.moduleContents norm rng s
+ types' <- forM types $ \ (x, t) -> do
+ t <- TCP.prettyTCM t
+ return (show x, text ":" <+> t)
+ return $ vcat
+ [ text "Modules"
+ , nest 2 $ vcat $ map (text . show) modules
+ , text "Names"
+ , nest 2 $ align 10 types'
+ ]
-- | Shows all the top-level names in scope which mention all the given
-- identifiers in their type.
@@ -1044,12 +1150,12 @@ searchAbout norm rg nm = do
-- | Explain why something is in scope.
whyInScope :: String -> CommandM ()
-whyInScope s = do
- (v, xs, ms) <- lift $ B.whyInScope s
- cwd <- do
- Just (file, _) <- gets $ theCurrentFile
- return $ takeDirectory $ filePath file
- display_info . Info_WhyInScope =<< do lift $ explanation cwd v xs ms
+whyInScope s = display_info . Info_WhyInScope =<< do
+ Just (file, _) <- gets theCurrentFile
+ let cwd = takeDirectory $ filePath file
+ liftLocalState $ do
+ (v, xs, ms) <- B.whyInScope s
+ explanation cwd v xs ms
where
explanation _ Nothing [] [] = TCP.text (s ++ " is not in scope.")
explanation cwd v xs ms = TCP.vcat
@@ -1129,6 +1235,8 @@ setCommandLineOpts opts = do
-- | Computes some status information.
+--
+-- Does not change the state.
status :: CommandM Status
status = do
@@ -1145,7 +1253,7 @@ status = do
case t == t' of
False -> return False
True -> do
- mm <- Map.lookup f <$> sourceToModule
+ mm <- lookupModuleFromSource f
case mm of
Nothing -> return False -- work-around for Issue1007
Just m -> not . miWarnings . fromMaybe __IMPOSSIBLE__ <$> getVisitedModule m
@@ -1154,15 +1262,17 @@ status = do
, sChecked = checked
}
--- | Displays\/updates status information.
+-- | Displays or updates status information.
+--
+-- Does not change the state.
displayStatus :: CommandM ()
displayStatus =
putResponse . Resp_Status =<< status
-- | @display_info@ does what @'display_info'' False@ does, but
--- additionally displays some status information (see 'status' and
--- 'displayStatus').
+-- additionally displays some status information (see 'status' and
+-- 'displayStatus').
display_info :: DisplayInfo -> CommandM ()
display_info info = do
@@ -1179,43 +1289,28 @@ nameModifiers :: [String]
nameModifiers = "" : "'" : "''" : [show i | i <-[3..]]
--- | Kill meta numbers and ranges from all metas (@?@ and @_@).
-lowerMeta :: (C.ExprLike a) => a -> a
-lowerMeta = C.mapExpr kill where
- kill e =
- case e of
- C.QuestionMark{} -> preMeta
- C.Underscore{} -> preUscore
- C.App{} -> case appView e of
- C.AppView (C.QuestionMark _ _) _ -> preMeta
- C.AppView (C.Underscore _ _) _ -> preUscore
- _ -> e
- C.Paren r q@(C.QuestionMark _ Nothing) -> q
- _ -> e
-
- preMeta = C.QuestionMark noRange Nothing
- preUscore = C.Underscore noRange Nothing
-
-
-- | Parses and scope checks an expression (using the \"inside scope\"
-- as the scope), performs the given command with the expression as
-- input, and displays the result.
-parseAndDoAtToplevel
- :: (A.Expr -> TCM A.Expr)
+parseAndDoAtToplevel'
+ :: (A.Expr -> TCM Doc)
-- ^ The command to perform.
-> (Doc -> DisplayInfo)
-- ^ The name to use for the buffer displaying the output.
-> String
-- ^ The expression to parse.
-> CommandM ()
-parseAndDoAtToplevel cmd title s = do
- e <- liftIO $ parse exprParser s
- (time, res) <-
+parseAndDoAtToplevel' cmd title s = do
+ (time, res) <- localStateCommandM $ do
+ e <- lift $ runPM $ parse exprParser s
maybeTimed (lift $ B.atTopLevel $
- prettyA =<< cmd =<< concreteToAbstract_ e)
+ cmd =<< concreteToAbstract_ e)
display_info (title $ fromMaybe empty time $$ res)
+parseAndDoAtToplevel :: (A.Expr -> TCM A.Expr) -> (Doc -> DisplayInfo) -> String -> CommandM ()
+parseAndDoAtToplevel cmd = parseAndDoAtToplevel' (prettyA <=< cmd)
+
maybeTimed :: CommandM a -> CommandM (Maybe Doc, a)
maybeTimed work = do
doTime <- lift $ hasVerbosity "profile.interactive" 10
diff --git a/src/full/Agda/Interaction/Library.hs b/src/full/Agda/Interaction/Library.hs
index c2c1dce..209d5cf 100644
--- a/src/full/Agda/Interaction/Library.hs
+++ b/src/full/Agda/Interaction/Library.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE PatternGuards #-}
module Agda.Interaction.Library
( getDefaultLibraries
@@ -75,10 +73,12 @@ findAgdaLibFiles root = do
if up == root then return [] else findAgdaLibFiles up
files -> return files
-getDefaultLibraries :: FilePath -> LibM ([LibName], [FilePath])
-getDefaultLibraries root = mkLibM [] $ do
+getDefaultLibraries :: FilePath -> Bool -> LibM ([LibName], [FilePath])
+getDefaultLibraries root optDefaultLibs = mkLibM [] $ do
libs <- findAgdaLibFiles root
- if null libs then first (, []) <$> readDefaultsFile
+ if null libs
+ then
+ if optDefaultLibs then first (, []) <$> readDefaultsFile else return (([], []), [])
else first libsAndPaths <$> parseLibFiles Nothing (zip (repeat 0) libs)
where
libsAndPaths ls = (concatMap libDepends ls, concatMap libIncludes ls)
@@ -94,13 +94,14 @@ readDefaultsFile = do
`catchIO` \e -> return (["."], [OtherError $ "Failed to read defaults file.\n" ++ show e])
getLibrariesFile :: Maybe FilePath -> IO FilePath
-getLibrariesFile overrideLibFile = do
+getLibrariesFile (Just overrideLibFile) = return overrideLibFile
+getLibrariesFile Nothing = do
agdaDir <- getAgdaAppDir
- let override = maybe [] (:[]) overrideLibFile
- files <- (override ++) <$> filterM doesFileExist (map (agdaDir </>) defaultLibraryFiles)
+ let defaults = map (agdaDir </>) defaultLibraryFiles
+ files <- filterM doesFileExist defaults
case files of
file : _ -> return file
- [] -> return (agdaDir </> last defaultLibraryFiles) -- doesn't exist, but that's ok
+ [] -> return (last defaults) -- doesn't exist, but that's ok
getInstalledLibraries :: Maybe FilePath -> LibM [AgdaLibFile]
getInstalledLibraries overrideLibFile = mkLibM [] $ do
@@ -195,4 +196,3 @@ versionView s =
valid [] = False
valid vs = not $ any null vs
_ -> (s, [])
-
diff --git a/src/full/Agda/Interaction/Library/Parse.hs b/src/full/Agda/Interaction/Library/Parse.hs
index 1ad97f2..070b78a 100644
--- a/src/full/Agda/Interaction/Library/Parse.hs
+++ b/src/full/Agda/Interaction/Library/Parse.hs
@@ -1,7 +1,3 @@
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards #-}
module Agda.Interaction.Library.Parse (parseLibFile, stripComments, splitCommas) where
import Control.Applicative
@@ -31,7 +27,7 @@ data Field = forall a. Field
agdaLibFields :: [Field]
agdaLibFields =
[ Field "name" False parseName $ \ name l -> l { libName = name }
- , Field "include" True pure $ \ inc l -> l { libIncludes = inc }
+ , Field "include" True (pure . concatMap words) $ \ inc l -> l { libIncludes = inc }
, Field "depend" True (pure . concatMap splitCommas) $ \ ds l -> l { libDepends = ds }
]
where
diff --git a/src/full/Agda/Interaction/MakeCase.hs b/src/full/Agda/Interaction/MakeCase.hs
index 306fad6..cbda47e 100644
--- a/src/full/Agda/Interaction/MakeCase.hs
+++ b/src/full/Agda/Interaction/MakeCase.hs
@@ -1,12 +1,14 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DoAndIfThenElse #-}
-{-# LANGUAGE TupleSections #-}
module Agda.Interaction.MakeCase where
import Prelude hiding (mapM, mapM_, null)
+
import Control.Applicative hiding (empty)
import Control.Monad hiding (mapM, mapM_, forM)
+
+import qualified Data.Map as Map
+import qualified Data.List as List
import Data.Maybe
import Data.Traversable
@@ -27,7 +29,6 @@ import Agda.TypeChecking.Pretty
import Agda.TypeChecking.RecordPatterns
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
-import Agda.TypeChecking.Substitute.Pattern
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Rules.LHS.Implicit
import Agda.TheTypeChecker
@@ -50,55 +51,17 @@ import Agda.Utils.Impossible
type CaseContext = Maybe ExtLamInfo
--- | 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
--- away. Raises an error if there is no matching clause.
---
--- Andreas, 2010-09-21: This looks like a SUPER UGLY HACK to me. You are
--- walking through the WHOLE signature to find an information you have
--- thrown away earlier. (shutter with disgust).
--- This code fails for record rhs because they have been eta-expanded,
--- so the MVar is gone.
-findClause :: MetaId -> TCM (CaseContext, QName, Clause)
-findClause m = do
- sig <- getImportedSignature
- let res = do
- def <- HMap.elems $ sig ^. sigDefinitions
- Function{funClauses = cs, funExtLam = extlam} <- [theDef def]
- c <- cs
- unless (rhsIsm $ clauseBody c) []
- return (extlam, defName def, c)
- case res of
- [] -> do
- reportSDoc "interaction.case" 10 $ vcat $
- [ text "Interaction.MakeCase.findClause fails"
- , text "expected rhs to be meta var" <+> (text $ show m)
- , text "but could not find it in the signature"
- ]
- reportSDoc "interaction.case" 100 $ vcat $ map (text . show) (HMap.elems $ sig ^. sigDefinitions) -- you asked for it!
- ifM (isInstantiatedMeta m)
- -- Andreas, 2012-03-22 If the goal has been solved by eta expansion, further
- -- case splitting is pointless and `smart-ass Agda' will refuse.
- -- Maybe not the best solution, but the lazy alternative to replace this
- -- SUPER UGLY HACK.
- (typeError $ GenericError "Since goal is solved, further case distinction is not supported; try `Solve constraints' instead")
- (typeError $ GenericError "Right hand side must be a single hole when making a case distinction")
- [triple] -> return triple
- _ -> __IMPOSSIBLE__
- where
- rhsIsm (Bind b) = rhsIsm $ unAbs b
- rhsIsm NoBody = False
- rhsIsm (Body e) = case ignoreSharing e of
- 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
+parseVariables
+ :: QName -- ^ The function name.
+ -> Telescope -- ^ The telescope of the clause we are splitting.
+ -> InteractionId -- ^ The hole of this function we are working on.
+ -> Range -- ^ The range of this hole.
+ -> [String] -- ^ The words the user entered in this hole (variable names).
+ -> TCM [Int] -- ^ The computed de Bruijn indices of the variables to split on.
+parseVariables f tel ii rng ss = do
-- Get into the context of the meta.
mId <- lookupInteractionId ii
@@ -111,16 +74,43 @@ parseVariables ii rng ss = do
xs <- forM (downFrom n) $ \ i -> do
(,i) . P.render <$> prettyTCM (var i)
- -- Get number of module parameters. These cannot be split on.
- fv <- getCurrentModuleFreeVars
- let numSplittableVars = n - fv
+ -- We might be under some lambdas, in which case the context
+ -- is bigger than the number of pattern variables.
+ let nlocals = n - size tel
+ unless (nlocals >= 0) __IMPOSSIBLE__
+
+ reportSDoc "interaction.case" 20 $ do
+ m <- currentModule
+ tel <- lookupSection m
+ fv <- getDefFreeVars f
+ vcat
+ [ text "parseVariables:"
+ , text "current module =" <+> prettyTCM m
+ , text "current section =" <+> inTopContext (prettyTCM tel)
+ , text $ "function's fvs = " ++ show fv
+ , text $ "number of locals= " ++ show nlocals
+ ]
+
+ -- Compute which variables correspond to module parameters. These cannot be split on.
+ -- Note: these are not necessarily the outer-most bound variables, since
+ -- module parameter refinement may have instantiated them, or
+ -- with-abstraction might have reshuffled the variables (#2181).
+ pars <- freeVarsToApply f
+ let nonSplittableVars = [ i | Var i [] <- map unArg pars ]
-- Resolve each string to a variable.
forM ss $ \ s -> do
- let failNotVar = typeError $ GenericError $ "Not a (splittable) variable: " ++ s
+ let failNotVar = typeError $ GenericError $ "Not a variable: " ++ s
done i
- | i < numSplittableVars = return i
- | otherwise = failNotVar
+ | i < 0 = typeError $ GenericError $
+ "Cannot split on local variable " ++ s
+ -- See issue #2239
+
+ | elem i nonSplittableVars = typeError $ GenericError $
+ "Cannot split on variable " ++ s ++ ". It is either a module parameter " ++
+ "or already instantiated by a dot pattern"
+
+ | otherwise = return i
-- Note: the range in the concrete name is only approximate.
resName <- resolveName $ C.QName $ C.Name r $ C.stringNameParts s
@@ -137,7 +127,7 @@ parseVariables ii rng ss = do
VarName x -> do
(v, _) <- getVarInfo x
case ignoreSharing v of
- Var i [] -> done i
+ Var i [] -> done $ i - nlocals
_ -> failNotVar
-- If s is not a name, compare it to the printed variable representation.
@@ -145,17 +135,48 @@ parseVariables ii rng ss = do
UnknownName -> do
case filter ((s ==) . fst) xs of
[] -> typeError $ GenericError $ "Unbound variable " ++ s
- [(_,i)] -> done i
+ [(_,i)] -> done $ i - nlocals
-- Issue 1325: Variable names in context can be ambiguous.
_ -> typeError $ GenericError $ "Ambiguous variable " ++ s
+-- | Lookup the clause for an interaction point in the signature.
+-- Returns the CaseContext, the clause itself, and a list of previous clauses
+
+-- Andreas, 2016-06-08, issue #289 and #2006.
+-- This replace the old findClause hack (shutter with disgust).
+getClauseForIP :: QName -> Int -> TCM (CaseContext, Clause, [Clause])
+getClauseForIP f clauseNo = do
+ (theDef <$> getConstInfo f) >>= \case
+ Function{funClauses = cs, funExtLam = extlam} -> do
+ let (cs1,cs2) = fromMaybe __IMPOSSIBLE__ $ splitExactlyAt clauseNo cs
+ c = fromMaybe __IMPOSSIBLE__ $ headMaybe cs2
+ return (extlam, c, cs1)
+ d -> do
+ reportSDoc "impossible" 10 $ vcat
+ [ text "getClauseForIP" <+> prettyTCM f <+> text (show clauseNo)
+ <+> text "received"
+ , text (show d)
+ ]
+ __IMPOSSIBLE__
+
-- | Entry point for case splitting tactic.
-makeCase :: InteractionId -> Range -> String -> TCM (CaseContext , [A.Clause])
+
+makeCase :: InteractionId -> Range -> String -> TCM (QName, CaseContext , [A.Clause])
makeCase hole rng s = withInteractionId hole $ do
- meta <- lookupInteractionId hole
- (casectxt, f, clause@(Clause{ clauseTel = tel, namedClausePats = ps })) <- findClause meta
- let perm = clausePerm clause
+
+ -- Get function clause which contains the interaction point.
+
+ InteractionPoint { ipMeta = mm, ipClause = ipCl} <- lookupInteractionPoint hole
+ let meta = fromMaybe __IMPOSSIBLE__ mm
+ (f, clauseNo, rhs) <- case ipCl of
+ IPClause f clauseNo rhs-> return (f, clauseNo, rhs)
+ IPNoClause -> typeError $ GenericError $
+ "Cannot split here, as we are not in a function definition"
+ (casectxt, clause, prevClauses) <- getClauseForIP f clauseNo
+ let perm = fromMaybe __IMPOSSIBLE__ $ clausePerm clause
+ tel = clauseTel clause
+ ps = namedClausePats clause
reportSDoc "interaction.case" 10 $ vcat
[ text "splitting clause:"
, nest 2 $ vcat
@@ -166,9 +187,14 @@ makeCase hole rng s = withInteractionId hole $ do
, text "ps =" <+> text (show ps)
]
]
+
+ -- Check split variables.
+
let vars = words s
+
+ -- If we have no split variables, split on result.
+
if null vars then do
- -- split result
(piTel, sc) <- fixTarget $ clauseToSplitClause clause
-- Andreas, 2015-05-05 If we introduced new function arguments
-- do not split on result. This might be more what the user wants.
@@ -186,32 +212,46 @@ makeCase hole rng s = withInteractionId hole $ do
case res of
Nothing -> typeError $ GenericError $ "Cannot split on result here"
Just cov -> ifNotM (optCopatterns <$> pragmaOptions) failNoCop $ {-else-} do
- mapM (snd <.> fixTarget) $ splitClauses cov
- (casectxt,) <$> mapM (makeAbstractClause f) scs
+ -- Andreas, 2016-05-03: do not introduce function arguments after projection.
+ -- This is sometimes annoying and can anyway be done by another C-c C-c.
+ -- mapM (snd <.> fixTarget) $ splitClauses cov
+ return $ splitClauses cov
+ checkClauseIsClean ipCl
+ (f, casectxt,) <$> mapM (makeAbstractClause f rhs) scs
else do
-- split on variables
- vars <- parseVariables hole rng vars
- cs <- split f vars $ clauseToSplitClause clause
+ xs <- parseVariables f tel hole rng vars
+ -- Variables that are not in scope yet are brought into scope (@toShow@)
+ -- The other variables are split on (@toSplit@).
+ let (toShow, toSplit) = flip mapEither (zip xs vars) $ \ (x, s) ->
+ if take 1 s == "." then Left x else Right x
+ let sc = makePatternVarsVisible toShow $ clauseToSplitClause clause
+ scs <- split f toSplit sc
+ -- filter out clauses that are already covered
+ scs <- filterM (not <.> isCovered f prevClauses . fst) scs
+ cs <- forM scs $ \(sc, isAbsurd) -> do
+ if isAbsurd then makeAbsurdClause f sc else makeAbstractClause f rhs sc
reportSDoc "interaction.case" 65 $ vcat
[ text "split result:"
, nest 2 $ vcat $ map (text . show) cs
]
- return (casectxt,cs)
- where
+ checkClauseIsClean ipCl
+ return (f, casectxt, cs)
+ where
failNoCop = typeError $ GenericError $
"OPTION --copatterns needed to split on result here"
- split :: QName -> [Nat] -> SplitClause -> TCM [A.Clause]
- split f [] clause = singleton <$> makeAbstractClause f clause
+ -- Split clause on given variables, return the resulting clauses together
+ -- with a bool indicating whether each clause is absurd
+ split :: QName -> [Nat] -> SplitClause -> TCM [(SplitClause, Bool)]
+ split f [] clause = return [(clause,False)]
split f (var : vars) clause = do
z <- splitClauseWithAbsurd clause var
case z of
Left err -> typeError $ SplitError err
- Right (Left cl) -> (:[]) <$> makeAbsurdClause f cl
- Right (Right cov)
- | null vars -> mapM (makeAbstractClause f) $ splitClauses cov
- | otherwise -> concat <$> do
+ Right (Left cl) -> return [(cl,True)]
+ Right (Right cov) -> concat <$> do
forM (splitClauses cov) $ \ cl ->
split f (mapMaybe (newVar cl) vars) cl
@@ -221,11 +261,36 @@ makeCase hole rng s = withInteractionId hole $ do
Var y [] -> Just y
_ -> Nothing
+ -- Check whether clause has been refined after last load.
+ -- In this case, we refuse to split, as this might lose the refinements.
+ checkClauseIsClean :: IPClause -> TCM ()
+ checkClauseIsClean ipCl = do
+ sips <- Map.elems <$> use stSolvedInteractionPoints
+ when (List.any ((== ipCl) . ipClause) sips) $
+ typeError $ GenericError $ "Cannot split as clause rhs has been refined. Please reload"
+
+-- | Mark the variables given by the list of deBruijn indices as 'UserWritten'
+-- in the 'SplitClause'.
+makePatternVarsVisible :: [Nat] -> SplitClause -> SplitClause
+makePatternVarsVisible [] sc = sc
+makePatternVarsVisible is sc@SClause{ scPats = ps } =
+ sc{ scPats = map (mapNamedArg mkVis) ps }
+ where
+ mkVis :: NamedArg DBPatVar -> NamedArg DBPatVar
+ mkVis nx@(Arg ai (Named n (DBPatVar x i)))
+ | i `elem` is =
+ -- We could introduce extra consistency checks, like
+ -- if visible ai then __IMPOSSIBLE__ else
+ -- or passing the parsed name along and comparing it with @x@
+ setOrigin UserWritten nx
+ | otherwise = nx
+
+-- | Make clause with no rhs (because of absurd match).
makeAbsurdClause :: QName -> SplitClause -> TCM A.Clause
-makeAbsurdClause f (SClause tel ps _ t) = do
+makeAbsurdClause f (SClause tel ps _ _ t) = do
reportSDoc "interaction.case" 10 $ vcat
- [ text "Interaction.MakeCase.makeCase: split clause:"
+ [ text "Interaction.MakeCase.makeAbsurdClause: split clause:"
, nest 2 $ vcat
[ text "context =" <+> (prettyTCM =<< getContextTelescope)
, text "tel =" <+> prettyTCM tel
@@ -237,28 +302,22 @@ makeAbsurdClause f (SClause tel ps _ t) = do
-- Contract implicit record patterns before printing.
-- c <- translateRecordPatterns $ Clause noRange tel perm ps NoBody t False
-- Jesper, 2015-09-19 Don't contract, since we do on-demand splitting
- let c = Clause noRange tel ps NoBody t False
+ let c = Clause noRange tel ps Nothing t False
-- Normalise the dot patterns
- ps <- addCtxTel tel $ normalise $ namedClausePats c
+ ps <- addContext tel $ normalise $ namedClausePats c
+ reportSDoc "interaction.case" 60 $ text "normalized patterns: " <+> text (show ps)
inTopContext $ reify $ QNamed f $ c { namedClausePats = ps }
+
-- | Make a clause with a question mark as rhs.
-makeAbstractClause :: QName -> SplitClause -> TCM A.Clause
-makeAbstractClause f cl = do
- A.Clause lhs _ _ _ <- makeAbsurdClause f cl
- let ii = InteractionId (-1) -- Dummy interaction point since we never type check this.
- -- Can end up in verbose output though (#1842), hence not __IMPOSSIBLE__.
- let info = A.emptyMetaInfo -- metaNumber = Nothing in order to print as ?, not ?n
- return $ A.Clause lhs (A.RHS $ A.QuestionMark info ii) [] False
-
-deBruijnIndex :: A.Expr -> TCM Nat
-deBruijnIndex e = do
- (v, _) <- -- Andreas, 2010-09-21 allow splitting on irrelevant (record) vars
--- Context.wakeIrrelevantVars $
- applyRelevanceToContext Irrelevant $
- inferExpr e
- case ignoreSharing v of
- Var n _ -> return n
- _ -> typeError . GenericError . show =<< (fsep $
- pwords "The scrutinee of a case distinction must be a variable,"
- ++ [ prettyTCM v ] ++ pwords "isn't.")
+
+makeAbstractClause :: QName -> A.RHS -> SplitClause -> TCM A.Clause
+makeAbstractClause f rhs cl = do
+
+ A.Clause lhs _ _ _ _ <- makeAbsurdClause f cl
+ reportSDoc "interaction.case" 60 $ text "reified lhs: " <+> text (show lhs)
+ return $ A.Clause lhs [] rhs [] False
+ -- let ii = InteractionId (-1) -- Dummy interaction point since we never type check this.
+ -- -- Can end up in verbose output though (#1842), hence not __IMPOSSIBLE__.
+ -- let info = A.emptyMetaInfo -- metaNumber = Nothing in order to print as ?, not ?n
+ -- return $ A.Clause lhs [] (A.RHS $ A.QuestionMark info ii) [] False
diff --git a/src/full/Agda/Interaction/Options.hs b/src/full/Agda/Interaction/Options.hs
index 588f55d..949d0e8 100644
--- a/src/full/Agda/Interaction/Options.hs
+++ b/src/full/Agda/Interaction/Options.hs
@@ -2,6 +2,7 @@
module Agda.Interaction.Options
( CommandLineOptions(..)
+ , IgnoreFlags(..)
, PragmaOptions(..)
, OptionsPragma
, Flag, OptM, runOptM
@@ -14,12 +15,12 @@ module Agda.Interaction.Options
, defaultInteractionOptions
, defaultVerbosity
, defaultCutOff
+ , defaultPragmaOptions
, standardOptions_
, unsafePragmaOptions
, isLiterate
, mapFlag
, usage
- , tests
, defaultLibDir
-- Reused by PandocAgda
, inputFlag
@@ -42,7 +43,7 @@ import Data.List ( isSuffixOf , intercalate )
import System.Console.GetOpt ( getOpt', usageInfo, ArgOrder(ReturnInOrder)
, OptDescr(..), ArgDescr(..)
)
-import System.Directory ( doesDirectoryExist )
+import System.Directory ( doesFileExist, doesDirectoryExist )
import Text.EditDistance
@@ -56,13 +57,12 @@ import Agda.Utils.Except
, runExceptT
)
-import Agda.Utils.TestHelpers ( runTests )
-import Agda.Utils.QuickCheck ( quickCheck' )
import Agda.Utils.FileName ( absolute, AbsolutePath, filePath )
import Agda.Utils.Monad ( ifM, readM )
import Agda.Utils.List ( groupOn, wordsBy )
import Agda.Utils.String ( indent )
import Agda.Utils.Trie ( Trie )
+import Agda.Syntax.Parser.Literate ( literateExts )
import qualified Agda.Utils.Trie as Trie
import Agda.Version
@@ -71,12 +71,17 @@ import Paths_Agda ( getDataFileName )
-- | This should probably go somewhere else.
isLiterate :: FilePath -> Bool
-isLiterate file = ".lagda" `isSuffixOf` file
+isLiterate file = any (`isSuffixOf` file) literateExts
-- OptDescr is a Functor --------------------------------------------------
type Verbosity = Trie String Int
+-- ignore or respect the flags --allow-unsolved-metas,
+-- --no-termination-check, --no-positivity-check?
+data IgnoreFlags = IgnoreFlags | RespectFlags
+ deriving Eq
+
data CommandLineOptions = Options
{ optProgramName :: String
, optInputFile :: Maybe FilePath
@@ -86,11 +91,12 @@ data CommandLineOptions = Options
, optOverrideLibrariesFile :: Maybe FilePath
-- ^ Use this (if Just) instead of .agda/libraries
, optDefaultLibs :: Bool
- -- ^ Use ~/.agda/defaults or look for .agda-lib file.
+ -- ^ Use ~/.agda/defaults
+ , optUseLibs :: Bool
+ -- ^ look for .agda-lib files
, optShowVersion :: Bool
, optShowHelp :: Bool
, optInteractive :: Bool
- , optRunTests :: Bool
, optGHCiInteraction :: Bool
, optCompileNoMain :: Bool
, optGhcCompile :: Bool
@@ -150,6 +156,10 @@ data PragmaOptions = PragmaOptions
, optExactSplit :: Bool
, optEta :: Bool
, optRewriting :: Bool -- ^ Can rewrite rules be added and used?
+ , optPostfixProjections :: Bool
+ -- ^ Should system generated projections 'ProjSystem' be printed
+ -- postfix (True) or prefix (False).
+ , optInstanceSearchDepth :: Int
}
deriving (Show,Eq)
@@ -180,10 +190,10 @@ defaultOptions = Options
, optLibraries = []
, optOverrideLibrariesFile = Nothing
, optDefaultLibs = True
+ , optUseLibs = True
, optShowVersion = False
, optShowHelp = False
, optInteractive = False
- , optRunTests = False
, optGHCiInteraction = False
, optCompileNoMain = False
, optGhcCompile = False
@@ -239,6 +249,8 @@ defaultPragmaOptions = PragmaOptions
, optExactSplit = False
, optEta = True
, optRewriting = False
+ , optPostfixProjections = False
+ , optInstanceSearchDepth = 500
}
-- | The default termination depth.
@@ -256,10 +268,6 @@ defaultLaTeXDir = "latex"
defaultHTMLDir :: String
defaultHTMLDir = "html"
-prop_defaultOptions :: IO Bool
-prop_defaultOptions =
- either (const False) (const True) <$> runOptM (checkOpts defaultOptions)
-
type OptM = ExceptT String IO
runOptM :: OptM a -> IO (Either String a)
@@ -321,16 +329,6 @@ unsafePragmaOptions opts =
[ "--rewriting" | optRewriting opts ] ++
[]
--- | The default pragma options should be considered safe.
-
-defaultPragmaOptionsSafe :: IO Bool
-defaultPragmaOptionsSafe
- | null unsafe = return True
- | otherwise = do putStrLn $ "Following pragmas are default but not safe: "
- ++ intercalate ", " unsafe
- return False
- where unsafe = unsafePragmaOptions defaultPragmaOptions
-
inputFlag :: FilePath -> Flag CommandLineOptions
inputFlag f o =
case optInputFile o of
@@ -373,9 +371,6 @@ 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 }
@@ -453,6 +448,14 @@ noExactSplitFlag o = return $ o { optExactSplit = False }
rewritingFlag :: Flag PragmaOptions
rewritingFlag o = return $ o { optRewriting = True }
+postfixProjectionsFlag :: Flag PragmaOptions
+postfixProjectionsFlag o = return $ o { optPostfixProjections = True }
+
+instanceDepthFlag :: String -> Flag PragmaOptions
+instanceDepthFlag s o = do
+ d <- integerArgument "--instance-search-depth" s
+ return $ o { optInstanceSearchDepth = d }
+
interactiveFlag :: Flag CommandLineOptions
interactiveFlag o = return $ o { optInteractive = True
, optPragmaOptions = (optPragmaOptions o)
@@ -508,9 +511,6 @@ uhcTraceLevelFlag i o = return $ o { optUHCTraceLevel = read i }
uhcFlagsFlag :: String -> Flag CommandLineOptions
uhcFlagsFlag s o = return $ o { optUHCFlags = optUHCFlags o ++ [s] }
-optimNoSmashing :: Flag CommandLineOptions
-optimNoSmashing o = return $ o {optOptimSmashing = False }
-
htmlFlag :: Flag CommandLineOptions
htmlFlag o = return $ o { optGenerateHTML = True }
@@ -530,11 +530,17 @@ libraryFlag :: String -> Flag CommandLineOptions
libraryFlag s o = return $ o { optLibraries = optLibraries o ++ [s] }
overrideLibrariesFileFlag :: String -> Flag CommandLineOptions
-overrideLibrariesFileFlag s o = return $ o { optOverrideLibrariesFile = Just s }
+overrideLibrariesFileFlag s o = do
+ ifM (liftIO $ doesFileExist s)
+ {-then-} (return $ o { optOverrideLibrariesFile = Just s })
+ {-else-} (throwError $ "Libraries file not found: " ++ s)
noDefaultLibsFlag :: Flag CommandLineOptions
noDefaultLibsFlag o = return $ o { optDefaultLibs = False }
+noLibsFlag :: Flag CommandLineOptions
+noLibsFlag o = return $ o { optUseLibs = False }
+
verboseFlag :: String -> Flag PragmaOptions
verboseFlag s o =
do (k,n) <- parseVerbose s
@@ -568,7 +574,7 @@ standardOptions =
, Option [] ["interaction"] (NoArg ghciInteractionFlag)
"for use with the Emacs mode"
, Option ['c'] ["compile", "ghc"] (NoArg compileGhcFlag)
- "compile program using the GHC backend (experimental)"
+ "compile program using the GHC backend"
, Option [] ["ghc-dont-call-ghc"] (NoArg ghcDontCallGhcFlag) "Don't call ghc, just write the GHC Haskell files."
, Option [] ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG")
"give the flag GHC-FLAG to GHC when compiling using the GHC backend"
@@ -588,7 +594,6 @@ standardOptions =
, Option [] ["uhc-gen-trace"] (ReqArg uhcTraceLevelFlag "TRACE") "Add tracing code to generated executable."
, Option [] ["uhc-flag"] (ReqArg uhcFlagsFlag "UHC-FLAG")
"give the flag UHC-FLAG to UHC when compiling using the UHC backend"
- , Option [] ["no-smashing"] (NoArg optimNoSmashing) "Don't apply the smashing optimization."
, Option [] ["compile-dir"] (ReqArg compileDirFlag "DIR")
("directory for compiler output (default: the project root)")
@@ -597,8 +602,6 @@ standardOptions =
-- "give the flag EPIC-FLAG to Epic when compiling using Epic"
"the Epic backend has been removed"
- , Option [] ["test"] (NoArg runTestsFlag)
- "run internal test suite"
, Option [] ["vim"] (NoArg vimFlag)
"generate Vim highlighting files"
, Option [] ["latex"] (NoArg latexFlag)
@@ -623,6 +626,8 @@ standardOptions =
"use library LIB"
, Option [] ["library-file"] (ReqArg overrideLibrariesFileFlag "FILE")
"use FILE instead of the standard libraries file"
+ , Option [] ["no-libraries"] (NoArg noLibsFlag)
+ "don't use any library files"
, Option [] ["no-default-libraries"] (NoArg noDefaultLibsFlag)
"don't use default libraries"
, Option [] ["no-forcing"] (NoArg noForcingFlag)
@@ -700,6 +705,10 @@ pragmaOptions =
"disable eta rules for records"
, Option [] ["rewriting"] (NoArg rewritingFlag)
"enable declaration and use of REWRITE rules"
+ , Option [] ["postfix-projections"] (NoArg postfixProjectionsFlag)
+ "make postfix projection notation the default"
+ , Option [] ["instance-search-depth"] (ReqArg instanceDepthFlag "N")
+ "set instance search depth to N (default: 500)"
]
-- | Used for printing usage info.
@@ -813,12 +822,3 @@ defaultLibDir = do
ifM (doesDirectoryExist libdir)
(return libdir)
(error $ "The lib directory " ++ libdir ++ " does not exist")
-
-------------------------------------------------------------------------
--- All tests
-
-tests :: IO Bool
-tests = runTests "Agda.Interaction.Options"
- [ prop_defaultOptions
- , defaultPragmaOptionsSafe
- ]
diff --git a/src/full/Agda/Interaction/Response.hs b/src/full/Agda/Interaction/Response.hs
index 151ad33..313c9a2 100644
--- a/src/full/Agda/Interaction/Response.hs
+++ b/src/full/Agda/Interaction/Response.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
------------------------------------------------------------------------
-- | Data type for all interactive responses
@@ -41,6 +40,7 @@ data Response
| Resp_GiveAction InteractionId GiveResult
| Resp_MakeCase MakeCaseVariant [String]
| Resp_SolveAll [(InteractionId, Expr)]
+ -- ^ Solution for one or more meta-variables.
| Resp_DisplayInfo DisplayInfo
| Resp_RunningInfo Int String
-- ^ The integer is the message's debug level.
@@ -56,11 +56,13 @@ data MakeCaseVariant = Function | ExtendedLambda
data DisplayInfo
= Info_CompilationOk
| Info_Constraints String
- | Info_AllGoals String
+ | Info_AllGoalsWarnings String String String
+ -- ^ Strings are the goals, the warnings and the (non-fatal) errors
| Info_Time Doc
| Info_Error String
-- ^ When an error message is displayed this constructor should be
-- used, if appropriate.
+-- | Info_Warning String --FNF: currently unused
| Info_Intro Doc
-- ^ 'Info_Intro' denotes two different types of errors
-- TODO: split these into separate constructors
diff --git a/src/full/Agda/Interaction/SearchAbout.hs b/src/full/Agda/Interaction/SearchAbout.hs
index 9a73a27..0f489ce 100644
--- a/src/full/Agda/Interaction/SearchAbout.hs
+++ b/src/full/Agda/Interaction/SearchAbout.hs
@@ -28,7 +28,7 @@ collectNamesInTerm :: Term -> [A.QName]
collectNamesInTerm (Var _ els) = collectNamesInElims els
collectNamesInTerm (Lam ty t) = collectNamesInTerm $ unAbs t
collectNamesInTerm (Def n els) = n : collectNamesInElims els
-collectNamesInTerm (Con n args) = conName n : collectNamesInArgs args
+collectNamesInTerm (Con n _ args) = conName n : collectNamesInArgs args
collectNamesInTerm (Pi dom cod) = collectNamesInType (Com.unDom dom) ++ collectNamesInType (unAbs cod)
collectNamesInTerm (Shared t) = collectNamesInTerm $ ignoreSharing $ derefPtr t
collectNamesInTerm _ = []
@@ -38,7 +38,7 @@ collectNamesInElims = concatMap collectNamesInElim
collectNamesInElim :: Elim -> [A.QName]
collectNamesInElim (Apply a) = collectNamesInTerm $ Com.unArg a
-collectNamesInElim (Proj n) = [n]
+collectNamesInElim (Proj _ n)= [n]
collectNamesInArgs :: Args -> [A.QName]
collectNamesInArgs = concatMap (collectNamesInTerm . Com.unArg)
@@ -68,7 +68,7 @@ findMentions norm rg nm = do
| otherwise = Right str
anames (DefinedName _ an) = [an]
- anames (FieldName an) = [an]
+ anames (FieldName ans) = ans
anames (ConstructorName ans) = ans
anames (PatternSynResName an) = [an]
anames _ = []
diff --git a/src/full/Agda/Main.hs b/src/full/Agda/Main.hs
index 1400682..2a2a688 100644
--- a/src/full/Agda/Main.hs
+++ b/src/full/Agda/Main.hs
@@ -12,6 +12,7 @@ import Data.Maybe
import System.Environment
import System.Exit
+import Agda.Syntax.Position (Range)
import Agda.Syntax.Concrete.Pretty ()
import Agda.Syntax.Abstract.Name (toTopLevelModuleName)
@@ -19,7 +20,7 @@ import Agda.Interaction.CommandLine
import Agda.Interaction.Options
import Agda.Interaction.Monad
import Agda.Interaction.EmacsTop (mimicGHCi)
-import Agda.Interaction.Imports (MaybeWarnings(..))
+import Agda.Interaction.Imports (MaybeWarnings'(..))
import qualified Agda.Interaction.Imports as Imp
import qualified Agda.Interaction.Highlighting.Dot as Dot
import qualified Agda.Interaction.Highlighting.LaTeX as LaTeX
@@ -40,9 +41,9 @@ import Agda.Utils.Lens
import Agda.Utils.Monad
import Agda.Utils.String
-import Agda.Tests
-import Agda.Version
+import Agda.VersionCommit
+import qualified Agda.Utils.Benchmark as UtilsBench
import Agda.Utils.Except ( MonadError(catchError, throwError) )
import Agda.Utils.Impossible
@@ -67,9 +68,6 @@ runAgdaWithOptions
runAgdaWithOptions generateHTML progName opts
| optShowHelp opts = liftIO printUsage
| optShowVersion opts = liftIO printVersion
- | optRunTests opts = liftIO $ do
- ok <- testSuite
- unless ok exitFailure
| isNothing (optInputFile opts)
&& not (optInteractive opts)
&& not (optGHCiInteraction opts)
@@ -77,15 +75,21 @@ runAgdaWithOptions generateHTML progName opts
| otherwise = do
-- Main function.
-- Bill everything to root of Benchmark trie.
- Bench.billTo [] (checkFile opts) `finally_` do
+ UtilsBench.setBenchmarking True
+ -- Andreas, Nisse, 2016-10-11 AIM XXIV
+ -- Turn benchmarking on provisionally, otherwise we lose track of time spent
+ -- on e.g. LaTeX-code generation.
+ -- Benchmarking might be turned off later by setCommandlineOptions
+
+ Bench.billTo [] checkFile `finally_` do
-- Print benchmarks.
Bench.print
-- Print accumulated statistics.
printStatistics 20 Nothing =<< use lensAccumStatistics
where
- checkFile :: CommandLineOptions -> TCM ()
- checkFile opts = do
+ checkFile :: TCM ()
+ checkFile = do
let i = optInteractive opts
ghci = optGHCiInteraction opts
ghc = optGhcCompile opts
@@ -126,22 +130,14 @@ runAgdaWithOptions generateHTML progName opts
file <- getInputFile
(i, mw) <- Imp.typeCheckMain file
- unsolvedOK <- optAllowUnsolved <$> pragmaOptions
-
- -- Reported unsolved problems as error unless unsolvedOK.
-- An interface is only generated if NoWarnings.
result <- case mw of
- -- Unsolved metas.
- SomeWarnings (Warnings w@(_:_) _)
- | not unsolvedOK -> typeError $ UnsolvedMetas w
- -- Unsolved constraints.
- 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
+ SomeWarnings ws -> do
+ ws' <- applyFlagsToTCWarnings RespectFlags ws
+ case ws' of
+ [] -> return Nothing
+ cuws -> tcWarningsToError cuws
+ NoWarnings -> return $ Just i
reportSDoc "main" 50 $ pretty i
@@ -152,7 +148,7 @@ runAgdaWithOptions generateHTML progName opts
Dot.generateDot $ i
whenM (optGenerateLaTeX <$> commandLineOptions) $
- LaTeX.generateLaTeX (toTopLevelModuleName $ iModuleName i) (iHighlighting i)
+ LaTeX.generateLaTeX i
return result
@@ -164,8 +160,8 @@ printUsage = do
-- | Print version information.
printVersion :: IO ()
-printVersion =
- putStrLn $ "Agda version " ++ version
+printVersion = do
+ putStrLn $ "Agda version " ++ versionWithCommitInfo
-- | What to do for bad options.
optionError :: String -> IO ()
@@ -178,7 +174,7 @@ runTCMPrettyErrors :: TCM () -> IO ()
runTCMPrettyErrors tcm = do
r <- runTCMTop $ tcm `catchError` \err -> do
s <- prettyError err
- liftIO $ putStrLn s
+ unless (null s) (liftIO $ putStrLn s)
throwError err
case r of
Right _ -> exitSuccess
diff --git a/src/full/Agda/Syntax/Abstract.hs b/src/full/Agda/Syntax/Abstract.hs
index 91a59cf..e58a222 100644
--- a/src/full/Agda/Syntax/Abstract.hs
+++ b/src/full/Agda/Syntax/Abstract.hs
@@ -1,10 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-| The abstract syntax. This is what you get after desugaring and scope
@@ -16,11 +11,12 @@ module Agda.Syntax.Abstract
, module Agda.Syntax.Abstract.Name
) where
-import Prelude hiding (foldl, foldr)
+import Prelude
import Control.Arrow (first)
import Control.Applicative
-import Data.Foldable as Fold
+import Data.Foldable (Foldable)
+import qualified Data.Foldable as Fold
import Data.Map (Map)
import Data.Maybe
import Data.Sequence (Seq, (<|), (><))
@@ -29,6 +25,7 @@ import Data.Traversable
import Data.Typeable (Typeable)
import Data.Void
+import Agda.Syntax.Concrete.Name (NumHoles(..))
import Agda.Syntax.Concrete (FieldAssignment'(..), exprFieldA)
import qualified Agda.Syntax.Concrete as C
import Agda.Syntax.Concrete.Pretty ()
@@ -39,9 +36,14 @@ import Agda.Syntax.Abstract.Name
import Agda.Syntax.Abstract.Name as A (QNamed)
import Agda.Syntax.Literal
import Agda.Syntax.Scope.Base
+import qualified Agda.Syntax.Internal as I
+import Agda.TypeChecking.Positivity.Occurrence
+
+import Agda.Utils.Functor
import Agda.Utils.Geniplate
import Agda.Utils.Lens
+import Agda.Utils.Pretty
#include "undefined.h"
import Agda.Utils.Impossible
@@ -52,8 +54,8 @@ type Args = [NamedArg Expr]
data Expr
= Var Name -- ^ Bound variable.
| Def QName -- ^ Constant: axiom, function, data or record type.
- | Proj QName -- ^ Projection.
- | Con AmbiguousQName -- ^ Constructor.
+ | Proj ProjOrigin AmbiguousQName -- ^ Projection (overloaded).
+ | Con AmbiguousQName -- ^ Constructor (overloaded).
| PatternSyn QName -- ^ Pattern synonym.
| Macro QName -- ^ Macro.
| Lit Literal -- ^ Literal.
@@ -66,6 +68,7 @@ data Expr
-- 'metaNumber' to 'Nothing' while keeping the 'InteractionId'.
| Underscore MetaInfo
-- ^ Meta variable for hidden argument (must be inferred locally).
+ | Dot ExprInfo Expr -- ^ @.e@, for postfix projection.
| App ExprInfo Expr (NamedArg Expr) -- ^ Ordinary (binary) application.
| WithApp ExprInfo Expr [Expr] -- ^ With application.
| Lam ExprInfo LamBinding Expr -- ^ @λ bs → e@.
@@ -106,13 +109,35 @@ data Axiom
-- | Renaming (generic).
type Ren a = [(a, a)]
+data ScopeCopyInfo = ScopeCopyInfo
+ { renModules :: Ren ModuleName
+ , renNames :: Ren QName }
+ deriving (Eq, Show)
+
+initCopyInfo :: ScopeCopyInfo
+initCopyInfo = ScopeCopyInfo
+ { renModules = []
+ , renNames = []
+ }
+
+instance Pretty ScopeCopyInfo where
+ pretty i = vcat [ prRen "renModules =" (renModules i)
+ , prRen "renNames =" (renNames i) ]
+ where
+ prRen s r = sep [ text s, nest 2 $ vcat (map pr r) ]
+ pr (x, y) = pretty x <+> text "->" <+> pretty y
+
data Declaration
- = Axiom Axiom DefInfo ArgInfo QName Expr -- ^ type signature (can be irrelevant and colored, but not hidden)
+ = Axiom Axiom DefInfo ArgInfo (Maybe [Occurrence]) QName Expr
+ -- ^ Type signature (can be irrelevant, but not hidden).
+ --
+ -- The fourth argument contains an optional assignment of
+ -- polarities to arguments.
| Field DefInfo QName (Arg Expr) -- ^ record field
| Primitive DefInfo QName Expr -- ^ primitive function
| Mutual MutualInfo [Declaration] -- ^ a bunch of mutually recursive definitions
| Section ModuleInfo ModuleName [TypedBindings] [Declaration]
- | Apply ModuleInfo ModuleName ModuleApplication (Ren QName) (Ren ModuleName) ImportDirective
+ | Apply ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective
-- ^ The @ImportDirective@ is for highlighting purposes.
| Import ModuleInfo ModuleName ImportDirective
-- ^ The @ImportDirective@ is for highlighting purposes.
@@ -139,7 +164,7 @@ class GetDefInfo a where
getDefInfo :: a -> Maybe DefInfo
instance GetDefInfo Declaration where
- getDefInfo (Axiom _ i _ _ _) = Just i
+ getDefInfo (Axiom _ i _ _ _ _) = Just i
getDefInfo (Field i _ _) = Just i
getDefInfo (Primitive i _ _) = Just i
getDefInfo (ScopedDecl _ (d:_)) = getDefInfo d
@@ -177,7 +202,6 @@ data Pragma
| CompiledJSPragma QName String
| CompiledUHCPragma QName String
| CompiledDataUHCPragma QName String [String]
- | NoSmashingPragma QName
| StaticPragma QName
| InlinePragma QName
| DisplayPragma QName [NamedArg Pattern] Expr
@@ -189,8 +213,8 @@ data LetBinding
-- ^ @LetBind info rel name type defn@
| LetPatBind LetInfo Pattern Expr
-- ^ Irrefutable pattern binding.
- | LetApply ModuleInfo ModuleName ModuleApplication (Ren QName) (Ren ModuleName) ImportDirective
- -- ^ @LetApply mi newM (oldM args) renaming moduleRenaming dir@.
+ | LetApply ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective
+ -- ^ @LetApply mi newM (oldM args) renamings dir@.
-- The @ImportDirective@ is for highlighting purposes.
| LetOpen ModuleInfo ModuleName ImportDirective
-- ^ only for highlighting and abstractToConcrete
@@ -238,11 +262,20 @@ data TypedBinding
type Telescope = [TypedBindings]
+data NamedDotPattern = NamedDot Name I.Term I.Type
+ deriving (Typeable, Show)
+
+instance Eq NamedDotPattern where
+ _ == _ = True -- These are not relevant for caching purposes
+
-- | We could throw away @where@ clauses at this point and translate them to
-- @let@. It's not obvious how to remember that the @let@ was really a
-- @where@ clause though, so for the time being we keep it here.
data Clause' lhs = Clause
{ clauseLHS :: lhs
+ , clauseNamedDots :: [NamedDotPattern]
+ -- ^ Only in with-clauses where we inherit some already checked dot patterns from the parent.
+ -- These live in the context of the parent clause left-hand side.
, clauseRHS :: RHS
, clauseWhereDecls :: [Declaration]
, clauseCatchall :: Bool
@@ -252,19 +285,38 @@ type Clause = Clause' LHS
type SpineClause = Clause' SpineLHS
data RHS
- = RHS Expr
+ = RHS
+ { rhsExpr :: Expr
+ , rhsConcrete :: Maybe C.Expr
+ -- ^ We store the original concrete expression in case
+ -- we have to reproduce it during interactive case splitting.
+ -- 'Nothing' for internally generated rhss.
+ }
| AbsurdRHS
| WithRHS QName [Expr] [Clause]
-- ^ The 'QName' is the name of the with function.
- | RewriteRHS [(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@.
- deriving (Typeable, Show, Eq)
+ | RewriteRHS
+ { rewriteExprs :: [(QName, Expr)]
+ -- ^ The 'QName's are the names of the generated with functions,
+ -- one for each 'Expr'.
+ , rewriteRHS :: RHS
+ -- ^ The RHS should not be another @RewriteRHS@.
+ , rewriteWhereDecls :: [Declaration]
+ -- ^ The where clauses are attached to the @RewriteRHS@ by
+ --- the scope checker (instead of to the clause).
+ }
+ deriving (Typeable, Show)
+
+instance Eq RHS where
+ RHS e _ == RHS e' _ = e == e'
+ AbsurdRHS == AbsurdRHS = True
+ WithRHS a b c == WithRHS a' b' c' = and [ a == a', b == b', c == c' ]
+ RewriteRHS a b c == RewriteRHS a' b' c' = and [ a == a', b == b', c == c' ]
+ _ == _ = False
-- | The lhs of a clause in spine view (inside-out).
-- Projection patterns are contained in @spLhsPats@,
--- represented as @DefP d []@.
+-- represented as @ProjP d@.
data SpineLHS = SpineLHS
{ spLhsInfo :: LHSInfo -- ^ Range.
, spLhsDefName :: QName -- ^ Name of function we are defining.
@@ -294,11 +346,8 @@ data LHSCore' e
, lhsPats :: [NamedArg (Pattern' e)] -- ^ Applied to patterns @ps@.
}
-- | Projection
- | LHSProj { lhsDestructor :: QName
+ | LHSProj { lhsDestructor :: AmbiguousQName
-- ^ Record projection identifier.
- , lhsPatsLeft :: [NamedArg (Pattern' e)]
- -- ^ Indices of the projection.
- -- Currently none @[]@, since we do not have indexed records.
, lhsFocus :: NamedArg (LHSCore' e)
-- ^ Main branch.
, lhsPatsRight :: [NamedArg (Pattern' e)]
@@ -331,29 +380,33 @@ instance LHSToSpine LHS SpineLHS where
lhsCoreToSpine :: LHSCore' e -> A.QNamed [NamedArg (Pattern' e)]
lhsCoreToSpine (LHSHead f ps) = QNamed f ps
-lhsCoreToSpine (LHSProj d ps1 h ps2) = (++ (p : ps2)) <$> lhsCoreToSpine (namedArg h)
- where p = updateNamedArg (const $ DefP patNoRange d ps1) h
+lhsCoreToSpine (LHSProj d h ps) = (++ (p : ps)) <$> lhsCoreToSpine (namedArg h)
+ where p = updateNamedArg (const $ ProjP patNoRange ProjPrefix d) h
-spineToLhsCore :: QNamed [NamedArg (Pattern' e)] -> LHSCore' e
+spineToLhsCore :: IsProjP e => QNamed [NamedArg (Pattern' e)] -> LHSCore' e
spineToLhsCore (QNamed f ps) = lhsCoreAddSpine (LHSHead f []) ps
-- | Add applicative patterns (non-projection patterns) to the right.
-lhsCoreApp :: 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'
+lhsCoreApp :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
+lhsCoreApp (LHSHead f ps) ps' = LHSHead f $ ps ++ ps'
+lhsCoreApp (LHSProj d h ps) ps' = LHSProj d h $ ps ++ ps'
-- | Add projection and applicative patterns to the right.
-lhsCoreAddSpine :: LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
+lhsCoreAddSpine :: IsProjP e => LHSCore' e -> [NamedArg (Pattern' e)] -> LHSCore' e
lhsCoreAddSpine core ps = case ps2 of
- (Arg info (Named n (DefP i d ps0)) : ps2') ->
- LHSProj d ps0 (Arg info $ Named n $ lhsCoreApp core ps1) []
- `lhsCoreAddSpine` ps2'
[] -> lhsCoreApp core ps
+ p@(Arg info (Named n (ProjP i o d))) : ps2' | let nh = numHoles d->
+ -- Andreas, 2016-06-13
+ -- If the projection was written prefix by the user
+ -- or it is fully applied an operator
+ -- we turn it to prefix projection form.
+ (if o == ProjPrefix || nh > 0 && nh <= 1 + length ps2' then
+ LHSProj d (Arg info $ Named n $ lhsCoreApp core ps1) []
+ else lhsCoreApp core $ ps1 ++ [p])
+ `lhsCoreAddSpine` ps2'
_ -> __IMPOSSIBLE__
where
- (ps1, ps2) = break (isDefP . namedArg) ps
- isDefP DefP{} = True
- isDefP _ = False
+ (ps1, ps2) = break (isJust . isProjP) ps
-- | Used for checking pattern linearity.
lhsCoreAllPatterns :: LHSCore' e -> [Pattern' e]
@@ -363,15 +416,14 @@ lhsCoreAllPatterns = map namedArg . qnamed . lhsCoreToSpine
lhsCoreToPattern :: LHSCore -> Pattern
lhsCoreToPattern lc =
case lc of
- LHSHead f aps -> DefP noInfo f aps
- LHSProj d aps1 lhscore aps2 -> DefP noInfo d $
- aps1 ++ fmap (fmap lhsCoreToPattern) lhscore : aps2
+ LHSHead f aps -> DefP noInfo (AmbQ [f]) aps
+ LHSProj d lhscore aps -> DefP noInfo d $
+ fmap (fmap lhsCoreToPattern) lhscore : aps
where noInfo = patNoRange -- TODO, preserve range!
mapLHSHead :: (QName -> [NamedArg Pattern] -> LHSCore) -> LHSCore -> LHSCore
-mapLHSHead f (LHSHead x ps) = f x ps
-mapLHSHead f (LHSProj d ps1 l ps2) =
- LHSProj d ps1 (fmap (fmap (mapLHSHead f)) l) ps2
+mapLHSHead f (LHSHead x ps) = f x ps
+mapLHSHead f (LHSProj d l ps) = LHSProj d (fmap (fmap (mapLHSHead f)) l) ps
---------------------------------------------------------------------------
-- * Patterns
@@ -381,13 +433,17 @@ mapLHSHead f (LHSProj d ps1 l ps2) =
data Pattern' e
= VarP Name
| ConP ConPatInfo AmbiguousQName [NamedArg (Pattern' e)]
- | DefP PatInfo QName [NamedArg (Pattern' e)]
- -- ^ Defined pattern: function definition @f ps@ or destructor pattern @d p ps@.
+ | ProjP PatInfo ProjOrigin AmbiguousQName
+ -- ^ Destructor pattern @d@.
+ | DefP PatInfo AmbiguousQName [NamedArg (Pattern' e)]
+ -- ^ Defined pattern: function definition @f ps@.
+ -- It is also abused to convert destructor patterns into concrete syntax
+ -- thus, we put AmbiguousQName here as well.
| WildP PatInfo
-- ^ Underscore pattern entered by user.
-- Or generated at type checking for implicit arguments.
| AsP PatInfo Name (Pattern' e)
- | DotP PatInfo e
+ | DotP PatInfo Origin e
| AbsurdP PatInfo
| LitP Literal
| PatternSynP PatInfo QName [NamedArg (Pattern' e)]
@@ -397,38 +453,49 @@ data Pattern' e
type Pattern = Pattern' Expr
type Patterns = [NamedArg Pattern]
--- | Check whether we are a projection pattern.
-class IsProjP a where
- isProjP :: a -> Maybe QName
-
instance IsProjP (Pattern' e) where
- isProjP (DefP _ d []) = Just d
- isProjP _ = Nothing
+ isProjP (ProjP _ o d) = Just (o, d)
+ isProjP _ = Nothing
+
+instance IsProjP Expr where
+ isProjP (Proj o ds) = Just (o, ds)
+ isProjP (ScopedExpr _ e) = isProjP e
+ isProjP _ = Nothing
-instance IsProjP a => IsProjP (Arg a) where
- isProjP = isProjP . unArg
+class MaybePostfixProjP a where
+ maybePostfixProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)
-instance IsProjP a => IsProjP (Named n a) where
- isProjP = isProjP . namedThing
+instance IsProjP e => MaybePostfixProjP (Pattern' e) where
+ maybePostfixProjP (DotP _ _ e) = isProjP e <&> \ (_o, d) -> (ProjPostfix, d)
+ maybePostfixProjP (ProjP _ o d) = Just (o, d)
+ maybePostfixProjP _ = Nothing
+
+instance MaybePostfixProjP a => MaybePostfixProjP (Arg a) where
+ maybePostfixProjP = maybePostfixProjP . unArg
+
+instance MaybePostfixProjP a => MaybePostfixProjP (Named n a) where
+ maybePostfixProjP = maybePostfixProjP . namedThing
{--------------------------------------------------------------------------
Instances
--------------------------------------------------------------------------}
-- | Does not compare 'ScopeInfo' fields.
+-- Does not distinguish between prefix and postfix projections.
instance Eq Expr where
ScopedExpr _ a1 == ScopedExpr _ a2 = a1 == a2
Var a1 == Var a2 = a1 == a2
Def a1 == Def a2 = a1 == a2
- Proj a1 == Proj a2 = a1 == a2
+ Proj _ a1 == Proj _ a2 = a1 == a2
Con a1 == Con a2 = a1 == a2
PatternSyn a1 == PatternSyn a2 = a1 == a2
Macro a1 == Macro a2 = a1 == a2
Lit a1 == Lit a2 = a1 == a2
QuestionMark a1 b1 == QuestionMark a2 b2 = (a1, b1) == (a2, b2)
Underscore a1 == Underscore a2 = a1 == a2
+ Dot r1 e1 == Dot r2 e2 = (r1, e1) == (r2, e2)
App a1 b1 c1 == App a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
WithApp a1 b1 c1 == WithApp a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Lam a1 b1 c1 == Lam a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
@@ -457,12 +524,12 @@ instance Eq Expr where
instance Eq Declaration where
ScopedDecl _ a1 == ScopedDecl _ a2 = a1 == a2
- Axiom a1 b1 c1 d1 e1 == Axiom a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)
+ Axiom a1 b1 c1 d1 e1 f1 == Axiom a2 b2 c2 d2 e2 f2 = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)
Field a1 b1 c1 == Field a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Primitive a1 b1 c1 == Primitive a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Mutual a1 b1 == Mutual a2 b2 = (a1, b1) == (a2, b2)
Section a1 b1 c1 d1 == Section a2 b2 c2 d2 = (a1, b1, c1, d1) == (a2, b2, c2, d2)
- Apply a1 b1 c1 d1 e1 f1 == Apply a2 b2 c2 d2 e2 f2 = (a1, b1, c1, d1, e1, f1) == (a2, b2, c2, d2, e2, f2)
+ Apply a1 b1 c1 d1 e1 == Apply a2 b2 c2 d2 e2 = (a1, b1, c1, d1, e1) == (a2, b2, c2, d2, e2)
Import a1 b1 c1 == Import a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
Pragma a1 b1 == Pragma a2 b2 = (a1, b1) == (a2, b2)
Open a1 b1 c1 == Open a2 b2 c2 = (a1, b1, c1) == (a2, b2, c2)
@@ -505,11 +572,12 @@ instance HasRange TypedBinding where
instance HasRange Expr where
getRange (Var x) = getRange x
getRange (Def x) = getRange x
- getRange (Proj x) = getRange x
+ getRange (Proj _ x) = getRange x
getRange (Con x) = getRange x
getRange (Lit l) = getRange l
getRange (QuestionMark i _) = getRange i
getRange (Underscore i) = getRange i
+ getRange (Dot i _) = getRange i
getRange (App i _ _) = getRange i
getRange (WithApp i _ _) = getRange i
getRange (Lam i _ _) = getRange i
@@ -535,11 +603,11 @@ instance HasRange Expr where
getRange (Macro x) = getRange x
instance HasRange Declaration where
- getRange (Axiom _ i _ _ _ ) = getRange i
+ getRange (Axiom _ i _ _ _ _ ) = getRange i
getRange (Field i _ _ ) = getRange i
getRange (Mutual i _ ) = getRange i
getRange (Section i _ _ _ ) = getRange i
- getRange (Apply i _ _ _ _ _) = getRange i
+ getRange (Apply i _ _ _ _) = getRange i
getRange (Import i _ _ ) = getRange i
getRange (Primitive i _ _ ) = getRange i
getRange (Pragma i _ ) = getRange i
@@ -557,10 +625,11 @@ instance HasRange Declaration where
instance HasRange (Pattern' e) where
getRange (VarP x) = getRange x
getRange (ConP i _ _) = getRange i
+ getRange (ProjP i _ _) = getRange i
getRange (DefP i _ _) = getRange i
getRange (WildP i) = getRange i
getRange (AsP i _ _) = getRange i
- getRange (DotP i _) = getRange i
+ getRange (DotP i _ _) = getRange i
getRange (AbsurdP i) = getRange i
getRange (LitP l) = getRange l
getRange (PatternSynP i _ _) = getRange i
@@ -574,21 +643,21 @@ instance HasRange LHS where
instance HasRange (LHSCore' e) where
getRange (LHSHead f ps) = fuseRange f ps
- getRange (LHSProj d ps1 lhscore ps2) = d `fuseRange` ps1 `fuseRange` lhscore `fuseRange` ps2
+ getRange (LHSProj d lhscore ps) = d `fuseRange` lhscore `fuseRange` ps
instance HasRange a => HasRange (Clause' a) where
- getRange (Clause lhs rhs ds catchall) = getRange (lhs,rhs,ds)
+ getRange (Clause lhs _ rhs ds catchall) = getRange (lhs,rhs,ds)
instance HasRange RHS where
getRange AbsurdRHS = noRange
- getRange (RHS e) = getRange e
+ getRange (RHS e _) = getRange e
getRange (WithRHS _ e cs) = fuseRange e cs
getRange (RewriteRHS xes rhs wh) = getRange (map snd xes, rhs, wh)
instance HasRange LetBinding where
getRange (LetBind i _ _ _ _ ) = getRange i
getRange (LetPatBind i _ _ ) = getRange i
- getRange (LetApply i _ _ _ _ _ ) = getRange i
+ getRange (LetApply i _ _ _ _ ) = getRange i
getRange (LetOpen i _ _ ) = getRange i
getRange (LetDeclaredVariable x) = getRange x
@@ -596,10 +665,11 @@ instance HasRange LetBinding where
instance SetRange (Pattern' a) where
setRange r (VarP x) = VarP (setRange r x)
setRange r (ConP i ns as) = ConP (setRange r i) ns as
- setRange r (DefP _ n as) = DefP (PatRange r) (setRange r n) as
+ setRange r (ProjP _ o ns) = ProjP (PatRange r) o ns
+ setRange r (DefP _ ns as) = DefP (PatRange r) ns as -- (setRange r n) as
setRange r (WildP _) = WildP (PatRange r)
setRange r (AsP _ n p) = AsP (PatRange r) (setRange r n) p
- setRange r (DotP _ e) = DotP (PatRange r) e
+ setRange r (DotP _ o e) = DotP (PatRange r) o e
setRange r (AbsurdP _) = AbsurdP (PatRange r)
setRange r (LitP l) = LitP (setRange r l)
setRange r (PatternSynP _ n as) = PatternSynP (PatRange r) (setRange r n) as
@@ -619,11 +689,12 @@ 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 (Proj o x) = killRange1 (Proj o) x
killRange (Con x) = killRange1 Con x
killRange (Lit l) = killRange1 Lit l
killRange (QuestionMark i ii) = killRange2 QuestionMark i ii
killRange (Underscore i) = killRange1 Underscore i
+ killRange (Dot i e) = killRange2 Dot i e
killRange (App i e1 e2) = killRange3 App i e1 e2
killRange (WithApp i e es) = killRange3 WithApp i e es
killRange (Lam i b e) = killRange3 Lam i b e
@@ -649,13 +720,11 @@ instance KillRange Expr where
killRange (Macro x) = killRange1 Macro x
instance KillRange Declaration where
- killRange (Axiom p i rel a b ) = killRange4 (Axiom p) i rel a b
+ killRange (Axiom p i a b c d ) = killRange4 (\i a c d -> Axiom p i a b c d) i a c d
killRange (Field i a b ) = killRange3 Field i a b
killRange (Mutual i a ) = killRange2 Mutual i a
killRange (Section i a b c ) = killRange4 Section i a b c
- killRange (Apply i a b c d e ) = killRange3 Apply i a b c d (killRange e)
- -- the arguments c and d of Apply are name maps, so nothing to kill
- -- Andreas, 2016-01-24 really?
+ killRange (Apply i a b c d ) = killRange5 Apply i a b c d
killRange (Import i a b ) = killRange3 Import i a b
killRange (Primitive i a b ) = killRange3 Primitive i a b
killRange (Pragma i a ) = Pragma (killRange i) a
@@ -674,13 +743,17 @@ instance KillRange ModuleApplication where
killRange (SectionApp a b c ) = killRange3 SectionApp a b c
killRange (RecordModuleIFS a ) = killRange1 RecordModuleIFS a
+instance KillRange ScopeCopyInfo where
+ killRange (ScopeCopyInfo a b) = killRange2 ScopeCopyInfo a b
+
instance KillRange e => KillRange (Pattern' e) where
killRange (VarP x) = killRange1 VarP x
killRange (ConP i a b) = killRange3 ConP i a b
+ killRange (ProjP i o a) = killRange3 ProjP i o a
killRange (DefP i a b) = killRange3 DefP i a b
killRange (WildP i) = killRange1 WildP i
killRange (AsP i a b) = killRange3 AsP i a b
- killRange (DotP i a) = killRange2 DotP i a
+ killRange (DotP i o a) = killRange3 DotP i o a
killRange (AbsurdP i) = killRange1 AbsurdP i
killRange (LitP l) = killRange1 LitP l
killRange (PatternSynP i a p) = killRange3 PatternSynP i a p
@@ -693,22 +766,25 @@ instance KillRange LHS where
killRange (LHS i a b) = killRange3 LHS i a b
instance KillRange e => KillRange (LHSCore' e) where
- killRange (LHSHead a b) = killRange2 LHSHead a b
- killRange (LHSProj a b c d) = killRange4 LHSProj a b c d
+ killRange (LHSHead a b) = killRange2 LHSHead a b
+ killRange (LHSProj a b c) = killRange3 LHSProj a b c
instance KillRange a => KillRange (Clause' a) where
- killRange (Clause lhs rhs ds catchall) = killRange4 Clause lhs rhs ds catchall
+ killRange (Clause lhs dots rhs ds catchall) = killRange5 Clause lhs dots rhs ds catchall
+
+instance KillRange NamedDotPattern where
+ killRange (NamedDot a b c) = killRange3 NamedDot a b c
instance KillRange RHS where
killRange AbsurdRHS = AbsurdRHS
- killRange (RHS e) = killRange1 RHS e
+ killRange (RHS e c) = killRange2 RHS e c
killRange (WithRHS q e cs) = killRange3 WithRHS q e cs
killRange (RewriteRHS xes rhs wh) = killRange3 RewriteRHS xes rhs wh
instance KillRange LetBinding where
killRange (LetBind i info a b c) = killRange5 LetBind i info a b c
killRange (LetPatBind i a b ) = killRange3 LetPatBind i a b
- killRange (LetApply i a b c d e ) = killRange3 LetApply i a b c d (killRange e)
+ killRange (LetApply i a b c d ) = killRange5 LetApply i a b c d
killRange (LetOpen i x dir ) = killRange3 LetOpen i x dir
killRange (LetDeclaredVariable x) = killRange1 LetDeclaredVariable x
@@ -760,7 +836,7 @@ instance AllNames QName where
allNames q = Seq.singleton q
instance AllNames Declaration where
- allNames (Axiom _ _ _ q _) = Seq.singleton q
+ allNames (Axiom _ _ _ _ q _) = Seq.singleton q
allNames (Field _ q _) = Seq.singleton q
allNames (Primitive _ q _) = Seq.singleton q
allNames (Mutual _ defs) = allNames defs
@@ -780,10 +856,10 @@ instance AllNames Declaration where
allNames (ScopedDecl _ decls) = allNames decls
instance AllNames Clause where
- allNames (Clause _ rhs decls _) = allNames rhs >< allNames decls
+ allNames (Clause _ _ rhs decls _) = allNames rhs >< allNames decls
instance AllNames RHS where
- allNames (RHS e) = allNames e
+ allNames (RHS e _) = allNames e
allNames AbsurdRHS{} = Seq.empty
allNames (WithRHS q _ cls) = q <| allNames cls
allNames (RewriteRHS qes rhs cls) = Seq.fromList (map fst qes) >< allNames rhs >< allNames cls
@@ -796,6 +872,7 @@ instance AllNames Expr where
allNames Lit{} = Seq.empty
allNames QuestionMark{} = Seq.empty
allNames Underscore{} = Seq.empty
+ allNames (Dot _ e) = allNames e
allNames (App _ e1 e2) = allNames e1 >< allNames e2
allNames (WithApp _ e es) = allNames e >< allNames es
allNames (Lam _ b e) = allNames b >< allNames e
@@ -832,11 +909,11 @@ instance AllNames TypedBinding where
allNames (TLet _ lbs) = allNames lbs
instance AllNames LetBinding where
- allNames (LetBind _ _ _ e1 e2) = allNames e1 >< allNames e2
- allNames (LetPatBind _ _ e) = allNames e
- allNames (LetApply _ _ app _ _ _) = allNames app
- allNames LetOpen{} = Seq.empty
- allNames (LetDeclaredVariable _) = Seq.empty
+ allNames (LetBind _ _ _ e1 e2) = allNames e1 >< allNames e2
+ allNames (LetPatBind _ _ e) = allNames e
+ allNames (LetApply _ _ app _ _) = allNames app
+ allNames LetOpen{} = Seq.empty
+ allNames (LetDeclaredVariable _) = Seq.empty
instance AllNames ModuleApplication where
allNames (SectionApp bindss _ es) = allNames bindss >< allNames es
@@ -847,7 +924,7 @@ instance AllNames ModuleApplication where
-- Precondition: The declaration has to be a (scoped) 'Axiom'.
axiomName :: Declaration -> QName
-axiomName (Axiom _ _ _ q _) = q
+axiomName (Axiom _ _ _ _ q _) = q
axiomName (ScopedDecl _ (d:_)) = axiomName d
axiomName _ = __IMPOSSIBLE__
@@ -861,7 +938,7 @@ instance AnyAbstract a => AnyAbstract [a] where
anyAbstract = Fold.any anyAbstract
instance AnyAbstract Declaration where
- anyAbstract (Axiom _ i _ _ _) = defAbstract i == AbstractDef
+ anyAbstract (Axiom _ i _ _ _ _) = defAbstract i == AbstractDef
anyAbstract (Field i _ _) = defAbstract i == AbstractDef
anyAbstract (Mutual _ ds) = anyAbstract ds
anyAbstract (ScopedDecl _ ds) = anyAbstract ds
@@ -878,7 +955,7 @@ nameExpr :: AbstractName -> Expr
nameExpr d = mk (anameKind d) $ anameName d
where
mk DefName x = Def x
- mk FldName x = Proj x
+ mk FldName x = Proj ProjSystem $ AmbQ [x]
mk ConName x = Con $ AmbQ [x]
mk PatternSynName x = PatternSyn x
mk MacroName x = Macro x
@@ -896,11 +973,13 @@ patternToExpr :: Pattern -> Expr
patternToExpr (VarP x) = Var x
patternToExpr (ConP _ c ps) =
Con c `app` map (fmap (fmap patternToExpr)) ps
-patternToExpr (DefP _ f ps) =
+patternToExpr (ProjP _ o ds) = Proj o ds
+patternToExpr (DefP _ (AmbQ [f]) ps) =
Def f `app` map (fmap (fmap patternToExpr)) ps
+patternToExpr (DefP _ (AmbQ _) ps) = __IMPOSSIBLE__
patternToExpr (WildP _) = Underscore emptyMetaInfo
patternToExpr (AsP _ _ p) = patternToExpr p
-patternToExpr (DotP _ e) = e
+patternToExpr (DotP _ _ e) = e
patternToExpr (AbsurdP _) = Underscore emptyMetaInfo -- TODO: could this happen?
patternToExpr (LitP l) = Lit l
patternToExpr (PatternSynP _ _ _) = __IMPOSSIBLE__
@@ -919,12 +998,13 @@ substPattern s p = case p of
VarP z -> fromMaybe p (lookup z s)
ConP i q ps -> ConP i q (map (fmap (fmap (substPattern s))) ps)
RecP i ps -> RecP i (map (fmap (substPattern s)) ps)
+ ProjP{} -> p
WildP i -> p
- DotP i e -> DotP i (substExpr (map (fmap patternToExpr) s) e)
+ DotP i o e -> DotP i o (substExpr (map (fmap patternToExpr) s) e)
AbsurdP i -> p
LitP l -> p
DefP{} -> p -- destructor pattern
- AsP{} -> __IMPOSSIBLE__ -- @-patterns (not supported anyways)
+ AsP i x p -> AsP i x (substPattern s p) -- Note: cannot substitute into as-variable
PatternSynP{} -> __IMPOSSIBLE__ -- pattern synonyms (already gone)
class SubstExpr a where
@@ -964,6 +1044,7 @@ instance SubstExpr Expr where
Lit _ -> e
QuestionMark{} -> e
Underscore _ -> e
+ Dot i e -> Dot i (substExpr s e)
App i e e' -> App i (substExpr s e) (substExpr s e')
WithApp i e es -> WithApp i (substExpr s e) (substExpr s es)
Lam i lb e -> Lam i lb (substExpr s e)
diff --git a/src/full/Agda/Syntax/Abstract/Copatterns.hs b/src/full/Agda/Syntax/Abstract/Copatterns.hs
index 0600c9b..7c420e2 100644
--- a/src/full/Agda/Syntax/Abstract/Copatterns.hs
+++ b/src/full/Agda/Syntax/Abstract/Copatterns.hs
@@ -1,11 +1,5 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TupleSections #-}
module Agda.Syntax.Abstract.Copatterns (translateCopatternClauses) where
@@ -30,6 +24,7 @@ import Agda.Syntax.Scope.Monad
import Agda.TypeChecking.Monad.Base (TypeError(..), typeError)
import Agda.Utils.Either
+import Agda.Utils.Maybe
import Agda.Utils.Tuple
#include "undefined.h"
@@ -139,18 +134,12 @@ translateCopatternClauses cs = if all noCopats cs then return (NotDelayed, cs) e
pcs :: [ProjPath Clause] <- mapM clauseToPath cs
let cps :: [(Clause, [ProjPath Expr])]
cps = groupClauses pcs
-{-
- cps = map ((theContent . head) /\ map (fmap (rhsExpr . clauseRHS))) $
- groupBy ((==) `on` clauseLHS . theContent) pcs
--}
ces <- mapM (mapSndM pathToRecord) $
map (mapSnd $ sortBy (compare `on` thePath)) cps
- return $ map (\ (c, e) -> c { clauseRHS = RHS e }) ces
+ return $ map (\ (c, e) -> c { clauseRHS = RHS e Nothing }) ces -- TODO: preserve C.Expr
where
noCopats Clause{ clauseLHS = LHS _ LHSHead{} _ } = True
noCopats _ = False
- rhsExpr (RHS e) = e
- rhsExpr _ = __IMPOSSIBLE__
-- | A sequence of decisions @b@ leading to a head @a@.
data Path a b = Path
@@ -162,7 +151,7 @@ mapContent :: (b -> c) -> Path a b -> Path a c
mapContent f (Path p c) = Path p (f c)
data ProjEntry = ProjEntry
- { projPE :: QName
+ { projPE :: AmbiguousQName
, patsPE :: [NamedArg Name] -- ^ currently we only support variable patterns
} deriving (Eq, Ord)
@@ -187,24 +176,23 @@ groupClauses (pc@(Path p c) : pcs) = (c, Path p (rhs c) : grp) : groupClauses re
collect [] = ([], [])
rhs = rhsExpr . clauseRHS
- rhsExpr (RHS e) = e
+ rhsExpr (RHS e _ ) = e -- TODO: preserve C.Expr
rhsExpr _ = __IMPOSSIBLE__
clauseToPath :: Clause -> ScopeM (ProjPath Clause)
-clauseToPath (Clause (LHS i lhs wps) (RHS e) [] catchall) =
- fmap (\ lhs -> Clause (LHS i lhs wps) (RHS e) [] catchall) <$> lhsToPath [] lhs
-clauseToPath (Clause lhs (RHS e) (_:_) _) = typeError $ NotImplemented $ "copattern clauses with where declarations"
-clauseToPath (Clause lhs _ wheredecls _) = typeError $ NotImplemented $ "copattern clauses with absurd, with or rewrite right hand side"
+clauseToPath (Clause (LHS i lhs wps) dots (RHS e c) [] catchall) =
+ fmap (\ lhs -> Clause (LHS i lhs wps) dots (RHS e c) [] catchall) <$> lhsToPath [] lhs
+clauseToPath (Clause lhs _ (RHS e _) (_:_) _) = typeError $ NotImplemented $ "copattern clauses with where declarations"
+clauseToPath (Clause lhs _ _ wheredecls _) = typeError $ NotImplemented $ "copattern clauses with absurd, with or rewrite right hand side"
lhsToPath :: [ProjEntry] -> LHSCore -> ScopeM (ProjPath LHSCore)
lhsToPath acc lhs@LHSHead{} = return $ Path acc lhs
-lhsToPath acc (LHSProj f [] lhs ps) | Just xs <- mapM (T.mapM (T.mapM fromVarP)) ps =
+lhsToPath acc (LHSProj f lhs ps) = do
+ let xs = fromMaybe __IMPOSSIBLE__ $ mapM (T.mapM (T.mapM fromVarP)) ps
lhsToPath (ProjEntry f xs : acc) $ namedArg lhs
where fromVarP :: Pattern -> Maybe Name
fromVarP (VarP n) = Just n
fromVarP _ = Nothing
-lhsToPath acc (LHSProj f _ lhs _) = typeError $ NotImplemented $
- "copatterns with patterns before the principal argument"
-- | Expects a sorted list.
pathToRecord :: [ProjPath Expr] -> ScopeM Expr
@@ -220,7 +208,8 @@ pathToRecord pps =
where
abstractions :: (ProjEntry, Expr) -> ScopeM RecordAssign
- abstractions (ProjEntry p xs, e) = Left . FieldAssignment (C.unqualify $ qnameToConcrete p) <$>
+ abstractions (ProjEntry (AmbQ []) xs, e) = __IMPOSSIBLE__
+ abstractions (ProjEntry (AmbQ (p:_)) xs, e) = Left . FieldAssignment (C.unqualify $ qnameToConcrete p) <$>
foldr abstract (return e) xs
abstract :: NamedArg Name -> ScopeM Expr -> ScopeM Expr
@@ -267,18 +256,19 @@ instance Rename QName where
rename _ q = q
instance Rename Name where
- rename rho x = maybe x id (rho x)
+ rename rho x = fromMaybe x (rho x)
instance Rename Expr where
rename rho e =
case e of
Var x -> Var (rename rho x)
Def f -> e
- Proj f -> e
+ Proj{} -> e
Con c -> e
Lit l -> e
QuestionMark{} -> e
Underscore i -> e
+ Dot i e -> Dot i (rename rho e)
App i e es -> App i (rename rho e) (rename rho es)
WithApp i e es -> WithApp i (rename rho e) (rename rho es)
Lam i lb e -> Lam i (rename rho lb) (rename rho e)
@@ -332,12 +322,15 @@ instance Rename TypedBinding where
rename rho (TLet r lbs) = TLet r (rename rho lbs)
instance Rename Clause where
- rename rho (Clause lhs rhs wheredecls catchall) =
- Clause (rename rho lhs) (rename rho rhs) (rename rho wheredecls) catchall
+ rename rho (Clause lhs dots rhs wheredecls catchall) =
+ Clause (rename rho lhs) (rename rho dots) (rename rho rhs) (rename rho wheredecls) catchall
+
+instance Rename NamedDotPattern where
+ rename rho (NamedDot x v t) = NamedDot (rename rho x) v t
instance Rename RHS where
rename rho e = case e of
- RHS e -> RHS (rename rho e)
+ RHS e c -> RHS (rename rho e) c
AbsurdRHS -> e
WithRHS n es cs -> WithRHS n (rename rho es) (rename rho cs)
RewriteRHS nes r ds -> RewriteRHS (rename rho nes) (rename rho r) (rename rho ds)
@@ -389,7 +382,7 @@ instance Alpha (Pattern' e) where
((DefP _ x ps) , (DefP _ x' ps') ) -> guard (x == x') >> alpha' ps ps'
((WildP _) , (WildP _) ) -> return ()
((AsP _ x p) , (AsP _ x' p') ) -> tell1 (x, x') >> alpha' p p'
- ((DotP _ _) , (DotP _ _) ) -> return ()
+ ((DotP _ _ _) , (DotP _ _ _) ) -> return ()
(AbsurdP{} , AbsurdP{} ) -> return ()
((LitP l) , (LitP l') ) -> guard (l == l')
((PatternSynP _ x ps) , (PatternSynP _ x' ps')) -> guard (x == x') >> alpha' ps ps'
@@ -400,8 +393,8 @@ tell1 a = tell [a]
instance Alpha (LHSCore' e) where
alpha' (LHSHead f ps) (LHSHead f' ps') = guard (f == f') >> alpha' ps ps'
- alpha' (LHSProj d ps1 lhs ps2) (LHSProj d' ps1' lhs' ps2') =
- guard (d == d') >> alpha' ps1 ps1' >> alpha' lhs lhs' >> alpha' ps2 ps2'
+ alpha' (LHSProj d lhs ps) (LHSProj d' lhs' ps') =
+ guard (d == d') >> alpha' lhs lhs' >> alpha' ps ps'
alpha' _ _ = fail "not alpha equivalent"
instance Alpha LHS where
diff --git a/src/full/Agda/Syntax/Abstract/Name.hs b/src/full/Agda/Syntax/Abstract/Name.hs
index 95259bc..2e51e46 100644
--- a/src/full/Agda/Syntax/Abstract/Name.hs
+++ b/src/full/Agda/Syntax/Abstract/Name.hs
@@ -1,12 +1,6 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-| Abstract names carry unique identifiers and stuff.
-}
@@ -24,8 +18,6 @@ import Data.List
import Data.Function
import Data.Hashable
-import Test.QuickCheck
-
import Agda.Syntax.Position
import Agda.Syntax.Common
import {-# SOURCE #-} Agda.Syntax.Fixity
@@ -33,6 +25,7 @@ import Agda.Syntax.Concrete.Name (IsNoName(..), NumHoles(..))
import qualified Agda.Syntax.Concrete.Name as C
import Agda.Utils.List
+import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Pretty
import Agda.Utils.Size
@@ -81,7 +74,17 @@ newtype ModuleName = MName { mnameToList :: [Name] }
-- Invariant: All the names in the list must have the same concrete,
-- unqualified name. (This implies that they all have the same 'Range').
newtype AmbiguousQName = AmbQ { unAmbQ :: [QName] }
- deriving (Eq, Typeable)
+ deriving (Eq, Ord, Typeable)
+
+-- | Check whether we are a projection pattern.
+class IsProjP a where
+ isProjP :: a -> Maybe (ProjOrigin, AmbiguousQName)
+
+instance IsProjP a => IsProjP (Arg a) where
+ isProjP = isProjP . unArg
+
+instance IsProjP a => IsProjP (Named n a) where
+ isProjP = isProjP . namedThing
-- | A module is anonymous if the qualification path ends in an underscore.
isAnonymousModuleName :: ModuleName -> Bool
@@ -262,6 +265,10 @@ instance NumHoles Name where
instance NumHoles QName where
numHoles = numHoles . qnameName
+-- | We can have an instance for ambiguous names as all share a common concrete name.
+instance NumHoles AmbiguousQName where
+ numHoles (AmbQ qs) = numHoles $ fromMaybe __IMPOSSIBLE__ $ headMaybe qs
+
------------------------------------------------------------------------
-- * Show instances
------------------------------------------------------------------------
@@ -382,29 +389,6 @@ instance Sized ModuleName where
size = size . mnameToList
------------------------------------------------------------------------
--- * Arbitrary instances
-------------------------------------------------------------------------
-
--- | The generated names all have the same 'Fixity'': 'noFixity''.
-
-instance Arbitrary Name where
- arbitrary =
- Name <$> arbitrary <*> arbitrary <*> arbitrary
- <*> return noFixity'
-
-instance CoArbitrary Name where
- coarbitrary = coarbitrary . nameId
-
-instance Arbitrary QName where
- arbitrary = do
- ms <- arbitrary
- n <- arbitrary
- return (QName (MName ms) n)
-
-instance CoArbitrary QName where
- coarbitrary = coarbitrary . qnameName
-
-------------------------------------------------------------------------
-- * NFData instances
------------------------------------------------------------------------
diff --git a/src/full/Agda/Syntax/Abstract/Pretty.hs b/src/full/Agda/Syntax/Abstract/Pretty.hs
index cedacae..dbd813e 100644
--- a/src/full/Agda/Syntax/Abstract/Pretty.hs
+++ b/src/full/Agda/Syntax/Abstract/Pretty.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
module Agda.Syntax.Abstract.Pretty where
diff --git a/src/full/Agda/Syntax/Abstract/Views.hs b/src/full/Agda/Syntax/Abstract/Views.hs
index ef0957e..961aae8 100644
--- a/src/full/Agda/Syntax/Abstract/Views.hs
+++ b/src/full/Agda/Syntax/Abstract/Views.hs
@@ -1,14 +1,7 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoMonoLocalBinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ <= 706
-{-# LANGUAGE FlexibleContexts #-}
-#endif
module Agda.Syntax.Abstract.Views where
@@ -39,11 +32,23 @@ data AppView = Application Expr [NamedArg Expr]
appView :: Expr -> AppView
appView e =
case e of
- App i e1 arg | Application hd es <- appView e1
+ App _ e1 e2
+ | Dot _ e2' <- unScope $ namedArg e2
+ , Just f <- maybeProjTurnPostfix e2'
+ -> Application f [defaultNamedArg e1]
+ App i e1 arg
+ | Application hd es <- appView e1
-> Application hd $ es ++ [arg]
ScopedExpr _ e -> appView e
_ -> Application e []
+maybeProjTurnPostfix :: Expr -> Maybe Expr
+maybeProjTurnPostfix e =
+ case e of
+ ScopedExpr i e' -> ScopedExpr i <$> maybeProjTurnPostfix e'
+ Proj _ x -> return $ Proj ProjPostfix x
+ _ -> Nothing
+
unAppView :: AppView -> Expr
unAppView (Application h es) =
foldl (App (ExprRange noRange)) h es
@@ -122,6 +127,7 @@ instance ExprLike Expr where
Lit{} -> pure e0
QuestionMark{} -> pure e0
Underscore{} -> pure e0
+ Dot ei e -> Dot ei <$> recurse e
App ei e arg -> App ei <$> recurse e <*> recurse arg
WithApp ei e es -> WithApp ei <$> recurse e <*> recurse es
Lam ei b e -> Lam ei <$> recurse b <*> recurse e
@@ -157,6 +163,7 @@ instance ExprLike Expr where
Lit{} -> m
QuestionMark{} -> m
Underscore{} -> m
+ Dot _ e -> m `mappend` fold e
App _ e e' -> m `mappend` fold e `mappend` fold e'
WithApp _ e es -> m `mappend` fold e `mappend` fold es
Lam _ b e -> m `mappend` fold b `mappend` fold e
@@ -192,6 +199,7 @@ instance ExprLike Expr where
Lit{} -> f e
QuestionMark{} -> f e
Underscore{} -> f e
+ Dot ei e -> f =<< Dot ei <$> trav e
App ei e arg -> f =<< App ei <$> trav e <*> trav arg
WithApp ei e es -> f =<< WithApp ei <$> trav e <*> trav es
Lam ei b e -> f =<< Lam ei <$> trav b <*> trav e
@@ -303,13 +311,13 @@ instance ExprLike LetBinding where
instance ExprLike a => ExprLike (Pattern' a) where
instance ExprLike a => ExprLike (Clause' a) where
- recurseExpr f (Clause lhs rhs ds ca) = Clause <$> rec lhs <*> rec rhs <*> rec ds <*> pure ca
+ recurseExpr f (Clause lhs dots rhs ds ca) = Clause <$> rec lhs <*> pure dots <*> rec rhs <*> rec ds <*> pure ca
where rec = recurseExpr f
instance ExprLike RHS where
recurseExpr f rhs =
case rhs of
- RHS e -> RHS <$> rec e
+ RHS e c -> RHS <$> rec e <*> pure c
AbsurdRHS{} -> pure rhs
WithRHS x es cs -> WithRHS x <$> rec es <*> rec cs
RewriteRHS xes rhs ds -> RewriteRHS <$> rec xes <*> rec rhs <*> rec ds
@@ -338,7 +346,6 @@ instance ExprLike Pragma where
CompiledJSPragma{} -> pure p
CompiledUHCPragma{} -> pure p
CompiledDataUHCPragma{} -> pure p
- NoSmashingPragma{} -> pure p
StaticPragma{} -> pure p
InlinePragma{} -> pure p
DisplayPragma f xs e -> DisplayPragma f <$> rec xs <*> rec e
@@ -355,12 +362,12 @@ instance ExprLike SpineLHS where
instance ExprLike Declaration where
recurseExpr f d =
case d of
- Axiom a d i x e -> Axiom a d i x <$> rec e
+ Axiom a d i mp x e -> Axiom a d i mp x <$> rec e
Field i x e -> Field i x <$> rec e
Primitive i x e -> Primitive i x <$> rec e
Mutual i ds -> Mutual i <$> rec ds
Section i m tel ds -> Section i m <$> rec tel <*> rec ds
- Apply i m a rd rm d -> (\ a -> Apply i m a rd rm d) <$> rec a
+ Apply i m a ci d -> (\ a -> Apply i m a ci d) <$> rec a
Import{} -> pure d
Pragma i p -> Pragma i <$> rec p
Open{} -> pure d
diff --git a/src/full/Agda/Syntax/Common.hs b/src/full/Agda/Syntax/Common.hs
index f1ac5d7..2ed6406 100644
--- a/src/full/Agda/Syntax/Common.hs
+++ b/src/full/Agda/Syntax/Common.hs
@@ -1,10 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| Some common syntactic entities are defined in this module.
@@ -19,18 +15,17 @@ import qualified Data.ByteString.Char8 as ByteString
import Data.Foldable
import Data.Hashable
import qualified Data.Strict.Maybe as Strict
-import Data.Monoid
+import Data.Semigroup hiding (Arg)
import Data.Traversable
import Data.Typeable (Typeable)
+import Data.Word
import GHC.Generics (Generic)
-import Test.QuickCheck hiding (Small)
-
import Agda.Syntax.Position
import Agda.Utils.Functor
-import Agda.Utils.Pretty
+import Agda.Utils.Pretty hiding ((<>))
#include "undefined.h"
import Agda.Utils.Impossible
@@ -63,13 +58,6 @@ instance HasRange Induction where
instance KillRange Induction where
killRange = id
-instance Arbitrary Induction where
- arbitrary = elements [Inductive, CoInductive]
-
-instance CoArbitrary Induction where
- coarbitrary Inductive = variant 0
- coarbitrary CoInductive = variant 1
-
instance NFData Induction where
rnf Inductive = ()
rnf CoInductive = ()
@@ -83,13 +71,16 @@ data Hiding = Hidden | Instance | NotHidden
-- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'.
-- 'Instance' and 'NotHidden' are incompatible.
+instance Semigroup Hiding where
+ NotHidden <> h = h
+ h <> NotHidden = h
+ Hidden <> Hidden = Hidden
+ Instance <> Instance = Instance
+ _ <> _ = __IMPOSSIBLE__
+
instance Monoid Hiding where
mempty = NotHidden
- mappend NotHidden h = h
- mappend h NotHidden = h
- mappend Hidden Hidden = Hidden
- mappend Instance Instance = Instance
- mappend _ _ = __IMPOSSIBLE__
+ mappend = (<>)
instance KillRange Hiding where
killRange = id
@@ -148,10 +139,6 @@ instance LensHiding (WithHiding a) where
mergeHiding :: LensHiding a => WithHiding a -> a
mergeHiding (WithHiding h a) = mapHiding (mappend h) a
--- | @isHidden@ does not apply to 'Instance', only to 'Hidden'.
-isHidden :: LensHiding a => a -> Bool
-isHidden a = getHiding a == Hidden
-
-- | Visible ('NotHidden') arguments are @notHidden@. (DEPRECATED, use 'visible'.)
notHidden :: LensHiding a => a -> Bool
notHidden a = getHiding a == NotHidden
@@ -232,9 +219,6 @@ allRelevances =
instance KillRange Relevance where
killRange rel = rel -- no range to kill
-instance Arbitrary Relevance where
- arbitrary = elements allRelevances
-
instance Ord Relevance where
(<=) = moreRelevant
@@ -350,26 +334,63 @@ ignoreForced Irrelevant = Irrelevant
-- | Irrelevant function arguments may appear non-strictly in the codomain type.
irrToNonStrict :: Relevance -> Relevance
irrToNonStrict Irrelevant = NonStrict
--- irrToNonStrict NonStrict = Relevant -- TODO: is that what we want (OR: NonStrict) -- better be more conservative
+-- irrToNonStrict NonStrict = Relevant -- TODO: this is bad if we apply irrToNonStrict several times!
irrToNonStrict rel = rel
+-- | Applied when working on types (unless --experimental-irrelevance).
+nonStrictToRel :: Relevance -> Relevance
+nonStrictToRel NonStrict = Relevant
+nonStrictToRel rel = rel
+
nonStrictToIrr :: Relevance -> Relevance
nonStrictToIrr NonStrict = Irrelevant
nonStrictToIrr rel = rel
---------------------------------------------------------------------------
+-- * Origin of arguments (user-written, inserted or reflected)
+---------------------------------------------------------------------------
+
+data Origin = UserWritten | Inserted | Reflected
+ deriving (Typeable, Show, Eq, Ord)
+
+instance KillRange Origin where
+ killRange = id
+
+instance NFData Origin where
+ rnf UserWritten = ()
+ rnf Inserted = ()
+ rnf Reflected = ()
+
+class LensOrigin a where
+
+ getOrigin :: a -> Origin
+
+ setOrigin :: Origin -> a -> a
+ setOrigin o = mapOrigin (const o)
+
+ mapOrigin :: (Origin -> Origin) -> a -> a
+ mapOrigin f a = setOrigin (f $ getOrigin a) a
+
+instance LensOrigin Origin where
+ getOrigin = id
+ setOrigin = const
+ mapOrigin = id
+
+---------------------------------------------------------------------------
-- * Argument decoration
---------------------------------------------------------------------------
-- | A function argument can be hidden and/or irrelevant.
data ArgInfo = ArgInfo
- { argInfoHiding :: Hiding
- , argInfoRelevance :: Relevance
+ { argInfoHiding :: Hiding
+ , argInfoRelevance :: Relevance
+ , argInfoOrigin :: Origin
+ , argInfoOverlappable :: Bool
} deriving (Typeable, Eq, Ord, Show)
instance KillRange ArgInfo where
- killRange (ArgInfo h r) = killRange2 ArgInfo h r
+ killRange (ArgInfo h r o v) = killRange3 ArgInfo h r o v
class LensArgInfo a where
getArgInfo :: a -> ArgInfo
@@ -384,7 +405,7 @@ instance LensArgInfo ArgInfo where
mapArgInfo = id
instance NFData ArgInfo where
- rnf (ArgInfo a b) = rnf a `seq` rnf b
+ rnf (ArgInfo a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d
instance LensHiding ArgInfo where
getHiding = argInfoHiding
@@ -396,9 +417,16 @@ instance LensRelevance ArgInfo where
setRelevance h ai = ai { argInfoRelevance = h }
mapRelevance f ai = ai { argInfoRelevance = f (argInfoRelevance ai) }
+instance LensOrigin ArgInfo where
+ getOrigin = argInfoOrigin
+ setOrigin o ai = ai { argInfoOrigin = o }
+ mapOrigin f ai = ai { argInfoOrigin = f (argInfoOrigin ai) }
+
defaultArgInfo :: ArgInfo
-defaultArgInfo = ArgInfo { argInfoHiding = NotHidden
- , argInfoRelevance = Relevant }
+defaultArgInfo = ArgInfo { argInfoHiding = NotHidden
+ , argInfoRelevance = Relevant
+ , argInfoOrigin = UserWritten
+ , argInfoOverlappable = False }
---------------------------------------------------------------------------
@@ -423,14 +451,14 @@ instance KillRange a => KillRange (Arg a) where
killRange (Arg info a) = killRange2 Arg info a
instance Eq a => Eq (Arg a) where
- Arg (ArgInfo h1 _) x1 == Arg (ArgInfo h2 _) x2 = (h1, x1) == (h2, x2)
+ Arg (ArgInfo h1 _ _ _) x1 == Arg (ArgInfo h2 _ _ _) x2 = (h1, x1) == (h2, x2)
instance Show a => Show (Arg a) where
- show (Arg (ArgInfo h r) x) = showR r $ showH h $ show x
+ show (Arg (ArgInfo h r o v) x) = showR r $ showO o $ showH h $ show x
where
showH Hidden s = "{" ++ s ++ "}"
showH NotHidden s = "(" ++ s ++ ")"
- showH Instance s = "{{" ++ s ++ "}}"
+ showH Instance s = (if v then "overlap " else "") ++ "{{" ++ s ++ "}}"
showR r s = case r of
Irrelevant -> "." ++ s
NonStrict -> "?" ++ s
@@ -438,6 +466,10 @@ instance Show a => Show (Arg a) where
Forced Small -> "!" ++ s
UnusedArg -> "k" ++ s -- constant
Relevant -> "r" ++ s -- Andreas: I want to see it explicitly
+ showO o s = case o of
+ UserWritten -> "u" ++ s
+ Inserted -> "i" ++ s
+ Reflected -> "g" ++ s -- generated by reflection
instance NFData e => NFData (Arg e) where
rnf (Arg a b) = rnf a `seq` rnf b
@@ -450,16 +482,9 @@ instance LensRelevance (Arg e) where
getRelevance = getRelevance . argInfo
mapRelevance = mapArgInfo . mapRelevance
-{- RETIRED
-hide :: Arg a -> Arg a
-hide = setArgHiding Hidden
-
-makeInstance :: Arg a -> Arg a
-makeInstance = setHiding Instance
-
-isHiddenArg :: Arg a -> Bool
-isHiddenArg arg = argHiding arg /= NotHidden
--}
+instance LensOrigin (Arg e) where
+ getOrigin = getOrigin . argInfo
+ mapOrigin = mapArgInfo . mapOrigin
instance LensArgInfo (Arg a) where
getArgInfo = argInfo
@@ -514,7 +539,7 @@ instance Underscore Doc where
data Dom e = Dom
{ domInfo :: ArgInfo
, unDom :: e
- } deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable)
+ } deriving (Typeable, Ord, Functor, Foldable, Traversable)
instance Decoration Dom where
traverseF f (Dom ai a) = Dom ai <$> f a
@@ -525,6 +550,10 @@ instance HasRange a => HasRange (Dom a) where
instance KillRange a => KillRange (Dom a) where
killRange (Dom info a) = killRange2 Dom info a
+instance Eq a => Eq (Dom a) where
+ Dom (ArgInfo h1 r1 _ _) x1 == Dom (ArgInfo h2 r2 _ _) x2 =
+ (h1, ignoreForced r1, x1) == (h2, ignoreForced r2, x2)
+
instance Show a => Show (Dom a) where
show = show . argFromDom
@@ -658,16 +687,34 @@ stringToRawName = id
type RString = Ranged RawName
---------------------------------------------------------------------------
--- * Constructor pattern info
+-- * Further constructor and projection info
---------------------------------------------------------------------------
--- | Where does the 'ConP' of come from?
-data ConPOrigin
- = ConPImplicit -- ^ Expanded from an implicit pattern.
- | ConPCon -- ^ User wrote a constructor pattern.
- | ConPRec -- ^ User wrote a record pattern.
+-- | Where does the 'ConP' or 'Con' come from?
+data ConOrigin
+ = ConOSystem -- ^ Inserted by system or expanded from an implicit pattern.
+ | ConOCon -- ^ User wrote a constructor (pattern).
+ | ConORec -- ^ User wrote a record (pattern).
+ deriving (Typeable, Show, Eq, Ord, Enum, Bounded)
+
+instance KillRange ConOrigin where
+ killRange = id
+
+-- | Prefer user-written over system-inserted.
+bestConInfo :: ConOrigin -> ConOrigin -> ConOrigin
+bestConInfo ConOSystem o = o
+bestConInfo o _ = o
+
+-- | Where does a projection come from?
+data ProjOrigin
+ = ProjPrefix -- ^ User wrote a prefix projection.
+ | ProjPostfix -- ^ User wrote a postfix projection.
+ | ProjSystem -- ^ Projection was generated by the system.
deriving (Typeable, Show, Eq, Ord, Enum, Bounded)
+instance KillRange ProjOrigin where
+ killRange = id
+
---------------------------------------------------------------------------
-- * Infixity, access, abstract, etc.
---------------------------------------------------------------------------
@@ -678,11 +725,24 @@ data IsInfix = InfixDef | PrefixDef
deriving (Typeable, Show, Eq, Ord)
-- | Access modifier.
-data Access = PrivateAccess | PublicAccess
- | OnlyQualified -- ^ Visible from outside, but not exported when opening the module
+data Access
+ = PrivateAccess Origin
+ -- ^ Store the 'Origin' of the private block that lead to this qualifier.
+ -- This is needed for more faithful printing of declarations.
+ | PublicAccess
+ | OnlyQualified -- ^ Visible from outside, but not exported when opening the module
-- Used for qualified constructors.
deriving (Typeable, Show, Eq, Ord)
+instance NFData Access where
+ rnf _ = ()
+
+instance HasRange Access where
+ getRange _ = noRange
+
+instance KillRange Access where
+ killRange = id
+
-- | Abstract or concrete
data IsAbstract = AbstractDef | ConcreteDef
deriving (Typeable, Show, Eq, Ord)
@@ -720,7 +780,7 @@ type Arity = Nat
-- | The unique identifier of a name. Second argument is the top-level module
-- identifier.
-data NameId = NameId !Integer !Integer
+data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
deriving (Eq, Ord, Typeable, Generic)
instance KillRange NameId where
@@ -742,11 +802,6 @@ instance Hashable NameId where
{-# INLINE hashWithSalt #-}
hashWithSalt salt (NameId n m) = hashWithSalt salt (n, m)
-instance Arbitrary NameId where
- arbitrary = elements [ NameId x y | x <- [-1, 1], y <- [-1, 1] ]
-
-instance CoArbitrary NameId
-
---------------------------------------------------------------------------
-- * Meta variables
---------------------------------------------------------------------------
@@ -843,11 +898,14 @@ data ImportDirective' a b = ImportDirective
data Using' a b = UseEverything | Using [ImportedName' a b]
deriving (Typeable, Eq)
+instance Semigroup (Using' a b) where
+ UseEverything <> u = u
+ u <> UseEverything = u
+ Using xs <> Using ys = Using (xs ++ ys)
+
instance Monoid (Using' a b) where
mempty = UseEverything
- mappend UseEverything u = u
- mappend u UseEverything = u
- mappend (Using xs) (Using ys) = Using (xs ++ ys)
+ mappend = (<>)
-- | Default is directive is @private@ (use everything, but do not export).
defaultImportDir :: ImportDirective' a b
diff --git a/src/full/Agda/Syntax/Concrete.hs b/src/full/Agda/Syntax/Concrete.hs
index 201fcc3..dacb521 100644
--- a/src/full/Agda/Syntax/Concrete.hs
+++ b/src/full/Agda/Syntax/Concrete.hs
@@ -1,9 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-| The concrete syntax is a raw representation of the program text
without any desugaring at all. This is what the parser produces.
@@ -72,6 +68,8 @@ import Agda.Syntax.Literal
import Agda.Syntax.Concrete.Name
import qualified Agda.Syntax.Abstract.Name as A
+import Agda.TypeChecking.Positivity.Occurrence
+
import Agda.Utils.Lens
import Agda.Utils.Null
@@ -150,6 +148,7 @@ data Expr
| RecUpdate Range Expr [FieldAssignment] -- ^ ex: @record e {x = a; y = b}@
| Let Range [Declaration] Expr -- ^ ex: @let Ds in e@
| Paren Range Expr -- ^ ex: @(e)@
+ | IdiomBrackets Range Expr -- ^ ex: @(| e |)@
| Absurd Range -- ^ ex: @()@ or @{}@, only in patterns
| As Range Name Expr -- ^ ex: @x\@p@, only in patterns
| Dot Range Expr -- ^ ex: @.p@, only in patterns
@@ -182,7 +181,7 @@ data Pattern
| WildP Range -- ^ @_@
| AbsurdP Range -- ^ @()@
| AsP Range Name Pattern -- ^ @x\@p@ unused
- | DotP Range Expr -- ^ @.e@
+ | DotP Range Origin Expr -- ^ @.e@
| LitP Literal -- ^ @0@, @1@, etc.
| RecP Range [FieldAssignment' Pattern] -- ^ @record {x = p; y = q}@
deriving (Typeable)
@@ -285,7 +284,10 @@ type WhereClause = WhereClause' [Declaration]
data WhereClause' decls
= NoWhere -- ^ No @where@ clauses.
| AnyWhere decls -- ^ Ordinary @where@.
- | SomeWhere Name decls -- ^ Named where: @module M where@.
+ | SomeWhere Name Access decls
+ -- ^ Named where: @module M where@.
+ -- The 'Access' flag applies to the 'Name' (not the module contents!)
+ -- and is propagated from the parent function.
deriving (Typeable, Functor, Foldable, Traversable)
-- | An expression followed by a where clause.
@@ -338,7 +340,10 @@ data Declaration
| PatternSyn Range Name [Arg Name] Pattern
| Mutual Range [Declaration]
| Abstract Range [Declaration]
- | Private Range [Declaration]
+ | Private Range Origin [Declaration]
+ -- ^ In "Agda.Syntax.Concrete.Definitions" we generate private blocks
+ -- temporarily, which should be treated different that user-declared
+ -- private blocks. Thus the 'Origin'.
| InstanceB Range [Declaration]
| Macro Range [Declaration]
| Postulate Range [TypeSignatureOrInstanceBlock]
@@ -367,7 +372,7 @@ data OpenShortHand = DoOpen | DontOpen
data Pragma
= OptionsPragma Range [String]
| BuiltinPragma Range String Expr
- | RewritePragma Range QName
+ | RewritePragma Range [QName]
| CompiledDataPragma Range QName String [String]
| CompiledDeclareDataPragma Range QName String
| CompiledTypePragma Range QName String
@@ -378,7 +383,6 @@ data Pragma
| CompiledUHCPragma Range QName String
| CompiledDataUHCPragma Range QName String [String]
| HaskellCodePragma Range String
- | NoSmashingPragma Range QName
| StaticPragma Range QName
| InlinePragma Range QName
| ImportPragma Range String
@@ -390,6 +394,7 @@ data Pragma
| CatchallPragma Range
| DisplayPragma Range Pattern Expr
| NoPositivityCheckPragma Range
+ | PolarityPragma Range Name [Occurrence]
deriving (Typeable)
---------------------------------------------------------------------------
@@ -419,7 +424,7 @@ spanAllowedBeforeModule :: [Declaration] -> ([Declaration], [Declaration])
spanAllowedBeforeModule = span isAllowedBeforeModule
where
isAllowedBeforeModule (Pragma OptionsPragma{}) = True
- isAllowedBeforeModule (Private _ ds) = all isAllowedBeforeModule ds
+ isAllowedBeforeModule (Private _ _ ds) = all isAllowedBeforeModule ds
isAllowedBeforeModule Import{} = True
isAllowedBeforeModule ModuleMacro{} = True
isAllowedBeforeModule Open{} = True
@@ -442,15 +447,17 @@ mapLhsOriginalPattern f lhs@LHS{ lhsOriginalPattern = p } =
data AppView = AppView Expr [NamedArg Expr]
appView :: Expr -> AppView
-appView (App r e1 e2) = vApp (appView e1) e2
+appView e =
+ case e of
+ App r e1 e2 -> vApp (appView e1) e2
+ RawApp _ (e:es) -> AppView e $ map arg es
+ _ -> AppView e []
where
vApp (AppView e es) arg = AppView e (es ++ [arg])
-appView (RawApp _ (e:es)) = AppView e $ map arg es
- where
+
arg (HiddenArg _ e) = setHiding Hidden $ defaultArg e
arg (InstanceArg _ e) = setHiding Instance $ defaultArg e
arg e = defaultArg (unnamed e)
-appView e = AppView e []
{--------------------------------------------------------------------------
Patterns
@@ -541,6 +548,7 @@ instance HasRange Expr where
SetN r _ -> r
Let r _ _ -> r
Paren r _ -> r
+ IdiomBrackets r _ -> r
As r _ _ -> r
Dot r _ -> r
Absurd r -> r
@@ -579,7 +587,7 @@ instance HasRange BoundName where
instance HasRange WhereClause where
getRange NoWhere = noRange
getRange (AnyWhere ds) = getRange ds
- getRange (SomeWhere _ ds) = getRange ds
+ getRange (SomeWhere _ _ ds) = getRange ds
instance HasRange ModuleApplication where
getRange (SectionApp r _ _) = r
@@ -606,7 +614,7 @@ instance HasRange Declaration where
getRange (Import r _ _ _ _) = r
getRange (InstanceB r _) = r
getRange (Macro r _) = r
- getRange (Private r _) = r
+ getRange (Private r _ _) = r
getRange (Postulate r _) = r
getRange (Primitive r _) = r
getRange (Module r _ _ _) = r
@@ -643,7 +651,6 @@ instance HasRange Pragma where
getRange (CompiledUHCPragma r _ _) = r
getRange (CompiledDataUHCPragma r _ _ _) = r
getRange (HaskellCodePragma r _) = r
- getRange (NoSmashingPragma r _) = r
getRange (StaticPragma r _) = r
getRange (InlinePragma r _) = r
getRange (ImportPragma r _) = r
@@ -653,6 +660,7 @@ instance HasRange Pragma where
getRange (CatchallPragma r) = r
getRange (DisplayPragma r _ _) = r
getRange (NoPositivityCheckPragma r) = r
+ getRange (PolarityPragma r _ _) = r
instance HasRange AsName where
getRange a = getRange (asRange a, asName a)
@@ -670,7 +678,7 @@ instance HasRange Pattern where
getRange (QuoteP r) = r
getRange (HiddenP r _) = r
getRange (InstanceP r _) = r
- getRange (DotP r _) = r
+ getRange (DotP r _ _) = r
getRange (RecP r _) = r
-- SetRange instances
@@ -692,7 +700,7 @@ instance SetRange Pattern where
setRange r (QuoteP _) = QuoteP r
setRange r (HiddenP _ p) = HiddenP r p
setRange r (InstanceP _ p) = InstanceP r p
- setRange r (DotP _ e) = DotP r e
+ setRange r (DotP _ o e) = DotP r o e
setRange r (RecP _ fs) = RecP r fs
-- KillRange instances
@@ -723,7 +731,7 @@ instance KillRange Declaration where
killRange (PatternSyn _ n ns p) = killRange3 (PatternSyn noRange) n ns p
killRange (Mutual _ d) = killRange1 (Mutual noRange) d
killRange (Abstract _ d) = killRange1 (Abstract noRange) d
- killRange (Private _ d) = killRange1 (Private noRange) d
+ killRange (Private _ o d) = killRange2 (Private noRange) o d
killRange (InstanceB _ d) = killRange1 (InstanceB noRange) d
killRange (Macro _ d) = killRange1 (Macro noRange) d
killRange (Postulate _ t) = killRange1 (Postulate noRange) t
@@ -759,6 +767,7 @@ instance KillRange Expr where
killRange (RecUpdate _ e ne) = killRange2 (RecUpdate noRange) e ne
killRange (Let _ d e) = killRange2 (Let noRange) d e
killRange (Paren _ e) = killRange1 (Paren noRange) e
+ killRange (IdiomBrackets _ e) = killRange1 (IdiomBrackets noRange) e
killRange (Absurd _) = Absurd noRange
killRange (As _ n e) = killRange2 (As noRange) n e
killRange (Dot _ e) = killRange1 (Dot noRange) e
@@ -799,7 +808,7 @@ instance KillRange Pattern where
killRange (WildP _) = WildP noRange
killRange (AbsurdP _) = AbsurdP noRange
killRange (AsP _ n p) = killRange2 (AsP noRange) n p
- killRange (DotP _ e) = killRange1 (DotP noRange) e
+ killRange (DotP _ o e) = killRange1 (DotP noRange) o e
killRange (LitP l) = killRange1 LitP l
killRange (QuoteP _) = QuoteP noRange
killRange (RecP _ fs) = killRange1 (RecP noRange) fs
@@ -807,7 +816,7 @@ instance KillRange Pattern where
instance KillRange Pragma where
killRange (OptionsPragma _ s) = OptionsPragma noRange s
killRange (BuiltinPragma _ s e) = killRange1 (BuiltinPragma noRange s) e
- killRange (RewritePragma _ q) = killRange1 (RewritePragma noRange) q
+ killRange (RewritePragma _ qs) = killRange1 (RewritePragma noRange) qs
killRange (CompiledDataPragma _ q s ss) = killRange1 (\q -> CompiledDataPragma noRange q s ss) q
killRange (CompiledDeclareDataPragma _ q s) = killRange1 (\q -> CompiledDeclareDataPragma noRange q s) q
killRange (CompiledTypePragma _ q s) = killRange1 (\q -> CompiledTypePragma noRange q s) q
@@ -818,7 +827,6 @@ instance KillRange Pragma where
killRange (CompiledUHCPragma _ q s) = killRange1 (\q -> CompiledUHCPragma noRange q s) q
killRange (CompiledDataUHCPragma _ q s ss) = killRange1 (\q -> CompiledDataUHCPragma noRange q s ss) q
killRange (HaskellCodePragma _ s) = HaskellCodePragma noRange s
- killRange (NoSmashingPragma _ q) = killRange1 (NoSmashingPragma noRange) q
killRange (StaticPragma _ q) = killRange1 (StaticPragma noRange) q
killRange (InlinePragma _ q) = killRange1 (InlinePragma noRange) q
killRange (ImportPragma _ s) = ImportPragma noRange s
@@ -828,6 +836,7 @@ instance KillRange Pragma where
killRange (CatchallPragma _) = CatchallPragma noRange
killRange (DisplayPragma _ lhs rhs) = killRange2 (DisplayPragma noRange) lhs rhs
killRange (NoPositivityCheckPragma _) = NoPositivityCheckPragma noRange
+ killRange (PolarityPragma _ q occs) = killRange1 (\q -> PolarityPragma noRange q occs) q
instance KillRange RHS where
killRange AbsurdRHS = AbsurdRHS
@@ -843,7 +852,7 @@ instance KillRange TypedBindings where
instance KillRange WhereClause where
killRange NoWhere = NoWhere
killRange (AnyWhere d) = killRange1 AnyWhere d
- killRange (SomeWhere n d) = killRange2 SomeWhere n d
+ killRange (SomeWhere n a d) = killRange3 SomeWhere n a d
------------------------------------------------------------------------
-- NFData instances
@@ -873,6 +882,7 @@ instance NFData Expr where
rnf (RecUpdate _ a b) = rnf a `seq` rnf b
rnf (Let _ a b) = rnf a `seq` rnf b
rnf (Paren _ a) = rnf a
+ rnf (IdiomBrackets _ a)= rnf a
rnf (Absurd _) = ()
rnf (As _ a b) = rnf a `seq` rnf b
rnf (Dot _ a) = rnf a
@@ -900,7 +910,7 @@ instance NFData Pattern where
rnf (WildP _) = ()
rnf (AbsurdP _) = ()
rnf (AsP _ a b) = rnf a `seq` rnf b
- rnf (DotP _ a) = rnf a
+ rnf (DotP _ a b) = rnf a `seq` rnf b
rnf (LitP a) = rnf a
rnf (RecP _ a) = rnf a
@@ -919,7 +929,7 @@ instance NFData Declaration where
rnf (PatternSyn _ a b c) = rnf a `seq` rnf b `seq` rnf c
rnf (Mutual _ a) = rnf a
rnf (Abstract _ a) = rnf a
- rnf (Private _ a) = rnf a
+ rnf (Private _ _ a) = rnf a
rnf (InstanceB _ a) = rnf a
rnf (Macro _ a) = rnf a
rnf (Postulate _ a) = rnf a
@@ -948,7 +958,6 @@ instance NFData Pragma where
rnf (CompiledUHCPragma _ a b) = rnf a `seq` rnf b
rnf (CompiledDataUHCPragma _ a b c) = rnf a `seq` rnf b `seq` rnf c
rnf (HaskellCodePragma _ s) = rnf s
- rnf (NoSmashingPragma _ a) = rnf a
rnf (StaticPragma _ a) = rnf a
rnf (InlinePragma _ a) = rnf a
rnf (ImportPragma _ a) = rnf a
@@ -958,6 +967,7 @@ instance NFData Pragma where
rnf (CatchallPragma _) = ()
rnf (DisplayPragma _ a b) = rnf a `seq` rnf b
rnf (NoPositivityCheckPragma _) = ()
+ rnf (PolarityPragma _ a b) = rnf a `seq` rnf b
-- | Ranges are not forced.
@@ -1002,7 +1012,7 @@ instance NFData ModuleAssignment where
instance NFData a => NFData (WhereClause' a) where
rnf NoWhere = ()
rnf (AnyWhere a) = rnf a
- rnf (SomeWhere a b) = rnf a `seq` rnf b
+ rnf (SomeWhere a b c) = rnf a `seq` rnf b `seq` rnf c
instance NFData a => NFData (LamBinding' a) where
rnf (DomainFree a b) = rnf a `seq` rnf b
diff --git a/src/full/Agda/Syntax/Concrete/Definitions.hs b/src/full/Agda/Syntax/Concrete/Definitions.hs
index 413cf48..020234e 100644
--- a/src/full/Agda/Syntax/Concrete/Definitions.hs
+++ b/src/full/Agda/Syntax/Concrete/Definitions.hs
@@ -1,13 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-#if __GLASGOW_HASKELL__ >= 710
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's.
--
@@ -39,7 +33,7 @@ module Agda.Syntax.Concrete.Definitions
, DeclarationException(..)
, Nice, runNice
, niceDeclarations
- , notSoNiceDeclaration
+ , notSoNiceDeclarations
, niceHasAbstract
, Measure
) where
@@ -57,9 +51,10 @@ import Data.Foldable ( foldMap )
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
-import Data.Monoid ( Monoid(mappend, mempty) )
+import Data.Semigroup ( Semigroup, Monoid, (<>), mempty, mappend )
import Data.List as List hiding (null)
-import Data.Traversable (traverse)
+import qualified Data.Set as Set
+import Data.Traversable (Traversable, traverse)
import Data.Typeable (Typeable)
import Agda.Syntax.Concrete
@@ -70,12 +65,17 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Concrete.Pretty ()
+import Agda.TypeChecking.Positivity.Occurrence
+
import Agda.Utils.Except ( Error(strMsg), MonadError(throwError) )
+import Agda.Utils.Functor
import Agda.Utils.Lens
-import Agda.Utils.List (headMaybe, isSublistOf)
+import Agda.Utils.List (caseList, headMaybe, isSublistOf)
import Agda.Utils.Monad
import Agda.Utils.Null
-import Agda.Utils.Pretty
+import qualified Agda.Utils.Pretty as Pretty
+import Agda.Utils.Pretty hiding ((<>))
+import Agda.Utils.Singleton
import Agda.Utils.Tuple
import Agda.Utils.Update
@@ -90,11 +90,32 @@ import Agda.Utils.Impossible
contained in a single constructor instead of spread out between type
signatures and clauses. The @private@, @postulate@, @abstract@ and @instance@
modifiers have been distributed to the individual declarations.
+
+ Observe the order of components:
+
+ Range
+ Fixity'
+ Access
+ IsAbstract
+ IsInstance
+ TerminationCheck
+ PositivityCheck
+
+ further attributes
+
+ (Q)Name
+
+ content (Expr, Declaration ...)
-}
data NiceDeclaration
- = Axiom Range Fixity' Access IsInstance ArgInfo Name Expr
- -- ^ Axioms and functions can be declared irrelevant. (Hiding should be NotHidden)
- | NiceField Range IsInstance Fixity' Access IsAbstract Name (Arg Expr)
+ = Axiom Range Fixity' Access IsAbstract IsInstance ArgInfo (Maybe [Occurrence]) Name Expr
+ -- ^ 'IsAbstract' argument: We record whether a declaration was made in an @abstract@ block.
+ --
+ -- 'ArgInfo' argument: Axioms and functions can be declared irrelevant.
+ -- ('Hiding' should be 'NotHidden'.)
+ --
+ -- @Maybe [Occurrence]@ argument: Polarities can be assigned to identifiers.
+ | NiceField Range Fixity' Access IsAbstract IsInstance Name (Arg Expr)
| PrimitiveFunction Range Fixity' Access IsAbstract Name Expr
| NiceMutual Range TerminationCheck PositivityCheck [NiceDeclaration]
| NiceModule Range Access IsAbstract QName Telescope [Declaration]
@@ -102,21 +123,21 @@ data NiceDeclaration
| NiceOpen Range QName ImportDirective
| NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective
| NicePragma Range Pragma
- | NiceRecSig Range Fixity' Access Name [LamBinding] Expr PositivityCheck
- | NiceDataSig Range Fixity' Access Name [LamBinding] Expr PositivityCheck
+ | NiceRecSig Range Fixity' Access IsAbstract PositivityCheck Name [LamBinding] Expr
+ | NiceDataSig Range Fixity' Access IsAbstract PositivityCheck Name [LamBinding] Expr
| NiceFunClause Range Access IsAbstract TerminationCheck Catchall Declaration
-- ^ An uncategorized function clause, could be a function clause
-- without type signature or a pattern lhs (e.g. for irrefutable let).
-- The 'Declaration' is the actual 'FunClause'.
- | FunSig Range Fixity' Access IsInstance IsMacro ArgInfo TerminationCheck Name Expr
- | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause]
+ | FunSig Range Fixity' Access IsAbstract IsInstance IsMacro ArgInfo TerminationCheck Name Expr
+ | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause]
-- ^ Block of function clauses (we have seen the type signature before).
-- The 'Declaration's are the original declarations that were processed
-- into this 'FunDef' and are only used in 'notSoNiceDeclaration'.
- | DataDef Range Fixity' IsAbstract Name [LamBinding] PositivityCheck [NiceConstructor]
- | RecDef Range Fixity' IsAbstract Name (Maybe (Ranged Induction)) (Maybe Bool) (Maybe (ThingWithFixity Name, IsInstance)) [LamBinding] PositivityCheck [NiceDeclaration]
+ | DataDef Range Fixity' IsAbstract PositivityCheck Name [LamBinding] [NiceConstructor]
+ | RecDef Range Fixity' IsAbstract PositivityCheck Name (Maybe (Ranged Induction)) (Maybe Bool) (Maybe (ThingWithFixity Name, IsInstance)) [LamBinding] [NiceDeclaration]
| NicePatternSyn Range Fixity' Name [Arg Name] Pattern
- | NiceUnquoteDecl Range [Fixity'] Access IsInstance IsAbstract TerminationCheck [Name] Expr
+ | NiceUnquoteDecl Range [Fixity'] Access IsAbstract IsInstance TerminationCheck [Name] Expr
| NiceUnquoteDef Range [Fixity'] Access IsAbstract TerminationCheck [Name] Expr
deriving (Typeable, Show)
@@ -141,6 +162,7 @@ data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]
-- | The exception type.
data DeclarationException
= MultipleFixityDecls [(Name, [Fixity'])]
+ | MultiplePolarityPragmas [Name]
| InvalidName Name
| DuplicateDefinition Name
| MissingDefinition Name
@@ -151,6 +173,8 @@ data DeclarationException
| WrongParameters Name
| NotAllowedInMutual NiceDeclaration
| UnknownNamesInFixityDecl [Name]
+ | UnknownNamesInPolarityPragmas [Name]
+ | PolarityPragmasButNotPostulates [Name]
| Codata Range
| DeclarationPanic String
| UselessPrivate Range
@@ -169,6 +193,7 @@ data DeclarationException
| UnquoteDefRequiresSignature [Name]
| BadMacroDef NiceDeclaration
| InvalidNoPositivityCheckPragma Range
+
deriving (Typeable)
-- | Several declarations expect only type signatures as sub-declarations. These are:
@@ -182,34 +207,37 @@ data KindOfBlock
instance HasRange DeclarationException where
- getRange (MultipleFixityDecls xs) = getRange (fst $ head xs)
- getRange (InvalidName x) = getRange x
- getRange (DuplicateDefinition x) = getRange x
- getRange (MissingDefinition x) = getRange x
- getRange (MissingWithClauses x) = getRange x
- getRange (MissingTypeSignature x) = getRange x
- getRange (MissingDataSignature x) = getRange x
- getRange (WrongDefinition x k k') = getRange x
- getRange (WrongParameters x) = getRange x
- getRange (AmbiguousFunClauses lhs xs) = getRange lhs
- getRange (NotAllowedInMutual x) = getRange x
- getRange (UnknownNamesInFixityDecl xs) = getRange . head $ xs
- getRange (Codata r) = r
- getRange (DeclarationPanic _) = noRange
- getRange (UselessPrivate r) = r
- getRange (UselessAbstract r) = r
- getRange (UselessInstance r) = r
- getRange (WrongContentBlock _ r) = r
- getRange (InvalidTerminationCheckPragma r) = r
- getRange (InvalidMeasureMutual r) = r
- getRange (PragmaNoTerminationCheck r) = r
- getRange (InvalidCatchallPragma r) = r
- getRange (UnquoteDefRequiresSignature x) = getRange x
- getRange (BadMacroDef d) = getRange d
- getRange (InvalidNoPositivityCheckPragma r) = r
+ getRange (MultipleFixityDecls xs) = getRange (fst $ head xs)
+ getRange (MultiplePolarityPragmas xs) = getRange (head xs)
+ getRange (InvalidName x) = getRange x
+ getRange (DuplicateDefinition x) = getRange x
+ getRange (MissingDefinition x) = getRange x
+ getRange (MissingWithClauses x) = getRange x
+ getRange (MissingTypeSignature x) = getRange x
+ getRange (MissingDataSignature x) = getRange x
+ getRange (WrongDefinition x k k') = getRange x
+ getRange (WrongParameters x) = getRange x
+ getRange (AmbiguousFunClauses lhs xs) = getRange lhs
+ getRange (NotAllowedInMutual x) = getRange x
+ getRange (UnknownNamesInFixityDecl xs) = getRange . head $ xs
+ getRange (UnknownNamesInPolarityPragmas xs) = getRange . head $ xs
+ getRange (PolarityPragmasButNotPostulates xs) = getRange . head $ xs
+ getRange (Codata r) = r
+ getRange (DeclarationPanic _) = noRange
+ getRange (UselessPrivate r) = r
+ getRange (UselessAbstract r) = r
+ getRange (UselessInstance r) = r
+ getRange (WrongContentBlock _ r) = r
+ getRange (InvalidTerminationCheckPragma r) = r
+ getRange (InvalidMeasureMutual r) = r
+ getRange (PragmaNoTerminationCheck r) = r
+ getRange (InvalidCatchallPragma r) = r
+ getRange (UnquoteDefRequiresSignature x) = getRange x
+ getRange (BadMacroDef d) = getRange d
+ getRange (InvalidNoPositivityCheckPragma r) = r
instance HasRange NiceDeclaration where
- getRange (Axiom r _ _ _ _ _ _) = r
+ getRange (Axiom r _ _ _ _ _ _ _ _) = r
getRange (NiceField r _ _ _ _ _ _) = r
getRange (NiceMutual r _ _ _) = r
getRange (NiceModule r _ _ _ _ _ ) = r
@@ -218,12 +246,12 @@ instance HasRange NiceDeclaration where
getRange (NiceImport r _ _ _ _) = r
getRange (NicePragma r _) = r
getRange (PrimitiveFunction r _ _ _ _ _) = r
- getRange (FunSig r _ _ _ _ _ _ _ _) = r
+ getRange (FunSig r _ _ _ _ _ _ _ _ _) = r
getRange (FunDef r _ _ _ _ _ _) = r
getRange (DataDef r _ _ _ _ _ _) = r
getRange (RecDef r _ _ _ _ _ _ _ _ _) = r
- getRange (NiceRecSig r _ _ _ _ _ _) = r
- getRange (NiceDataSig r _ _ _ _ _ _) = r
+ getRange (NiceRecSig r _ _ _ _ _ _ _) = r
+ getRange (NiceDataSig r _ _ _ _ _ _ _) = r
getRange (NicePatternSyn r _ _ _ _) = r
getRange (NiceFunClause r _ _ _ _ _) = r
getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r
@@ -240,7 +268,9 @@ instance Pretty DeclarationException where
, vcat $ map f xs
]
where
- f (x, fs) = pretty x <> text ": " <+> fsep (map pretty fs)
+ f (x, fs) = pretty x Pretty.<> text ": " <+> fsep (map pretty fs)
+ pretty (MultiplePolarityPragmas xs) = fsep $
+ pwords "Multiple polarity pragmas for" ++ map pretty xs
pretty (InvalidName x) = fsep $
pwords "Invalid name:" ++ [pretty x]
pretty (DuplicateDefinition x) = fsep $
@@ -266,6 +296,10 @@ instance Pretty DeclarationException where
]
pretty (UnknownNamesInFixityDecl xs) = fsep $
pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):" ++ map pretty xs
+ pretty (UnknownNamesInPolarityPragmas xs) = fsep $
+ pwords "The following names are not declared in the same scope as their polarity pragmas (they could for instance be out of scope, imported from another module, or declared in a super module):" ++ map pretty xs
+ pretty (PolarityPragmasButNotPostulates xs) = fsep $
+ pwords "Polarity pragmas have been given for the following identifiers which are not postulates:" ++ map pretty xs
pretty (UselessPrivate _) = fsep $
pwords "Using private here has no effect. Private applies only to declarations that introduce new identifiers into the module, like type signatures and data, record, and module declarations."
pretty (UselessAbstract _) = fsep $
@@ -407,18 +441,30 @@ type Nice = StateT NiceEnv (Either DeclarationException)
data NiceEnv = NiceEnv
{ _loneSigs :: LoneSigs
-- ^ Lone type signatures that wait for their definition.
+ , _termChk :: TerminationCheck
+ -- ^ Termination checking pragma waiting for a definition.
+ , _posChk :: PositivityCheck
+ -- ^ Positivity checking pragma waiting for a definition.
+ , _catchall :: Catchall
+ -- ^ Catchall pragma waiting for a function clause.
, fixs :: Fixities
+ , pols :: Polarities
}
-type LoneSigs = Map Name DataRecOrFun
-type Fixities = Map Name Fixity'
+type LoneSigs = Map Name DataRecOrFun
+type Fixities = Map Name Fixity'
+type Polarities = Map Name [Occurrence]
-- | Initial nicifier state.
initNiceEnv :: NiceEnv
initNiceEnv = NiceEnv
{ _loneSigs = empty
+ , _termChk = TerminationCheck
+ , _posChk = True
+ , _catchall = False
, fixs = empty
+ , pols = empty
}
-- * Handling the lone signatures, stored to infer mutual blocks.
@@ -460,11 +506,64 @@ checkLoneSigs xs =
[] -> return ()
(x, _):_ -> throwError $ MissingDefinition x
+-- | Lens for field '_termChk'.
+
+terminationCheckPragma :: Lens' TerminationCheck NiceEnv
+terminationCheckPragma f e = f (_termChk e) <&> \ s -> e { _termChk = s }
+
+withTerminationCheckPragma :: TerminationCheck -> Nice a -> Nice a
+withTerminationCheckPragma tc f = do
+ tc_old <- use terminationCheckPragma
+ terminationCheckPragma .= tc
+ result <- f
+ terminationCheckPragma .= tc_old
+ return result
+
+-- | Lens for field '_posChk'.
+
+positivityCheckPragma :: Lens' PositivityCheck NiceEnv
+positivityCheckPragma f e = f (_posChk e) <&> \ s -> e { _posChk = s }
+
+withPositivityCheckPragma :: PositivityCheck -> Nice a -> Nice a
+withPositivityCheckPragma pc f = do
+ pc_old <- use positivityCheckPragma
+ positivityCheckPragma .= pc
+ result <- f
+ positivityCheckPragma .= pc_old
+ return result
+
+-- | Lens for field '_catchall'.
+
+catchallPragma :: Lens' Catchall NiceEnv
+catchallPragma f e = f (_catchall e) <&> \ s -> e { _catchall = s }
+
+-- | Get current catchall pragma, and reset it for the next clause.
+
+popCatchallPragma :: Nice Catchall
+popCatchallPragma = do
+ ca <- use catchallPragma
+ catchallPragma .= False
+ return ca
+
+withCatchallPragma :: Catchall -> Nice a -> Nice a
+withCatchallPragma ca f = do
+ ca_old <- use catchallPragma
+ catchallPragma .= ca
+ result <- f
+ catchallPragma .= ca_old
+ return result
+
-- | Check whether name is not "_" and return its fixity.
getFixity :: Name -> Nice Fixity'
-getFixity x = do
- when (isUnderscore x) $ throwError $ InvalidName x
- Map.findWithDefault noFixity' x <$> gets fixs -- WAS: defaultFixity'
+getFixity x = Map.findWithDefault noFixity' x <$> gets fixs -- WAS: defaultFixity'
+
+-- | Fail if the name is @_@. Otherwise the name's polarity, if any,
+-- is removed from the state and returned.
+getPolarity :: Name -> Nice (Maybe [Occurrence])
+getPolarity x = do
+ p <- gets (Map.lookup x . pols)
+ modify (\s -> s { pols = Map.delete x (pols s) })
+ return p
runNice :: Nice a -> Either DeclarationException a
runNice nice = nice `evalStateT` initNiceEnv
@@ -476,12 +575,12 @@ data DeclKind
deriving (Eq, Show)
declKind :: NiceDeclaration -> DeclKind
-declKind (FunSig _ _ _ _ _ _ tc x _) = LoneSig (FunName tc) x
-declKind (NiceRecSig _ _ _ x pars _ pc) = LoneSig (RecName pc $ parameters pars) x
-declKind (NiceDataSig _ _ _ x pars _ pc) = LoneSig (DataName pc $ parameters pars) x
+declKind (FunSig _ _ _ _ _ _ _ tc x _) = LoneSig (FunName tc) x
+declKind (NiceRecSig _ _ _ _ pc x pars _) = LoneSig (RecName pc $ parameters pars) x
+declKind (NiceDataSig _ _ _ _ pc x pars _)= LoneSig (DataName pc $ parameters pars) x
declKind (FunDef _ _ _ _ tc x _) = LoneDefs (FunName tc) [x]
-declKind (DataDef _ _ _ x pars pc _) = LoneDefs (DataName pc $ parameters pars) [x]
-declKind (RecDef _ _ _ x _ _ _ pars pc _) = LoneDefs (RecName pc $ parameters pars) [x]
+declKind (DataDef _ _ _ pc x pars _) = LoneDefs (DataName pc $ parameters pars) [x]
+declKind (RecDef _ _ _ pc x _ _ _ pars _) = LoneDefs (RecName pc $ parameters pars) [x]
declKind (NiceUnquoteDef _ _ _ _ tc xs _) = LoneDefs (FunName tc) xs
declKind Axiom{} = OtherDecl
declKind NiceField{} = OtherDecl
@@ -507,15 +606,27 @@ parameters = List.concat . List.map numP where
niceDeclarations :: [Declaration] -> Nice [NiceDeclaration]
niceDeclarations ds = do
-- Get fixity and syntax declarations.
- fixs <- fixities ds
- case Map.keys fixs \\ concatMap declaredNames ds of
+ (fixs, polarities) <- fixitiesAndPolarities ds
+ let declared = Set.fromList (concatMap declaredNames ds)
+ unknownFixs = Map.keysSet fixs Set.\\ declared
+ unknownPols = Map.keysSet polarities Set.\\ declared
+ case (Set.null unknownFixs, Set.null unknownPols) of
-- If we have fixity/syntax decls for names not declared
-- in the current scope, fail.
- xs@(_:_) -> throwError $ UnknownNamesInFixityDecl xs
- [] -> localState $ do
- -- Run the nicifier in an initial environment of fixity decls.
- put $ initNiceEnv { fixs = fixs }
+ (False, _) -> throwError $ UnknownNamesInFixityDecl
+ (Set.toList unknownFixs)
+ -- Fail if there are polarity pragmas with undeclared names.
+ (_, False) -> throwError $ UnknownNamesInPolarityPragmas
+ (Set.toList unknownPols)
+ (True, True) -> localState $ do
+ -- Run the nicifier in an initial environment of fixity decls
+ -- and polarities.
+ put $ initNiceEnv { fixs = fixs, pols = polarities }
ds <- nice ds
+ -- Check that every polarity pragma was used.
+ unusedPolarities <- gets (Map.keys . pols)
+ unless (null unusedPolarities) $ do
+ throwError $ PolarityPragmasButNotPostulates unusedPolarities
-- Check that every signature got its definition.
checkLoneSigs . Map.toList =<< use loneSigs
-- Note that loneSigs is ensured to be empty.
@@ -541,7 +652,7 @@ niceDeclarations ds = do
PatternSyn _ x _ _ -> [x]
Mutual _ ds -> concatMap declaredNames ds
Abstract _ ds -> concatMap declaredNames ds
- Private _ ds -> concatMap declaredNames ds
+ Private _ _ ds -> concatMap declaredNames ds
InstanceB _ ds -> concatMap declaredNames ds
Macro _ ds -> concatMap declaredNames ds
Postulate _ ds -> concatMap declaredNames ds
@@ -573,7 +684,7 @@ niceDeclarations ds = do
-- block. See Issue 1760.
let prefix :: [NiceDeclaration] -> [NiceDeclaration]
prefix = case (d, ds0) of
- (NiceRecSig{}, [r@(RecDef _ _ _ _ _ _ _ _ True _)]) -> ([d, r] ++)
+ (NiceRecSig{}, [r@(RecDef _ _ _ True _ _ _ _ _ _)]) -> ([d, r] ++)
_ ->
(NiceMutual (getRange (d : ds0)) tc (and pcs) (d : ds0) :)
@@ -607,116 +718,137 @@ niceDeclarations ds = do
nice :: [Declaration] -> Nice [NiceDeclaration]
nice [] = return []
+ nice ds = do
+ (xs , ys) <- nice1 ds
+ (xs ++) <$> nice ys
+
+ nice1 :: [Declaration] -> Nice ([NiceDeclaration], [Declaration])
+ nice1 [] = __IMPOSSIBLE__
+ nice1 (d:ds) = case d of
+
+ (TypeSig info x t) -> do
+ termCheck <- use terminationCheckPragma
+ fx <- getFixity x
+ -- register x as lone type signature, to recognize clauses later
+ addLoneSig x (FunName termCheck)
+ return ([FunSig (getRange d) fx PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck x t] , ds)
+
+ (FunClause lhs _ _ _) -> do
+ termCheck <- use terminationCheckPragma
+ catchall <- popCatchallPragma
+ xs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs
+ -- for each type signature 'x' waiting for clauses, we try
+ -- if we have some clauses for 'x'
+ fixs <- gets fixs
+ case [ (x, (fits, rest))
+ | x <- xs
+ , let (fits, rest) =
+ -- Anonymous declarations only have 1 clause each!
+ if isNoName x then ([d], ds)
+ else span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)
+ , not (null fits)
+ ] of
- nice (Pragma (TerminationCheckPragma r NoTerminationCheck) : _) =
- throwError $ PragmaNoTerminationCheck r
-
- nice (Pragma (TerminationCheckPragma r tc) : ds@(Mutual{} : _)) | notMeasure tc = do
- ds <- nice ds
- case ds of
- NiceMutual r _ pc ds' : ds -> return $ NiceMutual r tc pc ds' : ds
- _ -> __IMPOSSIBLE__
-
- nice (Pragma (TerminationCheckPragma r tc) : d@TypeSig{} : ds) =
- niceTypeSig tc d ds
-
- nice (Pragma (TerminationCheckPragma r tc) : d@FunClause{} : ds) | notMeasure tc =
- niceFunClause tc False d ds
-
- nice (Pragma (TerminationCheckPragma r tc) : ds@(UnquoteDecl{} : _)) | notMeasure tc = do
- NiceUnquoteDecl r f p a i _ x e : ds <- nice ds
- return $ NiceUnquoteDecl r f p a i tc x e : ds
-
- nice (Pragma (TerminationCheckPragma r tc) : d@(Pragma (NoPositivityCheckPragma _)) : ds@(Mutual{} : _)) | notMeasure tc = do
- ds <- nice (d : ds)
- case ds of
- NiceMutual r _ pc ds' : ds -> return $ NiceMutual r tc pc ds' : ds
- _ -> __IMPOSSIBLE__
-
- nice (Pragma (CatchallPragma r) : d@FunClause{} : ds) =
- niceFunClause TerminationCheck True d ds
-
- nice (d@TypeSig{} : Pragma (TerminationCheckPragma r (TerminationMeasure _ x)) : ds) =
- niceTypeSig (TerminationMeasure r x) d ds
-
- -- nice (Pragma (MeasurePragma r x) : d@FunClause{} : ds) =
- -- niceFunClause (TerminationMeasure r x) d ds
-
- nice (Pragma (NoPositivityCheckPragma _) : ds@(Mutual{} : _)) = do
- ds <- nice ds
- case ds of
- NiceMutual r tc _ ds' : ds -> return $ NiceMutual r tc False ds' : ds
- _ -> __IMPOSSIBLE__
-
- nice (Pragma (NoPositivityCheckPragma _) : d@(Data _ Inductive _ _ _ _) : ds) =
- niceDataDef False d ds
-
- nice (Pragma (NoPositivityCheckPragma _) : d@(DataSig _ Inductive _ _ _) : ds) =
- niceDataSig False d ds
-
- nice (Pragma (NoPositivityCheckPragma _) : d@Record{} : ds) =
- niceRecord False d ds
+ -- case: clauses match none of the sigs
+ [] -> case lhs of
+ -- Subcase: The lhs is single identifier (potentially anonymous).
+ -- Treat it as a function clause without a type signature.
+ LHS p [] [] [] | Just x <- isSingleIdentifierP p -> do
+ d <- mkFunDef defaultArgInfo termCheck x Nothing [d] -- fun def without type signature is relevant
+ return (d , ds)
+ -- Subcase: The lhs is a proper pattern.
+ -- This could be a let-pattern binding. Pass it on.
+ -- A missing type signature error might be raise in ConcreteToAbstract
+ _ -> do
+ return ([NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck catchall d] , ds)
- nice (Pragma (NoPositivityCheckPragma _) : d@RecordSig{} : ds) =
- niceRecordSig False d ds
+ -- case: clauses match exactly one of the sigs
+ [(x,(fits,rest))] -> do
+ removeLoneSig x
+ cs <- mkClauses x (expandEllipsis fits) False
+ fx <- getFixity x
+ return ([FunDef (getRange fits) fits fx ConcreteDef termCheck x cs] , rest)
- nice (Pragma (NoPositivityCheckPragma _) : d@(Pragma (TerminationCheckPragma _ _)) : ds@(Mutual{} : _)) = do
- ds <- nice (d : ds)
- case ds of
- NiceMutual r tc _ ds' : ds -> return $ NiceMutual r tc False ds' : ds
- _ -> __IMPOSSIBLE__
+ -- case: clauses match more than one sigs (ambiguity)
+ l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature"
- nice (d:ds) = do
- case d of
- TypeSig{} -> niceTypeSig TerminationCheck d ds
- FunClause{} -> niceFunClause TerminationCheck False d ds
- Field{} -> (++) <$> niceAxioms FieldBlock [ d ] <*> nice ds
+ Field{} -> (,ds) <$> niceAxioms FieldBlock [ d ]
DataSig r CoInductive _ _ _ -> throwError (Codata r)
Data r CoInductive _ _ _ _ -> throwError (Codata r)
- d@(DataSig _ Inductive _ _ _) -> niceDataSig True d ds
- d@(Data _ Inductive _ _ _ _) -> niceDataDef True d ds
- d@RecordSig{} -> niceRecordSig True d ds
- d@Record{} -> niceRecord True d ds
+
+ (DataSig r Inductive x tel t) -> do
+ pc <- use positivityCheckPragma
+ addLoneSig x (DataName pc $ parameters tel)
+ (,) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel (Just t) Nothing
+ <*> return ds
+
+ (Data r Inductive x tel t cs) -> do
+ pc <- use positivityCheckPragma
+ t <- defaultTypeSig (DataName pc $ parameters tel) x t
+ (,) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel t (Just cs)
+ <*> return ds
+
+ (RecordSig r x tel t) -> do
+ pc <- use positivityCheckPragma
+ addLoneSig x (RecName pc $ parameters tel)
+ fx <- getFixity x
+ return ([NiceRecSig r fx PublicAccess ConcreteDef pc x tel t] , ds)
+
+ (Record r x i e c tel t cs) -> do
+ pc <- use positivityCheckPragma
+ t <- defaultTypeSig (RecName pc $ parameters tel) x t
+ c <- traverse (\(cname, cinst) -> do fix <- getFixity cname; return (ThingWithFixity cname fix, cinst)) c
+ (,) <$> dataOrRec pc (\ r f a pc x tel cs -> RecDef r f a pc x i e c tel cs) NiceRecSig
+ niceDeclarations r x tel t (Just cs)
+ <*> return ds
Mutual r ds' ->
- (:) <$> (mkOldMutual r =<< nice ds') <*> nice ds
+ (,ds) <$> (singleton <$> (mkOldMutual r =<< nice ds'))
Abstract r ds' ->
- (++) <$> (abstractBlock r =<< nice ds') <*> nice ds
+ (,ds) <$> (abstractBlock r =<< nice ds')
- Private r ds' ->
- (++) <$> (privateBlock r =<< nice ds') <*> nice ds
+ Private r o ds' ->
+ (,ds) <$> (privateBlock r o =<< nice ds')
InstanceB r ds' ->
- (++) <$> (instanceBlock r =<< nice ds') <*> nice ds
+ (,ds) <$> (instanceBlock r =<< nice ds')
Macro r ds' ->
- (++) <$> (macroBlock r =<< nice ds') <*> nice ds
+ (,ds) <$> (macroBlock r =<< nice ds')
- Postulate _ ds' -> (++) <$> niceAxioms PostulateBlock ds' <*> nice ds
+ Postulate _ ds' ->
+ (,ds) <$> (mapM setPolarity =<< niceAxioms PostulateBlock ds')
+ where
+ setPolarity (Axiom r f acc a i arg Nothing x e) = do
+ mp <- getPolarity x
+ return (Axiom r f acc a i arg mp x e)
+ setPolarity (Axiom _ _ _ _ _ _ (Just _) _ _) = __IMPOSSIBLE__
+ setPolarity d = return d
- Primitive _ ds' -> (++) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds') <*> nice ds
+ Primitive _ ds' -> (,ds) <$> (map toPrim <$> niceAxioms PrimitiveBlock ds')
- Module r x tel ds' ->
- (NiceModule r PublicAccess ConcreteDef x tel ds' :) <$> nice ds
+ Module r x tel ds' -> return $
+ ([NiceModule r PublicAccess ConcreteDef x tel ds'] , ds)
- ModuleMacro r x modapp op is ->
- (NiceModuleMacro r PublicAccess x modapp op is :)
- <$> nice ds
+ ModuleMacro r x modapp op is -> return $
+ ([NiceModuleMacro r PublicAccess x modapp op is] , ds)
- -- Fixity and syntax declarations have been looked at already.
- Infix _ _ -> nice ds
- Syntax _ _ -> nice ds
+ -- Fixity and syntax declarations and polarity pragmas have
+ -- already been processed.
+ Infix _ _ -> return ([], ds)
+ Syntax _ _ -> return ([], ds)
PatternSyn r n as p -> do
fx <- getFixity n
- (NicePatternSyn r fx n as p :) <$> nice ds
- Open r x is -> (NiceOpen r x is :) <$> nice ds
- Import r x as op is -> (NiceImport r x as op is :) <$> nice ds
+ return ([NicePatternSyn r fx n as p] , ds)
+ Open r x is -> return ([NiceOpen r x is] , ds)
+ Import r x as op is -> return ([NiceImport r x as op is] , ds)
UnquoteDecl r xs e -> do
fxs <- mapM getFixity xs
- (NiceUnquoteDecl r fxs PublicAccess NotInstanceDef ConcreteDef TerminationCheck xs e :) <$> nice ds
+ tc <- use terminationCheckPragma
+ return ([NiceUnquoteDecl r fxs PublicAccess ConcreteDef NotInstanceDef tc xs e] , ds)
UnquoteDef r xs e -> do
fxs <- mapM getFixity xs
@@ -725,105 +857,85 @@ niceDeclarations ds = do
if null missing
then do
mapM_ removeLoneSig xs
- (NiceUnquoteDef r fxs PublicAccess ConcreteDef TerminationCheck xs e :) <$> nice ds
+ return ([NiceUnquoteDef r fxs PublicAccess ConcreteDef TerminationCheck xs e] , ds)
else throwError $ UnquoteDefRequiresSignature missing
- Pragma (TerminationCheckPragma r NoTerminationCheck) ->
- throwError $ PragmaNoTerminationCheck r
- Pragma (TerminationCheckPragma r _) ->
- throwError $ InvalidTerminationCheckPragma r
-
- Pragma (CatchallPragma r) ->
- throwError $ InvalidCatchallPragma r
-
- Pragma (NoPositivityCheckPragma r) ->
- throwError $ InvalidNoPositivityCheckPragma r
-
- Pragma p -> (NicePragma (getRange p) p :) <$> nice ds
-
- niceFunClause :: TerminationCheck -> Catchall -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
- niceFunClause termCheck catchall d@(FunClause lhs _ _ _) ds = do
- xs <- map fst . filter (isFunName . snd) . Map.toList <$> use loneSigs
- -- for each type signature 'x' waiting for clauses, we try
- -- if we have some clauses for 'x'
- fixs <- gets fixs
- case [ (x, (fits, rest))
- | x <- xs
- , let (fits, rest) =
- span (couldBeFunClauseOf (Map.lookup x fixs) x) (d : ds)
- , not (null fits)
- ] of
+ Pragma p -> nicePragma p ds
- -- case: clauses match none of the sigs
- [] -> case lhs of
- -- Subcase: The lhs is single identifier.
- -- Treat it as a function clause without a type signature.
- LHS p [] [] [] | IdentP (QName x) <- removeSingletonRawAppP p -> do
- ds <- nice ds
- d <- mkFunDef defaultArgInfo termCheck x Nothing [d] -- fun def without type signature is relevant
- return $ d ++ ds
- -- Subcase: The lhs is a proper pattern.
- -- This could be a let-pattern binding. Pass it on.
- -- A missing type signature error might be raise in ConcreteToAbstract
- _ -> do
- ds <- nice ds
- return $ NiceFunClause (getRange d) PublicAccess ConcreteDef termCheck catchall d : ds
+ nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])
- -- case: clauses match exactly one of the sigs
- [(x,(fits,rest))] -> do
- removeLoneSig x
- cs <- mkClauses x (expandEllipsis fits) False
- ds1 <- nice rest
- fx <- getFixity x
- d <- return $ FunDef (getRange fits) fits fx ConcreteDef termCheck x cs
- return $ d : ds1
+ nicePragma (TerminationCheckPragma r (TerminationMeasure _ x)) ds =
+ if canHaveTerminationMeasure ds then
+ withTerminationCheckPragma (TerminationMeasure r x) $ nice1 ds
+ else
+ throwError $ InvalidTerminationCheckPragma r
- -- case: clauses match more than one sigs (ambiguity)
- l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature"
- niceFunClause _ _ _ _ = __IMPOSSIBLE__
+ nicePragma (TerminationCheckPragma r NoTerminationCheck) ds =
+ throwError $ PragmaNoTerminationCheck r
- niceTypeSig :: TerminationCheck -> Declaration -> [Declaration] -> Nice [NiceDeclaration]
- niceTypeSig termCheck d@(TypeSig info x t) ds = do
- fx <- getFixity x
- -- register x as lone type signature, to recognize clauses later
- addLoneSig x (FunName termCheck)
- ds <- nice ds
- return $ FunSig (getRange d) fx PublicAccess NotInstanceDef NotMacroDef info termCheck x t : ds
- niceTypeSig _ _ _ = __IMPOSSIBLE__
-
- niceDataDef :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceDataDef pc (Data r Inductive x tel t cs) ds = do
- t <- defaultTypeSig (DataName pc $ parameters tel) x t
- (++) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel t (Just cs)
- <*> nice ds
- niceDataDef _ _ _ = __IMPOSSIBLE__
-
- niceDataSig :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceDataSig pc (DataSig r Inductive x tel t) ds = do
- addLoneSig x (DataName pc $ parameters tel)
- (++) <$> dataOrRec pc DataDef NiceDataSig (niceAxioms DataBlock) r x tel (Just t) Nothing
- <*> nice ds
- niceDataSig _ _ _ = __IMPOSSIBLE__
-
- niceRecord :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceRecord pc (Record r x i e c tel t cs) ds = do
- t <- defaultTypeSig (RecName pc $ parameters tel) x t
- c <- traverse (\(cname, cinst) -> do fix <- getFixity cname; return (ThingWithFixity cname fix, cinst)) c
- (++) <$> dataOrRec pc (\x1 x2 x3 x4 -> RecDef x1 x2 x3 x4 i e c) NiceRecSig
- niceDeclarations r x tel t (Just cs)
- <*> nice ds
- niceRecord _ _ _ = __IMPOSSIBLE__
-
- niceRecordSig :: PositivityCheck -> Declaration -> [Declaration] ->
- Nice [NiceDeclaration]
- niceRecordSig pc (RecordSig r x tel t) ds = do
- addLoneSig x (RecName pc $ parameters tel)
- fx <- getFixity x
- (NiceRecSig r fx PublicAccess x tel t pc :) <$> nice ds
- niceRecordSig _ _ _ = __IMPOSSIBLE__
+ nicePragma (TerminationCheckPragma r tc) ds =
+ if canHaveTerminationCheckPragma ds then
+ withTerminationCheckPragma tc $ nice1 ds
+ else
+ throwError $ InvalidTerminationCheckPragma r
+
+ nicePragma (CatchallPragma r) ds =
+ if canHaveCatchallPragma ds then
+ withCatchallPragma True $ nice1 ds
+ else
+ throwError $ InvalidCatchallPragma r
+
+ nicePragma (NoPositivityCheckPragma r) ds =
+ if canHaveNoPositivityCheckPragma ds then
+ withPositivityCheckPragma False $ nice1 ds
+ else
+ throwError $ InvalidNoPositivityCheckPragma r
+
+ nicePragma (PolarityPragma{}) ds = return ([], ds)
+
+ nicePragma p ds = return ([NicePragma (getRange p) p], ds)
+
+ canHaveTerminationMeasure :: [Declaration] -> Bool
+ canHaveTerminationMeasure [] = False
+ canHaveTerminationMeasure (d:ds) = case d of
+ TypeSig{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveTerminationMeasure ds
+ _ -> False
+
+ canHaveTerminationCheckPragma :: [Declaration] -> Bool
+ canHaveTerminationCheckPragma [] = False
+ canHaveTerminationCheckPragma (d:ds) = case d of
+ Mutual{} -> True
+ TypeSig{} -> True
+ FunClause{} -> True
+ UnquoteDecl{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveTerminationCheckPragma ds
+ _ -> False
+
+ canHaveCatchallPragma :: [Declaration] -> Bool
+ canHaveCatchallPragma [] = False
+ canHaveCatchallPragma (d:ds) = case d of
+ FunClause{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveCatchallPragma ds
+ _ -> False
+
+ canHaveNoPositivityCheckPragma :: [Declaration] -> Bool
+ canHaveNoPositivityCheckPragma [] = False
+ canHaveNoPositivityCheckPragma (d:ds) = case d of
+ Mutual{} -> True
+ (Data _ Inductive _ _ _ _) -> True
+ (DataSig _ Inductive _ _ _) -> True
+ Record{} -> True
+ RecordSig{} -> True
+ (Pragma p) | isAttachedPragma p -> canHaveNoPositivityCheckPragma ds
+ _ -> False
+
+ isAttachedPragma :: Pragma -> Bool
+ isAttachedPragma p = case p of
+ TerminationCheckPragma{} -> True
+ CatchallPragma{} -> True
+ NoPositivityCheckPragma{} -> True
+ _ -> False
-- We could add a default type signature here, but at the moment we can't
-- infer the type of a record or datatype, so better to just fail here.
@@ -839,10 +951,10 @@ niceDeclarations ds = do
dataOrRec :: forall a .
PositivityCheck ->
- (Range -> Fixity' -> IsAbstract -> Name -> [LamBinding] ->
- PositivityCheck -> [NiceConstructor] -> NiceDeclaration) ->
- (Range -> Fixity' -> Access -> Name -> [LamBinding] -> Expr ->
- PositivityCheck -> NiceDeclaration) ->
+ (Range -> Fixity' -> IsAbstract -> PositivityCheck -> Name -> [LamBinding] ->
+ [NiceConstructor] -> NiceDeclaration) ->
+ (Range -> Fixity' -> Access -> IsAbstract -> PositivityCheck -> Name -> [LamBinding] -> Expr ->
+ NiceDeclaration) ->
([a] -> Nice [NiceDeclaration]) ->
Range ->
Name ->
@@ -854,8 +966,8 @@ niceDeclarations ds = do
mds <- traverse niceD mcs
f <- getFixity x
return $ catMaybes $
- [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess x tel t pc
- , mkDef r f ConcreteDef x (concatMap dropType tel) pc <$> mds
+ [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess ConcreteDef pc x tel t
+ , mkDef r f ConcreteDef pc x (concatMap dropType tel) <$> mds
]
where
dropType :: LamBinding -> [LamBinding]
@@ -872,10 +984,10 @@ niceDeclarations ds = do
niceAxiom b d = case d of
TypeSig rel x t -> do
fx <- getFixity x
- return [ Axiom (getRange d) fx PublicAccess NotInstanceDef rel x t ]
+ return [ Axiom (getRange d) fx PublicAccess ConcreteDef NotInstanceDef rel Nothing x t ]
Field i x argt -> do
fx <- getFixity x
- return [ NiceField (getRange d) i fx PublicAccess ConcreteDef x argt ]
+ return [ NiceField (getRange d) fx PublicAccess ConcreteDef i x argt ]
InstanceB r decls -> do
instanceBlock r =<< niceAxioms InstanceBlock decls
Pragma p@(RewritePragma r _) -> do
@@ -883,14 +995,14 @@ niceDeclarations ds = do
_ -> throwError $ WrongContentBlock b $ getRange d
toPrim :: NiceDeclaration -> NiceDeclaration
- toPrim (Axiom r f a i rel x t) = PrimitiveFunction r f a ConcreteDef x t
- toPrim _ = __IMPOSSIBLE__
+ toPrim (Axiom r f p a i rel Nothing x t) = PrimitiveFunction r f p a x t
+ toPrim _ = __IMPOSSIBLE__
-- Create a function definition.
mkFunDef info termCheck x mt ds0 = do
cs <- mkClauses x (expandEllipsis ds0) False
f <- getFixity x
- return [ FunSig (fuseRange x t) f PublicAccess NotInstanceDef NotMacroDef info termCheck x t
+ return [ FunSig (fuseRange x t) f PublicAccess ConcreteDef NotInstanceDef NotMacroDef info termCheck x t
, FunDef (getRange ds0) ds0 f ConcreteDef termCheck x cs ]
where
t = case mt of
@@ -905,7 +1017,7 @@ niceDeclarations ds = do
expandEllipsis (d@(FunClause Ellipsis{} _ _ _) : ds) =
d : expandEllipsis ds
expandEllipsis (d@(FunClause lhs@(LHS p ps _ _) _ _ _) : ds) =
- d : expand p ps ds
+ d : expand (setInserted p) (map setInserted ps) ds
where
expand _ _ [] = []
expand p ps (d@(Pragma (CatchallPragma r)) : ds) = d : expand p ps ds
@@ -920,6 +1032,23 @@ niceDeclarations ds = do
expand _ _ (_ : ds) = __IMPOSSIBLE__
expandEllipsis (_ : ds) = __IMPOSSIBLE__
+ setInserted :: Pattern -> Pattern
+ setInserted p = case p of
+ IdentP{} -> p
+ QuoteP{} -> p
+ AppP p q -> AppP (setInserted p) (fmap (fmap setInserted) q)
+ RawAppP r ps -> RawAppP r (map setInserted ps)
+ OpAppP r c ns ps -> OpAppP r c ns (map (fmap $ fmap setInserted) ps)
+ HiddenP r p -> HiddenP r (fmap setInserted p)
+ InstanceP r p -> InstanceP r (fmap setInserted p)
+ ParenP r p -> ParenP r (setInserted p)
+ WildP{} -> p
+ AbsurdP{} -> p
+ AsP r n p -> AsP r n (setInserted p)
+ DotP r _ e -> DotP r Inserted e
+ LitP{} -> p
+ RecP r fs -> RecP r (map (fmap setInserted) fs)
+
-- Turn function clauses into nice function clauses.
mkClauses :: Name -> [Declaration] -> Catchall -> Nice [Clause]
mkClauses _ [] _ = return []
@@ -998,9 +1127,14 @@ niceDeclarations ds = do
-- -- it's part of the current definition
-- isFunClauseOf _ _ = False
+ isSingleIdentifierP :: Pattern -> Maybe Name
+ isSingleIdentifierP p = case removeSingletonRawAppP p of
+ IdentP (QName x) -> Just x
+ WildP r -> Just $ noName r
+ _ -> Nothing
+
removeSingletonRawAppP :: Pattern -> Pattern
- removeSingletonRawAppP p =
- case p of
+ removeSingletonRawAppP p = case p of
RawAppP _ [p'] -> removeSingletonRawAppP p'
ParenP _ p' -> removeSingletonRawAppP p'
_ -> p
@@ -1015,11 +1149,13 @@ niceDeclarations ds = do
[] -> return ()
(NiceFunClause _ _ _ _ s_ (FunClause lhs _ _ _)):_ -> throwError $ MissingTypeSignature lhs
d:_ -> throwError $ NotAllowedInMutual d
+ tc0 <- use terminationCheckPragma
let tcs = map termCheck ds
- tc <- combineTermChecks r tcs
+ tc <- combineTermChecks r (tc0:tcs)
+ pc0 <- use positivityCheckPragma
let pc :: PositivityCheck
- pc = all positivityCheckOldMutual ds
+ pc = pc0 && all positivityCheckOldMutual ds
return $ NiceMutual r tc pc $ sigs ++ other
where
@@ -1040,7 +1176,7 @@ niceDeclarations ds = do
-- Andreas, 2013-02-28 (issue 804):
-- do not termination check a mutual block if any of its
-- inner declarations comes with a {-# NO_TERMINATION_CHECK #-}
- termCheck (FunSig _ _ _ _ _ _ tc _ _) = tc
+ termCheck (FunSig _ _ _ _ _ _ _ tc _ _) = tc
termCheck (FunDef _ _ _ _ tc _ _) = tc
-- ASR (28 December 2015): Is this equation necessary?
termCheck (NiceMutual _ tc _ _) = __IMPOSSIBLE__
@@ -1065,11 +1201,11 @@ niceDeclarations ds = do
-- block if any of its inner declarations comes with a
-- NO_POSITIVITY_CHECK pragma. See Issue 1614.
positivityCheckOldMutual :: NiceDeclaration -> PositivityCheck
- positivityCheckOldMutual (DataDef _ _ _ _ _ pc _) = pc
- positivityCheckOldMutual (NiceDataSig _ _ _ _ _ _ pc) = pc
+ positivityCheckOldMutual (DataDef _ _ _ pc _ _ _) = pc
+ positivityCheckOldMutual (NiceDataSig _ _ _ _ pc _ _ _)= pc
positivityCheckOldMutual (NiceMutual _ _ pc _) = __IMPOSSIBLE__
- positivityCheckOldMutual (NiceRecSig _ _ _ _ _ _ pc) = pc
- positivityCheckOldMutual (RecDef _ _ _ _ _ _ _ _ pc _) = pc
+ positivityCheckOldMutual (NiceRecSig _ _ _ _ pc _ _ _) = pc
+ positivityCheckOldMutual (RecDef _ _ _ pc _ _ _ _ _ _) = pc
positivityCheckOldMutual _ = True
-- A mutual block cannot have a measure,
@@ -1077,101 +1213,16 @@ niceDeclarations ds = do
abstractBlock _ [] = return []
abstractBlock r ds = do
- let (ds', anyChange) = runChange $ mapM mkAbstract ds
+ let (ds', anyChange) = runChange $ mkAbstract ds
inherited = r == noRange
-- hack to avoid failing on inherited abstract blocks in where clauses
if anyChange || inherited then return ds' else throwError $ UselessAbstract r
- -- Make a declaration abstract
- mkAbstract :: Updater NiceDeclaration
- mkAbstract d =
- case d of
- NiceMutual r termCheck pc ds -> NiceMutual r termCheck pc <$> mapM mkAbstract ds
- FunDef r ds f a tc x cs -> (\ a -> FunDef r ds f a tc x) <$> setAbstract a <*> mapM mkAbstractClause cs
- DataDef r f a x ps pc cs -> (\ a -> DataDef r f a x ps pc) <$> setAbstract a <*> mapM mkAbstract cs
- RecDef r f a x i e c ps pc cs -> (\ a -> RecDef r f a x i e c ps pc) <$> setAbstract a <*> mapM mkAbstract cs
- NiceFunClause r p a termCheck catchall d -> (\ a -> NiceFunClause r p a termCheck catchall d) <$> setAbstract a
- -- no effect on fields or primitives, the InAbstract field there is unused
- NiceField r i f p _ x e -> return $ NiceField r i f p AbstractDef x e
- PrimitiveFunction r f p _ x e -> return $ PrimitiveFunction r f p AbstractDef x e
- NiceUnquoteDecl r f p i _ t x e -> return $ NiceUnquoteDecl r f p i AbstractDef t x e
- NiceUnquoteDef r f p _ t x e -> return $ NiceUnquoteDef r f p AbstractDef t x e
- NiceModule{} -> return d
- NiceModuleMacro{} -> return d
- Axiom{} -> return d
- NicePragma{} -> return d
- NiceOpen{} -> return d
- NiceImport{} -> return d
- FunSig{} -> return d
- NiceRecSig{} -> return d
- NiceDataSig{} -> return d
- NicePatternSyn{} -> return d
-
- setAbstract :: Updater IsAbstract
- setAbstract a = case a of
- AbstractDef -> return a
- ConcreteDef -> dirty $ AbstractDef
-
- mkAbstractClause :: Updater Clause
- mkAbstractClause (Clause x catchall lhs rhs wh with) = do
- wh <- mkAbstractWhere wh
- Clause x catchall lhs rhs wh <$> mapM mkAbstractClause with
-
- mkAbstractWhere :: Updater WhereClause
- mkAbstractWhere NoWhere = return $ NoWhere
- mkAbstractWhere (AnyWhere ds) = dirty $ AnyWhere [Abstract noRange ds]
- mkAbstractWhere (SomeWhere m ds) = dirty $SomeWhere m [Abstract noRange ds]
-
- privateBlock _ [] = return []
- privateBlock r ds = do
- let (ds', anyChange) = runChange $ mapM mkPrivate ds
- if anyChange then return ds' else throwError $ UselessPrivate r
-
- -- Make a declaration private.
- -- Andreas, 2012-11-17:
- -- Mark computation 'dirty' if there was a declaration that could be privatized.
- -- If no privatization is taking place, we want to complain about 'UselessPrivate'.
- -- Alternatively, we could only dirty if a non-private thing was privatized.
- -- Then, nested 'private's would sometimes also be complained about.
- mkPrivate :: Updater NiceDeclaration
- mkPrivate d =
- case d of
- Axiom r f p i rel x e -> (\ p -> Axiom r f p i rel x e) <$> setPrivate p
- NiceField r i f p a x e -> (\ p -> NiceField r i f p a x e) <$> setPrivate p
- PrimitiveFunction r f p a x e -> (\ p -> PrimitiveFunction r f p a x e) <$> setPrivate p
- NiceMutual r termCheck pc ds -> NiceMutual r termCheck pc <$> mapM mkPrivate ds
- NiceModule r p a x tel ds -> (\ p -> NiceModule r p a x tel ds) <$> setPrivate p
- NiceModuleMacro r p x ma op is -> (\ p -> NiceModuleMacro r p x ma op is) <$> setPrivate p
- FunSig r f p i m rel tc x e -> (\ p -> FunSig r f p i m rel tc x e) <$> setPrivate p
- NiceRecSig r f p x ls t pc -> (\ p -> NiceRecSig r f p x ls t pc) <$> setPrivate p
- NiceDataSig r f p x ls t pc -> (\ p -> NiceDataSig r f p x ls t pc) <$> setPrivate p
- NiceFunClause r p a termCheck catchall d -> (\ p -> NiceFunClause r p a termCheck catchall d) <$> setPrivate p
- NiceUnquoteDecl r f p i a t x e -> (\ p -> NiceUnquoteDecl r f p i a t x e) <$> setPrivate p
- NiceUnquoteDef r f p a t x e -> (\ p -> NiceUnquoteDef r f p a t x e) <$> setPrivate p
- NicePragma _ _ -> return $ d
- NiceOpen _ _ _ -> return $ d
- NiceImport _ _ _ _ _ -> return $ d
- FunDef{} -> return $ d
- DataDef{} -> return $ d
- RecDef{} -> return $ d
- NicePatternSyn _ _ _ _ _ -> return $ d
-
- setPrivate :: Updater Access
- setPrivate p = case p of
- PrivateAccess -> return p
- _ -> dirty $ PrivateAccess
-
- -- Andreas, 2012-11-22: Q: is this necessary?
- -- Are where clauses not always private?
- mkPrivateClause :: Updater Clause
- mkPrivateClause (Clause x catchall lhs rhs wh with) = do
- wh <- mkPrivateWhere wh
- Clause x catchall lhs rhs wh <$> mapM mkPrivateClause with
-
- mkPrivateWhere :: Updater WhereClause
- mkPrivateWhere NoWhere = return $ NoWhere
- mkPrivateWhere (AnyWhere ds) = dirty $ AnyWhere [Private (getRange ds) ds]
- mkPrivateWhere (SomeWhere m ds) = dirty $ SomeWhere m [Private (getRange ds) ds]
+ privateBlock _ _ [] = return []
+ privateBlock r o ds = do
+ let (ds', anyChange) = runChange $ mkPrivate o ds
+ if anyChange then return ds' else
+ if o == UserWritten then throwError $ UselessPrivate r else return ds -- no change!
instanceBlock _ [] = return []
instanceBlock r ds = do
@@ -1182,9 +1233,9 @@ niceDeclarations ds = do
mkInstance :: Updater NiceDeclaration
mkInstance d =
case d of
- Axiom r f p i rel x e -> (\ i -> Axiom r f p i rel x e) <$> setInstance i
- FunSig r f p i m rel tc x e -> (\ i -> FunSig r f p i m rel tc x e) <$> setInstance i
- NiceUnquoteDecl r f p i a tc x e -> (\ i -> NiceUnquoteDecl r f p i a tc x e) <$> setInstance i
+ Axiom r f p a i rel mp x e -> (\ i -> Axiom r f p a i rel mp x e) <$> setInstance i
+ FunSig r f p a i m rel tc x e -> (\ i -> FunSig r f p a i m rel tc x e) <$> setInstance i
+ NiceUnquoteDecl r f p a i tc x e -> (\ i -> NiceUnquoteDecl r f p a i tc x e) <$> setInstance i
NiceMutual{} -> return d
NiceFunClause{} -> return d
FunDef{} -> return d
@@ -1212,10 +1263,142 @@ niceDeclarations ds = do
mkMacro :: NiceDeclaration -> Nice NiceDeclaration
mkMacro d =
case d of
- FunSig r f p i _ rel tc x e -> return $ FunSig r f p i MacroDef rel tc x e
+ FunSig r f p a i _ rel tc x e -> return $ FunSig r f p a i MacroDef rel tc x e
FunDef{} -> return d
_ -> throwError (BadMacroDef d)
+-- | Make a declaration abstract.
+--
+-- Mark computation as 'dirty' if there was a declaration that could be made abstract.
+-- If no abstraction is taking place, we want to complain about 'UselessAbstract'.
+--
+-- Alternatively, we could only flag 'dirty' if a non-abstract thing was abstracted.
+-- Then, nested @abstract@s would sometimes also be complained about.
+
+class MakeAbstract a where
+ mkAbstract :: Updater a
+ default mkAbstract :: (Traversable f, MakeAbstract a', a ~ f a') => Updater a
+ mkAbstract = traverse mkAbstract
+
+instance MakeAbstract a => MakeAbstract [a] where
+ -- Default definition kicks in here!
+ -- But note that we still have to declare the instance!
+
+-- Leads to overlap with 'WhereClause':
+-- instance (Traversable f, MakeAbstract a) => MakeAbstract (f a) where
+-- mkAbstract = traverse mkAbstract
+
+instance MakeAbstract IsAbstract where
+ mkAbstract a = case a of
+ AbstractDef -> return a
+ ConcreteDef -> dirty $ AbstractDef
+
+instance MakeAbstract NiceDeclaration where
+ mkAbstract d =
+ case d of
+ NiceMutual r termCheck pc ds -> NiceMutual r termCheck pc <$> mkAbstract ds
+ FunDef r ds f a tc x cs -> (\ a -> FunDef r ds f a tc x) <$> mkAbstract a <*> mkAbstract cs
+ DataDef r f a pc x ps cs -> (\ a -> DataDef r f a pc x ps) <$> mkAbstract a <*> mkAbstract cs
+ RecDef r f a pc x i e c ps cs -> (\ a -> RecDef r f a pc x i e c ps) <$> mkAbstract a <*> mkAbstract cs
+ NiceFunClause r p a termCheck catchall d -> (\ a -> NiceFunClause r p a termCheck catchall d) <$> mkAbstract a
+ -- The following declarations have an @InAbstract@ field
+ -- but are not really definitions, so we do count them into
+ -- the declarations which can be made abstract
+ -- (thus, do not notify progress with @dirty@).
+ Axiom r f p a i rel mp x e -> return $ Axiom r f p AbstractDef i rel mp x e
+ FunSig r f p a i m rel tc x e -> return $ FunSig r f p AbstractDef i m rel tc x e
+ NiceRecSig r f p a pc x ls t -> return $ NiceRecSig r f p AbstractDef pc x ls t
+ NiceDataSig r f p a pc x ls t -> return $ NiceDataSig r f p AbstractDef pc x ls t
+ NiceField r f p _ i x e -> return $ NiceField r f p AbstractDef i x e
+ PrimitiveFunction r f p _ x e -> return $ PrimitiveFunction r f p AbstractDef x e
+ -- Andreas, 2016-07-17 it does have effect on unquoted defs.
+ -- Need to set updater state to dirty!
+ NiceUnquoteDecl r f p _ i t x e -> dirty $ NiceUnquoteDecl r f p AbstractDef i t x e
+ NiceUnquoteDef r f p _ t x e -> dirty $ NiceUnquoteDef r f p AbstractDef t x e
+ NiceModule{} -> return d
+ NiceModuleMacro{} -> return d
+ NicePragma{} -> return d
+ NiceOpen{} -> return d
+ NiceImport{} -> return d
+ NicePatternSyn{} -> return d
+
+instance MakeAbstract Clause where
+ mkAbstract (Clause x catchall lhs rhs wh with) = do
+ Clause x catchall lhs rhs <$> mkAbstract wh <*> mkAbstract with
+
+-- | Contents of a @where@ clause are abstract if the parent is.
+instance MakeAbstract WhereClause where
+ mkAbstract NoWhere = return $ NoWhere
+ mkAbstract (AnyWhere ds) = dirty $ AnyWhere [Abstract noRange ds]
+ mkAbstract (SomeWhere m a ds) = dirty $ SomeWhere m a [Abstract noRange ds]
+
+-- | Make a declaration private.
+--
+-- Andreas, 2012-11-17:
+-- Mark computation as 'dirty' if there was a declaration that could be privatized.
+-- If no privatization is taking place, we want to complain about 'UselessPrivate'.
+--
+-- Alternatively, we could only flag 'dirty' if a non-private thing was privatized.
+-- Then, nested @private@s would sometimes also be complained about.
+
+class MakePrivate a where
+ mkPrivate :: Origin -> Updater a
+ default mkPrivate :: (Traversable f, MakePrivate a', a ~ f a') => Origin -> Updater a
+ mkPrivate o = traverse $ mkPrivate o
+
+instance MakePrivate a => MakePrivate [a] where
+ -- Default definition kicks in here!
+ -- But note that we still have to declare the instance!
+
+-- Leads to overlap with 'WhereClause':
+-- instance (Traversable f, MakePrivate a) => MakePrivate (f a) where
+-- mkPrivate = traverse mkPrivate
+
+instance MakePrivate Access where
+ mkPrivate o p = case p of
+ PrivateAccess{} -> return p -- OR? return $ PrivateAccess o
+ _ -> dirty $ PrivateAccess o
+
+instance MakePrivate NiceDeclaration where
+ mkPrivate o d =
+ case d of
+ Axiom r f p a i rel mp x e -> (\ p -> Axiom r f p a i rel mp x e) <$> mkPrivate o p
+ NiceField r f p a i x e -> (\ p -> NiceField r f p a i x e) <$> mkPrivate o p
+ PrimitiveFunction r f p a x e -> (\ p -> PrimitiveFunction r f p a x e) <$> mkPrivate o p
+ NiceMutual r termCheck pc ds -> (\ p -> NiceMutual r termCheck pc p) <$> mkPrivate o ds
+ NiceModule r p a x tel ds -> (\ p -> NiceModule r p a x tel ds) <$> mkPrivate o p
+ NiceModuleMacro r p x ma op is -> (\ p -> NiceModuleMacro r p x ma op is) <$> mkPrivate o p
+ FunSig r f p a i m rel tc x e -> (\ p -> FunSig r f p a i m rel tc x e) <$> mkPrivate o p
+ NiceRecSig r f p a pc x ls t -> (\ p -> NiceRecSig r f p a pc x ls t) <$> mkPrivate o p
+ NiceDataSig r f p a pc x ls t -> (\ p -> NiceDataSig r f p a pc x ls t) <$> mkPrivate o p
+ NiceFunClause r p a termCheck catchall d -> (\ p -> NiceFunClause r p a termCheck catchall d) <$> mkPrivate o p
+ NiceUnquoteDecl r f p a i t x e -> (\ p -> NiceUnquoteDecl r f p a i t x e) <$> mkPrivate o p
+ NiceUnquoteDef r f p a t x e -> (\ p -> NiceUnquoteDef r f p a t x e) <$> mkPrivate o p
+ NicePragma _ _ -> return $ d
+ NiceOpen _ _ _ -> return $ d
+ NiceImport _ _ _ _ _ -> return $ d
+ -- Andreas, 2016-07-08, issue #2089
+ -- we need to propagate 'private' to the named where modules
+ FunDef r ds f a tc x cls -> FunDef r ds f a tc x <$> mkPrivate o cls
+ DataDef{} -> return $ d
+ RecDef{} -> return $ d
+ NicePatternSyn _ _ _ _ _ -> return $ d
+
+instance MakePrivate Clause where
+ mkPrivate o (Clause x catchall lhs rhs wh with) = do
+ Clause x catchall lhs rhs <$> mkPrivate o wh <*> mkPrivate o with
+
+instance MakePrivate WhereClause where
+ mkPrivate o NoWhere = return $ NoWhere
+ -- @where@-declarations are protected behind an anonymous module,
+ -- thus, they are effectively private by default.
+ mkPrivate o (AnyWhere ds) = return $ AnyWhere ds
+ -- Andreas, 2016-07-08
+ -- A @where@-module is private if the parent function is private.
+ -- The contents of this module are not private, unless declared so!
+ -- Thus, we do not recurse into the @ds@ (could not anyway).
+ mkPrivate o (SomeWhere m a ds) = mkPrivate o a <&> \ a' -> SomeWhere m a' ds
+
-- | Add more fixities. Throw an exception for multiple fixity declarations.
-- OR: Disjoint union of fixity maps. Throws exception if not disjoint.
@@ -1227,7 +1410,7 @@ plusFixities m1 m2
| 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
+ mergeFixites name (Fixity' f1 s1 r1) (Fixity' f2 s2 r2) = Fixity' f s $ fuseRange r1 r2
where f | f1 == noFixity = f2
| f2 == noFixity = f1
| otherwise = __IMPOSSIBLE__
@@ -1240,32 +1423,54 @@ plusFixities 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)
+ compatible (Fixity' f1 s1 _) (Fixity' f2 s2 _) =
+ (f1 == noFixity || f2 == noFixity ) &&
+ (s1 == noNotation || s2 == noNotation)
+
+-- | While 'Fixities' and Polarities are not semigroups under disjoint
+-- union (which might fail), we get a semigroup instance for the
+-- monadic @Nice (Fixities, Polarities)@ which propagates the first
+-- error.
+instance Semigroup (Nice (Fixities, Polarities)) where
+ c1 <> c2 = do
+ (f1, p1) <- c1
+ (f2, p2) <- c2
+ f <- plusFixities f1 f2
+ p <- mergePolarities p1 p2
+ return (f, p)
+ where
+ mergePolarities p1 p2
+ | Set.null i = return (Map.union p1 p2)
+ | otherwise = throwError $ MultiplePolarityPragmas (Set.toList i)
+ where
+ i = Set.intersection (Map.keysSet p1) (Map.keysSet p2)
--- | 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 = plusFixities ==<< (c1, c2)
+instance Monoid (Nice (Fixities, Polarities)) where
+ mempty = return (Map.empty, Map.empty)
+ mappend = (<>)
--- | Get the fixities from the current block.
+-- | Get the fixities and polarity pragmas 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
+-- The reason for this is that these declarations have to appear at the same
+-- level (or possibly outside an abstract or mutual block) as their target
-- declaration.
-fixities :: [Declaration] -> Nice Fixities
-fixities = foldMap $ \ d -> case d of
+fixitiesAndPolarities :: [Declaration] -> Nice (Fixities, Polarities)
+fixitiesAndPolarities = foldMap $ \ d -> case d of
+ -- These declarations define polarities:
+ Pragma (PolarityPragma _ x occs) -> return (Map.empty, Map.singleton x occs)
-- These declarations define fixities:
- Syntax x syn -> return $ Map.singleton x $ Fixity' noFixity syn
- Infix f xs -> return $ Map.fromList $ map (,Fixity' f noNotation) xs
+ Syntax x syn -> return ( Map.singleton x (Fixity' noFixity syn $ getRange x)
+ , Map.empty
+ )
+ Infix f xs -> return ( Map.fromList $ for xs $ \ x -> (x, Fixity' f noNotation$ getRange x)
+ , Map.empty
+ )
-- We look into these blocks:
- Mutual _ ds' -> fixities ds'
- Abstract _ ds' -> fixities ds'
- Private _ ds' -> fixities ds'
- InstanceB _ ds' -> fixities ds'
- Macro _ ds' -> fixities ds'
+ Mutual _ ds' -> fixitiesAndPolarities ds'
+ Abstract _ ds' -> fixitiesAndPolarities ds'
+ Private _ _ ds' -> fixitiesAndPolarities ds'
+ InstanceB _ ds' -> fixitiesAndPolarities ds'
+ Macro _ ds' -> fixitiesAndPolarities ds'
-- All other declarations are ignored.
-- We expand these boring cases to trigger a revisit
-- in case the @Declaration@ type is extended in the future.
@@ -1288,42 +1493,47 @@ fixities = foldMap $ \ d -> case d of
Pragma {} -> mempty
--- Andreas, 2012-04-07
--- The following function is only used twice, for building a Let, and for
--- printing an error message.
+-- The following function is (at the time of writing) only used three
+-- times: for building Lets, and for printing error messages.
--- | (Approximately) convert a 'NiceDeclaration' back to a 'Declaration'.
-notSoNiceDeclaration :: NiceDeclaration -> Declaration
-notSoNiceDeclaration d =
+-- | (Approximately) convert a 'NiceDeclaration' back to a list of
+-- 'Declaration's.
+notSoNiceDeclarations :: NiceDeclaration -> [Declaration]
+notSoNiceDeclarations d =
case d of
- Axiom _ _ _ _ rel x e -> TypeSig rel x e
- NiceField _ i _ _ _ x argt -> Field i x argt
- PrimitiveFunction r _ _ _ x e -> Primitive r [TypeSig defaultArgInfo x e]
- NiceMutual r _ _ ds -> Mutual r $ map notSoNiceDeclaration ds
- NiceModule r _ _ x tel ds -> Module r x tel ds
- NiceModuleMacro r _ x ma o dir -> ModuleMacro r x ma o dir
- NiceOpen r x dir -> Open r x dir
- NiceImport r x as o dir -> Import r x as o dir
- NicePragma _ p -> Pragma p
- NiceRecSig r _ _ x bs e _ -> RecordSig r x bs e
- NiceDataSig r _ _ x bs e _ -> DataSig r Inductive x bs e
- NiceFunClause _ _ _ _ _ d -> d
- FunSig _ _ _ _ _ rel tc x e -> TypeSig rel x e
- FunDef r [d] _ _ _ _ _ -> d
- FunDef r ds _ _ _ _ _ -> Mutual r ds -- Andreas, 2012-04-07 Hack!
- DataDef r _ _ x bs _ cs -> Data r Inductive x bs Nothing $ map notSoNiceDeclaration cs
- RecDef r _ _ x i e c bs _ ds -> Record r x i e (unThing <$> c) bs Nothing $ map notSoNiceDeclaration ds
+ Axiom _ _ _ _ i rel mp x e -> (case mp of
+ Nothing -> []
+ Just occs -> [Pragma (PolarityPragma noRange x occs)]) ++
+ inst i [TypeSig rel x e]
+ NiceField _ _ _ _ i x argt -> [Field i x argt]
+ PrimitiveFunction r _ _ _ x e -> [Primitive r [TypeSig defaultArgInfo x e]]
+ NiceMutual r _ _ ds -> [Mutual r $ concatMap notSoNiceDeclarations ds]
+ NiceModule r _ _ x tel ds -> [Module r x tel ds]
+ NiceModuleMacro r _ x ma o dir -> [ModuleMacro r x ma o dir]
+ NiceOpen r x dir -> [Open r x dir]
+ NiceImport r x as o dir -> [Import r x as o dir]
+ NicePragma _ p -> [Pragma p]
+ NiceRecSig r _ _ _ _ x bs e -> [RecordSig r x bs e]
+ NiceDataSig r _ _ _ _ x bs e -> [DataSig r Inductive x bs e]
+ NiceFunClause _ _ _ _ _ d -> [d]
+ FunSig _ _ _ _ i _ rel tc x e -> inst i [TypeSig rel x e]
+ FunDef _r ds _ _ _ _ _ -> ds
+ DataDef r _ _ _ x bs cs -> [Data r Inductive x bs Nothing $ concatMap notSoNiceDeclarations cs]
+ RecDef r _ _ _ x i e c bs ds -> [Record r x i e (unThing <$> c) bs Nothing $ concatMap notSoNiceDeclarations ds]
where unThing (ThingWithFixity c _, inst) = (c, inst)
- NicePatternSyn r _ n as p -> PatternSyn r n as p
- NiceUnquoteDecl r _ _ _ _ _ x e -> UnquoteDecl r x e
- NiceUnquoteDef r _ _ _ _ x e -> UnquoteDef r x e
+ NicePatternSyn r _ n as p -> [PatternSyn r n as p]
+ NiceUnquoteDecl r _ _ _ i _ x e -> inst i [UnquoteDecl r x e]
+ NiceUnquoteDef r _ _ _ _ x e -> [UnquoteDef r x e]
+ where
+ inst InstanceDef ds = [InstanceB (getRange ds) ds]
+ inst NotInstanceDef ds = ds
-- | Has the 'NiceDeclaration' a field of type 'IsAbstract'?
niceHasAbstract :: NiceDeclaration -> Maybe IsAbstract
niceHasAbstract d =
case d of
Axiom{} -> Nothing
- NiceField _ _ _ _ a _ _ -> Just a
+ NiceField _ _ _ a _ _ _ -> Just a
PrimitiveFunction _ _ _ a _ _ -> Just a
NiceMutual{} -> Nothing
NiceModule _ _ a _ _ _ -> Just a
@@ -1339,5 +1549,5 @@ niceHasAbstract d =
DataDef _ _ a _ _ _ _ -> Just a
RecDef _ _ a _ _ _ _ _ _ _ -> Just a
NicePatternSyn{} -> Nothing
- NiceUnquoteDecl _ _ _ _ a _ _ _ -> Just a
+ NiceUnquoteDecl _ _ _ a _ _ _ _ -> Just a
NiceUnquoteDef _ _ _ a _ _ _ -> Just a
diff --git a/src/full/Agda/Syntax/Concrete/Generic.hs b/src/full/Agda/Syntax/Concrete/Generic.hs
index f9066e3..66990ad 100644
--- a/src/full/Agda/Syntax/Concrete/Generic.hs
+++ b/src/full/Agda/Syntax/Concrete/Generic.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
-- | Generic traversal and reduce for concrete syntax,
-- in the style of "Agda.Syntax.Internal.Generic".
@@ -143,6 +142,7 @@ instance ExprLike Expr where
RecUpdate r e es -> f $ RecUpdate r (mapE e) $ mapE es
Let r ds e -> f $ Let r (mapE ds) $ mapE e
Paren r e -> f $ Paren r $ mapE e
+ IdiomBrackets r e -> f $ IdiomBrackets r $ mapE e
Absurd{} -> f $ e0
As r x e -> f $ As r x $ mapE e
Dot r e -> f $ Dot r $ mapE e
@@ -210,7 +210,7 @@ instance ExprLike Declaration where
PatternSyn{} -> e0
Mutual r ds -> Mutual r $ mapE ds
Abstract r ds -> Abstract r $ mapE ds
- Private r ds -> Private r $ mapE ds
+ Private r o ds -> Private r o $ mapE ds
InstanceB r ds -> InstanceB r $ mapE ds
Macro r ds -> Macro r $ mapE ds
Postulate r ds -> Postulate r $ mapE ds
diff --git a/src/full/Agda/Syntax/Concrete/Name.hs b/src/full/Agda/Syntax/Concrete/Name.hs
index df2a945..0a22253 100644
--- a/src/full/Agda/Syntax/Concrete/Name.hs
+++ b/src/full/Agda/Syntax/Concrete/Name.hs
@@ -1,9 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| Names in the concrete syntax are just strings (or lists of strings for
qualified names).
@@ -21,12 +19,12 @@ import GHC.Generics (Generic)
import System.FilePath
-import Test.QuickCheck
-
import Agda.Syntax.Common
import Agda.Syntax.Position
+
import Agda.Utils.FileName
import Agda.Utils.Pretty
+import Agda.Utils.Size
#include "undefined.h"
import Agda.Utils.Impossible
@@ -111,7 +109,7 @@ instance Underscore QName where
newtype TopLevelModuleName
= TopLevelModuleName { moduleNameParts :: [String] }
- deriving (Show, Eq, Ord, Typeable)
+ deriving (Show, Eq, Ord, Typeable, Sized)
------------------------------------------------------------------------
-- * Operations on 'Name' and 'NamePart'
@@ -202,6 +200,17 @@ qnameParts (QName x) = [x]
toTopLevelModuleName :: QName -> TopLevelModuleName
toTopLevelModuleName = TopLevelModuleName . map prettyShow . qnameParts
+-- | Turns a top level module into a qualified name with 'noRange'.
+
+fromTopLevelModuleName :: TopLevelModuleName -> QName
+fromTopLevelModuleName (TopLevelModuleName []) = __IMPOSSIBLE__
+fromTopLevelModuleName (TopLevelModuleName (x:xs)) = loop x xs
+ where
+ loop x [] = QName (mk x)
+ loop x (y : ys) = Qual (mk x) $ loop y ys
+ mk :: String -> Name
+ mk x = Name noRange [Id x]
+
-- | Turns a top-level module name into a file name with the given
-- suffix.
@@ -250,6 +259,7 @@ instance IsNoName Name where
isNoName (NoName _ _) = True
isNoName (Name _ [Hole]) = True -- TODO: Track down where these come from
isNoName (Name _ []) = True
+ isNoName (Name _ [Id x]) = isNoName x
isNoName _ = False
instance IsNoName QName where
@@ -292,44 +302,15 @@ instance Pretty NamePart where
pretty (Id s) = text $ rawNameToString s
instance Pretty QName where
- pretty (Qual m x) = pretty m <> pretty "." <> pretty x
+ pretty (Qual m x)
+ | isUnderscore m = pretty x -- don't print anonymous modules
+ | otherwise = pretty m <> pretty "." <> pretty x
pretty (QName x) = pretty x
instance Pretty TopLevelModuleName where
pretty (TopLevelModuleName ms) = text $ intercalate "." ms
------------------------------------------------------------------------
--- * QuickCheck instances
-------------------------------------------------------------------------
-
-instance Arbitrary TopLevelModuleName where
- arbitrary = TopLevelModuleName <$> listOf1 (listOf1 $ elements "AB")
-
-instance CoArbitrary TopLevelModuleName where
- coarbitrary (TopLevelModuleName m) = coarbitrary m
-
-instance Arbitrary Name where
- arbitrary = oneof
- [ Name <$> arbitrary <*> parts
- , NoName <$> arbitrary <*> arbitrary
- ]
- where
- parts = do
- parts <- listOf1 (elements ["x", "y", "z"])
- startWithHole <- arbitrary
- endWithHole <- arbitrary
- return $
- (if startWithHole then (Hole :) else id) $
- (if endWithHole then (++ [Hole]) else id) $
- intersperse Hole (map Id parts)
-
-instance CoArbitrary NamePart
-
-instance CoArbitrary Name where
- coarbitrary (Name _ ns) = variant 0 . coarbitrary ns
- coarbitrary (NoName _ i) = variant 1 . coarbitrary i
-
-------------------------------------------------------------------------
-- * Range instances
------------------------------------------------------------------------
diff --git a/src/full/Agda/Syntax/Concrete/Operators.hs b/src/full/Agda/Syntax/Concrete/Operators.hs
index 246ce8f..5b4210c 100644
--- a/src/full/Agda/Syntax/Concrete/Operators.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -40,6 +39,7 @@ import Agda.Syntax.Concrete.Pretty ()
import Agda.Syntax.Common
import Agda.Syntax.Concrete hiding (appView)
import Agda.Syntax.Concrete.Operators.Parser
+import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse)
import qualified Agda.Syntax.Abstract.Name as A
import Agda.Syntax.Position
import Agda.Syntax.Fixity
@@ -53,7 +53,6 @@ import Agda.TypeChecking.Monad.State (getScope)
import Agda.TypeChecking.Monad.Options
import Agda.Utils.Either
-import Agda.Utils.Parser.MemoisedCPS (memoise)
import Agda.Utils.Pretty
#if MIN_VERSION_base(4,8,0)
import Agda.Utils.List hiding ( uncons )
@@ -346,44 +345,49 @@ buildParsers r flat kind exprNames = do
, "relatedOperators = " ++ show relatedOperators
]
- return (parseSections, everything, Data.Function.fix $ \p -> Parsers
- { pTop = memoise TopK $
- Fold.asum $
- foldr ($) (pApp p)
- (map (\(l, ns) higher ->
- mkP (Right l) parseSections
- (pTop p) ns higher True)
- relatedOperators) :
- map (\(k, n) ->
- mkP (Left k) parseSections
- (pTop p) [n] (pApp p) False)
- (zip [0..] unrelatedOperators)
- , pApp = memoise AppK $ appP (pNonfix p) (pArgs p)
- , pArgs = argsP (pNonfix p)
- , pNonfix = memoise NonfixK $
- Fold.asum $
- pAtom p :
- flip map nonWithSections (\sect ->
- let n = sectNotation sect
-
- inner :: forall k. NK k ->
- Parser e (OperatorType k e)
- inner = opP parseSections (pTop p) n
- in
- case notationKind (notation n) of
- InfixNotation ->
- flip ($) <$> placeholder Beginning
- <*> inner In
- <*> placeholder End
- PrefixNotation ->
- inner Pre <*> placeholder End
- PostfixNotation ->
- flip ($) <$> placeholder Beginning
- <*> inner Post
- NonfixNotation -> inner Non
- NoNotation -> __IMPOSSIBLE__)
- , pAtom = atomP isAtom
- })
+ let g = Data.Function.fix $ \p -> Parsers
+ { pTop = memoise TopK $
+ Fold.asum $
+ foldr ($) (pApp p)
+ (map (\(l, ns) higher ->
+ mkP (Right l) parseSections
+ (pTop p) ns higher True)
+ relatedOperators) :
+ map (\(k, n) ->
+ mkP (Left k) parseSections
+ (pTop p) [n] (pApp p) False)
+ (zip [0..] unrelatedOperators)
+ , pApp = memoise AppK $ appP (pNonfix p) (pArgs p)
+ , pArgs = argsP (pNonfix p)
+ , pNonfix = memoise NonfixK $
+ Fold.asum $
+ pAtom p :
+ flip map nonWithSections (\sect ->
+ let n = sectNotation sect
+
+ inner :: forall k. NK k ->
+ Parser e (OperatorType k e)
+ inner = opP parseSections (pTop p) n
+ in
+ case notationKind (notation n) of
+ InfixNotation ->
+ flip ($) <$> placeholder Beginning
+ <*> inner In
+ <*> placeholder End
+ PrefixNotation ->
+ inner Pre <*> placeholder End
+ PostfixNotation ->
+ flip ($) <$> placeholder Beginning
+ <*> inner Post
+ NonfixNotation -> inner Non
+ NoNotation -> __IMPOSSIBLE__)
+ , pAtom = atomP isAtom
+ }
+
+ reportSDoc "scope.grammar" 10 $ return $
+ text "Operator grammar:" $$ nest 2 (grammar (pTop g))
+
+ return (parseSections, everything, g)
where
level :: NewNotation -> PrecedenceLevel
level = fixityLevel . notaFixity
@@ -451,11 +455,11 @@ buildParsers r flat kind exprNames = do
nonAssoc :: Maybe (Parser e e)
nonAssoc = case filter (isInfix NonAssoc) ops of
[] -> Nothing
- ops -> Just $ do
- x <- noPlaceholder <$> higher
- f <- choice In ops
- y <- noPlaceholder <$> higher
- return (f x y)
+ ops -> Just $
+ (\x f y -> f (noPlaceholder x) (noPlaceholder y))
+ <$> higher
+ <*> choice In ops
+ <*> higher
or p1 [] p2 [] = Nothing
or p1 [] p2 ops2 = Just (p2 ops2)
@@ -474,7 +478,8 @@ buildParsers r flat kind exprNames = do
preRights = do
preRight <- preRight
return $ Data.Function.fix $ \preRights ->
- preRight <*> (noPlaceholder <$> (preRights <|> higher))
+ memoiseIfPrinting (PreRightsK key) $
+ preRight <*> (noPlaceholder <$> (preRights <|> higher))
postLeft :: Maybe (Parser e (MaybePlaceholder e -> e))
postLeft =
@@ -524,7 +529,7 @@ parsePat prs p = case p of
HiddenP _ _ -> fail "bad hidden argument"
InstanceP _ _ -> fail "bad instance argument"
AsP r x p -> AsP r x <$> parsePat prs p
- DotP r e -> return $ DotP r e
+ DotP r o e -> return $ DotP r o e
ParenP r p -> fullParen' <$> parsePat prs p
WildP _ -> return p
AbsurdP _ -> return p
@@ -578,6 +583,8 @@ type ParseLHS = Either Pattern (QName, LHSCore)
parseLHS' ::
LHSOrPatSyn -> Maybe QName -> Pattern ->
ScopeM (ParseLHS, [NotationSection])
+parseLHS' IsLHS (Just qn) (RawAppP _ [WildP{}]) =
+ return (Right (qn, LHSHead qn []), [])
parseLHS' lhsOrPatSyn top p = do
let names = patternQNames p
ms = qualifierModules names
diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
index 79596b7..b8a15fc 100644
--- a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
+++ b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs
@@ -1,6 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
@@ -15,7 +13,7 @@ import Data.Maybe
import qualified Data.Strict.Maybe as Strict
import Data.Set (Set)
-import GHC.Generics (Generic)
+import Text.PrettyPrint.HughesPJ hiding (empty)
import Agda.Syntax.Position
import qualified Agda.Syntax.Abstract.Name as A
@@ -23,28 +21,16 @@ import Agda.Syntax.Common
import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Concrete
-
-import qualified Agda.Utils.Parser.MemoisedCPS as MemoisedCPS
-import Agda.Utils.Parser.MemoisedCPS hiding (Parser, parse)
-import qualified Agda.Utils.Parser.MemoisedCPS as Parser
+import Agda.Syntax.Concrete.Operators.Parser.Monad hiding (parse)
+import qualified Agda.Syntax.Concrete.Operators.Parser.Monad as P
#include "undefined.h"
import Agda.Utils.Impossible
-data MemoKey = NodeK (Either Integer Integer)
- | PostLeftsK (Either Integer Integer)
- | TopK
- | AppK
- | NonfixK
- deriving (Eq, Generic)
-
-instance Hashable MemoKey
-
-type Parser tok a =
- MemoisedCPS.Parser MemoKey tok (MaybePlaceholder tok) a
-
placeholder :: PositionInName -> Parser e (MaybePlaceholder e)
-placeholder p = sat $ \t ->
+placeholder p =
+ annotate (const $ text ("_" ++ show p)) $
+ sat $ \t ->
case t of
Placeholder p' | p' == p -> True
_ -> False
@@ -150,9 +136,8 @@ data ParseSections = ParseSections | DoNotParseSections
-- within their respective identifiers.
parse :: IsExpr e => (ParseSections, Parser e a) -> [e] -> [a]
-parse (DoNotParseSections, p) es = Parser.parse p (map noPlaceholder es)
-parse (ParseSections, p) es = Parser.parse p
- (concat $ map splitExpr es)
+parse (DoNotParseSections, p) es = P.parse p (map noPlaceholder es)
+parse (ParseSections, p) es = P.parse p (concat $ map splitExpr es)
where
splitExpr :: IsExpr e => e -> [MaybePlaceholder e]
splitExpr e = case exprView e of
@@ -194,7 +179,7 @@ parse (ParseSections, p) es = Parser.parse p
-- | Parse a specific identifier as a NamePart
partP :: IsExpr e => [Name] -> RawName -> Parser e Range
-partP ms s = do
+partP ms s = annotate (const $ text (show str)) $ do
tok <- notPlaceholder
case isLocal tok of
Just p -> return p
@@ -277,9 +262,9 @@ data NK (k :: NotationKind) :: * where
opP :: forall e k. IsExpr e
=> ParseSections
-> Parser e e -> NewNotation -> NK k -> Parser e (OperatorType k e)
-opP parseSections p (NewNotation q names _ syn isOp) kind = do
-
- (range, hs) <- worker (init $ qnameParts q) withoutExternalHoles
+opP parseSections p (NewNotation q names _ syn isOp) kind =
+ flip fmap (worker (init $ qnameParts q)
+ withoutExternalHoles) $ \(range, hs) ->
let (normal, binders) = partitionEithers hs
lastHole = maximum $ mapMaybe holeTarget syn
@@ -299,8 +284,9 @@ opP parseSections p (NewNotation q names _ syn isOp) kind = do
where
args = map (findExprFor (f normal) binders) [0..lastHole]
q' = setRange range q
+ in
- return $ case kind of
+ case kind of
In -> \x y -> app (\es -> (x, leadingHole) : es ++ [(y, trailingHole)])
Pre -> \ y -> app (\es -> es ++ [(y, trailingHole)])
Post -> \x -> app (\es -> (x, leadingHole) : es)
@@ -325,32 +311,31 @@ opP parseSections p (NewNotation q names _ syn isOp) kind = do
Parser e (Range, [Either (MaybePlaceholder e, NamedArg Int)
(LamBinding, Int)])
worker ms [] = return (noRange, [])
- worker ms (IdPart x : xs) = do
- r1 <- partP ms x
- (r2, es) <- worker [] xs
- -- Only the first
- -- part is qualified.
- return (fuseRanges r1 r2, es)
- worker ms (NormalHole h : xs) = do
- e <- maybePlaceholder
- (if isOp && parseSections == ParseSections
- then Just Middle else Nothing)
- p
- (r, es) <- worker ms xs
- return (r, Left (e, h) : es)
- worker ms (WildHole h : xs) = do
- (r, es) <- worker ms xs
- return (r, Right (mkBinding h $ Name noRange [Hole]) : es)
+ worker ms (IdPart x : xs) =
+ (\r1 (r2, es) -> (fuseRanges r1 r2, es))
+ <$> partP ms x
+ <*> worker [] xs
+ -- Only the first part is qualified.
+ worker ms (NormalHole h : xs) =
+ (\e (r, es) -> (r, Left (e, h) : es))
+ <$> maybePlaceholder
+ (if isOp && parseSections == ParseSections
+ then Just Middle else Nothing)
+ p
+ <*> worker ms xs
+ worker ms (WildHole h : xs) =
+ (\(r, es) -> (r, Right (mkBinding h $ Name noRange [Hole]) : es))
+ <$> worker ms xs
worker ms (BindHole h : xs) = do
- e <- wildOrUnqualifiedName
- case e of
- Just name -> ret name
- Nothing -> ret (Name noRange [Hole])
- where
- ret x = do
- (r, es) <- worker ms xs
- return (r, Right (mkBinding h x) : es)
- -- Andreas, 2011-04-07 put just 'Relevant' here, is this correct?
+ (\e (r, es) ->
+ let x = case e of
+ Just name -> name
+ Nothing -> Name noRange [Hole]
+ in (r, Right (mkBinding h x) : es))
+ -- Andreas, 2011-04-07 put just 'Relevant' here, is this
+ -- correct?
+ <$> wildOrUnqualifiedName
+ <*> worker ms xs
mkBinding h x = (DomainFree defaultArgInfo $ mkBoundName_ x, h)
@@ -375,7 +360,8 @@ opP parseSections p (NewNotation q names _ syn isOp) kind = do
isPlaceholder Placeholder{} = 1
argsP :: IsExpr e => Parser e e -> Parser e [NamedArg e]
-argsP p = many (nothidden <|> hidden <|> instanceH)
+argsP p = many (annotate (const $ text "<argument>") $
+ nothidden <|> hidden <|> instanceH)
where
isHidden (HiddenArgV _) = True
isHidden _ = False
@@ -399,15 +385,12 @@ argsP p = many (nothidden <|> hidden <|> instanceH)
return $ hide $ defaultArg e
appP :: IsExpr e => Parser e e -> Parser e [NamedArg e] -> Parser e e
-appP p pa = do
- h <- p
- es <- pa
- return $ foldl app h es
+appP p pa = foldl app <$> p <*> pa
where
app e = unExprView . AppV e
atomP :: IsExpr e => (QName -> Bool) -> Parser e e
-atomP p = do
+atomP p = annotate (const $ text "<atom>") $ do
e <- notPlaceholder
case exprView e of
LocalV x | not (p x) -> empty
diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs
new file mode 100644
index 0000000..2c0dfc6
--- /dev/null
+++ b/src/full/Agda/Syntax/Concrete/Operators/Parser/Monad.hs
@@ -0,0 +1,100 @@
+------------------------------------------------------------------------
+-- | The parser monad used by the operator parser
+------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Agda.Syntax.Concrete.Operators.Parser.Monad
+ ( MemoKey(..)
+ , Parser
+ , parse
+ , token
+ , sat
+ , tok
+ , annotate
+ , memoise
+ , memoiseIfPrinting
+ , grammar
+ ) where
+
+import Data.Hashable
+import GHC.Generics (Generic)
+import Text.PrettyPrint.HughesPJ
+
+import Agda.Syntax.Common
+import qualified Agda.Utils.Parser.MemoisedCPS as Parser
+
+-- | Memoisation keys.
+
+data MemoKey = NodeK (Either Integer Integer)
+ | PostLeftsK (Either Integer Integer)
+ | PreRightsK (Either Integer Integer)
+ | TopK
+ | AppK
+ | NonfixK
+ deriving (Eq, Show, Generic)
+
+instance Hashable MemoKey
+
+-- | The parser monad.
+
+type Parser tok a =
+#ifdef DEBUG
+ Parser.ParserWithGrammar
+#else
+ Parser.Parser
+#endif
+ MemoKey tok (MaybePlaceholder tok) a
+
+-- | Runs the parser.
+
+parse :: forall tok a. Parser tok a -> [MaybePlaceholder tok] -> [a]
+parse = Parser.parse
+
+-- | Parses a single token.
+
+token :: Parser tok (MaybePlaceholder tok)
+token = Parser.token
+
+-- | Parses a token satisfying the given predicate.
+
+sat :: (MaybePlaceholder tok -> Bool) ->
+ Parser tok (MaybePlaceholder tok)
+sat = Parser.sat
+
+-- | Parses a given token.
+
+tok :: (Eq tok, Show tok) =>
+ MaybePlaceholder tok -> Parser tok (MaybePlaceholder tok)
+tok = Parser.tok
+
+-- | Uses the given function to modify the printed representation (if
+-- any) of the given parser.
+
+annotate :: (Doc -> Doc) -> Parser tok a -> Parser tok a
+annotate = Parser.annotate
+
+-- | Memoises the given parser.
+--
+-- Every memoised parser must be annotated with a /unique/ key.
+-- (Parametrised parsers must use distinct keys for distinct inputs.)
+
+memoise :: MemoKey -> Parser tok tok -> Parser tok tok
+memoise = Parser.memoise
+
+-- | Memoises the given parser, but only if printing, not if parsing.
+--
+-- Every memoised parser must be annotated with a /unique/ key.
+-- (Parametrised parsers must use distinct keys for distinct inputs.)
+
+memoiseIfPrinting :: MemoKey -> Parser tok tok -> Parser tok tok
+memoiseIfPrinting = Parser.memoiseIfPrinting
+
+-- | Tries to print the parser, or returns 'empty', depending on the
+-- implementation. This function might not terminate.
+
+grammar :: Parser tok a -> Doc
+grammar = Parser.grammar
diff --git a/src/full/Agda/Syntax/Concrete/Pretty.hs b/src/full/Agda/Syntax/Concrete/Pretty.hs
index 6683057..92922a4 100644
--- a/src/full/Agda/Syntax/Concrete/Pretty.hs
+++ b/src/full/Agda/Syntax/Concrete/Pretty.hs
@@ -1,8 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
{-| Pretty printer for the concrete syntax.
-}
@@ -20,6 +18,9 @@ import Agda.Syntax.Fixity
import Agda.Syntax.Notation
import Agda.Syntax.Position
+import Agda.TypeChecking.Positivity.Occurrence
+
+import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Null
import Agda.Utils.Pretty
@@ -162,6 +163,7 @@ instance Pretty Expr where
, text "in" <+> pretty e
]
Paren _ e -> parens $ pretty e
+ IdiomBrackets _ e -> text "(|" <+> pretty e <+> text "|)"
As _ x e -> pretty x <> text "@" <> pretty e
Dot _ e -> text "." <> pretty e
Absurd _ -> text "()"
@@ -255,8 +257,9 @@ instance Pretty WhereClause where
pretty (AnyWhere [Module _ x [] ds]) | isNoName (unqualify x)
= vcat [ text "where", nest 2 (vcat $ map pretty ds) ]
pretty (AnyWhere ds) = vcat [ text "where", nest 2 (vcat $ map pretty ds) ]
- pretty (SomeWhere m ds) =
- vcat [ hsep [ text "module", pretty m, text "where" ]
+ pretty (SomeWhere m a ds) =
+ vcat [ hsep $ applyWhen (a == PrivateAccess UserWritten) (text "private" :)
+ [ text "module", pretty m, text "where" ]
, nest 2 (vcat $ map pretty ds)
]
@@ -300,13 +303,16 @@ instance Pretty Declaration where
]
Field inst x (Arg i e) ->
sep [ text "field"
- , nest 2 $ mkInst inst $
+ , nest 2 $ mkInst inst $ mkOverlap i $
prettyRelevance i $ prettyHiding i id $
pretty $ TypeSig (i {argInfoRelevance = Relevant}) x e
]
where
mkInst InstanceDef d = sep [ text "instance", nest 2 d ]
mkInst NotInstanceDef d = d
+
+ mkOverlap i d | argInfoOverlappable i = text "overlap" <+> d
+ | otherwise = d
FunClause lhs rhs wh _ ->
sep [ pretty lhs
, nest 2 $ pretty rhs
@@ -376,7 +382,7 @@ instance Pretty Declaration where
<+> text "=" <+> pretty p
Mutual _ ds -> namedBlock "mutual" ds
Abstract _ ds -> namedBlock "abstract" ds
- Private _ ds -> namedBlock "private" ds
+ Private _ _ ds -> namedBlock "private" ds
InstanceB _ ds -> namedBlock "instance" ds
Macro _ ds -> namedBlock "macro" ds
Postulate _ ds -> namedBlock "postulate" ds
@@ -424,8 +430,8 @@ instance Pretty OpenShortHand where
instance Pretty Pragma where
pretty (OptionsPragma _ opts) = fsep $ map text $ "OPTIONS" : opts
pretty (BuiltinPragma _ b x) = hsep [ text "BUILTIN", text b, pretty x ]
- pretty (RewritePragma _ x) =
- hsep [ text "REWRITE", pretty x ]
+ pretty (RewritePragma _ xs) =
+ hsep [ text "REWRITE", hsep $ map pretty xs ]
pretty (CompiledPragma _ x hs) =
hsep [ text "COMPILED", pretty x, text hs ]
pretty (CompiledExportPragma _ x hs) =
@@ -446,8 +452,6 @@ instance Pretty Pragma where
hsep $ [ text "COMPILED_DATA_UHC", pretty x] ++ map text (crd : crcs)
pretty (HaskellCodePragma _ s) =
vcat (text "HASKELL" : map text (lines s))
- pretty (NoSmashingPragma _ i) =
- hsep $ [text "NO_SMASHING", pretty i]
pretty (StaticPragma _ i) =
hsep $ [text "STATIC", pretty i]
pretty (InlinePragma _ i) =
@@ -468,6 +472,8 @@ instance Pretty Pragma where
pretty (CatchallPragma _) = text "CATCHALL"
pretty (DisplayPragma _ lhs rhs) = text "DISPLAY" <+> sep [ pretty lhs <+> text "=", nest 2 $ pretty rhs ]
pretty (NoPositivityCheckPragma _) = text "NO_POSITIVITY_CHECK"
+ pretty (PolarityPragma _ q occs) =
+ hsep (text "NO_POSITIVITY_CHECK" : pretty q : map pretty occs)
instance Pretty Fixity where
pretty (Fixity _ Unrelated _) = __IMPOSSIBLE__
@@ -478,6 +484,17 @@ instance Pretty Fixity where
RightAssoc -> "infixr"
NonAssoc -> "infix"
+instance Pretty Occurrence where
+ pretty Unused = text "_"
+ pretty Mixed = text "*"
+ pretty JustNeg = text "-"
+ pretty JustPos = text "+"
+ pretty StrictPos = text "++"
+
+ -- No syntax has been assigned to GuardPos.
+
+ pretty GuardPos = __IMPOSSIBLE__
+
instance Pretty GenPart where
pretty (IdPart x) = text x
pretty BindHole{} = underscore
@@ -488,20 +505,20 @@ instance Pretty Notation where
pretty = hcat . map pretty
instance Pretty Fixity' where
- pretty (Fixity' fix nota)
+ pretty (Fixity' fix nota _)
| nota == noNotation = 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!
-- Andreas 2010-09-24: and in record fields
- pretty a = -- pRelevance r $
- -- TODO guilhem: print colors
- prettyHiding (argInfo a) id $ pretty $ unArg a
+instance Pretty a => Pretty (Arg a) where
+ prettyPrec p (Arg ai e) = prettyHiding ai id $ prettyPrec p' e
+ where p' | getHiding ai == NotHidden = p
+ | otherwise = 0
instance Pretty e => Pretty (Named_ e) where
- pretty (Named Nothing e) = pretty e
- pretty (Named (Just s) e) = sep [ text (rawNameToString $ rangedThing s) <+> text "=", pretty e ]
+ prettyPrec p (Named Nothing e) = prettyPrec p e
+ prettyPrec p (Named (Just s) e) = mparens (p > 0) $ sep [ text (rawNameToString $ rangedThing s) <+> text "=", pretty e ]
instance Pretty [Pattern] where
pretty = fsep . map pretty
@@ -518,7 +535,7 @@ instance Pretty Pattern where
ParenP _ p -> parens $ pretty p
WildP _ -> underscore
AsP _ x p -> pretty x <> text "@" <> pretty p
- DotP _ p -> text "." <> pretty p
+ DotP _ _ p -> text "." <> pretty p
AbsurdP _ -> text "()"
LitP l -> pretty l
QuoteP _ -> text "quote"
diff --git a/src/full/Agda/Syntax/Fixity.hs b/src/full/Agda/Syntax/Fixity.hs
index d83fec0..dd65d28 100644
--- a/src/full/Agda/Syntax/Fixity.hs
+++ b/src/full/Agda/Syntax/Fixity.hs
@@ -1,9 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE PatternGuards #-}
{-| Definitions for fixity, precedence levels, and declared syntax.
-}
@@ -41,8 +37,14 @@ import Agda.Utils.Impossible
data Fixity' = Fixity'
{ theFixity :: !Fixity
, theNotation :: Notation
+ , theNameRange :: Range
+ -- ^ Range of the name in the fixity declaration
+ -- (used for correct highlighting, see issue #2140).
}
- deriving (Typeable, Show, Eq)
+ deriving (Typeable, Show)
+
+instance Eq Fixity' where
+ Fixity' f n _ == Fixity' f' n' _ = f == f' && n == n'
-- | Decorating something with @Fixity'@.
data ThingWithFixity x = ThingWithFixity x Fixity'
@@ -75,7 +77,7 @@ namesToNotation q n = NewNotation
, notation = if null syn then syntaxOf (unqualify q) else syn
, notaIsOperator = null syn
}
- where Fixity' f syn = A.nameFixity n
+ where Fixity' f syn _ = A.nameFixity n
-- | Replace 'noFixity' by 'defaultFixity'.
useDefaultFixity :: NewNotation -> NewNotation
@@ -114,7 +116,7 @@ syntaxOf (Name _ xs) = mkSyn 0 xs
mkSyn n (Id x : xs) = IdPart x : mkSyn n xs
noFixity' :: Fixity'
-noFixity' = Fixity' noFixity noNotation
+noFixity' = Fixity' noFixity noNotation noRange
-- | Merges 'NewNotation's that have the same precedence level and
-- notation, with two exceptions:
@@ -208,7 +210,11 @@ noSection n = NotationSection
-- | Precedence levels for operators.
-data PrecedenceLevel = Unrelated | Related !Integer
+data PrecedenceLevel
+ = Unrelated
+ -- ^ No fixity declared.
+ | Related !Integer
+ -- ^ Fixity level declared as the @Integer@.
deriving (Eq, Ord, Show, Typeable)
-- | Associativity.
@@ -218,11 +224,12 @@ data Associativity = NonAssoc | LeftAssoc | RightAssoc
-- | Fixity of operators.
-data Fixity =
- Fixity { fixityRange :: Range
- , fixityLevel :: !PrecedenceLevel
- , fixityAssoc :: !Associativity
- }
+data Fixity = Fixity
+ { fixityRange :: Range
+ -- ^ Range of the whole fixity declaration.
+ , fixityLevel :: !PrecedenceLevel
+ , fixityAssoc :: !Associativity
+ }
deriving (Typeable, Show)
instance Eq Fixity where
@@ -318,7 +325,7 @@ instance KillRange Fixity where
killRange f = f { fixityRange = noRange }
instance KillRange Fixity' where
- killRange (Fixity' f n) = killRange2 Fixity' f n
+ killRange (Fixity' f n r) = killRange3 Fixity' f n r
instance KillRange x => KillRange (ThingWithFixity x) where
killRange (ThingWithFixity c f) = ThingWithFixity (killRange c) f
@@ -345,7 +352,7 @@ _fixityLevel f r = f (fixityLevel r) <&> \x -> r { fixityLevel = x }
------------------------------------------------------------------------
instance NFData Fixity' where
- rnf (Fixity' _ a) = rnf a
+ rnf (Fixity' _ a _) = rnf a
-- | Ranges are not forced.
diff --git a/src/full/Agda/Syntax/IdiomBrackets.hs b/src/full/Agda/Syntax/IdiomBrackets.hs
new file mode 100644
index 0000000..4fc4121
--- /dev/null
+++ b/src/full/Agda/Syntax/IdiomBrackets.hs
@@ -0,0 +1,48 @@
+module Agda.Syntax.IdiomBrackets (parseIdiomBrackets) where
+
+import Control.Applicative
+import Control.Monad
+
+import Agda.Syntax.Common
+import Agda.Syntax.Position
+import Agda.Syntax.Concrete
+import Agda.Syntax.Concrete.Operators
+
+import Agda.Syntax.Scope.Monad
+import Agda.TypeChecking.Monad
+
+parseIdiomBrackets :: Range -> Expr -> ScopeM Expr
+parseIdiomBrackets r e = do
+ let qPure = QName $ Name noRange [Id "pure"]
+ qAp = QName $ Name noRange [Hole, Id "<*>", Hole]
+ ePure = App r (Ident qPure) . defaultNamedArg
+ eAp a b = App r (App r (Ident qAp) (defaultNamedArg a)) (defaultNamedArg b)
+ mapM_ ensureInScope [qPure, qAp]
+ case e of
+ RawApp _ es -> do
+ e : es <- appViewM =<< parseApplication es
+ return $ foldl eAp (ePure e) es
+ _ -> return $ ePure e
+
+appViewM :: Expr -> ScopeM [Expr]
+appViewM e =
+ case e of
+ App{} -> let AppView e' es = appView e in (e' :) <$> mapM onlyVisible es
+ OpApp _ op _ es -> (Ident op :) <$> mapM (ordinary <=< noPlaceholder <=< onlyVisible) es
+ _ -> return [e]
+ where
+ onlyVisible a
+ | defaultNamedArg () == (fmap (() <$) a) = return $ namedArg a
+ | otherwise = genericError $ "Only regular arguments are allowed in idiom brackets (no implicit or instance arguments)"
+ noPlaceholder Placeholder{} = genericError "Naked sections are not allowed in idiom brackets"
+ noPlaceholder (NoPlaceholder _ x) = return x
+
+ ordinary (Ordinary a) = return a
+ ordinary _ = genericError "Binding syntax is not allowed in idiom brackets"
+
+ensureInScope :: QName -> ScopeM ()
+ensureInScope q = do
+ r <- resolveName q
+ case r of
+ UnknownName -> genericError $ show q ++ " needs to be in scope to use idiom brackets (| ... |)"
+ _ -> return ()
diff --git a/src/full/Agda/Syntax/Info.hs b/src/full/Agda/Syntax/Info.hs
index 53f990f..abc766e 100644
--- a/src/full/Agda/Syntax/Info.hs
+++ b/src/full/Agda/Syntax/Info.hs
@@ -1,7 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-| An info object contains additional information about a piece of abstract
@@ -169,6 +167,10 @@ data MutualInfo = MutualInfo
}
deriving (Typeable, Show, Eq)
+-- | Default value for 'MutualInfo'.
+instance Null MutualInfo where
+ empty = MutualInfo TerminationCheck True noRange
+
instance HasRange MutualInfo where
getRange = mutualRange
@@ -203,7 +205,7 @@ patNoRange = PatRange noRange
-- | Constructor pattern info.
data ConPatInfo = ConPatInfo
- { patOrigin :: ConPOrigin
+ { patOrigin :: ConOrigin
-- ^ Does this pattern come form the eta-expansion of an implicit pattern?
--- Or from a user written constructor or record pattern?
, patInfo :: PatInfo
@@ -211,7 +213,7 @@ data ConPatInfo = ConPatInfo
deriving (Typeable, Eq)
instance Show ConPatInfo where
- show (ConPatInfo po i) = applyWhen (po == ConPImplicit) ("implicit " ++) $ show i
+ show (ConPatInfo po i) = applyWhen (po == ConOSystem) ("implicit " ++) $ show i
instance HasRange ConPatInfo where
getRange = getRange . patInfo
diff --git a/src/full/Agda/Syntax/Internal.hs b/src/full/Agda/Syntax/Internal.hs
index 50a78fc..a39c4fe 100644
--- a/src/full/Agda/Syntax/Internal.hs
+++ b/src/full/Agda/Syntax/Internal.hs
@@ -1,15 +1,8 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
#if __GLASGOW_HASKELL__ <= 708
{-# LANGUAGE OverlappingInstances #-}
#endif
@@ -25,12 +18,13 @@ import Prelude hiding (foldr, mapM, null)
import Control.Applicative hiding (empty)
import Control.Monad.Identity hiding (mapM)
+import Control.DeepSeq
import Data.Foldable ( Foldable, foldMap )
import Data.Function
import qualified Data.List as List
import Data.Maybe
-import Data.Monoid
+import Data.Semigroup (Semigroup, Monoid, (<>), mempty, mappend, Sum(..))
-- base-4.7 defines the Num instance for Sum
#if !(MIN_VERSION_base(4,7,0))
@@ -43,7 +37,7 @@ import Data.Typeable (Typeable)
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Literal
-import Agda.Syntax.Abstract (IsProjP(..))
+import Agda.Syntax.Concrete.Pretty (prettyHiding)
import Agda.Syntax.Abstract.Name
import Agda.Utils.Empty
@@ -62,7 +56,8 @@ import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Pointer
import Agda.Utils.Size
-import Agda.Utils.Pretty as P
+import qualified Agda.Utils.Pretty as P
+import Agda.Utils.Pretty hiding ((<>))
import Agda.Utils.Tuple
#include "undefined.h"
@@ -123,7 +118,7 @@ data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral
| Lam ArgInfo (Abs Term) -- ^ Terms are beta normal. Relevance is ignored
| Lit Literal
| Def QName Elims -- ^ @f es@, possibly a delta/iota-redex
- | Con ConHead Args -- ^ @c vs@
+ | Con ConHead ConInfo Args -- ^ @c vs@ or @record { fs = vs }@
| Pi (Dom Type) (Abs Type) -- ^ dependent or non-dependent function space
| Sort Sort
| Level Level
@@ -136,9 +131,13 @@ data Term = Var {-# UNPACK #-} !Int Elims -- ^ @x es@ neutral
-- ^ Explicit sharing
deriving (Typeable, Show)
+type ConInfo = ConOrigin
+
-- | Eliminations, subsuming applications and projections.
--
-data Elim' a = Apply (Arg a) | Proj QName -- ^ name of a record projection
+data Elim' a
+ = Apply (Arg a) -- ^ Application.
+ | Proj ProjOrigin QName -- ^ Projection. 'QName' is name of a record projection.
deriving (Typeable, Show, Functor, Foldable, Traversable)
type Elim = Elim' Term
@@ -295,17 +294,20 @@ data NotBlocked
-- | 'ReallyNotBlocked' is the unit.
-- 'MissingClauses' is dominant.
-- @'StuckOn'{}@ should be propagated, if tied, we take the left.
-instance Monoid NotBlocked where
- -- ReallyNotBlocked is neutral
- mempty = ReallyNotBlocked
- ReallyNotBlocked `mappend` b = b
+instance Semigroup NotBlocked where
+ ReallyNotBlocked <> b = b
-- MissingClauses is dominant (absorptive)
- b@MissingClauses `mappend` _ = b
- _ `mappend` b@MissingClauses = b
+ b@MissingClauses <> _ = b
+ _ <> b@MissingClauses = b
-- StuckOn is second strongest
- b@StuckOn{} `mappend` _ = b
- _ `mappend` b@StuckOn{} = b
- b `mappend` _ = b
+ b@StuckOn{} <> _ = b
+ _ <> b@StuckOn{} = b
+ b <> _ = b
+
+instance Monoid NotBlocked where
+ -- ReallyNotBlocked is neutral
+ mempty = ReallyNotBlocked
+ mappend = (<>)
-- | Something where a meta variable may block reduction.
data Blocked t
@@ -329,11 +331,14 @@ instance Applicative Blocked where
-- | @'Blocked' t@ without the @t@.
type Blocked_ = Blocked ()
+instance Semigroup Blocked_ where
+ b@Blocked{} <> _ = b
+ _ <> b@Blocked{} = b
+ NotBlocked x _ <> NotBlocked y _ = NotBlocked (x <> y) ()
+
instance Monoid Blocked_ where
mempty = notBlocked ()
- b@Blocked{} `mappend` _ = b
- _ `mappend` b@Blocked{} = b
- NotBlocked x _ `mappend` NotBlocked y _ = NotBlocked (x `mappend` y) ()
+ mappend = (<>)
-- See issues 1573 and 1674.
#if !MIN_VERSION_transformers(0,4,1)
@@ -379,12 +384,12 @@ stuckOn e r =
-- * Definitions
---------------------------------------------------------------------------
--- | A clause is a list of patterns and the clause body should @Bind@.
+-- | A clause is a list of patterns and the clause body.
--
-- The telescope contains the types of the pattern variables and the
-- de Bruijn indices say how to get from the order the variables occur in
-- the patterns to the order they occur in the telescope. The body
--- binds the variables in the order they appear in the patterns.
+-- binds the variables in the order they appear in the telescope.
--
-- @clauseTel ~ permute clausePerm (patternVars namedClausePats)@
--
@@ -395,37 +400,25 @@ stuckOn e r =
data Clause = Clause
{ clauseRange :: Range
, clauseTel :: Telescope
- -- ^ @Δ@: The types of the pattern variables.
+ -- ^ @Δ@: The types of the pattern variables in dependency order.
, namedClausePats :: [NamedArg DeBruijnPattern]
- -- ^ @let Γ = patternVars namedClausePats@
- , clauseBody :: ClauseBody
- -- ^ @λΓ.v@
+ -- ^ @Δ ⊢ ps@. The de Bruijn indices refer to @Δ@.
+ , clauseBody :: Maybe Term
+ -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an
+ -- absurd one.
, clauseType :: Maybe (Arg Type)
-- ^ @Δ ⊢ t@. The type of the rhs under @clauseTel@.
-- Used, e.g., by @TermCheck@.
-- Can be 'Irrelevant' if we encountered an irrelevant projection
-- pattern on the lhs.
, clauseCatchall :: Bool
+ -- ^ Clause has been labelled as CATCHALL.
}
deriving (Typeable, Show)
clausePats :: Clause -> [Arg DeBruijnPattern]
clausePats = map (fmap namedThing) . namedClausePats
-data ClauseBodyF a = Body a
- | Bind (Abs (ClauseBodyF a))
- | NoBody -- ^ for absurd clauses.
- deriving (Typeable, Show, Functor, Foldable, Traversable)
-
-type ClauseBody = ClauseBodyF Term
-
-imapClauseBody :: (Nat -> a -> b) -> ClauseBodyF a -> ClauseBodyF b
-imapClauseBody f b = go 0 b
- where
- go i (Body x) = Body (f i x)
- go _ NoBody = NoBody
- go !i (Bind b) = Bind $ go (i + 1) <$> b
-
instance HasRange Clause where
getRange = clauseRange
@@ -454,22 +447,30 @@ data Pattern' x
-- The subpatterns do not contain any projection copatterns.
| LitP Literal
-- ^ E.g. @5@, @"hello"@.
- | ProjP QName
+ | ProjP ProjOrigin QName
-- ^ Projection copattern. Can only appear by itself.
deriving (Typeable, Show, Functor, Foldable, Traversable)
type Pattern = Pattern' PatVarName
-- ^ The @PatVarName@ is a name suggestion.
+varP :: ArgName -> Pattern
+varP = VarP
+
-- | Type used when numbering pattern variables.
-type DeBruijnPattern = Pattern' (Int, PatVarName)
+data DBPatVar = DBPatVar
+ { dbPatVarName :: PatVarName
+ , dbPatVarIndex :: Int
+ } deriving (Typeable, Show)
-namedVarP :: PatVarName -> Named (Ranged PatVarName) Pattern
-namedVarP x = Named named $ VarP x
+type DeBruijnPattern = Pattern' DBPatVar
+
+namedVarP :: PatVarName -> Named_ Pattern
+namedVarP x = Named named $ varP x
where named = if isUnderscore x then Nothing else Just $ unranged x
-namedDBVarP :: Int -> PatVarName -> Named (Ranged PatVarName) DeBruijnPattern
-namedDBVarP m = (fmap . fmap) (m,) . namedVarP
+namedDBVarP :: Int -> PatVarName -> Named_ DeBruijnPattern
+namedDBVarP m = (fmap . fmap) (\x -> DBPatVar x m) . namedVarP
-- | The @ConPatternInfo@ states whether the constructor belongs to
-- a record type (@Just@) or data type (@Nothing@).
@@ -479,7 +480,7 @@ namedDBVarP m = (fmap . fmap) (m,) . namedVarP
-- The scope used for the type is given by any outer scope
-- plus the clause's telescope ('clauseTel').
data ConPatternInfo = ConPatternInfo
- { conPRecord :: Maybe ConPOrigin
+ { conPRecord :: Maybe ConOrigin
-- ^ @Nothing@ if data constructor.
-- @Just@ if record constructor.
, conPType :: Maybe (Arg Type)
@@ -495,6 +496,15 @@ data ConPatternInfo = ConPatternInfo
noConPatternInfo :: ConPatternInfo
noConPatternInfo = ConPatternInfo Nothing Nothing
+-- | Build partial 'ConPatternInfo' from 'ConInfo'
+toConPatternInfo :: ConInfo -> ConPatternInfo
+toConPatternInfo ConORec = ConPatternInfo (Just ConORec) Nothing
+toConPatternInfo _ = noConPatternInfo
+
+-- | Build 'ConInfo' from 'ConPatternInfo'.
+fromConPatternInfo :: ConPatternInfo -> ConInfo
+fromConPatternInfo = fromMaybe ConOSystem . conPRecord
+
-- | Extract pattern variables in left-to-right order.
-- A 'DotP' is also treated as variable (see docu for 'Clause').
patternVars :: Arg (Pattern' a) -> [Arg (Either a Term)]
@@ -505,8 +515,8 @@ patternVars (Arg i (LitP l) ) = []
patternVars (Arg i ProjP{} ) = []
-- | Does the pattern perform a match that could fail?
-properlyMatching :: Pattern' a -> Bool
-properlyMatching VarP{} = False
+properlyMatching :: DeBruijnPattern -> Bool
+properlyMatching (VarP x) = isAbsurdPatternName $ dbPatVarName x
properlyMatching DotP{} = False
properlyMatching LitP{} = True
properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record cons
@@ -514,8 +524,8 @@ properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record c
properlyMatching ProjP{} = True
instance IsProjP (Pattern' a) where
- isProjP (ProjP d) = Just d
- isProjP _ = Nothing
+ isProjP (ProjP o d) = Just (o, AmbQ [d])
+ isProjP _ = Nothing
-----------------------------------------------------------------------------
-- * Explicit substitutions
@@ -577,6 +587,11 @@ type PatternSubstitution = Substitution' DeBruijnPattern
infixr 4 :#
+instance Null (Substitution' a) where
+ empty = IdS
+ null IdS = True
+ null _ = False
+
---------------------------------------------------------------------------
-- * Views
@@ -635,7 +650,7 @@ ignoreSharingType (El s v) = El s (ignoreSharing v)
shared_ :: Term -> Term
shared_ v@Shared{} = v
shared_ v@(Var _ []) = v
-shared_ v@(Con _ []) = v -- Issue 1691: sharing (zero : Nat) destroys constructorForm
+shared_ v@(Con _ _ []) = v -- Issue 1691: sharing (zero : Nat) destroys constructorForm
shared_ v = Shared (newPtr v)
-- | Typically m would be TCM and f would be Blocked.
@@ -817,17 +832,23 @@ instance Suggest Name (Abs b) where
-- | Convert top-level postfix projections into prefix projections.
unSpine :: Term -> Term
-unSpine v =
+unSpine = unSpine' $ const True
+
+-- | Convert 'Proj' projection eliminations
+-- according to their 'ProjOrigin' into
+-- 'Def' projection applications.
+unSpine' :: (ProjOrigin -> Bool) -> Term -> Term
+unSpine' p v =
case hasElims v of
- Just (h, es) -> unSpine' h [] es
+ Just (h, es) -> loop h [] es
Nothing -> v
where
- unSpine' :: (Elims -> Term) -> Elims -> Elims -> Term
- unSpine' h res es =
+ loop :: (Elims -> Term) -> Elims -> Elims -> Term
+ loop h res es =
case es of
- [] -> v
- e@(Apply a) : es' -> unSpine' h (e : res) es'
- Proj f : es' -> unSpine' (Def f) [Apply (defaultArg v)] es'
+ [] -> v
+ Proj o f : es' | p o -> loop (Def f) [Apply (defaultArg v)] es'
+ e : es' -> loop h (e : res) es'
where v = h $ reverse res
-- | A view distinguishing the neutrals @Var@, @Def@, and @MetaV@ which
@@ -842,8 +863,8 @@ hasElims v =
Lit{} -> Nothing
-- Andreas, 2016-04-13, Issue 1932: We convert λ x → x .f into f
Lam _ (Abs _ v) -> case ignoreSharing v of
- Var 0 [Proj f] -> Just (Def f, [])
- _ -> Nothing
+ Var 0 [Proj _o f] -> Just (Def f, [])
+ _ -> Nothing
Lam{} -> Nothing
Pi{} -> Nothing
Sort{} -> Nothing
@@ -859,30 +880,30 @@ getElims v = maybe default id $ hasElims v
-}
-- | Drop 'Apply' constructor. (Unsafe!)
-argFromElim :: Elim -> Arg Term
+argFromElim :: Elim' a -> Arg a
argFromElim (Apply u) = u
argFromElim Proj{} = __IMPOSSIBLE__
-- | Drop 'Apply' constructor. (Safe)
-isApplyElim :: Elim -> Maybe (Arg Term)
+isApplyElim :: Elim' a -> Maybe (Arg a)
isApplyElim (Apply u) = Just u
isApplyElim Proj{} = Nothing
-- | Drop 'Apply' constructors. (Safe)
-allApplyElims :: Elims -> Maybe Args
+allApplyElims :: [Elim' a] -> Maybe [Arg a]
allApplyElims = mapM isApplyElim
-- | Split at first non-'Apply'
-splitApplyElims :: Elims -> (Args, Elims)
+splitApplyElims :: [Elim' a] -> ([Arg a], [Elim' a])
splitApplyElims (Apply u : es) = mapFst (u :) $ splitApplyElims es
splitApplyElims es = ([], es)
class IsProjElim e where
- isProjElim :: e -> Maybe QName
+ isProjElim :: e -> Maybe (ProjOrigin, QName)
instance IsProjElim Elim where
- isProjElim (Proj d) = Just d
- isProjElim Apply{} = Nothing
+ isProjElim (Proj o d) = Just (o, d)
+ isProjElim Apply{} = Nothing
-- | Discard @Proj f@ entries.
dropProjElims :: IsProjElim e => [e] -> [e]
@@ -893,23 +914,9 @@ argsFromElims :: Elims -> Args
argsFromElims = map argFromElim . dropProjElims
-- | Drop 'Proj' constructors. (Safe)
-allProjElims :: Elims -> Maybe [QName]
+allProjElims :: Elims -> Maybe [(ProjOrigin, QName)]
allProjElims = mapM isProjElim
-{- NOTE: Elim' already contains Arg.
-
--- | Commute functors 'Arg' and 'Elim\''.
-swapArgElim :: Arg (Elim' a) -> Elim' (Arg a)
-
-swapArgElim (Arg ai (Apply a)) = Apply (Arg ai a)
-swapArgElim (Arg ai (Proj d)) = Proj d
-
--- IMPOSSIBLE TO DEFINE
-swapElimArg :: Elim' (Arg a) -> Arg (Elim' a)
-swapElimArg (Apply (Arg ai a)) = Arg ai (Apply a)
-swapElimArg (Proj d) = defaultArg (Proj d)
--}
-
---------------------------------------------------------------------------
-- * Null instances.
---------------------------------------------------------------------------
@@ -919,11 +926,6 @@ instance Null (Tele a) where
null EmptyTel = True
null ExtendTel{} = False
-instance Null ClauseBody where
- empty = NoBody
- null NoBody = True
- null _ = False
-
-- | A 'null' clause is one with no patterns and no rhs.
-- Should not exist in practice.
instance Null Clause where
@@ -988,7 +990,7 @@ instance TermSize Term where
tsize v = case v of
Var _ vs -> 1 + tsize vs
Def _ vs -> 1 + tsize vs
- Con _ vs -> 1 + tsize vs
+ Con _ _ vs -> 1 + tsize vs
MetaV _ vs -> 1 + tsize vs
Level l -> tsize l
Lam _ f -> 1 + tsize f
@@ -1038,7 +1040,7 @@ instance KillRange Term where
killRange v = case v of
Var i vs -> killRange1 (Var i) vs
Def c vs -> killRange2 Def c vs
- Con c vs -> killRange2 Con c vs
+ Con c ci vs -> killRange3 Con c ci vs
MetaV m vs -> killRange1 (MetaV m) vs
Lam i f -> killRange2 Lam i f
Lit l -> killRange1 Lit l
@@ -1083,6 +1085,9 @@ instance KillRange Substitution where
instance KillRange ConPatternInfo where
killRange (ConPatternInfo mr mt) = killRange1 (ConPatternInfo mr) mt
+instance KillRange DBPatVar where
+ killRange (DBPatVar x i) = killRange2 DBPatVar x i
+
instance KillRange a => KillRange (Pattern' a) where
killRange p =
case p of
@@ -1090,14 +1095,11 @@ instance KillRange a => KillRange (Pattern' a) where
DotP v -> killRange1 DotP v
ConP con info ps -> killRange3 ConP con info ps
LitP l -> killRange1 LitP l
- ProjP q -> killRange1 ProjP q
+ ProjP o q -> killRange1 (ProjP o) q
instance KillRange Clause where
killRange (Clause r tel ps body t catchall) = killRange6 Clause r tel ps body t catchall
-instance KillRange a => KillRange (ClauseBodyF a) where
- killRange = fmap killRange
-
instance KillRange a => KillRange (Tele a) where
killRange = fmap killRange
@@ -1126,48 +1128,65 @@ instanceUniverseBiT' [] [t| ([Term], Term) |]
-- * Simple pretty printing
-----------------------------------------------------------------------------
-instance Pretty Substitution where
- prettyPrec p rho = brackets $ pr rho
+instance Pretty a => Pretty (Substitution' a) where
+ prettyPrec p rho = pr p rho
where
- pr rho = case rho of
+ pr p rho = case rho of
IdS -> text "idS"
- EmptyS -> text "ε"
- t :# rho -> prettyPrec 1 t <+> text ":#" <+> pr rho
- Strengthen _ rho -> text "↓" <+> pr rho
- Wk n rho -> text ("↑" ++ show n) <+> pr rho
- Lift n rho -> text ("⇑" ++ show n) <+> pr rho
+ EmptyS -> text "emptyS"
+ t :# rho -> mparens (p > 2) $ sep [ pr 2 rho P.<> text ",", prettyPrec 3 t ]
+ Strengthen _ rho -> mparens (p > 9) $ text "strS" <+> pr 10 rho
+ Wk n rho -> mparens (p > 9) $ text ("wkS " ++ show n) <+> pr 10 rho
+ Lift n rho -> mparens (p > 9) $ text ("liftS " ++ show n) <+> pr 10 rho
instance Pretty Term where
prettyPrec p v =
case ignoreSharing v of
Var x els -> text ("@" ++ show x) `pApp` els
- Lam _ b ->
+ Lam ai b ->
mparens (p > 0) $
- sep [ text ("λ " ++ show (absName b) ++ " ->")
+ sep [ text "λ" <+> prettyHiding ai id (text . show . absName $ b) <+> text "->"
, nest 2 $ pretty (unAbs b) ]
Lit l -> pretty l
Def q els -> text (show q) `pApp` els
- Con c vs -> text (show $ conName c) `pApp` map Apply vs
+ Con c ci vs -> text (show $ conName c) `pApp` map Apply vs
Pi a (NoAbs _ b) -> mparens (p > 0) $
sep [ prettyPrec 1 (unDom a) <+> text "->"
, nest 2 $ pretty b ]
Pi a b -> mparens (p > 0) $
sep [ pDom (domInfo a) (text (absName b) <+> text ":" <+> pretty (unDom a)) <+> text "->"
, nest 2 $ pretty (unAbs b) ]
- Sort s -> pretty s
- Level l -> pretty l
+ Sort s -> prettyPrec p s
+ Level l -> prettyPrec p l
MetaV x els -> pretty x `pApp` els
- DontCare v -> pretty v
+ DontCare v -> prettyPrec p v
Shared{} -> __IMPOSSIBLE__
where
pApp d els = mparens (not (null els) && p > 9) $
- d <+> fsep (map (prettyPrec 10) els)
+ sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]
+
+pDom :: LensHiding a => a -> Doc -> Doc
+pDom i =
+ case getHiding i of
+ NotHidden -> parens
+ Hidden -> braces
+ Instance -> braces . braces
+
+instance Pretty Clause where
+ pretty Clause{clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t} =
+ sep [ pretty tel <+> text "|-"
+ , nest 2 $ sep [ fsep (map (prettyPrec 10) ps) <+> text "="
+ , nest 2 $ pBody b t ] ]
+ where
+ pBody Nothing _ = text "(absurd)"
+ pBody (Just b) Nothing = pretty b
+ pBody (Just b) (Just t) = sep [ pretty b <+> text ":", nest 2 $ pretty t ]
- pDom i =
- case getHiding i of
- NotHidden -> parens
- Hidden -> braces
- Instance -> braces . braces
+instance Pretty a => Pretty (Tele (Dom a)) where
+ pretty tel = fsep [ pDom a (text x <+> text ":" <+> pretty (unDom a)) | (x, a) <- telToList tel ]
+ where
+ telToList EmptyTel = []
+ telToList (ExtendTel a tel) = (absName tel, a) : telToList (unAbs tel)
instance Pretty Level where
prettyPrec p (Max as) =
@@ -1211,26 +1230,71 @@ instance Pretty Type where
prettyPrec p (El _ a) = prettyPrec p a
instance Pretty Elim where
- prettyPrec p (Apply v) = prettyPrec p v
- prettyPrec _ (Proj x) = text ("." ++ show x)
+ prettyPrec p (Apply v) = prettyPrec p v
+ prettyPrec _ (Proj _o x) = text ("." ++ show x)
+
+instance Pretty DBPatVar where
+ prettyPrec _ x = text $ patVarNameToString (dbPatVarName x) ++ "@" ++ show (dbPatVarIndex x)
instance Pretty a => Pretty (Pattern' a) where
prettyPrec n (VarP x) = prettyPrec n x
prettyPrec _ (DotP t) = text "." P.<> prettyPrec 10 t
- prettyPrec n (ConP c i ps) = mparens (n > 0) $
- text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)
+ prettyPrec n (ConP c i nps)= mparens (n > 0) $
+ text (show $ conName c) <+> fsep (map pretty ps)
+ where ps = map (fmap namedThing) nps
-- -- Version with printing record type:
-- prettyPrec _ (ConP c i ps) = (if b then braces else parens) $ prTy $
-- text (show $ conName c) <+> fsep (map (pretty . namedArg) ps)
-- where
- -- b = maybe False (== ConPImplicit) $ conPRecord i
+ -- b = maybe False (== ConOSystem) $ conPRecord i
-- prTy d = caseMaybe (conPType i) d $ \ t -> d <+> text ":" <+> pretty t
prettyPrec _ (LitP l) = text (show l)
- prettyPrec _ (ProjP q) = text (show q)
-
-instance Pretty a => Pretty (ClauseBodyF a) where
- pretty b = case b of
- Bind (NoAbs _ b) -> pretty b
- Bind (Abs x b) -> text (show x ++ ".") <+> pretty b
- Body t -> pretty t
- NoBody -> text "()"
+ prettyPrec _ (ProjP _o q) = text ("." ++ show q)
+
+-----------------------------------------------------------------------------
+-- * NFData instances
+-----------------------------------------------------------------------------
+
+-- Note: only strict in the shape of the terms.
+
+instance NFData Term where
+ rnf v = case v of
+ Var _ es -> rnf es
+ Lam _ b -> rnf (unAbs b)
+ Lit l -> rnf l
+ Def _ es -> rnf es
+ Con _ _ vs -> rnf vs
+ Pi a b -> rnf (unDom a, unAbs b)
+ Sort s -> rnf s
+ Level l -> rnf l
+ MetaV _ es -> rnf es
+ DontCare v -> rnf v
+ Shared{} -> ()
+
+instance NFData Type where
+ rnf (El s v) = rnf (s, v)
+
+instance NFData Sort where
+ rnf s = case s of
+ Type l -> rnf l
+ Prop -> ()
+ Inf -> ()
+ SizeUniv -> ()
+ DLub a b -> rnf (a, unAbs b)
+
+instance NFData Level where
+ rnf (Max as) = rnf as
+
+instance NFData PlusLevel where
+ rnf (ClosedLevel n) = rnf n
+ rnf (Plus n l) = rnf (n, l)
+
+instance NFData LevelAtom where
+ rnf (MetaLevel _ es) = rnf es
+ rnf (BlockedLevel _ v) = rnf v
+ rnf (NeutralLevel _ v) = rnf v
+ rnf (UnreducedLevel v) = rnf v
+
+instance NFData a => NFData (Elim' a) where
+ rnf (Apply x) = rnf x
+ rnf Proj{} = ()
diff --git a/src/full/Agda/Syntax/Internal/Defs.hs b/src/full/Agda/Syntax/Internal/Defs.hs
index 3faaec8..e66626d 100644
--- a/src/full/Agda/Syntax/Internal/Defs.hs
+++ b/src/full/Agda/Syntax/Internal/Defs.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-- | Extract used definitions from terms.
module Agda.Syntax.Internal.Defs where
@@ -45,16 +44,10 @@ class GetDefs a where
instance GetDefs Clause where
getDefs = getDefs . clauseBody
-instance GetDefs ClauseBody where
- getDefs b = case b of
- Body v -> getDefs v
- Bind b -> getDefs b
- NoBody -> return ()
-
instance GetDefs Term where
getDefs v = case v of
Def d vs -> doDef d >> getDefs vs
- Con c vs -> getDefs vs
+ Con _ _ vs -> getDefs vs
Lit l -> return ()
Var i vs -> getDefs vs
Lam _ v -> getDefs v
diff --git a/src/full/Agda/Syntax/Internal/Generic.hs b/src/full/Agda/Syntax/Internal/Generic.hs
index 6aed85a..57f7f15 100644
--- a/src/full/Agda/Syntax/Internal/Generic.hs
+++ b/src/full/Agda/Syntax/Internal/Generic.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleInstances #-}
module Agda.Syntax.Internal.Generic where
@@ -100,13 +99,18 @@ instance TermLike a => TermLike (Ptr a) where
traverseTermM f = traverse (traverseTermM f)
foldTerm f = foldMap (foldTerm f)
+instance TermLike a => TermLike (Blocked a) where
+ traverseTerm f = fmap (traverseTerm f)
+ traverseTermM f = traverse (traverseTermM f)
+ foldTerm f = foldMap (foldTerm f)
+
-- * Real terms
instance TermLike Term where
traverseTerm f t = case t of
Var i xs -> f $ Var i $ traverseTerm f xs
Def c xs -> f $ Def c $ traverseTerm f xs
- Con c xs -> f $ Con c $ traverseTerm f xs
+ Con c ci xs -> f $ Con c ci $ traverseTerm f xs
Lam h b -> f $ Lam h $ traverseTerm f b
Pi a b -> f $ uncurry Pi $ traverseTerm f (a, b)
MetaV m xs -> f $ MetaV m $ traverseTerm f xs
@@ -119,7 +123,7 @@ instance TermLike Term where
traverseTermM f t = case t of
Var i xs -> f =<< Var i <$> traverseTermM f xs
Def c xs -> f =<< Def c <$> traverseTermM f xs
- Con c xs -> f =<< Con c <$> traverseTermM f xs
+ Con c ci xs -> f =<< Con c ci <$> traverseTermM f xs
Lam h b -> f =<< Lam h <$> traverseTermM f b
Pi a b -> f =<< uncurry Pi <$> traverseTermM f (a, b)
MetaV m xs -> f =<< MetaV m <$> traverseTermM f xs
@@ -132,7 +136,7 @@ instance TermLike Term where
foldTerm f t = f t `mappend` case t of
Var i xs -> foldTerm f xs
Def c xs -> foldTerm f xs
- Con c xs -> foldTerm f xs
+ Con c ci xs -> foldTerm f xs
Lam h b -> foldTerm f b
Pi a b -> foldTerm f (a, b)
MetaV m xs -> foldTerm f xs
diff --git a/src/full/Agda/Syntax/Internal/Names.hs b/src/full/Agda/Syntax/Internal/Names.hs
index 7bac092..eb9d023 100644
--- a/src/full/Agda/Syntax/Internal/Names.hs
+++ b/src/full/Agda/Syntax/Internal/Names.hs
@@ -19,6 +19,7 @@ import qualified Agda.Syntax.Abstract as A
import Agda.TypeChecking.Monad.Base
import Agda.TypeChecking.CompiledClause
+import Agda.Utils.Functor
import Agda.Utils.Impossible
#include "undefined.h"
@@ -36,7 +37,6 @@ instance NamesIn a => NamesIn (Named n a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (Abs a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (WithArity a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (Tele a) where namesIn = namesInFoldable
-instance NamesIn a => NamesIn (ClauseBodyF a) where namesIn = namesInFoldable
instance NamesIn a => NamesIn (C.FieldAssignment' a) where namesIn = namesInFoldable
@@ -55,9 +55,10 @@ instance NamesIn Defn where
Function { funClauses = cl, funCompiled = cc } -> namesIn (cl, cc)
Datatype { dataClause = cl, dataCons = cs, dataSort = s } -> namesIn (cl, cs, s)
Record { recClause = cl, recConHead = c, recFields = fs } -> namesIn (cl, c, fs)
- -- Don't need recTel or recConType since those will be reachable from the constructor
+ -- Don't need recTel since those will be reachable from the constructor
Constructor { conSrcCon = c, conData = d } -> namesIn (c, d)
Primitive { primClauses = cl, primCompiled = cc } -> namesIn (cl, cc)
+ AbstractDefn -> __IMPOSSIBLE__
instance NamesIn Clause where
namesIn Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =
@@ -78,7 +79,7 @@ instance NamesIn (Pattern' a) where
LitP l -> namesIn l
DotP v -> namesIn v
ConP c _ args -> namesIn (c, args)
- ProjP f -> namesIn f
+ ProjP _ f -> namesIn f
instance NamesIn a => NamesIn (Type' a) where
namesIn (El s t) = namesIn (s, t)
@@ -97,7 +98,7 @@ instance NamesIn Term where
Lam _ b -> namesIn b
Lit l -> namesIn l
Def f args -> namesIn (f, args)
- Con c args -> namesIn (c, args)
+ Con c _ args -> namesIn (c, args)
Pi a b -> namesIn (a, b)
Sort s -> namesIn s
Level l -> namesIn l
@@ -131,7 +132,7 @@ instance NamesIn Literal where
instance NamesIn a => NamesIn (Elim' a) where
namesIn (Apply arg) = namesIn arg
- namesIn (Proj f) = namesIn f
+ namesIn (Proj _ f) = namesIn f
instance NamesIn QName where namesIn x = Set.singleton x
instance NamesIn ConHead where namesIn h = namesIn (conName h)
@@ -139,13 +140,15 @@ instance NamesIn ConHead where namesIn h = namesIn (conName h)
instance NamesIn a => NamesIn (Open a) where
namesIn = namesIn . openThing
+instance NamesIn a => NamesIn (Local a) where namesIn = namesIn . dget
+
instance NamesIn DisplayForm where
namesIn (Display _ ps v) = namesIn (ps, v)
instance NamesIn DisplayTerm where
namesIn v = case v of
- DWithApp v us vs -> namesIn (v, us, vs)
- DCon c vs -> namesIn (c, vs)
+ DWithApp v us es -> namesIn (v, us, es)
+ DCon c _ vs -> namesIn (c, vs)
DDef f es -> namesIn (f, es)
DDot v -> namesIn v
DTerm v -> namesIn v
@@ -160,6 +163,7 @@ instance NamesIn (A.Pattern' a) where
namesIn p = case p of
A.VarP{} -> Set.empty
A.ConP _ c args -> namesIn (c, args)
+ A.ProjP _ _ d -> namesIn d
A.DefP _ f args -> namesIn (f, args)
A.WildP{} -> Set.empty
A.AsP _ _ p -> namesIn p
diff --git a/src/full/Agda/Syntax/Internal/Pattern.hs b/src/full/Agda/Syntax/Internal/Pattern.hs
index b8a3526..40b7234 100644
--- a/src/full/Agda/Syntax/Internal/Pattern.hs
+++ b/src/full/Agda/Syntax/Internal/Pattern.hs
@@ -1,9 +1,4 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-} -- because of func. deps.
#if __GLASGOW_HASKELL__ <= 708
@@ -24,6 +19,7 @@ import Agda.Syntax.Abstract (IsProjP(..))
import Agda.Syntax.Internal
import qualified Agda.Syntax.Internal as I
+import Agda.Utils.Empty
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Permutation
@@ -62,7 +58,7 @@ instance IsProjP p => FunArity [p] where
-- | Get the number of initial 'Apply' patterns in a clause.
instance FunArity Clause where
- funArity = funArity . clausePats
+ funArity = funArity . namedClausePats
-- | Get the number of common initial 'Apply' patterns in a list of clauses.
#if __GLASGOW_HASKELL__ >= 710
@@ -95,20 +91,20 @@ instance LabelPatVars a b i => LabelPatVars [a] [b] i where
labelPatVars = traverse labelPatVars
unlabelPatVars = fmap unlabelPatVars
-instance LabelPatVars (Pattern' x) (Pattern' (i,x)) i where
+instance LabelPatVars Pattern DeBruijnPattern Int where
labelPatVars p =
case p of
- VarP x -> VarP . (,x) <$> next
+ VarP x -> do i <- next
+ return $ VarP (DBPatVar x i)
DotP t -> DotP t <$ next
ConP c mt ps -> ConP c mt <$> labelPatVars ps
LitP l -> return $ LitP l
- ProjP q -> return $ ProjP q
+ ProjP o q -> return $ ProjP o q
where next = do (x:xs) <- get; put xs; return x
- unlabelPatVars = fmap snd
+ unlabelPatVars = fmap dbPatVarName
-- | Augment pattern variables with their de Bruijn index.
-{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [NamedArg (Pattern' (Int, x))] #-}
-{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg Pattern] -> [NamedArg DeBruijnPattern] #-}
+{-# SPECIALIZE numberPatVars :: Int -> Permutation -> [NamedArg Pattern] -> [NamedArg DeBruijnPattern] #-}
--
-- Example:
-- @
@@ -123,38 +119,58 @@ instance LabelPatVars (Pattern' x) (Pattern' (i,x)) i where
-- dBpats = 3 .(suc 2) (cons 2 1 0 )
-- @
--
-numberPatVars :: LabelPatVars a b Int => Permutation -> a -> b
-numberPatVars perm ps = evalState (labelPatVars ps) $
- permPicks $ flipP $ invertP __IMPOSSIBLE__ perm
+numberPatVars :: LabelPatVars a b Int => Int -> Permutation -> a -> b
+numberPatVars err perm ps = evalState (labelPatVars ps) $
+ permPicks $ flipP $ invertP err perm
unnumberPatVars :: LabelPatVars a b i => b -> a
unnumberPatVars = unlabelPatVars
-dbPatPerm :: [NamedArg DeBruijnPattern] -> Permutation
-dbPatPerm ps = Perm (size ixs) picks
+dbPatPerm :: [NamedArg DeBruijnPattern] -> Maybe Permutation
+dbPatPerm = dbPatPerm' True
+
+-- | Computes the permutation from the clause telescope
+-- to the pattern variables.
+--
+-- Use as @fromMaybe __IMPOSSIBLE__ . dbPatPerm@ to crash
+-- in a controlled way if a de Bruijn index is out of scope here.
+--
+-- The first argument controls whether dot patterns counts as variables or
+-- not.
+dbPatPerm' :: Bool -> [NamedArg DeBruijnPattern] -> Maybe Permutation
+dbPatPerm' countDots ps = Perm (size ixs) <$> picks
where
ixs = concatMap (getIndices . namedThing . unArg) ps
n = size $ catMaybes ixs
- picks = for (downFrom n) $ \i ->
- fromMaybe __IMPOSSIBLE__ $ findIndex (Just i ==) ixs
+ picks = forM (downFrom n) $ \ i -> findIndex (Just i ==) ixs
getIndices :: DeBruijnPattern -> [Maybe Int]
- getIndices (VarP (i,_)) = [Just i]
+ getIndices (VarP x) = [Just $ dbPatVarIndex x]
getIndices (ConP c _ ps) = concatMap (getIndices . namedThing . unArg) ps
- getIndices (DotP _) = [Nothing]
+ getIndices (DotP _) = [Nothing | countDots]
getIndices (LitP _) = []
- getIndices (ProjP _) = []
+ getIndices ProjP{} = []
-clausePerm :: Clause -> Permutation
+
+-- | Computes the permutation from the clause telescope
+-- to the pattern variables.
+--
+-- Use as @fromMaybe __IMPOSSIBLE__ . clausePerm@ to crash
+-- in a controlled way if a de Bruijn index is out of scope here.
+clausePerm :: Clause -> Maybe Permutation
clausePerm = dbPatPerm . namedClausePats
+-- | Turn a pattern into a term.
+-- Projection patterns are turned into projection eliminations,
+-- other patterns into apply elimination.
patternToElim :: Arg DeBruijnPattern -> Elim
-patternToElim (Arg ai (VarP (i, _))) = Apply $ Arg ai $ var i
-patternToElim (Arg ai (ConP c _ ps)) = Apply $ Arg ai $ Con c $
+patternToElim (Arg ai (VarP x)) = Apply $ Arg ai $ var $ dbPatVarIndex x
+patternToElim (Arg ai (ConP c cpi ps)) = Apply $ Arg ai $ Con c ci $
map (argFromElim . patternToElim . fmap namedThing) ps
+ where ci = fromConPatternInfo cpi
patternToElim (Arg ai (DotP t) ) = Apply $ Arg ai t
patternToElim (Arg ai (LitP l) ) = Apply $ Arg ai $ Lit l
-patternToElim (Arg ai (ProjP dest) ) = Proj $ dest
+patternToElim (Arg ai (ProjP o dest)) = Proj o dest
patternsToElims :: [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims ps = map build ps
@@ -165,23 +181,19 @@ patternsToElims ps = map build ps
patternToTerm :: DeBruijnPattern -> Term
patternToTerm p = case patternToElim (defaultArg p) of
Apply x -> unArg x
- Proj f -> __IMPOSSIBLE__
-
--- patternsToElims :: Permutation -> [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 :: 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
+ Proj{} -> __IMPOSSIBLE__
+
+class MapNamedArg f where
+ mapNamedArg :: (NamedArg a -> NamedArg b) -> NamedArg (f a) -> NamedArg (f b)
+
+instance MapNamedArg Pattern' where
+ mapNamedArg f np =
+ case namedArg np of
+ VarP x -> map2 VarP $ f $ map2 (const x) np
+ DotP t -> map2 (const $ DotP t) np -- just Haskell type conversion
+ LitP l -> map2 (const $ LitP l) np -- ditto
+ ProjP o q -> map2 (const $ ProjP o q) np -- ditto
+ ConP c i ps -> map2 (const $ ConP c i $ map (mapNamedArg f) ps) np
+ where
+ map2 :: (a -> b) -> NamedArg a -> NamedArg b
+ map2 = fmap . fmap
diff --git a/src/full/Agda/Syntax/Internal/SanityCheck.hs b/src/full/Agda/Syntax/Internal/SanityCheck.hs
new file mode 100644
index 0000000..6a5dd68
--- /dev/null
+++ b/src/full/Agda/Syntax/Internal/SanityCheck.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE CPP #-}
+-- | Sanity checking for internal syntax. Mostly checking variable scoping.
+module Agda.Syntax.Internal.SanityCheck where
+
+import Control.Monad
+import qualified Data.IntSet as Set
+
+import Text.PrettyPrint (empty)
+
+import Agda.Syntax.Internal
+import Agda.TypeChecking.Free
+import Agda.TypeChecking.Monad
+import Agda.TypeChecking.Substitute
+
+import Agda.Utils.Pretty
+import Agda.Utils.Size
+import Agda.Utils.Impossible
+
+#include "undefined.h"
+
+sanityCheckVars :: (Pretty a, FreeVS a) => Telescope -> a -> TCM ()
+sanityCheckVars tel v =
+ case filter bad (Set.toList $ allFreeVars v) of
+ [] -> return ()
+ xs -> do
+ reportSDoc "impossible" 1 . return $
+ sep [ hang (text "Sanity check failed for") 2
+ (hang (pretty tel <+> text "|-") 2 (pretty v))
+ , text $ "out of scope: " ++ show xs ]
+ __IMPOSSIBLE__
+ where
+ n = size tel
+ bad x = x < 0 || x >= n
+
+-- | Check that @Γ ⊢ ρ : Δ@.
+sanityCheckSubst :: (Pretty a, FreeVS a) => Telescope -> Substitution' a -> Telescope -> TCM ()
+sanityCheckSubst gamma rho delta = go gamma rho delta
+ where
+ go gamma rho delta =
+ case rho of
+ IdS -> unless (size gamma == size delta) $ err $ text "idS:" <+> hang (pretty gamma <+> text "/=") 2 (pretty delta)
+ EmptyS -> unless (size delta == 0) $ err $ text "emptyS:" <+> pretty delta <+> text "is not empty"
+ v :# rho -> do
+ unless (size delta > 0) $ err $ text "consS: empty target"
+ sanityCheckVars gamma v
+ sanityCheckSubst gamma rho (dropLast delta)
+ Strengthen _ rho -> do
+ unless (size delta > 0) $ err $ text "strS: empty target"
+ sanityCheckSubst gamma rho (dropLast delta)
+ Wk n rho -> do
+ unless (size gamma >= n) $ err $ text "wkS:" <+> sep [ text "|" <> pretty gamma <> text "|"
+ , text $ "< " ++ show n ]
+ sanityCheckSubst (dropLastN n gamma) rho delta
+ Lift n rho -> do
+ unless (size gamma >= n) $ err $ text "liftS: source" <+> sep [ text "|" <> pretty gamma <> text "|"
+ , text $ "< " ++ show n ]
+ unless (size delta >= n) $ err $ text "liftS: target" <+> sep [ text "|" <> pretty delta <> text "|"
+ , text $ "< " ++ show n ]
+ sanityCheckSubst (dropLastN n gamma) rho (dropLastN n delta)
+
+ dropLast = telFromList . init . telToList
+ dropLastN n = telFromList . reverse . drop n . reverse . telToList
+
+ err reason = do
+ reportSDoc "impossible" 1 . return $
+ sep [ hang (text "Sanity check failed for") 2 $
+ hang (pretty gamma <+> text "|-") 2 $
+ hang (pretty rho <+> text ":") 2 $
+ pretty delta
+ , reason ]
+ __IMPOSSIBLE__
+
diff --git a/src/full/Agda/Syntax/Literal.hs b/src/full/Agda/Syntax/Literal.hs
index 0733004..ee1359c 100644
--- a/src/full/Agda/Syntax/Literal.hs
+++ b/src/full/Agda/Syntax/Literal.hs
@@ -5,6 +5,9 @@ module Agda.Syntax.Literal where
import Control.DeepSeq
import Data.Char
import Data.Typeable (Typeable)
+
+import Numeric.IEEE ( IEEE(identicalIEEE) )
+
import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Abstract.Name
@@ -53,7 +56,10 @@ showChar' c
instance Eq Literal where
LitNat _ n == LitNat _ m = n == m
- LitFloat _ x == LitFloat _ y = x == y
+ -- ASR (2016-09-29). We use bitwise equality for comparing Double
+ -- because Haskell's Eq, which equates 0.0 and -0.0, allows to prove
+ -- a contradiction (see Issue #2169).
+ LitFloat _ x == LitFloat _ y = identicalIEEE x y || (isNaN x && isNaN y)
LitString _ s == LitString _ t = s == t
LitChar _ c == LitChar _ d = c == d
LitQName _ x == LitQName _ y = x == y
@@ -62,7 +68,7 @@ instance Eq Literal where
instance Ord Literal where
LitNat _ n `compare` LitNat _ m = n `compare` m
- LitFloat _ x `compare` LitFloat _ y = x `compare` y
+ LitFloat _ x `compare` LitFloat _ y = compareFloat x y
LitString _ s `compare` LitString _ t = s `compare` t
LitChar _ c `compare` LitChar _ d = c `compare` d
LitQName _ x `compare` LitQName _ y = x `compare` y
@@ -80,6 +86,23 @@ instance Ord Literal where
-- compare LitMeta{} _ = LT
-- compare _ LitMeta{} = GT
+-- NOTE: This is not the same ordering as primFloatNumericalEquality!
+-- This ordering must be a total order of all allowed float values,
+-- while primFloatNumericalEquality is only a preorder
+compareFloat :: Double -> Double -> Ordering
+compareFloat x y
+ | identicalIEEE x y = EQ
+ | isNegInf x = LT
+ | isNegInf y = GT
+ | isNaN x && isNaN y = EQ
+ | isNaN x = LT
+ | isNaN y = GT
+ | isNegativeZero x && x == y = LT
+ | isNegativeZero y && x == y = GT
+ | otherwise = compare x y
+ where
+ isNegInf z = z < 0 && isInfinite z
+
instance HasRange Literal where
getRange (LitNat r _) = r
getRange (LitFloat r _) = r
diff --git a/src/full/Agda/Syntax/Parser.hs b/src/full/Agda/Syntax/Parser.hs
index dc917f9..2e1e7bb 100644
--- a/src/full/Agda/Syntax/Parser.hs
+++ b/src/full/Agda/Syntax/Parser.hs
@@ -1,10 +1,12 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Agda.Syntax.Parser
( -- * Types
Parser
-- * Parse functions
, Agda.Syntax.Parser.parse
- , Agda.Syntax.Parser.parseLiterate
, Agda.Syntax.Parser.parsePosString
, parseFile'
-- * Parsers
@@ -15,34 +17,77 @@ module Agda.Syntax.Parser
, tokensParser
-- * Parse errors
, ParseError(..)
+ , ParseWarning(..)
+ , PM(..)
+ , runPMIO
) where
+import Control.Arrow (second)
import Control.Exception
+import Control.Monad ((>=>), forM_)
+import Control.Monad.State
+import Control.Monad.Reader
+import Control.Monad.Writer hiding ((<>))
import Data.List
+import Data.Typeable ( Typeable )
import Agda.Syntax.Position
import Agda.Syntax.Parser.Monad as M hiding (Parser, parseFlags)
import qualified Agda.Syntax.Parser.Monad as M
import qualified Agda.Syntax.Parser.Parser as P
import Agda.Syntax.Parser.Lexer
+import Agda.Syntax.Parser.Literate
import Agda.Syntax.Concrete
+import Agda.Syntax.Concrete.Definitions
import Agda.Syntax.Parser.Tokens
+import Agda.Utils.Except
+ ( Error(strMsg)
+ , ExceptT
+ , MonadError(catchError, throwError)
+ , runExceptT
+ )
import Agda.Utils.FileName
+import qualified Agda.Utils.Maybe.Strict as Strict
+import Agda.Utils.Pretty
+
+
+
+
+#if __GLASGOW_HASKELL__ <= 708
+import Control.Applicative ((<$>), Applicative)
+#endif
+
+#include "undefined.h"
+import Agda.Utils.Impossible
------------------------------------------------------------------------
-- Wrapping parse results
-wrap :: ParseResult a -> a
-wrap (ParseOk _ x) = x
-wrap (ParseFailed err) = throw err
+wrap :: ParseResult a -> PM a
+wrap (ParseOk _ x) = return x
+wrap (ParseFailed err) = throwError err
+
+wrapIOM :: (MonadError e m, MonadIO m) => (IOError -> e) -> IO a -> m a
+wrapIOM f m = do
+ a <- liftIO$ (Right <$> m) `catch` (\err -> return$ Left (err :: IOError))
+ case a of
+ Right x -> return x
+ Left err -> throwError (f err)
+
+wrapM :: IO (ParseResult a) -> PM a
+wrapM m = liftIO m >>= wrap
+
+-- | A monad for handling parse results
+newtype PM a = PM { unPM :: ExceptT ParseError (StateT [ParseWarning] IO) a }
+ deriving (Functor, Applicative, Monad,
+ MonadError ParseError, MonadIO)
-wrapM:: Monad m => m (ParseResult a) -> m a
-wrapM m =
- do r <- m
- case r of
- ParseOk _ x -> return x
- ParseFailed err -> throw err
+warning :: ParseWarning -> PM ()
+warning w = PM (modify (w:))
+
+runPMIO :: (MonadIO m) => PM a -> m (Either ParseError a, [ParseWarning])
+runPMIO = liftIO . fmap (second reverse) . flip runStateT [] . runExceptT . unPM
------------------------------------------------------------------------
-- Parse functions
@@ -50,34 +95,69 @@ wrapM m =
-- | Wrapped Parser type.
data Parser a = Parser
- { parser :: M.Parser a
- , parseFlags :: ParseFlags
+ { parser :: M.Parser a
+ , parseFlags :: ParseFlags
+ , parseLiterate :: LiterateParser a
}
-parse :: Parser a -> String -> IO a
+type LiterateParser a = Parser a -> [Layer] -> PM a
+
+parse :: Parser a -> String -> PM a
parse p = wrapM . return . M.parse (parseFlags p) [normal] (parser p)
-parseFile :: Parser a -> AbsolutePath -> IO a
+parseFile :: Parser a -> AbsolutePath -> PM a
parseFile p = wrapM . M.parseFile (parseFlags p) [layout, normal] (parser p)
-parseLiterate :: Parser a -> String -> IO a
-parseLiterate p =
- wrapM . return . M.parse (parseFlags p) [literate, layout, code] (parser p)
+parseString :: Parser a -> String -> PM a
+parseString = parseStringFromFile Strict.Nothing
+
+parseStringFromFile :: SrcFile -> Parser a -> String -> PM a
+parseStringFromFile src p = wrapM . return . M.parseFromSrc (parseFlags p) [layout, normal] (parser p) src
+
+parseLiterateWithoutComments :: LiterateParser a
+parseLiterateWithoutComments p layers = parseStringFromFile (literateSrcFile layers) p $ illiterate layers
+
+parseLiterateWithComments :: LiterateParser [Token]
+parseLiterateWithComments p layers = do
+ code <- map Left <$> parseLiterateWithoutComments p layers
+ let literate = Right <$> filter (not . isCode) layers
+ let (terms, overlaps) = interleaveRanges code literate
+ forM_ (map fst overlaps) $ \c ->
+ warning$ OverlappingTokensWarning { warnRange = getRange c }
+
+ return$ concat [ case m of
+ Left t -> [t]
+ Right (Layer Comment interval s) -> [TokTeX (interval, s)]
+ Right (Layer Markup _ _) -> []
+ Right (Layer Code _ _) -> []
+ | m <- terms ]
+
+readFilePM :: AbsolutePath -> PM String
+readFilePM path = wrapIOM (ReadFileError path) (readFile (filePath path))
+
+parseLiterateFile :: Processor -> Parser a -> AbsolutePath -> PM a
+parseLiterateFile po p path = readFilePM path >>= parseLiterate p p . po (startPos (Just path))
-parseLiterateFile :: Parser a -> AbsolutePath -> IO a
-parseLiterateFile p =
- wrapM . M.parseFile (parseFlags p) [literate, layout, code] (parser p)
+parsePosString :: Parser a -> Position -> String -> PM a
+parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) [normal] (parser p)
-parsePosString :: Parser a -> Position -> String -> IO a
-parsePosString p pos =
- wrapM . return . M.parsePosString pos (parseFlags p) [normal] (parser p)
+-- | Extensions supported by `parseFile'`
+parseFileExts :: [String]
+parseFileExts = ".agda":literateExts
-parseFile' :: Parser a -> AbsolutePath -> IO a
+parseFile' :: (Show a) => Parser a -> AbsolutePath -> PM a
parseFile' p file =
- if "lagda" `isSuffixOf` filePath file then
- Agda.Syntax.Parser.parseLiterateFile p file
- else
+ if ".agda" `isSuffixOf` filePath file then
Agda.Syntax.Parser.parseFile p file
+ else
+ go literateProcessors
+ where
+ go [] = throwError InvalidExtensionError {
+ errPath = file
+ , errValidExts = parseFileExts
+ }
+ go ((ext, po):pos) | ext `isSuffixOf` filePath file = parseLiterateFile po p file
+ go (_:pos) = go pos
------------------------------------------------------------------------
-- Specific parsers
@@ -86,19 +166,25 @@ parseFile' p file =
moduleParser :: Parser Module
moduleParser = Parser { parser = P.moduleParser
- , parseFlags = withoutComments }
+ , parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
+ }
-- | Parses a module name.
moduleNameParser :: Parser QName
moduleNameParser = Parser { parser = P.moduleNameParser
- , parseFlags = withoutComments }
+ , parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
+ }
-- | Parses an expression.
exprParser :: Parser Expr
exprParser = Parser { parser = P.exprParser
- , parseFlags = withoutComments }
+ , parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
+ }
-- | Parses an expression followed by a where clause.
@@ -106,13 +192,16 @@ exprWhereParser :: Parser ExprWhere
exprWhereParser = Parser
{ parser = P.exprWhereParser
, parseFlags = withoutComments
+ , parseLiterate = parseLiterateWithoutComments
}
-- | Gives the parsed token stream (including comments).
tokensParser :: Parser [Token]
tokensParser = Parser { parser = P.tokensParser
- , parseFlags = withComments }
+ , parseFlags = withComments
+ , parseLiterate = parseLiterateWithComments
+ }
-- | Keep comments in the token stream generated by the lexer.
diff --git a/src/full/Agda/Syntax/Parser/LexActions.hs b/src/full/Agda/Syntax/Parser/LexActions.hs
index df79d20..28e6539 100644
--- a/src/full/Agda/Syntax/Parser/LexActions.hs
+++ b/src/full/Agda/Syntax/Parser/LexActions.hs
@@ -72,6 +72,8 @@ postToken (TokId (r, "\x2026")) = TokSymbol SymEllipsis r
postToken (TokId (r, "\x2192")) = TokSymbol SymArrow r
postToken (TokId (r, "\x2983")) = TokSymbol SymDoubleOpenBrace r
postToken (TokId (r, "\x2984")) = TokSymbol SymDoubleCloseBrace r
+postToken (TokId (r, "\x2987")) = TokSymbol SymOpenIdiomBracket r
+postToken (TokId (r, "\x2988")) = TokSymbol SymCloseIdiomBracket r
postToken (TokId (r, "\x2200")) = TokKeyword KwForall r
postToken (TokId (r, s))
| set == "Set" && all isSub n = TokSetN (r, readSubscript n)
diff --git a/src/full/Agda/Syntax/Parser/Lexer.x b/src/full/Agda/Syntax/Parser/Lexer.x
index bdb592c..966aa80 100644
--- a/src/full/Agda/Syntax/Parser/Lexer.x
+++ b/src/full/Agda/Syntax/Parser/Lexer.x
@@ -14,7 +14,7 @@ module Agda.Syntax.Parser.Lexer
( -- * The main function
lexer
-- * Lex states
- , normal, literate, code
+ , normal, code
, layout, empty_layout, bol, imp_dir
-- * Alex generated functions
, AlexReturn(..), alexScanUser
@@ -65,16 +65,6 @@ $white_nonl = $white_notab # \n
tokens :-
--- Lexing literate files
-<tex> $white_nonl* \\ "begin{code}" $white_nonl* $ { end_ }
-<tex> .+ / { keepComments } { withInterval TokTeX }
-<tex> .+ ;
-<tex> \n ;
-<tex> () / { eof } { end_ }
-<bol_,layout_>
- \\ "end{code}" / { inState code } { begin_ tex }
- -- \end{code} should only be recognized if the bottom of the stack is <code>
-
-- White space
<0,code,bol_,layout_,empty_layout_,imp_dir_>
$white_nonl+ ;
@@ -105,10 +95,10 @@ tokens :-
<pragma_> "LINE" { keyword KwLINE }
<pragma_> "MEASURE" { keyword KwMEASURE }
<pragma_> "NO_POSITIVITY_CHECK" { keyword KwNO_POSITIVITY_CHECK }
-<pragma_> "NO_SMASHING" { keyword KwNO_SMASHING }
<pragma_> "NO_TERMINATION_CHECK" { keyword KwNO_TERMINATION_CHECK }
<pragma_> "NON_TERMINATING" { keyword KwNON_TERMINATING }
<pragma_> "OPTIONS" { keyword KwOPTIONS }
+<pragma_> "POLARITY" { keyword KwPOLARITY }
<pragma_> "REWRITE" { keyword KwREWRITE }
<pragma_> "STATIC" { keyword KwSTATIC }
<pragma_> "TERMINATING" { keyword KwTERMINATING }
@@ -179,6 +169,7 @@ tokens :-
<0,code> abstract { keyword KwAbstract }
<0,code> private { keyword KwPrivate }
<0,code> instance { keyword KwInstance }
+<0,code> overlap { keyword KwOverlap }
<0,code> macro { keyword KwMacro }
<0,code> Set { keyword KwSet }
<0,code> forall { keyword KwForall }
@@ -216,6 +207,8 @@ tokens :-
<0,code> "_" { symbol SymUnderscore }
<0,code> "?" { symbol SymQuestionMark }
<0,code> "|" { symbol SymBar }
+<0,code> "(|" /[$white] { symbol SymOpenIdiomBracket }
+<0,code> "|)" { symbol SymCloseIdiomBracket }
<0,code> "(" { symbol SymOpenParen }
<0,code> ")" { symbol SymCloseParen }
<0,code> "->" { symbol SymArrow }
@@ -248,12 +241,6 @@ tokens :-
{
--- | This is the initial state for parsing a literate file. Code blocks
--- should be enclosed in @\\begin{code}@ @\\end{code}@ pairs.
-literate :: LexState
-literate = tex
-
-
-- | This is the initial state for parsing a regular, non-literate file.
normal :: LexState
normal = 0
diff --git a/src/full/Agda/Syntax/Parser/Literate.hs b/src/full/Agda/Syntax/Parser/Literate.hs
new file mode 100644
index 0000000..f997af7
--- /dev/null
+++ b/src/full/Agda/Syntax/Parser/Literate.hs
@@ -0,0 +1,219 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+-- | Preprocessors for literate code formats
+module Agda.Syntax.Parser.Literate (
+ literateProcessors,
+ literateExts,
+ literateExtsShortList,
+ literateSrcFile,
+ literateTeX,
+ literateRsT,
+ illiterate,
+ isCode,
+ Processor,
+ Layer(..),
+ LayerType(..)
+ )
+ where
+
+import Prelude hiding (getLine)
+import Data.Char (isSpace, isControl)
+import Data.List (isPrefixOf)
+import Agda.Syntax.Position
+import Text.Regex.TDFA
+
+#if __GLASGOW_HASKELL__ <= 708
+import Control.Applicative ((<$>),(<*>))
+#endif
+
+#include "undefined.h"
+import Agda.Utils.Impossible
+
+data LayerType = Markup | Comment | Code
+ deriving (Show, Eq)
+
+data Layer = Layer {
+ layerType :: LayerType
+ ,interval :: Interval
+ ,layerContent :: String
+} deriving (Show)
+
+instance HasRange Layer where
+ getRange = getRange . interval
+
+-- | Annotates a tokenized string with position information.
+mkLayers :: Position -> [(LayerType, String)] -> [Layer]
+mkLayers pos [] = emptyLiterate pos
+mkLayers pos ((_,""):xs) = mkLayers pos xs
+mkLayers pos ((ty,s):xs) = let next = movePosByString pos s in
+ (Layer ty (Interval pos next) s):(mkLayers next xs)
+
+-- | Checks if a layer corresponds to Agda code
+isCode :: Layer -> Bool
+isCode Layer{layerType=Code} = True
+isCode Layer{layerType=Markup } = False
+isCode Layer{layerType=Comment} = False
+
+-- | Type of a literate preprocessor:
+-- Invariants:
+--
+-- > f : Processor
+--
+-- prop> f pos s /= []
+--
+-- prop> f pos s >>= layerContent == s
+type Processor = Position -> String -> [Layer]
+
+literateSrcFile :: [Layer] -> SrcFile
+literateSrcFile [] = __IMPOSSIBLE__
+literateSrcFile (Layer{interval}:_) = getIntervalFile interval
+
+-- | List of valid extensions for literate Agda files, and their corresponding
+-- preprocessors.
+--
+-- If you add new extensions, remember to update test/Utils.hs so that test
+-- cases ending in the new extensions are found.
+literateProcessors :: [(String, Processor)]
+literateProcessors = map ((,) <$> (".lagda" ++) . fst <*> snd)
+ [("" , literateTeX)
+ ,(".rst", literateRsT)
+ ,(".tex", literateTeX)
+ ]
+
+-- | Blanks the non-code parts of a given file, preserving positions of
+-- characters corresponding to code. This way, there is a direct
+-- correspondence between source positions and positions in the
+-- processed result.
+illiterate :: [Layer] -> String
+illiterate xs = concat [
+ (if isCode m then id else bleach) layerContent
+ | m@Layer{layerContent} <- xs]
+
+-- | Replaces non-space characters in a string with spaces.
+bleach :: String -> String
+bleach s = map go s
+ where
+ go c | isSpace c = c
+ go _ = ' '
+
+-- | Check if a character is a blank character.
+isBlank :: Char -> Bool
+isBlank = (&&) <$> isSpace <*> not . (== '\n')
+
+-- | Possible extensions for a literate Agda file
+literateExts :: [String]
+literateExts = map fst literateProcessors
+
+-- | Short list of extensions for literate Agda files
+-- For display purposes.
+literateExtsShortList :: [String]
+literateExtsShortList = [".lagda"]
+
+-- | break a list just *after* an element satisfying the predicate is found
+--
+-- >>> break1 even [1,3,5,2,4,7,8]
+-- ([1,3,5,2],[4,7,8])
+--
+break1 :: (a -> Bool) -> [a] -> ([a],[a])
+break1 _ [] = ([], [])
+break1 p (x:xs) | p x = (x:[],xs)
+break1 p (x:xs) = let (ys,zs) = break1 p xs in (x:ys,zs)
+
+-- | Returns a tuple consisting of the first line of the input, and the rest
+-- of the input.
+getLine :: String -> (String, String)
+getLine = break1 (== '\n')
+
+-- | Canonical decomposition of an empty literate file
+emptyLiterate :: Position -> [Layer]
+emptyLiterate pos = [Layer (Markup) (Interval pos pos) ""]
+
+-- | Create a regular expression that:
+-- - Must match the whole string
+-- - Works across line boundaries
+rex :: String -> Regex
+rex s = makeRegexOpts blankCompOpt{newSyntax = True} blankExecOpt$ "\\`" ++ s ++ "\\'"
+
+-- | Preprocessor for literate TeX
+literateTeX :: Position -> String -> [Layer]
+literateTeX pos s = mkLayers pos$ tex s
+ where
+ tex :: String -> [(LayerType, String)]
+ tex [] = []
+ tex s = let (line, rest) = getLine s in
+ case r_begin `matchM` line of
+ Just (getAllTextSubmatches -> [_, pre, markup]) ->
+ (Comment, pre):(Markup, markup):code rest
+ Just _ -> __IMPOSSIBLE__
+ Nothing -> (Comment, line):tex rest
+
+ r_begin = rex "(.*)([[:space:]]*\\\\begin\\{code\\}[[:space:]]*)"
+
+
+ code :: String -> [(LayerType, String)]
+ code [] = []
+ code s = let (line, rest) = getLine s in
+ case r_end `matchM` line of
+ Just (getAllTextSubmatches -> [_, markup, post]) ->
+ (Markup, markup):(Comment, post):tex rest
+ Just _ -> __IMPOSSIBLE__
+ Nothing -> (Code, line):code rest
+
+ r_end = rex "([[:space:]]*\\\\end\\{code\\}[[:space:]]*)(.*)"
+
+
+-- | Preprocessor for reStructuredText
+literateRsT :: Position -> String -> [Layer]
+literateRsT pos s = mkLayers pos$ rst s
+ where
+ rst :: String -> [(LayerType, String)]
+ rst [] = []
+ rst s = maybe_code s
+
+ maybe_code s =
+ if r_comment `match` line then
+ not_code