diff --git a/Agda.cabal b/Agda.cabal --- a/Agda.cabal +++ b/Agda.cabal @@ -1,10 +1,10 @@ name: Agda -version: 2.4.2.2 +version: 2.4.2.3 cabal-version: >= 1.8 build-type: Custom license: OtherLicense license-file: LICENSE -author: Ulf Norell, Andreas Abel, Nils Anders Danielsson, Makoto Takeyama, Catarina Coquand, with contributions by Stevan Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, James Chapman, Jesper Cockx, Dominique Devriese, Peter Divanski, Fredrik Nordvall Forsberg, Olle Fredriksson, Daniel Gustafsson, Patrik Jansson, Alan Jeffrey, Wolfram Kahl, Fredrik Lindblad, Francesco Mazzoli, Stefan Monnier, Darin Morrison, Guilhem Moulin, Nicolas Pouillard, Andrés Sicard-Ramírez, Andrea Vezzosi and many more. +author: Ulf Norell, Andreas Abel, Nils Anders Danielsson, Makoto Takeyama, Catarina Coquand, with contributions by Stevan Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, James Chapman, Jesper Cockx, Dominique Devriese, Peter Divanski, Fredrik Nordvall Forsberg, Olle Fredriksson, Daniel Gustafsson, Philipp Hausmann, Patrik Jansson, Alan Jeffrey, Wolfram Kahl, Fredrik Lindblad, Francesco Mazzoli, Stefan Monnier, Darin Morrison, Guilhem Moulin, Nicolas Pouillard, Andrés Sicard-Ramírez, Andrea Vezzosi and many more. maintainer: Ulf Norell homepage: http://wiki.portal.chalmers.se/agda/ bug-reports: http://code.google.com/p/agda/issues/list @@ -32,19 +32,19 @@ Note that the Agda library does not follow the package versioning policy, because it is not intended to be used by third-party packages. -tested-with: GHC == 7.0.4 - GHC == 7.4.2 +tested-with: GHC == 7.4.2 GHC == 7.6.3 - GHC == 7.8.3 + GHC == 7.8.4 + GHC == 7.10.1 extra-source-files: src/full/undefined.h README.md CHANGELOG data-dir: src/data data-files: Agda.css emacs-mode/*.el - EpicInclude/AgdaPrelude.e - EpicInclude/stdagda.c - EpicInclude/stdagda.h + -- EpicInclude/AgdaPrelude.e + -- EpicInclude/stdagda.c + -- EpicInclude/stdagda.h agda.sty postprocess-latex.pl lib/prim/Agda/Primitive.agda @@ -56,90 +56,101 @@ source-repository this type: git location: https://github.com/agda/agda - tag: 2.4.2.2 + tag: 2.4.2.3 flag cpphs default: True manual: True description: Use cpphs instead of cpp. -flag epic - default: False - manual: True - description: - Install the Epic compiler. - library hs-source-dirs: src/full include-dirs: src/full - if flag(epic) - build-depends: epic >= 0.1.13 && < 0.10 + if flag(cpphs) + build-tools: cpphs >= 1.19 && < 1.20 + ghc-options: -pgmP cpphs -optP --cpp + if os(windows) build-depends: Win32 >= 2.2 && < 2.4 build-depends: - array >= 0.1 && < 0.6 - , base >= 4.2 && < 4.8 + array >= 0.4.0.0 && < 0.6 + , base >= 4.5.0.0 && < 4.9 , binary >= 0.6 && < 0.8 , boxes >= 0.1.3 && < 0.2 -- NFData ByteString is only available from bytestring >= 0.10 - -- but bytestring-0.10 is not accepted by travis build for ghc <= 7.4 + -- but bytestring-0.10 is not accepted by travis build for GHC <= 7.4 -- as it breaks the accompanying haskell-platform - -- even though it builds with older ghcs. - , bytestring >= 0.9.0.1 && < 0.11 - , containers >= 0.1 && < 0.6 + -- even though it builds with older GHCs. + , bytestring >= 0.9.2.1 && < 0.11 + , containers >= 0.4.2.1 && < 0.6 , data-hash == 0.2.0.0 - , deepseq == 1.3.* - , equivalence >= 0.2.5 && < 0.3 - , filepath >= 1.1 && < 1.4 - , geniplate >= 0.6.0.3 && < 0.7 + , deepseq >= 1.3.0.0 && < 1.5 + , edit-distance >= 0.2.1.2 && < 0.3 + , equivalence >= 0.2.5 && < 0.4 + , filepath >= 1.3.0.0 && < 1.5 + , geniplate-mirror >= 0.6.0.6 && < 0.7 -- hashable 1.2.0.10 makes library-test 10x slower. The issue was -- fixed in hashable 1.2.1.0. -- https://github.com/tibbe/hashable/issues/57. , hashable >= 1.1.2.3 && < 1.2 || >= 1.2.1.0 && < 1.3 - , hashtables >= 1.0 && < 1.2 + -- There is a "serious bug" + -- (https://hackage.haskell.org/package/hashtables-1.2.0.2/changelog) + -- in hashtables 1.2.0.0/1.2.0.1. This bug seems to have made Agda + -- much slower (infinitely slower?) in some cases. + , hashtables >= 1.0 && < 1.2 || >= 1.2.0.2 && < 1.3 , haskeline >= 0.7 && < 0.8 - , haskell-src-exts >= 1.9.6 && < 1.17 + , haskell-src-exts >= 1.16.0.1 && < 1.17 -- mtl-2.1 contains a severe bug. -- -- mtl >= 2.2 && < 2.2.1 doesn't export Control.Monad.Except. , mtl >= 2.1.1 && <= 2.1.3.1 || >= 2.2.1 && < 2.3 - , parallel < 3.3 + , QuickCheck >= 2.8 && < 2.9 + , parallel >= 3.2.0.4 && < 3.3 -- , parsec >= 3.1 && < 3.2, -- only for Agda.TypeChecking.SizedTypes.Parser, which is not included - , pretty >= 1.0 && < 1.2 - , process >= 1.0.1.0 && < 1.3 - , QuickCheck >= 2.7.5 && < 2.8 - , STMonadTrans >= 0.3.2 && < 0.4 + + -- pretty 1.1.1.2 and 1.1.1.3 do not follow the package versioning + -- policy. + , pretty >= 1.1.1.0 && < 1.1.1.2 || >= 1.1.2 && < 1.2 + , process >= 1.1.0.1 && < 1.3 , strict >= 0.3.2 && < 0.4 - , template-haskell >= 2.5 && < 2.10 + , template-haskell >= 2.7.0.0 && < 2.11 , text >= 0.11 && < 1.3 - -- tranformers 0.4.0.0 was deprecated. + -- transformers 0.4.0.0 was deprecated. , transformers >= 0.3 && < 0.4 || >= 0.4.1.0 && < 0.5 + , transformers-compat >= 0.3.3.2 && < 0.5 , unordered-containers == 0.2.* , xhtml == 3000.2.* - , zlib >= 0.4.0.1 && < 0.6 + , zlib >= 0.4.0.1 && < 0.7 + if impl(ghc < 7.8) + build-depends: base-orphans >= 0.3.1 && < 0.4 + if impl(ghc < 7.6) build-depends: - directory >= 1.0 && < 1.2 - , old-time >= 1.0 && < 1.2 + directory >= 1.1.0.2 && < 1.2 + -- The package ghc-prim is included in order to get access to + -- GHC.Generics, which later moved to base. + , ghc-prim == 0.2.* + , old-time >= 1.1.0.0 && < 1.2 else build-depends: - directory == 1.2.* - , time == 1.4.* + directory >= 1.2.0.0 && < 1.3 + , time >= 1.4 && < 1.6 build-tools: alex >= 3.1.0 && < 3.2 - , happy >= 1.19.3 && < 2 + , happy >= 1.19.4 && < 2 - exposed-modules: Agda.Main - Agda.ImpossibleTest - Agda.Interaction.BasicOps - Agda.Interaction.EmacsTop - Agda.Interaction.InteractionTop + exposed-modules: Agda.Auto.Auto + Agda.Auto.CaseSplit + Agda.Auto.Convert + Agda.Auto.NarrowingSearch + Agda.Auto.SearchControl + Agda.Auto.Syntax + Agda.Auto.Typecheck Agda.Compiler.CallCompiler - Agda.Compiler.HaskellTypes Agda.Compiler.Epic.AuxAST Agda.Compiler.Epic.CaseOpts Agda.Compiler.Epic.Compiler @@ -155,6 +166,7 @@ Agda.Compiler.Epic.Primitive Agda.Compiler.Epic.Smashing Agda.Compiler.Epic.Static + Agda.Compiler.HaskellTypes Agda.Compiler.JS.Case Agda.Compiler.JS.Compiler Agda.Compiler.JS.Syntax @@ -166,8 +178,11 @@ Agda.Compiler.MAlonzo.Misc Agda.Compiler.MAlonzo.Pretty Agda.Compiler.MAlonzo.Primitives - Agda.Interaction.CommandLine.CommandLine + Agda.ImpossibleTest + Agda.Interaction.BasicOps + Agda.Interaction.CommandLine Agda.Interaction.EmacsCommand + Agda.Interaction.EmacsTop Agda.Interaction.Exceptions Agda.Interaction.FindFile Agda.Interaction.Highlighting.Dot @@ -179,11 +194,13 @@ Agda.Interaction.Highlighting.Vim Agda.Interaction.Highlighting.LaTeX Agda.Interaction.Imports + Agda.Interaction.InteractionTop Agda.Interaction.Response Agda.Interaction.MakeCase Agda.Interaction.Monad Agda.Interaction.Options Agda.Interaction.Options.Lenses + Agda.Main Agda.Syntax.Abstract.Copatterns Agda.Syntax.Abstract.Name Agda.Syntax.Abstract.Pretty @@ -303,6 +320,7 @@ Agda.TypeChecking.Reduce Agda.TypeChecking.Reduce.Monad Agda.TypeChecking.Rewriting + Agda.TypeChecking.Rewriting.NonLinMatch Agda.TypeChecking.Rules.Builtin Agda.TypeChecking.Rules.Builtin.Coinduction Agda.TypeChecking.Rules.Data @@ -356,7 +374,10 @@ Agda.Utils.Lens Agda.Utils.Lens.Examples Agda.Utils.List + Agda.Utils.ListT + Agda.Utils.ListT.Tests Agda.Utils.Map + Agda.Utils.Map.Compat Agda.Utils.Maybe Agda.Utils.Maybe.Strict Agda.Utils.Monad @@ -365,11 +386,11 @@ Agda.Utils.Permutation Agda.Utils.Permutation.Tests Agda.Utils.Pointer - Agda.Utils.Pointed Agda.Utils.Pretty Agda.Utils.QuickCheck Agda.Utils.ReadP Agda.Utils.SemiRing + Agda.Utils.Singleton Agda.Utils.Size Agda.Utils.String Agda.Utils.Suffix @@ -381,68 +402,53 @@ Agda.Utils.VarSet Agda.Utils.Warshall Agda.Version - Agda.Auto.Auto - Agda.Auto.Convert - Agda.Auto.Typecheck - Agda.Auto.NarrowingSearch - Agda.Auto.Syntax - Agda.Auto.SearchControl - Agda.Auto.CaseSplit + other-modules: Paths_Agda - -- This conditional is required by GHC <= 7.4.2. - if true - ghc-options: -w - -fwarn-deprecated-flags - -fwarn-dodgy-foreign-imports - -fwarn-dodgy-imports - -fwarn-duplicate-exports - -fwarn-hi-shadowing - -fwarn-incomplete-patterns - -fwarn-missing-fields - -fwarn-missing-methods - -fwarn-missing-signatures - -fwarn-monomorphism-restriction - -fwarn-tabs - -fwarn-overlapping-patterns - -fwarn-unrecognised-pragmas - -fwarn-warnings-deprecations - if flag(cpphs) - build-tools: cpphs >= 1.18.6 && < 1.19 - ghc-options: -pgmPcpphs -optP--cpp + if impl(ghc >= 7.4.2) + ghc-options: -w + -fwarn-deprecated-flags + -fwarn-dodgy-exports + -fwarn-dodgy-foreign-imports + -fwarn-dodgy-imports + -fwarn-duplicate-exports + -fwarn-hi-shadowing + -fwarn-identities + -fwarn-incomplete-patterns + -fwarn-missing-fields + -fwarn-missing-methods + -fwarn-missing-signatures + -fwarn-monomorphism-restriction + -fwarn-tabs + -fwarn-overlapping-patterns + -fwarn-unrecognised-pragmas + -fwarn-unused-do-bind + -fwarn-warnings-deprecations + -fwarn-wrong-do-bind - -- The Cabal-generated module Paths_Agda triggers a warning under - -- GHC 7.2.1/7.2.2 (at least when certain versions of Cabal are - -- used). - -- - -- Issue 1103: Some files (e.g. Syntax.Scope.Monad, - -- Termination.SparseMatrix and Utils.Cluster) trigger a warning - -- under GHC 7.0.4. -Werror is for developers only, who are assumed - -- to use a recent GHC. - -- if impl(ghc > 7.2.2) - -- ghc-options: -Werror - if impl(ghc >= 6.12) - ghc-options: -fwarn-dodgy-exports - -fwarn-wrong-do-bind - if impl(ghc >= 7.2) - ghc-options: -fwarn-identities if impl(ghc >= 7.6.3) - ghc-options: -fwarn-pointless-pragmas + ghc-options: -fwarn-pointless-pragmas + if impl(ghc >= 7.8) - ghc-options: -fwarn-amp - -fwarn-duplicate-constraints - -fwarn-empty-enumerations - -fwarn-overflowed-literals - -fwarn-typed-holes - -fwarn-inline-rule-shadowing + ghc-options: -fwarn-duplicate-constraints + -fwarn-empty-enumerations + -fwarn-overflowed-literals + -fwarn-typed-holes + -fwarn-inline-rule-shadowing - ghc-prof-options: -auto-all + if impl(ghc >= 7.10) + ghc-options: -fwarn-context-quantification + -fwarn-unticked-promoted-constructors + -- The -fwarn-amp flag is deprected in GHC 7.10.1. + if impl(ghc >= 7.8) && impl(ghc < 7.10) + ghc-options: -fwarn-amp + executable agda hs-source-dirs: src/main main-is: Main.hs build-depends: - Agda == 2.4.2.2 + Agda == 2.4.2.3 -- Nothing is used from the following package, except for the -- prelude. , base >= 3 && < 6 @@ -459,8 +465,7 @@ main-is: Main.hs other-modules: Paths_Agda build-depends: - base >= 4.2 && < 4.8 - , directory >= 1.0 && < 1.3 - , filepath >= 1.1 && < 1.4 + base >= 4.5.0.0 && < 4.9 + , directory >= 1.1.0.2 && < 1.3 + , filepath >= 1.3.0.0 && < 1.5 , process >= 1.0.1.0 && < 1.3 - diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,4 +1,264 @@ ------------------------------------------------------------------------ +-- Release notes for Agda version 2.4.2.3 +------------------------------------------------------------------------ + +Important changes since 2.4.2.2: + +Installation and infrastructure +=============================== + +* Added support for GHC 7.10.1. + +* Removed support for GHC 7.0.4. + +Language +======== + +* _ is no longer a valid name for a definition. The following fails now: + [Issue 1465] + + postulate _ : Set + +* Typed bindings can now contain hiding information [Issue 1391]. + This means you can now write + + assoc : (xs {ys zs} : List A) → ((xs ++ ys) ++ zs) ≡ (xs ++ (ys ++ zs)) + + instead of the longer + + assoc : (xs : List A) {ys zs : List A} → ... + + It also works with irrelevance + + .(xs {ys zs} : List A) → ... + + but of course does not make sense if there is hiding information already. + Thus, this is (still) a parse error: + + {xs {ys zs} : List A} → ... + +* The builtins for sized types no longer need accompanying postulates. + The BUILTIN pragmas for size stuff now also declare the identifiers + they bind to. + + {-# BUILTIN SIZEUNIV SizeUniv #-} -- SizeUniv : SizeUniv + {-# BUILTIN SIZE Size #-} -- Size : SizeUniv + {-# BUILTIN SIZELT Size<_ #-} -- Size<_ : ..Size → SizeUniv + {-# BUILTIN SIZESUC ↑_ #-} -- ↑_ : Size → Size + {-# BUILTIN SIZEINF ∞ #-} -- ∞ : Size + + Size and Size< now live in the new universe SizeUniv. + It is forbidden to build function spaces in this universe, + in order to prevent the malicious assumption of a size predecessor + + pred : (i : Size) → Size< i + + [Issue 1428]. + +* Unambiguous notations (coming from syntax declarations) that resolve + to ambiguous names are now parsed unambiguously [Issue 1194]. + +* If only some instances of an overloaded name have a given + associated notation (coming from syntax declarations), then this + name can only be resolved to the given instances of the + name, not to other instances [Issue 1194]. + + Previously, if different instances of an overloaded name had + /different/ associated notations, then none of the notations could + be used. Now all of them can be used. + + Note that notation identity does not only involve the right-hand + side of the syntax declaration. For instance, the following + notations are not seen as identical, because the implicit argument + names are different: + + module A where + + data D : Set where + c : {x y : D} → D + + syntax c {x = a} {y = b} = a ∙ b + + module B where + + data D : Set where + c : {y x : D} → D + + syntax c {y = a} {x = b} = a ∙ b + +* If an overloaded operator is in scope with at least two distinct + fixities, then it gets the default fixity [Issue 1436]. + + Similarly, if two or more identical notations for a given overloaded + name are in scope, and these notations do not all have the + same fixity, then they get the default fixity. + +Type checking +============= + +* Functions of varying arity can now have with-clauses and use rewrite. + Example: + + NPred : Nat → Set + NPred 0 = Bool + NPred (suc n) = Nat → NPred n + + const : Bool → ∀{n} → NPred n + const b {0} = b + const b {suc n} m = const b {n} + + allOdd : ∀ n → NPred n + allOdd 0 = true + allOdd (suc n) m with even m + ... | true = const false + ... | false = allOdd n + +* Function defined by copattern matching can now have with-clauses + and use rewrite. Example: + + {-# OPTIONS --copatterns #-} + + record Stream (A : Set) : Set where + coinductive + constructor delay + field + force : A × Stream A + open Stream + + map : ∀{A B} → (A → B) → Stream A → Stream B + force (map f s) with force s + ... | a , as = f a , map f as + + record Bisim {A B} (R : A → B → Set) (s : Stream A) (t : Stream B) : Set where + coinductive + constructor ~delay + field + ~force : let a , as = force s + b , bs = force t + in R a b × Bisim R as bs + open Bisim + + SEq : ∀{A} (s t : Stream A) → Set + SEq = Bisim (_≡_) + + -- Slightly weird definition of symmetry to demonstrate rewrite. + + ~sym' : ∀{A} {s t : Stream A} → SEq s t → SEq t s + ~force (~sym' {s = s} {t} p) with force s | force t | ~force p + ... | a , as | b , bs | r , q rewrite r = refl , ~sym' q + +* Instances can now be defined by copattern matching. [Issue 1413] + The following example extends the one in + [Abel, Pientka, Thibodeau, Setzer, POPL 2013, Section 2.2]: + + {-# OPTIONS --copatterns #-} + + -- The Monad type class + + record Monad (M : Set → Set) : Set1 where + field + return : {A : Set} → A → M A + _>>=_ : {A B : Set} → M A → (A → M B) → M B + open Monad {{...}} + + -- The State newtype + + record State (S A : Set) : Set where + field + runState : S → A × S + open State + + -- State is an instance of Monad + + instance + stateMonad : {S : Set} → Monad (State S) + runState (return {{stateMonad}} a ) s = a , s -- NEW + runState (_>>=_ {{stateMonad}} m k) s₀ = -- NEW + let a , s₁ = runState m s₀ + in runState (k a) s₁ + + -- stateMonad fulfills the monad laws + + leftId : {A B S : Set}(a : A)(k : A → State S B) → + (return a >>= k) ≡ k a + leftId a k = refl + + rightId : {A B S : Set}(m : State S A) → + (m >>= return) ≡ m + rightId m = refl + + assoc : {A B C S : Set}(m : State S A)(k : A → State S B)(l : B → State S C) → + ((m >>= k) >>= l) ≡ (m >>= λ a → k a >>= l) + assoc m k l = refl + + +Emacs mode +========== + +* The new menu option "Switch to another version of Agda" tries to do + what it says. + +* Changed feature: Interactively split result. + + [ This is as before: ] + Make-case (C-c C-c) with no variables given tries to split on the + result to introduce projection patterns. The hole needs to be of + record type, of course. + + test : {A B : Set} (a : A) (b : B) → A × B + test a b = ? + + Result-splitting ? will produce the new clauses: + + proj₁ (test a b) = ? + proj₂ (test a b) = ? + + [ This has changed: ] + If hole is of function type, make-case will introduce only pattern + variables (as much as it can). + + testFun : {A B : Set} (a : A) (b : B) → A × B + testFun = ? + + Result-splitting ? will produce the new clause: + + testFun a b = ? + + A second invocation of make-case will then introduce projection patterns. + +Error messages +============== + +* Agda now suggests corrections of misspelled options, e.g. + + {-# OPTIONS + --dont-termination-check + --without-k + --senf-gurke + #-} + + Unrecognized options: + --dont-termination-check (did you mean --no-termination-check ?) + --without-k (did you mean --without-K ?) + --senf-gurke + + Nothing close to --senf-gurke, I am afraid. + +Compiler backends +================= + +* The Epic backend has been disabled [Issue 1481]. + +Bug fixes +========= + +* Fixed bug with unquoteDecl not working in instance blocks [Issue 1491]. + +* Other issues fixed ( see https://code.google.com/p/agda/issues ) + 1497 + 1500 + +------------------------------------------------------------------------ -- Release notes for Agda version 2.4.2.2 ------------------------------------------------------------------------ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2005-2014 Ulf Norell, Andreas Abel, Nils Anders +Copyright (c) 2005-2015 Ulf Norell, Andreas Abel, Nils Anders Danielsson, Andrés Sicard-Ramírez, Dominique Devriese, Péter Divianszki, Francesco Mazzoli, Stevan Andjelkovic, Daniel Gustafsson, Alan Jeffrey, Makoto Takeyama, Andrea Vezzosi, Nicolas Pouillard, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ +[![Build Status](https://travis-ci.org/agda/agda.svg?branch=maint-2.4.2)](https://travis-ci.org/agda/agda) + Agda 2 ====== @@ -6,7 +8,6 @@ * [Prerequisites](#prerequisites) * [Installing Agda](#installing-agda) * [Configuring the Emacs mode](#configuring-the-emacs-mode) -* [Installing the Epic backend's dependencies](#installing-the-epic-backends-dependencies) * [Installing Emacs under Windows](#installing-emacs-under-windows) Note that this README only discusses installation of Agda, not its standard @@ -161,44 +162,6 @@ displayed. This only works if the right fonts are available, though. If you want to turn off this feature, then you should customise the agda2-fontset-name variable. - - ------------------------------------------------------------------------- -Installing the Epic backend's dependencies ------------------------------------------------------------------------- - -The Epic backend is experimental and requires that the Epic program is -installed. You can install this program by giving the epic flag to -cabal (but note that, at the time of writing, the Epic program does -not build with certain recent versions of GHC): - -### Installing from Hackage: - - cabal update - cabal install Agda -fepic - agda-mode setup - -### Installing from development sources using cabal - - cabal update - cabal install -fepic - agda-mode setup - -### Installing from development sources using make - - make CABAL_OPTIONS=-fepic install - -You can also install Epic directly: - - cabal install epic - -Note that Epic depends on other software: - -* The Boehm garbage collector: http://www.hpl.hp.com/personal/Hans_Boehm/gc/ -* The GNU Multiple Precision Arithmetic Library: http://gmplib.org/ -* GCC, the GNU Compiler Collection: http://gcc.gnu.org/ - -For more information about Epic: http://www.cs.st-andrews.ac.uk/~eb/epic.php ------------------------------------------------------------------------ Installing Emacs under Windows diff --git a/dist/build/Agda/Syntax/Parser/Parser.hs b/dist/build/Agda/Syntax/Parser/Parser.hs --- a/dist/build/Agda/Syntax/Parser/Parser.hs +++ b/dist/build/Agda/Syntax/Parser/Parser.hs @@ -1,5366 +1,5431 @@ {-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} -{-| The parser is generated by Happy (). - - - - Ideally, ranges should be as precise as possible, to get messages that - - emphasize precisely the faulting term(s) upon error. - - - - However, interactive highlighting is only applied at the end of each - - mutual block, keywords are only highlighted once (see - - `TypeChecking.Rules.Decl'). So if the ranges of two declarations - - interleave, one must ensure that keyword ranges are not included in - - the intersection. (Otherwise they are uncolored by the interactive - - highlighting.) - - - -} -module Agda.Syntax.Parser.Parser ( - moduleParser - , exprParser - , tokensParser - , tests - ) where - -import Control.Monad - -import Data.Char -import Data.Functor -import Data.List -import Data.Maybe -import qualified Data.Traversable as T - -import Agda.Syntax.Position hiding (tests) -import Agda.Syntax.Parser.Monad -import Agda.Syntax.Parser.Lexer -import Agda.Syntax.Parser.Tokens -import Agda.Syntax.Concrete as C -import Agda.Syntax.Concrete.Pretty () -import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) -import qualified Agda.Syntax.Common as Common -import Agda.Syntax.Fixity -import Agda.Syntax.Notation -import Agda.Syntax.Literal - -import Agda.Utils.Hash -import Agda.Utils.List (spanJust) -import Agda.Utils.Monad -import Agda.Utils.QuickCheck -import Agda.Utils.TestHelpers -import Agda.Utils.Tuple -import qualified Data.Array as Happy_Data_Array -import qualified GHC.Exts as Happy_GHC_Exts -import Control.Applicative(Applicative(..)) - --- parser produced by Happy Version 1.19.4 - -newtype HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72 = HappyAbsSyn HappyAny -#if __GLASGOW_HASKELL__ >= 607 -type HappyAny = Happy_GHC_Exts.Any -#else -type HappyAny = forall a . a -#endif -happyIn6 :: ([Token]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn6 #-} -happyOut6 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Token]) -happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut6 #-} -happyIn7 :: ([Token]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Token]) -happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut7 #-} -happyIn8 :: (Token) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Token) -happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut8 #-} -happyIn9 :: (([Pragma], [Declaration])) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (([Pragma], [Declaration])) -happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut9 #-} -happyIn10 :: t10 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t10 -happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut10 #-} -happyIn11 :: t11 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t11 -happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut11 #-} -happyIn12 :: t12 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t12 -happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut12 #-} -happyIn13 :: (()) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn13 #-} -happyOut13 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (()) -happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut13 #-} -happyIn14 :: (Integer) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Integer) -happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut14 #-} -happyIn15 :: (Name) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Name) -happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut15 #-} -happyIn16 :: ([Name]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Name]) -happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut16 #-} -happyIn17 :: (Range) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Range) -happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut17 #-} -happyIn18 :: (Arg Name) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Arg Name) -happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut18 #-} -happyIn19 :: ([Arg Name]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg Name]) -happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut19 #-} -happyIn20 :: ([Arg Name]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg Name]) -happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut20 #-} -happyIn21 :: (QName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (QName) -happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut21 #-} -happyIn22 :: (QName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (QName) -happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut22 #-} -happyIn23 :: (Name) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Name) -happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut23 #-} -happyIn24 :: ([Name]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Name]) -happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut24 #-} -happyIn25 :: ([Name]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Name]) -happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut25 #-} -happyIn26 :: (Either [Name] [Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Either [Name] [Expr]) -happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut26 #-} -happyIn27 :: ([String]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([String]) -happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut27 #-} -happyIn28 :: (String) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (String) -happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut28 #-} -happyIn29 :: (Name) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Name) -happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut29 #-} -happyIn30 :: (QName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (QName) -happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut30 #-} -happyIn31 :: (Expr) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Expr) -happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut31 #-} -happyIn32 :: t32 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t32 -happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut32 #-} -happyIn33 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Expr]) -happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut33 #-} -happyIn34 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Expr]) -happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut34 #-} -happyIn35 :: t35 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t35 -happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut35 #-} -happyIn36 :: (Expr) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Expr) -happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut36 #-} -happyIn37 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Expr]) -happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut37 #-} -happyIn38 :: t38 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t38 -happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut38 #-} -happyIn39 :: t39 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t39 -happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut39 #-} -happyIn40 :: t40 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t40 -happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut40 #-} -happyIn41 :: ([(Name, Expr)]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([(Name, Expr)]) -happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut41 #-} -happyIn42 :: ([(Name, Expr)]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([(Name, Expr)]) -happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut42 #-} -happyIn43 :: ((Name, Expr)) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((Name, Expr)) -happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut43 #-} -happyIn44 :: t44 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t44 -happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut44 #-} -happyIn45 :: t45 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t45 -happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut45 #-} -happyIn46 :: ([TypedBindings]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypedBindings]) -happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut46 #-} -happyIn47 :: (TypedBindings) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (TypedBindings) -happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut47 #-} -happyIn48 :: (( [Color], TypedBinding )) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (( [Color], TypedBinding )) -happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut48 #-} -happyIn49 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([LamBinding]) -happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut49 #-} -happyIn50 :: (Either ([LamBinding], Hiding) [Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Either ([LamBinding], Hiding) [Expr]) -happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut50 #-} -happyIn51 :: ([Either Hiding LamBinding]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Either Hiding LamBinding]) -happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut51 #-} -happyIn52 :: (Either [Either Hiding LamBinding] [Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Either [Either Hiding LamBinding] [Expr]) -happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut52 #-} -happyIn53 :: ((LHS,RHS,WhereClause)) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn53 #-} -happyOut53 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((LHS,RHS,WhereClause)) -happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut53 #-} -happyIn54 :: ((LHS,RHS,WhereClause)) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn54 #-} -happyOut54 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((LHS,RHS,WhereClause)) -happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut54 #-} -happyIn55 :: ((LHS,RHS,WhereClause)) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn55 #-} -happyOut55 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((LHS,RHS,WhereClause)) -happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut55 #-} -happyIn56 :: ([(LHS,RHS,WhereClause)]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn56 #-} -happyOut56 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([(LHS,RHS,WhereClause)]) -happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut56 #-} -happyIn57 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn57 #-} -happyOut57 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([LamBinding]) -happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut57 #-} -happyIn58 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn58 #-} -happyOut58 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([LamBinding]) -happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut58 #-} -happyIn59 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([LamBinding]) -happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut59 #-} -happyIn60 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([LamBinding]) -happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut60 #-} -happyIn61 :: (Either [LamBinding] [Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Either [LamBinding] [Expr]) -happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut61 #-} -happyIn62 :: (ImportDirective) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (ImportDirective) -happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut62 #-} -happyIn63 :: ([ImportDirective]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([ImportDirective]) -happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut63 #-} -happyIn64 :: (ImportDirective) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (ImportDirective) -happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut64 #-} -happyIn65 :: ((UsingOrHiding , Range)) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((UsingOrHiding , Range)) -happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut65 #-} -happyIn66 :: (([Renaming] , Range)) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (([Renaming] , Range)) -happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut66 #-} -happyIn67 :: ([Renaming]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Renaming]) -happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut67 #-} -happyIn68 :: (Renaming) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Renaming) -happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut68 #-} -happyIn69 :: (ImportedName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (ImportedName) -happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut69 #-} -happyIn70 :: (ImportedName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn70 #-} -happyOut70 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (ImportedName) -happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut70 #-} -happyIn71 :: ([ImportedName]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn71 #-} -happyOut71 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([ImportedName]) -happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut71 #-} -happyIn72 :: t72 -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> t72 -happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut72 #-} -happyIn73 :: (LHS) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (LHS) -happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut73 #-} -happyIn74 :: ([Pattern]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Pattern]) -happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut74 #-} -happyIn75 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Expr]) -happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut75 #-} -happyIn76 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Expr]) -happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut76 #-} -happyIn77 :: (WhereClause) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (WhereClause) -happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut77 #-} -happyIn78 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut78 #-} -happyIn79 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut79 #-} -happyIn80 :: ([Arg Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg Declaration]) -happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut80 #-} -happyIn81 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn81 #-} -happyOut81 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut81 #-} -happyIn82 :: (RHSOrTypeSigs) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn82 #-} -happyOut82 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (RHSOrTypeSigs) -happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut82 #-} -happyIn83 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn83 #-} -happyOut83 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut83 #-} -happyIn84 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn84 #-} -happyOut84 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut84 #-} -happyIn85 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn85 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn85 #-} -happyOut85 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut85 #-} -happyIn86 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn86 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn86 #-} -happyOut86 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut86 #-} -happyIn87 :: (Name) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn87 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn87 #-} -happyOut87 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Name) -happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut87 #-} -happyIn88 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn88 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn88 #-} -happyOut88 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut88 #-} -happyIn89 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn89 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn89 #-} -happyOut89 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut89 #-} -happyIn90 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn90 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn90 #-} -happyOut90 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut90 #-} -happyIn91 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn91 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn91 #-} -happyOut91 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut91 #-} -happyIn92 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn92 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn92 #-} -happyOut92 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut92 #-} -happyIn93 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn93 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn93 #-} -happyOut93 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut93 #-} -happyIn94 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn94 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn94 #-} -happyOut94 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut94 #-} -happyIn95 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn95 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn95 #-} -happyOut95 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut95 #-} -happyIn96 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn96 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn96 #-} -happyOut96 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut96 #-} -happyIn97 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn97 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn97 #-} -happyOut97 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut97 #-} -happyIn98 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn98 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn98 #-} -happyOut98 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut98 #-} -happyIn99 :: ([Arg Name]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn99 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn99 #-} -happyOut99 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg Name]) -happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut99 #-} -happyIn100 :: ([RString]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn100 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn100 #-} -happyOut100 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([RString]) -happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut100 #-} -happyIn101 :: ([NamedArg HoleName]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn101 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn101 #-} -happyOut101 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([NamedArg HoleName]) -happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut101 #-} -happyIn102 :: (NamedArg HoleName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn102 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn102 #-} -happyOut102 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (NamedArg HoleName) -happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut102 #-} -happyIn103 :: (HoleName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn103 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn103 #-} -happyOut103 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (HoleName) -happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut103 #-} -happyIn104 :: (HoleName) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn104 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn104 #-} -happyOut104 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (HoleName) -happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut104 #-} -happyIn105 :: (RString) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn105 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn105 #-} -happyOut105 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (RString) -happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut105 #-} -happyIn106 :: (Maybe Range) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn106 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn106 #-} -happyOut106 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Maybe Range) -happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut106 #-} -happyIn107 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn107 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn107 #-} -happyOut107 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut107 #-} -happyIn108 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn108 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn108 #-} -happyOut108 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Expr]) -happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut108 #-} -happyIn109 :: ([TypedBindings] -> Parser ModuleApplication) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn109 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn109 #-} -happyOut109 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypedBindings] -> Parser ModuleApplication) -happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut109 #-} -happyIn110 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn110 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn110 #-} -happyOut110 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut110 #-} -happyIn111 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn111 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn111 #-} -happyOut111 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut111 #-} -happyIn112 :: (Name) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn112 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn112 #-} -happyOut112 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Name) -happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut112 #-} -happyIn113 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn113 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn113 #-} -happyOut113 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut113 #-} -happyIn114 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn114 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn114 #-} -happyOut114 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Declaration) -happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut114 #-} -happyIn115 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn115 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn115 #-} -happyOut115 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut115 #-} -happyIn116 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn116 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn116 #-} -happyOut116 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut116 #-} -happyIn117 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn117 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn117 #-} -happyOut117 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut117 #-} -happyIn118 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn118 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn118 #-} -happyOut118 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut118 #-} -happyIn119 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn119 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn119 #-} -happyOut119 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut119 #-} -happyIn120 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn120 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn120 #-} -happyOut120 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut120 #-} -happyIn121 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn121 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn121 #-} -happyOut121 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut121 #-} -happyIn122 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn122 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn122 #-} -happyOut122 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut122 #-} -happyIn123 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn123 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn123 #-} -happyOut123 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut123 #-} -happyIn124 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn124 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn124 #-} -happyOut124 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut124 #-} -happyIn125 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn125 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn125 #-} -happyOut125 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut125 #-} -happyIn126 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn126 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn126 #-} -happyOut126 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut126 #-} -happyIn127 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn127 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn127 #-} -happyOut127 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut127 #-} -happyIn128 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn128 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn128 #-} -happyOut128 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut128 #-} -happyIn129 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn129 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn129 #-} -happyOut129 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut129 #-} -happyIn130 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn130 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn130 #-} -happyOut130 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut130 #-} -happyIn131 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn131 #-} -happyOut131 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut131 #-} -happyIn132 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn132 #-} -happyOut132 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Pragma) -happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut132 #-} -happyIn133 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn133 #-} -happyOut133 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypeSignature]) -happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut133 #-} -happyIn134 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn134 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn134 #-} -happyOut134 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([TypeSignature]) -happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut134 #-} -happyIn135 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn135 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn135 #-} -happyOut135 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg TypeSignature]) -happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut135 #-} -happyIn136 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn136 #-} -happyOut136 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Arg TypeSignature]) -happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut136 #-} -happyIn137 :: ([Constructor]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn137 #-} -happyOut137 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Constructor]) -happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut137 #-} -happyIn138 :: ((Maybe (Ranged Induction), Maybe Name, [Declaration])) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn138 #-} -happyOut138 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ((Maybe (Ranged Induction), Maybe Name, [Declaration])) -happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut138 #-} -happyIn139 :: (Ranged Induction) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn139 #-} -happyOut139 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Ranged Induction) -happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut139 #-} -happyIn140 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn140 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn140 #-} -happyOut140 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut140 #-} -happyIn141 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn141 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn141 #-} -happyOut141 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut141 #-} -happyIn142 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn142 #-} -happyOut142 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut142 #-} -happyIn143 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyIn143 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyIn143 #-} -happyOut143 :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> ([Declaration]) -happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut143 #-} -happyInTok :: (Token) -> (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -happyInTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyInTok #-} -happyOutTok :: (HappyAbsSyn t10 t11 t12 t32 t35 t38 t39 t40 t44 t45 t72) -> (Token) -happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOutTok #-} - - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x00\x00\x4b\x09\xd7\x05\x00\x00\xe7\x04\xdb\x05\x8e\x04\xde\x05\x00\x00\xcc\x05\xd4\x05\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x01\x00\x00\x00\x00\x1a\x09\xf0\x08\xce\x05\x00\x00\xbe\x01\xc3\x05\x6b\x0b\x00\x00\x00\x00\x6f\x0f\xb9\x05\xb9\x05\x00\x00\x00\x00\x43\x0b\x00\x00\x00\x00\x0e\x02\x20\x0b\x00\x00\x00\x00\x42\x0b\x7a\x06\x3a\x06\x83\x07\x00\x00\x00\x00\x00\x00\xa9\x05\xbe\x05\x00\x00\xbb\x05\xa9\x02\xb6\x05\x00\x00\x00\x00\x9a\x02\x9a\x02\x00\x00\xb4\x05\xb2\x05\xb1\x05\xee\x05\xab\x05\xa4\x05\x4f\x03\x00\x00\x00\x00\x00\x00\x6c\x0f\xf0\x08\x00\x00\xa7\x05\x00\x00\x1f\x0b\x9b\x08\xfb\x03\xe1\x03\x00\x00\xbf\x08\x81\x08\xda\x09\x00\x00\xf8\x0a\x52\x07\x3a\x06\x17\x07\x15\x0a\x15\x0a\x15\x0a\xa3\x05\xf8\x0a\xe6\x06\x3a\x06\xab\x06\xe9\x05\xe8\x05\xf7\x0a\x57\x08\xa2\x05\xf7\x0a\x00\x00\xb0\x09\x15\x0a\x15\x0a\x99\x05\x94\x05\xe4\x05\x89\x05\x00\x00\xd8\x00\x15\x0a\x15\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x57\x08\x15\x0a\x57\x08\xf8\x0a\xe0\x05\x9b\x05\x5e\x03\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x05\x92\x05\x34\x00\xdf\xff\x88\x05\x88\x05\xd5\x0a\x90\x05\x57\x00\x57\x00\x57\x00\x82\x05\x82\x05\x82\x05\x82\x05\x86\x05\x86\x05\x86\x05\x70\x05\xa2\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x05\x66\x00\x7d\x05\x7a\x05\x7b\x05\x6e\x05\x77\x05\x76\x05\x74\x05\x65\x05\x63\x05\x63\x05\x63\x05\x63\x05\x63\x05\x63\x05\x63\x05\xb3\x05\xad\x0a\x73\x05\xd4\x0a\x3e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x00\x00\x9c\x02\xac\x0a\x89\x0a\x89\x0a\x00\x00\x00\x00\x89\x0a\x89\x0a\x00\x00\x8a\x0a\x62\x05\x00\x00\x62\x05\x00\x00\x00\x00\x00\x00\x89\x05\x00\x00\x00\x00\x06\x00\x57\x08\x57\x08\xb0\x05\x15\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x0a\x15\x0a\x15\x0a\x15\x0a\x0c\x00\x57\x08\x72\x05\x64\x05\x00\x00\x71\x05\x5c\x05\x61\x05\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x08\x57\x08\x15\x0a\x5a\x05\x9a\x02\x53\x05\x4e\x05\x9a\x02\x3a\x05\xdf\x00\x4d\x05\x00\x00\x63\x00\x37\x01\x48\x05\x46\x05\x42\x05\x00\x00\x15\x0a\x15\x0a\x00\x00\x15\x0a\x15\x0a\x61\x0a\x41\x05\x61\x0a\x26\x08\xe8\x07\x75\x09\x00\x00\x00\x00\x3c\x05\x11\x00\x00\x00\x47\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x07\x00\x00\x62\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb5\x00\xef\xff\xb5\x00\x15\x0a\x00\x00\x15\x0a\xbe\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x05\x2b\x05\x00\x00\xbe\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x07\x00\x00\x00\x00\x00\x00\x2e\x05\x62\x00\x00\x00\x27\x05\x39\x05\x00\x00\x3b\x00\x3e\x0a\x62\x0a\x61\x03\xfa\x05\x3e\x0a\x6f\x05\x3e\x0a\x9d\x00\x85\x00\x60\x00\x1d\x00\x15\x0a\x00\x00\x9c\x02\x2f\x05\x00\x00\x3b\x00\x42\x02\xed\x01\xcd\xff\xcd\xff\x61\x00\x00\x00\x00\x00\x00\x00\x91\x03\x00\x00\x00\x00\x00\x00\x29\x05\xec\xff\xec\xff\x00\x00\x00\x00\x28\x05\xbe\x07\x21\x05\xe1\x04\x1b\x05\x00\x00\x17\x05\x17\x05\x17\x05\x16\x05\x15\x05\x12\x05\x14\x05\x00\x00\x00\x00\x00\x00\x00\x00\x13\x05\x00\x00\x0e\x05\xf8\x04\x08\x05\x08\x05\xf7\x04\xfd\x04\x00\x00\x00\x00\xf6\x04\xf5\x04\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x04\xf0\x04\x00\x00\x8b\x04\xef\x04\xee\x04\xed\x04\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x07\x91\x04\x98\x04\x89\x04\x8c\x04\x94\x04\x88\x04\x00\x00\x88\x04\x00\x00\xcd\xff\x82\x04\x7b\x04\x15\x02\x00\x00\x7b\x04\x7b\x04\x7b\x04\x7b\x04\x00\x00\x9c\x02\xbe\x07\x00\x00\xf5\x00\x86\x04\xbe\x07\x84\x04\xbe\x07\x84\x04\xbe\x07\x7f\x04\x47\x03\x00\x00\x7f\x04\x00\x00\x15\x02\x00\x00\x00\x00\x61\x03\x00\x00\x00\x00\x83\x04\x81\x04\x80\x04\x00\x00\x00\x00\x7d\x04\x00\x00\x6c\x04\xbe\x07\x00\x00\xbc\x04\xbb\x04\x00\x00\x00\x00\x3b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x03\x00\x00\x00\x00\x6d\x04\x6d\x04\x00\x00\x00\x00\x47\x03\xf5\xff\x2e\x00\x2e\x00\x00\x00\x61\x03\x00\x00\x3f\x0a\x61\x03\x00\x00\xb9\x04\x00\x00\x00\x00\x2d\x00\xb8\x04\x00\x00\x99\x04\x00\x00\xe2\x03\x00\x00\x00\x00\x6b\x04\x15\x02\x6a\x04\x15\x02\x9c\x02\x9c\x02\x00\x00\x63\x04\x00\x00\x71\x04\xec\xff\x00\x00\x70\x04\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x04\x00\x00\x59\x04\x39\x04\x4e\x04\x00\x00\x00\x00\x00\x00\x9c\x02\x9c\x02\x9c\x02\x9c\x02\x00\x00\x3b\x00\x3b\x00\x0c\x00\x4d\x04\x00\x00\x00\x00\x49\x04\x48\x04\x00\x00\x48\x04\x00\x00\x00\x00\xba\x05\x00\x00\x00\x00\x56\x04\x47\x04\x00\x00\x38\x04\x3f\x04\x36\x04\x3d\x04\x43\x04\x74\x04\x00\x00\x00\x00\x61\x03\x00\x00\x00\x00\x00\x00\x2e\x04\x2e\x04\x6f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x15\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x05\x00\x00\x89\x05\x00\x00\x00\x00\x00\x00\x00\x00\x31\x04\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x3b\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x05\x00\x00\x0c\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x83\x03\x81\x0f\x7a\x04\x79\x04\x76\x04\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x08\x66\x0f\x00\x00\x00\x00\x58\x03\xe0\x03\x9f\x00\x00\x00\x00\x00\xda\x01\x6e\x04\x5e\x04\x00\x00\x00\x00\x8d\x05\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x69\x01\xb0\x03\x42\x06\xe3\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x04\x5d\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x03\x71\x02\x00\x00\x00\x00\x00\x00\x37\x04\x4b\x0f\x00\x00\x00\x00\x00\x00\x41\x03\x00\x00\xcc\x00\xa7\x00\x00\x00\x0b\x01\x23\x0c\x7c\x01\x00\x00\xe4\x02\xc7\x0b\x02\x06\xab\x0b\x34\x0d\x18\x0d\x11\x0d\x00\x00\x44\x05\x30\x0f\x82\x06\x15\x0f\x00\x00\x00\x00\x35\x04\xfa\x0e\x00\x00\xdc\x03\x00\x00\x0b\x01\xf5\x0c\xee\x0c\x00\x00\x7e\x01\x00\x00\x3a\x03\x00\x00\x00\x00\xd2\x0c\xcb\x0c\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x0e\x42\x03\xc4\x0e\x8b\x02\x1b\x04\x00\x00\x17\x04\x5c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x03\xd0\x03\x71\x02\x1c\x00\x45\x04\x34\x04\x9e\x00\xb8\x03\x2c\x04\x2a\x04\x29\x04\xa4\x03\xa2\x03\x9e\x03\x9d\x03\x18\x04\x16\x04\x15\x04\xcd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x03\x00\x00\xea\x03\x00\x00\x00\x00\xd8\x03\x00\x00\x00\x00\x00\x00\xd7\x03\xd4\x03\xcf\x03\xcc\x03\xc9\x03\xc8\x03\xc6\x03\xc4\x03\x8f\x03\x92\x04\x00\x00\x01\x00\xaa\x02\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x02\x00\x00\x00\x00\xdb\x01\xbb\x01\x00\x00\x18\x00\x3f\x03\x3c\x03\xcc\x02\x00\x00\x00\x00\xc9\x02\xc6\x02\x00\x00\xf0\x00\xbf\x03\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\xc4\x02\x00\x00\x00\x00\x80\x03\xa9\x0e\x8e\x0e\x8e\x03\xc5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x01\xaf\x0c\xa8\x0c\x8c\x0c\xc1\x03\x73\x0e\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\xba\x03\x00\x00\x00\x00\x00\x00\x00\x00\x58\x0e\x3d\x0e\x56\x02\x00\x00\xb6\x03\x00\x00\x00\x00\xb5\x03\x00\x00\x00\x00\x00\x00\x00\x00\x85\x03\x63\x03\x00\x00\x00\x00\x00\x00\x00\x00\x85\x0c\x69\x0c\x00\x00\x62\x0c\x46\x0c\x55\x02\x00\x00\x52\x02\x0b\x01\x1c\x0c\x3f\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x0e\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x65\x03\x5f\x07\x00\x00\xf3\x06\x07\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\xec\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x0d\x00\x00\x00\x00\x00\x00\xf8\x02\x16\x00\x00\x00\x3d\x03\x00\x00\x00\x00\x76\x03\x50\x02\x92\x00\xd3\x03\x82\x06\xe0\x01\x00\x00\xdd\x01\x00\x00\x00\x00\x00\x00\x00\x00\xff\x0b\x00\x00\x81\x02\x00\x00\x00\x00\x74\x03\x00\x00\x4a\x03\xf3\x01\xb6\x01\xb7\x01\x00\x00\x00\x00\x00\x00\x32\x02\x00\x00\x00\x00\x00\x00\x00\x00\x04\x03\xec\x02\x00\x00\x00\x00\x00\x00\xb6\x0d\x00\x03\xd0\x02\x00\x00\x00\x00\xfb\x02\xf9\x02\xf3\x02\x00\x00\xe1\x02\xdb\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x02\xd3\x02\x00\x00\xbf\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x0d\x00\x00\x00\x00\x3c\x02\x00\x00\x00\x00\xd4\x01\x00\x00\xeb\x00\x00\x00\x46\x01\x00\x00\x18\x02\x5c\x02\x00\x00\x25\x03\x21\x03\xcf\x02\xaf\x02\x00\x00\xcb\x00\x80\x0d\x00\x00\x00\x00\x64\x01\x65\x0d\x0e\x01\x4a\x0d\xf4\x00\x1c\x0a\xa0\x02\x20\x00\x00\x00\x73\x02\x00\x00\x38\x02\x00\x00\x00\x00\x75\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\xb7\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x03\x00\x00\x00\x00\x4a\x02\x2e\x02\x00\x00\x00\x00\xff\xff\x2f\x01\x0a\x01\xf1\x00\x00\x00\x82\x03\x00\x00\x39\x00\x5f\x03\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\x1e\x02\x00\x00\xba\x01\x2c\x02\x16\x02\x00\x00\xac\x01\x00\x00\x00\x00\x35\x02\x00\x00\x00\x00\x21\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x01\x00\x00\xa1\x01\x00\x00\x00\x00\x00\x00\x9b\x01\x6d\x01\x17\x01\xca\x00\x00\x00\x77\x02\xea\x01\xbc\x01\x85\x01\x00\x00\x00\x00\x24\x01\xb3\xff\x00\x00\x91\xff\x00\x00\x00\x00\x82\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x01\x00\x00\x27\x01\x00\x00\x00\x00\x00\x00\x23\x01\x00\x00\xe9\x02\x00\x00\x00\x00\x00\x00\x30\x00\x08\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x01\x00\x00\x4e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\xf7\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x01\x00\x00\x40\x00\x00\x00\x00\x00"# - -happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\xa6\xfe\x7f\xff\x5a\xff\x00\x00\x6e\xff\x6d\xff\x6b\xff\x6a\xff\x67\xff\x00\x00\x48\xff\x47\xff\x65\xff\x00\x00\x00\x00\x40\xff\x3e\xff\x00\x00\x00\x00\x56\xff\x55\xff\x00\x00\x00\x00\x00\x00\x54\xff\x53\xff\x00\x00\x52\xff\x51\xff\x00\x00\x00\x00\x57\xff\x58\xff\x00\x00\xa6\xfe\x00\x00\x00\x00\x97\xff\x80\xff\x59\xff\x00\x00\x00\x00\x79\xff\x00\x00\x78\xff\x00\x00\x5b\xff\x4d\xff\x00\x00\x00\x00\x94\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\xfe\x4e\xff\x7d\xff\x11\xff\x25\xff\x00\x00\x5f\xff\x00\x00\x30\xff\x2d\xff\x26\xff\x00\x00\x00\x00\x7c\xff\xa6\xfe\x00\x00\x00\x00\x4b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\xff\x5e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\xff\x00\x00\x00\x00\x17\xff\x12\xff\xa6\xfe\x00\x00\x00\x00\x00\x00\x46\xff\x00\x00\xa6\xfe\x3f\xff\x00\x00\x00\x00\x00\x00\x41\xff\x72\xff\x69\xff\x5d\xff\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfe\x00\x00\xce\xfe\x5e\xfe\xe6\xfe\xe5\xfe\xe4\xfe\xe3\xfe\xe2\xfe\xe1\xfe\xe7\xfe\xe0\xfe\xdf\xfe\xde\xfe\xdd\xfe\xdc\xfe\xdb\xfe\xd4\xfe\xd6\xfe\xd5\xfe\xda\xfe\xd9\xfe\xd8\xfe\xa0\xff\xd7\xfe\x98\xfe\x87\xfe\x97\xfe\x96\xfe\x95\xfe\x94\xfe\x92\xfe\x93\xfe\x91\xfe\x90\xfe\x8f\xfe\x8c\xfe\x89\xfe\x8a\xfe\x8b\xfe\x88\xfe\x8e\xfe\x8d\xfe\x5c\xfe\x99\xfe\x00\x00\x00\x00\xa7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xfe\x00\x00\xfb\xff\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf5\xff\xf4\xff\xf3\xff\xf2\xff\xf1\xff\xf0\xff\xef\xff\xee\xff\xed\xff\xec\xff\xeb\xff\xea\xff\xe9\xff\xe8\xff\xe7\xff\xe6\xff\xe5\xff\xe4\xff\xe3\xff\xe2\xff\xe1\xff\xe0\xff\xdf\xff\xde\xff\xdd\xff\xdc\xff\xdb\xff\xda\xff\xd9\xff\xd8\xff\xd7\xff\xd6\xff\xd5\xff\xd4\xff\xcc\xff\xcb\xff\xca\xff\xc9\xff\xc8\xff\xc7\xff\xd3\xff\xd2\xff\xd1\xff\xd0\xff\xcf\xff\xce\xff\xcd\xff\xc6\xff\xc5\xff\xc4\xff\xc3\xff\xc2\xff\xc1\xff\xc0\xff\xbf\xff\xbe\xff\xbd\xff\xbc\xff\xbb\xff\xba\xff\xb9\xff\xb8\xff\xb7\xff\xb6\xff\xb5\xff\xb4\xff\xb3\xff\xb2\xff\xb1\xff\xb0\xff\xaf\xff\xae\xff\xad\xff\xac\xff\xab\xff\xaa\xff\xa9\xff\xa8\xff\xa7\xff\xa6\xff\xa5\xff\xa4\xff\xa3\xff\xa2\xff\x77\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfe\x00\x00\x00\x00\xb7\xfe\x00\x00\xbd\xfe\xbe\xfe\xbf\xfe\xc0\xfe\x00\x00\x98\xff\x99\xff\x00\x00\x00\x00\xc1\xfe\x00\x00\x13\xff\x13\xff\x13\xff\x7f\xff\x7e\xff\x13\xff\x13\xff\x9a\xfe\xa2\xfe\x00\x00\xbb\xfe\x00\x00\xbc\xfe\xa1\xff\x9f\xff\xa6\xfe\x9c\xff\x9b\xff\xeb\xfe\x00\x00\x00\x00\xef\xfe\x00\x00\x4c\xff\x6f\xff\x6c\xff\x70\xff\x78\xff\x65\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\xff\x44\xff\x46\xff\x79\xff\x00\x00\x19\xff\x1a\xff\x71\xff\x18\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\xff\x00\x00\x1b\xff\x00\x00\x00\x00\x23\xff\x22\xff\x24\xff\x10\xff\x00\x00\x00\x00\x0f\xff\x00\x00\x00\x00\x2c\xff\x28\xff\x2d\xff\xa6\xfe\x00\x00\x00\x00\x31\xff\x68\xff\x27\xff\x00\x00\x34\xff\x00\x00\x37\xff\x4f\xff\x93\xff\x36\xff\x50\xff\x35\xff\x5c\xff\x00\x00\x32\xff\xa2\xfe\x33\xff\x2a\xff\x29\xff\x2b\xff\x2f\xff\x2e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xff\x00\x00\x00\x00\x3d\xff\x3b\xff\x3c\xff\x3a\xff\x38\xff\x39\xff\x61\xff\x63\xff\x64\xff\x0d\xff\x0e\xff\x00\x00\x00\x00\x4a\xff\x00\x00\x66\xff\x62\xfe\x9d\xff\x9e\xff\xec\xfe\xf3\xfe\x00\x00\xd0\xfe\xcf\xfe\xd1\xfe\x00\x00\x00\x00\x5f\xfe\x95\xff\x00\x00\x72\xfe\x00\x00\x13\xff\xa2\xfe\x06\xff\x00\x00\x13\xff\x00\x00\x13\xff\x00\x00\x00\x00\x00\x00\x00\x00\x46\xff\x91\xff\x8d\xff\x00\x00\x6f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\xff\xc4\xfe\xc3\xfe\xc2\xfe\x00\x00\xb3\xfe\xb1\xfe\xac\xfe\x00\x00\x00\x00\x00\x00\xa8\xfe\xb6\xfe\x00\x00\x00\x00\xf1\xfe\xef\xfe\x00\x00\x73\xff\x77\xff\x77\xff\x77\xff\x00\x00\x00\x00\x77\xff\x00\x00\x74\xff\x78\xfe\x79\xfe\x7a\xfe\x00\x00\x75\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\xff\x76\xff\x86\xfe\x00\x00\x00\x00\x83\xfe\x76\xfe\x7b\xfe\x77\xfe\x00\x00\x00\x00\x75\xff\x77\xff\x00\x00\x00\x00\x00\x00\x7c\xfe\xf2\xfe\xf0\xfe\xba\xfe\x00\x00\x00\x00\xaa\xfe\x00\x00\x00\x00\xaa\xfe\x00\x00\xb2\xfe\x00\x00\x7b\xff\x8f\xff\x00\x00\x00\x00\x00\x00\x92\xff\x00\x00\x00\x00\x00\x00\x00\x00\x71\xfe\x00\x00\x00\x00\x8e\xff\x7f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\xff\x00\x00\x14\xff\x00\x00\xa4\xfe\x08\xff\x06\xff\x04\xff\x03\xff\x00\x00\x00\x00\x00\x00\x05\xff\xa1\xfe\x00\x00\x74\xfe\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x60\xfe\xea\xfe\x00\x00\xee\xfe\x42\xff\x43\xff\x49\xff\x21\xff\x20\xff\x1f\xff\x1e\xff\x1c\xff\x1d\xff\x0b\xff\x0c\xff\x09\xff\x0a\xff\x06\xff\xa5\xfe\x61\xfe\x00\x00\x00\x00\xd3\xfe\x73\xfe\x00\x00\x9a\xff\xf7\xfe\xf7\xfe\x07\xff\x06\xff\x9b\xfe\xa2\xfe\x06\xff\x9c\xfe\xc9\xfe\x6d\xfe\xcb\xfe\x00\x00\x00\x00\xca\xfe\xc6\xfe\xc7\xfe\x00\x00\xd2\xfe\x70\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x8b\xff\x89\xff\x90\xff\xb9\xfe\xb5\xfe\x00\x00\x00\x00\xaf\xfe\x00\x00\x00\x00\xb0\xfe\xb8\xfe\x7d\xfe\x7e\xfe\x80\xfe\x00\x00\x81\xfe\x82\xfe\x84\xfe\x85\xfe\x7f\xfe\x00\x00\xaa\xfe\x00\x00\x00\x00\x00\x00\xb4\xfe\x8a\xff\x8c\xff\x85\xff\x87\xff\x81\xff\x83\xff\x6c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x63\xfe\x00\x00\x00\x00\x6e\xfe\x00\x00\x9e\xfe\x9f\xfe\x00\x00\xa3\xfe\xf9\xfe\xf5\xfe\x00\x00\xf6\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfe\x00\x00\x9a\xff\xff\xfe\x06\xff\xe9\xfe\xe8\xfe\x9d\xfe\x00\x00\x00\x00\x9a\xff\x00\xff\xfb\xfe\x01\xff\xf8\xfe\x02\xff\x00\x00\x00\x00\xcd\xfe\xcc\xfe\xc8\xfe\xc5\xfe\x69\xfe\x68\xfe\xa6\xfe\x6b\xfe\xa6\xfe\x84\xff\x82\xff\x88\xff\x86\xff\x00\x00\xad\xfe\xa9\xfe\xae\xfe\xab\xfe\x00\x00\x00\x00\x00\x00\xa0\xfe\xf4\xfe\xfe\xfe\xfc\xfe\xfa\xfe\x65\xfe\x67\xfe\xa6\xfe\x6a\xfe\x00\x00\x66\xfe"# - -happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x09\x00\x0f\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x03\x00\x09\x00\x0f\x00\x00\x00\x40\x00\x0f\x00\x10\x00\x7f\x00\x09\x00\x11\x00\x02\x00\x83\x00\x0f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x09\x00\x03\x00\x09\x00\x55\x00\x44\x00\x0c\x00\x09\x00\x0e\x00\x09\x00\x0a\x00\x09\x00\x29\x00\x0f\x00\x10\x00\x00\x00\x2d\x00\x0f\x00\x10\x00\x42\x00\x7f\x00\x47\x00\x55\x00\x56\x00\x83\x00\x36\x00\x37\x00\x09\x00\x40\x00\x00\x00\x42\x00\x0f\x00\x4f\x00\x43\x00\x4b\x00\x55\x00\x09\x00\x0f\x00\x48\x00\x05\x00\x49\x00\x4b\x00\x0f\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x20\x00\x21\x00\x22\x00\x4b\x00\x51\x00\x5d\x00\x42\x00\x64\x00\x65\x00\x4a\x00\x03\x00\x68\x00\x69\x00\x67\x00\x49\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x41\x00\x80\x00\x51\x00\x09\x00\x6a\x00\x85\x00\x55\x00\x55\x00\x88\x00\x0f\x00\x6a\x00\x67\x00\x03\x00\x55\x00\x56\x00\x25\x00\x51\x00\x52\x00\x05\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x05\x00\x82\x00\x09\x00\x09\x00\x0a\x00\x80\x00\x66\x00\x03\x00\x0f\x00\x42\x00\x09\x00\x41\x00\x44\x00\x44\x00\x09\x00\x09\x00\x0f\x00\x24\x00\x25\x00\x55\x00\x0f\x00\x0f\x00\x58\x00\x09\x00\x44\x00\x20\x00\x21\x00\x22\x00\x52\x00\x55\x00\x55\x00\x11\x00\x43\x00\x20\x00\x21\x00\x22\x00\x57\x00\x48\x00\x21\x00\x21\x00\x4b\x00\x55\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x42\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x09\x00\x09\x00\x09\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x64\x00\x65\x00\x49\x00\x11\x00\x68\x00\x69\x00\x43\x00\x07\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x42\x00\x42\x00\x66\x00\x09\x00\x09\x00\x0f\x00\x05\x00\x06\x00\x88\x00\x0f\x00\x66\x00\x09\x00\x4d\x00\x4f\x00\x4f\x00\x41\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0b\x00\x20\x00\x21\x00\x22\x00\x09\x00\x09\x00\x4a\x00\x52\x00\x3d\x00\x3e\x00\x3f\x00\x0f\x00\x23\x00\x24\x00\x25\x00\x13\x00\x14\x00\x09\x00\x42\x00\x4a\x00\x0c\x00\x4c\x00\x0e\x00\x4e\x00\x1c\x00\x1d\x00\x1e\x00\x07\x00\x20\x00\x21\x00\x22\x00\x4f\x00\x43\x00\x09\x00\x40\x00\x41\x00\x42\x00\x48\x00\x2a\x00\x07\x00\x4b\x00\x43\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x48\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5e\x00\x40\x00\x41\x00\x42\x00\x09\x00\x63\x00\x09\x00\x64\x00\x65\x00\x0c\x00\x0d\x00\x68\x00\x69\x00\x66\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x3d\x00\x3e\x00\x3f\x00\x64\x00\x65\x00\x0f\x00\x09\x00\x7f\x00\x88\x00\x89\x00\x09\x00\x83\x00\x41\x00\x0c\x00\x11\x00\x0e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x09\x00\x4f\x00\x09\x00\x4a\x00\x52\x00\x4c\x00\x0f\x00\x4e\x00\x7f\x00\x09\x00\x13\x00\x14\x00\x83\x00\x29\x00\x55\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x36\x00\x37\x00\x23\x00\x24\x00\x25\x00\x09\x00\x43\x00\x2a\x00\x0c\x00\x84\x00\x0e\x00\x48\x00\x2f\x00\x30\x00\x4b\x00\x32\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x09\x00\x09\x00\x05\x00\x0c\x00\x0d\x00\x09\x00\x0b\x00\x64\x00\x65\x00\x11\x00\x12\x00\x68\x00\x69\x00\x11\x00\x12\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x46\x00\x09\x00\x09\x00\x49\x00\x09\x00\x0f\x00\x84\x00\x09\x00\x88\x00\x11\x00\x11\x00\x12\x00\x11\x00\x05\x00\x06\x00\x11\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x09\x00\x09\x00\x3f\x00\x40\x00\x0c\x00\x0d\x00\x0f\x00\x10\x00\x29\x00\x63\x00\x09\x00\x29\x00\x63\x00\x4a\x00\x29\x00\x4c\x00\x0f\x00\x4e\x00\x33\x00\x34\x00\x63\x00\x36\x00\x37\x00\x35\x00\x36\x00\x37\x00\x35\x00\x36\x00\x37\x00\x1c\x00\x1d\x00\x1e\x00\x43\x00\x20\x00\x21\x00\x22\x00\x09\x00\x48\x00\x09\x00\x0c\x00\x4b\x00\x0e\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x0b\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x09\x00\x09\x00\x63\x00\x0c\x00\x4c\x00\x0e\x00\x4e\x00\x64\x00\x65\x00\x11\x00\x12\x00\x68\x00\x69\x00\x55\x00\x0b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x4a\x00\x09\x00\x4c\x00\x09\x00\x4e\x00\x0f\x00\x09\x00\x09\x00\x88\x00\x11\x00\x4d\x00\x11\x00\x4f\x00\x0f\x00\x11\x00\x0b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x29\x00\x09\x00\x29\x00\x05\x00\x06\x00\x29\x00\x2d\x00\x0f\x00\x10\x00\x2d\x00\x62\x00\x63\x00\x35\x00\x36\x00\x37\x00\x36\x00\x37\x00\x09\x00\x36\x00\x37\x00\x0c\x00\x4c\x00\x0e\x00\x4e\x00\x43\x00\x60\x00\x61\x00\x09\x00\x63\x00\x48\x00\x62\x00\x63\x00\x4b\x00\x0f\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x63\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x20\x00\x21\x00\x22\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x64\x00\x65\x00\x86\x00\x87\x00\x68\x00\x69\x00\x09\x00\x0a\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x15\x00\x09\x00\x86\x00\x87\x00\x09\x00\x0f\x00\x15\x00\x09\x00\x88\x00\x11\x00\x09\x00\x0a\x00\x11\x00\x3f\x00\x40\x00\x11\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x4d\x00\x4c\x00\x4f\x00\x4e\x00\x18\x00\x43\x00\x09\x00\x18\x00\x29\x00\x15\x00\x55\x00\x29\x00\x0f\x00\x4b\x00\x29\x00\x4d\x00\x16\x00\x4f\x00\x86\x00\x87\x00\x35\x00\x36\x00\x37\x00\x35\x00\x36\x00\x37\x00\x35\x00\x36\x00\x37\x00\x20\x00\x21\x00\x22\x00\x43\x00\x15\x00\x5f\x00\x60\x00\x61\x00\x48\x00\x63\x00\x15\x00\x4b\x00\x15\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x45\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x86\x00\x87\x00\x64\x00\x65\x00\x09\x00\x0a\x00\x68\x00\x69\x00\x09\x00\x0a\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x44\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x0f\x00\x09\x00\x09\x00\x88\x00\x11\x00\x62\x00\x63\x00\x11\x00\x0f\x00\x11\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x29\x00\x62\x00\x63\x00\x29\x00\x06\x00\x29\x00\x0a\x00\x0b\x00\x0c\x00\x2d\x00\x0e\x00\x0b\x00\x35\x00\x36\x00\x37\x00\x35\x00\x36\x00\x37\x00\x36\x00\x37\x00\x05\x00\x06\x00\x05\x00\x06\x00\x43\x00\x86\x00\x87\x00\x28\x00\x29\x00\x48\x00\x00\x00\x01\x00\x4b\x00\x0b\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x06\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x55\x00\x56\x00\x64\x00\x65\x00\x42\x00\x43\x00\x68\x00\x69\x00\x55\x00\x56\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x0f\x00\x0b\x00\x0b\x00\x88\x00\x13\x00\x14\x00\x0b\x00\x05\x00\x47\x00\x09\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x45\x00\x43\x00\x46\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x4a\x00\x18\x00\x4c\x00\x18\x00\x4e\x00\x18\x00\x18\x00\x00\x00\x01\x00\x18\x00\x09\x00\x55\x00\x18\x00\x06\x00\x07\x00\x08\x00\x09\x00\x18\x00\x11\x00\x17\x00\x15\x00\x18\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x18\x00\x21\x00\x22\x00\x29\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x34\x00\x44\x00\x36\x00\x37\x00\x64\x00\x65\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x09\x00\x09\x00\x3e\x00\x09\x00\x40\x00\x86\x00\x86\x00\x44\x00\x44\x00\x45\x00\x86\x00\x47\x00\x86\x00\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\x08\x00\x08\x00\x51\x00\x08\x00\x53\x00\x55\x00\x55\x00\x56\x00\x81\x00\x58\x00\x00\x00\x01\x00\x09\x00\x09\x00\x44\x00\x09\x00\x06\x00\x07\x00\x08\x00\x09\x00\x4a\x00\x11\x00\x4c\x00\x11\x00\x4e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x09\x00\x7f\x00\x55\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x86\x00\x21\x00\x22\x00\x29\x00\x04\x00\x29\x00\x46\x00\x06\x00\x4c\x00\x2d\x00\x86\x00\x86\x00\x09\x00\x0b\x00\x34\x00\x0b\x00\x36\x00\x37\x00\x36\x00\x37\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x09\x00\x02\x00\x3e\x00\x01\x00\x40\x00\x4b\x00\x03\x00\x0f\x00\x44\x00\x45\x00\x0d\x00\x47\x00\x55\x00\x41\x00\x4a\x00\x4d\x00\x4c\x00\x4b\x00\x4e\x00\x4b\x00\x55\x00\x51\x00\x55\x00\x53\x00\x01\x00\x55\x00\x56\x00\x4b\x00\x58\x00\x06\x00\x07\x00\x08\x00\x41\x00\x50\x00\x50\x00\x4f\x00\x09\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0f\x00\x55\x00\x55\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x55\x00\x21\x00\x22\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x54\x00\x46\x00\x46\x00\x55\x00\x4f\x00\x4f\x00\x03\x00\x03\x00\x50\x00\x03\x00\x03\x00\x43\x00\x55\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x4a\x00\x4a\x00\x3e\x00\x4a\x00\x40\x00\x50\x00\x55\x00\x4f\x00\x44\x00\x45\x00\x50\x00\x47\x00\x50\x00\x43\x00\x4a\x00\x4d\x00\x4c\x00\x43\x00\x4e\x00\x55\x00\x55\x00\x51\x00\x4f\x00\x53\x00\x57\x00\x55\x00\x56\x00\x04\x00\x58\x00\x59\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x01\x00\x54\x00\x54\x00\x54\x00\x54\x00\x06\x00\x07\x00\x08\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x09\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0f\x00\x57\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x57\x00\x21\x00\x22\x00\x54\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x54\x00\x54\x00\x57\x00\x49\x00\x43\x00\x57\x00\x57\x00\x57\x00\x54\x00\x47\x00\x42\x00\x03\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x42\x00\x55\x00\x3e\x00\x50\x00\x40\x00\x55\x00\x4f\x00\x46\x00\x44\x00\x45\x00\x4b\x00\x47\x00\x46\x00\x46\x00\x4a\x00\x01\x00\x4c\x00\x46\x00\x4e\x00\x46\x00\x06\x00\x07\x00\x08\x00\x53\x00\x46\x00\x55\x00\x56\x00\x09\x00\x58\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0f\x00\x4f\x00\x4b\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x4f\x00\x21\x00\x22\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x4f\x00\x55\x00\x41\x00\x4f\x00\x04\x00\x43\x00\x43\x00\x55\x00\x05\x00\x49\x00\x57\x00\x01\x00\x57\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x57\x00\x51\x00\x3e\x00\x54\x00\x40\x00\x54\x00\x54\x00\x12\x00\x44\x00\x45\x00\x54\x00\x47\x00\x57\x00\x50\x00\x4a\x00\x57\x00\x4c\x00\x57\x00\x4e\x00\x1e\x00\x1f\x00\x20\x00\x55\x00\x53\x00\x55\x00\x55\x00\x56\x00\x50\x00\x58\x00\x50\x00\x50\x00\x49\x00\x05\x00\x02\x00\x4e\x00\x46\x00\x55\x00\x02\x00\x02\x00\x49\x00\x46\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x50\x00\x3b\x00\x4b\x00\x09\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x4b\x00\x4b\x00\x44\x00\x45\x00\x42\x00\x47\x00\x59\x00\x4f\x00\x4a\x00\x4f\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x4f\x00\x09\x00\x12\x00\x0b\x00\x55\x00\x55\x00\x56\x00\x0f\x00\x58\x00\x50\x00\x46\x00\x13\x00\x14\x00\x43\x00\x1e\x00\x1f\x00\x20\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x59\x00\x48\x00\x50\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x59\x00\x3b\x00\xff\xff\xff\xff\x3e\x00\x3f\x00\x40\x00\x01\x00\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\x09\x00\x12\x00\x0b\x00\xff\xff\x55\x00\x56\x00\x0f\x00\x58\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1e\x00\x1f\x00\x20\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x3f\x00\x40\x00\x01\x00\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x08\x00\xff\xff\x4a\x00\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\x09\x00\x12\x00\x0b\x00\xff\xff\x55\x00\x56\x00\x0f\x00\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\x1f\x00\x20\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x0f\x00\x58\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x2f\x00\x30\x00\x31\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x0f\x00\x58\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x2f\x00\x30\x00\x31\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x1e\x00\x1f\x00\x20\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x01\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\x08\x00\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x12\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1f\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x01\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\x08\x00\x47\x00\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x3f\x00\x40\x00\xff\xff\x1e\x00\x1f\x00\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\x46\x00\x47\x00\xff\xff\x49\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x08\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x1e\x00\x1f\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x01\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x1e\x00\x1f\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x09\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x55\x00\x56\x00\xff\xff\x58\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x09\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x09\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x09\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x09\x00\xff\xff\x0b\x00\xff\xff\x2a\x00\xff\xff\x0f\x00\x09\x00\xff\xff\x0b\x00\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x1e\x00\xff\xff\x20\x00\x21\x00\x22\x00\x2a\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x09\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x09\x00\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\xff\xff\x26\x00\x27\x00\x28\x00\x29\x00\x3f\x00\x40\x00\xff\xff\x3f\x00\x40\x00\x44\x00\xff\xff\x46\x00\x44\x00\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\x4a\x00\x4e\x00\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\x55\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x8f\x02\x98\x02\x9e\x02\xa9\x02\x07\x00\xb6\x01\xb7\x01\x35\x01\xb4\x01\x41\x00\x08\x00\xac\x01\x15\x02\x36\x01\x5c\x02\x60\x02\xd0\x02\x42\x00\x54\x01\xb8\x02\xb5\x01\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x3b\x02\x21\x02\xc6\x01\x2c\x00\x3a\x01\xc7\x01\x35\x01\xc8\x01\xb6\x01\xb7\x01\x35\x01\x76\x01\x36\x01\x37\x01\xac\x01\xdb\x01\x36\x01\x5c\x02\x8a\x01\x60\x02\x0c\x02\x2c\x00\x2d\x00\xb9\x02\x78\x01\x63\x00\xd1\x02\x9f\x02\xac\x01\xce\x02\xa3\x02\x4c\x02\x79\x00\xaa\x02\xdb\x01\x07\x00\x3c\x01\x7a\x00\xd7\x02\xb8\x01\x7b\x00\x08\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x90\x02\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x10\x00\x11\x00\xbb\x01\x8d\x01\xad\x01\xdc\x01\x22\x02\x3c\x00\x8b\x00\xc9\x01\x23\x02\x8c\x00\x8d\x00\xaa\x02\xb8\x01\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x50\x02\x43\x01\xb9\x01\xad\x01\x07\x00\x3c\x02\x91\x02\x2c\x00\x2c\x00\x92\x02\x08\x00\x38\x01\x5d\x02\x25\x02\x2c\x00\x2d\x00\xf2\x01\xad\x01\x44\x01\xd2\x02\x54\x01\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\xd5\x02\xca\x01\x07\x00\xb6\x01\xb7\x01\xb9\x01\x9b\x02\x27\x02\x08\x00\x24\x02\x07\x00\x43\x01\x4d\x00\x3a\x01\x07\x00\x07\x00\x08\x00\x42\x02\x57\x01\x2d\x01\x08\x00\x08\x00\x2e\x01\x41\x00\x4d\x00\x10\x00\x11\x00\xbb\x01\x44\x01\x2c\x00\x2c\x00\x70\x01\x79\x00\x10\x00\x11\x00\xbb\x01\xf3\x01\x7a\x00\x32\x01\x67\x00\x7b\x00\x2c\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x26\x02\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\xc6\x01\xc6\x01\x41\x00\xc7\x01\xc7\x01\xc1\x02\xc8\x01\x3c\x00\x8b\x00\x54\x02\x73\x01\x8c\x00\x8d\x00\x28\x02\xa4\x02\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\x8a\x01\x8a\x01\x35\x02\x07\x00\x9e\x02\x08\x00\xd3\x02\xd4\x02\x52\x01\x08\x00\x4e\x02\x54\x01\x39\x00\x4e\x02\x3a\x00\x43\x01\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\xcd\x02\x10\x00\x11\x00\xbb\x01\x9e\x02\x07\x00\x69\x02\x44\x01\xcf\x02\xa6\x02\xa7\x02\x08\x00\xa5\x01\x56\x01\x57\x01\x2f\x00\x30\x00\xc6\x01\x78\xff\x50\x01\xc7\x01\x51\x01\xc2\x02\x52\x01\x4d\x01\x0d\x00\x0e\x00\xae\x02\x10\x00\x11\x00\x4e\x01\x78\xff\x79\x00\xb2\x02\x9f\x02\xa0\x02\xa1\x02\x7a\x00\x3b\x00\xa4\x02\x7b\x00\xa9\x01\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x71\x02\x9f\x02\xa3\x02\xa1\x02\xb4\x02\x72\x02\xc6\x01\x3c\x00\x8b\x00\x12\x02\x70\x02\x8c\x00\x8d\x00\xbc\x01\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\xa5\x02\xa6\x02\xa7\x02\x3c\x00\x3d\x00\x08\x00\x41\x00\x60\x02\xa2\x00\xa3\x00\xc6\x01\x61\x02\x43\x01\xc7\x01\x42\x00\xc3\x02\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x07\x00\x98\x01\x54\x01\xd8\x01\x44\x01\xd9\x01\x08\x00\xda\x01\x60\x02\xbb\x02\x2f\x00\x59\x01\x64\x02\x43\x00\xdb\x01\x44\x00\x45\x00\x46\x00\x47\x00\x68\x01\x0d\x00\x0e\x00\x69\x01\x10\x00\x11\x00\x12\x00\x48\x00\x49\x00\x55\x01\x56\x01\x57\x01\xc6\x01\x79\x00\x33\x00\xc7\x01\xba\x02\xc4\x02\x7a\x00\x6a\x01\x6b\x01\x7b\x00\x6c\x01\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xcb\x02\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\xc6\x01\x41\x00\xbc\x02\x12\x02\x13\x02\x41\x00\x8b\x02\x3c\x00\x8b\x00\xcf\x01\x11\x02\x8c\x00\x8d\x00\xcf\x01\xd0\x01\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\x74\x00\x41\x00\x41\x00\x75\x00\x41\x00\x08\x00\x66\x02\x41\x00\xcc\x02\x42\x00\xcf\x01\xd1\x01\x42\x00\xbd\x02\xbe\x02\x42\x00\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x35\x01\xc6\x01\x24\x00\x6d\x00\x12\x02\x15\x02\x36\x01\x8b\x01\x5f\x00\xc5\x02\x07\x00\xbe\x01\xc7\x02\x65\x00\xbe\x01\x6e\x00\x08\x00\x6f\x00\x60\x00\x61\x00\x88\x02\x62\x00\x63\x00\x28\x02\xc0\x01\x63\x00\x2a\x02\xc0\x01\x63\x00\x71\x00\x0d\x00\x0e\x00\x79\x00\x10\x00\x11\x00\x4e\x01\xc6\x01\x7a\x00\x16\x02\xc7\x01\x7b\x00\x89\x02\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x8d\x02\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\xc6\x01\x41\x00\x73\x02\xc7\x01\x18\x02\x8a\x02\x19\x02\x3c\x00\x8b\x00\xcf\x01\xd2\x01\x8c\x00\x8d\x00\x2c\x00\x5a\x02\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\x56\x00\x41\x00\x57\x00\x41\x00\x58\x00\x08\x00\x41\x00\x07\x00\xd6\x02\x42\x00\x39\x00\x42\x00\x3a\x00\x08\x00\x42\x00\x6e\x02\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\xa0\x01\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\xbe\x01\x35\x01\x76\x01\xbf\x02\xc0\x02\x76\x01\x90\x01\x36\x01\x3a\x01\x91\x01\x83\x02\x84\x02\x36\x02\xc0\x01\x63\x00\x78\x01\x63\x00\xc6\x01\x78\x01\x63\x00\xc7\x01\x1a\x02\x1e\x02\x1b\x02\x79\x00\x0f\x02\xd5\x01\x07\x00\xd6\x01\x7a\x00\x86\x02\x84\x02\x7b\x00\x08\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x76\x02\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x10\x00\x11\x00\x49\x01\x59\x02\x2e\x02\x2f\x02\x30\x02\x3c\x00\x8b\x00\x3d\x02\xab\x02\x8c\x00\x8d\x00\xb6\x01\x6a\x02\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\x7d\x02\x41\x00\x3d\x02\xac\x02\x41\x00\x08\x00\xf5\x01\x41\x00\xca\x02\x42\x00\xb6\x01\x6b\x02\x42\x00\xcc\x01\xcd\x01\x42\x00\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x39\x00\xce\x01\x3a\x00\xcf\x01\xf7\x01\x6b\xff\x07\x00\xf8\x01\xbe\x01\xfd\x01\x2c\x00\xbe\x01\x08\x00\x6b\xff\xbe\x01\x6b\xff\xfe\x01\x6b\xff\x3d\x02\x5b\x02\xbf\x01\xc0\x01\x63\x00\xc1\x01\xc0\x01\x63\x00\xc2\x01\xc0\x01\x63\x00\x10\x00\x11\x00\x50\x00\x79\x00\x01\x02\xd3\x01\xd4\x01\xd5\x01\x7a\x00\xd6\x01\x02\x02\x7b\x00\x03\x02\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x05\x02\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\xad\x02\x2d\x02\x2e\x02\x2f\x02\x30\x02\x3d\x02\x5e\x02\x3c\x00\x8b\x00\xb6\x01\x6c\x02\x8c\x00\x8d\x00\xb6\x01\x6d\x02\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\x06\x02\x41\x00\xb6\x01\x3a\x02\x41\x00\x08\x00\x41\x00\x07\x00\xb5\x01\x42\x00\x09\x02\x0a\x02\x42\x00\x08\x00\x42\x00\x16\x02\x77\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x4b\x01\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\xbe\x01\x0c\x02\x0d\x02\xbe\x01\x96\x01\x76\x01\x32\x02\x33\x02\x34\x02\x77\x01\x35\x02\x4a\x02\xc3\x01\xc0\x01\x63\x00\xc4\x01\xc0\x01\x63\x00\x78\x01\x63\x00\x1b\x02\x1c\x02\x37\x02\x38\x02\x79\x00\x3d\x02\x3e\x02\x6b\x00\x16\x00\x7a\x00\x2e\x00\x04\x00\x7b\x00\x4c\x02\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x98\x01\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x9a\x02\x2d\x02\x2e\x02\x2f\x02\x30\x02\x2c\x00\x2d\x00\x3c\x00\x8b\x00\x46\x01\x47\x01\x8c\x00\x8d\x00\x2c\x00\x2d\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\x07\x00\x9d\x02\x2d\x02\x2e\x02\x2f\x02\x30\x02\x08\x00\x9b\x01\x9e\x01\x52\x01\x2f\x00\x30\x00\xa3\x01\xaa\x01\xb2\x01\xba\x01\x3a\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xae\x01\x11\x02\xdf\x01\x13\x00\x14\x00\x15\x00\x16\x00\x3b\x00\xd8\x01\xe0\x01\xd9\x01\xe2\x01\xda\x01\xe3\x01\xe4\x01\xac\x01\x18\x00\xe5\x01\x41\x00\xdb\x01\xe6\x01\xa5\x00\xa6\x00\xa7\x00\xa6\xfe\xe7\x01\x42\x00\xe8\x01\xf3\x01\xed\x01\xa8\x00\xa9\x00\xaa\x00\xab\x00\x94\x02\x95\x02\x96\x02\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\x1a\x00\x1b\x00\xf0\x01\xb4\x00\xb5\x00\x5f\x00\x4f\x02\x2d\x02\x2e\x02\x2f\x02\x30\x02\x2c\x02\x2d\x02\x2e\x02\x2f\x02\x30\x02\x5b\x01\x22\x01\x62\x00\x63\x00\x3c\x00\x3d\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb6\x00\x23\x00\x24\x01\x25\x01\xb7\x00\x26\x01\x52\x00\x27\x01\x28\x01\x4d\x00\x26\x00\x27\x00\x29\x01\x28\x00\x2a\x01\x50\x01\x5b\x00\x72\x01\x5c\x00\x73\x01\x5d\x00\x2b\x01\x2e\x01\xad\x01\x2f\x01\xb8\x00\x2c\x00\x2c\x00\x2d\x00\x30\x01\x2e\x00\xac\x01\x18\x00\x33\x01\x41\x00\x4d\x00\x41\x00\xa5\x00\xa6\x00\xa7\x00\xa6\xfe\x56\x00\x42\x00\x75\x01\x42\x00\x76\x01\xa8\x00\xa9\x00\xaa\x00\xab\x00\x34\x01\x3c\x01\x2c\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\x1a\x00\x1b\x00\x3e\x01\xb4\x00\xb5\x00\x5f\x00\x3f\x01\x76\x01\x47\x01\x41\x01\x44\x01\x7e\x01\x7f\x01\x69\x00\x5d\x00\x85\x01\x5e\x01\x86\x01\x62\x00\x63\x00\x78\x01\x63\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb6\x00\x23\x00\x5e\x00\xb8\x00\xb7\x00\x04\x00\x52\x00\xca\x02\x05\x00\xa9\x02\x26\x00\x27\x00\xb0\x02\x28\x00\x2c\x00\xb1\x02\x5b\x00\xc7\x02\x5c\x00\xb2\x02\x5d\x00\xb4\x02\x2c\x00\xad\x01\x2c\x00\xb8\x00\x18\x00\x2c\x00\x2d\x00\xb6\x02\x2e\x00\xa5\x00\xa6\x00\xa7\x00\xb7\x02\x63\x02\x68\x02\xc9\x02\x07\x00\x97\x02\xa8\x00\xa9\x00\xaa\x00\xab\x00\x08\x00\x2c\x00\xdb\x01\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\x1a\x00\x1b\x00\xdb\x01\xb4\x00\xb5\x00\xde\x01\x10\x00\x11\x00\x59\x00\x83\x02\x86\x02\x88\x02\xdb\x01\x8d\x02\x8f\x02\x98\x02\x9a\x02\x40\x02\x52\x02\x53\x02\x56\x02\x2c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb6\x00\x23\x00\x57\x02\x58\x02\xb7\x00\x59\x02\x52\x00\x40\x02\x2c\x00\x70\x02\x26\x00\x27\x00\x63\x02\x28\x00\x68\x02\x75\x02\x5b\x00\x76\x02\x5c\x00\x78\x02\x5d\x00\xdb\x01\xdb\x01\x5d\xfe\x79\x02\xb8\x00\xf5\x01\x2c\x00\x2d\x00\xb0\x01\x2e\x00\x5d\xfe\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x01\x01\x01\x02\x01\x03\x01\x04\x01\x05\x01\x06\x01\x07\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x0f\x01\x10\x01\x11\x01\x18\x00\x7b\x02\x7c\x02\x7d\x02\x7f\x02\xa5\x00\xa6\x00\xa7\x00\x80\x02\x81\x02\x82\x02\xf7\x01\xfa\x01\x07\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\x94\x02\x08\x00\xf5\x01\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\x1a\x00\x1b\x00\xe2\x01\xb4\x00\xb5\x00\xfb\x01\x72\x00\x10\x00\x11\x00\x59\x00\xfc\x01\xfd\x01\xf5\x01\x24\x01\x09\x02\x00\x02\x01\x02\xf5\x01\x05\x02\x0f\x02\x1e\x02\x2a\x02\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb6\x00\x23\x00\x3a\x02\x2c\x00\xb7\x00\x40\x02\x52\x00\x2c\x00\x44\x02\x2e\xff\x26\x00\x27\x00\x9b\x01\x28\x00\x2f\xff\x2b\xff\x5b\x00\x18\x00\x5c\x00\x29\xff\x5d\x00\x2a\xff\xa5\x00\xa6\x00\xa7\x00\xb8\x00\x9a\x01\x2c\x00\x2d\x00\x07\x00\x2e\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\x08\x00\x9d\x01\x9e\x01\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\x1a\x00\x1b\x00\xa0\x01\xb4\x00\xb5\x00\x58\x00\x10\x00\x11\x00\x59\x00\xa5\x01\x2c\x00\xa7\x01\xa8\x01\xb0\x01\xa9\x01\xde\x01\x2c\x00\x49\x01\x24\x01\xe2\x01\x18\x00\xea\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb6\x00\x23\x00\xe2\x01\x41\x01\xb7\x00\xeb\x01\x52\x00\xec\x01\xed\x01\x19\x00\x26\x00\x27\x00\xef\x01\x28\x00\xf0\x01\x6b\x00\x5b\x00\xe2\x01\x5c\x00\xf5\x01\x5d\x00\x1a\x00\x1b\x00\x1c\x00\x2c\x00\xb8\x00\x2c\x00\x2c\x00\x2d\x00\x32\x01\x2e\x00\x3e\x01\x6b\x00\x75\x00\x49\x01\x54\x01\x59\x01\x5d\x01\x2c\x00\x60\x01\x61\x01\x62\x01\x7d\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x6b\x00\x23\x00\x81\x01\x82\x01\xb8\x02\x24\x00\x25\x00\x18\x00\x83\x01\x84\x01\x26\x00\x27\x00\x8a\x01\x28\x00\xff\xff\x85\x01\x29\x00\x88\x01\x2a\x00\x39\x00\x2b\x00\x3a\x00\x89\x01\x07\x00\x19\x00\x35\x00\x2c\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x6b\x00\x70\x00\x2f\x00\x30\x00\x76\x00\x1a\x00\x1b\x00\x1c\x00\x36\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x77\x00\x07\x00\x13\x00\x14\x00\x15\x00\x16\x00\x66\x01\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x23\x00\x00\x00\x00\x00\x2c\x02\x24\x00\x25\x00\x18\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x39\x00\x2b\x00\x3a\x00\x00\x00\x07\x00\x19\x00\x35\x00\x00\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x1a\x00\x1b\x00\x1c\x00\x36\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x37\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x3f\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x40\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x39\x00\x2b\x00\x3a\x00\x00\x00\x07\x00\x19\x00\x35\x00\x00\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1b\x00\x1c\x00\x36\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x41\x00\x2a\x00\x00\x00\x2b\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x19\x00\x2b\x00\x35\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x02\x0d\x00\x0e\x00\x69\x01\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x46\x02\x47\x02\x48\x02\x24\x00\x25\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x41\x00\x2a\x00\x00\x00\x2b\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x19\x00\x2b\x00\x35\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x02\x0d\x00\x0e\x00\x69\x01\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x46\x02\x47\x02\x49\x02\x24\x00\x25\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x41\x00\x2a\x00\x00\x00\x2b\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x07\x00\x2a\x00\x19\x00\x2b\x00\x35\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1a\x00\x1b\x00\x1c\x00\xad\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x78\x00\x10\x00\x11\x00\x12\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x52\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x40\x00\x28\x00\x00\x00\x00\x00\x5b\x00\x07\x00\x5c\x00\x39\x00\x5d\x00\x3a\x00\x19\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1b\x00\x71\x00\x0d\x00\x0e\x00\x72\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5b\x00\x90\x01\x5c\x00\x00\x00\x5d\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x52\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x40\x00\x28\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5c\x00\x39\x00\x5d\x00\x3a\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x12\xff\x12\xff\x00\x00\x1a\x00\x1b\x00\x12\xff\x00\x00\x12\xff\x00\x00\x00\x00\x00\x00\x12\xff\x00\x00\x12\xff\x00\x00\x12\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\xff\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5b\x00\x70\x01\x5c\x00\x00\x00\x5d\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x5e\xff\x28\x00\x00\x00\x5e\xff\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x40\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5b\x00\x07\x00\x5c\x00\x19\x00\x5d\x00\x8e\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1a\x00\x1b\x00\x53\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x18\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5b\x00\x07\x00\x5c\x00\x19\x00\x5d\x00\x6e\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1a\x00\x1b\x00\x5f\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x1a\x00\x1b\x00\x4d\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x65\x00\x5b\x00\x66\x00\x9d\x02\x67\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x00\x00\x00\x00\x4d\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x7a\x01\x5b\x00\x7b\x01\x5c\x00\x7c\x01\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x1a\x00\x1b\x00\x4d\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x65\x00\x5b\x00\x66\x00\xbe\x01\x67\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x00\x00\x00\x00\x4d\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x65\x00\x5b\x00\x66\x00\x5c\x00\xc6\x01\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x1a\x00\x1b\x00\x4d\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x7a\x01\x5b\x00\x7b\x01\x5c\x00\x7c\x01\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x00\x00\x00\x00\x4d\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x65\x00\x5b\x00\x66\x00\x5c\x00\x67\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x1a\x00\x1b\x00\x4d\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x7a\x01\x53\x00\x7b\x01\x54\x00\x7c\x01\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x52\x00\x00\x00\x00\x00\x4d\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x4e\x00\x5b\x00\x4f\x00\x5c\x00\x50\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x07\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x69\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x31\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x07\x00\x13\x00\x14\x00\x15\x00\x16\x00\x65\x01\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x07\x00\x13\x00\x14\x00\x15\x00\x16\x00\x67\x01\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x1f\x02\x13\x00\x14\x00\x15\x00\x16\x00\x33\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x59\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\xa5\x01\x56\x01\x57\x01\x07\x00\x00\x00\x8e\x01\x00\x00\x33\x00\x00\x00\x08\x00\x07\x00\x00\x00\x6e\x01\x5a\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x5a\x01\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x37\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x59\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x92\x01\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x33\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x01\x08\x00\x07\x00\x00\x00\x00\x00\x93\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x94\x01\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x63\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x08\x00\x07\x00\x00\x00\x00\x00\x95\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x66\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x66\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x33\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x59\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x5a\x01\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x33\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x4d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x4e\x01\x62\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x01\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x0d\x00\x0e\x00\x07\x00\x10\x00\x11\x00\x4e\x01\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x01\x00\x00\x00\x00\x00\x00\x00\x00\x63\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x4b\x00\x4c\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x2c\xff\x4d\x00\x00\x00\x00\x00\x7a\x01\x00\x00\x7b\x01\x65\x00\x7c\x01\x66\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x2c\x00\x12\x01\x13\x01\x14\x01\x15\x01\x16\x01\x17\x01\x18\x01\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyReduceArr = Happy_Data_Array.array (3, 419) [ - (3 , happyReduce_3), - (4 , happyReduce_4), - (5 , happyReduce_5), - (6 , happyReduce_6), - (7 , happyReduce_7), - (8 , happyReduce_8), - (9 , happyReduce_9), - (10 , happyReduce_10), - (11 , happyReduce_11), - (12 , happyReduce_12), - (13 , happyReduce_13), - (14 , happyReduce_14), - (15 , happyReduce_15), - (16 , happyReduce_16), - (17 , happyReduce_17), - (18 , happyReduce_18), - (19 , happyReduce_19), - (20 , happyReduce_20), - (21 , happyReduce_21), - (22 , happyReduce_22), - (23 , happyReduce_23), - (24 , happyReduce_24), - (25 , happyReduce_25), - (26 , happyReduce_26), - (27 , happyReduce_27), - (28 , happyReduce_28), - (29 , happyReduce_29), - (30 , happyReduce_30), - (31 , happyReduce_31), - (32 , happyReduce_32), - (33 , happyReduce_33), - (34 , happyReduce_34), - (35 , happyReduce_35), - (36 , happyReduce_36), - (37 , happyReduce_37), - (38 , happyReduce_38), - (39 , happyReduce_39), - (40 , happyReduce_40), - (41 , happyReduce_41), - (42 , happyReduce_42), - (43 , happyReduce_43), - (44 , happyReduce_44), - (45 , happyReduce_45), - (46 , happyReduce_46), - (47 , happyReduce_47), - (48 , happyReduce_48), - (49 , happyReduce_49), - (50 , happyReduce_50), - (51 , happyReduce_51), - (52 , happyReduce_52), - (53 , happyReduce_53), - (54 , happyReduce_54), - (55 , happyReduce_55), - (56 , happyReduce_56), - (57 , happyReduce_57), - (58 , happyReduce_58), - (59 , happyReduce_59), - (60 , happyReduce_60), - (61 , happyReduce_61), - (62 , happyReduce_62), - (63 , happyReduce_63), - (64 , happyReduce_64), - (65 , happyReduce_65), - (66 , happyReduce_66), - (67 , happyReduce_67), - (68 , happyReduce_68), - (69 , happyReduce_69), - (70 , happyReduce_70), - (71 , happyReduce_71), - (72 , happyReduce_72), - (73 , happyReduce_73), - (74 , happyReduce_74), - (75 , happyReduce_75), - (76 , happyReduce_76), - (77 , happyReduce_77), - (78 , happyReduce_78), - (79 , happyReduce_79), - (80 , happyReduce_80), - (81 , happyReduce_81), - (82 , happyReduce_82), - (83 , happyReduce_83), - (84 , happyReduce_84), - (85 , happyReduce_85), - (86 , happyReduce_86), - (87 , happyReduce_87), - (88 , happyReduce_88), - (89 , happyReduce_89), - (90 , happyReduce_90), - (91 , happyReduce_91), - (92 , happyReduce_92), - (93 , happyReduce_93), - (94 , happyReduce_94), - (95 , happyReduce_95), - (96 , happyReduce_96), - (97 , happyReduce_97), - (98 , happyReduce_98), - (99 , happyReduce_99), - (100 , happyReduce_100), - (101 , happyReduce_101), - (102 , happyReduce_102), - (103 , happyReduce_103), - (104 , happyReduce_104), - (105 , happyReduce_105), - (106 , happyReduce_106), - (107 , happyReduce_107), - (108 , happyReduce_108), - (109 , happyReduce_109), - (110 , happyReduce_110), - (111 , happyReduce_111), - (112 , happyReduce_112), - (113 , happyReduce_113), - (114 , happyReduce_114), - (115 , happyReduce_115), - (116 , happyReduce_116), - (117 , happyReduce_117), - (118 , happyReduce_118), - (119 , happyReduce_119), - (120 , happyReduce_120), - (121 , happyReduce_121), - (122 , happyReduce_122), - (123 , happyReduce_123), - (124 , happyReduce_124), - (125 , happyReduce_125), - (126 , happyReduce_126), - (127 , happyReduce_127), - (128 , happyReduce_128), - (129 , happyReduce_129), - (130 , happyReduce_130), - (131 , happyReduce_131), - (132 , happyReduce_132), - (133 , happyReduce_133), - (134 , happyReduce_134), - (135 , happyReduce_135), - (136 , happyReduce_136), - (137 , happyReduce_137), - (138 , happyReduce_138), - (139 , happyReduce_139), - (140 , happyReduce_140), - (141 , happyReduce_141), - (142 , happyReduce_142), - (143 , happyReduce_143), - (144 , happyReduce_144), - (145 , happyReduce_145), - (146 , happyReduce_146), - (147 , happyReduce_147), - (148 , happyReduce_148), - (149 , happyReduce_149), - (150 , happyReduce_150), - (151 , happyReduce_151), - (152 , happyReduce_152), - (153 , happyReduce_153), - (154 , happyReduce_154), - (155 , happyReduce_155), - (156 , happyReduce_156), - (157 , happyReduce_157), - (158 , happyReduce_158), - (159 , happyReduce_159), - (160 , happyReduce_160), - (161 , happyReduce_161), - (162 , happyReduce_162), - (163 , happyReduce_163), - (164 , happyReduce_164), - (165 , happyReduce_165), - (166 , happyReduce_166), - (167 , happyReduce_167), - (168 , happyReduce_168), - (169 , happyReduce_169), - (170 , happyReduce_170), - (171 , happyReduce_171), - (172 , happyReduce_172), - (173 , happyReduce_173), - (174 , happyReduce_174), - (175 , happyReduce_175), - (176 , happyReduce_176), - (177 , happyReduce_177), - (178 , happyReduce_178), - (179 , happyReduce_179), - (180 , happyReduce_180), - (181 , happyReduce_181), - (182 , happyReduce_182), - (183 , happyReduce_183), - (184 , happyReduce_184), - (185 , happyReduce_185), - (186 , happyReduce_186), - (187 , happyReduce_187), - (188 , happyReduce_188), - (189 , happyReduce_189), - (190 , happyReduce_190), - (191 , happyReduce_191), - (192 , happyReduce_192), - (193 , happyReduce_193), - (194 , happyReduce_194), - (195 , happyReduce_195), - (196 , happyReduce_196), - (197 , happyReduce_197), - (198 , happyReduce_198), - (199 , happyReduce_199), - (200 , happyReduce_200), - (201 , happyReduce_201), - (202 , happyReduce_202), - (203 , happyReduce_203), - (204 , happyReduce_204), - (205 , happyReduce_205), - (206 , happyReduce_206), - (207 , happyReduce_207), - (208 , happyReduce_208), - (209 , happyReduce_209), - (210 , happyReduce_210), - (211 , happyReduce_211), - (212 , happyReduce_212), - (213 , happyReduce_213), - (214 , happyReduce_214), - (215 , happyReduce_215), - (216 , happyReduce_216), - (217 , happyReduce_217), - (218 , happyReduce_218), - (219 , happyReduce_219), - (220 , happyReduce_220), - (221 , happyReduce_221), - (222 , happyReduce_222), - (223 , happyReduce_223), - (224 , happyReduce_224), - (225 , happyReduce_225), - (226 , happyReduce_226), - (227 , happyReduce_227), - (228 , happyReduce_228), - (229 , happyReduce_229), - (230 , happyReduce_230), - (231 , happyReduce_231), - (232 , happyReduce_232), - (233 , happyReduce_233), - (234 , happyReduce_234), - (235 , happyReduce_235), - (236 , happyReduce_236), - (237 , happyReduce_237), - (238 , happyReduce_238), - (239 , happyReduce_239), - (240 , happyReduce_240), - (241 , happyReduce_241), - (242 , happyReduce_242), - (243 , happyReduce_243), - (244 , happyReduce_244), - (245 , happyReduce_245), - (246 , happyReduce_246), - (247 , happyReduce_247), - (248 , happyReduce_248), - (249 , happyReduce_249), - (250 , happyReduce_250), - (251 , happyReduce_251), - (252 , happyReduce_252), - (253 , happyReduce_253), - (254 , happyReduce_254), - (255 , happyReduce_255), - (256 , happyReduce_256), - (257 , happyReduce_257), - (258 , happyReduce_258), - (259 , happyReduce_259), - (260 , happyReduce_260), - (261 , happyReduce_261), - (262 , happyReduce_262), - (263 , happyReduce_263), - (264 , happyReduce_264), - (265 , happyReduce_265), - (266 , happyReduce_266), - (267 , happyReduce_267), - (268 , happyReduce_268), - (269 , happyReduce_269), - (270 , happyReduce_270), - (271 , happyReduce_271), - (272 , happyReduce_272), - (273 , happyReduce_273), - (274 , happyReduce_274), - (275 , happyReduce_275), - (276 , happyReduce_276), - (277 , happyReduce_277), - (278 , happyReduce_278), - (279 , happyReduce_279), - (280 , happyReduce_280), - (281 , happyReduce_281), - (282 , happyReduce_282), - (283 , happyReduce_283), - (284 , happyReduce_284), - (285 , happyReduce_285), - (286 , happyReduce_286), - (287 , happyReduce_287), - (288 , happyReduce_288), - (289 , happyReduce_289), - (290 , happyReduce_290), - (291 , happyReduce_291), - (292 , happyReduce_292), - (293 , happyReduce_293), - (294 , happyReduce_294), - (295 , happyReduce_295), - (296 , happyReduce_296), - (297 , happyReduce_297), - (298 , happyReduce_298), - (299 , happyReduce_299), - (300 , happyReduce_300), - (301 , happyReduce_301), - (302 , happyReduce_302), - (303 , happyReduce_303), - (304 , happyReduce_304), - (305 , happyReduce_305), - (306 , happyReduce_306), - (307 , happyReduce_307), - (308 , happyReduce_308), - (309 , happyReduce_309), - (310 , happyReduce_310), - (311 , happyReduce_311), - (312 , happyReduce_312), - (313 , happyReduce_313), - (314 , happyReduce_314), - (315 , happyReduce_315), - (316 , happyReduce_316), - (317 , happyReduce_317), - (318 , happyReduce_318), - (319 , happyReduce_319), - (320 , happyReduce_320), - (321 , happyReduce_321), - (322 , happyReduce_322), - (323 , happyReduce_323), - (324 , happyReduce_324), - (325 , happyReduce_325), - (326 , happyReduce_326), - (327 , happyReduce_327), - (328 , happyReduce_328), - (329 , happyReduce_329), - (330 , happyReduce_330), - (331 , happyReduce_331), - (332 , happyReduce_332), - (333 , happyReduce_333), - (334 , happyReduce_334), - (335 , happyReduce_335), - (336 , happyReduce_336), - (337 , happyReduce_337), - (338 , happyReduce_338), - (339 , happyReduce_339), - (340 , happyReduce_340), - (341 , happyReduce_341), - (342 , happyReduce_342), - (343 , happyReduce_343), - (344 , happyReduce_344), - (345 , happyReduce_345), - (346 , happyReduce_346), - (347 , happyReduce_347), - (348 , happyReduce_348), - (349 , happyReduce_349), - (350 , happyReduce_350), - (351 , happyReduce_351), - (352 , happyReduce_352), - (353 , happyReduce_353), - (354 , happyReduce_354), - (355 , happyReduce_355), - (356 , happyReduce_356), - (357 , happyReduce_357), - (358 , happyReduce_358), - (359 , happyReduce_359), - (360 , happyReduce_360), - (361 , happyReduce_361), - (362 , happyReduce_362), - (363 , happyReduce_363), - (364 , happyReduce_364), - (365 , happyReduce_365), - (366 , happyReduce_366), - (367 , happyReduce_367), - (368 , happyReduce_368), - (369 , happyReduce_369), - (370 , happyReduce_370), - (371 , happyReduce_371), - (372 , happyReduce_372), - (373 , happyReduce_373), - (374 , happyReduce_374), - (375 , happyReduce_375), - (376 , happyReduce_376), - (377 , happyReduce_377), - (378 , happyReduce_378), - (379 , happyReduce_379), - (380 , happyReduce_380), - (381 , happyReduce_381), - (382 , happyReduce_382), - (383 , happyReduce_383), - (384 , happyReduce_384), - (385 , happyReduce_385), - (386 , happyReduce_386), - (387 , happyReduce_387), - (388 , happyReduce_388), - (389 , happyReduce_389), - (390 , happyReduce_390), - (391 , happyReduce_391), - (392 , happyReduce_392), - (393 , happyReduce_393), - (394 , happyReduce_394), - (395 , happyReduce_395), - (396 , happyReduce_396), - (397 , happyReduce_397), - (398 , happyReduce_398), - (399 , happyReduce_399), - (400 , happyReduce_400), - (401 , happyReduce_401), - (402 , happyReduce_402), - (403 , happyReduce_403), - (404 , happyReduce_404), - (405 , happyReduce_405), - (406 , happyReduce_406), - (407 , happyReduce_407), - (408 , happyReduce_408), - (409 , happyReduce_409), - (410 , happyReduce_410), - (411 , happyReduce_411), - (412 , happyReduce_412), - (413 , happyReduce_413), - (414 , happyReduce_414), - (415 , happyReduce_415), - (416 , happyReduce_416), - (417 , happyReduce_417), - (418 , happyReduce_418), - (419 , happyReduce_419) - ] - -happy_n_terms = 90 :: Int -happy_n_nonterms = 138 :: Int - -happyReduce_3 = happySpecReduce_1 0# happyReduction_3 -happyReduction_3 happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - happyIn6 - (reverse happy_var_1 - )} - -happyReduce_4 = happySpecReduce_2 1# happyReduction_4 -happyReduction_4 happy_x_2 - happy_x_1 - = case happyOut7 happy_x_1 of { happy_var_1 -> - case happyOut8 happy_x_2 of { happy_var_2 -> - happyIn7 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_5 = happySpecReduce_0 1# happyReduction_5 -happyReduction_5 = happyIn7 - ([] - ) - -happyReduce_6 = happySpecReduce_1 2# happyReduction_6 -happyReduction_6 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) -> - happyIn8 - (TokKeyword KwLet happy_var_1 - )} - -happyReduce_7 = happySpecReduce_1 2# happyReduction_7 -happyReduction_7 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwIn happy_var_1) -> - happyIn8 - (TokKeyword KwIn happy_var_1 - )} - -happyReduce_8 = happySpecReduce_1 2# happyReduction_8 -happyReduction_8 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwWhere happy_var_1) -> - happyIn8 - (TokKeyword KwWhere happy_var_1 - )} - -happyReduce_9 = happySpecReduce_1 2# happyReduction_9 -happyReduction_9 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwWith happy_var_1) -> - happyIn8 - (TokKeyword KwWith happy_var_1 - )} - -happyReduce_10 = happySpecReduce_1 2# happyReduction_10 -happyReduction_10 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwRewrite happy_var_1) -> - happyIn8 - (TokKeyword KwRewrite happy_var_1 - )} - -happyReduce_11 = happySpecReduce_1 2# happyReduction_11 -happyReduction_11 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) -> - happyIn8 - (TokKeyword KwPostulate happy_var_1 - )} - -happyReduce_12 = happySpecReduce_1 2# happyReduction_12 -happyReduction_12 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) -> - happyIn8 - (TokKeyword KwPrimitive happy_var_1 - )} - -happyReduce_13 = happySpecReduce_1 2# happyReduction_13 -happyReduction_13 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> - happyIn8 - (TokKeyword KwOpen happy_var_1 - )} - -happyReduce_14 = happySpecReduce_1 2# happyReduction_14 -happyReduction_14 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwImport happy_var_1) -> - happyIn8 - (TokKeyword KwImport happy_var_1 - )} - -happyReduce_15 = happySpecReduce_1 2# happyReduction_15 -happyReduction_15 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwUsing happy_var_1) -> - happyIn8 - (TokKeyword KwUsing happy_var_1 - )} - -happyReduce_16 = happySpecReduce_1 2# happyReduction_16 -happyReduction_16 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwHiding happy_var_1) -> - happyIn8 - (TokKeyword KwHiding happy_var_1 - )} - -happyReduce_17 = happySpecReduce_1 2# happyReduction_17 -happyReduction_17 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> - happyIn8 - (TokKeyword KwRenaming happy_var_1 - )} - -happyReduce_18 = happySpecReduce_1 2# happyReduction_18 -happyReduction_18 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwTo happy_var_1) -> - happyIn8 - (TokKeyword KwTo happy_var_1 - )} - -happyReduce_19 = happySpecReduce_1 2# happyReduction_19 -happyReduction_19 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) -> - happyIn8 - (TokKeyword KwPublic happy_var_1 - )} - -happyReduce_20 = happySpecReduce_1 2# happyReduction_20 -happyReduction_20 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> - happyIn8 - (TokKeyword KwModule happy_var_1 - )} - -happyReduce_21 = happySpecReduce_1 2# happyReduction_21 -happyReduction_21 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> - happyIn8 - (TokKeyword KwData happy_var_1 - )} - -happyReduce_22 = happySpecReduce_1 2# happyReduction_22 -happyReduction_22 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> - happyIn8 - (TokKeyword KwCoData happy_var_1 - )} - -happyReduce_23 = happySpecReduce_1 2# happyReduction_23 -happyReduction_23 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> - happyIn8 - (TokKeyword KwRecord happy_var_1 - )} - -happyReduce_24 = happySpecReduce_1 2# happyReduction_24 -happyReduction_24 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwConstructor happy_var_1) -> - happyIn8 - (TokKeyword KwConstructor happy_var_1 - )} - -happyReduce_25 = happySpecReduce_1 2# happyReduction_25 -happyReduction_25 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) -> - happyIn8 - (TokKeyword KwInductive happy_var_1 - )} - -happyReduce_26 = happySpecReduce_1 2# happyReduction_26 -happyReduction_26 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) -> - happyIn8 - (TokKeyword KwCoInductive happy_var_1 - )} - -happyReduce_27 = happySpecReduce_1 2# happyReduction_27 -happyReduction_27 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwField happy_var_1) -> - happyIn8 - (TokKeyword KwField happy_var_1 - )} - -happyReduce_28 = happySpecReduce_1 2# happyReduction_28 -happyReduction_28 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) -> - happyIn8 - (TokKeyword KwInfix happy_var_1 - )} - -happyReduce_29 = happySpecReduce_1 2# happyReduction_29 -happyReduction_29 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) -> - happyIn8 - (TokKeyword KwInfixL happy_var_1 - )} - -happyReduce_30 = happySpecReduce_1 2# happyReduction_30 -happyReduction_30 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) -> - happyIn8 - (TokKeyword KwInfixR happy_var_1 - )} - -happyReduce_31 = happySpecReduce_1 2# happyReduction_31 -happyReduction_31 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) -> - happyIn8 - (TokKeyword KwMutual happy_var_1 - )} - -happyReduce_32 = happySpecReduce_1 2# happyReduction_32 -happyReduction_32 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) -> - happyIn8 - (TokKeyword KwAbstract happy_var_1 - )} - -happyReduce_33 = happySpecReduce_1 2# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) -> - happyIn8 - (TokKeyword KwPrivate happy_var_1 - )} - -happyReduce_34 = happySpecReduce_1 2# happyReduction_34 -happyReduction_34 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) -> - happyIn8 - (TokKeyword KwInstance happy_var_1 - )} - -happyReduce_35 = happySpecReduce_1 2# happyReduction_35 -happyReduction_35 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) -> - happyIn8 - (TokKeyword KwProp happy_var_1 - )} - -happyReduce_36 = happySpecReduce_1 2# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) -> - happyIn8 - (TokKeyword KwSet happy_var_1 - )} - -happyReduce_37 = happySpecReduce_1 2# happyReduction_37 -happyReduction_37 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwForall happy_var_1) -> - happyIn8 - (TokKeyword KwForall happy_var_1 - )} - -happyReduce_38 = happySpecReduce_1 2# happyReduction_38 -happyReduction_38 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwSyntax happy_var_1) -> - happyIn8 - (TokKeyword KwSyntax happy_var_1 - )} - -happyReduce_39 = happySpecReduce_1 2# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPatternSyn happy_var_1) -> - happyIn8 - (TokKeyword KwPatternSyn happy_var_1 - )} - -happyReduce_40 = happySpecReduce_1 2# happyReduction_40 -happyReduction_40 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwOPTIONS happy_var_1) -> - happyIn8 - (TokKeyword KwOPTIONS happy_var_1 - )} - -happyReduce_41 = happySpecReduce_1 2# happyReduction_41 -happyReduction_41 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwBUILTIN happy_var_1) -> - happyIn8 - (TokKeyword KwBUILTIN happy_var_1 - )} - -happyReduce_42 = happySpecReduce_1 2# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwREWRITE happy_var_1) -> - happyIn8 - (TokKeyword KwREWRITE happy_var_1 - )} - -happyReduce_43 = happySpecReduce_1 2# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwIMPORT happy_var_1) -> - happyIn8 - (TokKeyword KwIMPORT happy_var_1 - )} - -happyReduce_44 = happySpecReduce_1 2# happyReduction_44 -happyReduction_44 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED happy_var_1) -> - happyIn8 - (TokKeyword KwCOMPILED happy_var_1 - )} - -happyReduce_45 = happySpecReduce_1 2# happyReduction_45 -happyReduction_45 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_EXPORT happy_var_1) -> - happyIn8 - (TokKeyword KwCOMPILED_EXPORT happy_var_1 - )} - -happyReduce_46 = happySpecReduce_1 2# happyReduction_46 -happyReduction_46 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_DATA happy_var_1) -> - happyIn8 - (TokKeyword KwCOMPILED_DATA happy_var_1 - )} - -happyReduce_47 = happySpecReduce_1 2# happyReduction_47 -happyReduction_47 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_TYPE happy_var_1) -> - happyIn8 - (TokKeyword KwCOMPILED_TYPE happy_var_1 - )} - -happyReduce_48 = happySpecReduce_1 2# happyReduction_48 -happyReduction_48 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_EPIC happy_var_1) -> - happyIn8 - (TokKeyword KwCOMPILED_EPIC happy_var_1 - )} - -happyReduce_49 = happySpecReduce_1 2# happyReduction_49 -happyReduction_49 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_JS happy_var_1) -> - happyIn8 - (TokKeyword KwCOMPILED_JS happy_var_1 - )} - -happyReduce_50 = happySpecReduce_1 2# happyReduction_50 -happyReduction_50 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwSTATIC happy_var_1) -> - happyIn8 - (TokKeyword KwSTATIC happy_var_1 - )} - -happyReduce_51 = happySpecReduce_1 2# happyReduction_51 -happyReduction_51 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwIMPOSSIBLE happy_var_1) -> - happyIn8 - (TokKeyword KwIMPOSSIBLE happy_var_1 - )} - -happyReduce_52 = happySpecReduce_1 2# happyReduction_52 -happyReduction_52 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwETA happy_var_1) -> - happyIn8 - (TokKeyword KwETA happy_var_1 - )} - -happyReduce_53 = happySpecReduce_1 2# happyReduction_53 -happyReduction_53 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwNO_TERMINATION_CHECK happy_var_1) -> - happyIn8 - (TokKeyword KwNO_TERMINATION_CHECK happy_var_1 - )} - -happyReduce_54 = happySpecReduce_1 2# happyReduction_54 -happyReduction_54 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwNON_TERMINATING happy_var_1) -> - happyIn8 - (TokKeyword KwNON_TERMINATING happy_var_1 - )} - -happyReduce_55 = happySpecReduce_1 2# happyReduction_55 -happyReduction_55 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwTERMINATING happy_var_1) -> - happyIn8 - (TokKeyword KwTERMINATING happy_var_1 - )} - -happyReduce_56 = happySpecReduce_1 2# happyReduction_56 -happyReduction_56 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwMEASURE happy_var_1) -> - happyIn8 - (TokKeyword KwMEASURE happy_var_1 - )} - -happyReduce_57 = happySpecReduce_1 2# happyReduction_57 -happyReduction_57 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) -> - happyIn8 - (TokKeyword KwQuoteGoal happy_var_1 - )} - -happyReduce_58 = happySpecReduce_1 2# happyReduction_58 -happyReduction_58 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) -> - happyIn8 - (TokKeyword KwQuoteContext happy_var_1 - )} - -happyReduce_59 = happySpecReduce_1 2# happyReduction_59 -happyReduction_59 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) -> - happyIn8 - (TokKeyword KwQuote happy_var_1 - )} - -happyReduce_60 = happySpecReduce_1 2# happyReduction_60 -happyReduction_60 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) -> - happyIn8 - (TokKeyword KwQuoteTerm happy_var_1 - )} - -happyReduce_61 = happySpecReduce_1 2# happyReduction_61 -happyReduction_61 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> - happyIn8 - (TokKeyword KwTactic happy_var_1 - )} - -happyReduce_62 = happySpecReduce_1 2# happyReduction_62 -happyReduction_62 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) -> - happyIn8 - (TokKeyword KwUnquote happy_var_1 - )} - -happyReduce_63 = happySpecReduce_1 2# happyReduction_63 -happyReduction_63 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> - happyIn8 - (TokKeyword KwUnquoteDecl happy_var_1 - )} - -happyReduce_64 = happySpecReduce_1 2# happyReduction_64 -happyReduction_64 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSetN happy_var_1) -> - happyIn8 - (TokSetN happy_var_1 - )} - -happyReduce_65 = happySpecReduce_1 2# happyReduction_65 -happyReduction_65 happy_x_1 - = case happyOutTok happy_x_1 of { (TokTeX happy_var_1) -> - happyIn8 - (TokTeX happy_var_1 - )} - -happyReduce_66 = happySpecReduce_1 2# happyReduction_66 -happyReduction_66 happy_x_1 - = case happyOutTok happy_x_1 of { (TokComment happy_var_1) -> - happyIn8 - (TokComment happy_var_1 - )} - -happyReduce_67 = happySpecReduce_1 2# happyReduction_67 -happyReduction_67 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) -> - happyIn8 - (TokSymbol SymEllipsis happy_var_1 - )} - -happyReduce_68 = happySpecReduce_1 2# happyReduction_68 -happyReduction_68 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDotDot happy_var_1) -> - happyIn8 - (TokSymbol SymDotDot happy_var_1 - )} - -happyReduce_69 = happySpecReduce_1 2# happyReduction_69 -happyReduction_69 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) -> - happyIn8 - (TokSymbol SymDot happy_var_1 - )} - -happyReduce_70 = happySpecReduce_1 2# happyReduction_70 -happyReduction_70 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) -> - happyIn8 - (TokSymbol SymSemi happy_var_1 - )} - -happyReduce_71 = happySpecReduce_1 2# happyReduction_71 -happyReduction_71 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymColon happy_var_1) -> - happyIn8 - (TokSymbol SymColon happy_var_1 - )} - -happyReduce_72 = happySpecReduce_1 2# happyReduction_72 -happyReduction_72 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymEqual happy_var_1) -> - happyIn8 - (TokSymbol SymEqual happy_var_1 - )} - -happyReduce_73 = happySpecReduce_1 2# happyReduction_73 -happyReduction_73 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> - happyIn8 - (TokSymbol SymUnderscore happy_var_1 - )} - -happyReduce_74 = happySpecReduce_1 2# happyReduction_74 -happyReduction_74 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) -> - happyIn8 - (TokSymbol SymQuestionMark happy_var_1 - )} - -happyReduce_75 = happySpecReduce_1 2# happyReduction_75 -happyReduction_75 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymArrow happy_var_1) -> - happyIn8 - (TokSymbol SymArrow happy_var_1 - )} - -happyReduce_76 = happySpecReduce_1 2# happyReduction_76 -happyReduction_76 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> - happyIn8 - (TokSymbol SymLambda happy_var_1 - )} - -happyReduce_77 = happySpecReduce_1 2# happyReduction_77 -happyReduction_77 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymAs happy_var_1) -> - happyIn8 - (TokSymbol SymAs happy_var_1 - )} - -happyReduce_78 = happySpecReduce_1 2# happyReduction_78 -happyReduction_78 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymBar happy_var_1) -> - happyIn8 - (TokSymbol SymBar happy_var_1 - )} - -happyReduce_79 = happySpecReduce_1 2# happyReduction_79 -happyReduction_79 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> - happyIn8 - (TokSymbol SymOpenParen happy_var_1 - )} - -happyReduce_80 = happySpecReduce_1 2# happyReduction_80 -happyReduction_80 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymCloseParen happy_var_1) -> - happyIn8 - (TokSymbol SymCloseParen happy_var_1 - )} - -happyReduce_81 = happySpecReduce_1 2# happyReduction_81 -happyReduction_81 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> - happyIn8 - (TokSymbol SymDoubleOpenBrace happy_var_1 - )} - -happyReduce_82 = happySpecReduce_1 2# happyReduction_82 -happyReduction_82 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) -> - happyIn8 - (TokSymbol SymDoubleCloseBrace happy_var_1 - )} - -happyReduce_83 = happySpecReduce_1 2# happyReduction_83 -happyReduction_83 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> - happyIn8 - (TokSymbol SymOpenBrace happy_var_1 - )} - -happyReduce_84 = happySpecReduce_1 2# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) -> - happyIn8 - (TokSymbol SymCloseBrace happy_var_1 - )} - -happyReduce_85 = happySpecReduce_1 2# happyReduction_85 -happyReduction_85 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenVirtualBrace happy_var_1) -> - happyIn8 - (TokSymbol SymOpenVirtualBrace happy_var_1 - )} - -happyReduce_86 = happySpecReduce_1 2# happyReduction_86 -happyReduction_86 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymCloseVirtualBrace happy_var_1) -> - happyIn8 - (TokSymbol SymCloseVirtualBrace happy_var_1 - )} - -happyReduce_87 = happySpecReduce_1 2# happyReduction_87 -happyReduction_87 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) -> - happyIn8 - (TokSymbol SymVirtualSemi happy_var_1 - )} - -happyReduce_88 = happySpecReduce_1 2# happyReduction_88 -happyReduction_88 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - happyIn8 - (TokSymbol SymOpenPragma happy_var_1 - )} - -happyReduce_89 = happySpecReduce_1 2# happyReduction_89 -happyReduction_89 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymClosePragma happy_var_1) -> - happyIn8 - (TokSymbol SymClosePragma happy_var_1 - )} - -happyReduce_90 = happySpecReduce_1 2# happyReduction_90 -happyReduction_90 happy_x_1 - = case happyOutTok happy_x_1 of { (TokId happy_var_1) -> - happyIn8 - (TokId happy_var_1 - )} - -happyReduce_91 = happySpecReduce_1 2# happyReduction_91 -happyReduction_91 happy_x_1 - = case happyOutTok happy_x_1 of { (TokQId happy_var_1) -> - happyIn8 - (TokQId happy_var_1 - )} - -happyReduce_92 = happySpecReduce_1 2# happyReduction_92 -happyReduction_92 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - happyIn8 - (TokString happy_var_1 - )} - -happyReduce_93 = happySpecReduce_1 2# happyReduction_93 -happyReduction_93 happy_x_1 - = case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> - happyIn8 - (TokLiteral happy_var_1 - )} - -happyReduce_94 = happySpecReduce_3 3# happyReduction_94 -happyReduction_94 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut113 happy_x_2 of { happy_var_2 -> - happyIn9 - (takeOptionsPragmas happy_var_2 - )} - -happyReduce_95 = happySpecReduce_0 4# happyReduction_95 -happyReduction_95 = happyIn10 - (() - ) - -happyReduce_96 = happySpecReduce_1 4# happyReduction_96 -happyReduction_96 happy_x_1 - = happyIn10 - (() - ) - -happyReduce_97 = happySpecReduce_1 5# happyReduction_97 -happyReduction_97 happy_x_1 - = happyIn11 - (() - ) - -happyReduce_98 = happyMonadReduce 1# 5# happyReduction_98 -happyReduction_98 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (( popContext) - ) (\r -> happyReturn (happyIn11 r)) - -happyReduce_99 = happySpecReduce_1 6# happyReduction_99 -happyReduction_99 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) -> - happyIn12 - (happy_var_1 - )} - -happyReduce_100 = happySpecReduce_1 6# happyReduction_100 -happyReduction_100 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) -> - happyIn12 - (happy_var_1 - )} - -happyReduce_101 = happyMonadReduce 0# 7# happyReduction_101 -happyReduction_101 (happyRest) tk - = happyThen (( pushLexState imp_dir) - ) (\r -> happyReturn (happyIn13 r)) - -happyReduce_102 = happyMonadReduce 1# 8# happyReduction_102 -happyReduction_102 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> - ( case happy_var_1 of { - LitInt _ i -> return i; - _ -> fail $ "Expected integer" - })} - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_103 = happyMonadReduce 1# 8# happyReduction_103 -happyReduction_103 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) -> - ( case happy_var_1 of { - (_, s) -> case readM s of { - Right i -> return i; - Left (err :: String) -> fail $ "Expected integer" - } - })} - ) (\r -> happyReturn (happyIn14 r)) - -happyReduce_104 = happyMonadReduce 1# 9# happyReduction_104 -happyReduction_104 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) -> - ( mkName happy_var_1)} - ) (\r -> happyReturn (happyIn15 r)) - -happyReduce_105 = happySpecReduce_2 10# happyReduction_105 -happyReduction_105 happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn16 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_106 = happySpecReduce_1 10# happyReduction_106 -happyReduction_106 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn16 - ([happy_var_1] - )} - -happyReduce_107 = happySpecReduce_1 11# happyReduction_107 -happyReduction_107 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) -> - happyIn17 - (getRange happy_var_1 - )} - -happyReduce_108 = happyMonadReduce 2# 11# happyReduction_108 -happyReduction_108 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) -> - ( - if posPos (fromJust (rEnd (getRange happy_var_2))) - - posPos (fromJust (rStart (getRange happy_var_1))) > 2 - then parseErrorAt (fromJust (rStart (getRange happy_var_2))) - "Expecting '}}', found separated '}'s." - else return $ getRange (happy_var_1, happy_var_2))}} - ) (\r -> happyReturn (happyIn17 r)) - -happyReduce_109 = happySpecReduce_2 12# happyReduction_109 -happyReduction_109 happy_x_2 - happy_x_1 - = case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn18 - (setRelevance Irrelevant $ defaultArg happy_var_2 - )} - -happyReduce_110 = happySpecReduce_1 12# happyReduction_110 -happyReduction_110 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn18 - (defaultArg happy_var_1 - )} - -happyReduce_111 = happySpecReduce_2 13# happyReduction_111 -happyReduction_111 happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn19 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_112 = happySpecReduce_1 13# happyReduction_112 -happyReduction_112 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn19 - ([happy_var_1] - )} - -happyReduce_113 = happySpecReduce_2 14# happyReduction_113 -happyReduction_113 happy_x_2 - happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { happy_var_2 -> - happyIn20 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_114 = happySpecReduce_1 14# happyReduction_114 -happyReduction_114 happy_x_1 - = case happyOut18 happy_x_1 of { happy_var_1 -> - happyIn20 - ([happy_var_1] - )} - -happyReduce_115 = happyReduce 4# 14# happyReduction_115 -happyReduction_115 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut19 happy_x_2 of { happy_var_2 -> - case happyOut20 happy_x_4 of { happy_var_4 -> - happyIn20 - (map makeInstance happy_var_2 ++ happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_116 = happySpecReduce_3 14# happyReduction_116 -happyReduction_116 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn20 - (map makeInstance happy_var_2 - )} - -happyReduce_117 = happyReduce 4# 14# happyReduction_117 -happyReduction_117 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut19 happy_x_2 of { happy_var_2 -> - case happyOut20 happy_x_4 of { happy_var_4 -> - happyIn20 - (map hide happy_var_2 ++ happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_118 = happySpecReduce_3 14# happyReduction_118 -happyReduction_118 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn20 - (map hide happy_var_2 - )} - -happyReduce_119 = happyReduce 5# 14# happyReduction_119 -happyReduction_119 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - happyIn20 - (map (hide . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_120 = happyReduce 4# 14# happyReduction_120 -happyReduction_120 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - happyIn20 - (map (hide . setRelevance Irrelevant . defaultArg) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_121 = happyReduce 5# 14# happyReduction_121 -happyReduction_121 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - happyIn20 - (map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_122 = happyReduce 4# 14# happyReduction_122 -happyReduction_122 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - happyIn20 - (map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_123 = happyReduce 5# 14# happyReduction_123 -happyReduction_123 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - happyIn20 - (map (hide . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_124 = happyReduce 4# 14# happyReduction_124 -happyReduction_124 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - happyIn20 - (map (hide . setRelevance NonStrict . defaultArg) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_125 = happyReduce 5# 14# happyReduction_125 -happyReduction_125 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - happyIn20 - (map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5 - ) `HappyStk` happyRest}} - -happyReduce_126 = happyReduce 4# 14# happyReduction_126 -happyReduction_126 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut16 happy_x_3 of { happy_var_3 -> - happyIn20 - (map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_127 = happyMonadReduce 1# 15# happyReduction_127 -happyReduction_127 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokQId happy_var_1) -> - ( mkQName happy_var_1)} - ) (\r -> happyReturn (happyIn21 r)) - -happyReduce_128 = happySpecReduce_1 15# happyReduction_128 -happyReduction_128 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn21 - (QName happy_var_1 - )} - -happyReduce_129 = happySpecReduce_1 16# happyReduction_129 -happyReduction_129 happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn22 - (happy_var_1 - )} - -happyReduce_130 = happySpecReduce_1 17# happyReduction_130 -happyReduction_130 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn23 - (happy_var_1 - )} - -happyReduce_131 = happySpecReduce_1 17# happyReduction_131 -happyReduction_131 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> - happyIn23 - (Name (getRange happy_var_1) [Hole] - )} - -happyReduce_132 = happySpecReduce_2 18# happyReduction_132 -happyReduction_132 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { happy_var_2 -> - happyIn24 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_133 = happySpecReduce_1 18# happyReduction_133 -happyReduction_133 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn24 - ([happy_var_1] - )} - -happyReduce_134 = happySpecReduce_1 19# happyReduction_134 -happyReduction_134 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn25 - (case happy_var_1 of - Left ns -> ns - Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern" - )} - -happyReduce_135 = happyMonadReduce 1# 20# happyReduction_135 -happyReduction_135 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut34 happy_x_1 of { happy_var_1 -> - ( - let getName (Ident (QName x)) = Just x - getName (Underscore r _) = Just (Name r [Hole]) - getName _ = Nothing - - containsAbsurd (Absurd _) = True - containsAbsurd (HiddenArg _ (Named _ e)) = containsAbsurd e - containsAbsurd (InstanceArg _ (Named _ e)) = containsAbsurd e - containsAbsurd (Paren _ expr) = containsAbsurd expr - containsAbsurd (RawApp _ exprs) = any containsAbsurd exprs - containsAbsurd _ = False - in - if isJust $ find containsAbsurd happy_var_1 then return $ Right happy_var_1 else - case partition isJust $ map getName happy_var_1 of - (good, []) -> return $ Left $ map fromJust good - _ -> fail $ "expected sequence of bound identifiers")} - ) (\r -> happyReturn (happyIn26 r)) - -happyReduce_136 = happySpecReduce_0 21# happyReduction_136 -happyReduction_136 = happyIn27 - ([] - ) - -happyReduce_137 = happySpecReduce_2 21# happyReduction_137 -happyReduction_137 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - case happyOut27 happy_x_2 of { happy_var_2 -> - happyIn27 - (snd happy_var_1 : happy_var_2 - )}} - -happyReduce_138 = happySpecReduce_1 22# happyReduction_138 -happyReduction_138 happy_x_1 - = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - happyIn28 - (snd happy_var_1 - )} - -happyReduce_139 = happyMonadReduce 1# 23# happyReduction_139 -happyReduction_139 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - ( mkName happy_var_1)} - ) (\r -> happyReturn (happyIn29 r)) - -happyReduce_140 = happyMonadReduce 1# 24# happyReduction_140 -happyReduction_140 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> - ( fmap QName (mkName happy_var_1))} - ) (\r -> happyReturn (happyIn30 r)) - -happyReduce_141 = happySpecReduce_2 25# happyReduction_141 -happyReduction_141 happy_x_2 - happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn31 - (Pi happy_var_1 happy_var_2 - )}} - -happyReduce_142 = happySpecReduce_3 25# happyReduction_142 -happyReduction_142 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut57 happy_x_2 of { happy_var_2 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn31 - (forallPi happy_var_2 happy_var_3 - )}} - -happyReduce_143 = happySpecReduce_3 25# happyReduction_143 -happyReduction_143 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokSymbol SymArrow happy_var_2) -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn31 - (Fun (getRange (happy_var_1,happy_var_2,happy_var_3)) - (RawApp (getRange happy_var_1) happy_var_1) - happy_var_3 - )}}} - -happyReduce_144 = happySpecReduce_3 25# happyReduction_144 -happyReduction_144 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokSymbol SymEqual happy_var_2) -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn31 - (Equal (getRange (happy_var_1, happy_var_2, happy_var_3)) happy_var_1 happy_var_3 - )}}} - -happyReduce_145 = happySpecReduce_1 25# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut32 happy_x_1 of { happy_var_1 -> - happyIn31 - (happy_var_1 - )} - -happyReduce_146 = happyMonadReduce 1# 26# happyReduction_146 -happyReduction_146 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut33 happy_x_1 of { happy_var_1 -> - ( case happy_var_1 of - { [e] -> return e - ; e : es -> return $ WithApp (fuseRange e es) e es - ; [] -> fail "impossible: empty with expressions" - })} - ) (\r -> happyReturn (happyIn32 r)) - -happyReduce_147 = happySpecReduce_3 27# happyReduction_147 -happyReduction_147 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut33 happy_x_3 of { happy_var_3 -> - happyIn33 - (RawApp (getRange happy_var_1) happy_var_1 : happy_var_3 - )}} - -happyReduce_148 = happySpecReduce_1 27# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOut34 happy_x_1 of { happy_var_1 -> - happyIn33 - ([RawApp (getRange happy_var_1) happy_var_1] - )} - -happyReduce_149 = happySpecReduce_1 28# happyReduction_149 -happyReduction_149 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn34 - ([happy_var_1] - )} - -happyReduce_150 = happySpecReduce_2 28# happyReduction_150 -happyReduction_150 happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn34 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_151 = happySpecReduce_3 29# happyReduction_151 -happyReduction_151 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> - case happyOut49 happy_x_2 of { happy_var_2 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn35 - (Lam (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 happy_var_3 - )}}} - -happyReduce_152 = happySpecReduce_1 29# happyReduction_152 -happyReduction_152 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn35 - (happy_var_1 - )} - -happyReduce_153 = happyReduce 4# 29# happyReduction_153 -happyReduction_153 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) -> - case happyOut140 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> - case happyOut31 happy_x_4 of { happy_var_4 -> - happyIn35 - (Let (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_154 = happySpecReduce_1 29# happyReduction_154 -happyReduction_154 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - happyIn35 - (happy_var_1 - )} - -happyReduce_155 = happyReduce 4# 29# happyReduction_155 -happyReduction_155 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> - case happyOut31 happy_x_4 of { happy_var_4 -> - happyIn35 - (QuoteGoal (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_156 = happyReduce 4# 29# happyReduction_156 -happyReduction_156 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> - case happyOut31 happy_x_4 of { happy_var_4 -> - happyIn35 - (QuoteContext (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_157 = happySpecReduce_2 29# happyReduction_157 -happyReduction_157 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> - case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn35 - (Tactic (getRange (happy_var_1, happy_var_2)) (RawApp (getRange happy_var_2) happy_var_2) [] - )}} - -happyReduce_158 = happyReduce 4# 29# happyReduction_158 -happyReduction_158 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> - case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymBar happy_var_3) -> - case happyOut33 happy_x_4 of { happy_var_4 -> - happyIn35 - (Tactic (getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4)) (RawApp (getRange happy_var_2) happy_var_2) happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_159 = happyReduce 4# 30# happyReduction_159 -happyReduction_159 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> - case happyOut56 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> - happyIn36 - (ExtendedLam (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) (reverse happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_160 = happyMonadReduce 2# 30# happyReduction_160 -happyReduction_160 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> - case happyOut50 happy_x_2 of { happy_var_2 -> - ( case happy_var_2 of - Left (bs, h) -> if null bs then return $ AbsurdLam r h else - return $ Lam r bs (AbsurdLam r h) - where r = fuseRange happy_var_1 bs - Right es -> do -- it is of the form @\ { p1 ... () }@ - p <- exprToLHS (RawApp (getRange es) es); - return $ ExtendedLam (fuseRange happy_var_1 es) - [(p [] [], AbsurdRHS, NoWhere)])}} - ) (\r -> happyReturn (happyIn36 r)) - -happyReduce_161 = happySpecReduce_1 31# happyReduction_161 -happyReduction_161 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - happyIn37 - ([happy_var_1] - )} - -happyReduce_162 = happySpecReduce_2 31# happyReduction_162 -happyReduction_162 happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut37 happy_x_2 of { happy_var_2 -> - happyIn37 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_163 = happySpecReduce_3 32# happyReduction_163 -happyReduction_163 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> - case happyOut31 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymCloseBrace happy_var_3) -> - happyIn38 - (HiddenArg (getRange (happy_var_1,happy_var_2,happy_var_3)) (maybeNamed happy_var_2) - )}}} - -happyReduce_164 = happySpecReduce_2 32# happyReduction_164 -happyReduction_164 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) -> - happyIn38 - (let r = fuseRange happy_var_1 happy_var_2 in HiddenArg r $ unnamed $ Absurd r - )}} - -happyReduce_165 = happySpecReduce_1 33# happyReduction_165 -happyReduction_165 happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn39 - (Ident happy_var_1 - )} - -happyReduce_166 = happySpecReduce_1 33# happyReduction_166 -happyReduction_166 happy_x_1 - = case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> - happyIn39 - (Lit happy_var_1 - )} - -happyReduce_167 = happySpecReduce_1 33# happyReduction_167 -happyReduction_167 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) -> - happyIn39 - (QuestionMark (getRange happy_var_1) Nothing - )} - -happyReduce_168 = happySpecReduce_1 33# happyReduction_168 -happyReduction_168 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> - happyIn39 - (Underscore (getRange happy_var_1) Nothing - )} - -happyReduce_169 = happySpecReduce_1 33# happyReduction_169 -happyReduction_169 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) -> - happyIn39 - (Prop (getRange happy_var_1) - )} - -happyReduce_170 = happySpecReduce_1 33# happyReduction_170 -happyReduction_170 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) -> - happyIn39 - (Set (getRange happy_var_1) - )} - -happyReduce_171 = happySpecReduce_1 33# happyReduction_171 -happyReduction_171 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) -> - happyIn39 - (Quote (getRange happy_var_1) - )} - -happyReduce_172 = happySpecReduce_1 33# happyReduction_172 -happyReduction_172 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) -> - happyIn39 - (QuoteTerm (getRange happy_var_1) - )} - -happyReduce_173 = happySpecReduce_1 33# happyReduction_173 -happyReduction_173 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) -> - happyIn39 - (Unquote (getRange happy_var_1) - )} - -happyReduce_174 = happySpecReduce_1 33# happyReduction_174 -happyReduction_174 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSetN happy_var_1) -> - happyIn39 - (SetN (getRange (fst happy_var_1)) (snd happy_var_1) - )} - -happyReduce_175 = happySpecReduce_3 33# happyReduction_175 -happyReduction_175 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> - case happyOut31 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn39 - (InstanceArg (getRange (happy_var_1,happy_var_2,happy_var_3)) - (maybeNamed happy_var_2) - )}}} - -happyReduce_176 = happySpecReduce_3 33# happyReduction_176 -happyReduction_176 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> - case happyOut31 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> - happyIn39 - (Paren (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 - )}}} - -happyReduce_177 = happySpecReduce_2 33# happyReduction_177 -happyReduction_177 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymCloseParen happy_var_2) -> - happyIn39 - (Absurd (fuseRange happy_var_1 happy_var_2) - )}} - -happyReduce_178 = happySpecReduce_2 33# happyReduction_178 -happyReduction_178 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> - case happyOut17 happy_x_2 of { happy_var_2 -> - happyIn39 - (let r = fuseRange happy_var_1 happy_var_2 in InstanceArg r $ unnamed $ Absurd r - )}} - -happyReduce_179 = happySpecReduce_3 33# happyReduction_179 -happyReduction_179 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokSymbol SymAs happy_var_2) -> - case happyOut40 happy_x_3 of { happy_var_3 -> - happyIn39 - (As (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_1 happy_var_3 - )}}} - -happyReduce_180 = happySpecReduce_2 33# happyReduction_180 -happyReduction_180 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) -> - case happyOut40 happy_x_2 of { happy_var_2 -> - happyIn39 - (Dot (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_181 = happyReduce 4# 33# happyReduction_181 -happyReduction_181 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> - case happyOut41 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> - happyIn39 - (Rec (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_182 = happyReduce 5# 33# happyReduction_182 -happyReduction_182 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> - case happyOut39 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymOpenBrace happy_var_3) -> - case happyOut41 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymCloseBrace happy_var_5) -> - happyIn39 - (RecUpdate (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}}}} - -happyReduce_183 = happySpecReduce_1 34# happyReduction_183 -happyReduction_183 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - happyIn40 - (happy_var_1 - )} - -happyReduce_184 = happySpecReduce_1 34# happyReduction_184 -happyReduction_184 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - happyIn40 - (happy_var_1 - )} - -happyReduce_185 = happySpecReduce_0 35# happyReduction_185 -happyReduction_185 = happyIn41 - ([] - ) - -happyReduce_186 = happySpecReduce_1 35# happyReduction_186 -happyReduction_186 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn41 - (happy_var_1 - )} - -happyReduce_187 = happySpecReduce_1 36# happyReduction_187 -happyReduction_187 happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - happyIn42 - ([happy_var_1] - )} - -happyReduce_188 = happySpecReduce_3 36# happyReduction_188 -happyReduction_188 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - case happyOut42 happy_x_3 of { happy_var_3 -> - happyIn42 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_189 = happySpecReduce_3 37# happyReduction_189 -happyReduction_189 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn43 - ((happy_var_1, happy_var_3) - )}} - -happyReduce_190 = happySpecReduce_2 38# happyReduction_190 -happyReduction_190 happy_x_2 - happy_x_1 - = case happyOut45 happy_x_1 of { happy_var_1 -> - happyIn44 - (happy_var_1 - )} - -happyReduce_191 = happySpecReduce_1 39# happyReduction_191 -happyReduction_191 happy_x_1 - = case happyOut46 happy_x_1 of { happy_var_1 -> - happyIn45 - ({-TeleBind-} happy_var_1 - )} - -happyReduce_192 = happySpecReduce_2 40# happyReduction_192 -happyReduction_192 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn46 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_193 = happySpecReduce_1 40# happyReduction_193 -happyReduction_193 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn46 - ([happy_var_1] - )} - -happyReduce_194 = happyReduce 4# 41# happyReduction_194 -happyReduction_194 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> - happyIn47 - (TypedBindings (getRange (happy_var_2,happy_var_3,happy_var_4)) - (setRelevance Irrelevant $ defaultColoredArg happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_195 = happyReduce 4# 41# happyReduction_195 -happyReduction_195 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> - happyIn47 - (TypedBindings (getRange (happy_var_2,happy_var_3,happy_var_4)) - (hide $ setRelevance Irrelevant $ defaultColoredArg happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_196 = happyReduce 4# 41# happyReduction_196 -happyReduction_196 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn47 - (TypedBindings (getRange (happy_var_2,happy_var_3,happy_var_4)) - (makeInstance $ setRelevance Irrelevant $ defaultColoredArg happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_197 = happyReduce 4# 41# happyReduction_197 -happyReduction_197 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> - happyIn47 - (TypedBindings (getRange (happy_var_2,happy_var_3,happy_var_4)) - (setRelevance NonStrict $ defaultColoredArg happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_198 = happyReduce 4# 41# happyReduction_198 -happyReduction_198 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> - happyIn47 - (TypedBindings (getRange (happy_var_2,happy_var_3,happy_var_4)) - (hide $ setRelevance NonStrict $ defaultColoredArg happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_199 = happyReduce 4# 41# happyReduction_199 -happyReduction_199 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> - case happyOut48 happy_x_3 of { happy_var_3 -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn47 - (TypedBindings (getRange (happy_var_2,happy_var_3,happy_var_4)) - (makeInstance $ setRelevance NonStrict $ defaultColoredArg happy_var_3) - ) `HappyStk` happyRest}}} - -happyReduce_200 = happySpecReduce_3 41# happyReduction_200 -happyReduction_200 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> - happyIn47 - (TypedBindings (getRange (happy_var_1,happy_var_2,happy_var_3)) - (defaultColoredArg happy_var_2) - )}}} - -happyReduce_201 = happySpecReduce_3 41# happyReduction_201 -happyReduction_201 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOut17 happy_x_3 of { happy_var_3 -> - happyIn47 - (TypedBindings (getRange (happy_var_1,happy_var_2,happy_var_3)) - (makeInstance $ defaultColoredArg happy_var_2) - )}}} - -happyReduce_202 = happySpecReduce_3 41# happyReduction_202 -happyReduction_202 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> - case happyOut48 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymCloseBrace happy_var_3) -> - happyIn47 - (TypedBindings (getRange (happy_var_1,happy_var_2,happy_var_3)) - (hide $ defaultColoredArg happy_var_2) - )}}} - -happyReduce_203 = happySpecReduce_3 41# happyReduction_203 -happyReduction_203 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> - case happyOut107 happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> - happyIn47 - (tLet (getRange (happy_var_1,happy_var_3)) happy_var_2 - )}}} - -happyReduce_204 = happyReduce 4# 41# happyReduction_204 -happyReduction_204 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> - case happyOut140 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> - happyIn47 - (tLet (getRange (happy_var_1,happy_var_4)) happy_var_3 - ) `HappyStk` happyRest}}} - -happyReduce_205 = happySpecReduce_3 42# happyReduction_205 -happyReduction_205 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokSymbol SymColon happy_var_2) -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn48 - (( [], TBind (getRange (happy_var_1,happy_var_2,happy_var_3)) (map mkBoundName_ happy_var_1) happy_var_3 ) - )}}} - -happyReduce_206 = happyMonadReduce 2# 43# happyReduction_206 -happyReduction_206 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> - ( - case reverse happy_var_1 of - Left _ : _ -> parseError "Absurd lambda cannot have a body." - _ : _ -> return [ b | Right b <- happy_var_1 ] - [] -> parsePanic "Empty LamBinds")} - ) (\r -> happyReturn (happyIn49 r)) - -happyReduce_207 = happyMonadReduce 1# 44# happyReduction_207 -happyReduction_207 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut52 happy_x_1 of { happy_var_1 -> - ( - case happy_var_1 of - Left lb -> case reverse lb of - Right _ : _ -> parseError "Missing body for lambda" - Left h : _ -> return $ Left ([ b | Right b <- init lb], h) - _ -> parsePanic "Empty LamBindsAbsurd" - Right es -> return $ Right es)} - ) (\r -> happyReturn (happyIn50 r)) - -happyReduce_208 = happySpecReduce_2 45# happyReduction_208 -happyReduction_208 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn51 - (map Right happy_var_1 ++ happy_var_2 - )}} - -happyReduce_209 = happySpecReduce_2 45# happyReduction_209 -happyReduction_209 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn51 - (Right (DomainFull happy_var_1) : happy_var_2 - )}} - -happyReduce_210 = happySpecReduce_1 45# happyReduction_210 -happyReduction_210 happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - happyIn51 - (map Right happy_var_1 - )} - -happyReduce_211 = happySpecReduce_1 45# happyReduction_211 -happyReduction_211 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn51 - ([Right $ DomainFull happy_var_1] - )} - -happyReduce_212 = happySpecReduce_2 45# happyReduction_212 -happyReduction_212 happy_x_2 - happy_x_1 - = happyIn51 - ([Left NotHidden] - ) - -happyReduce_213 = happySpecReduce_2 45# happyReduction_213 -happyReduction_213 happy_x_2 - happy_x_1 - = happyIn51 - ([Left Hidden] - ) - -happyReduce_214 = happySpecReduce_2 45# happyReduction_214 -happyReduction_214 happy_x_2 - happy_x_1 - = happyIn51 - ([Left Instance] - ) - -happyReduce_215 = happySpecReduce_2 46# happyReduction_215 -happyReduction_215 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn52 - (Left $ map Right happy_var_1 ++ happy_var_2 - )}} - -happyReduce_216 = happySpecReduce_2 46# happyReduction_216 -happyReduction_216 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn52 - (Left $ Right (DomainFull happy_var_1) : happy_var_2 - )}} - -happyReduce_217 = happySpecReduce_1 46# happyReduction_217 -happyReduction_217 happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - happyIn52 - (case happy_var_1 of - Left lb -> Left $ map Right lb - Right es -> Right es - )} - -happyReduce_218 = happySpecReduce_1 46# happyReduction_218 -happyReduction_218 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn52 - (Left [Right $ DomainFull happy_var_1] - )} - -happyReduce_219 = happySpecReduce_2 46# happyReduction_219 -happyReduction_219 happy_x_2 - happy_x_1 - = happyIn52 - (Left [Left NotHidden] - ) - -happyReduce_220 = happySpecReduce_2 46# happyReduction_220 -happyReduction_220 happy_x_2 - happy_x_1 - = happyIn52 - (Left [Left Hidden] - ) - -happyReduce_221 = happySpecReduce_2 46# happyReduction_221 -happyReduction_221 happy_x_2 - happy_x_1 - = happyIn52 - (Left [Left Instance] - ) - -happyReduce_222 = happyMonadReduce 3# 47# happyReduction_222 -happyReduction_222 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - ( do - p <- exprToLHS (RawApp (getRange happy_var_1) happy_var_1) ; - return (p [] [], RHS happy_var_3, NoWhere))}} - ) (\r -> happyReturn (happyIn53 r)) - -happyReduce_223 = happyMonadReduce 1# 48# happyReduction_223 -happyReduction_223 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut34 happy_x_1 of { happy_var_1 -> - ( do - p <- exprToLHS (RawApp (getRange happy_var_1) happy_var_1); - return (p [] [], AbsurdRHS, NoWhere))} - ) (\r -> happyReturn (happyIn54 r)) - -happyReduce_224 = happySpecReduce_1 49# happyReduction_224 -happyReduction_224 happy_x_1 - = case happyOut53 happy_x_1 of { happy_var_1 -> - happyIn55 - (happy_var_1 - )} - -happyReduce_225 = happySpecReduce_1 49# happyReduction_225 -happyReduction_225 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - happyIn55 - (happy_var_1 - )} - -happyReduce_226 = happySpecReduce_3 50# happyReduction_226 -happyReduction_226 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut56 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn56 - (happy_var_3 : happy_var_1 - )}} - -happyReduce_227 = happySpecReduce_3 50# happyReduction_227 -happyReduction_227 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_3 of { happy_var_3 -> - happyIn56 - ([happy_var_3, happy_var_1] - )}} - -happyReduce_228 = happySpecReduce_1 50# happyReduction_228 -happyReduction_228 happy_x_1 - = case happyOut53 happy_x_1 of { happy_var_1 -> - happyIn56 - ([happy_var_1] - )} - -happyReduce_229 = happySpecReduce_2 51# happyReduction_229 -happyReduction_229 happy_x_2 - happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn57 - (happy_var_1 - )} - -happyReduce_230 = happySpecReduce_2 52# happyReduction_230 -happyReduction_230 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - case happyOut58 happy_x_2 of { happy_var_2 -> - happyIn58 - (happy_var_1 ++ happy_var_2 - )}} - -happyReduce_231 = happySpecReduce_2 52# happyReduction_231 -happyReduction_231 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut58 happy_x_2 of { happy_var_2 -> - happyIn58 - (DomainFull happy_var_1 : happy_var_2 - )}} - -happyReduce_232 = happySpecReduce_1 52# happyReduction_232 -happyReduction_232 happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - happyIn58 - (happy_var_1 - )} - -happyReduce_233 = happySpecReduce_1 52# happyReduction_233 -happyReduction_233 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn58 - ([DomainFull happy_var_1] - )} - -happyReduce_234 = happySpecReduce_2 53# happyReduction_234 -happyReduction_234 happy_x_2 - happy_x_1 - = case happyOut60 happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_2 of { happy_var_2 -> - happyIn59 - (happy_var_1 ++ happy_var_2 - )}} - -happyReduce_235 = happySpecReduce_2 53# happyReduction_235 -happyReduction_235 happy_x_2 - happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_2 of { happy_var_2 -> - happyIn59 - (DomainFull happy_var_1 : happy_var_2 - )}} - -happyReduce_236 = happySpecReduce_0 53# happyReduction_236 -happyReduction_236 = happyIn59 - ([] - ) - -happyReduce_237 = happySpecReduce_1 54# happyReduction_237 -happyReduction_237 happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - happyIn60 - (case happy_var_1 of - Left lbs -> lbs - Right _ -> fail "expected sequence of bound identifiers, not absurd pattern" - )} - -happyReduce_238 = happySpecReduce_1 55# happyReduction_238 -happyReduction_238 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - happyIn61 - (Left [DomainFree defaultArgInfo $ mkBoundName_ happy_var_1] - )} - -happyReduce_239 = happySpecReduce_2 55# happyReduction_239 -happyReduction_239 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn61 - (Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ happy_var_2] - )} - -happyReduce_240 = happySpecReduce_2 55# happyReduction_240 -happyReduction_240 happy_x_2 - happy_x_1 - = case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn61 - (Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ happy_var_2] - )} - -happyReduce_241 = happySpecReduce_3 55# happyReduction_241 -happyReduction_241 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut26 happy_x_2 of { happy_var_2 -> - happyIn61 - (either (Left . map (DomainFree (setHiding Hidden $ defaultArgInfo) . mkBoundName_)) Right happy_var_2 - )} - -happyReduce_242 = happySpecReduce_3 55# happyReduction_242 -happyReduction_242 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn61 - (Left $ map (DomainFree (setHiding Instance $ defaultArgInfo) . mkBoundName_) happy_var_2 - )} - -happyReduce_243 = happyReduce 4# 55# happyReduction_243 -happyReduction_243 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn61 - (Left $ map (DomainFree (setHiding Hidden $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_244 = happyReduce 4# 55# happyReduction_244 -happyReduction_244 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn61 - (Left $ map (DomainFree (setHiding Instance $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_245 = happyReduce 4# 55# happyReduction_245 -happyReduction_245 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn61 - (Left $ map (DomainFree (setHiding Hidden $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_246 = happyReduce 4# 55# happyReduction_246 -happyReduction_246 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut25 happy_x_3 of { happy_var_3 -> - happyIn61 - (Left $ map (DomainFree (setHiding Instance $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3 - ) `HappyStk` happyRest} - -happyReduce_247 = happyMonadReduce 1# 56# happyReduction_247 -happyReduction_247 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut63 happy_x_1 of { happy_var_1 -> - ( mergeImportDirectives happy_var_1)} - ) (\r -> happyReturn (happyIn62 r)) - -happyReduce_248 = happySpecReduce_2 57# happyReduction_248 -happyReduction_248 happy_x_2 - happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_2 of { happy_var_2 -> - happyIn63 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_249 = happySpecReduce_0 57# happyReduction_249 -happyReduction_249 = happyIn63 - ([] - ) - -happyReduce_250 = happySpecReduce_1 58# happyReduction_250 -happyReduction_250 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) -> - happyIn64 - (defaultImportDir { importDirRange = getRange happy_var_1, publicOpen = True } - )} - -happyReduce_251 = happySpecReduce_1 58# happyReduction_251 -happyReduction_251 happy_x_1 - = case happyOut65 happy_x_1 of { happy_var_1 -> - happyIn64 - (defaultImportDir { importDirRange = snd happy_var_1, usingOrHiding = fst happy_var_1 } - )} - -happyReduce_252 = happySpecReduce_1 58# happyReduction_252 -happyReduction_252 happy_x_1 - = case happyOut66 happy_x_1 of { happy_var_1 -> - happyIn64 - (defaultImportDir { importDirRange = snd happy_var_1, renaming = fst happy_var_1 } - )} - -happyReduce_253 = happyReduce 4# 59# happyReduction_253 -happyReduction_253 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwUsing happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> - case happyOut71 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> - happyIn65 - ((Using happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_254 = happyReduce 4# 59# happyReduction_254 -happyReduction_254 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwHiding happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> - case happyOut71 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> - happyIn65 - ((Hiding happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_255 = happyReduce 4# 60# happyReduction_255 -happyReduction_255 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> - case happyOut67 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> - happyIn66 - ((happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) - ) `HappyStk` happyRest}}}} - -happyReduce_256 = happySpecReduce_3 60# happyReduction_256 -happyReduction_256 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> - case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> - case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> - happyIn66 - (([] , getRange (happy_var_1,happy_var_2,happy_var_3)) - )}}} - -happyReduce_257 = happySpecReduce_3 61# happyReduction_257 -happyReduction_257 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut68 happy_x_1 of { happy_var_1 -> - case happyOut67 happy_x_3 of { happy_var_3 -> - happyIn67 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_258 = happySpecReduce_1 61# happyReduction_258 -happyReduction_258 happy_x_1 - = case happyOut68 happy_x_1 of { happy_var_1 -> - happyIn67 - ([happy_var_1] - )} - -happyReduce_259 = happySpecReduce_3 62# happyReduction_259 -happyReduction_259 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokKeyword KwTo happy_var_2) -> - case happyOut15 happy_x_3 of { happy_var_3 -> - happyIn68 - (Renaming happy_var_1 happy_var_3 (getRange happy_var_2) - )}}} - -happyReduce_260 = happySpecReduce_2 63# happyReduction_260 -happyReduction_260 happy_x_2 - happy_x_1 - = case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn69 - (ImportedName happy_var_2 - )} - -happyReduce_261 = happySpecReduce_3 63# happyReduction_261 -happyReduction_261 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut15 happy_x_3 of { happy_var_3 -> - happyIn69 - (ImportedModule happy_var_3 - )} - -happyReduce_262 = happySpecReduce_1 64# happyReduction_262 -happyReduction_262 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn70 - (ImportedName happy_var_1 - )} - -happyReduce_263 = happySpecReduce_2 64# happyReduction_263 -happyReduction_263 happy_x_2 - happy_x_1 - = case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn70 - (ImportedModule happy_var_2 - )} - -happyReduce_264 = happySpecReduce_0 65# happyReduction_264 -happyReduction_264 = happyIn71 - ([] - ) - -happyReduce_265 = happySpecReduce_1 65# happyReduction_265 -happyReduction_265 happy_x_1 - = case happyOut72 happy_x_1 of { happy_var_1 -> - happyIn71 - (happy_var_1 - )} - -happyReduce_266 = happySpecReduce_1 66# happyReduction_266 -happyReduction_266 happy_x_1 - = case happyOut70 happy_x_1 of { happy_var_1 -> - happyIn72 - ([happy_var_1] - )} - -happyReduce_267 = happySpecReduce_3 66# happyReduction_267 -happyReduction_267 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut70 happy_x_1 of { happy_var_1 -> - case happyOut72 happy_x_3 of { happy_var_3 -> - happyIn72 - (happy_var_1 : happy_var_3 - )}} - -happyReduce_268 = happyMonadReduce 3# 67# happyReduction_268 -happyReduction_268 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut32 happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - case happyOut75 happy_x_3 of { happy_var_3 -> - ( exprToLHS happy_var_1 >>= \p -> return (p happy_var_2 happy_var_3))}}} - ) (\r -> happyReturn (happyIn73 r)) - -happyReduce_269 = happyReduce 4# 67# happyReduction_269 -happyReduction_269 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) -> - case happyOut74 happy_x_2 of { happy_var_2 -> - case happyOut76 happy_x_3 of { happy_var_3 -> - case happyOut75 happy_x_4 of { happy_var_4 -> - happyIn73 - (Ellipsis (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}}} - -happyReduce_270 = happySpecReduce_0 68# happyReduction_270 -happyReduction_270 = happyIn74 - ([] - ) - -happyReduce_271 = happyMonadReduce 3# 68# happyReduction_271 -happyReduction_271 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut37 happy_x_2 of { happy_var_2 -> - case happyOut74 happy_x_3 of { happy_var_3 -> - ( exprToPattern (RawApp (getRange happy_var_2) happy_var_2) >>= \p -> - return (p : happy_var_3))}} - ) (\r -> happyReturn (happyIn74 r)) - -happyReduce_272 = happySpecReduce_0 69# happyReduction_272 -happyReduction_272 = happyIn75 - ([] - ) - -happyReduce_273 = happySpecReduce_2 69# happyReduction_273 -happyReduction_273 happy_x_2 - happy_x_1 - = case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn75 - (case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] } - )} - -happyReduce_274 = happySpecReduce_0 70# happyReduction_274 -happyReduction_274 = happyIn76 - ([] - ) - -happyReduce_275 = happySpecReduce_2 70# happyReduction_275 -happyReduction_275 happy_x_2 - happy_x_1 - = case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn76 - (case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] } - )} - -happyReduce_276 = happySpecReduce_0 71# happyReduction_276 -happyReduction_276 = happyIn77 - (NoWhere - ) - -happyReduce_277 = happySpecReduce_2 71# happyReduction_277 -happyReduction_277 happy_x_2 - happy_x_1 - = case happyOut141 happy_x_2 of { happy_var_2 -> - happyIn77 - (AnyWhere happy_var_2 - )} - -happyReduce_278 = happyReduce 4# 71# happyReduction_278 -happyReduction_278 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut141 happy_x_4 of { happy_var_4 -> - happyIn77 - (SomeWhere happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_279 = happyReduce 4# 71# happyReduction_279 -happyReduction_279 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut112 happy_x_2 of { happy_var_2 -> - case happyOut141 happy_x_4 of { happy_var_4 -> - happyIn77 - (SomeWhere happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_280 = happySpecReduce_1 72# happyReduction_280 -happyReduction_280 happy_x_1 - = case happyOut89 happy_x_1 of { happy_var_1 -> - happyIn78 - (happy_var_1 - )} - -happyReduce_281 = happySpecReduce_1 72# happyReduction_281 -happyReduction_281 happy_x_1 - = case happyOut81 happy_x_1 of { happy_var_1 -> - happyIn78 - (happy_var_1 - )} - -happyReduce_282 = happySpecReduce_1 72# happyReduction_282 -happyReduction_282 happy_x_1 - = case happyOut83 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_283 = happySpecReduce_1 72# happyReduction_283 -happyReduction_283 happy_x_1 - = case happyOut84 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_284 = happySpecReduce_1 72# happyReduction_284 -happyReduction_284 happy_x_1 - = case happyOut85 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_285 = happySpecReduce_1 72# happyReduction_285 -happyReduction_285 happy_x_1 - = case happyOut86 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_286 = happySpecReduce_1 72# happyReduction_286 -happyReduction_286 happy_x_1 - = case happyOut88 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_287 = happySpecReduce_1 72# happyReduction_287 -happyReduction_287 happy_x_1 - = case happyOut90 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_288 = happySpecReduce_1 72# happyReduction_288 -happyReduction_288 happy_x_1 - = case happyOut91 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_289 = happySpecReduce_1 72# happyReduction_289 -happyReduction_289 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_290 = happySpecReduce_1 72# happyReduction_290 -happyReduction_290 happy_x_1 - = case happyOut93 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_291 = happySpecReduce_1 72# happyReduction_291 -happyReduction_291 happy_x_1 - = case happyOut94 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_292 = happySpecReduce_1 72# happyReduction_292 -happyReduction_292 happy_x_1 - = case happyOut95 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_293 = happySpecReduce_1 72# happyReduction_293 -happyReduction_293 happy_x_1 - = case happyOut107 happy_x_1 of { happy_var_1 -> - happyIn78 - (happy_var_1 - )} - -happyReduce_294 = happySpecReduce_1 72# happyReduction_294 -happyReduction_294 happy_x_1 - = case happyOut110 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_295 = happySpecReduce_1 72# happyReduction_295 -happyReduction_295 happy_x_1 - = case happyOut111 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_296 = happySpecReduce_1 72# happyReduction_296 -happyReduction_296 happy_x_1 - = case happyOut114 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_297 = happySpecReduce_1 72# happyReduction_297 -happyReduction_297 happy_x_1 - = case happyOut97 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_298 = happySpecReduce_1 72# happyReduction_298 -happyReduction_298 happy_x_1 - = case happyOut98 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_299 = happySpecReduce_1 72# happyReduction_299 -happyReduction_299 happy_x_1 - = case happyOut96 happy_x_1 of { happy_var_1 -> - happyIn78 - ([happy_var_1] - )} - -happyReduce_300 = happySpecReduce_3 73# happyReduction_300 -happyReduction_300 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut16 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn79 - (map (flip (TypeSig defaultArgInfo) happy_var_3) happy_var_1 - )}} - -happyReduce_301 = happySpecReduce_3 74# happyReduction_301 -happyReduction_301 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - case happyOut31 happy_x_3 of { happy_var_3 -> - happyIn80 - (map (fmap (flip (TypeSig defaultArgInfo) happy_var_3)) happy_var_1 - )}} - -happyReduce_302 = happyMonadReduce 3# 75# happyReduction_302 -happyReduction_302 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut73 happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_2 of { happy_var_2 -> - case happyOut77 happy_x_3 of { happy_var_3 -> - ( funClauseOrTypeSigs happy_var_1 happy_var_2 happy_var_3)}}} - ) (\r -> happyReturn (happyIn81 r)) - -happyReduce_303 = happySpecReduce_2 76# happyReduction_303 -happyReduction_303 happy_x_2 - happy_x_1 - = case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn82 - (JustRHS (RHS happy_var_2) - )} - -happyReduce_304 = happySpecReduce_2 76# happyReduction_304 -happyReduction_304 happy_x_2 - happy_x_1 - = case happyOut31 happy_x_2 of { happy_var_2 -> - happyIn82 - (TypeSigsRHS happy_var_2 - )} - -happyReduce_305 = happySpecReduce_0 76# happyReduction_305 -happyReduction_305 = happyIn82 - (JustRHS AbsurdRHS - ) - -happyReduce_306 = happyReduce 7# 77# happyReduction_306 -happyReduction_306 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> - case happyOut31 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> - case happyOut137 happy_x_7 of { happy_var_7 -> - happyIn83 - (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) Inductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7 - ) `HappyStk` happyRest}}}}}}} - -happyReduce_307 = happyReduce 7# 77# happyReduction_307 -happyReduction_307 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> - case happyOut31 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> - case happyOut137 happy_x_7 of { happy_var_7 -> - happyIn83 - (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) CoInductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7 - ) `HappyStk` happyRest}}}}}}} - -happyReduce_308 = happyReduce 5# 77# happyReduction_308 -happyReduction_308 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> - case happyOut137 happy_x_5 of { happy_var_5 -> - happyIn83 - (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 Nothing happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_309 = happyReduce 5# 77# happyReduction_309 -happyReduction_309 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> - case happyOut137 happy_x_5 of { happy_var_5 -> - happyIn83 - (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) CoInductive happy_var_2 happy_var_3 Nothing happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_310 = happyReduce 5# 78# happyReduction_310 -happyReduction_310 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> - case happyOut31 happy_x_5 of { happy_var_5 -> - happyIn84 - (DataSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_311 = happyMonadReduce 7# 79# happyReduction_311 -happyReduction_311 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> - case happyOut39 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> - case happyOut31 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> - case happyOut138 happy_x_7 of { happy_var_7 -> - ( exprToName happy_var_2 >>= \ n -> return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) n (fst3 happy_var_7) (snd3 happy_var_7) happy_var_3 (Just happy_var_5) (thd3 happy_var_7))}}}}}}} - ) (\r -> happyReturn (happyIn85 r)) - -happyReduce_312 = happyMonadReduce 5# 79# happyReduction_312 -happyReduction_312 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> - case happyOut39 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> - case happyOut138 happy_x_5 of { happy_var_5 -> - ( exprToName happy_var_2 >>= \ n -> return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n (fst3 happy_var_5) (snd3 happy_var_5) happy_var_3 Nothing (thd3 happy_var_5))}}}}} - ) (\r -> happyReturn (happyIn85 r)) - -happyReduce_313 = happyMonadReduce 5# 80# happyReduction_313 -happyReduction_313 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> - case happyOut39 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> - case happyOut31 happy_x_5 of { happy_var_5 -> - ( exprToName happy_var_2 >>= \ n -> return $ RecordSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n happy_var_3 happy_var_5)}}}}} - ) (\r -> happyReturn (happyIn86 r)) - -happyReduce_314 = happySpecReduce_2 81# happyReduction_314 -happyReduction_314 happy_x_2 - happy_x_1 - = case happyOut15 happy_x_2 of { happy_var_2 -> - happyIn87 - (happy_var_2 - )} - -happyReduce_315 = happySpecReduce_3 82# happyReduction_315 -happyReduction_315 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) -> - case happyOut14 happy_x_2 of { happy_var_2 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - happyIn88 - (Infix (NonAssoc (getRange (happy_var_1,happy_var_3)) happy_var_2) happy_var_3 - )}}} - -happyReduce_316 = happySpecReduce_3 82# happyReduction_316 -happyReduction_316 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) -> - case happyOut14 happy_x_2 of { happy_var_2 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - happyIn88 - (Infix (LeftAssoc (getRange (happy_var_1,happy_var_3)) happy_var_2) happy_var_3 - )}}} - -happyReduce_317 = happySpecReduce_3 82# happyReduction_317 -happyReduction_317 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) -> - case happyOut14 happy_x_2 of { happy_var_2 -> - case happyOut24 happy_x_3 of { happy_var_3 -> - happyIn88 - (Infix (RightAssoc (getRange (happy_var_1,happy_var_3)) happy_var_2) happy_var_3 - )}}} - -happyReduce_318 = happySpecReduce_2 83# happyReduction_318 -happyReduction_318 happy_x_2 - happy_x_1 - = case happyOut135 happy_x_2 of { happy_var_2 -> - happyIn89 - (let toField (Common.Arg info (TypeSig _ x t)) = Field x (Common.Arg info t) in map toField happy_var_2 - )} - -happyReduce_319 = happySpecReduce_2 84# happyReduction_319 -happyReduction_319 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) -> - case happyOut140 happy_x_2 of { happy_var_2 -> - happyIn90 - (Mutual (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_320 = happySpecReduce_2 85# happyReduction_320 -happyReduction_320 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) -> - case happyOut140 happy_x_2 of { happy_var_2 -> - happyIn91 - (Abstract (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_321 = happySpecReduce_2 86# happyReduction_321 -happyReduction_321 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) -> - case happyOut140 happy_x_2 of { happy_var_2 -> - happyIn92 - (Private (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_322 = happySpecReduce_2 87# happyReduction_322 -happyReduction_322 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) -> - case happyOut140 happy_x_2 of { happy_var_2 -> - happyIn93 - (InstanceB (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_323 = happySpecReduce_2 88# happyReduction_323 -happyReduction_323 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) -> - case happyOut140 happy_x_2 of { happy_var_2 -> - happyIn94 - (Postulate (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_324 = happySpecReduce_2 89# happyReduction_324 -happyReduction_324 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) -> - case happyOut133 happy_x_2 of { happy_var_2 -> - happyIn95 - (Primitive (fuseRange happy_var_1 happy_var_2) happy_var_2 - )}} - -happyReduce_325 = happyReduce 4# 90# happyReduction_325 -happyReduction_325 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut31 happy_x_4 of { happy_var_4 -> - happyIn96 - (UnquoteDecl (fuseRange happy_var_1 happy_var_4) happy_var_2 happy_var_4 - ) `HappyStk` happyRest}}} - -happyReduce_326 = happyMonadReduce 5# 91# happyReduction_326 -happyReduction_326 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut101 happy_x_3 of { happy_var_3 -> - case happyOut100 happy_x_5 of { happy_var_5 -> - ( - case happy_var_2 of - Name _ [_] -> case mkNotation happy_var_3 (map rangedThing happy_var_5) of - Left err -> parseError $ "Malformed syntax declaration: " ++ err - Right n -> return $ Syntax happy_var_2 n - _ -> parseError "Syntax declarations are allowed only for simple names (without holes)")}}} - ) (\r -> happyReturn (happyIn97 r)) - -happyReduce_327 = happyMonadReduce 5# 92# happyReduction_327 -happyReduction_327 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwPatternSyn happy_var_1) -> - case happyOut15 happy_x_2 of { happy_var_2 -> - case happyOut99 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymEqual happy_var_4) -> - case happyOut31 happy_x_5 of { happy_var_5 -> - ( do - p <- exprToPattern happy_var_5 - return (PatternSyn (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_3 p))}}}}} - ) (\r -> happyReturn (happyIn98 r)) - -happyReduce_328 = happySpecReduce_0 93# happyReduction_328 -happyReduction_328 = happyIn99 - ([] - ) - -happyReduce_329 = happyMonadReduce 1# 93# happyReduction_329 -happyReduction_329 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut51 happy_x_1 of { happy_var_1 -> - ( patternSynArgs happy_var_1)} - ) (\r -> happyReturn (happyIn99 r)) - -happyReduce_330 = happySpecReduce_1 94# happyReduction_330 -happyReduction_330 happy_x_1 - = case happyOut105 happy_x_1 of { happy_var_1 -> - happyIn100 - ([happy_var_1] - )} - -happyReduce_331 = happySpecReduce_2 94# happyReduction_331 -happyReduction_331 happy_x_2 - happy_x_1 - = case happyOut100 happy_x_1 of { happy_var_1 -> - case happyOut105 happy_x_2 of { happy_var_2 -> - happyIn100 - (happy_var_1 ++ [happy_var_2] - )}} - -happyReduce_332 = happySpecReduce_1 95# happyReduction_332 -happyReduction_332 happy_x_1 - = case happyOut102 happy_x_1 of { happy_var_1 -> - happyIn101 - ([happy_var_1] - )} - -happyReduce_333 = happySpecReduce_2 95# happyReduction_333 -happyReduction_333 happy_x_2 - happy_x_1 - = case happyOut101 happy_x_1 of { happy_var_1 -> - case happyOut102 happy_x_2 of { happy_var_2 -> - happyIn101 - (happy_var_1 ++ [happy_var_2] - )}} - -happyReduce_334 = happySpecReduce_1 96# happyReduction_334 -happyReduction_334 happy_x_1 - = case happyOut103 happy_x_1 of { happy_var_1 -> - happyIn102 - (defaultNamedArg happy_var_1 - )} - -happyReduce_335 = happySpecReduce_3 96# happyReduction_335 -happyReduction_335 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut104 happy_x_2 of { happy_var_2 -> - happyIn102 - (setHiding Hidden $ defaultNamedArg happy_var_2 - )} - -happyReduce_336 = happySpecReduce_3 96# happyReduction_336 -happyReduction_336 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut104 happy_x_2 of { happy_var_2 -> - happyIn102 - (setHiding Instance $ defaultNamedArg happy_var_2 - )} - -happyReduce_337 = happyReduce 5# 96# happyReduction_337 -happyReduction_337 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut105 happy_x_2 of { happy_var_2 -> - case happyOut104 happy_x_4 of { happy_var_4 -> - happyIn102 - (setHiding Hidden $ defaultArg $ named happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_338 = happyReduce 5# 96# happyReduction_338 -happyReduction_338 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut105 happy_x_2 of { happy_var_2 -> - case happyOut104 happy_x_4 of { happy_var_4 -> - happyIn102 - (setHiding Instance $ defaultArg $ named happy_var_2 happy_var_4 - ) `HappyStk` happyRest}} - -happyReduce_339 = happySpecReduce_1 97# happyReduction_339 -happyReduction_339 happy_x_1 - = case happyOut105 happy_x_1 of { happy_var_1 -> - happyIn103 - (ExprHole (rangedThing happy_var_1) - )} - -happyReduce_340 = happyReduce 6# 97# happyReduction_340 -happyReduction_340 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut105 happy_x_3 of { happy_var_3 -> - case happyOut105 happy_x_5 of { happy_var_5 -> - happyIn103 - (LambdaHole (rangedThing happy_var_3) (rangedThing happy_var_5) - ) `HappyStk` happyRest}} - -happyReduce_341 = happySpecReduce_1 98# happyReduction_341 -happyReduction_341 happy_x_1 - = case happyOut105 happy_x_1 of { happy_var_1 -> - happyIn104 - (ExprHole (rangedThing happy_var_1) - )} - -happyReduce_342 = happyReduce 4# 98# happyReduction_342 -happyReduction_342 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut105 happy_x_2 of { happy_var_2 -> - case happyOut105 happy_x_4 of { happy_var_4 -> - happyIn104 - (LambdaHole (rangedThing happy_var_2) (rangedThing happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_343 = happySpecReduce_1 99# happyReduction_343 -happyReduction_343 happy_x_1 - = case happyOutTok happy_x_1 of { (TokId happy_var_1) -> - happyIn105 - (Ranged (getRange $ fst happy_var_1) (stringToRawName $ snd happy_var_1) - )} - -happyReduce_344 = happySpecReduce_1 100# happyReduction_344 -happyReduction_344 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> - happyIn106 - (Just (getRange happy_var_1) - )} - -happyReduce_345 = happySpecReduce_0 100# happyReduction_345 -happyReduction_345 = happyIn106 - (Nothing - ) - -happyReduce_346 = happyMonadReduce 5# 101# happyReduction_346 -happyReduction_346 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOut106 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokKeyword KwImport happy_var_2) -> - case happyOut22 happy_x_3 of { happy_var_3 -> - case happyOut108 happy_x_4 of { happy_var_4 -> - case happyOut62 happy_x_5 of { happy_var_5 -> - ( - let - { doOpen = maybe DontOpen (const DoOpen) happy_var_1 - ; m = happy_var_3 - ; es = happy_var_4 - ; dir = happy_var_5 - ; r = getRange (m, es, dir) - ; mr = getRange m - ; unique = hashString $ show $ (Nothing :: Maybe ()) <$ r - -- turn range into unique id, but delete file path - -- which is absolute and messes up suite of failing tests - -- (different hashs on different installations) - -- TODO: Don't use (insecure) hashes in this way. - ; fresh = Name mr [ Id $ stringToRawName $ ".#" ++ show m ++ "-" ++ show unique ] - ; impStm asR = Import mr m (Just (AsName fresh asR)) DontOpen defaultImportDir - ; appStm m' es = - let r = getRange (m, es) in - Private r - [ ModuleMacro r m' - (SectionApp (getRange es) [] - (RawApp (getRange es) (Ident (QName fresh) : es))) - doOpen dir - ] - ; (initArgs, last2Args) = splitAt (length es - 2) es - ; parseAsClause = case last2Args of - { [ Ident (QName (Name asR [Id x])) - , Ident (QName m') - ] | rawNameToString x == "as" -> Just (asR, m') - ; _ -> Nothing - } - } in - case es of - { [] -> return [Import mr m Nothing doOpen dir] - ; _ | Just (asR, m') <- parseAsClause -> - if null initArgs then return - [ Import (getRange (m, asR, m', dir)) m - (Just (AsName m' asR)) doOpen dir - ] - else return [ impStm asR, appStm m' initArgs ] - | DontOpen <- doOpen -> parseErrorAt (fromJust $ rStart $ getRange happy_var_2) "An import statement with module instantiation does not actually import the module. This statement achieves nothing. Either add the `open' keyword or bind the instantiated module with an `as' clause." - | otherwise -> return - [ impStm noRange - , appStm (noName $ beginningOf $ getRange m) es - ] - })}}}}} - ) (\r -> happyReturn (happyIn107 r)) - -happyReduce_347 = happyReduce 4# 101# happyReduction_347 -happyReduction_347 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_2 of { happy_var_2 -> - case happyOut108 happy_x_3 of { happy_var_3 -> - case happyOut62 happy_x_4 of { happy_var_4 -> - happyIn107 - (let - { m = happy_var_2 - ; es = happy_var_3 - ; dir = happy_var_4 - ; r = getRange (m, es, dir) - } in - [ case es of - { [] -> Open r m dir - ; _ -> Private r [ ModuleMacro r (noName $ beginningOf $ getRange m) - (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es))) - DoOpen dir - ] - } - ] - ) `HappyStk` happyRest}}} - -happyReduce_348 = happyReduce 6# 101# happyReduction_348 -happyReduction_348 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_2 of { happy_var_2 -> - case happyOut62 happy_x_6 of { happy_var_6 -> - happyIn107 - (let r = getRange happy_var_2 in - [ Private r [ ModuleMacro r (noName $ beginningOf $ getRange happy_var_2) - (RecordModuleIFS r happy_var_2) DoOpen happy_var_6 - ] - ] - ) `HappyStk` happyRest}} - -happyReduce_349 = happySpecReduce_0 102# happyReduction_349 -happyReduction_349 = happyIn108 - ([] - ) - -happyReduce_350 = happySpecReduce_2 102# happyReduction_350 -happyReduction_350 happy_x_2 - happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - case happyOut108 happy_x_2 of { happy_var_2 -> - happyIn108 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_351 = happyReduce 4# 103# happyReduction_351 -happyReduction_351 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> - case happyOutTok happy_x_3 of { (TokSymbol SymEllipsis happy_var_3) -> - case happyOut17 happy_x_4 of { happy_var_4 -> - happyIn109 - ((\ts -> - if null ts then return $ RecordModuleIFS (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_1 - else parseError "No bindings allowed for record module with non-canonical implicits" ) - ) `HappyStk` happyRest}}}} - -happyReduce_352 = happySpecReduce_2 103# happyReduction_352 -happyReduction_352 happy_x_2 - happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut108 happy_x_2 of { happy_var_2 -> - happyIn109 - ((\ts -> return $ SectionApp (getRange (happy_var_1, happy_var_2)) ts (RawApp (fuseRange happy_var_1 happy_var_2) (Ident happy_var_1 : happy_var_2)) ) - )}} - -happyReduce_353 = happyMonadReduce 6# 104# happyReduction_353 -happyReduction_353 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> - case happyOut22 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOut109 happy_x_5 of { happy_var_5 -> - case happyOut62 happy_x_6 of { happy_var_6 -> - ( do { ma <- happy_var_5 (map addType happy_var_3) - ; name <- ensureUnqual happy_var_2 - ; return $ ModuleMacro (getRange (happy_var_1, happy_var_2, ma, happy_var_6)) name ma DontOpen happy_var_6 })}}}}} - ) (\r -> happyReturn (happyIn110 r)) - -happyReduce_354 = happyMonadReduce 7# 104# happyReduction_354 -happyReduction_354 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwModule happy_var_2) -> - case happyOut15 happy_x_3 of { happy_var_3 -> - case happyOut59 happy_x_4 of { happy_var_4 -> - case happyOut109 happy_x_6 of { happy_var_6 -> - case happyOut62 happy_x_7 of { happy_var_7 -> - ( do {ma <- happy_var_6 (map addType happy_var_4); return $ ModuleMacro (getRange (happy_var_1, happy_var_2, happy_var_3, ma, happy_var_7)) happy_var_3 ma DoOpen happy_var_7 })}}}}}} - ) (\r -> happyReturn (happyIn110 r)) - -happyReduce_355 = happyReduce 5# 105# happyReduction_355 -happyReduction_355 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> - case happyOut22 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> - case happyOut141 happy_x_5 of { happy_var_5 -> - happyIn111 - (Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 (map addType happy_var_3) happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_356 = happyReduce 5# 105# happyReduction_356 -happyReduction_356 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> - case happyOut112 happy_x_2 of { happy_var_2 -> - case happyOut59 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> - case happyOut141 happy_x_5 of { happy_var_5 -> - happyIn111 - (Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) (QName happy_var_2) (map addType happy_var_3) happy_var_5 - ) `HappyStk` happyRest}}}}} - -happyReduce_357 = happySpecReduce_1 106# happyReduction_357 -happyReduction_357 happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> - happyIn112 - (noName (getRange happy_var_1) - )} - -happyReduce_358 = happySpecReduce_1 107# happyReduction_358 -happyReduction_358 happy_x_1 - = case happyOut143 happy_x_1 of { happy_var_1 -> - happyIn113 - (figureOutTopLevelModule happy_var_1 - )} - -happyReduce_359 = happySpecReduce_1 108# happyReduction_359 -happyReduction_359 happy_x_1 - = case happyOut115 happy_x_1 of { happy_var_1 -> - happyIn114 - (Pragma happy_var_1 - )} - -happyReduce_360 = happySpecReduce_1 109# happyReduction_360 -happyReduction_360 happy_x_1 - = case happyOut117 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_361 = happySpecReduce_1 109# happyReduction_361 -happyReduction_361 happy_x_1 - = case happyOut118 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_362 = happySpecReduce_1 109# happyReduction_362 -happyReduction_362 happy_x_1 - = case happyOut119 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_363 = happySpecReduce_1 109# happyReduction_363 -happyReduction_363 happy_x_1 - = case happyOut120 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_364 = happySpecReduce_1 109# happyReduction_364 -happyReduction_364 happy_x_1 - = case happyOut122 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_365 = happySpecReduce_1 109# happyReduction_365 -happyReduction_365 happy_x_1 - = case happyOut121 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_366 = happySpecReduce_1 109# happyReduction_366 -happyReduction_366 happy_x_1 - = case happyOut123 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_367 = happySpecReduce_1 109# happyReduction_367 -happyReduction_367 happy_x_1 - = case happyOut124 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_368 = happySpecReduce_1 109# happyReduction_368 -happyReduction_368 happy_x_1 - = case happyOut125 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_369 = happySpecReduce_1 109# happyReduction_369 -happyReduction_369 happy_x_1 - = case happyOut131 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_370 = happySpecReduce_1 109# happyReduction_370 -happyReduction_370 happy_x_1 - = case happyOut132 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_371 = happySpecReduce_1 109# happyReduction_371 -happyReduction_371 happy_x_1 - = case happyOut126 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_372 = happySpecReduce_1 109# happyReduction_372 -happyReduction_372 happy_x_1 - = case happyOut129 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_373 = happySpecReduce_1 109# happyReduction_373 -happyReduction_373 happy_x_1 - = case happyOut128 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_374 = happySpecReduce_1 109# happyReduction_374 -happyReduction_374 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_375 = happySpecReduce_1 109# happyReduction_375 -happyReduction_375 happy_x_1 - = case happyOut130 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_376 = happySpecReduce_1 109# happyReduction_376 -happyReduction_376 happy_x_1 - = case happyOut116 happy_x_1 of { happy_var_1 -> - happyIn115 - (happy_var_1 - )} - -happyReduce_377 = happyReduce 4# 110# happyReduction_377 -happyReduction_377 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwOPTIONS happy_var_2) -> - case happyOut27 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> - happyIn116 - (OptionsPragma (getRange (happy_var_1,happy_var_2,happy_var_4)) happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_378 = happyReduce 5# 111# happyReduction_378 -happyReduction_378 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwBUILTIN happy_var_2) -> - case happyOutTok happy_x_3 of { (TokString happy_var_3) -> - case happyOut30 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn117 - (BuiltinPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4,happy_var_5)) (snd happy_var_3) (Ident happy_var_4) - ) `HappyStk` happyRest}}}}} - -happyReduce_379 = happyReduce 5# 111# happyReduction_379 -happyReduction_379 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwBUILTIN happy_var_2) -> - case happyOutTok happy_x_3 of { (TokKeyword KwREWRITE happy_var_3) -> - case happyOut30 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn117 - (BuiltinPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) "REWRITE" (Ident happy_var_4) - ) `HappyStk` happyRest}}}}} - -happyReduce_380 = happyReduce 4# 112# happyReduction_380 -happyReduction_380 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwREWRITE happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> - happyIn118 - (RewritePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_381 = happyReduce 5# 113# happyReduction_381 -happyReduction_381 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut27 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn119 - (CompiledPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) - ) `HappyStk` happyRest}}}}} - -happyReduce_382 = happyReduce 5# 114# happyReduction_382 -happyReduction_382 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_EXPORT happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut28 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn120 - (CompiledExportPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 happy_var_4 - ) `HappyStk` happyRest}}}}} - -happyReduce_383 = happyReduce 5# 115# happyReduction_383 -happyReduction_383 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_TYPE happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut27 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn121 - (CompiledTypePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) - ) `HappyStk` happyRest}}}}} - -happyReduce_384 = happyReduce 6# 116# happyReduction_384 -happyReduction_384 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_DATA happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokString happy_var_4) -> - case happyOut27 happy_x_5 of { happy_var_5 -> - case happyOutTok happy_x_6 of { (TokSymbol SymClosePragma happy_var_6) -> - happyIn122 - (CompiledDataPragma (getRange (happy_var_1,happy_var_2,happy_var_3,fst happy_var_4,happy_var_6)) happy_var_3 (snd happy_var_4) happy_var_5 - ) `HappyStk` happyRest}}}}}} - -happyReduce_385 = happyReduce 5# 117# happyReduction_385 -happyReduction_385 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_EPIC happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut27 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn123 - (CompiledEpicPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) - ) `HappyStk` happyRest}}}}} - -happyReduce_386 = happyReduce 5# 118# happyReduction_386 -happyReduction_386 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_JS happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut27 happy_x_4 of { happy_var_4 -> - case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> - happyIn124 - (CompiledJSPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) - ) `HappyStk` happyRest}}}}} - -happyReduce_387 = happyReduce 4# 119# happyReduction_387 -happyReduction_387 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwSTATIC happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> - happyIn125 - (StaticPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_388 = happyReduce 4# 120# happyReduction_388 -happyReduction_388 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwETA happy_var_2) -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> - happyIn126 - (EtaPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 - ) `HappyStk` happyRest}}}} - -happyReduce_389 = happySpecReduce_3 121# happyReduction_389 -happyReduction_389 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwNO_TERMINATION_CHECK happy_var_2) -> - case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> - happyIn127 - (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NoTerminationCheck - )}}} - -happyReduce_390 = happySpecReduce_3 122# happyReduction_390 -happyReduction_390 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwNON_TERMINATING happy_var_2) -> - case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> - happyIn128 - (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NonTerminating - )}}} - -happyReduce_391 = happySpecReduce_3 123# happyReduction_391 -happyReduction_391 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwTERMINATING happy_var_2) -> - case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> - happyIn129 - (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) Terminating - )}}} - -happyReduce_392 = happyReduce 4# 124# happyReduction_392 -happyReduction_392 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwMEASURE happy_var_2) -> - case happyOut29 happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> - happyIn130 - (let r = getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4) in - TerminationCheckPragma r (TerminationMeasure r happy_var_3) - ) `HappyStk` happyRest}}}} - -happyReduce_393 = happyMonadReduce 4# 125# happyReduction_393 -happyReduction_393 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwIMPORT happy_var_2) -> - case happyOutTok happy_x_3 of { (TokString happy_var_3) -> - case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> - ( let s = snd happy_var_3 in - if validHaskellModuleName s - then return $ ImportPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4)) s - else parseError $ "Malformed module name: " ++ s ++ ".")}}}} - ) (\r -> happyReturn (happyIn131 r)) - -happyReduce_394 = happySpecReduce_3 126# happyReduction_394 -happyReduction_394 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> - case happyOutTok happy_x_2 of { (TokKeyword KwIMPOSSIBLE happy_var_2) -> - case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> - happyIn132 - (ImpossiblePragma (getRange (happy_var_1,happy_var_2,happy_var_3)) - )}}} - -happyReduce_395 = happySpecReduce_3 127# happyReduction_395 -happyReduction_395 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut134 happy_x_2 of { happy_var_2 -> - happyIn133 - (reverse happy_var_2 - )} - -happyReduce_396 = happySpecReduce_3 128# happyReduction_396 -happyReduction_396 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut134 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_3 of { happy_var_3 -> - happyIn134 - (reverse happy_var_3 ++ happy_var_1 - )}} - -happyReduce_397 = happySpecReduce_1 128# happyReduction_397 -happyReduction_397 happy_x_1 - = case happyOut79 happy_x_1 of { happy_var_1 -> - happyIn134 - (reverse happy_var_1 - )} - -happyReduce_398 = happySpecReduce_3 129# happyReduction_398 -happyReduction_398 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut136 happy_x_2 of { happy_var_2 -> - happyIn135 - (reverse happy_var_2 - )} - -happyReduce_399 = happySpecReduce_3 130# happyReduction_399 -happyReduction_399 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut136 happy_x_1 of { happy_var_1 -> - case happyOut80 happy_x_3 of { happy_var_3 -> - happyIn136 - (reverse happy_var_3 ++ happy_var_1 - )}} - -happyReduce_400 = happySpecReduce_1 130# happyReduction_400 -happyReduction_400 happy_x_1 - = case happyOut80 happy_x_1 of { happy_var_1 -> - happyIn136 - (reverse happy_var_1 - )} - -happyReduce_401 = happySpecReduce_2 131# happyReduction_401 -happyReduction_401 happy_x_2 - happy_x_1 - = happyIn137 - ([] - ) - -happyReduce_402 = happySpecReduce_1 131# happyReduction_402 -happyReduction_402 happy_x_1 - = case happyOut133 happy_x_1 of { happy_var_1 -> - happyIn137 - (happy_var_1 - )} - -happyReduce_403 = happySpecReduce_2 132# happyReduction_403 -happyReduction_403 happy_x_2 - happy_x_1 - = happyIn138 - ((Nothing, Nothing, []) - ) - -happyReduce_404 = happySpecReduce_3 132# happyReduction_404 -happyReduction_404 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut87 happy_x_2 of { happy_var_2 -> - happyIn138 - ((Nothing, Just happy_var_2, []) - )} - -happyReduce_405 = happyReduce 5# 132# happyReduction_405 -happyReduction_405 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut87 happy_x_2 of { happy_var_2 -> - case happyOut142 happy_x_4 of { happy_var_4 -> - happyIn138 - ((Nothing, Just happy_var_2, happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_406 = happySpecReduce_3 132# happyReduction_406 -happyReduction_406 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut142 happy_x_2 of { happy_var_2 -> - happyIn138 - ((Nothing, Nothing, happy_var_2) - )} - -happyReduce_407 = happySpecReduce_3 132# happyReduction_407 -happyReduction_407 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut139 happy_x_2 of { happy_var_2 -> - happyIn138 - ((Just happy_var_2, Nothing, []) - )} - -happyReduce_408 = happyReduce 5# 132# happyReduction_408 -happyReduction_408 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut139 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> - happyIn138 - ((Just happy_var_2, Just happy_var_4, []) - ) `HappyStk` happyRest}} - -happyReduce_409 = happyReduce 7# 132# happyReduction_409 -happyReduction_409 (happy_x_7 `HappyStk` - happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut139 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> - case happyOut142 happy_x_6 of { happy_var_6 -> - happyIn138 - ((Just happy_var_2, Just happy_var_4, happy_var_6) - ) `HappyStk` happyRest}}} - -happyReduce_410 = happyReduce 5# 132# happyReduction_410 -happyReduction_410 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut139 happy_x_2 of { happy_var_2 -> - case happyOut142 happy_x_4 of { happy_var_4 -> - happyIn138 - ((Just happy_var_2, Nothing, happy_var_4) - ) `HappyStk` happyRest}} - -happyReduce_411 = happySpecReduce_1 133# happyReduction_411 -happyReduction_411 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) -> - happyIn139 - (Ranged (getRange happy_var_1) Inductive - )} - -happyReduce_412 = happySpecReduce_1 133# happyReduction_412 -happyReduction_412 happy_x_1 - = case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) -> - happyIn139 - (Ranged (getRange happy_var_1) CoInductive - )} - -happyReduce_413 = happySpecReduce_3 134# happyReduction_413 -happyReduction_413 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut142 happy_x_2 of { happy_var_2 -> - happyIn140 - (happy_var_2 - )} - -happyReduce_414 = happySpecReduce_2 135# happyReduction_414 -happyReduction_414 happy_x_2 - happy_x_1 - = happyIn141 - ([] - ) - -happyReduce_415 = happySpecReduce_1 135# happyReduction_415 -happyReduction_415 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - happyIn141 - (happy_var_1 - )} - -happyReduce_416 = happySpecReduce_3 136# happyReduction_416 -happyReduction_416 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - case happyOut142 happy_x_3 of { happy_var_3 -> - happyIn142 - (happy_var_1 ++ happy_var_3 - )}} - -happyReduce_417 = happySpecReduce_1 136# happyReduction_417 -happyReduction_417 happy_x_1 - = case happyOut78 happy_x_1 of { happy_var_1 -> - happyIn142 - (happy_var_1 - )} - -happyReduce_418 = happySpecReduce_0 137# happyReduction_418 -happyReduction_418 = happyIn143 - ([] - ) - -happyReduce_419 = happySpecReduce_1 137# happyReduction_419 -happyReduction_419 happy_x_1 - = case happyOut142 happy_x_1 of { happy_var_1 -> - happyIn143 - (happy_var_1 - )} - -happyNewToken action sts stk - = lexer(\tk -> - let cont i = happyDoAction i tk action sts stk in - case tk of { - TokEOF -> happyDoAction 89# tk action sts stk; - TokKeyword KwLet happy_dollar_dollar -> cont 1#; - TokKeyword KwIn happy_dollar_dollar -> cont 2#; - TokKeyword KwWhere happy_dollar_dollar -> cont 3#; - TokKeyword KwWith happy_dollar_dollar -> cont 4#; - TokKeyword KwRewrite happy_dollar_dollar -> cont 5#; - TokKeyword KwPostulate happy_dollar_dollar -> cont 6#; - TokKeyword KwPrimitive happy_dollar_dollar -> cont 7#; - TokKeyword KwOpen happy_dollar_dollar -> cont 8#; - TokKeyword KwImport happy_dollar_dollar -> cont 9#; - TokKeyword KwUsing happy_dollar_dollar -> cont 10#; - TokKeyword KwHiding happy_dollar_dollar -> cont 11#; - TokKeyword KwRenaming happy_dollar_dollar -> cont 12#; - TokKeyword KwTo happy_dollar_dollar -> cont 13#; - TokKeyword KwPublic happy_dollar_dollar -> cont 14#; - TokKeyword KwModule happy_dollar_dollar -> cont 15#; - TokKeyword KwData happy_dollar_dollar -> cont 16#; - TokKeyword KwCoData happy_dollar_dollar -> cont 17#; - TokKeyword KwRecord happy_dollar_dollar -> cont 18#; - TokKeyword KwConstructor happy_dollar_dollar -> cont 19#; - TokKeyword KwInductive happy_dollar_dollar -> cont 20#; - TokKeyword KwCoInductive happy_dollar_dollar -> cont 21#; - TokKeyword KwField happy_dollar_dollar -> cont 22#; - TokKeyword KwInfix happy_dollar_dollar -> cont 23#; - TokKeyword KwInfixL happy_dollar_dollar -> cont 24#; - TokKeyword KwInfixR happy_dollar_dollar -> cont 25#; - TokKeyword KwMutual happy_dollar_dollar -> cont 26#; - TokKeyword KwAbstract happy_dollar_dollar -> cont 27#; - TokKeyword KwPrivate happy_dollar_dollar -> cont 28#; - TokKeyword KwInstance happy_dollar_dollar -> cont 29#; - TokKeyword KwProp happy_dollar_dollar -> cont 30#; - TokKeyword KwSet happy_dollar_dollar -> cont 31#; - TokKeyword KwForall happy_dollar_dollar -> cont 32#; - TokKeyword KwSyntax happy_dollar_dollar -> cont 33#; - TokKeyword KwPatternSyn happy_dollar_dollar -> cont 34#; - TokKeyword KwOPTIONS happy_dollar_dollar -> cont 35#; - TokKeyword KwBUILTIN happy_dollar_dollar -> cont 36#; - TokKeyword KwREWRITE happy_dollar_dollar -> cont 37#; - TokKeyword KwIMPORT happy_dollar_dollar -> cont 38#; - TokKeyword KwIMPOSSIBLE happy_dollar_dollar -> cont 39#; - TokKeyword KwETA happy_dollar_dollar -> cont 40#; - TokKeyword KwNO_TERMINATION_CHECK happy_dollar_dollar -> cont 41#; - TokKeyword KwNON_TERMINATING happy_dollar_dollar -> cont 42#; - TokKeyword KwTERMINATING happy_dollar_dollar -> cont 43#; - TokKeyword KwMEASURE happy_dollar_dollar -> cont 44#; - TokKeyword KwCOMPILED happy_dollar_dollar -> cont 45#; - TokKeyword KwCOMPILED_EXPORT happy_dollar_dollar -> cont 46#; - TokKeyword KwCOMPILED_DATA happy_dollar_dollar -> cont 47#; - TokKeyword KwCOMPILED_TYPE happy_dollar_dollar -> cont 48#; - TokKeyword KwCOMPILED_EPIC happy_dollar_dollar -> cont 49#; - TokKeyword KwCOMPILED_JS happy_dollar_dollar -> cont 50#; - TokKeyword KwSTATIC happy_dollar_dollar -> cont 51#; - TokKeyword KwQuoteGoal happy_dollar_dollar -> cont 52#; - TokKeyword KwQuoteContext happy_dollar_dollar -> cont 53#; - TokKeyword KwQuote happy_dollar_dollar -> cont 54#; - TokKeyword KwQuoteTerm happy_dollar_dollar -> cont 55#; - TokKeyword KwTactic happy_dollar_dollar -> cont 56#; - TokKeyword KwUnquote happy_dollar_dollar -> cont 57#; - TokKeyword KwUnquoteDecl happy_dollar_dollar -> cont 58#; - TokSetN happy_dollar_dollar -> cont 59#; - TokTeX happy_dollar_dollar -> cont 60#; - TokComment happy_dollar_dollar -> cont 61#; - TokSymbol SymEllipsis happy_dollar_dollar -> cont 62#; - TokSymbol SymDotDot happy_dollar_dollar -> cont 63#; - TokSymbol SymDot happy_dollar_dollar -> cont 64#; - TokSymbol SymSemi happy_dollar_dollar -> cont 65#; - TokSymbol SymColon happy_dollar_dollar -> cont 66#; - TokSymbol SymEqual happy_dollar_dollar -> cont 67#; - TokSymbol SymUnderscore happy_dollar_dollar -> cont 68#; - TokSymbol SymQuestionMark happy_dollar_dollar -> cont 69#; - TokSymbol SymArrow happy_dollar_dollar -> cont 70#; - TokSymbol SymLambda happy_dollar_dollar -> cont 71#; - TokSymbol SymAs happy_dollar_dollar -> cont 72#; - TokSymbol SymBar happy_dollar_dollar -> cont 73#; - TokSymbol SymOpenParen happy_dollar_dollar -> cont 74#; - TokSymbol SymCloseParen happy_dollar_dollar -> cont 75#; - TokSymbol SymDoubleOpenBrace happy_dollar_dollar -> cont 76#; - TokSymbol SymDoubleCloseBrace happy_dollar_dollar -> cont 77#; - TokSymbol SymOpenBrace happy_dollar_dollar -> cont 78#; - TokSymbol SymCloseBrace happy_dollar_dollar -> cont 79#; - TokSymbol SymOpenVirtualBrace happy_dollar_dollar -> cont 80#; - TokSymbol SymCloseVirtualBrace happy_dollar_dollar -> cont 81#; - TokSymbol SymVirtualSemi happy_dollar_dollar -> cont 82#; - TokSymbol SymOpenPragma happy_dollar_dollar -> cont 83#; - TokSymbol SymClosePragma happy_dollar_dollar -> cont 84#; - TokId happy_dollar_dollar -> cont 85#; - TokQId happy_dollar_dollar -> cont 86#; - TokString happy_dollar_dollar -> cont 87#; - TokLiteral happy_dollar_dollar -> cont 88#; - _ -> happyError' tk - }) - -happyError_ 89# tk = happyError' tk -happyError_ _ tk = happyError' tk - -happyThen :: () => Parser a -> (a -> Parser b) -> Parser b -happyThen = (>>=) -happyReturn :: () => a -> Parser a -happyReturn = (return) -happyThen1 = happyThen -happyReturn1 :: () => a -> Parser a -happyReturn1 = happyReturn -happyError' :: () => (Token) -> Parser a -happyError' tk = (\token -> happyError) tk - -tokensParser = happySomeParser where - happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut6 x)) - -exprParser = happySomeParser where - happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut31 x)) - -moduleParser = happySomeParser where - happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut9 x)) - -happySeq = happyDontSeq - - -{-------------------------------------------------------------------------- - Parsers - --------------------------------------------------------------------------} - --- | Parse the token stream. Used by the TeX compiler. -tokensParser :: Parser [Token] - --- | Parse an expression. Could be used in interactions. -exprParser :: Parser Expr - --- | Parse a module. -moduleParser :: Parser Module - - -{-------------------------------------------------------------------------- - Happy stuff - --------------------------------------------------------------------------} - --- | Required by Happy. -happyError :: Parser a -happyError = parseError "Parse error" - - -{-------------------------------------------------------------------------- - Utility functions - --------------------------------------------------------------------------} - --- | Grab leading OPTIONS pragmas. -takeOptionsPragmas :: [Declaration] -> ([Pragma], [Declaration]) -takeOptionsPragmas = spanJust $ \ d -> case d of - Pragma p@OptionsPragma{} -> Just p - _ -> Nothing - --- | Insert a top-level module if there is none. -figureOutTopLevelModule :: [Declaration] -> [Declaration] -figureOutTopLevelModule ds = - case span isAllowedBeforeModule ds of - (ds0, Module r m tel ds1 : ds2) -> ds0 ++ [Module r m tel $ ds1 ++ ds2] - (ds0, ds1) -> ds0 ++ [Module (getRange ds1) (QName noName_) [] ds1] - where - isAllowedBeforeModule (Pragma OptionsPragma{}) = True - isAllowedBeforeModule (Private _ ds) = all isAllowedBeforeModule ds - isAllowedBeforeModule Import{} = True - isAllowedBeforeModule ModuleMacro{} = True - isAllowedBeforeModule Open{} = True - isAllowedBeforeModule _ = False - --- | Create a name from a string. - -mkName :: (Interval, String) -> Parser Name -mkName (i, s) = do - let xs = C.stringNameParts s - mapM_ isValidId xs - unless (alternating xs) $ fail $ "a name cannot contain two consecutive underscores" - return $ Name (getRange i) xs - where - isValidId Hole = return () - isValidId (Id y) = do - let x = rawNameToString y - case parse defaultParseFlags [0] (lexer return) x of - ParseOk _ (TokId _) -> return () - _ -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid" - - -- we know that there are no two Ids in a row - alternating (Hole : Hole : _) = False - alternating (_ : xs) = alternating xs - alternating [] = True - --- | Create a qualified name from a list of strings -mkQName :: [(Interval, String)] -> Parser QName -mkQName ss = do - xs <- mapM mkName ss - return $ foldr Qual (QName $ last xs) (init xs) - -ensureUnqual :: QName -> Parser Name -ensureUnqual (QName x) = return x -ensureUnqual q@Qual{} = parseError' (rStart $ getRange q) "Qualified name not allowed here" - --- | Match a particular name. -isName :: String -> (Interval, String) -> Parser () -isName s (_,s') - | s == s' = return () - | otherwise = fail $ "expected " ++ s ++ ", found " ++ s' - --- | Build a forall pi (forall x y z -> ...) -forallPi :: [LamBinding] -> Expr -> Expr -forallPi bs e = Pi (map addType bs) e - --- | Build a telescoping let (let Ds) -tLet :: Range -> [Declaration] -> TypedBindings -tLet r = TypedBindings r . Common.Arg defaultArgInfo . TLet r - --- | Converts lambda bindings to typed bindings. -addType :: LamBinding -> TypedBindings -addType (DomainFull b) = b -addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [x] $ Underscore r Nothing +{-# LANGUAGE TupleSections #-} + +{-| The parser is generated by Happy (). + - + - Ideally, ranges should be as precise as possible, to get messages that + - emphasize precisely the faulting term(s) upon error. + - + - However, interactive highlighting is only applied at the end of each + - mutual block, keywords are only highlighted once (see + - `TypeChecking.Rules.Decl'). So if the ranges of two declarations + - interleave, one must ensure that keyword ranges are not included in + - the intersection. (Otherwise they are uncolored by the interactive + - highlighting.) + - + -} +module Agda.Syntax.Parser.Parser ( + moduleParser + , exprParser + , tokensParser + , tests + ) where + +import Control.Monad + +import Data.Char +import Data.Functor +import Data.List +import Data.Maybe +import qualified Data.Traversable as T + +import Agda.Syntax.Position hiding (tests) +import Agda.Syntax.Parser.Monad +import Agda.Syntax.Parser.Lexer +import Agda.Syntax.Parser.Tokens +import Agda.Syntax.Concrete as C +import Agda.Syntax.Concrete.Pretty () +import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) +import qualified Agda.Syntax.Common as Common +import Agda.Syntax.Fixity +import Agda.Syntax.Notation +import Agda.Syntax.Literal + +import Agda.Utils.Hash +import Agda.Utils.List (spanJust) +import Agda.Utils.Monad +import Agda.Utils.QuickCheck +import Agda.Utils.Singleton +import Agda.Utils.TestHelpers +import Agda.Utils.Tuple +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.19.5 + +newtype HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74 = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn6 :: ([Token]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Token]) +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: ([Token]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Token]) +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: (Token) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Token) +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: (([Pragma], [Declaration])) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (([Pragma], [Declaration])) +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: t10 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t10 +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: t11 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t11 +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyIn12 :: t12 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn12 #-} +happyOut12 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t12 +happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut12 #-} +happyIn13 :: (()) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn13 #-} +happyOut13 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (()) +happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut13 #-} +happyIn14 :: (Integer) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn14 #-} +happyOut14 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Integer) +happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut14 #-} +happyIn15 :: (Name) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn15 #-} +happyOut15 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Name) +happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut15 #-} +happyIn16 :: ([Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn16 #-} +happyOut16 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Name]) +happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut16 #-} +happyIn17 :: (Range) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn17 #-} +happyOut17 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Range) +happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut17 #-} +happyIn18 :: (Arg Name) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn18 #-} +happyOut18 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Arg Name) +happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut18 #-} +happyIn19 :: ([Arg Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn19 #-} +happyOut19 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Arg Name]) +happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut19 #-} +happyIn20 :: ([Arg Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn20 #-} +happyOut20 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Arg Name]) +happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut20 #-} +happyIn21 :: (QName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn21 #-} +happyOut21 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (QName) +happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut21 #-} +happyIn22 :: (QName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn22 #-} +happyOut22 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (QName) +happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut22 #-} +happyIn23 :: (Name) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn23 #-} +happyOut23 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Name) +happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut23 #-} +happyIn24 :: ([Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn24 #-} +happyOut24 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Name]) +happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut24 #-} +happyIn25 :: ([Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn25 #-} +happyOut25 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Name]) +happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut25 #-} +happyIn26 :: (Either [Name] [Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn26 #-} +happyOut26 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Either [Name] [Expr]) +happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut26 #-} +happyIn27 :: ([WithHiding Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn27 #-} +happyOut27 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([WithHiding Name]) +happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut27 #-} +happyIn28 :: ([String]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn28 #-} +happyOut28 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([String]) +happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut28 #-} +happyIn29 :: (String) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn29 #-} +happyOut29 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (String) +happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut29 #-} +happyIn30 :: (Name) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn30 #-} +happyOut30 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Name) +happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut30 #-} +happyIn31 :: (QName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn31 #-} +happyOut31 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (QName) +happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut31 #-} +happyIn32 :: (Expr) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn32 #-} +happyOut32 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Expr) +happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut32 #-} +happyIn33 :: t33 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn33 #-} +happyOut33 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t33 +happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut33 #-} +happyIn34 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn34 #-} +happyOut34 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Expr]) +happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut34 #-} +happyIn35 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn35 #-} +happyOut35 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Expr]) +happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut35 #-} +happyIn36 :: t36 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn36 #-} +happyOut36 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t36 +happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut36 #-} +happyIn37 :: (Expr) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn37 #-} +happyOut37 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Expr) +happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut37 #-} +happyIn38 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn38 #-} +happyOut38 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Expr]) +happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut38 #-} +happyIn39 :: t39 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn39 #-} +happyOut39 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t39 +happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut39 #-} +happyIn40 :: t40 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn40 #-} +happyOut40 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t40 +happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut40 #-} +happyIn41 :: t41 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn41 #-} +happyOut41 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t41 +happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut41 #-} +happyIn42 :: ([(Name, Expr)]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn42 #-} +happyOut42 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([(Name, Expr)]) +happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut42 #-} +happyIn43 :: ([(Name, Expr)]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn43 #-} +happyOut43 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([(Name, Expr)]) +happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut43 #-} +happyIn44 :: ((Name, Expr)) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn44 #-} +happyOut44 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ((Name, Expr)) +happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut44 #-} +happyIn45 :: t45 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn45 #-} +happyOut45 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t45 +happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut45 #-} +happyIn46 :: t46 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn46 #-} +happyOut46 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t46 +happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut46 #-} +happyIn47 :: ([TypedBindings]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn47 #-} +happyOut47 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([TypedBindings]) +happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut47 #-} +happyIn48 :: (TypedBindings) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn48 #-} +happyOut48 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (TypedBindings) +happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut48 #-} +happyIn49 :: (TypedBindings) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn49 #-} +happyOut49 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (TypedBindings) +happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut49 #-} +happyIn50 :: (TypedBindings) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn50 #-} +happyOut50 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (TypedBindings) +happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut50 #-} +happyIn51 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn51 #-} +happyOut51 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([LamBinding]) +happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut51 #-} +happyIn52 :: (Either ([LamBinding], Hiding) [Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn52 #-} +happyOut52 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Either ([LamBinding], Hiding) [Expr]) +happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut52 #-} +happyIn53 :: ([Either Hiding LamBinding]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Either Hiding LamBinding]) +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: (Either [Either Hiding LamBinding] [Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Either [Either Hiding LamBinding] [Expr]) +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} +happyIn55 :: ((LHS,RHS,WhereClause)) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn55 #-} +happyOut55 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ((LHS,RHS,WhereClause)) +happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut55 #-} +happyIn56 :: ((LHS,RHS,WhereClause)) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn56 #-} +happyOut56 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ((LHS,RHS,WhereClause)) +happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut56 #-} +happyIn57 :: ((LHS,RHS,WhereClause)) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn57 #-} +happyOut57 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ((LHS,RHS,WhereClause)) +happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut57 #-} +happyIn58 :: ([(LHS,RHS,WhereClause)]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn58 #-} +happyOut58 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([(LHS,RHS,WhereClause)]) +happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut58 #-} +happyIn59 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn59 #-} +happyOut59 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([LamBinding]) +happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut59 #-} +happyIn60 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn60 #-} +happyOut60 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([LamBinding]) +happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut60 #-} +happyIn61 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn61 #-} +happyOut61 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([LamBinding]) +happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut61 #-} +happyIn62 :: ([LamBinding]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn62 #-} +happyOut62 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([LamBinding]) +happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut62 #-} +happyIn63 :: (Either [LamBinding] [Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn63 #-} +happyOut63 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Either [LamBinding] [Expr]) +happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut63 #-} +happyIn64 :: (ImportDirective) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn64 #-} +happyOut64 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (ImportDirective) +happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut64 #-} +happyIn65 :: ([ImportDirective]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn65 #-} +happyOut65 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([ImportDirective]) +happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut65 #-} +happyIn66 :: (ImportDirective) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn66 #-} +happyOut66 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (ImportDirective) +happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut66 #-} +happyIn67 :: ((UsingOrHiding , Range)) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn67 #-} +happyOut67 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ((UsingOrHiding , Range)) +happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut67 #-} +happyIn68 :: (([Renaming] , Range)) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn68 #-} +happyOut68 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (([Renaming] , Range)) +happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut68 #-} +happyIn69 :: ([Renaming]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn69 #-} +happyOut69 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Renaming]) +happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut69 #-} +happyIn70 :: (Renaming) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn70 #-} +happyOut70 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Renaming) +happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut70 #-} +happyIn71 :: (ImportedName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn71 #-} +happyOut71 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (ImportedName) +happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut71 #-} +happyIn72 :: (ImportedName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn72 #-} +happyOut72 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (ImportedName) +happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut72 #-} +happyIn73 :: ([ImportedName]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn73 #-} +happyOut73 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([ImportedName]) +happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut73 #-} +happyIn74 :: t74 -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn74 #-} +happyOut74 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> t74 +happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut74 #-} +happyIn75 :: (LHS) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn75 #-} +happyOut75 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (LHS) +happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut75 #-} +happyIn76 :: ([Pattern]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn76 #-} +happyOut76 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Pattern]) +happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut76 #-} +happyIn77 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn77 #-} +happyOut77 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Expr]) +happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut77 #-} +happyIn78 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn78 #-} +happyOut78 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Expr]) +happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut78 #-} +happyIn79 :: (WhereClause) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn79 #-} +happyOut79 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (WhereClause) +happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut79 #-} +happyIn80 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn80 #-} +happyOut80 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut80 #-} +happyIn81 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn81 #-} +happyOut81 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut81 #-} +happyIn82 :: ([Arg Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn82 #-} +happyOut82 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Arg Declaration]) +happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut82 #-} +happyIn83 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn83 #-} +happyOut83 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut83 #-} +happyIn84 :: (RHSOrTypeSigs) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn84 #-} +happyOut84 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (RHSOrTypeSigs) +happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut84 #-} +happyIn85 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn85 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn85 #-} +happyOut85 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut85 #-} +happyIn86 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn86 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn86 #-} +happyOut86 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut86 #-} +happyIn87 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn87 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn87 #-} +happyOut87 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut87 #-} +happyIn88 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn88 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn88 #-} +happyOut88 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut88 #-} +happyIn89 :: (Name) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn89 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn89 #-} +happyOut89 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Name) +happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut89 #-} +happyIn90 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn90 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn90 #-} +happyOut90 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut90 #-} +happyIn91 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn91 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn91 #-} +happyOut91 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut91 #-} +happyIn92 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn92 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn92 #-} +happyOut92 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut92 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut92 #-} +happyIn93 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn93 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn93 #-} +happyOut93 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut93 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut93 #-} +happyIn94 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn94 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn94 #-} +happyOut94 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut94 #-} +happyIn95 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn95 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn95 #-} +happyOut95 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut95 #-} +happyIn96 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn96 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn96 #-} +happyOut96 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut96 #-} +happyIn97 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn97 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn97 #-} +happyOut97 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut97 #-} +happyIn98 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn98 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn98 #-} +happyOut98 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut98 #-} +happyIn99 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn99 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn99 #-} +happyOut99 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut99 #-} +happyIn100 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn100 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn100 #-} +happyOut100 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut100 #-} +happyIn101 :: ([Arg Name]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn101 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn101 #-} +happyOut101 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Arg Name]) +happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut101 #-} +happyIn102 :: ([RString]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn102 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn102 #-} +happyOut102 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([RString]) +happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut102 #-} +happyIn103 :: ([NamedArg HoleName]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn103 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn103 #-} +happyOut103 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([NamedArg HoleName]) +happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut103 #-} +happyIn104 :: (NamedArg HoleName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn104 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn104 #-} +happyOut104 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (NamedArg HoleName) +happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut104 #-} +happyIn105 :: (HoleName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn105 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn105 #-} +happyOut105 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (HoleName) +happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut105 #-} +happyIn106 :: (HoleName) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn106 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn106 #-} +happyOut106 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (HoleName) +happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut106 #-} +happyIn107 :: (RString) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn107 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn107 #-} +happyOut107 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (RString) +happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut107 #-} +happyIn108 :: (Maybe Range) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn108 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn108 #-} +happyOut108 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Maybe Range) +happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut108 #-} +happyIn109 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn109 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn109 #-} +happyOut109 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut109 #-} +happyIn110 :: ([Expr]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn110 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn110 #-} +happyOut110 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Expr]) +happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut110 #-} +happyIn111 :: ([TypedBindings] -> Parser ModuleApplication) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn111 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn111 #-} +happyOut111 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([TypedBindings] -> Parser ModuleApplication) +happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut111 #-} +happyIn112 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn112 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn112 #-} +happyOut112 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut112 #-} +happyIn113 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn113 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn113 #-} +happyOut113 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut113 #-} +happyIn114 :: (Name) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn114 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn114 #-} +happyOut114 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Name) +happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut114 #-} +happyIn115 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn115 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn115 #-} +happyOut115 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut115 #-} +happyIn116 :: (Declaration) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn116 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn116 #-} +happyOut116 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Declaration) +happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut116 #-} +happyIn117 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn117 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn117 #-} +happyOut117 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut117 #-} +happyIn118 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn118 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn118 #-} +happyOut118 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut118 #-} +happyIn119 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn119 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn119 #-} +happyOut119 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut119 #-} +happyIn120 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn120 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn120 #-} +happyOut120 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut120 #-} +happyIn121 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn121 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn121 #-} +happyOut121 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut121 #-} +happyIn122 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn122 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn122 #-} +happyOut122 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut122 #-} +happyIn123 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn123 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn123 #-} +happyOut123 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut123 #-} +happyIn124 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn124 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn124 #-} +happyOut124 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut124 #-} +happyIn125 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn125 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn125 #-} +happyOut125 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut125 #-} +happyIn126 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn126 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn126 #-} +happyOut126 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut126 #-} +happyIn127 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn127 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn127 #-} +happyOut127 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut127 #-} +happyIn128 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn128 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn128 #-} +happyOut128 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut128 #-} +happyIn129 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn129 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn129 #-} +happyOut129 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut129 #-} +happyIn130 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn130 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn130 #-} +happyOut130 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut130 #-} +happyIn131 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn131 #-} +happyOut131 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut131 #-} +happyIn132 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn132 #-} +happyOut132 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut132 #-} +happyIn133 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn133 #-} +happyOut133 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut133 #-} +happyIn134 :: (Pragma) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn134 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn134 #-} +happyOut134 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Pragma) +happyOut134 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut134 #-} +happyIn135 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn135 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn135 #-} +happyOut135 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([TypeSignature]) +happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut135 #-} +happyIn136 :: ([TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn136 #-} +happyOut136 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([TypeSignature]) +happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut136 #-} +happyIn137 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn137 #-} +happyOut137 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Arg TypeSignature]) +happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut137 #-} +happyIn138 :: ([Arg TypeSignature]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn138 #-} +happyOut138 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Arg TypeSignature]) +happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut138 #-} +happyIn139 :: ([Constructor]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn139 #-} +happyOut139 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Constructor]) +happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut139 #-} +happyIn140 :: ((Maybe (Ranged Induction), Maybe Name, [Declaration])) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn140 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn140 #-} +happyOut140 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ((Maybe (Ranged Induction), Maybe Name, [Declaration])) +happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut140 #-} +happyIn141 :: (Ranged Induction) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn141 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn141 #-} +happyOut141 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Ranged Induction) +happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut141 #-} +happyIn142 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn142 #-} +happyOut142 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut142 #-} +happyIn143 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn143 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn143 #-} +happyOut143 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut143 #-} +happyIn144 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn144 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn144 #-} +happyOut144 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut144 #-} +happyIn145 :: ([Declaration]) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyIn145 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn145 #-} +happyOut145 :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> ([Declaration]) +happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut145 #-} +happyInTok :: (Token) -> (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn t10 t11 t12 t33 t36 t39 t40 t41 t45 t46 t74) -> (Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x00\x00\x36\x09\xdb\x05\x00\x00\xd2\x04\xd4\x05\x79\x04\xe0\x05\x00\x00\xce\x05\xdf\x05\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x02\x00\x00\x00\x00\x05\x09\xdb\x08\xd2\x05\x00\x00\xb6\x02\xd1\x05\x56\x0b\x00\x00\x00\x00\xa1\x0f\xb9\x05\xb9\x05\x00\x00\x00\x00\x2e\x0b\x00\x00\x00\x00\xe6\x02\x0b\x0b\x00\x00\x00\x00\x2d\x0b\x65\x06\x25\x06\x6e\x07\x00\x00\x00\x00\x00\x00\xb4\x05\xca\x05\x00\x00\xc8\x05\x1f\x02\xc4\x05\x00\x00\x00\x00\xef\x00\xef\x00\x00\x00\xc0\x05\xc9\x05\xbf\x05\x31\x01\xbe\x05\xfe\x05\xbb\x05\xb1\x05\x0d\x04\x00\x00\x00\x00\x00\x00\x91\x0f\xdb\x08\x00\x00\xba\x05\x00\x00\x0a\x0b\x8e\x0f\x39\x04\xd3\x00\x00\x00\xaa\x08\x6c\x08\xc5\x09\x00\x00\xe3\x0a\x3d\x07\x25\x06\x02\x07\x00\x0a\x00\x0a\x00\x0a\xb6\x05\xe3\x0a\xd1\x06\x25\x06\x96\x06\xfc\x05\xf7\x05\xe2\x0a\x42\x08\xb2\x05\xe2\x0a\x00\x00\x9b\x09\x00\x0a\x00\x0a\xa8\x05\xa0\x05\xee\x05\x74\x05\x00\x00\xb7\x02\x00\x0a\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x42\x08\x00\x0a\x42\x08\xe3\x0a\xe9\x05\xa4\x05\x12\x04\x3c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x05\x98\x05\x82\x00\xd0\x00\x8d\x05\x8d\x05\xc0\x0a\x86\x05\x88\x02\x88\x02\x88\x02\x84\x05\x84\x05\x84\x05\x84\x05\x8c\x05\x8c\x05\x8c\x05\x89\x05\xd4\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x05\xe4\xff\x81\x05\x80\x05\x7f\x05\x7e\x05\x7d\x05\x7c\x05\x7b\x05\x77\x05\x76\x05\x76\x05\x76\x05\x76\x05\x76\x05\x76\x05\x76\x05\xc6\x05\x98\x0a\x85\x05\xbf\x0a\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\x00\x00\xff\x00\xff\x00\x00\x00\xca\x03\x97\x0a\x74\x0a\x74\x0a\x00\x00\x00\x00\x74\x0a\x74\x0a\x00\x00\x75\x0a\x71\x05\x00\x00\x71\x05\x00\x00\x00\x00\x00\x00\x74\x05\x00\x00\x00\x00\xd6\x00\x42\x08\x42\x08\xbd\x05\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x10\x00\x42\x08\x7a\x05\x6d\x05\x00\x00\x79\x05\x6a\x05\x67\x05\x62\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x08\x42\x08\x00\x0a\x66\x05\xef\x00\x68\x05\x62\x05\xef\x00\x65\x05\x30\x01\x61\x05\x00\x00\xe2\x00\x3d\x01\x5f\x05\x5e\x05\x5d\x05\x00\x00\x00\x0a\x00\x0a\x00\x00\x00\x0a\x00\x0a\x4c\x0a\x5c\x05\x4c\x0a\x11\x08\xd3\x07\x60\x09\x00\x00\x00\x00\x5b\x05\x35\x00\x00\x00\xe5\x03\x00\x00\x00\x00\xa9\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x07\x00\x00\x00\x00\x4d\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x62\x01\x66\x00\x62\x01\x00\x0a\x00\x00\x00\x0a\xa9\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x05\x4a\x05\x00\x00\xa9\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x07\x00\x00\x00\x00\x00\x00\x4e\x05\xde\x00\x00\x00\x48\x05\x5a\x05\x00\x00\x3d\x00\x29\x0a\x4d\x0a\x0d\x03\xe5\x05\x29\x0a\x97\x05\x29\x0a\x1d\x00\xb9\x00\x9f\x00\x9a\x00\x00\x0a\x00\x00\xca\x03\x1b\x05\x00\x00\x3d\x00\x34\x01\x5e\x01\xd5\xff\xd5\xff\xf2\xff\x00\x00\x00\x00\x00\x00\x29\x03\x00\x00\x00\x00\x00\x00\x54\x05\xed\xff\xed\xff\x00\x00\x00\x00\x16\x05\xa9\x07\x11\x05\x53\x05\x45\x05\x00\x00\x41\x05\x41\x05\x41\x05\x32\x05\x30\x05\x27\x05\x43\x05\x00\x00\x00\x00\x00\x00\x00\x00\x40\x05\x00\x00\x34\x05\x2d\x05\x22\x05\x22\x05\x1f\x05\x20\x05\x00\x00\x00\x00\x1e\x05\x1c\x05\x00\x00\x00\x00\x00\x00\x00\x00\x19\x05\x18\x05\x00\x00\x10\x05\x17\x05\x15\x05\x12\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x07\x09\x05\x13\x05\x07\x05\x08\x05\x0d\x05\x06\x05\x00\x00\x06\x05\x00\x00\xd5\xff\x05\x05\xfe\x04\x60\x00\x00\x00\xfe\x04\xfe\x04\xfe\x04\xfe\x04\x00\x00\xca\x03\xa9\x07\x00\x00\x48\x00\x02\x05\xa9\x07\x01\x05\xa9\x07\x01\x05\xa9\x07\xff\x04\xe5\x03\x00\x00\xff\x04\x00\x00\x60\x00\x00\x00\x00\x00\x0d\x03\x00\x00\x00\x00\x04\x05\x03\x05\x00\x05\x00\x00\x00\x00\xfb\x04\x00\x00\xea\x04\xa9\x07\x00\x00\x35\x05\x33\x05\x00\x00\x00\x00\x26\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x03\x00\x00\x00\x00\xe7\x04\xe7\x04\x00\x00\x00\x00\xe5\x03\x90\x00\x2d\x00\x2d\x00\x00\x00\x0d\x03\x00\x00\x2a\x0a\x0d\x03\x00\x00\xc8\x04\x00\x00\x00\x00\x0a\x00\xbc\x04\x00\x00\xb7\x04\x00\x00\xcd\x03\x00\x00\x00\x00\xe6\x04\x60\x00\xe5\x04\x60\x00\xca\x03\xca\x03\x00\x00\xde\x04\x00\x00\xe9\x04\xed\xff\x00\x00\x87\x04\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x04\x00\x00\xd9\x04\x77\x04\xd8\x04\x00\x00\x00\x00\x00\x00\xca\x03\xca\x03\xca\x03\xca\x03\x00\x00\x3d\x00\x3d\x00\x10\x00\xd7\x04\x00\x00\x00\x00\x78\x04\x72\x04\x00\x00\x72\x04\x00\x00\x00\x00\xa5\x05\x00\x00\x00\x00\x7b\x04\x76\x04\x00\x00\x71\x04\x70\x04\x63\x04\x6b\x04\x74\x04\x9f\x04\x00\x00\x00\x00\x0d\x03\x00\x00\x00\x00\x00\x00\x56\x04\x56\x04\x7e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x05\x00\x00\x74\x05\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x3d\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x05\x00\x00\x10\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x31\x04\xa2\x0f\x89\x04\x85\x04\x82\x04\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x08\x86\x0f\x00\x00\x00\x00\xe6\x03\xfa\x03\xa5\x01\x00\x00\x00\x00\xe3\x01\x6f\x04\x6d\x04\x00\x00\x00\x00\x4d\x03\x00\x00\x00\x00\x00\x00\x2a\x04\x00\x00\x00\x00\x70\x01\x0f\x01\xd2\x0b\x0c\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x04\x68\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x03\x06\x02\x00\x00\x00\x00\x00\x00\x1f\x04\x6a\x0f\x00\x00\x00\x00\x00\x00\x4c\x03\x00\x00\x81\x00\x03\x00\x00\x00\x84\x01\x47\x0c\x94\x0b\x00\x00\x2a\x04\xd8\x06\xaf\x0b\xef\x0b\x44\x07\x1f\x0d\x02\x0d\x00\x00\xef\x02\x4e\x0f\x3a\x0d\x32\x0f\x00\x00\x00\x00\xe4\x03\x16\x0f\x00\x00\xc6\x03\x00\x00\x84\x01\xfb\x0c\xde\x0c\x00\x00\x1a\x00\x00\x00\x48\x03\x00\x00\x00\x00\xd7\x0c\xba\x0c\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x0e\x60\x02\xde\x0e\x87\x03\x27\x04\x00\x00\x20\x04\x66\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x03\xe7\x03\x06\x02\x1c\x00\x5c\x04\x50\x04\xfa\x00\xd3\x03\x42\x04\x3e\x04\x2c\x04\xa3\x03\x9c\x03\x99\x03\x8d\x03\x0a\x04\x03\x04\xf7\x03\xb7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x03\x00\x00\xe2\x03\x00\x00\x00\x00\x94\x03\x00\x00\x00\x00\x00\x00\x83\x03\x7a\x03\x78\x03\x70\x03\x58\x03\x49\x03\x45\x03\x3b\x03\xf0\x02\x7e\x02\x00\x00\x7b\x00\x98\x02\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x02\x00\x00\x00\x00\xe4\x01\xbf\x01\x00\x00\x18\x00\x4a\x03\x28\x03\xd5\x02\x00\x00\x00\x00\xd2\x02\xb0\x02\x00\x00\x9d\x00\x2c\x03\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\xd0\x02\x00\x00\x00\x00\xea\x02\xc2\x0e\xa6\x0e\xe8\x02\x1b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x02\xf3\x05\xb3\x0c\x96\x0c\x1e\x03\x8a\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x13\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x0e\x52\x0e\xe8\x01\x00\x00\x11\x03\x00\x00\x00\x00\xec\x02\x00\x00\x00\x00\x00\x00\x00\x00\x10\x03\x02\x03\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x0c\x72\x0c\x00\x00\x6b\x0c\x4e\x0c\x5f\x02\x00\x00\x5c\x02\x84\x01\x76\x0b\x69\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x01\x00\x00\x00\x00\x36\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x0e\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x02\x00\x00\xdf\x02\x70\x06\x00\x00\x30\x06\xfe\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\xe2\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x0d\x00\x00\x00\x00\x00\x00\xa1\x03\x19\x00\x00\x00\xea\x03\x00\x00\x00\x00\xec\x03\x5a\x02\x95\x00\x6c\x04\x3a\x0d\x09\x02\x00\x00\xe7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x29\x0c\x00\x00\xaf\x02\x00\x00\x00\x00\xd5\x03\x00\x00\xdc\x02\x83\x02\x3c\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x41\x02\x00\x00\x00\x00\x00\x00\x00\x00\x74\x03\x6c\x03\x00\x00\x00\x00\x00\x00\xaa\x0d\x96\x02\x79\x02\x00\x00\x00\x00\x95\x02\x86\x02\x84\x02\x00\x00\x4f\x02\x4e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x02\x26\x02\x00\x00\x15\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x0d\x00\x00\x00\x00\xb8\x01\x00\x00\x00\x00\x89\x01\x00\x00\xad\xff\x00\x00\x8f\x01\x00\x00\xcc\x01\xc1\x01\x00\x00\xab\x03\xa7\x03\xa2\x03\x4f\x03\x00\x00\xb8\x00\x72\x0d\x00\x00\x00\x00\x44\x01\x56\x0d\x92\x01\x07\x0a\x8b\x01\xa2\x09\x06\x03\x20\x00\x00\x00\xf7\x02\x00\x00\xab\x01\x00\x00\x00\x00\x8e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\xb0\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x04\x00\x00\x00\x00\xf1\x02\x8b\x02\x00\x00\x00\x00\xff\xff\x55\x01\x0d\x01\xd7\x00\x00\x00\x62\x04\x00\x00\x3b\x00\x15\x04\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x1c\x01\xae\x02\x8d\x02\x00\x00\x32\x01\x00\x00\x00\x00\xd8\x02\x00\x00\x00\x00\xa2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x01\x00\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x7c\x02\x20\x02\xa2\x00\x2c\x00\x00\x00\xbf\x02\x6c\x02\x1b\x01\xfe\x00\x00\x00\x00\x00\x57\x00\xd4\x00\x00\x00\x85\x00\x00\x00\x00\x00\x3a\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\xbc\x03\x00\x00\x00\x00\x00\x00\xc2\x00\x84\x00\x51\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x01\x00\x00\x58\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x4d\x01\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x01\x00\x00\x0e\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfa\xff\x00\x00\x00\x00\x00\x00\xfc\xff\x00\x00\xa4\xfe\x7f\xff\x59\xff\x00\x00\x6d\xff\x6c\xff\x6a\xff\x69\xff\x66\xff\x00\x00\x47\xff\x46\xff\x64\xff\x00\x00\x00\x00\x3f\xff\x3d\xff\x00\x00\x00\x00\x55\xff\x54\xff\x00\x00\x00\x00\x00\x00\x53\xff\x52\xff\x00\x00\x51\xff\x50\xff\x00\x00\x00\x00\x56\xff\x57\xff\x00\x00\xa4\xfe\x00\x00\x00\x00\x97\xff\x80\xff\x58\xff\x00\x00\x00\x00\x79\xff\x00\x00\x78\xff\x00\x00\x5a\xff\x4c\xff\x00\x00\x00\x00\x94\xff\x00\x00\x00\x00\x00\x00\x77\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa5\xfe\x4d\xff\x7d\xff\x0f\xff\x23\xff\x00\x00\x5e\xff\x00\x00\x2e\xff\x2b\xff\x24\xff\x00\x00\x00\x00\x7c\xff\xa4\xfe\x00\x00\x00\x00\x4a\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\xff\x5d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\xff\x00\x00\x00\x00\x15\xff\x10\xff\xa4\xfe\x00\x00\x00\x00\x00\x00\x45\xff\x00\x00\xa4\xfe\x3e\xff\x00\x00\x00\x00\x00\x00\x40\xff\x71\xff\x68\xff\x5c\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xfe\x00\x00\xcc\xfe\x5c\xfe\xe4\xfe\xe3\xfe\xe2\xfe\xe1\xfe\xe0\xfe\xdf\xfe\xe5\xfe\xde\xfe\xdd\xfe\xdc\xfe\xdb\xfe\xda\xfe\xd9\xfe\xd2\xfe\xd4\xfe\xd3\xfe\xd8\xfe\xd7\xfe\xd6\xfe\xa0\xff\xd5\xfe\x96\xfe\x85\xfe\x95\xfe\x94\xfe\x93\xfe\x92\xfe\x90\xfe\x91\xfe\x8f\xfe\x8e\xfe\x8d\xfe\x8a\xfe\x87\xfe\x88\xfe\x89\xfe\x86\xfe\x8c\xfe\x8b\xfe\x5a\xfe\x97\xfe\x00\x00\x00\x00\xa5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\xfe\x00\x00\xfb\xff\xf9\xff\xf8\xff\xf7\xff\xf6\xff\xf5\xff\xf4\xff\xf3\xff\xf2\xff\xf1\xff\xf0\xff\xef\xff\xee\xff\xed\xff\xec\xff\xeb\xff\xea\xff\xe9\xff\xe8\xff\xe7\xff\xe6\xff\xe5\xff\xe4\xff\xe3\xff\xe2\xff\xe1\xff\xe0\xff\xdf\xff\xde\xff\xdd\xff\xdc\xff\xdb\xff\xda\xff\xd9\xff\xd8\xff\xd7\xff\xd6\xff\xd5\xff\xd4\xff\xcc\xff\xcb\xff\xca\xff\xc9\xff\xc8\xff\xc7\xff\xd3\xff\xd2\xff\xd1\xff\xd0\xff\xcf\xff\xce\xff\xcd\xff\xc6\xff\xc5\xff\xc4\xff\xc3\xff\xc2\xff\xc1\xff\xc0\xff\xbf\xff\xbe\xff\xbd\xff\xbc\xff\xbb\xff\xba\xff\xb9\xff\xb8\xff\xb7\xff\xb6\xff\xb5\xff\xb4\xff\xb3\xff\xb2\xff\xb1\xff\xb0\xff\xaf\xff\xae\xff\xad\xff\xac\xff\xab\xff\xaa\xff\xa9\xff\xa8\xff\xa7\xff\xa6\xff\xa5\xff\xa4\xff\xa3\xff\xa2\xff\x76\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xfe\x00\x00\x00\x00\xb5\xfe\x00\x00\xbb\xfe\xbc\xfe\xbd\xfe\xbe\xfe\x00\x00\x98\xff\x99\xff\x00\x00\x00\x00\xbf\xfe\x00\x00\x11\xff\x11\xff\x11\xff\x7f\xff\x7e\xff\x11\xff\x11\xff\x98\xfe\xa0\xfe\x00\x00\xb9\xfe\x00\x00\xba\xfe\xa1\xff\x9f\xff\xa4\xfe\x9c\xff\x9b\xff\xe9\xfe\x00\x00\x00\x00\xed\xfe\x00\x00\x4b\xff\x6e\xff\x6b\xff\x6f\xff\x78\xff\x64\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\xff\x43\xff\x45\xff\x79\xff\x00\x00\x77\xff\x17\xff\x18\xff\x70\xff\x16\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\xff\x00\x00\x19\xff\x00\x00\x00\x00\x21\xff\x20\xff\x22\xff\x0e\xff\x00\x00\x00\x00\x0d\xff\x00\x00\x00\x00\x2a\xff\x26\xff\x2b\xff\xa4\xfe\x00\x00\x00\x00\x2f\xff\x67\xff\x25\xff\x00\x00\x33\xff\x00\x00\x36\xff\x4e\xff\x00\x00\x93\xff\x35\xff\x4f\xff\x34\xff\x5b\xff\x00\x00\x31\xff\x30\xff\xa0\xfe\x32\xff\x28\xff\x27\xff\x29\xff\x2d\xff\x2c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\xff\x00\x00\x00\x00\x3c\xff\x3a\xff\x3b\xff\x39\xff\x37\xff\x38\xff\x60\xff\x62\xff\x63\xff\x0b\xff\x0c\xff\x00\x00\x00\x00\x49\xff\x00\x00\x65\xff\x60\xfe\x9d\xff\x9e\xff\xea\xfe\xf1\xfe\x00\x00\xce\xfe\xcd\xfe\xcf\xfe\x00\x00\x00\x00\x5d\xfe\x95\xff\x00\x00\x70\xfe\x00\x00\x11\xff\xa0\xfe\x04\xff\x00\x00\x11\xff\x00\x00\x11\xff\x00\x00\x00\x00\x00\x00\x00\x00\x45\xff\x91\xff\x8d\xff\x00\x00\x6d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\xff\xc2\xfe\xc1\xfe\xc0\xfe\x00\x00\xb1\xfe\xaf\xfe\xaa\xfe\x00\x00\x00\x00\x00\x00\xa6\xfe\xb4\xfe\x00\x00\x00\x00\xef\xfe\xed\xfe\x00\x00\x72\xff\x76\xff\x76\xff\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x73\xff\x76\xfe\x77\xfe\x78\xfe\x00\x00\x73\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\xff\x75\xff\x84\xfe\x00\x00\x00\x00\x81\xfe\x74\xfe\x79\xfe\x75\xfe\x00\x00\x00\x00\x74\xff\x76\xff\x00\x00\x00\x00\x00\x00\x7a\xfe\xf0\xfe\xee\xfe\xb8\xfe\x00\x00\x00\x00\xa8\xfe\x00\x00\x00\x00\xa8\xfe\x00\x00\xb0\xfe\x00\x00\x7b\xff\x8f\xff\x00\x00\x00\x00\x00\x00\x92\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x00\x00\x00\x00\x8e\xff\x7f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\xff\x00\x00\x12\xff\x00\x00\xa2\xfe\x06\xff\x04\xff\x02\xff\x01\xff\x00\x00\x00\x00\x00\x00\x03\xff\x9f\xfe\x00\x00\x72\xfe\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x5e\xfe\xe8\xfe\x00\x00\xec\xfe\x41\xff\x42\xff\x48\xff\x1f\xff\x1e\xff\x1d\xff\x1c\xff\x1a\xff\x1b\xff\x09\xff\x0a\xff\x07\xff\x08\xff\x04\xff\xa3\xfe\x5f\xfe\x00\x00\x00\x00\xd1\xfe\x71\xfe\x00\x00\x9a\xff\xf5\xfe\xf5\xfe\x05\xff\x04\xff\x99\xfe\xa0\xfe\x04\xff\x9a\xfe\xc7\xfe\x6b\xfe\xc9\xfe\x00\x00\x00\x00\xc8\xfe\xc4\xfe\xc5\xfe\x00\x00\xd0\xfe\x6e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x8b\xff\x89\xff\x90\xff\xb7\xfe\xb3\xfe\x00\x00\x00\x00\xad\xfe\x00\x00\x00\x00\xae\xfe\xb6\xfe\x7b\xfe\x7c\xfe\x7e\xfe\x00\x00\x7f\xfe\x80\xfe\x82\xfe\x83\xfe\x7d\xfe\x00\x00\xa8\xfe\x00\x00\x00\x00\x00\x00\xb2\xfe\x8a\xff\x8c\xff\x85\xff\x87\xff\x81\xff\x83\xff\x6a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x62\xfe\x61\xfe\x00\x00\x00\x00\x6c\xfe\x00\x00\x9c\xfe\x9d\xfe\x00\x00\xa1\xfe\xf7\xfe\xf3\xfe\x00\x00\xf4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xfe\x00\x00\x9a\xff\xfd\xfe\x04\xff\xe7\xfe\xe6\xfe\x9b\xfe\x00\x00\x00\x00\x9a\xff\xfe\xfe\xf9\xfe\xff\xfe\xf6\xfe\x00\xff\x00\x00\x00\x00\xcb\xfe\xca\xfe\xc6\xfe\xc3\xfe\x67\xfe\x66\xfe\xa4\xfe\x69\xfe\xa4\xfe\x84\xff\x82\xff\x88\xff\x86\xff\x00\x00\xab\xfe\xa7\xfe\xac\xfe\xa9\xfe\x00\x00\x00\x00\x00\x00\x9e\xfe\xf2\xfe\xfc\xfe\xfa\xfe\xf8\xfe\x63\xfe\x65\xfe\xa4\xfe\x68\xfe\x00\x00\x64\xfe"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0a\x00\x09\x00\x25\x00\x00\x00\x0f\x00\x09\x00\x60\x00\x0f\x00\x10\x00\x00\x00\x09\x00\x65\x00\x05\x00\x11\x00\x40\x00\x09\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x03\x00\x09\x00\x09\x00\x09\x00\x0c\x00\x09\x00\x0e\x00\x09\x00\x0a\x00\x09\x00\x55\x00\x0f\x00\x10\x00\x25\x00\x26\x00\x0f\x00\x10\x00\x24\x00\x25\x00\x26\x00\x47\x00\x09\x00\x44\x00\x02\x00\x0c\x00\x05\x00\x0e\x00\x57\x00\x0f\x00\x00\x00\x24\x00\x25\x00\x26\x00\x45\x00\x55\x00\x05\x00\x09\x00\x4b\x00\x4a\x00\x55\x00\x4b\x00\x4d\x00\x0f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x51\x00\x21\x00\x22\x00\x23\x00\x55\x00\x43\x00\x51\x00\x66\x00\x67\x00\x4c\x00\x0b\x00\x6a\x00\x6b\x00\x69\x00\x4b\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x05\x00\x41\x00\x82\x00\x4b\x00\x09\x00\x55\x00\x87\x00\x09\x00\x6c\x00\x8a\x00\x0f\x00\x6c\x00\x69\x00\x09\x00\x43\x00\x11\x00\x09\x00\x51\x00\x52\x00\x48\x00\x0f\x00\x11\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x84\x00\x03\x00\x09\x00\x0f\x00\x82\x00\x09\x00\x03\x00\x68\x00\x0f\x00\x2a\x00\x09\x00\x0f\x00\x42\x00\x09\x00\x2f\x00\x09\x00\x0f\x00\x4d\x00\x0c\x00\x4f\x00\x0e\x00\x11\x00\x12\x00\x38\x00\x39\x00\x4f\x00\x21\x00\x22\x00\x23\x00\x21\x00\x22\x00\x23\x00\x03\x00\x45\x00\x21\x00\x22\x00\x23\x00\x09\x00\x4a\x00\x09\x00\x0c\x00\x4d\x00\x0e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x09\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x55\x00\x56\x00\x03\x00\x5f\x00\x4b\x00\x42\x00\x86\x00\x66\x00\x67\x00\x09\x00\x42\x00\x6a\x00\x6b\x00\x07\x00\x0f\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x09\x00\x09\x00\x42\x00\x42\x00\x68\x00\x44\x00\x0f\x00\x68\x00\x09\x00\x8a\x00\x09\x00\x4c\x00\x68\x00\x81\x00\x09\x00\x42\x00\x0f\x00\x85\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x44\x00\x4f\x00\x09\x00\x44\x00\x09\x00\x42\x00\x43\x00\x44\x00\x22\x00\x4a\x00\x0f\x00\x4c\x00\x05\x00\x4e\x00\x44\x00\x41\x00\x15\x00\x55\x00\x56\x00\x0b\x00\x55\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x55\x00\x52\x00\x45\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x4a\x00\x2c\x00\x4d\x00\x4d\x00\x4f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x44\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x42\x00\x43\x00\x44\x00\x05\x00\x06\x00\x55\x00\x81\x00\x66\x00\x67\x00\x07\x00\x85\x00\x6a\x00\x6b\x00\x07\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x09\x00\x42\x00\x65\x00\x43\x00\x66\x00\x67\x00\x0f\x00\x65\x00\x09\x00\x8a\x00\x8b\x00\x4b\x00\x41\x00\x41\x00\x4f\x00\x4c\x00\x11\x00\x4e\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x4f\x00\x09\x00\x52\x00\x52\x00\x3f\x00\x40\x00\x41\x00\x0f\x00\x3f\x00\x40\x00\x41\x00\x65\x00\x09\x00\x15\x00\x2a\x00\x0c\x00\x0d\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x1d\x00\x1e\x00\x1f\x00\x42\x00\x21\x00\x22\x00\x23\x00\x38\x00\x39\x00\x4c\x00\x0b\x00\x4e\x00\x45\x00\x09\x00\x4d\x00\x2c\x00\x4f\x00\x4a\x00\x55\x00\x0f\x00\x4d\x00\x0b\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x22\x00\x09\x00\x4a\x00\x86\x00\x4c\x00\x0b\x00\x4e\x00\x66\x00\x67\x00\x11\x00\x12\x00\x6a\x00\x6b\x00\x55\x00\x09\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x09\x00\x66\x00\x67\x00\x09\x00\x09\x00\x65\x00\x0f\x00\x09\x00\x09\x00\x8a\x00\x09\x00\x11\x00\x11\x00\x12\x00\x0f\x00\x11\x00\x0f\x00\x10\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x81\x00\x2a\x00\x09\x00\x09\x00\x85\x00\x2a\x00\x09\x00\x81\x00\x0f\x00\x0f\x00\x10\x00\x85\x00\x35\x00\x36\x00\x11\x00\x38\x00\x39\x00\x65\x00\x37\x00\x38\x00\x39\x00\x16\x00\x1d\x00\x1e\x00\x1f\x00\x45\x00\x21\x00\x22\x00\x23\x00\x09\x00\x4a\x00\x16\x00\x0c\x00\x4d\x00\x0e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x2a\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x19\x00\x37\x00\x38\x00\x39\x00\x19\x00\x09\x00\x09\x00\x66\x00\x67\x00\x0c\x00\x0d\x00\x6a\x00\x6b\x00\x11\x00\x12\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x09\x00\x43\x00\x09\x00\x16\x00\x09\x00\x17\x00\x0f\x00\x09\x00\x09\x00\x8a\x00\x11\x00\x4d\x00\x11\x00\x4f\x00\x0f\x00\x11\x00\x05\x00\x06\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x2a\x00\x09\x00\x2a\x00\x09\x00\x0c\x00\x2a\x00\x0e\x00\x2f\x00\x09\x00\x0f\x00\x2f\x00\x0c\x00\x0d\x00\x37\x00\x38\x00\x39\x00\x38\x00\x39\x00\x09\x00\x38\x00\x39\x00\x0c\x00\x16\x00\x0e\x00\x16\x00\x45\x00\x20\x00\x21\x00\x22\x00\x23\x00\x4a\x00\x62\x00\x63\x00\x4d\x00\x65\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x16\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x09\x00\x09\x00\x09\x00\x0c\x00\x0c\x00\x0e\x00\x0e\x00\x66\x00\x67\x00\x47\x00\x11\x00\x6a\x00\x6b\x00\x05\x00\x06\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x09\x00\x2a\x00\x09\x00\x46\x00\x55\x00\x09\x00\x0f\x00\x58\x00\x46\x00\x8a\x00\x11\x00\x49\x00\x09\x00\x11\x00\x37\x00\x38\x00\x39\x00\x0b\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x0b\x00\x3f\x00\x40\x00\x0b\x00\x09\x00\x61\x00\x62\x00\x63\x00\x2a\x00\x65\x00\x0f\x00\x2a\x00\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\x64\x00\x65\x00\x06\x00\x37\x00\x38\x00\x39\x00\x37\x00\x38\x00\x39\x00\x20\x00\x21\x00\x22\x00\x23\x00\x88\x00\x89\x00\x45\x00\x06\x00\x0a\x00\x0b\x00\x0c\x00\x4a\x00\x0e\x00\x0b\x00\x4d\x00\x0b\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x05\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x47\x00\x4a\x00\x09\x00\x4c\x00\x49\x00\x4e\x00\x09\x00\x66\x00\x67\x00\x48\x00\x11\x00\x6a\x00\x6b\x00\x64\x00\x65\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x09\x00\x2a\x00\x09\x00\x19\x00\x09\x00\x09\x00\x0f\x00\x09\x00\x0a\x00\x8a\x00\x11\x00\x0f\x00\x11\x00\x19\x00\x37\x00\x38\x00\x39\x00\x19\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x43\x00\x20\x00\x21\x00\x22\x00\x23\x00\x19\x00\x09\x00\x4a\x00\x2a\x00\x4c\x00\x2a\x00\x4e\x00\x0f\x00\x88\x00\x89\x00\x2f\x00\x13\x00\x14\x00\x55\x00\x88\x00\x89\x00\x37\x00\x38\x00\x39\x00\x38\x00\x39\x00\x1d\x00\x1e\x00\x1f\x00\x19\x00\x21\x00\x22\x00\x23\x00\x45\x00\x88\x00\x89\x00\x09\x00\x19\x00\x4a\x00\x19\x00\x2b\x00\x4d\x00\x0f\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x18\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x16\x00\x21\x00\x22\x00\x23\x00\x09\x00\x0a\x00\x19\x00\x66\x00\x67\x00\x09\x00\x0a\x00\x6a\x00\x6b\x00\x09\x00\x0a\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x01\x00\x09\x00\x64\x00\x65\x00\x8a\x00\x06\x00\x07\x00\x08\x00\x09\x00\x11\x00\x64\x00\x65\x00\x05\x00\x06\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x21\x00\x22\x00\x2a\x00\x05\x00\x06\x00\x09\x00\x0a\x00\x11\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x19\x00\x36\x00\x46\x00\x38\x00\x39\x00\x09\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3f\x00\x40\x00\x3e\x00\x09\x00\x40\x00\x2a\x00\x29\x00\x2a\x00\x44\x00\x45\x00\x09\x00\x47\x00\x88\x00\x4c\x00\x4a\x00\x4e\x00\x4c\x00\x36\x00\x4e\x00\x38\x00\x39\x00\x51\x00\x55\x00\x53\x00\x88\x00\x55\x00\x56\x00\x88\x00\x58\x00\x00\x00\x01\x00\x09\x00\x88\x00\x89\x00\x88\x00\x06\x00\x07\x00\x08\x00\x09\x00\x11\x00\x00\x00\x01\x00\x09\x00\x08\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0f\x00\x55\x00\x56\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x21\x00\x22\x00\x2a\x00\x08\x00\x21\x00\x22\x00\x23\x00\x2f\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x43\x00\x83\x00\x38\x00\x39\x00\x09\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x55\x00\x56\x00\x3e\x00\x09\x00\x40\x00\x88\x00\x81\x00\x04\x00\x44\x00\x45\x00\x06\x00\x47\x00\x4e\x00\x48\x00\x4a\x00\x88\x00\x4c\x00\x0b\x00\x4e\x00\x0b\x00\x09\x00\x51\x00\x09\x00\x53\x00\x01\x00\x55\x00\x56\x00\x44\x00\x58\x00\x06\x00\x07\x00\x08\x00\x88\x00\x4a\x00\x02\x00\x4c\x00\x01\x00\x4e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x03\x00\x0f\x00\x55\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x4b\x00\x21\x00\x22\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x55\x00\x0d\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x41\x00\x4b\x00\x3e\x00\x55\x00\x40\x00\x03\x00\x4b\x00\x41\x00\x44\x00\x45\x00\x03\x00\x47\x00\x4b\x00\x50\x00\x4a\x00\x4d\x00\x4c\x00\x55\x00\x4e\x00\x50\x00\x4f\x00\x51\x00\x03\x00\x53\x00\x46\x00\x55\x00\x56\x00\x54\x00\x58\x00\x59\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x01\x00\x55\x00\x55\x00\x55\x00\x46\x00\x06\x00\x07\x00\x08\x00\x55\x00\x4f\x00\x4f\x00\x03\x00\x50\x00\x03\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x43\x00\x55\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x4a\x00\x21\x00\x22\x00\x4a\x00\x4a\x00\x50\x00\x43\x00\x50\x00\x50\x00\x55\x00\x4f\x00\x4d\x00\x43\x00\x04\x00\x4f\x00\x43\x00\x49\x00\x55\x00\x55\x00\x42\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x54\x00\x57\x00\x3e\x00\x54\x00\x40\x00\x54\x00\x54\x00\x54\x00\x44\x00\x45\x00\x54\x00\x47\x00\x54\x00\x54\x00\x4a\x00\x01\x00\x4c\x00\x57\x00\x4e\x00\x57\x00\x06\x00\x07\x00\x08\x00\x53\x00\x57\x00\x55\x00\x56\x00\x54\x00\x58\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x57\x00\x54\x00\x57\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x54\x00\x21\x00\x22\x00\x54\x00\x57\x00\x54\x00\x03\x00\x47\x00\x42\x00\x55\x00\x50\x00\x55\x00\x4f\x00\x46\x00\x46\x00\x46\x00\x46\x00\x46\x00\x01\x00\x46\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x4b\x00\x4f\x00\x3e\x00\x4b\x00\x40\x00\x4f\x00\x4f\x00\x12\x00\x44\x00\x45\x00\x41\x00\x47\x00\x4f\x00\x43\x00\x4a\x00\x55\x00\x4c\x00\x04\x00\x4e\x00\x1e\x00\x1f\x00\x20\x00\x55\x00\x53\x00\x43\x00\x55\x00\x56\x00\x05\x00\x58\x00\x57\x00\x57\x00\x54\x00\x54\x00\x54\x00\x49\x00\x54\x00\x50\x00\x57\x00\x50\x00\x57\x00\x57\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x57\x00\x3b\x00\x55\x00\x55\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x51\x00\x50\x00\x44\x00\x45\x00\x50\x00\x47\x00\x49\x00\x05\x00\x4a\x00\x02\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x55\x00\x4e\x00\x12\x00\x46\x00\x02\x00\x55\x00\x56\x00\x09\x00\x58\x00\x02\x00\x49\x00\x46\x00\x50\x00\x0f\x00\x1e\x00\x1f\x00\x20\x00\x4b\x00\x09\x00\x15\x00\x4b\x00\x4b\x00\x42\x00\x42\x00\x59\x00\x55\x00\x4f\x00\x1d\x00\x1e\x00\x1f\x00\x4f\x00\x21\x00\x22\x00\x23\x00\x4f\x00\x46\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x2c\x00\x3b\x00\x50\x00\x43\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x59\x00\x48\x00\x44\x00\x45\x00\x50\x00\x47\x00\x59\x00\xff\xff\x4a\x00\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x12\x00\xff\xff\x09\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x31\x00\x32\x00\x33\x00\x3f\x00\x40\x00\x01\x00\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x08\x00\xff\xff\x4a\x00\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x12\x00\xff\xff\x09\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x31\x00\x32\x00\x33\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x15\x00\x58\x00\x1e\x00\x1f\x00\x20\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x01\x00\x2c\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x15\x00\x58\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x2c\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x1e\x00\x1f\x00\x20\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x01\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\x08\x00\x47\x00\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x12\x00\x09\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\x0f\x00\x58\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\x01\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\x08\x00\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x12\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1f\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x12\x00\x44\x00\x45\x00\x46\x00\x47\x00\xff\xff\x49\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\x08\x00\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x1e\x00\x1f\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x01\x00\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x01\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\xff\xff\xff\xff\x4a\x00\x09\x00\x4c\x00\x12\x00\x4e\x00\x4f\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\x1e\x00\x1f\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x12\x00\xff\xff\xff\xff\xff\xff\x40\x00\xff\xff\xff\xff\xff\xff\x44\x00\x45\x00\xff\xff\x47\x00\x1e\x00\x1f\x00\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\x1e\x00\x1f\x00\x44\x00\x44\x00\x45\x00\xff\xff\xff\xff\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x55\x00\x56\x00\xff\xff\x58\x00\x36\x00\x37\x00\xff\xff\x39\x00\x12\x00\x3b\x00\xff\xff\xff\xff\x3f\x00\x40\x00\x40\x00\xff\xff\xff\xff\x44\x00\x44\x00\x45\x00\x1e\x00\x1f\x00\xff\xff\x4a\x00\x4a\x00\x4c\x00\x4c\x00\x4e\x00\x4e\x00\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x55\x00\x55\x00\x56\x00\x0f\x00\x58\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x36\x00\x37\x00\xff\xff\x39\x00\xff\xff\x3b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x40\x00\x21\x00\x22\x00\x23\x00\x44\x00\x45\x00\xff\xff\x09\x00\xff\xff\xff\xff\x4a\x00\x2b\x00\x4c\x00\x0f\x00\x4e\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\x55\x00\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x2b\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x31\x00\x32\x00\xff\xff\x34\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\x09\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\x09\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\x09\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x09\x00\xff\xff\x0b\x00\xff\xff\x2b\x00\xff\xff\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x2b\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x2b\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x2b\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x2b\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x2b\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x0f\x00\x09\x00\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x2b\x00\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x0f\x00\xff\xff\xff\xff\xff\xff\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\xff\xff\x21\x00\x22\x00\x23\x00\x09\x00\xff\xff\x0b\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x09\x00\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x3f\x00\x40\x00\xff\xff\x3f\x00\x40\x00\x44\x00\xff\xff\x46\x00\x44\x00\xff\xff\x46\x00\x4a\x00\xff\xff\x4c\x00\x4a\x00\x4e\x00\x4c\x00\xff\xff\x4e\x00\x3f\x00\x40\x00\xff\xff\x55\x00\xff\xff\x44\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x94\x02\x9d\x02\xbb\x01\xbc\x01\x07\x00\xbb\x01\xbc\x01\x37\x01\xf7\x01\xb1\x01\x08\x00\x43\x00\x76\x02\x38\x01\x61\x02\xb1\x01\x56\x01\x77\x02\xdc\x02\x73\x01\x1a\x02\x56\x01\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x2c\x02\xcb\x01\x40\x02\x56\x01\xcc\x01\x37\x01\xcd\x01\xbb\x01\xbc\x01\x37\x01\x2c\x00\x38\x01\x39\x01\x47\x02\x59\x01\x38\x01\x61\x02\xaa\x01\x58\x01\x59\x01\x11\x02\xcb\x01\x4f\x00\x56\x01\xcc\x01\xd7\x02\xc6\x02\xf8\x01\xa8\x02\xb1\x01\x57\x01\x58\x01\x59\x01\x7b\x00\xe0\x01\xda\x02\x07\x00\x59\x02\x7c\x00\x2c\x00\xbd\x01\x7d\x00\x08\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x95\x02\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xb2\x01\x10\x00\x11\x00\xc0\x01\x2c\x00\x2d\x02\xb2\x01\x3e\x00\x8d\x00\xce\x01\xd2\x02\x8e\x00\x8f\x00\xaf\x02\xbd\x01\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x55\x02\x45\x01\xbe\x01\x92\x01\x07\x00\x2c\x00\x96\x02\x43\x00\x41\x02\x97\x02\x08\x00\x3a\x01\x62\x02\x43\x00\xae\x01\x44\x00\xd5\x02\xb2\x01\x46\x01\x79\x00\x3e\x01\x76\x01\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\xcf\x01\x26\x02\x07\x00\xae\x02\xbe\x01\x07\x00\x28\x02\xa0\x02\x08\x00\x79\x01\x07\x00\x08\x00\x8e\x01\x43\x00\xe0\x01\xcb\x01\x08\x00\x39\x00\xcc\x01\x3a\x00\xc7\x02\xd4\x01\x16\x02\x7b\x01\x65\x00\x51\x02\x10\x00\x11\x00\xc0\x01\x10\x00\x11\x00\xc0\x01\x2a\x02\x7b\x00\x10\x00\x11\x00\xc0\x01\xcb\x01\x7c\x00\xa3\x02\xcc\x01\x7d\x00\xcd\x01\x7e\x00\x7f\x00\x80\x00\x81\x00\xd6\x02\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x2c\x00\x2d\x00\xb9\x01\xe1\x01\xaf\x02\x27\x02\xbf\x02\x3e\x00\x8d\x00\xa3\x02\x29\x02\x8e\x00\x8f\x00\xb3\x02\xba\x01\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x07\x00\xb7\x02\x2b\x02\xa4\x02\x3a\x02\xd3\x02\x08\x00\x53\x02\xb9\x02\x54\x01\x07\x00\x6e\x02\xc1\x01\x65\x02\xc0\x02\x8e\x01\x08\x00\xbd\x02\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x3c\x01\x53\x02\xa3\x02\x4f\x00\x07\x00\xa4\x02\xa5\x02\xa6\x02\x34\x01\x52\x01\x08\x00\x75\x01\xc1\x02\x76\x01\x3c\x01\x45\x01\x3a\x00\x2c\x00\x2d\x00\x90\x02\x2c\x00\x3b\x00\x0a\x00\x0b\x00\x3c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x2c\x00\x46\x01\x7b\x00\x13\x00\x14\x00\x15\x00\x16\x00\x7c\x00\x3d\x00\x39\x00\x7d\x00\x3a\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x4f\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xa4\x02\xa8\x02\xa6\x02\xd8\x02\xd9\x02\x2c\x00\x65\x02\x3e\x00\x8d\x00\xa9\x02\xbe\x02\x8e\x00\x8f\x00\xa9\x02\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x07\x00\x78\xff\xca\x02\x6a\xff\x3e\x00\x3f\x00\x08\x00\xcc\x02\x43\x00\xa4\x00\xa5\x00\x6a\xff\x45\x01\x45\x01\x78\xff\x1f\x02\x44\x00\x20\x02\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x9d\x01\x07\x00\x46\x01\x46\x01\xd4\x02\xab\x02\xac\x02\x08\x00\xaa\x02\xab\x02\xac\x02\x8d\x02\xcb\x01\x3a\x00\x45\x00\x17\x02\x75\x02\x46\x00\x47\x00\x48\x00\x49\x00\x5d\x01\x0d\x00\x0e\x00\x8e\x01\x10\x00\x11\x00\x50\x01\x4a\x00\x4b\x00\x1d\x02\x92\x02\x1e\x02\x7b\x00\x07\x00\x39\x00\x3d\x00\x3a\x00\x7c\x00\x2c\x00\x08\x00\x7d\x00\x5f\x02\x7e\x00\x7f\x00\x80\x00\x81\x00\xd0\x02\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x69\x00\x43\x00\xdd\x01\x6b\x02\xde\x01\x73\x02\xdf\x01\x3e\x00\x8d\x00\xd4\x01\xd5\x01\x8e\x00\x8f\x00\xe0\x01\x1b\x02\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x07\x00\x3e\x00\x3f\x00\x43\x00\x43\x00\x78\x02\x08\x00\x43\x00\x07\x00\xd1\x02\x37\x01\x44\x00\xd4\x01\xd6\x01\x08\x00\x44\x00\x38\x01\x90\x01\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\xa5\x01\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x65\x02\x61\x00\x07\x00\x37\x01\x66\x02\xc3\x01\x43\x00\x65\x02\x08\x00\x38\x01\x3c\x01\x69\x02\x62\x00\x63\x00\x44\x00\x64\x00\x65\x00\x7b\x02\x2d\x02\xc5\x01\x65\x00\x82\x02\x73\x00\x0d\x00\x0e\x00\x7b\x00\x10\x00\x11\x00\x50\x01\xcb\x01\x7c\x00\xfa\x01\xcc\x01\x7d\x00\xc8\x02\x7e\x00\x7f\x00\x80\x00\x81\x00\xc3\x01\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xfc\x01\x2f\x02\xc5\x01\x65\x00\xfd\x01\x43\x00\xcb\x01\x3e\x00\x8d\x00\x17\x02\x18\x02\x8e\x00\x8f\x00\xd4\x01\xd7\x01\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x07\x00\x6a\xff\x43\x00\x02\x02\x43\x00\x03\x02\x08\x00\x43\x00\x07\x00\xdb\x02\x44\x00\x6a\xff\x44\x00\x6a\xff\x08\x00\x44\x00\xc2\x02\xc3\x02\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x4d\x01\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\xc3\x01\xcb\x01\x79\x01\x07\x00\xcc\x01\x79\x01\xc9\x02\x95\x01\xcb\x01\x08\x00\x96\x01\x17\x02\x1a\x02\x3b\x02\xc5\x01\x65\x00\x7b\x01\x65\x00\xcb\x01\x7b\x01\x65\x00\xcc\x01\x06\x02\x8e\x02\x07\x02\x7b\x00\xe3\x01\x10\x00\x11\x00\x5b\x00\x7c\x00\x14\x02\xda\x01\x7d\x00\xdb\x01\x7e\x00\x7f\x00\x80\x00\x81\x00\x08\x02\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xcb\x01\xcb\x01\x43\x00\xcc\x01\xcc\x01\x8f\x02\x23\x02\x3e\x00\x8d\x00\x0a\x02\x44\x00\x8e\x00\x8f\x00\xc4\x02\xc5\x02\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x07\x00\xc3\x01\x43\x00\x0b\x02\x2f\x01\x43\x00\x08\x00\x30\x01\x76\x00\xcf\x02\x44\x00\x77\x00\x1b\x02\x44\x00\xc4\x01\xc5\x01\x65\x00\x4f\x02\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x51\x02\x24\x00\x6f\x00\xa0\x01\x07\x00\xd8\x01\xd9\x01\xda\x01\xc3\x01\xdb\x01\x08\x00\xc3\x01\x67\x00\x52\x01\x70\x00\x53\x01\x71\x00\x54\x01\x88\x02\x89\x02\x9b\x01\xc6\x01\xc5\x01\x65\x00\xc7\x01\xc5\x01\x65\x00\x74\x00\x10\x00\x11\x00\x5b\x00\x42\x02\xb0\x02\x7b\x00\x9d\x01\x37\x02\x38\x02\x39\x02\x7c\x00\x3a\x02\xa3\x01\x7d\x00\xa8\x01\x7e\x00\x7f\x00\x80\x00\x81\x00\xaf\x01\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xb3\x01\x58\x00\x43\x00\x59\x00\xb7\x01\x5a\x00\xbf\x01\x3e\x00\x8d\x00\xe4\x01\x44\x00\x8e\x00\x8f\x00\x8b\x02\x89\x02\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x07\x00\xc3\x01\x43\x00\xe5\x01\x43\x00\x07\x00\x08\x00\xbb\x01\x6f\x02\xba\x01\x44\x00\x08\x00\x44\x00\xe7\x01\xc8\x01\xc5\x01\x65\x00\xe8\x01\x79\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x16\x02\x5a\x00\x10\x00\x11\x00\x5b\x00\xe9\x01\x07\x00\xdd\x01\xc3\x01\xde\x01\x79\x01\xdf\x01\x08\x00\x42\x02\xb1\x02\x7a\x01\x2f\x00\x5b\x01\xe0\x01\x42\x02\x60\x02\xc9\x01\xc5\x01\x65\x00\x7b\x01\x65\x00\x4f\x01\x0d\x00\x0e\x00\xea\x01\x10\x00\x11\x00\x50\x01\x7b\x00\x42\x02\x63\x02\x07\x00\xeb\x01\x7c\x00\xec\x01\x33\x00\x7d\x00\x08\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xed\x01\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\xf8\x01\x10\x00\x11\x00\x4b\x01\xbb\x01\x70\x02\xf2\x01\x3e\x00\x8d\x00\xbb\x01\x71\x02\x8e\x00\x8f\x00\xbb\x01\x72\x02\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\x5e\x02\x33\x02\x34\x02\x35\x02\xb1\x01\x18\x00\x43\x00\x0e\x02\x0f\x02\x54\x01\xa7\x00\xa8\x00\xa9\x00\xa4\xfe\x44\x00\x11\x02\x12\x02\x20\x02\x21\x02\xaa\x00\xab\x00\xac\x00\xad\x00\x99\x02\x9a\x02\x9b\x02\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\x1a\x00\x1b\x00\x43\x00\xb6\x00\xb7\x00\x61\x00\x3c\x02\x3d\x02\xbb\x01\x3f\x02\x44\x00\xb2\x02\x32\x02\x33\x02\x34\x02\x35\x02\xf5\x01\x5e\x01\x24\x01\x64\x00\x65\x00\x26\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb8\x00\x23\x00\xd1\x01\xd2\x01\xb9\x00\x27\x01\x54\x00\x61\x00\x6d\x00\x16\x00\x26\x00\x27\x00\x28\x01\x28\x00\x29\x01\xd3\x01\x5d\x00\xd4\x01\x5e\x00\x61\x01\x5f\x00\x64\x00\x65\x00\xb2\x01\x2c\x00\xba\x00\x2a\x01\x2c\x00\x2d\x00\x2b\x01\x2e\x00\xb1\x01\x18\x00\x43\x00\x42\x02\x43\x02\x2c\x01\xa7\x00\xa8\x00\xa9\x00\xa4\xfe\x44\x00\x2e\x00\x04\x00\x07\x00\x2d\x01\xaa\x00\xab\x00\xac\x00\xad\x00\x08\x00\x2c\x00\x2d\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\x1a\x00\x1b\x00\x30\x01\xb6\x00\xb7\x00\x79\x01\x31\x01\x10\x00\x11\x00\x52\x00\x81\x01\x9f\x02\x32\x02\x33\x02\x34\x02\x35\x02\x48\x01\x49\x01\x32\x01\x7b\x01\x65\x00\x35\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb8\x00\x23\x00\x2c\x00\x2d\x00\xb9\x00\x36\x01\x54\x00\x40\x01\x3e\x01\x41\x01\x26\x00\x27\x00\x43\x01\x28\x00\x46\x01\x49\x01\x5d\x00\x82\x01\x5e\x00\x89\x01\x5f\x00\x8a\x01\x5f\x00\xb2\x01\x60\x00\xba\x00\x18\x00\x2c\x00\x2d\x00\x4f\x00\x2e\x00\xa7\x00\xa8\x00\xa9\x00\x6b\x00\x58\x00\xba\x00\x78\x01\x04\x00\x79\x01\xaa\x00\xab\x00\xac\x00\xad\x00\x05\x00\xae\x02\x2c\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\x1a\x00\x1b\x00\xcf\x02\xb6\x00\xb7\x00\xa2\x02\x32\x02\x33\x02\x34\x02\x35\x02\x54\x02\x32\x02\x33\x02\x34\x02\x35\x02\x31\x02\x32\x02\x33\x02\x34\x02\x35\x02\x2c\x00\xb5\x02\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb8\x00\x23\x00\xb6\x02\xb7\x02\xb9\x00\x2c\x00\x54\x00\x9c\x02\xb9\x02\xbc\x02\x26\x00\x27\x00\x9d\x02\x28\x00\xbb\x02\x68\x02\x5d\x00\xcc\x02\x5e\x00\x2c\x00\x5f\x00\x6d\x02\xce\x02\x5b\xfe\x9f\x02\xba\x00\x8b\x02\x2c\x00\x2d\x00\x88\x02\x2e\x00\x5b\xfe\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x01\x01\x01\x02\x01\x03\x01\x04\x01\x05\x01\x06\x01\x07\x01\x08\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x0f\x01\x10\x01\x11\x01\x12\x01\x13\x01\x18\x00\x2c\x00\xe0\x01\xe0\x01\x8d\x02\xa7\x00\xa8\x00\xa9\x00\xe0\x01\x92\x02\x94\x02\x57\x02\x45\x02\x58\x02\xaa\x00\xab\x00\xac\x00\xad\x00\x99\x02\x5b\x02\x2c\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\x1a\x00\x1b\x00\x5c\x02\xb6\x00\xb7\x00\x5d\x02\x5e\x02\x45\x02\x7a\x02\x68\x02\x6d\x02\x2c\x00\x75\x02\x7b\x02\x7d\x02\xb5\x01\x7e\x02\x0e\x02\x26\x01\xe0\x01\xe0\x01\x23\x02\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb8\x00\x23\x00\x80\x02\xfa\x01\xb9\x00\x81\x02\x54\x00\x82\x02\x84\x02\x85\x02\x26\x00\x27\x00\x86\x02\x28\x00\x87\x02\xfc\x01\x5d\x00\x18\x00\x5e\x00\xfa\x01\x5f\x00\xe7\x01\xa7\x00\xa8\x00\xa9\x00\xba\x00\xfa\x01\x2c\x00\x2d\x00\xff\x01\x2e\x00\xaa\x00\xab\x00\xac\x00\xad\x00\x05\x02\x00\x02\x06\x02\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\x1a\x00\x1b\x00\x01\x02\xb6\x00\xb7\x00\x02\x02\xfa\x01\x0a\x02\x2f\x02\x14\x02\x3f\x02\x2c\x00\x45\x02\x2c\x00\x49\x02\x2c\xff\x2d\xff\x29\xff\x27\xff\x28\xff\x18\x00\x9f\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xb8\x00\x23\x00\xa0\x01\xa2\x01\xb9\x00\xa3\x01\x54\x00\xa5\x01\xaa\x01\x19\x00\x26\x00\x27\x00\xac\x01\x28\x00\xad\x01\xae\x01\x5d\x00\x2c\x00\x5e\x00\xb5\x01\x5f\x00\x1a\x00\x1b\x00\x1c\x00\x2c\x00\xba\x00\xe3\x01\x2c\x00\x2d\x00\x4b\x01\x2e\x00\xe7\x01\xef\x01\xf0\x01\xf1\x01\xf2\x01\x26\x01\xf4\x01\x6d\x00\xe7\x01\x34\x01\xf5\x01\xe7\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xfa\x01\x23\x00\x2c\x00\x2c\x00\xbd\x02\x24\x00\x25\x00\x18\x00\x43\x01\x40\x01\x26\x00\x27\x00\x6d\x00\x28\x00\x77\x00\x4b\x01\x29\x00\x56\x01\x2a\x00\x39\x00\x2b\x00\x3a\x00\x2c\x00\x5b\x01\x19\x00\x60\x01\x63\x01\x2c\x00\x2d\x00\x07\x00\x2e\x00\x64\x01\x65\x01\x80\x01\x6d\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x84\x01\x85\x01\x3a\x00\x86\x01\x87\x01\x88\x01\x8e\x01\xff\xff\x2c\x00\x89\x01\x5d\x01\x0d\x00\x0e\x00\x8c\x01\x10\x00\x11\x00\x50\x01\x8d\x01\x72\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x6a\x01\x23\x00\x6d\x00\x78\x00\x31\x02\x24\x00\x25\x00\x18\x00\xff\xff\x79\x00\x26\x00\x27\x00\x07\x00\x28\x00\xff\xff\x00\x00\x29\x00\x00\x00\x2a\x00\x39\x00\x2b\x00\x3a\x00\x00\x00\x00\x00\x19\x00\x00\x00\x07\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x02\x0d\x00\x0e\x00\x6c\x01\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x4b\x02\x4c\x02\x4d\x02\x24\x00\x25\x00\x41\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x42\x00\x00\x00\x29\x00\x00\x00\x2a\x00\x39\x00\x2b\x00\x3a\x00\x00\x00\x00\x00\x19\x00\x00\x00\x07\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x02\x0d\x00\x0e\x00\x6c\x01\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x4b\x02\x4c\x02\x4e\x02\x24\x00\x25\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x43\x00\x2a\x00\x00\x00\x2b\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x07\x00\x2a\x00\x19\x00\x2b\x00\x35\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x3a\x00\x2e\x00\x1a\x00\x1b\x00\x1c\x00\x3b\x00\x0a\x00\x0b\x00\x3c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x18\x00\x6a\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x43\x00\x2a\x00\x00\x00\x2b\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x07\x00\x2a\x00\x19\x00\x2b\x00\x35\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x3a\x00\x2e\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x5d\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x67\x01\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x43\x00\x2a\x00\x00\x00\x2b\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x07\x00\x2a\x00\x19\x00\x2b\x00\x35\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1a\x00\x1b\x00\x1c\x00\x58\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x41\x00\x54\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x42\x00\x28\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5e\x00\x39\x00\x5f\x00\x3a\x00\x19\x00\x07\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x01\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x7a\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5d\x00\x95\x01\x5e\x00\x00\x00\x5f\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x41\x00\x54\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x42\x00\x28\x00\x00\x00\x00\x00\x5d\x00\x07\x00\x5e\x00\x39\x00\x5f\x00\x3a\x00\x19\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x1b\x00\x00\x00\x73\x00\x0d\x00\x0e\x00\x74\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5d\x00\x73\x01\x5e\x00\x00\x00\x5f\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x19\x00\x26\x00\x27\x00\x5d\xff\x28\x00\x00\x00\x5d\xff\x5d\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x24\x00\x25\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x29\x00\x00\x00\x2a\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x41\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x42\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5d\x00\x07\x00\x5e\x00\x19\x00\x5f\x00\x93\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1a\x00\x1b\x00\x00\x00\x64\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x18\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x18\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x00\x00\x00\x00\x5d\x00\x07\x00\x5e\x00\x19\x00\x5f\x00\x71\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1a\x00\x1b\x00\x00\x00\x68\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x00\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x00\x00\x23\x00\x19\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x1a\x00\x1b\x00\x5d\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x1a\x00\x1b\x00\x4f\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x67\x00\x5d\x00\x68\x00\xa2\x02\x69\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x00\x00\x00\x00\x4f\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x7d\x01\x5d\x00\x7e\x01\x5e\x00\x7f\x01\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x1a\x00\x1b\x00\x4f\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x67\x00\x5d\x00\x68\x00\xc3\x01\x69\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x00\x00\x00\x00\x4f\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x67\x00\x5d\x00\x68\x00\x5e\x00\xcb\x01\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x1a\x00\x1b\x00\x4f\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x7d\x01\x5d\x00\x7e\x01\x5e\x00\x7f\x01\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x00\x00\x00\x00\x4f\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x67\x00\x5d\x00\x68\x00\x5e\x00\x69\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x1a\x00\x1b\x00\x4f\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x7d\x01\x55\x00\x7e\x01\x56\x00\x7f\x01\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x19\x00\x23\x00\x00\x00\x00\x00\x4d\x00\x4e\x00\x54\x00\x00\x00\x00\x00\x4f\x00\x26\x00\x27\x00\x1a\x00\x1b\x00\x00\x00\x50\x00\x5d\x00\x51\x00\x5e\x00\x52\x00\x5f\x00\x00\x00\x00\x00\x07\x00\x00\x00\x93\x01\x2c\x00\x2c\x00\x2d\x00\x08\x00\x2e\x00\x00\x00\x00\x00\x5c\x01\x30\x00\x00\x00\x1f\x00\x20\x00\x00\x00\x22\x00\x00\x00\x23\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x54\x00\x10\x00\x11\x00\x50\x01\x26\x00\x27\x00\x00\x00\x07\x00\x00\x00\x00\x00\x5d\x00\x37\x00\x5e\x00\x08\x00\x6b\x00\x00\x00\x00\x00\x2f\x00\x5b\x01\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x6b\x01\x0d\x00\x0e\x00\x6c\x01\x10\x00\x11\x00\x12\x00\x07\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x08\x00\x33\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x6d\x01\x6e\x01\x00\x00\x6f\x01\x36\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x69\x01\x07\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x07\x00\x13\x00\x14\x00\x15\x00\x16\x00\x37\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x07\x00\x13\x00\x14\x00\x15\x00\x16\x00\x68\x01\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x0a\x00\x0b\x00\x32\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x24\x02\x13\x00\x14\x00\x15\x00\x16\x00\x33\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\xaa\x01\x58\x01\x59\x01\x07\x00\x00\x00\x71\x01\x00\x00\x33\x00\x00\x00\x08\x00\x07\x00\x00\x00\x00\x00\x5c\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x97\x01\x30\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x37\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x08\x00\x07\x00\x00\x00\x00\x00\x98\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x99\x01\x30\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x66\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x01\x08\x00\x07\x00\x00\x00\x00\x00\x9a\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x69\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x01\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x69\x01\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x08\x00\x07\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x5b\x01\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x37\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x08\x00\x07\x00\x00\x00\x00\x00\x5c\x01\x30\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x37\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x01\x08\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x0d\x00\x0e\x00\x00\x00\x10\x00\x11\x00\x50\x01\x07\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x08\x00\x66\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x02\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x07\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x00\x00\x00\x00\x00\x00\x13\x00\x14\x00\x15\x00\x16\x00\x10\xff\x10\xff\x00\x00\x4d\x00\x4e\x00\x10\xff\x00\x00\x10\xff\x4f\x00\x00\x00\x2a\xff\x10\xff\x00\x00\x10\xff\x7d\x01\x10\xff\x7e\x01\x00\x00\x7f\x01\x4d\x00\x4e\x00\x00\x00\x10\xff\x00\x00\x4f\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x68\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x14\x01\x15\x01\x16\x01\x17\x01\x18\x01\x19\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (3, 421) [ + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188), + (189 , happyReduce_189), + (190 , happyReduce_190), + (191 , happyReduce_191), + (192 , happyReduce_192), + (193 , happyReduce_193), + (194 , happyReduce_194), + (195 , happyReduce_195), + (196 , happyReduce_196), + (197 , happyReduce_197), + (198 , happyReduce_198), + (199 , happyReduce_199), + (200 , happyReduce_200), + (201 , happyReduce_201), + (202 , happyReduce_202), + (203 , happyReduce_203), + (204 , happyReduce_204), + (205 , happyReduce_205), + (206 , happyReduce_206), + (207 , happyReduce_207), + (208 , happyReduce_208), + (209 , happyReduce_209), + (210 , happyReduce_210), + (211 , happyReduce_211), + (212 , happyReduce_212), + (213 , happyReduce_213), + (214 , happyReduce_214), + (215 , happyReduce_215), + (216 , happyReduce_216), + (217 , happyReduce_217), + (218 , happyReduce_218), + (219 , happyReduce_219), + (220 , happyReduce_220), + (221 , happyReduce_221), + (222 , happyReduce_222), + (223 , happyReduce_223), + (224 , happyReduce_224), + (225 , happyReduce_225), + (226 , happyReduce_226), + (227 , happyReduce_227), + (228 , happyReduce_228), + (229 , happyReduce_229), + (230 , happyReduce_230), + (231 , happyReduce_231), + (232 , happyReduce_232), + (233 , happyReduce_233), + (234 , happyReduce_234), + (235 , happyReduce_235), + (236 , happyReduce_236), + (237 , happyReduce_237), + (238 , happyReduce_238), + (239 , happyReduce_239), + (240 , happyReduce_240), + (241 , happyReduce_241), + (242 , happyReduce_242), + (243 , happyReduce_243), + (244 , happyReduce_244), + (245 , happyReduce_245), + (246 , happyReduce_246), + (247 , happyReduce_247), + (248 , happyReduce_248), + (249 , happyReduce_249), + (250 , happyReduce_250), + (251 , happyReduce_251), + (252 , happyReduce_252), + (253 , happyReduce_253), + (254 , happyReduce_254), + (255 , happyReduce_255), + (256 , happyReduce_256), + (257 , happyReduce_257), + (258 , happyReduce_258), + (259 , happyReduce_259), + (260 , happyReduce_260), + (261 , happyReduce_261), + (262 , happyReduce_262), + (263 , happyReduce_263), + (264 , happyReduce_264), + (265 , happyReduce_265), + (266 , happyReduce_266), + (267 , happyReduce_267), + (268 , happyReduce_268), + (269 , happyReduce_269), + (270 , happyReduce_270), + (271 , happyReduce_271), + (272 , happyReduce_272), + (273 , happyReduce_273), + (274 , happyReduce_274), + (275 , happyReduce_275), + (276 , happyReduce_276), + (277 , happyReduce_277), + (278 , happyReduce_278), + (279 , happyReduce_279), + (280 , happyReduce_280), + (281 , happyReduce_281), + (282 , happyReduce_282), + (283 , happyReduce_283), + (284 , happyReduce_284), + (285 , happyReduce_285), + (286 , happyReduce_286), + (287 , happyReduce_287), + (288 , happyReduce_288), + (289 , happyReduce_289), + (290 , happyReduce_290), + (291 , happyReduce_291), + (292 , happyReduce_292), + (293 , happyReduce_293), + (294 , happyReduce_294), + (295 , happyReduce_295), + (296 , happyReduce_296), + (297 , happyReduce_297), + (298 , happyReduce_298), + (299 , happyReduce_299), + (300 , happyReduce_300), + (301 , happyReduce_301), + (302 , happyReduce_302), + (303 , happyReduce_303), + (304 , happyReduce_304), + (305 , happyReduce_305), + (306 , happyReduce_306), + (307 , happyReduce_307), + (308 , happyReduce_308), + (309 , happyReduce_309), + (310 , happyReduce_310), + (311 , happyReduce_311), + (312 , happyReduce_312), + (313 , happyReduce_313), + (314 , happyReduce_314), + (315 , happyReduce_315), + (316 , happyReduce_316), + (317 , happyReduce_317), + (318 , happyReduce_318), + (319 , happyReduce_319), + (320 , happyReduce_320), + (321 , happyReduce_321), + (322 , happyReduce_322), + (323 , happyReduce_323), + (324 , happyReduce_324), + (325 , happyReduce_325), + (326 , happyReduce_326), + (327 , happyReduce_327), + (328 , happyReduce_328), + (329 , happyReduce_329), + (330 , happyReduce_330), + (331 , happyReduce_331), + (332 , happyReduce_332), + (333 , happyReduce_333), + (334 , happyReduce_334), + (335 , happyReduce_335), + (336 , happyReduce_336), + (337 , happyReduce_337), + (338 , happyReduce_338), + (339 , happyReduce_339), + (340 , happyReduce_340), + (341 , happyReduce_341), + (342 , happyReduce_342), + (343 , happyReduce_343), + (344 , happyReduce_344), + (345 , happyReduce_345), + (346 , happyReduce_346), + (347 , happyReduce_347), + (348 , happyReduce_348), + (349 , happyReduce_349), + (350 , happyReduce_350), + (351 , happyReduce_351), + (352 , happyReduce_352), + (353 , happyReduce_353), + (354 , happyReduce_354), + (355 , happyReduce_355), + (356 , happyReduce_356), + (357 , happyReduce_357), + (358 , happyReduce_358), + (359 , happyReduce_359), + (360 , happyReduce_360), + (361 , happyReduce_361), + (362 , happyReduce_362), + (363 , happyReduce_363), + (364 , happyReduce_364), + (365 , happyReduce_365), + (366 , happyReduce_366), + (367 , happyReduce_367), + (368 , happyReduce_368), + (369 , happyReduce_369), + (370 , happyReduce_370), + (371 , happyReduce_371), + (372 , happyReduce_372), + (373 , happyReduce_373), + (374 , happyReduce_374), + (375 , happyReduce_375), + (376 , happyReduce_376), + (377 , happyReduce_377), + (378 , happyReduce_378), + (379 , happyReduce_379), + (380 , happyReduce_380), + (381 , happyReduce_381), + (382 , happyReduce_382), + (383 , happyReduce_383), + (384 , happyReduce_384), + (385 , happyReduce_385), + (386 , happyReduce_386), + (387 , happyReduce_387), + (388 , happyReduce_388), + (389 , happyReduce_389), + (390 , happyReduce_390), + (391 , happyReduce_391), + (392 , happyReduce_392), + (393 , happyReduce_393), + (394 , happyReduce_394), + (395 , happyReduce_395), + (396 , happyReduce_396), + (397 , happyReduce_397), + (398 , happyReduce_398), + (399 , happyReduce_399), + (400 , happyReduce_400), + (401 , happyReduce_401), + (402 , happyReduce_402), + (403 , happyReduce_403), + (404 , happyReduce_404), + (405 , happyReduce_405), + (406 , happyReduce_406), + (407 , happyReduce_407), + (408 , happyReduce_408), + (409 , happyReduce_409), + (410 , happyReduce_410), + (411 , happyReduce_411), + (412 , happyReduce_412), + (413 , happyReduce_413), + (414 , happyReduce_414), + (415 , happyReduce_415), + (416 , happyReduce_416), + (417 , happyReduce_417), + (418 , happyReduce_418), + (419 , happyReduce_419), + (420 , happyReduce_420), + (421 , happyReduce_421) + ] + +happy_n_terms = 90 :: Int +happy_n_nonterms = 140 :: Int + +happyReduce_3 = happySpecReduce_1 0# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + (reverse happy_var_1 + )} + +happyReduce_4 = happySpecReduce_2 1# happyReduction_4 +happyReduction_4 happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn7 + (happy_var_2 : happy_var_1 + )}} + +happyReduce_5 = happySpecReduce_0 1# happyReduction_5 +happyReduction_5 = happyIn7 + ([] + ) + +happyReduce_6 = happySpecReduce_1 2# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) -> + happyIn8 + (TokKeyword KwLet happy_var_1 + )} + +happyReduce_7 = happySpecReduce_1 2# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwIn happy_var_1) -> + happyIn8 + (TokKeyword KwIn happy_var_1 + )} + +happyReduce_8 = happySpecReduce_1 2# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwWhere happy_var_1) -> + happyIn8 + (TokKeyword KwWhere happy_var_1 + )} + +happyReduce_9 = happySpecReduce_1 2# happyReduction_9 +happyReduction_9 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwWith happy_var_1) -> + happyIn8 + (TokKeyword KwWith happy_var_1 + )} + +happyReduce_10 = happySpecReduce_1 2# happyReduction_10 +happyReduction_10 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwRewrite happy_var_1) -> + happyIn8 + (TokKeyword KwRewrite happy_var_1 + )} + +happyReduce_11 = happySpecReduce_1 2# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) -> + happyIn8 + (TokKeyword KwPostulate happy_var_1 + )} + +happyReduce_12 = happySpecReduce_1 2# happyReduction_12 +happyReduction_12 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) -> + happyIn8 + (TokKeyword KwPrimitive happy_var_1 + )} + +happyReduce_13 = happySpecReduce_1 2# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> + happyIn8 + (TokKeyword KwOpen happy_var_1 + )} + +happyReduce_14 = happySpecReduce_1 2# happyReduction_14 +happyReduction_14 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwImport happy_var_1) -> + happyIn8 + (TokKeyword KwImport happy_var_1 + )} + +happyReduce_15 = happySpecReduce_1 2# happyReduction_15 +happyReduction_15 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwUsing happy_var_1) -> + happyIn8 + (TokKeyword KwUsing happy_var_1 + )} + +happyReduce_16 = happySpecReduce_1 2# happyReduction_16 +happyReduction_16 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwHiding happy_var_1) -> + happyIn8 + (TokKeyword KwHiding happy_var_1 + )} + +happyReduce_17 = happySpecReduce_1 2# happyReduction_17 +happyReduction_17 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> + happyIn8 + (TokKeyword KwRenaming happy_var_1 + )} + +happyReduce_18 = happySpecReduce_1 2# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwTo happy_var_1) -> + happyIn8 + (TokKeyword KwTo happy_var_1 + )} + +happyReduce_19 = happySpecReduce_1 2# happyReduction_19 +happyReduction_19 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) -> + happyIn8 + (TokKeyword KwPublic happy_var_1 + )} + +happyReduce_20 = happySpecReduce_1 2# happyReduction_20 +happyReduction_20 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> + happyIn8 + (TokKeyword KwModule happy_var_1 + )} + +happyReduce_21 = happySpecReduce_1 2# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> + happyIn8 + (TokKeyword KwData happy_var_1 + )} + +happyReduce_22 = happySpecReduce_1 2# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> + happyIn8 + (TokKeyword KwCoData happy_var_1 + )} + +happyReduce_23 = happySpecReduce_1 2# happyReduction_23 +happyReduction_23 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> + happyIn8 + (TokKeyword KwRecord happy_var_1 + )} + +happyReduce_24 = happySpecReduce_1 2# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwConstructor happy_var_1) -> + happyIn8 + (TokKeyword KwConstructor happy_var_1 + )} + +happyReduce_25 = happySpecReduce_1 2# happyReduction_25 +happyReduction_25 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) -> + happyIn8 + (TokKeyword KwInductive happy_var_1 + )} + +happyReduce_26 = happySpecReduce_1 2# happyReduction_26 +happyReduction_26 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) -> + happyIn8 + (TokKeyword KwCoInductive happy_var_1 + )} + +happyReduce_27 = happySpecReduce_1 2# happyReduction_27 +happyReduction_27 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwField happy_var_1) -> + happyIn8 + (TokKeyword KwField happy_var_1 + )} + +happyReduce_28 = happySpecReduce_1 2# happyReduction_28 +happyReduction_28 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) -> + happyIn8 + (TokKeyword KwInfix happy_var_1 + )} + +happyReduce_29 = happySpecReduce_1 2# happyReduction_29 +happyReduction_29 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) -> + happyIn8 + (TokKeyword KwInfixL happy_var_1 + )} + +happyReduce_30 = happySpecReduce_1 2# happyReduction_30 +happyReduction_30 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) -> + happyIn8 + (TokKeyword KwInfixR happy_var_1 + )} + +happyReduce_31 = happySpecReduce_1 2# happyReduction_31 +happyReduction_31 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) -> + happyIn8 + (TokKeyword KwMutual happy_var_1 + )} + +happyReduce_32 = happySpecReduce_1 2# happyReduction_32 +happyReduction_32 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) -> + happyIn8 + (TokKeyword KwAbstract happy_var_1 + )} + +happyReduce_33 = happySpecReduce_1 2# happyReduction_33 +happyReduction_33 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) -> + happyIn8 + (TokKeyword KwPrivate happy_var_1 + )} + +happyReduce_34 = happySpecReduce_1 2# happyReduction_34 +happyReduction_34 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) -> + happyIn8 + (TokKeyword KwInstance happy_var_1 + )} + +happyReduce_35 = happySpecReduce_1 2# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) -> + happyIn8 + (TokKeyword KwProp happy_var_1 + )} + +happyReduce_36 = happySpecReduce_1 2# happyReduction_36 +happyReduction_36 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) -> + happyIn8 + (TokKeyword KwSet happy_var_1 + )} + +happyReduce_37 = happySpecReduce_1 2# happyReduction_37 +happyReduction_37 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwForall happy_var_1) -> + happyIn8 + (TokKeyword KwForall happy_var_1 + )} + +happyReduce_38 = happySpecReduce_1 2# happyReduction_38 +happyReduction_38 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwSyntax happy_var_1) -> + happyIn8 + (TokKeyword KwSyntax happy_var_1 + )} + +happyReduce_39 = happySpecReduce_1 2# happyReduction_39 +happyReduction_39 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPatternSyn happy_var_1) -> + happyIn8 + (TokKeyword KwPatternSyn happy_var_1 + )} + +happyReduce_40 = happySpecReduce_1 2# happyReduction_40 +happyReduction_40 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwOPTIONS happy_var_1) -> + happyIn8 + (TokKeyword KwOPTIONS happy_var_1 + )} + +happyReduce_41 = happySpecReduce_1 2# happyReduction_41 +happyReduction_41 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwBUILTIN happy_var_1) -> + happyIn8 + (TokKeyword KwBUILTIN happy_var_1 + )} + +happyReduce_42 = happySpecReduce_1 2# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwREWRITE happy_var_1) -> + happyIn8 + (TokKeyword KwREWRITE happy_var_1 + )} + +happyReduce_43 = happySpecReduce_1 2# happyReduction_43 +happyReduction_43 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwIMPORT happy_var_1) -> + happyIn8 + (TokKeyword KwIMPORT happy_var_1 + )} + +happyReduce_44 = happySpecReduce_1 2# happyReduction_44 +happyReduction_44 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED happy_var_1) -> + happyIn8 + (TokKeyword KwCOMPILED happy_var_1 + )} + +happyReduce_45 = happySpecReduce_1 2# happyReduction_45 +happyReduction_45 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_EXPORT happy_var_1) -> + happyIn8 + (TokKeyword KwCOMPILED_EXPORT happy_var_1 + )} + +happyReduce_46 = happySpecReduce_1 2# happyReduction_46 +happyReduction_46 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_DATA happy_var_1) -> + happyIn8 + (TokKeyword KwCOMPILED_DATA happy_var_1 + )} + +happyReduce_47 = happySpecReduce_1 2# happyReduction_47 +happyReduction_47 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_TYPE happy_var_1) -> + happyIn8 + (TokKeyword KwCOMPILED_TYPE happy_var_1 + )} + +happyReduce_48 = happySpecReduce_1 2# happyReduction_48 +happyReduction_48 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_EPIC happy_var_1) -> + happyIn8 + (TokKeyword KwCOMPILED_EPIC happy_var_1 + )} + +happyReduce_49 = happySpecReduce_1 2# happyReduction_49 +happyReduction_49 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCOMPILED_JS happy_var_1) -> + happyIn8 + (TokKeyword KwCOMPILED_JS happy_var_1 + )} + +happyReduce_50 = happySpecReduce_1 2# happyReduction_50 +happyReduction_50 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwSTATIC happy_var_1) -> + happyIn8 + (TokKeyword KwSTATIC happy_var_1 + )} + +happyReduce_51 = happySpecReduce_1 2# happyReduction_51 +happyReduction_51 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwIMPOSSIBLE happy_var_1) -> + happyIn8 + (TokKeyword KwIMPOSSIBLE happy_var_1 + )} + +happyReduce_52 = happySpecReduce_1 2# happyReduction_52 +happyReduction_52 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwETA happy_var_1) -> + happyIn8 + (TokKeyword KwETA happy_var_1 + )} + +happyReduce_53 = happySpecReduce_1 2# happyReduction_53 +happyReduction_53 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwNO_TERMINATION_CHECK happy_var_1) -> + happyIn8 + (TokKeyword KwNO_TERMINATION_CHECK happy_var_1 + )} + +happyReduce_54 = happySpecReduce_1 2# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwNON_TERMINATING happy_var_1) -> + happyIn8 + (TokKeyword KwNON_TERMINATING happy_var_1 + )} + +happyReduce_55 = happySpecReduce_1 2# happyReduction_55 +happyReduction_55 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwTERMINATING happy_var_1) -> + happyIn8 + (TokKeyword KwTERMINATING happy_var_1 + )} + +happyReduce_56 = happySpecReduce_1 2# happyReduction_56 +happyReduction_56 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwMEASURE happy_var_1) -> + happyIn8 + (TokKeyword KwMEASURE happy_var_1 + )} + +happyReduce_57 = happySpecReduce_1 2# happyReduction_57 +happyReduction_57 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) -> + happyIn8 + (TokKeyword KwQuoteGoal happy_var_1 + )} + +happyReduce_58 = happySpecReduce_1 2# happyReduction_58 +happyReduction_58 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) -> + happyIn8 + (TokKeyword KwQuoteContext happy_var_1 + )} + +happyReduce_59 = happySpecReduce_1 2# happyReduction_59 +happyReduction_59 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) -> + happyIn8 + (TokKeyword KwQuote happy_var_1 + )} + +happyReduce_60 = happySpecReduce_1 2# happyReduction_60 +happyReduction_60 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) -> + happyIn8 + (TokKeyword KwQuoteTerm happy_var_1 + )} + +happyReduce_61 = happySpecReduce_1 2# happyReduction_61 +happyReduction_61 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> + happyIn8 + (TokKeyword KwTactic happy_var_1 + )} + +happyReduce_62 = happySpecReduce_1 2# happyReduction_62 +happyReduction_62 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) -> + happyIn8 + (TokKeyword KwUnquote happy_var_1 + )} + +happyReduce_63 = happySpecReduce_1 2# happyReduction_63 +happyReduction_63 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> + happyIn8 + (TokKeyword KwUnquoteDecl happy_var_1 + )} + +happyReduce_64 = happySpecReduce_1 2# happyReduction_64 +happyReduction_64 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSetN happy_var_1) -> + happyIn8 + (TokSetN happy_var_1 + )} + +happyReduce_65 = happySpecReduce_1 2# happyReduction_65 +happyReduction_65 happy_x_1 + = case happyOutTok happy_x_1 of { (TokTeX happy_var_1) -> + happyIn8 + (TokTeX happy_var_1 + )} + +happyReduce_66 = happySpecReduce_1 2# happyReduction_66 +happyReduction_66 happy_x_1 + = case happyOutTok happy_x_1 of { (TokComment happy_var_1) -> + happyIn8 + (TokComment happy_var_1 + )} + +happyReduce_67 = happySpecReduce_1 2# happyReduction_67 +happyReduction_67 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) -> + happyIn8 + (TokSymbol SymEllipsis happy_var_1 + )} + +happyReduce_68 = happySpecReduce_1 2# happyReduction_68 +happyReduction_68 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDotDot happy_var_1) -> + happyIn8 + (TokSymbol SymDotDot happy_var_1 + )} + +happyReduce_69 = happySpecReduce_1 2# happyReduction_69 +happyReduction_69 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) -> + happyIn8 + (TokSymbol SymDot happy_var_1 + )} + +happyReduce_70 = happySpecReduce_1 2# happyReduction_70 +happyReduction_70 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) -> + happyIn8 + (TokSymbol SymSemi happy_var_1 + )} + +happyReduce_71 = happySpecReduce_1 2# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymColon happy_var_1) -> + happyIn8 + (TokSymbol SymColon happy_var_1 + )} + +happyReduce_72 = happySpecReduce_1 2# happyReduction_72 +happyReduction_72 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymEqual happy_var_1) -> + happyIn8 + (TokSymbol SymEqual happy_var_1 + )} + +happyReduce_73 = happySpecReduce_1 2# happyReduction_73 +happyReduction_73 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> + happyIn8 + (TokSymbol SymUnderscore happy_var_1 + )} + +happyReduce_74 = happySpecReduce_1 2# happyReduction_74 +happyReduction_74 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) -> + happyIn8 + (TokSymbol SymQuestionMark happy_var_1 + )} + +happyReduce_75 = happySpecReduce_1 2# happyReduction_75 +happyReduction_75 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymArrow happy_var_1) -> + happyIn8 + (TokSymbol SymArrow happy_var_1 + )} + +happyReduce_76 = happySpecReduce_1 2# happyReduction_76 +happyReduction_76 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> + happyIn8 + (TokSymbol SymLambda happy_var_1 + )} + +happyReduce_77 = happySpecReduce_1 2# happyReduction_77 +happyReduction_77 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymAs happy_var_1) -> + happyIn8 + (TokSymbol SymAs happy_var_1 + )} + +happyReduce_78 = happySpecReduce_1 2# happyReduction_78 +happyReduction_78 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymBar happy_var_1) -> + happyIn8 + (TokSymbol SymBar happy_var_1 + )} + +happyReduce_79 = happySpecReduce_1 2# happyReduction_79 +happyReduction_79 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> + happyIn8 + (TokSymbol SymOpenParen happy_var_1 + )} + +happyReduce_80 = happySpecReduce_1 2# happyReduction_80 +happyReduction_80 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymCloseParen happy_var_1) -> + happyIn8 + (TokSymbol SymCloseParen happy_var_1 + )} + +happyReduce_81 = happySpecReduce_1 2# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> + happyIn8 + (TokSymbol SymDoubleOpenBrace happy_var_1 + )} + +happyReduce_82 = happySpecReduce_1 2# happyReduction_82 +happyReduction_82 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) -> + happyIn8 + (TokSymbol SymDoubleCloseBrace happy_var_1 + )} + +happyReduce_83 = happySpecReduce_1 2# happyReduction_83 +happyReduction_83 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> + happyIn8 + (TokSymbol SymOpenBrace happy_var_1 + )} + +happyReduce_84 = happySpecReduce_1 2# happyReduction_84 +happyReduction_84 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) -> + happyIn8 + (TokSymbol SymCloseBrace happy_var_1 + )} + +happyReduce_85 = happySpecReduce_1 2# happyReduction_85 +happyReduction_85 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenVirtualBrace happy_var_1) -> + happyIn8 + (TokSymbol SymOpenVirtualBrace happy_var_1 + )} + +happyReduce_86 = happySpecReduce_1 2# happyReduction_86 +happyReduction_86 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymCloseVirtualBrace happy_var_1) -> + happyIn8 + (TokSymbol SymCloseVirtualBrace happy_var_1 + )} + +happyReduce_87 = happySpecReduce_1 2# happyReduction_87 +happyReduction_87 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) -> + happyIn8 + (TokSymbol SymVirtualSemi happy_var_1 + )} + +happyReduce_88 = happySpecReduce_1 2# happyReduction_88 +happyReduction_88 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + happyIn8 + (TokSymbol SymOpenPragma happy_var_1 + )} + +happyReduce_89 = happySpecReduce_1 2# happyReduction_89 +happyReduction_89 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymClosePragma happy_var_1) -> + happyIn8 + (TokSymbol SymClosePragma happy_var_1 + )} + +happyReduce_90 = happySpecReduce_1 2# happyReduction_90 +happyReduction_90 happy_x_1 + = case happyOutTok happy_x_1 of { (TokId happy_var_1) -> + happyIn8 + (TokId happy_var_1 + )} + +happyReduce_91 = happySpecReduce_1 2# happyReduction_91 +happyReduction_91 happy_x_1 + = case happyOutTok happy_x_1 of { (TokQId happy_var_1) -> + happyIn8 + (TokQId happy_var_1 + )} + +happyReduce_92 = happySpecReduce_1 2# happyReduction_92 +happyReduction_92 happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + happyIn8 + (TokString happy_var_1 + )} + +happyReduce_93 = happySpecReduce_1 2# happyReduction_93 +happyReduction_93 happy_x_1 + = case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> + happyIn8 + (TokLiteral happy_var_1 + )} + +happyReduce_94 = happySpecReduce_3 3# happyReduction_94 +happyReduction_94 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut115 happy_x_2 of { happy_var_2 -> + happyIn9 + (takeOptionsPragmas happy_var_2 + )} + +happyReduce_95 = happySpecReduce_0 4# happyReduction_95 +happyReduction_95 = happyIn10 + (() + ) + +happyReduce_96 = happySpecReduce_1 4# happyReduction_96 +happyReduction_96 happy_x_1 + = happyIn10 + (() + ) + +happyReduce_97 = happySpecReduce_1 5# happyReduction_97 +happyReduction_97 happy_x_1 + = happyIn11 + (() + ) + +happyReduce_98 = happyMonadReduce 1# 5# happyReduction_98 +happyReduction_98 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (( popContext) + ) (\r -> happyReturn (happyIn11 r)) + +happyReduce_99 = happySpecReduce_1 6# happyReduction_99 +happyReduction_99 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymSemi happy_var_1) -> + happyIn12 + (happy_var_1 + )} + +happyReduce_100 = happySpecReduce_1 6# happyReduction_100 +happyReduction_100 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymVirtualSemi happy_var_1) -> + happyIn12 + (happy_var_1 + )} + +happyReduce_101 = happyMonadReduce 0# 7# happyReduction_101 +happyReduction_101 (happyRest) tk + = happyThen (( pushLexState imp_dir) + ) (\r -> happyReturn (happyIn13 r)) + +happyReduce_102 = happyMonadReduce 1# 8# happyReduction_102 +happyReduction_102 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> + ( case happy_var_1 of { + LitInt _ i -> return i; + _ -> fail $ "Expected integer" + })} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_103 = happyMonadReduce 1# 8# happyReduction_103 +happyReduction_103 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) -> + ( case happy_var_1 of { + (_, s) -> case readM s of { + Right i -> return i; + Left (err :: String) -> fail $ "Expected integer" + } + })} + ) (\r -> happyReturn (happyIn14 r)) + +happyReduce_104 = happyMonadReduce 1# 9# happyReduction_104 +happyReduction_104 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokId happy_var_1) -> + ( mkName happy_var_1)} + ) (\r -> happyReturn (happyIn15 r)) + +happyReduce_105 = happySpecReduce_2 10# happyReduction_105 +happyReduction_105 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn16 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_106 = happySpecReduce_1 10# happyReduction_106 +happyReduction_106 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn16 + ([happy_var_1] + )} + +happyReduce_107 = happySpecReduce_1 11# happyReduction_107 +happyReduction_107 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleCloseBrace happy_var_1) -> + happyIn17 + (getRange happy_var_1 + )} + +happyReduce_108 = happyMonadReduce 2# 11# happyReduction_108 +happyReduction_108 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymCloseBrace happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) -> + ( + if posPos (fromJust (rEnd (getRange happy_var_2))) - + posPos (fromJust (rStart (getRange happy_var_1))) > 2 + then parseErrorAt (fromJust (rStart (getRange happy_var_2))) + "Expecting '}}', found separated '}'s." + else return $ getRange (happy_var_1, happy_var_2))}} + ) (\r -> happyReturn (happyIn17 r)) + +happyReduce_109 = happySpecReduce_2 12# happyReduction_109 +happyReduction_109 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn18 + (setRelevance Irrelevant $ defaultArg happy_var_2 + )} + +happyReduce_110 = happySpecReduce_1 12# happyReduction_110 +happyReduction_110 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn18 + (defaultArg happy_var_1 + )} + +happyReduce_111 = happySpecReduce_2 13# happyReduction_111 +happyReduction_111 happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn19 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_112 = happySpecReduce_1 13# happyReduction_112 +happyReduction_112 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn19 + ([happy_var_1] + )} + +happyReduce_113 = happySpecReduce_2 14# happyReduction_113 +happyReduction_113 happy_x_2 + happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_2 of { happy_var_2 -> + happyIn20 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_114 = happySpecReduce_1 14# happyReduction_114 +happyReduction_114 happy_x_1 + = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn20 + ([happy_var_1] + )} + +happyReduce_115 = happyReduce 4# 14# happyReduction_115 +happyReduction_115 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut19 happy_x_2 of { happy_var_2 -> + case happyOut20 happy_x_4 of { happy_var_4 -> + happyIn20 + (map makeInstance happy_var_2 ++ happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_116 = happySpecReduce_3 14# happyReduction_116 +happyReduction_116 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn20 + (map makeInstance happy_var_2 + )} + +happyReduce_117 = happyReduce 4# 14# happyReduction_117 +happyReduction_117 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut19 happy_x_2 of { happy_var_2 -> + case happyOut20 happy_x_4 of { happy_var_4 -> + happyIn20 + (map hide happy_var_2 ++ happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_118 = happySpecReduce_3 14# happyReduction_118 +happyReduction_118 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut19 happy_x_2 of { happy_var_2 -> + happyIn20 + (map hide happy_var_2 + )} + +happyReduce_119 = happyReduce 5# 14# happyReduction_119 +happyReduction_119 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + case happyOut20 happy_x_5 of { happy_var_5 -> + happyIn20 + (map (hide . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_120 = happyReduce 4# 14# happyReduction_120 +happyReduction_120 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn20 + (map (hide . setRelevance Irrelevant . defaultArg) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_121 = happyReduce 5# 14# happyReduction_121 +happyReduction_121 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + case happyOut20 happy_x_5 of { happy_var_5 -> + happyIn20 + (map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3 ++ happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_122 = happyReduce 4# 14# happyReduction_122 +happyReduction_122 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn20 + (map (makeInstance . setRelevance Irrelevant . defaultArg) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_123 = happyReduce 5# 14# happyReduction_123 +happyReduction_123 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + case happyOut20 happy_x_5 of { happy_var_5 -> + happyIn20 + (map (hide . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_124 = happyReduce 4# 14# happyReduction_124 +happyReduction_124 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn20 + (map (hide . setRelevance NonStrict . defaultArg) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_125 = happyReduce 5# 14# happyReduction_125 +happyReduction_125 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + case happyOut20 happy_x_5 of { happy_var_5 -> + happyIn20 + (map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3 ++ happy_var_5 + ) `HappyStk` happyRest}} + +happyReduce_126 = happyReduce 4# 14# happyReduction_126 +happyReduction_126 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut16 happy_x_3 of { happy_var_3 -> + happyIn20 + (map (makeInstance . setRelevance NonStrict . defaultArg) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_127 = happyMonadReduce 1# 15# happyReduction_127 +happyReduction_127 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokQId happy_var_1) -> + ( mkQName happy_var_1)} + ) (\r -> happyReturn (happyIn21 r)) + +happyReduce_128 = happySpecReduce_1 15# happyReduction_128 +happyReduction_128 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn21 + (QName happy_var_1 + )} + +happyReduce_129 = happySpecReduce_1 16# happyReduction_129 +happyReduction_129 happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn22 + (happy_var_1 + )} + +happyReduce_130 = happySpecReduce_1 17# happyReduction_130 +happyReduction_130 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn23 + (happy_var_1 + )} + +happyReduce_131 = happySpecReduce_1 17# happyReduction_131 +happyReduction_131 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> + happyIn23 + (Name (getRange happy_var_1) [Hole] + )} + +happyReduce_132 = happySpecReduce_2 18# happyReduction_132 +happyReduction_132 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn24 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_133 = happySpecReduce_1 18# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn24 + ([happy_var_1] + )} + +happyReduce_134 = happySpecReduce_1 19# happyReduction_134 +happyReduction_134 happy_x_1 + = case happyOut26 happy_x_1 of { happy_var_1 -> + happyIn25 + (case happy_var_1 of + Left ns -> ns + Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern" + )} + +happyReduce_135 = happyMonadReduce 1# 20# happyReduction_135 +happyReduction_135 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut35 happy_x_1 of { happy_var_1 -> + ( + let getName :: Expr -> Maybe Name + getName (Ident (QName x)) = Just x + getName (Underscore r _) = Just (Name r [Hole]) + getName _ = Nothing + + isAbsurd :: Expr -> Bool + isAbsurd (Absurd _) = True + isAbsurd (HiddenArg _ (Named _ e)) = isAbsurd e + isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e + isAbsurd (Paren _ expr) = isAbsurd expr + isAbsurd (RawApp _ exprs) = any isAbsurd exprs + isAbsurd _ = False + in + if any isAbsurd happy_var_1 then return $ Right happy_var_1 else + case mapM getName happy_var_1 of + Just good -> return $ Left good + Nothing -> fail $ "expected sequence of bound identifiers")} + ) (\r -> happyReturn (happyIn26 r)) + +happyReduce_136 = happyMonadReduce 1# 21# happyReduction_136 +happyReduction_136 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut35 happy_x_1 of { happy_var_1 -> + ( + let -- interpret an expression as name + getName :: Expr -> Maybe Name + getName (Ident (QName x)) = Just x + getName (Underscore r _) = Just (Name r [Hole]) + getName _ = Nothing + + getNames :: Expr -> Maybe [Name] + getNames (RawApp _ es) = mapM getName es + getNames e = singleton `fmap` getName e + + -- interpret an expression as name or list of hidden names + getName1 :: Expr -> Maybe [WithHiding Name] + getName1 (Ident (QName x)) = Just [WithHiding NotHidden x] + getName1 (Underscore r _) = Just [WithHiding NotHidden $ Name r [Hole]] + getName1 (HiddenArg _ (Named Nothing e)) + = map (WithHiding Hidden) `fmap` getNames e + getName1 _ = Nothing + + in + case mapM getName1 happy_var_1 of + Just good -> return $ concat good + Nothing -> fail $ "expected sequence of possibly hidden bound identifiers")} + ) (\r -> happyReturn (happyIn27 r)) + +happyReduce_137 = happySpecReduce_0 22# happyReduction_137 +happyReduction_137 = happyIn28 + ([] + ) + +happyReduce_138 = happySpecReduce_2 22# happyReduction_138 +happyReduction_138 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + case happyOut28 happy_x_2 of { happy_var_2 -> + happyIn28 + (snd happy_var_1 : happy_var_2 + )}} + +happyReduce_139 = happySpecReduce_1 23# happyReduction_139 +happyReduction_139 happy_x_1 + = case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + happyIn29 + (snd happy_var_1 + )} + +happyReduce_140 = happyMonadReduce 1# 24# happyReduction_140 +happyReduction_140 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + ( mkName happy_var_1)} + ) (\r -> happyReturn (happyIn30 r)) + +happyReduce_141 = happyMonadReduce 1# 25# happyReduction_141 +happyReduction_141 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokString happy_var_1) -> + ( fmap QName (mkName happy_var_1))} + ) (\r -> happyReturn (happyIn31 r)) + +happyReduce_142 = happySpecReduce_2 26# happyReduction_142 +happyReduction_142 happy_x_2 + happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn32 + (Pi happy_var_1 happy_var_2 + )}} + +happyReduce_143 = happySpecReduce_3 26# happyReduction_143 +happyReduction_143 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut59 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 + (forallPi happy_var_2 happy_var_3 + )}} + +happyReduce_144 = happySpecReduce_3 26# happyReduction_144 +happyReduction_144 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokSymbol SymArrow happy_var_2) -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 + (Fun (getRange (happy_var_1,happy_var_2,happy_var_3)) + (RawApp (getRange happy_var_1) happy_var_1) + happy_var_3 + )}}} + +happyReduce_145 = happySpecReduce_3 26# happyReduction_145 +happyReduction_145 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokSymbol SymEqual happy_var_2) -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 + (Equal (getRange (happy_var_1, happy_var_2, happy_var_3)) happy_var_1 happy_var_3 + )}}} + +happyReduce_146 = happySpecReduce_1 26# happyReduction_146 +happyReduction_146 happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + happyIn32 + (happy_var_1 + )} + +happyReduce_147 = happyMonadReduce 1# 27# happyReduction_147 +happyReduction_147 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut34 happy_x_1 of { happy_var_1 -> + ( case happy_var_1 of + { [e] -> return e + ; e : es -> return $ WithApp (fuseRange e es) e es + ; [] -> fail "impossible: empty with expressions" + })} + ) (\r -> happyReturn (happyIn33 r)) + +happyReduce_148 = happySpecReduce_3 28# happyReduction_148 +happyReduction_148 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_3 of { happy_var_3 -> + happyIn34 + (RawApp (getRange happy_var_1) happy_var_1 : happy_var_3 + )}} + +happyReduce_149 = happySpecReduce_1 28# happyReduction_149 +happyReduction_149 happy_x_1 + = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn34 + ([RawApp (getRange happy_var_1) happy_var_1] + )} + +happyReduce_150 = happySpecReduce_1 29# happyReduction_150 +happyReduction_150 happy_x_1 + = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn35 + ([happy_var_1] + )} + +happyReduce_151 = happySpecReduce_2 29# happyReduction_151 +happyReduction_151 happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn35 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_152 = happySpecReduce_3 30# happyReduction_152 +happyReduction_152 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> + case happyOut51 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn36 + (Lam (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 happy_var_3 + )}}} + +happyReduce_153 = happySpecReduce_1 30# happyReduction_153 +happyReduction_153 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn36 + (happy_var_1 + )} + +happyReduce_154 = happyReduce 4# 30# happyReduction_154 +happyReduction_154 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwLet happy_var_1) -> + case happyOut142 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> + case happyOut32 happy_x_4 of { happy_var_4 -> + happyIn36 + (Let (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_155 = happySpecReduce_1 30# happyReduction_155 +happyReduction_155 happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn36 + (happy_var_1 + )} + +happyReduce_156 = happyReduce 4# 30# happyReduction_156 +happyReduction_156 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteGoal happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> + case happyOut32 happy_x_4 of { happy_var_4 -> + happyIn36 + (QuoteGoal (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_157 = happyReduce 4# 30# happyReduction_157 +happyReduction_157 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteContext happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokKeyword KwIn happy_var_3) -> + case happyOut32 happy_x_4 of { happy_var_4 -> + happyIn36 + (QuoteContext (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_158 = happySpecReduce_2 30# happyReduction_158 +happyReduction_158 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> + case happyOut38 happy_x_2 of { happy_var_2 -> + happyIn36 + (Tactic (getRange (happy_var_1, happy_var_2)) (RawApp (getRange happy_var_2) happy_var_2) [] + )}} + +happyReduce_159 = happyReduce 4# 30# happyReduction_159 +happyReduction_159 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwTactic happy_var_1) -> + case happyOut38 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymBar happy_var_3) -> + case happyOut34 happy_x_4 of { happy_var_4 -> + happyIn36 + (Tactic (getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4)) (RawApp (getRange happy_var_2) happy_var_2) happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_160 = happyReduce 4# 31# happyReduction_160 +happyReduction_160 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> + case happyOut58 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> + happyIn37 + (ExtendedLam (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) (reverse happy_var_3) + ) `HappyStk` happyRest}}}} + +happyReduce_161 = happyMonadReduce 2# 31# happyReduction_161 +happyReduction_161 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymLambda happy_var_1) -> + case happyOut52 happy_x_2 of { happy_var_2 -> + ( case happy_var_2 of + Left (bs, h) -> if null bs then return $ AbsurdLam r h else + return $ Lam r bs (AbsurdLam r h) + where r = fuseRange happy_var_1 bs + Right es -> do -- it is of the form @\ { p1 ... () }@ + p <- exprToLHS (RawApp (getRange es) es); + return $ ExtendedLam (fuseRange happy_var_1 es) + [(p [] [], AbsurdRHS, NoWhere)])}} + ) (\r -> happyReturn (happyIn37 r)) + +happyReduce_162 = happySpecReduce_1 32# happyReduction_162 +happyReduction_162 happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn38 + ([happy_var_1] + )} + +happyReduce_163 = happySpecReduce_2 32# happyReduction_163 +happyReduction_163 happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_2 of { happy_var_2 -> + happyIn38 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_164 = happySpecReduce_3 33# happyReduction_164 +happyReduction_164 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> + case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymCloseBrace happy_var_3) -> + happyIn39 + (HiddenArg (getRange (happy_var_1,happy_var_2,happy_var_3)) (maybeNamed happy_var_2) + )}}} + +happyReduce_165 = happySpecReduce_2 33# happyReduction_165 +happyReduction_165 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymCloseBrace happy_var_2) -> + happyIn39 + (let r = fuseRange happy_var_1 happy_var_2 in HiddenArg r $ unnamed $ Absurd r + )}} + +happyReduce_166 = happySpecReduce_1 34# happyReduction_166 +happyReduction_166 happy_x_1 + = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn40 + (Ident happy_var_1 + )} + +happyReduce_167 = happySpecReduce_1 34# happyReduction_167 +happyReduction_167 happy_x_1 + = case happyOutTok happy_x_1 of { (TokLiteral happy_var_1) -> + happyIn40 + (Lit happy_var_1 + )} + +happyReduce_168 = happySpecReduce_1 34# happyReduction_168 +happyReduction_168 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymQuestionMark happy_var_1) -> + happyIn40 + (QuestionMark (getRange happy_var_1) Nothing + )} + +happyReduce_169 = happySpecReduce_1 34# happyReduction_169 +happyReduction_169 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> + happyIn40 + (Underscore (getRange happy_var_1) Nothing + )} + +happyReduce_170 = happySpecReduce_1 34# happyReduction_170 +happyReduction_170 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwProp happy_var_1) -> + happyIn40 + (Prop (getRange happy_var_1) + )} + +happyReduce_171 = happySpecReduce_1 34# happyReduction_171 +happyReduction_171 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwSet happy_var_1) -> + happyIn40 + (Set (getRange happy_var_1) + )} + +happyReduce_172 = happySpecReduce_1 34# happyReduction_172 +happyReduction_172 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwQuote happy_var_1) -> + happyIn40 + (Quote (getRange happy_var_1) + )} + +happyReduce_173 = happySpecReduce_1 34# happyReduction_173 +happyReduction_173 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwQuoteTerm happy_var_1) -> + happyIn40 + (QuoteTerm (getRange happy_var_1) + )} + +happyReduce_174 = happySpecReduce_1 34# happyReduction_174 +happyReduction_174 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwUnquote happy_var_1) -> + happyIn40 + (Unquote (getRange happy_var_1) + )} + +happyReduce_175 = happySpecReduce_1 34# happyReduction_175 +happyReduction_175 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSetN happy_var_1) -> + happyIn40 + (SetN (getRange (fst happy_var_1)) (snd happy_var_1) + )} + +happyReduce_176 = happySpecReduce_3 34# happyReduction_176 +happyReduction_176 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> + case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut17 happy_x_3 of { happy_var_3 -> + happyIn40 + (InstanceArg (getRange (happy_var_1,happy_var_2,happy_var_3)) + (maybeNamed happy_var_2) + )}}} + +happyReduce_177 = happySpecReduce_3 34# happyReduction_177 +happyReduction_177 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> + case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> + happyIn40 + (Paren (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 + )}}} + +happyReduce_178 = happySpecReduce_2 34# happyReduction_178 +happyReduction_178 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymCloseParen happy_var_2) -> + happyIn40 + (Absurd (fuseRange happy_var_1 happy_var_2) + )}} + +happyReduce_179 = happySpecReduce_2 34# happyReduction_179 +happyReduction_179 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn40 + (let r = fuseRange happy_var_1 happy_var_2 in InstanceArg r $ unnamed $ Absurd r + )}} + +happyReduce_180 = happySpecReduce_3 34# happyReduction_180 +happyReduction_180 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokSymbol SymAs happy_var_2) -> + case happyOut41 happy_x_3 of { happy_var_3 -> + happyIn40 + (As (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_1 happy_var_3 + )}}} + +happyReduce_181 = happySpecReduce_2 34# happyReduction_181 +happyReduction_181 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDot happy_var_1) -> + case happyOut41 happy_x_2 of { happy_var_2 -> + happyIn40 + (Dot (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_182 = happyReduce 4# 34# happyReduction_182 +happyReduction_182 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> + case happyOut42 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> + happyIn40 + (Rec (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 + ) `HappyStk` happyRest}}}} + +happyReduce_183 = happyReduce 5# 34# happyReduction_183 +happyReduction_183 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> + case happyOut40 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymOpenBrace happy_var_3) -> + case happyOut42 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymCloseBrace happy_var_5) -> + happyIn40 + (RecUpdate (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}}}} + +happyReduce_184 = happySpecReduce_1 35# happyReduction_184 +happyReduction_184 happy_x_1 + = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn41 + (happy_var_1 + )} + +happyReduce_185 = happySpecReduce_1 35# happyReduction_185 +happyReduction_185 happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn41 + (happy_var_1 + )} + +happyReduce_186 = happySpecReduce_0 36# happyReduction_186 +happyReduction_186 = happyIn42 + ([] + ) + +happyReduce_187 = happySpecReduce_1 36# happyReduction_187 +happyReduction_187 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn42 + (happy_var_1 + )} + +happyReduce_188 = happySpecReduce_1 37# happyReduction_188 +happyReduction_188 happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + happyIn43 + ([happy_var_1] + )} + +happyReduce_189 = happySpecReduce_3 37# happyReduction_189 +happyReduction_189 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_3 of { happy_var_3 -> + happyIn43 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_190 = happySpecReduce_3 38# happyReduction_190 +happyReduction_190 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn44 + ((happy_var_1, happy_var_3) + )}} + +happyReduce_191 = happySpecReduce_2 39# happyReduction_191 +happyReduction_191 happy_x_2 + happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn45 + (happy_var_1 + )} + +happyReduce_192 = happySpecReduce_1 40# happyReduction_192 +happyReduction_192 happy_x_1 + = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn46 + ({-TeleBind-} happy_var_1 + )} + +happyReduce_193 = happySpecReduce_2 41# happyReduction_193 +happyReduction_193 happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn47 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_194 = happySpecReduce_1 41# happyReduction_194 +happyReduction_194 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn47 + ([happy_var_1] + )} + +happyReduce_195 = happyReduce 4# 42# happyReduction_195 +happyReduction_195 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> + case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> + happyIn48 + (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $ + setRelevance Irrelevant happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_196 = happyReduce 4# 42# happyReduction_196 +happyReduction_196 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> + happyIn48 + (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $ + setHiding Hidden $ + setRelevance Irrelevant happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_197 = happyReduce 4# 42# happyReduction_197 +happyReduction_197 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut17 happy_x_4 of { happy_var_4 -> + happyIn48 + (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $ + setHiding Instance $ + setRelevance Irrelevant happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_198 = happyReduce 4# 42# happyReduction_198 +happyReduction_198 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> + case happyOut50 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> + happyIn48 + (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $ + setRelevance NonStrict happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_199 = happyReduce 4# 42# happyReduction_199 +happyReduction_199 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokSymbol SymOpenBrace happy_var_2) -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseBrace happy_var_4) -> + happyIn48 + (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $ + setHiding Hidden $ + setRelevance NonStrict happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_200 = happyReduce 4# 42# happyReduction_200 +happyReduction_200 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut17 happy_x_4 of { happy_var_4 -> + happyIn48 + (setRange (getRange (happy_var_2,happy_var_3,happy_var_4)) $ + setHiding Instance $ + setRelevance NonStrict happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_201 = happySpecReduce_3 42# happyReduction_201 +happyReduction_201 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> + case happyOut50 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> + happyIn48 + (setRange (getRange (happy_var_1,happy_var_2,happy_var_3)) happy_var_2 + )}}} + +happyReduce_202 = happySpecReduce_3 42# happyReduction_202 +happyReduction_202 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymDoubleOpenBrace happy_var_1) -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut17 happy_x_3 of { happy_var_3 -> + happyIn48 + (setRange (getRange (happy_var_1,happy_var_2,happy_var_3)) $ + setHiding Instance happy_var_2 + )}}} + +happyReduce_203 = happySpecReduce_3 42# happyReduction_203 +happyReduction_203 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenBrace happy_var_1) -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymCloseBrace happy_var_3) -> + happyIn48 + (setRange (getRange (happy_var_1,happy_var_2,happy_var_3)) $ + setHiding Hidden happy_var_2 + )}}} + +happyReduce_204 = happySpecReduce_3 42# happyReduction_204 +happyReduction_204 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> + case happyOut109 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> + happyIn48 + (tLet (getRange (happy_var_1,happy_var_3)) happy_var_2 + )}}} + +happyReduce_205 = happyReduce 4# 42# happyReduction_205 +happyReduction_205 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenParen happy_var_1) -> + case happyOut142 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> + happyIn48 + (tLet (getRange (happy_var_1,happy_var_4)) happy_var_3 + ) `HappyStk` happyRest}}} + +happyReduce_206 = happySpecReduce_3 43# happyReduction_206 +happyReduction_206 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut25 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokSymbol SymColon happy_var_2) -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn49 + (let r = getRange (happy_var_1,happy_var_2,happy_var_3) -- the range is approximate only for TypedBindings + in TypedBindings r $ defaultArg $ TBind r (map (pure . mkBoundName_) happy_var_1) happy_var_3 + )}}} + +happyReduce_207 = happySpecReduce_3 44# happyReduction_207 +happyReduction_207 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokSymbol SymColon happy_var_2) -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn50 + (let r = getRange (happy_var_1,happy_var_2,happy_var_3) -- the range is approximate only for TypedBindings + in TypedBindings r $ defaultArg $ TBind r (map (fmap mkBoundName_) happy_var_1) happy_var_3 + )}}} + +happyReduce_208 = happyMonadReduce 2# 45# happyReduction_208 +happyReduction_208 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut53 happy_x_1 of { happy_var_1 -> + ( + case reverse happy_var_1 of + Left _ : _ -> parseError "Absurd lambda cannot have a body." + _ : _ -> return [ b | Right b <- happy_var_1 ] + [] -> parsePanic "Empty LamBinds")} + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_209 = happyMonadReduce 1# 46# happyReduction_209 +happyReduction_209 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut54 happy_x_1 of { happy_var_1 -> + ( + case happy_var_1 of + Left lb -> case reverse lb of + Right _ : _ -> parseError "Missing body for lambda" + Left h : _ -> return $ Left ([ b | Right b <- init lb], h) + _ -> parseError "Unsupported variant of lambda" + Right es -> return $ Right es)} + ) (\r -> happyReturn (happyIn52 r)) + +happyReduce_210 = happySpecReduce_2 47# happyReduction_210 +happyReduction_210 happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn53 + (map Right happy_var_1 ++ happy_var_2 + )}} + +happyReduce_211 = happySpecReduce_2 47# happyReduction_211 +happyReduction_211 happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn53 + (Right (DomainFull happy_var_1) : happy_var_2 + )}} + +happyReduce_212 = happySpecReduce_1 47# happyReduction_212 +happyReduction_212 happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn53 + (map Right happy_var_1 + )} + +happyReduce_213 = happySpecReduce_1 47# happyReduction_213 +happyReduction_213 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn53 + ([Right $ DomainFull happy_var_1] + )} + +happyReduce_214 = happySpecReduce_2 47# happyReduction_214 +happyReduction_214 happy_x_2 + happy_x_1 + = happyIn53 + ([Left NotHidden] + ) + +happyReduce_215 = happySpecReduce_2 47# happyReduction_215 +happyReduction_215 happy_x_2 + happy_x_1 + = happyIn53 + ([Left Hidden] + ) + +happyReduce_216 = happySpecReduce_2 47# happyReduction_216 +happyReduction_216 happy_x_2 + happy_x_1 + = happyIn53 + ([Left Instance] + ) + +happyReduce_217 = happySpecReduce_2 48# happyReduction_217 +happyReduction_217 happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn54 + (Left $ map Right happy_var_1 ++ happy_var_2 + )}} + +happyReduce_218 = happySpecReduce_2 48# happyReduction_218 +happyReduction_218 happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn54 + (Left $ Right (DomainFull happy_var_1) : happy_var_2 + )}} + +happyReduce_219 = happySpecReduce_1 48# happyReduction_219 +happyReduction_219 happy_x_1 + = case happyOut63 happy_x_1 of { happy_var_1 -> + happyIn54 + (case happy_var_1 of + Left lb -> Left $ map Right lb + Right es -> Right es + )} + +happyReduce_220 = happySpecReduce_1 48# happyReduction_220 +happyReduction_220 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn54 + (Left [Right $ DomainFull happy_var_1] + )} + +happyReduce_221 = happySpecReduce_2 48# happyReduction_221 +happyReduction_221 happy_x_2 + happy_x_1 + = happyIn54 + (Left [Left NotHidden] + ) + +happyReduce_222 = happySpecReduce_2 48# happyReduction_222 +happyReduction_222 happy_x_2 + happy_x_1 + = happyIn54 + (Left [Left Hidden] + ) + +happyReduce_223 = happySpecReduce_2 48# happyReduction_223 +happyReduction_223 happy_x_2 + happy_x_1 + = happyIn54 + (Left [Left Instance] + ) + +happyReduce_224 = happyMonadReduce 3# 49# happyReduction_224 +happyReduction_224 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + ( do + p <- exprToLHS (RawApp (getRange happy_var_1) happy_var_1) ; + return (p [] [], RHS happy_var_3, NoWhere))}} + ) (\r -> happyReturn (happyIn55 r)) + +happyReduce_225 = happyMonadReduce 1# 50# happyReduction_225 +happyReduction_225 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut35 happy_x_1 of { happy_var_1 -> + ( do + p <- exprToLHS (RawApp (getRange happy_var_1) happy_var_1); + return (p [] [], AbsurdRHS, NoWhere))} + ) (\r -> happyReturn (happyIn56 r)) + +happyReduce_226 = happySpecReduce_1 51# happyReduction_226 +happyReduction_226 happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn57 + (happy_var_1 + )} + +happyReduce_227 = happySpecReduce_1 51# happyReduction_227 +happyReduction_227 happy_x_1 + = case happyOut56 happy_x_1 of { happy_var_1 -> + happyIn57 + (happy_var_1 + )} + +happyReduce_228 = happySpecReduce_3 52# happyReduction_228 +happyReduction_228 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut58 happy_x_1 of { happy_var_1 -> + case happyOut57 happy_x_3 of { happy_var_3 -> + happyIn58 + (happy_var_3 : happy_var_1 + )}} + +happyReduce_229 = happySpecReduce_3 52# happyReduction_229 +happyReduction_229 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut56 happy_x_1 of { happy_var_1 -> + case happyOut57 happy_x_3 of { happy_var_3 -> + happyIn58 + ([happy_var_3, happy_var_1] + )}} + +happyReduce_230 = happySpecReduce_1 52# happyReduction_230 +happyReduction_230 happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn58 + ([happy_var_1] + )} + +happyReduce_231 = happySpecReduce_2 53# happyReduction_231 +happyReduction_231 happy_x_2 + happy_x_1 + = case happyOut60 happy_x_1 of { happy_var_1 -> + happyIn59 + (happy_var_1 + )} + +happyReduce_232 = happySpecReduce_2 54# happyReduction_232 +happyReduction_232 happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_2 of { happy_var_2 -> + happyIn60 + (happy_var_1 ++ happy_var_2 + )}} + +happyReduce_233 = happySpecReduce_2 54# happyReduction_233 +happyReduction_233 happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_2 of { happy_var_2 -> + happyIn60 + (DomainFull happy_var_1 : happy_var_2 + )}} + +happyReduce_234 = happySpecReduce_1 54# happyReduction_234 +happyReduction_234 happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn60 + (happy_var_1 + )} + +happyReduce_235 = happySpecReduce_1 54# happyReduction_235 +happyReduction_235 happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + happyIn60 + ([DomainFull happy_var_1] + )} + +happyReduce_236 = happySpecReduce_2 55# happyReduction_236 +happyReduction_236 happy_x_2 + happy_x_1 + = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut61 happy_x_2 of { happy_var_2 -> + happyIn61 + (happy_var_1 ++ happy_var_2 + )}} + +happyReduce_237 = happySpecReduce_2 55# happyReduction_237 +happyReduction_237 happy_x_2 + happy_x_1 + = case happyOut48 happy_x_1 of { happy_var_1 -> + case happyOut61 happy_x_2 of { happy_var_2 -> + happyIn61 + (DomainFull happy_var_1 : happy_var_2 + )}} + +happyReduce_238 = happySpecReduce_0 55# happyReduction_238 +happyReduction_238 = happyIn61 + ([] + ) + +happyReduce_239 = happySpecReduce_1 56# happyReduction_239 +happyReduction_239 happy_x_1 + = case happyOut63 happy_x_1 of { happy_var_1 -> + happyIn62 + (case happy_var_1 of + Left lbs -> lbs + Right _ -> fail "expected sequence of bound identifiers, not absurd pattern" + )} + +happyReduce_240 = happySpecReduce_1 57# happyReduction_240 +happyReduction_240 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn63 + (Left [DomainFree defaultArgInfo $ mkBoundName_ happy_var_1] + )} + +happyReduce_241 = happySpecReduce_2 57# happyReduction_241 +happyReduction_241 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn63 + (Left [DomainFree (setRelevance Irrelevant $ defaultArgInfo) $ mkBoundName_ happy_var_2] + )} + +happyReduce_242 = happySpecReduce_2 57# happyReduction_242 +happyReduction_242 happy_x_2 + happy_x_1 + = case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn63 + (Left [DomainFree (setRelevance NonStrict $ defaultArgInfo) $ mkBoundName_ happy_var_2] + )} + +happyReduce_243 = happySpecReduce_3 57# happyReduction_243 +happyReduction_243 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut26 happy_x_2 of { happy_var_2 -> + happyIn63 + (either (Left . map (DomainFree (setHiding Hidden $ defaultArgInfo) . mkBoundName_)) Right happy_var_2 + )} + +happyReduce_244 = happySpecReduce_3 57# happyReduction_244 +happyReduction_244 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut25 happy_x_2 of { happy_var_2 -> + happyIn63 + (Left $ map (DomainFree (setHiding Instance $ defaultArgInfo) . mkBoundName_) happy_var_2 + )} + +happyReduce_245 = happyReduce 4# 57# happyReduction_245 +happyReduction_245 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_3 of { happy_var_3 -> + happyIn63 + (Left $ map (DomainFree (setHiding Hidden $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_246 = happyReduce 4# 57# happyReduction_246 +happyReduction_246 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_3 of { happy_var_3 -> + happyIn63 + (Left $ map (DomainFree (setHiding Instance $ setRelevance Irrelevant $ defaultArgInfo) . mkBoundName_) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_247 = happyReduce 4# 57# happyReduction_247 +happyReduction_247 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_3 of { happy_var_3 -> + happyIn63 + (Left $ map (DomainFree (setHiding Hidden $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_248 = happyReduce 4# 57# happyReduction_248 +happyReduction_248 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut25 happy_x_3 of { happy_var_3 -> + happyIn63 + (Left $ map (DomainFree (setHiding Instance $ setRelevance NonStrict $ defaultArgInfo) . mkBoundName_) happy_var_3 + ) `HappyStk` happyRest} + +happyReduce_249 = happyMonadReduce 1# 58# happyReduction_249 +happyReduction_249 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut65 happy_x_1 of { happy_var_1 -> + ( mergeImportDirectives happy_var_1)} + ) (\r -> happyReturn (happyIn64 r)) + +happyReduce_250 = happySpecReduce_2 59# happyReduction_250 +happyReduction_250 happy_x_2 + happy_x_1 + = case happyOut66 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + happyIn65 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_251 = happySpecReduce_0 59# happyReduction_251 +happyReduction_251 = happyIn65 + ([] + ) + +happyReduce_252 = happySpecReduce_1 60# happyReduction_252 +happyReduction_252 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPublic happy_var_1) -> + happyIn66 + (defaultImportDir { importDirRange = getRange happy_var_1, publicOpen = True } + )} + +happyReduce_253 = happySpecReduce_1 60# happyReduction_253 +happyReduction_253 happy_x_1 + = case happyOut67 happy_x_1 of { happy_var_1 -> + happyIn66 + (defaultImportDir { importDirRange = snd happy_var_1, usingOrHiding = fst happy_var_1 } + )} + +happyReduce_254 = happySpecReduce_1 60# happyReduction_254 +happyReduction_254 happy_x_1 + = case happyOut68 happy_x_1 of { happy_var_1 -> + happyIn66 + (defaultImportDir { importDirRange = snd happy_var_1, renaming = fst happy_var_1 } + )} + +happyReduce_255 = happyReduce 4# 61# happyReduction_255 +happyReduction_255 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwUsing happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> + case happyOut73 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> + happyIn67 + ((Using happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_256 = happyReduce 4# 61# happyReduction_256 +happyReduction_256 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwHiding happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> + case happyOut73 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> + happyIn67 + ((Hiding happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_257 = happyReduce 4# 62# happyReduction_257 +happyReduction_257 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> + case happyOut69 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymCloseParen happy_var_4) -> + happyIn68 + ((happy_var_3 , getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_258 = happySpecReduce_3 62# happyReduction_258 +happyReduction_258 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwRenaming happy_var_1) -> + case happyOutTok happy_x_2 of { (TokSymbol SymOpenParen happy_var_2) -> + case happyOutTok happy_x_3 of { (TokSymbol SymCloseParen happy_var_3) -> + happyIn68 + (([] , getRange (happy_var_1,happy_var_2,happy_var_3)) + )}}} + +happyReduce_259 = happySpecReduce_3 63# happyReduction_259 +happyReduction_259 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut70 happy_x_1 of { happy_var_1 -> + case happyOut69 happy_x_3 of { happy_var_3 -> + happyIn69 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_260 = happySpecReduce_1 63# happyReduction_260 +happyReduction_260 happy_x_1 + = case happyOut70 happy_x_1 of { happy_var_1 -> + happyIn69 + ([happy_var_1] + )} + +happyReduce_261 = happySpecReduce_3 64# happyReduction_261 +happyReduction_261 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokKeyword KwTo happy_var_2) -> + case happyOut15 happy_x_3 of { happy_var_3 -> + happyIn70 + (Renaming happy_var_1 happy_var_3 (getRange happy_var_2) + )}}} + +happyReduce_262 = happySpecReduce_2 65# happyReduction_262 +happyReduction_262 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn71 + (ImportedName happy_var_2 + )} + +happyReduce_263 = happySpecReduce_3 65# happyReduction_263 +happyReduction_263 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut15 happy_x_3 of { happy_var_3 -> + happyIn71 + (ImportedModule happy_var_3 + )} + +happyReduce_264 = happySpecReduce_1 66# happyReduction_264 +happyReduction_264 happy_x_1 + = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn72 + (ImportedName happy_var_1 + )} + +happyReduce_265 = happySpecReduce_2 66# happyReduction_265 +happyReduction_265 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn72 + (ImportedModule happy_var_2 + )} + +happyReduce_266 = happySpecReduce_0 67# happyReduction_266 +happyReduction_266 = happyIn73 + ([] + ) + +happyReduce_267 = happySpecReduce_1 67# happyReduction_267 +happyReduction_267 happy_x_1 + = case happyOut74 happy_x_1 of { happy_var_1 -> + happyIn73 + (happy_var_1 + )} + +happyReduce_268 = happySpecReduce_1 68# happyReduction_268 +happyReduction_268 happy_x_1 + = case happyOut72 happy_x_1 of { happy_var_1 -> + happyIn74 + ([happy_var_1] + )} + +happyReduce_269 = happySpecReduce_3 68# happyReduction_269 +happyReduction_269 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut72 happy_x_1 of { happy_var_1 -> + case happyOut74 happy_x_3 of { happy_var_3 -> + happyIn74 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_270 = happyMonadReduce 3# 69# happyReduction_270 +happyReduction_270 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut78 happy_x_2 of { happy_var_2 -> + case happyOut77 happy_x_3 of { happy_var_3 -> + ( exprToLHS happy_var_1 >>= \p -> return (p happy_var_2 happy_var_3))}}} + ) (\r -> happyReturn (happyIn75 r)) + +happyReduce_271 = happyReduce 4# 69# happyReduction_271 +happyReduction_271 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymEllipsis happy_var_1) -> + case happyOut76 happy_x_2 of { happy_var_2 -> + case happyOut78 happy_x_3 of { happy_var_3 -> + case happyOut77 happy_x_4 of { happy_var_4 -> + happyIn75 + (Ellipsis (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_2 happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}}} + +happyReduce_272 = happySpecReduce_0 70# happyReduction_272 +happyReduction_272 = happyIn76 + ([] + ) + +happyReduce_273 = happyMonadReduce 3# 70# happyReduction_273 +happyReduction_273 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut38 happy_x_2 of { happy_var_2 -> + case happyOut76 happy_x_3 of { happy_var_3 -> + ( exprToPattern (RawApp (getRange happy_var_2) happy_var_2) >>= \p -> + return (p : happy_var_3))}} + ) (\r -> happyReturn (happyIn76 r)) + +happyReduce_274 = happySpecReduce_0 71# happyReduction_274 +happyReduction_274 = happyIn77 + ([] + ) + +happyReduce_275 = happySpecReduce_2 71# happyReduction_275 +happyReduction_275 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn77 + (case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] } + )} + +happyReduce_276 = happySpecReduce_0 72# happyReduction_276 +happyReduction_276 = happyIn78 + ([] + ) + +happyReduce_277 = happySpecReduce_2 72# happyReduction_277 +happyReduction_277 happy_x_2 + happy_x_1 + = case happyOut33 happy_x_2 of { happy_var_2 -> + happyIn78 + (case happy_var_2 of { WithApp _ e es -> e : es; e -> [e] } + )} + +happyReduce_278 = happySpecReduce_0 73# happyReduction_278 +happyReduction_278 = happyIn79 + (NoWhere + ) + +happyReduce_279 = happySpecReduce_2 73# happyReduction_279 +happyReduction_279 happy_x_2 + happy_x_1 + = case happyOut143 happy_x_2 of { happy_var_2 -> + happyIn79 + (AnyWhere happy_var_2 + )} + +happyReduce_280 = happyReduce 4# 73# happyReduction_280 +happyReduction_280 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut143 happy_x_4 of { happy_var_4 -> + happyIn79 + (SomeWhere happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_281 = happyReduce 4# 73# happyReduction_281 +happyReduction_281 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOut143 happy_x_4 of { happy_var_4 -> + happyIn79 + (SomeWhere happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_282 = happySpecReduce_1 74# happyReduction_282 +happyReduction_282 happy_x_1 + = case happyOut91 happy_x_1 of { happy_var_1 -> + happyIn80 + (happy_var_1 + )} + +happyReduce_283 = happySpecReduce_1 74# happyReduction_283 +happyReduction_283 happy_x_1 + = case happyOut83 happy_x_1 of { happy_var_1 -> + happyIn80 + (happy_var_1 + )} + +happyReduce_284 = happySpecReduce_1 74# happyReduction_284 +happyReduction_284 happy_x_1 + = case happyOut85 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_285 = happySpecReduce_1 74# happyReduction_285 +happyReduction_285 happy_x_1 + = case happyOut86 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_286 = happySpecReduce_1 74# happyReduction_286 +happyReduction_286 happy_x_1 + = case happyOut87 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_287 = happySpecReduce_1 74# happyReduction_287 +happyReduction_287 happy_x_1 + = case happyOut88 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_288 = happySpecReduce_1 74# happyReduction_288 +happyReduction_288 happy_x_1 + = case happyOut90 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_289 = happySpecReduce_1 74# happyReduction_289 +happyReduction_289 happy_x_1 + = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_290 = happySpecReduce_1 74# happyReduction_290 +happyReduction_290 happy_x_1 + = case happyOut93 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_291 = happySpecReduce_1 74# happyReduction_291 +happyReduction_291 happy_x_1 + = case happyOut94 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_292 = happySpecReduce_1 74# happyReduction_292 +happyReduction_292 happy_x_1 + = case happyOut95 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_293 = happySpecReduce_1 74# happyReduction_293 +happyReduction_293 happy_x_1 + = case happyOut96 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_294 = happySpecReduce_1 74# happyReduction_294 +happyReduction_294 happy_x_1 + = case happyOut97 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_295 = happySpecReduce_1 74# happyReduction_295 +happyReduction_295 happy_x_1 + = case happyOut109 happy_x_1 of { happy_var_1 -> + happyIn80 + (happy_var_1 + )} + +happyReduce_296 = happySpecReduce_1 74# happyReduction_296 +happyReduction_296 happy_x_1 + = case happyOut112 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_297 = happySpecReduce_1 74# happyReduction_297 +happyReduction_297 happy_x_1 + = case happyOut113 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_298 = happySpecReduce_1 74# happyReduction_298 +happyReduction_298 happy_x_1 + = case happyOut116 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_299 = happySpecReduce_1 74# happyReduction_299 +happyReduction_299 happy_x_1 + = case happyOut99 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_300 = happySpecReduce_1 74# happyReduction_300 +happyReduction_300 happy_x_1 + = case happyOut100 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_301 = happySpecReduce_1 74# happyReduction_301 +happyReduction_301 happy_x_1 + = case happyOut98 happy_x_1 of { happy_var_1 -> + happyIn80 + ([happy_var_1] + )} + +happyReduce_302 = happySpecReduce_3 75# happyReduction_302 +happyReduction_302 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn81 + (map (\ x -> TypeSig defaultArgInfo x happy_var_3) happy_var_1 + )}} + +happyReduce_303 = happySpecReduce_3 76# happyReduction_303 +happyReduction_303 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn82 + (map (fmap (\ x -> TypeSig defaultArgInfo x happy_var_3)) happy_var_1 + )}} + +happyReduce_304 = happyMonadReduce 3# 77# happyReduction_304 +happyReduction_304 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut75 happy_x_1 of { happy_var_1 -> + case happyOut84 happy_x_2 of { happy_var_2 -> + case happyOut79 happy_x_3 of { happy_var_3 -> + ( funClauseOrTypeSigs happy_var_1 happy_var_2 happy_var_3)}}} + ) (\r -> happyReturn (happyIn83 r)) + +happyReduce_305 = happySpecReduce_2 78# happyReduction_305 +happyReduction_305 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn84 + (JustRHS (RHS happy_var_2) + )} + +happyReduce_306 = happySpecReduce_2 78# happyReduction_306 +happyReduction_306 happy_x_2 + happy_x_1 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn84 + (TypeSigsRHS happy_var_2 + )} + +happyReduce_307 = happySpecReduce_0 78# happyReduction_307 +happyReduction_307 = happyIn84 + (JustRHS AbsurdRHS + ) + +happyReduce_308 = happyReduce 7# 79# happyReduction_308 +happyReduction_308 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> + case happyOut32 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> + case happyOut139 happy_x_7 of { happy_var_7 -> + happyIn85 + (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) Inductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7 + ) `HappyStk` happyRest}}}}}}} + +happyReduce_309 = happyReduce 7# 79# happyReduction_309 +happyReduction_309 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> + case happyOut32 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> + case happyOut139 happy_x_7 of { happy_var_7 -> + happyIn85 + (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) CoInductive happy_var_2 happy_var_3 (Just happy_var_5) happy_var_7 + ) `HappyStk` happyRest}}}}}}} + +happyReduce_310 = happyReduce 5# 79# happyReduction_310 +happyReduction_310 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> + case happyOut139 happy_x_5 of { happy_var_5 -> + happyIn85 + (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 Nothing happy_var_5 + ) `HappyStk` happyRest}}}}} + +happyReduce_311 = happyReduce 5# 79# happyReduction_311 +happyReduction_311 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwCoData happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> + case happyOut139 happy_x_5 of { happy_var_5 -> + happyIn85 + (Data (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) CoInductive happy_var_2 happy_var_3 Nothing happy_var_5 + ) `HappyStk` happyRest}}}}} + +happyReduce_312 = happyReduce 5# 80# happyReduction_312 +happyReduction_312 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwData happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> + case happyOut32 happy_x_5 of { happy_var_5 -> + happyIn86 + (DataSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) Inductive happy_var_2 happy_var_3 happy_var_5 + ) `HappyStk` happyRest}}}}} + +happyReduce_313 = happyMonadReduce 7# 81# happyReduction_313 +happyReduction_313 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> + case happyOut40 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> + case happyOut32 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { (TokKeyword KwWhere happy_var_6) -> + case happyOut140 happy_x_7 of { happy_var_7 -> + ( exprToName happy_var_2 >>= \ n -> return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5,happy_var_6,happy_var_7)) n (fst3 happy_var_7) (snd3 happy_var_7) happy_var_3 (Just happy_var_5) (thd3 happy_var_7))}}}}}}} + ) (\r -> happyReturn (happyIn87 r)) + +happyReduce_314 = happyMonadReduce 5# 81# happyReduction_314 +happyReduction_314 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> + case happyOut40 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> + case happyOut140 happy_x_5 of { happy_var_5 -> + ( exprToName happy_var_2 >>= \ n -> return $ Record (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n (fst3 happy_var_5) (snd3 happy_var_5) happy_var_3 Nothing (thd3 happy_var_5))}}}}} + ) (\r -> happyReturn (happyIn87 r)) + +happyReduce_315 = happyMonadReduce 5# 82# happyReduction_315 +happyReduction_315 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwRecord happy_var_1) -> + case happyOut40 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymColon happy_var_4) -> + case happyOut32 happy_x_5 of { happy_var_5 -> + ( exprToName happy_var_2 >>= \ n -> return $ RecordSig (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) n happy_var_3 happy_var_5)}}}}} + ) (\r -> happyReturn (happyIn88 r)) + +happyReduce_316 = happySpecReduce_2 83# happyReduction_316 +happyReduction_316 happy_x_2 + happy_x_1 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn89 + (happy_var_2 + )} + +happyReduce_317 = happySpecReduce_3 84# happyReduction_317 +happyReduction_317 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInfix happy_var_1) -> + case happyOut14 happy_x_2 of { happy_var_2 -> + case happyOut24 happy_x_3 of { happy_var_3 -> + happyIn90 + (Infix (Fixity (getRange (happy_var_1,happy_var_3)) happy_var_2 NonAssoc) happy_var_3 + )}}} + +happyReduce_318 = happySpecReduce_3 84# happyReduction_318 +happyReduction_318 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInfixL happy_var_1) -> + case happyOut14 happy_x_2 of { happy_var_2 -> + case happyOut24 happy_x_3 of { happy_var_3 -> + happyIn90 + (Infix (Fixity (getRange (happy_var_1,happy_var_3)) happy_var_2 LeftAssoc) happy_var_3 + )}}} + +happyReduce_319 = happySpecReduce_3 84# happyReduction_319 +happyReduction_319 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInfixR happy_var_1) -> + case happyOut14 happy_x_2 of { happy_var_2 -> + case happyOut24 happy_x_3 of { happy_var_3 -> + happyIn90 + (Infix (Fixity (getRange (happy_var_1,happy_var_3)) happy_var_2 RightAssoc) happy_var_3 + )}}} + +happyReduce_320 = happySpecReduce_2 85# happyReduction_320 +happyReduction_320 happy_x_2 + happy_x_1 + = case happyOut137 happy_x_2 of { happy_var_2 -> + happyIn91 + (let toField (Common.Arg info (TypeSig _ x t)) = Field x (Common.Arg info t) in map toField happy_var_2 + )} + +happyReduce_321 = happySpecReduce_2 86# happyReduction_321 +happyReduction_321 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwMutual happy_var_1) -> + case happyOut142 happy_x_2 of { happy_var_2 -> + happyIn92 + (Mutual (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_322 = happySpecReduce_2 87# happyReduction_322 +happyReduction_322 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwAbstract happy_var_1) -> + case happyOut142 happy_x_2 of { happy_var_2 -> + happyIn93 + (Abstract (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_323 = happySpecReduce_2 88# happyReduction_323 +happyReduction_323 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPrivate happy_var_1) -> + case happyOut142 happy_x_2 of { happy_var_2 -> + happyIn94 + (Private (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_324 = happySpecReduce_2 89# happyReduction_324 +happyReduction_324 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInstance happy_var_1) -> + case happyOut142 happy_x_2 of { happy_var_2 -> + happyIn95 + (InstanceB (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_325 = happySpecReduce_2 90# happyReduction_325 +happyReduction_325 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPostulate happy_var_1) -> + case happyOut142 happy_x_2 of { happy_var_2 -> + happyIn96 + (Postulate (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_326 = happySpecReduce_2 91# happyReduction_326 +happyReduction_326 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwPrimitive happy_var_1) -> + case happyOut135 happy_x_2 of { happy_var_2 -> + happyIn97 + (Primitive (fuseRange happy_var_1 happy_var_2) happy_var_2 + )}} + +happyReduce_327 = happyReduce 4# 92# happyReduction_327 +happyReduction_327 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwUnquoteDecl happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_4 of { happy_var_4 -> + happyIn98 + (UnquoteDecl (fuseRange happy_var_1 happy_var_4) happy_var_2 happy_var_4 + ) `HappyStk` happyRest}}} + +happyReduce_328 = happyMonadReduce 5# 93# happyReduction_328 +happyReduction_328 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut103 happy_x_3 of { happy_var_3 -> + case happyOut102 happy_x_5 of { happy_var_5 -> + ( + case happy_var_2 of + Name _ [_] -> case mkNotation happy_var_3 (map rangedThing happy_var_5) of + Left err -> parseError $ "Malformed syntax declaration: " ++ err + Right n -> return $ Syntax happy_var_2 n + _ -> parseError "Syntax declarations are allowed only for simple names (without holes)")}}} + ) (\r -> happyReturn (happyIn99 r)) + +happyReduce_329 = happyMonadReduce 5# 94# happyReduction_329 +happyReduction_329 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwPatternSyn happy_var_1) -> + case happyOut15 happy_x_2 of { happy_var_2 -> + case happyOut101 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymEqual happy_var_4) -> + case happyOut32 happy_x_5 of { happy_var_5 -> + ( do + p <- exprToPattern happy_var_5 + return (PatternSyn (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 happy_var_3 p))}}}}} + ) (\r -> happyReturn (happyIn100 r)) + +happyReduce_330 = happySpecReduce_0 95# happyReduction_330 +happyReduction_330 = happyIn101 + ([] + ) + +happyReduce_331 = happyMonadReduce 1# 95# happyReduction_331 +happyReduction_331 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut53 happy_x_1 of { happy_var_1 -> + ( patternSynArgs happy_var_1)} + ) (\r -> happyReturn (happyIn101 r)) + +happyReduce_332 = happySpecReduce_1 96# happyReduction_332 +happyReduction_332 happy_x_1 + = case happyOut107 happy_x_1 of { happy_var_1 -> + happyIn102 + ([happy_var_1] + )} + +happyReduce_333 = happySpecReduce_2 96# happyReduction_333 +happyReduction_333 happy_x_2 + happy_x_1 + = case happyOut102 happy_x_1 of { happy_var_1 -> + case happyOut107 happy_x_2 of { happy_var_2 -> + happyIn102 + (happy_var_1 ++ [happy_var_2] + )}} + +happyReduce_334 = happySpecReduce_1 97# happyReduction_334 +happyReduction_334 happy_x_1 + = case happyOut104 happy_x_1 of { happy_var_1 -> + happyIn103 + ([happy_var_1] + )} + +happyReduce_335 = happySpecReduce_2 97# happyReduction_335 +happyReduction_335 happy_x_2 + happy_x_1 + = case happyOut103 happy_x_1 of { happy_var_1 -> + case happyOut104 happy_x_2 of { happy_var_2 -> + happyIn103 + (happy_var_1 ++ [happy_var_2] + )}} + +happyReduce_336 = happySpecReduce_1 98# happyReduction_336 +happyReduction_336 happy_x_1 + = case happyOut105 happy_x_1 of { happy_var_1 -> + happyIn104 + (defaultNamedArg happy_var_1 + )} + +happyReduce_337 = happySpecReduce_3 98# happyReduction_337 +happyReduction_337 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut106 happy_x_2 of { happy_var_2 -> + happyIn104 + (setHiding Hidden $ defaultNamedArg happy_var_2 + )} + +happyReduce_338 = happySpecReduce_3 98# happyReduction_338 +happyReduction_338 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut106 happy_x_2 of { happy_var_2 -> + happyIn104 + (setHiding Instance $ defaultNamedArg happy_var_2 + )} + +happyReduce_339 = happyReduce 5# 98# happyReduction_339 +happyReduction_339 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut107 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_4 of { happy_var_4 -> + happyIn104 + (setHiding Hidden $ defaultArg $ named happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_340 = happyReduce 5# 98# happyReduction_340 +happyReduction_340 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut107 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_4 of { happy_var_4 -> + happyIn104 + (setHiding Instance $ defaultArg $ named happy_var_2 happy_var_4 + ) `HappyStk` happyRest}} + +happyReduce_341 = happySpecReduce_1 99# happyReduction_341 +happyReduction_341 happy_x_1 + = case happyOut107 happy_x_1 of { happy_var_1 -> + happyIn105 + (ExprHole (rangedThing happy_var_1) + )} + +happyReduce_342 = happyReduce 6# 99# happyReduction_342 +happyReduction_342 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut107 happy_x_3 of { happy_var_3 -> + case happyOut107 happy_x_5 of { happy_var_5 -> + happyIn105 + (LambdaHole (rangedThing happy_var_3) (rangedThing happy_var_5) + ) `HappyStk` happyRest}} + +happyReduce_343 = happySpecReduce_1 100# happyReduction_343 +happyReduction_343 happy_x_1 + = case happyOut107 happy_x_1 of { happy_var_1 -> + happyIn106 + (ExprHole (rangedThing happy_var_1) + )} + +happyReduce_344 = happyReduce 4# 100# happyReduction_344 +happyReduction_344 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut107 happy_x_2 of { happy_var_2 -> + case happyOut107 happy_x_4 of { happy_var_4 -> + happyIn106 + (LambdaHole (rangedThing happy_var_2) (rangedThing happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_345 = happySpecReduce_1 101# happyReduction_345 +happyReduction_345 happy_x_1 + = case happyOutTok happy_x_1 of { (TokId happy_var_1) -> + happyIn107 + (Ranged (getRange $ fst happy_var_1) (stringToRawName $ snd happy_var_1) + )} + +happyReduce_346 = happySpecReduce_1 102# happyReduction_346 +happyReduction_346 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> + happyIn108 + (Just (getRange happy_var_1) + )} + +happyReduce_347 = happySpecReduce_0 102# happyReduction_347 +happyReduction_347 = happyIn108 + (Nothing + ) + +happyReduce_348 = happyMonadReduce 5# 103# happyReduction_348 +happyReduction_348 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut108 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokKeyword KwImport happy_var_2) -> + case happyOut22 happy_x_3 of { happy_var_3 -> + case happyOut110 happy_x_4 of { happy_var_4 -> + case happyOut64 happy_x_5 of { happy_var_5 -> + ( + let + { doOpen = maybe DontOpen (const DoOpen) happy_var_1 + ; m = happy_var_3 + ; es = happy_var_4 + ; dir = happy_var_5 + ; r = getRange (m, es, dir) + ; mr = getRange m + ; unique = hashString $ show $ (Nothing :: Maybe ()) <$ r + -- turn range into unique id, but delete file path + -- which is absolute and messes up suite of failing tests + -- (different hashs on different installations) + -- TODO: Don't use (insecure) hashes in this way. + ; fresh = Name mr [ Id $ stringToRawName $ ".#" ++ show m ++ "-" ++ show unique ] + ; impStm asR = Import mr m (Just (AsName fresh asR)) DontOpen defaultImportDir + ; appStm m' es = + let r = getRange (m, es) in + Private r + [ ModuleMacro r m' + (SectionApp (getRange es) [] + (RawApp (getRange es) (Ident (QName fresh) : es))) + doOpen dir + ] + ; (initArgs, last2Args) = splitAt (length es - 2) es + ; parseAsClause = case last2Args of + { [ Ident (QName (Name asR [Id x])) + , Ident (QName m') + ] | rawNameToString x == "as" -> Just (asR, m') + ; _ -> Nothing + } + } in + case es of + { [] -> return [Import mr m Nothing doOpen dir] + ; _ | Just (asR, m') <- parseAsClause -> + if null initArgs then return + [ Import (getRange (m, asR, m', dir)) m + (Just (AsName m' asR)) doOpen dir + ] + else return [ impStm asR, appStm m' initArgs ] + | DontOpen <- doOpen -> parseErrorAt (fromJust $ rStart $ getRange happy_var_2) "An import statement with module instantiation does not actually import the module. This statement achieves nothing. Either add the `open' keyword or bind the instantiated module with an `as' clause." + | otherwise -> return + [ impStm noRange + , appStm (noName $ beginningOf $ getRange m) es + ] + })}}}}} + ) (\r -> happyReturn (happyIn109 r)) + +happyReduce_349 = happyReduce 4# 103# happyReduction_349 +happyReduction_349 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOut110 happy_x_3 of { happy_var_3 -> + case happyOut64 happy_x_4 of { happy_var_4 -> + happyIn109 + (let + { m = happy_var_2 + ; es = happy_var_3 + ; dir = happy_var_4 + ; r = getRange (m, es, dir) + } in + [ case es of + { [] -> Open r m dir + ; _ -> Private r [ ModuleMacro r (noName $ beginningOf $ getRange m) + (SectionApp (getRange (m , es)) [] (RawApp (fuseRange m es) (Ident m : es))) + DoOpen dir + ] + } + ] + ) `HappyStk` happyRest}}} + +happyReduce_350 = happyReduce 6# 103# happyReduction_350 +happyReduction_350 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOut64 happy_x_6 of { happy_var_6 -> + happyIn109 + (let r = getRange happy_var_2 in + [ Private r [ ModuleMacro r (noName $ beginningOf $ getRange happy_var_2) + (RecordModuleIFS r happy_var_2) DoOpen happy_var_6 + ] + ] + ) `HappyStk` happyRest}} + +happyReduce_351 = happySpecReduce_0 104# happyReduction_351 +happyReduction_351 = happyIn110 + ([] + ) + +happyReduce_352 = happySpecReduce_2 104# happyReduction_352 +happyReduction_352 happy_x_2 + happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut110 happy_x_2 of { happy_var_2 -> + happyIn110 + (happy_var_1 : happy_var_2 + )}} + +happyReduce_353 = happyReduce 4# 105# happyReduction_353 +happyReduction_353 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut22 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (TokSymbol SymDoubleOpenBrace happy_var_2) -> + case happyOutTok happy_x_3 of { (TokSymbol SymEllipsis happy_var_3) -> + case happyOut17 happy_x_4 of { happy_var_4 -> + happyIn111 + ((\ts -> + if null ts then return $ RecordModuleIFS (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_1 + else parseError "No bindings allowed for record module with non-canonical implicits" ) + ) `HappyStk` happyRest}}}} + +happyReduce_354 = happySpecReduce_2 105# happyReduction_354 +happyReduction_354 happy_x_2 + happy_x_1 + = case happyOut22 happy_x_1 of { happy_var_1 -> + case happyOut110 happy_x_2 of { happy_var_2 -> + happyIn111 + ((\ts -> return $ SectionApp (getRange (happy_var_1, happy_var_2)) ts (RawApp (fuseRange happy_var_1 happy_var_2) (Ident happy_var_1 : happy_var_2)) ) + )}} + +happyReduce_355 = happyMonadReduce 6# 106# happyReduction_355 +happyReduction_355 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> + case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOut111 happy_x_5 of { happy_var_5 -> + case happyOut64 happy_x_6 of { happy_var_6 -> + ( do { ma <- happy_var_5 (map addType happy_var_3) + ; name <- ensureUnqual happy_var_2 + ; return $ ModuleMacro (getRange (happy_var_1, happy_var_2, ma, happy_var_6)) name ma DontOpen happy_var_6 })}}}}} + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_356 = happyMonadReduce 7# 106# happyReduction_356 +happyReduction_356 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokKeyword KwOpen happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwModule happy_var_2) -> + case happyOut15 happy_x_3 of { happy_var_3 -> + case happyOut61 happy_x_4 of { happy_var_4 -> + case happyOut111 happy_x_6 of { happy_var_6 -> + case happyOut64 happy_x_7 of { happy_var_7 -> + ( do {ma <- happy_var_6 (map addType happy_var_4); return $ ModuleMacro (getRange (happy_var_1, happy_var_2, happy_var_3, ma, happy_var_7)) happy_var_3 ma DoOpen happy_var_7 })}}}}}} + ) (\r -> happyReturn (happyIn112 r)) + +happyReduce_357 = happyReduce 5# 107# happyReduction_357 +happyReduction_357 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> + case happyOut22 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> + case happyOut143 happy_x_5 of { happy_var_5 -> + happyIn113 + (Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) happy_var_2 (map addType happy_var_3) happy_var_5 + ) `HappyStk` happyRest}}}}} + +happyReduce_358 = happyReduce 5# 107# happyReduction_358 +happyReduction_358 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokKeyword KwModule happy_var_1) -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOut61 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokKeyword KwWhere happy_var_4) -> + case happyOut143 happy_x_5 of { happy_var_5 -> + happyIn113 + (Module (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) (QName happy_var_2) (map addType happy_var_3) happy_var_5 + ) `HappyStk` happyRest}}}}} + +happyReduce_359 = happySpecReduce_1 108# happyReduction_359 +happyReduction_359 happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymUnderscore happy_var_1) -> + happyIn114 + (noName (getRange happy_var_1) + )} + +happyReduce_360 = happySpecReduce_1 109# happyReduction_360 +happyReduction_360 happy_x_1 + = case happyOut145 happy_x_1 of { happy_var_1 -> + happyIn115 + (figureOutTopLevelModule happy_var_1 + )} + +happyReduce_361 = happySpecReduce_1 110# happyReduction_361 +happyReduction_361 happy_x_1 + = case happyOut117 happy_x_1 of { happy_var_1 -> + happyIn116 + (Pragma happy_var_1 + )} + +happyReduce_362 = happySpecReduce_1 111# happyReduction_362 +happyReduction_362 happy_x_1 + = case happyOut119 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_363 = happySpecReduce_1 111# happyReduction_363 +happyReduction_363 happy_x_1 + = case happyOut120 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_364 = happySpecReduce_1 111# happyReduction_364 +happyReduction_364 happy_x_1 + = case happyOut121 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_365 = happySpecReduce_1 111# happyReduction_365 +happyReduction_365 happy_x_1 + = case happyOut122 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_366 = happySpecReduce_1 111# happyReduction_366 +happyReduction_366 happy_x_1 + = case happyOut124 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_367 = happySpecReduce_1 111# happyReduction_367 +happyReduction_367 happy_x_1 + = case happyOut123 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_368 = happySpecReduce_1 111# happyReduction_368 +happyReduction_368 happy_x_1 + = case happyOut125 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_369 = happySpecReduce_1 111# happyReduction_369 +happyReduction_369 happy_x_1 + = case happyOut126 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_370 = happySpecReduce_1 111# happyReduction_370 +happyReduction_370 happy_x_1 + = case happyOut127 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_371 = happySpecReduce_1 111# happyReduction_371 +happyReduction_371 happy_x_1 + = case happyOut133 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_372 = happySpecReduce_1 111# happyReduction_372 +happyReduction_372 happy_x_1 + = case happyOut134 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_373 = happySpecReduce_1 111# happyReduction_373 +happyReduction_373 happy_x_1 + = case happyOut128 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_374 = happySpecReduce_1 111# happyReduction_374 +happyReduction_374 happy_x_1 + = case happyOut131 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_375 = happySpecReduce_1 111# happyReduction_375 +happyReduction_375 happy_x_1 + = case happyOut130 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_376 = happySpecReduce_1 111# happyReduction_376 +happyReduction_376 happy_x_1 + = case happyOut129 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_377 = happySpecReduce_1 111# happyReduction_377 +happyReduction_377 happy_x_1 + = case happyOut132 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_378 = happySpecReduce_1 111# happyReduction_378 +happyReduction_378 happy_x_1 + = case happyOut118 happy_x_1 of { happy_var_1 -> + happyIn117 + (happy_var_1 + )} + +happyReduce_379 = happyReduce 4# 112# happyReduction_379 +happyReduction_379 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwOPTIONS happy_var_2) -> + case happyOut28 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> + happyIn118 + (OptionsPragma (getRange (happy_var_1,happy_var_2,happy_var_4)) happy_var_3 + ) `HappyStk` happyRest}}}} + +happyReduce_380 = happyReduce 5# 113# happyReduction_380 +happyReduction_380 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwBUILTIN happy_var_2) -> + case happyOutTok happy_x_3 of { (TokString happy_var_3) -> + case happyOut31 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn119 + (BuiltinPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4,happy_var_5)) (snd happy_var_3) (Ident happy_var_4) + ) `HappyStk` happyRest}}}}} + +happyReduce_381 = happyReduce 5# 113# happyReduction_381 +happyReduction_381 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwBUILTIN happy_var_2) -> + case happyOutTok happy_x_3 of { (TokKeyword KwREWRITE happy_var_3) -> + case happyOut31 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn119 + (BuiltinPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4,happy_var_5)) "REWRITE" (Ident happy_var_4) + ) `HappyStk` happyRest}}}}} + +happyReduce_382 = happyReduce 4# 114# happyReduction_382 +happyReduction_382 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwREWRITE happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> + happyIn120 + (RewritePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 + ) `HappyStk` happyRest}}}} + +happyReduce_383 = happyReduce 5# 115# happyReduction_383 +happyReduction_383 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOut28 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn121 + (CompiledPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) + ) `HappyStk` happyRest}}}}} + +happyReduce_384 = happyReduce 5# 116# happyReduction_384 +happyReduction_384 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_EXPORT happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOut29 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn122 + (CompiledExportPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 happy_var_4 + ) `HappyStk` happyRest}}}}} + +happyReduce_385 = happyReduce 5# 117# happyReduction_385 +happyReduction_385 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_TYPE happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOut28 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn123 + (CompiledTypePragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) + ) `HappyStk` happyRest}}}}} + +happyReduce_386 = happyReduce 6# 118# happyReduction_386 +happyReduction_386 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_DATA happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokString happy_var_4) -> + case happyOut28 happy_x_5 of { happy_var_5 -> + case happyOutTok happy_x_6 of { (TokSymbol SymClosePragma happy_var_6) -> + happyIn124 + (CompiledDataPragma (getRange (happy_var_1,happy_var_2,happy_var_3,fst happy_var_4,happy_var_6)) happy_var_3 (snd happy_var_4) happy_var_5 + ) `HappyStk` happyRest}}}}}} + +happyReduce_387 = happyReduce 5# 119# happyReduction_387 +happyReduction_387 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_EPIC happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOut28 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn125 + (CompiledEpicPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) + ) `HappyStk` happyRest}}}}} + +happyReduce_388 = happyReduce 5# 120# happyReduction_388 +happyReduction_388 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwCOMPILED_JS happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOut28 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { (TokSymbol SymClosePragma happy_var_5) -> + happyIn126 + (CompiledJSPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_5)) happy_var_3 (unwords happy_var_4) + ) `HappyStk` happyRest}}}}} + +happyReduce_389 = happyReduce 4# 121# happyReduction_389 +happyReduction_389 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwSTATIC happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> + happyIn127 + (StaticPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 + ) `HappyStk` happyRest}}}} + +happyReduce_390 = happyReduce 4# 122# happyReduction_390 +happyReduction_390 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwETA happy_var_2) -> + case happyOut31 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> + happyIn128 + (EtaPragma (getRange (happy_var_1,happy_var_2,happy_var_3,happy_var_4)) happy_var_3 + ) `HappyStk` happyRest}}}} + +happyReduce_391 = happySpecReduce_3 123# happyReduction_391 +happyReduction_391 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwNO_TERMINATION_CHECK happy_var_2) -> + case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> + happyIn129 + (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NoTerminationCheck + )}}} + +happyReduce_392 = happySpecReduce_3 124# happyReduction_392 +happyReduction_392 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwNON_TERMINATING happy_var_2) -> + case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> + happyIn130 + (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) NonTerminating + )}}} + +happyReduce_393 = happySpecReduce_3 125# happyReduction_393 +happyReduction_393 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwTERMINATING happy_var_2) -> + case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> + happyIn131 + (TerminationCheckPragma (getRange (happy_var_1,happy_var_2,happy_var_3)) Terminating + )}}} + +happyReduce_394 = happyReduce 4# 126# happyReduction_394 +happyReduction_394 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwMEASURE happy_var_2) -> + case happyOut30 happy_x_3 of { happy_var_3 -> + case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> + happyIn132 + (let r = getRange (happy_var_1, happy_var_2, happy_var_3, happy_var_4) in + TerminationCheckPragma r (TerminationMeasure r happy_var_3) + ) `HappyStk` happyRest}}}} + +happyReduce_395 = happyMonadReduce 4# 127# happyReduction_395 +happyReduction_395 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwIMPORT happy_var_2) -> + case happyOutTok happy_x_3 of { (TokString happy_var_3) -> + case happyOutTok happy_x_4 of { (TokSymbol SymClosePragma happy_var_4) -> + ( let s = snd happy_var_3 in + if validHaskellModuleName s + then return $ ImportPragma (getRange (happy_var_1,happy_var_2,fst happy_var_3,happy_var_4)) s + else parseError $ "Malformed module name: " ++ s ++ ".")}}}} + ) (\r -> happyReturn (happyIn133 r)) + +happyReduce_396 = happySpecReduce_3 128# happyReduction_396 +happyReduction_396 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TokSymbol SymOpenPragma happy_var_1) -> + case happyOutTok happy_x_2 of { (TokKeyword KwIMPOSSIBLE happy_var_2) -> + case happyOutTok happy_x_3 of { (TokSymbol SymClosePragma happy_var_3) -> + happyIn134 + (ImpossiblePragma (getRange (happy_var_1,happy_var_2,happy_var_3)) + )}}} + +happyReduce_397 = happySpecReduce_3 129# happyReduction_397 +happyReduction_397 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut136 happy_x_2 of { happy_var_2 -> + happyIn135 + (reverse happy_var_2 + )} + +happyReduce_398 = happySpecReduce_3 130# happyReduction_398 +happyReduction_398 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut136 happy_x_1 of { happy_var_1 -> + case happyOut81 happy_x_3 of { happy_var_3 -> + happyIn136 + (reverse happy_var_3 ++ happy_var_1 + )}} + +happyReduce_399 = happySpecReduce_1 130# happyReduction_399 +happyReduction_399 happy_x_1 + = case happyOut81 happy_x_1 of { happy_var_1 -> + happyIn136 + (reverse happy_var_1 + )} + +happyReduce_400 = happySpecReduce_3 131# happyReduction_400 +happyReduction_400 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut138 happy_x_2 of { happy_var_2 -> + happyIn137 + (reverse happy_var_2 + )} + +happyReduce_401 = happySpecReduce_3 132# happyReduction_401 +happyReduction_401 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut138 happy_x_1 of { happy_var_1 -> + case happyOut82 happy_x_3 of { happy_var_3 -> + happyIn138 + (reverse happy_var_3 ++ happy_var_1 + )}} + +happyReduce_402 = happySpecReduce_1 132# happyReduction_402 +happyReduction_402 happy_x_1 + = case happyOut82 happy_x_1 of { happy_var_1 -> + happyIn138 + (reverse happy_var_1 + )} + +happyReduce_403 = happySpecReduce_2 133# happyReduction_403 +happyReduction_403 happy_x_2 + happy_x_1 + = happyIn139 + ([] + ) + +happyReduce_404 = happySpecReduce_1 133# happyReduction_404 +happyReduction_404 happy_x_1 + = case happyOut135 happy_x_1 of { happy_var_1 -> + happyIn139 + (happy_var_1 + )} + +happyReduce_405 = happySpecReduce_2 134# happyReduction_405 +happyReduction_405 happy_x_2 + happy_x_1 + = happyIn140 + ((Nothing, Nothing, []) + ) + +happyReduce_406 = happySpecReduce_3 134# happyReduction_406 +happyReduction_406 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut89 happy_x_2 of { happy_var_2 -> + happyIn140 + ((Nothing, Just happy_var_2, []) + )} + +happyReduce_407 = happyReduce 5# 134# happyReduction_407 +happyReduction_407 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut89 happy_x_2 of { happy_var_2 -> + case happyOut144 happy_x_4 of { happy_var_4 -> + happyIn140 + ((Nothing, Just happy_var_2, happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_408 = happySpecReduce_3 134# happyReduction_408 +happyReduction_408 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut144 happy_x_2 of { happy_var_2 -> + happyIn140 + ((Nothing, Nothing, happy_var_2) + )} + +happyReduce_409 = happySpecReduce_3 134# happyReduction_409 +happyReduction_409 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut141 happy_x_2 of { happy_var_2 -> + happyIn140 + ((Just happy_var_2, Nothing, []) + )} + +happyReduce_410 = happyReduce 5# 134# happyReduction_410 +happyReduction_410 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut141 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> + happyIn140 + ((Just happy_var_2, Just happy_var_4, []) + ) `HappyStk` happyRest}} + +happyReduce_411 = happyReduce 7# 134# happyReduction_411 +happyReduction_411 (happy_x_7 `HappyStk` + happy_x_6 `HappyStk` + happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut141 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> + case happyOut144 happy_x_6 of { happy_var_6 -> + happyIn140 + ((Just happy_var_2, Just happy_var_4, happy_var_6) + ) `HappyStk` happyRest}}} + +happyReduce_412 = happyReduce 5# 134# happyReduction_412 +happyReduction_412 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut141 happy_x_2 of { happy_var_2 -> + case happyOut144 happy_x_4 of { happy_var_4 -> + happyIn140 + ((Just happy_var_2, Nothing, happy_var_4) + ) `HappyStk` happyRest}} + +happyReduce_413 = happySpecReduce_1 135# happyReduction_413 +happyReduction_413 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwInductive happy_var_1) -> + happyIn141 + (Ranged (getRange happy_var_1) Inductive + )} + +happyReduce_414 = happySpecReduce_1 135# happyReduction_414 +happyReduction_414 happy_x_1 + = case happyOutTok happy_x_1 of { (TokKeyword KwCoInductive happy_var_1) -> + happyIn141 + (Ranged (getRange happy_var_1) CoInductive + )} + +happyReduce_415 = happySpecReduce_3 136# happyReduction_415 +happyReduction_415 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut144 happy_x_2 of { happy_var_2 -> + happyIn142 + (happy_var_2 + )} + +happyReduce_416 = happySpecReduce_2 137# happyReduction_416 +happyReduction_416 happy_x_2 + happy_x_1 + = happyIn143 + ([] + ) + +happyReduce_417 = happySpecReduce_1 137# happyReduction_417 +happyReduction_417 happy_x_1 + = case happyOut142 happy_x_1 of { happy_var_1 -> + happyIn143 + (happy_var_1 + )} + +happyReduce_418 = happySpecReduce_3 138# happyReduction_418 +happyReduction_418 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut80 happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_3 of { happy_var_3 -> + happyIn144 + (happy_var_1 ++ happy_var_3 + )}} + +happyReduce_419 = happySpecReduce_1 138# happyReduction_419 +happyReduction_419 happy_x_1 + = case happyOut80 happy_x_1 of { happy_var_1 -> + happyIn144 + (happy_var_1 + )} + +happyReduce_420 = happySpecReduce_0 139# happyReduction_420 +happyReduction_420 = happyIn145 + ([] + ) + +happyReduce_421 = happySpecReduce_1 139# happyReduction_421 +happyReduction_421 happy_x_1 + = case happyOut144 happy_x_1 of { happy_var_1 -> + happyIn145 + (happy_var_1 + )} + +happyNewToken action sts stk + = lexer(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + TokEOF -> happyDoAction 89# tk action sts stk; + TokKeyword KwLet happy_dollar_dollar -> cont 1#; + TokKeyword KwIn happy_dollar_dollar -> cont 2#; + TokKeyword KwWhere happy_dollar_dollar -> cont 3#; + TokKeyword KwWith happy_dollar_dollar -> cont 4#; + TokKeyword KwRewrite happy_dollar_dollar -> cont 5#; + TokKeyword KwPostulate happy_dollar_dollar -> cont 6#; + TokKeyword KwPrimitive happy_dollar_dollar -> cont 7#; + TokKeyword KwOpen happy_dollar_dollar -> cont 8#; + TokKeyword KwImport happy_dollar_dollar -> cont 9#; + TokKeyword KwUsing happy_dollar_dollar -> cont 10#; + TokKeyword KwHiding happy_dollar_dollar -> cont 11#; + TokKeyword KwRenaming happy_dollar_dollar -> cont 12#; + TokKeyword KwTo happy_dollar_dollar -> cont 13#; + TokKeyword KwPublic happy_dollar_dollar -> cont 14#; + TokKeyword KwModule happy_dollar_dollar -> cont 15#; + TokKeyword KwData happy_dollar_dollar -> cont 16#; + TokKeyword KwCoData happy_dollar_dollar -> cont 17#; + TokKeyword KwRecord happy_dollar_dollar -> cont 18#; + TokKeyword KwConstructor happy_dollar_dollar -> cont 19#; + TokKeyword KwInductive happy_dollar_dollar -> cont 20#; + TokKeyword KwCoInductive happy_dollar_dollar -> cont 21#; + TokKeyword KwField happy_dollar_dollar -> cont 22#; + TokKeyword KwInfix happy_dollar_dollar -> cont 23#; + TokKeyword KwInfixL happy_dollar_dollar -> cont 24#; + TokKeyword KwInfixR happy_dollar_dollar -> cont 25#; + TokKeyword KwMutual happy_dollar_dollar -> cont 26#; + TokKeyword KwAbstract happy_dollar_dollar -> cont 27#; + TokKeyword KwPrivate happy_dollar_dollar -> cont 28#; + TokKeyword KwInstance happy_dollar_dollar -> cont 29#; + TokKeyword KwProp happy_dollar_dollar -> cont 30#; + TokKeyword KwSet happy_dollar_dollar -> cont 31#; + TokKeyword KwForall happy_dollar_dollar -> cont 32#; + TokKeyword KwSyntax happy_dollar_dollar -> cont 33#; + TokKeyword KwPatternSyn happy_dollar_dollar -> cont 34#; + TokKeyword KwOPTIONS happy_dollar_dollar -> cont 35#; + TokKeyword KwBUILTIN happy_dollar_dollar -> cont 36#; + TokKeyword KwREWRITE happy_dollar_dollar -> cont 37#; + TokKeyword KwIMPORT happy_dollar_dollar -> cont 38#; + TokKeyword KwIMPOSSIBLE happy_dollar_dollar -> cont 39#; + TokKeyword KwETA happy_dollar_dollar -> cont 40#; + TokKeyword KwNO_TERMINATION_CHECK happy_dollar_dollar -> cont 41#; + TokKeyword KwNON_TERMINATING happy_dollar_dollar -> cont 42#; + TokKeyword KwTERMINATING happy_dollar_dollar -> cont 43#; + TokKeyword KwMEASURE happy_dollar_dollar -> cont 44#; + TokKeyword KwCOMPILED happy_dollar_dollar -> cont 45#; + TokKeyword KwCOMPILED_EXPORT happy_dollar_dollar -> cont 46#; + TokKeyword KwCOMPILED_DATA happy_dollar_dollar -> cont 47#; + TokKeyword KwCOMPILED_TYPE happy_dollar_dollar -> cont 48#; + TokKeyword KwCOMPILED_EPIC happy_dollar_dollar -> cont 49#; + TokKeyword KwCOMPILED_JS happy_dollar_dollar -> cont 50#; + TokKeyword KwSTATIC happy_dollar_dollar -> cont 51#; + TokKeyword KwQuoteGoal happy_dollar_dollar -> cont 52#; + TokKeyword KwQuoteContext happy_dollar_dollar -> cont 53#; + TokKeyword KwQuote happy_dollar_dollar -> cont 54#; + TokKeyword KwQuoteTerm happy_dollar_dollar -> cont 55#; + TokKeyword KwTactic happy_dollar_dollar -> cont 56#; + TokKeyword KwUnquote happy_dollar_dollar -> cont 57#; + TokKeyword KwUnquoteDecl happy_dollar_dollar -> cont 58#; + TokSetN happy_dollar_dollar -> cont 59#; + TokTeX happy_dollar_dollar -> cont 60#; + TokComment happy_dollar_dollar -> cont 61#; + TokSymbol SymEllipsis happy_dollar_dollar -> cont 62#; + TokSymbol SymDotDot happy_dollar_dollar -> cont 63#; + TokSymbol SymDot happy_dollar_dollar -> cont 64#; + TokSymbol SymSemi happy_dollar_dollar -> cont 65#; + TokSymbol SymColon happy_dollar_dollar -> cont 66#; + TokSymbol SymEqual happy_dollar_dollar -> cont 67#; + TokSymbol SymUnderscore happy_dollar_dollar -> cont 68#; + TokSymbol SymQuestionMark happy_dollar_dollar -> cont 69#; + TokSymbol SymArrow happy_dollar_dollar -> cont 70#; + TokSymbol SymLambda happy_dollar_dollar -> cont 71#; + TokSymbol SymAs happy_dollar_dollar -> cont 72#; + TokSymbol SymBar happy_dollar_dollar -> cont 73#; + TokSymbol SymOpenParen happy_dollar_dollar -> cont 74#; + TokSymbol SymCloseParen happy_dollar_dollar -> cont 75#; + TokSymbol SymDoubleOpenBrace happy_dollar_dollar -> cont 76#; + TokSymbol SymDoubleCloseBrace happy_dollar_dollar -> cont 77#; + TokSymbol SymOpenBrace happy_dollar_dollar -> cont 78#; + TokSymbol SymCloseBrace happy_dollar_dollar -> cont 79#; + TokSymbol SymOpenVirtualBrace happy_dollar_dollar -> cont 80#; + TokSymbol SymCloseVirtualBrace happy_dollar_dollar -> cont 81#; + TokSymbol SymVirtualSemi happy_dollar_dollar -> cont 82#; + TokSymbol SymOpenPragma happy_dollar_dollar -> cont 83#; + TokSymbol SymClosePragma happy_dollar_dollar -> cont 84#; + TokId happy_dollar_dollar -> cont 85#; + TokQId happy_dollar_dollar -> cont 86#; + TokString happy_dollar_dollar -> cont 87#; + TokLiteral happy_dollar_dollar -> cont 88#; + _ -> happyError' tk + }) + +happyError_ 89# tk = happyError' tk +happyError_ _ tk = happyError' tk + +happyThen :: () => Parser a -> (a -> Parser b) -> Parser b +happyThen = (>>=) +happyReturn :: () => a -> Parser a +happyReturn = (return) +happyThen1 = happyThen +happyReturn1 :: () => a -> Parser a +happyReturn1 = happyReturn +happyError' :: () => (Token) -> Parser a +happyError' tk = (\token -> happyError) tk + +tokensParser = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut6 x)) + +exprParser = happySomeParser where + happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut32 x)) + +moduleParser = happySomeParser where + happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut9 x)) + +happySeq = happyDontSeq + + +{-------------------------------------------------------------------------- + Parsers + --------------------------------------------------------------------------} + +-- | Parse the token stream. Used by the TeX compiler. +tokensParser :: Parser [Token] + +-- | Parse an expression. Could be used in interactions. +exprParser :: Parser Expr + +-- | Parse a module. +moduleParser :: Parser Module + + +{-------------------------------------------------------------------------- + Happy stuff + --------------------------------------------------------------------------} + +-- | Required by Happy. +happyError :: Parser a +happyError = parseError "Parse error" + + +{-------------------------------------------------------------------------- + Utility functions + --------------------------------------------------------------------------} + +-- | Grab leading OPTIONS pragmas. +takeOptionsPragmas :: [Declaration] -> ([Pragma], [Declaration]) +takeOptionsPragmas = spanJust $ \ d -> case d of + Pragma p@OptionsPragma{} -> Just p + _ -> Nothing + +-- | Insert a top-level module if there is none. +figureOutTopLevelModule :: [Declaration] -> [Declaration] +figureOutTopLevelModule ds = + case span isAllowedBeforeModule ds of + (ds0, Module r m tel ds1 : ds2) -> ds0 ++ [Module r m tel $ ds1 ++ ds2] + (ds0, ds1) -> ds0 ++ [Module (getRange ds1) (QName noName_) [] ds1] + where + isAllowedBeforeModule (Pragma OptionsPragma{}) = True + isAllowedBeforeModule (Private _ ds) = all isAllowedBeforeModule ds + isAllowedBeforeModule Import{} = True + isAllowedBeforeModule ModuleMacro{} = True + isAllowedBeforeModule Open{} = True + isAllowedBeforeModule _ = False + +-- | Create a name from a string. + +mkName :: (Interval, String) -> Parser Name +mkName (i, s) = do + let xs = C.stringNameParts s + mapM_ isValidId xs + unless (alternating xs) $ fail $ "a name cannot contain two consecutive underscores" + return $ Name (getRange i) xs + where + isValidId Hole = return () + isValidId (Id y) = do + let x = rawNameToString y + case parse defaultParseFlags [0] (lexer return) x of + ParseOk _ (TokId _) -> return () + _ -> fail $ "in the name " ++ s ++ ", the part " ++ x ++ " is not valid" + + -- we know that there are no two Ids in a row + alternating (Hole : Hole : _) = False + alternating (_ : xs) = alternating xs + alternating [] = True + +-- | Create a qualified name from a list of strings +mkQName :: [(Interval, String)] -> Parser QName +mkQName ss = do + xs <- mapM mkName ss + return $ foldr Qual (QName $ last xs) (init xs) + +ensureUnqual :: QName -> Parser Name +ensureUnqual (QName x) = return x +ensureUnqual q@Qual{} = parseError' (rStart $ getRange q) "Qualified name not allowed here" + +-- | Match a particular name. +isName :: String -> (Interval, String) -> Parser () +isName s (_,s') + | s == s' = return () + | otherwise = fail $ "expected " ++ s ++ ", found " ++ s' + +-- | Build a forall pi (forall x y z -> ...) +forallPi :: [LamBinding] -> Expr -> Expr +forallPi bs e = Pi (map addType bs) e + +-- | Build a telescoping let (let Ds) +tLet :: Range -> [Declaration] -> TypedBindings +tLet r = TypedBindings r . Common.Arg defaultArgInfo . TLet r + +-- | Converts lambda bindings to typed bindings. +addType :: LamBinding -> TypedBindings +addType (DomainFull b) = b +addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [pure x] $ Underscore r Nothing where r = getRange x mergeImportDirectives :: [ImportDirective] -> Parser ImportDirective diff --git a/src/data/EpicInclude/AgdaPrelude.e b/src/data/EpicInclude/AgdaPrelude.e deleted file mode 100644 --- a/src/data/EpicInclude/AgdaPrelude.e +++ /dev/null @@ -1,207 +0,0 @@ -%include "string.h" - --- IO - -{- -%inline putStr (x:String) -> Unit = - foreign Unit "wputStr" (x:String) - -putStrLn (x:String) -> Unit = - putStr(primStringAppend(x,"\n")) - -readStr () -> String = - foreign String "readStr" () - -intToStr (x:Int) -> String = - foreign String "intToStr" (x:Int) - -strToInt (x:String) -> Int = - foreign String "strToInt" (x:String) - -printInt (x:Int) -> Unit = - foreign Unit "printInt" (x:Int) --} - -ioreturn (a : Any, u : Unit) -> Any = a -iobind (x : Any, f : Any, u : Unit) -> Any = %effect (let v : Any = %effect (x(u)) in f (v, u)) - --- String operations - --- data String = Con 0 | Con 1 (Char*) String - -freadStr (stream : Ptr) -> String = - let isEof : Bool = foreign Int "feof" (stream : Ptr) - in if isEof then Con 0 () - else let str : String = %effect(foreign String "freadStrChunk" (stream : Ptr)) - in primStringAppend( str , freadStr (stream)) - -readStr (u : Unit) -> String = - let isEof : Bool = foreign Int "eofstdin" () - in if isEof then Con 0 () - else let str : String = %effect(foreign String "readStrChunk" ()) - in primStringAppend ( str , readStr (u)) - -primStringAppend (xs : String, ys : String) -> String = - foreign String "append" (xs : String, ys : String) - - -%inline length (xs : String) -> Int = strlen (xs) - -charAt (xs : String, i : Int) -> Int = - foreign Int "strIndex" (xs : String , i : Int) - -primStringEquality (xs : String, ys : String) -> Bool = - foreign Int "eqString" (xs : String, ys : String) - -charToString (c : Int) -> String = - foreign String "charToStr" (c : Int) - -strlen (s : String) -> Int = foreign Int "strlen" (s : String) - --- TODO: toList/fromList could be made slightly more efficient. - -primStringToList (xs : String) -> Data = %effect( - let result : Data = primNil () in - let i : Int = strlen (xs) - 1 in - %while (i >= 0, - let ! result = primCons (foreign Int "strIndex" (xs : String, i : Int), result) in - let ! i = i - 1 in - unit) ; - result) - - -map (f : Any, l : Any) -> Any = case l of - { Con 0 () -> Con 0 () - | Con 1 (x : Any, xs : Any) -> Con 1 (f (x), map (f, xs)) - } - -primStringFromList (l : Data) -> String = - case l of { - Con 0 () -> "" - | Con 1 (c : Char, cs : Data) -> strCons (c , primStringFromList(cs)) - } - -strCons(i : Int , s : String) -> String = - foreign String "strCons" (i : Int, s : String) - --- Lists - -primNil () -> Data = Con 0 () - -primCons(x : Any , xs : Data) -> Data = Con 1 (x, xs) - -listElim (op : Any, z : Any, xs : Data) -> Any = case xs of - { Con 0 () -> z - | Con 1 (y : Any, ys : Data) -> op (y, listElim(op, z, ys)) - } - -primListAppend (xs : Data, ys : Data) -> Data = listElim(primCons, ys, xs) --- Big number arithmetic - -subBig (x:BigInt, y:BigInt) -> BigInt = - foreign BigInt "subBig" (x:BigInt, y:BigInt) - -gtBig (x:BigInt, y:BigInt) -> Bool = - foreign Int "gtBig" (x:BigInt, y:BigInt) - -leBig (x:BigInt, y:BigInt) -> Bool = - foreign Int "leBig" (x:BigInt, y:BigInt) - -geBig (x:BigInt, y:BigInt) -> Bool = - foreign Int "geBig" (x:BigInt, y:BigInt) - -printBig (x:BigInt) -> Unit = - foreign Unit "printBig" (x:BigInt) - -bigToStr (x:BigInt) -> String = - foreign String "bigToStr" (x:BigInt) - -strToBig (x : String) -> Any = foreign BigInt "strToBig" (x : String) - --- strToBig (x:String) -> Any = --- foreign Any "strToBig" (x:String) - -bigToInt (x : BigInt) -> Int = - foreign Int "bigToInt" (x : BigInt) - --- Unit - -%inline primUnit() -> Unit = unit - --- Nats - -primNatPlus (x:Any, y:Any) -> Any = - foreign Any "addBig" (x:Any, y:Any) - -primNatTimes (x:Any, y:Any) -> Any = - foreign Any "mulBig" (x:Any, y:Any) - -%inline primNatMinus(x : Any, y : Any) -> Any = atLeastZeroBig(subBig(x, y)) - - - -primZero() -> Any = 0L -- foreign BigInt "bigZero" () -primOne() -> Any = 1L -- foreign BigInt "bigOne" () - -primSuc (n : Any) -> Any = primNatPlus(n, primOne()) - -primPred(n : Any) -> Any = subBig(n, primOne()) - -%inline atLeastZeroBig (x : Any) -> Any = - if primNatLess(x, primZero) - then primZero - else x - -primNatModSucAux(k : BigInt, m : BigInt, n : BigInt, j : BigInt) -> BigInt = - foreign BigInt "modBig" (n : BigInt, m : BigInt) - - - -primNatEquality (x:BigInt, y:BigInt) -> Bool = - foreign Int "eqBig" (x:BigInt, y:BigInt) - -primNatLess (x:BigInt, y:BigInt) -> Bool = - foreign Int "ltBig" (x:BigInt, y:BigInt) - - --- Bools - -%inline primTrue () -> Bool = true - -%inline primFalse () -> Bool = false - --- Chars - -printChar (x:Int) -> Unit = - foreign Unit "printCharRep" (x:Int) - -%inline primCharEquality (c1 : Int, c2 : Int) -> Bool = c1 == c2 - -primCharToNat (c : Int) -> BigInt = foreign BigInt "NEWBIGINTVALI" (c : Int) - - --- Floats -floatToStr (x : Float) -> String = - foreign String "floatToStr" (x : Float) - -strToFloat (s : String) -> Float = - foreign Float "strToFloat" (s : String) - --- Coinduction - -primSharp (u1 : Any, u2 : Any, x : Any) -> Data = Con 0 (x) - --- RUNTIME - -init () -> Unit = - foreign Unit "init" () - --- Levels - -primLevelMax (x : Any, y : Any) -> Any = 0L -- error "primLevelMax" -primLevelZero () -> Any = 0L -- error "primLevelZero" -primLevelSuc (x : Any) -> Any = primSuc(x) -- error "primLevelSuc" - --- TrustMe - -primTrustMe (a : Unit, x : Any, y : Any) -> Any = Con 0 () diff --git a/src/data/EpicInclude/stdagda.c b/src/data/EpicInclude/stdagda.c deleted file mode 100644 --- a/src/data/EpicInclude/stdagda.c +++ /dev/null @@ -1,95 +0,0 @@ -#include "stdagda.h" -#include -#include -#include -#include -#include -#include -//#include "closure.h" - - -#define _UNICODE -#define UNICODE - -void wputStr(char* s) { wprintf(L"%s",s); } - -int eqString(char *x, char *y) { - return strcmp(x, y) == 0; -} - -VAL bigZeroRep; -VAL bigOneRep; - -VAL bigZero() { return bigZeroRep;} -VAL bigOne() {return bigOneRep;} - -void init(void) { - setlocale(LC_CTYPE, ""); - - bigZeroRep = NEWBIGINTVALI(0); - bigOneRep = NEWBIGINTVALI(1); -} - -void printCharRep(int c) { - - wprintf(L"%lc", c); -} - -int bigToInt(VAL n) { - return (int) mpz_get_si(*(GETBIGINT(n))); -} - -VAL intToBig(int n) { - return NEWBIGINTVALI(n); -} - -VAL getArgBig(VAL num) { - return evm_getArg(bigToInt(num)); -} - -VAL numArgsBig(void) { - return NEWBIGINTVALI(epic_numArgs()); -} - -char* charToStr(int x) -{ - char* buf = EMALLOC(2*sizeof(char)); - buf[0] = (char)x; buf[1] = '\0'; - return buf; -} - -int eof() { return EOF; } - -int charAtBig(char* str, VAL n) -{ - return (int)str[bigToInt(n)]; -} - -int charAt(char* str, int n) { return (int)str[n]; } - -#define STRING_BUFFER_SIZE 1024 - -int eofstdin() { return feof(stdin);} - -char* readStrChunk() { return freadStrChunk(stdin); } - -char* freadStrChunk(FILE* f) { - char* in = EMALLOC(sizeof(char)*STRING_BUFFER_SIZE); - fgets(in,STRING_BUFFER_SIZE,f); - return in; -} - -void** newArray(VAL size) -{ - return EMALLOC(sizeof(void*)*bigToInt(size)); -} - -void* arrayIndex(void** array, VAL i) -{ - return array[bigToInt(i)]; -} - -void setArrayIndex(void** array, VAL i, void* val) -{ - array[bigToInt(i)] = val; -} diff --git a/src/data/EpicInclude/stdagda.h b/src/data/EpicInclude/stdagda.h deleted file mode 100644 --- a/src/data/EpicInclude/stdagda.h +++ /dev/null @@ -1,41 +0,0 @@ -#ifndef _STDAGDA_H -#define _STDAGDA_H - -# ifndef WIN32 -# include -# define GC_THREADS -# else -# define GC_WIN32_THREADS -# endif - -#include -#include -#include -#include "stdfuns.h" -void init(void); -int eqString(char *x, char *y); -void printCharRep(int c); - -void wputStr(char* s); - -int bigToInt(VAL n); -VAL intToBig(int n); - -VAL getArgBig(VAL num); - -VAL numArgsBig(void); - -FILE* getStdin (void); -FILE* getStdout(void); - - -char* charToStr(int x); -int charAt(char* str, int n); -int charAtBig(char* str, VAL n); - -int eof(); - -char* freadStrChunk(FILE* f); -// void* freadStrChunk(void* h); - -#endif diff --git a/src/data/emacs-mode/agda-input.el b/src/data/emacs-mode/agda-input.el --- a/src/data/emacs-mode/agda-input.el +++ b/src/data/emacs-mode/agda-input.el @@ -163,7 +163,7 @@ (agda-input-drop-prefix "\\") (agda-input-or (agda-input-compose - (agda-input-drop '("^o")) + (agda-input-drop '("^l" "^o" "^r" "^v")) (agda-input-prefix "^")) (agda-input-prefix "_"))))) ) @@ -539,7 +539,6 @@ ("\\" . ("\\")) ("en" . ("–")) ("em" . ("—")) - ("^i" . ("ⁱ")) ("!!" . ("‼")) ("??" . ("⁇")) ("?!" . ("‽" "⁈")) diff --git a/src/data/emacs-mode/agda2-mode.el b/src/data/emacs-mode/agda2-mode.el --- a/src/data/emacs-mode/agda2-mode.el +++ b/src/data/emacs-mode/agda2-mode.el @@ -10,19 +10,18 @@ ;;; Code: -(defvar agda2-version "2.4.2.2" +(defvar agda2-version "2.4.2.3" "The version of the Agda mode. Note that the same version of the Agda executable must be used.") (require 'cl) -(set (make-local-variable 'lisp-indent-function) - 'common-lisp-indent-function) (require 'compile) (require 'pp) (require 'time-date) (require 'eri) (require 'annotation) (require 'agda-input) +(require 'agda2) (require 'agda2-highlight) (require 'agda2-abbrevs) (require 'agda2-queue) @@ -33,6 +32,8 @@ (error nil)) (unless (fboundp 'overlays-in) (load "overlay")) ; for Xemacs (unless (fboundp 'propertize) ; for Xemacs 21.4 + ;; FIXME: XEmacs-21.4 (patch 22) does have `propertize' and so does Emacs-22 + ;; (and agda2-mode doesn't work in Emacs-21, AFAICT). (defun propertize (string &rest properties) "Return a copy of STRING with text properties added. First argument is the string to copy. @@ -41,12 +42,8 @@ (let ((str (copy-sequence string))) (add-text-properties 0 (length str) properties str) str))) - (unless (fboundp 'run-mode-hooks) - (fset 'run-mode-hooks 'run-hooks)) ; For Emacs versions < 21. - (unless (fboundp 'cl-labels) - (fset 'cl-labels 'labels)) ; For Emacs versions < 24.2. - (unless (fboundp 'cl-flet) - (fset 'cl-flet 'flet))) ; For Emacs versions < 24.2. + (unless (fboundp 'prog-mode) ;For Emacs<24. + (defalias 'prog-mode 'fundamental-mode))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Utilities @@ -56,9 +53,10 @@ Or possibly (let* VARBIND (labels FUNCBIND BODY...))." (declare (debug ((&rest [&or symbolp (symbolp form)]) (&rest (cl-defun)) - body))) - `(let* ,varbind (cl-labels ,funcbind ,@body))) -(put 'agda2-let 'lisp-indent-function 2) + body)) + (indent 2)) + ;; Use cl-labels if available to avoid obsolescence warnings. + `(let* ,varbind (,(if (fboundp 'cl-labels) 'cl-labels 'labels) ,funcbind ,@body))) (defun agda2-chunkify (n xs) "Returns a list containing chunks of XS of length at most N. @@ -252,6 +250,7 @@ (describe-char nil (global) "Information about the character at point") (agda2-comment-dwim-rest-of-buffer ,(kbd "C-c C-x M-;") (global) "Comment/uncomment the rest of the buffer") (agda2-display-program-version nil (global) "Version") + (agda2-set-program-version nil (global) "Switch to another version of Agda") (eri-indent ,(kbd "TAB")) (eri-indent-reverse [S-iso-lefttab]) (eri-indent-reverse [S-lefttab]) @@ -381,9 +380,7 @@ ;;;###autoload (modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8) ;;;###autoload -(eval `(define-derived-mode agda2-mode - ,(if (fboundp 'prog-mode) 'prog-mode) - "Agda" +(define-derived-mode agda2-mode prog-mode "Agda" "Major mode for Agda files. The following paragraph does not apply to Emacs 23 or newer. @@ -444,7 +441,7 @@ ;; including "mode: latex" is loaded chances are that the Agda mode ;; is activated before the LaTeX mode, and the LaTeX mode does not ;; seem to remove the text properties set by the Agda mode. - (add-hook 'change-major-mode-hook 'agda2-quit nil 'local))) + (add-hook 'change-major-mode-hook 'agda2-quit nil 'local)) (defun agda2-restart () "Kill and restart the *agda2* buffer and load `agda2-toplevel-module'." @@ -573,7 +570,13 @@ reloaded from `agda2-highlighting-file', unless `agda2-highlighting-in-progress' is nil." - + ;; Beware: the buffer may have been killed in the mean time. E.g. when + ;; viewing an attachment containing Agda code in Gnus, Gnus will + ;; create a temp buffer, set it in agda2-mode, call font-lock-ensure on it + ;; (which won't know that it needs to wait for some process to reply), then + ;; extract the fontified text and kill the temp buffer; so when Agda + ;; finally answers, the temp buffer is long gone. + (when (buffer-live-p agda2-file-buffer) (let (;; The input lines in the current chunk. (lines (split-string chunk "\n")) @@ -652,7 +655,7 @@ (setq agda2-measure-data nil) (message "Load time: %s." elapsed) (when continuation - (funcall continuation elapsed))))))))) + (funcall continuation elapsed)))))))))) (defun agda2-run-last-commands nil "Execute the last commands in the right order. @@ -988,11 +991,12 @@ (defun agda2-term () "Send a SIGTERM signal to the Agda2 process, then kill its buffer." (interactive) - (with-current-buffer agda2-process-buffer - (condition-case nil - (signal-process agda2-process 'SIGTERM) - (error nil)) - (kill-buffer))) + (when (buffer-live-p agda2-process-buffer) + (with-current-buffer agda2-process-buffer + (condition-case nil + (signal-process agda2-process 'SIGTERM) + (error nil)) + (kill-buffer)))) (defmacro agda2-maybe-normalised (name comment cmd want) "This macro constructs a function NAME which runs CMD. @@ -1220,6 +1224,15 @@ "Is the current buffer a literate Agda buffer?" (equal (file-name-extension (buffer-name)) "lagda")) +(defmacro agda2--case (exp &rest branches) ;FIXME: Use `pcase' instead! + (declare (debug t) (indent 1)) + (let ((s (make-symbol "v"))) + `(let ((,s ,exp)) + (cond + ,@(mapcar (lambda (branch) + `((equal ,s ,(car branch)) ,@(cdr branch))) + branches))))) + (defun agda2-goals-action (goals) "Annotates the goals in the current buffer with text properties. GOALS is a list of the buffer's goal numbers, in the order in @@ -1267,34 +1280,33 @@ (if literate (push 'outside stk)) (goto-char (point-min)) (while (and goals (safe-delims)) - (cl-labels ((c (s) (equal s (match-string 0)))) - (cond - ((c "\\begin{code}") (when (outside-code) (pop stk))) - ((c "\\end{code}") (when (not stk) (push 'outside stk))) - ((c "--") (when (and (not stk) - (is-proper "--" t)) (end-of-line))) - ((c "{-") (when (and (inside-code) - (not (inside-goal))) (push nil stk))) - ((c "-}") (when (inside-comment) (pop stk))) - ((c "{!") (when (and (inside-code) - (not (inside-comment))) (push (- (point) 2) stk))) - ((c "!}") (when (inside-goal) - (setq top (pop stk)) - (unless stk (make top)))) - ((c "?") (progn - (when (and (not stk) (is-proper "?" nil)) - (delete-char -1) - (insert "{!!}") - (make (- (point) 4))))))))))) + (agda2--case (match-string 0) + ("\\begin{code}" (when (outside-code) (pop stk))) + ("\\end{code}" (when (not stk) (push 'outside stk))) + ("--" (when (and (not stk) + (is-proper "--" t)) (end-of-line))) + ("{-" (when (and (inside-code) + (not (inside-goal))) (push nil stk))) + ("-}" (when (inside-comment) (pop stk))) + ("{!" (when (and (inside-code) + (not (inside-comment))) (push (- (point) 2) stk))) + ("!}" (when (inside-goal) + (setq top (pop stk)) + (unless stk (make top)))) + ("?" (progn + (when (and (not stk) (is-proper "?" nil)) + (delete-char -1) + (insert "{!!}") + (make (- (point) 4)))))))))) (defun agda2-make-goal (p q n) "Make a goal with number N at

{!...!}. Assume the region is clean." (annotation-preserve-mod-p-and-undo - (cl-flet ((atp (x ps) (add-text-properties x (1+ x) ps))) - (atp p '(category agda2-delim1)) - (atp (1+ p) '(category agda2-delim2)) - (atp (- q 2) '(category agda2-delim3)) - (atp (1- q) '(category agda2-delim4))) + (let ((atp (lambda (x ps) (add-text-properties x (1+ x) ps)))) + (funcall atp p '(category agda2-delim1)) + (funcall atp (1+ p) '(category agda2-delim2)) + (funcall atp (- q 2) '(category agda2-delim3)) + (funcall atp (1- q) '(category agda2-delim4))) (let ((o (make-overlay p q nil t nil))) (overlay-put o 'modification-hooks '(agda2-protect-goal-markers)) (overlay-put o 'agda2-gn n) @@ -1600,6 +1612,91 @@ (setq choice (x-popup-menu ev agda2-goal-map)) (call-interactively (lookup-key agda2-goal-map (apply 'vector choice))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Switching to a different version of Agda + +;; Note that other versions of Agda may use different protocols, so +;; this function unloads the Emacs mode. + +(defun agda2-set-program-version (version) + "Tries to switch to Agda version VERSION. + +This command assumes that the agda and agda-mode executables for +Agda version VERSION are called agda-VERSION and +agda-mode-VERSION, and that they are located on the PATH. (If +VERSION is empty, then agda and agda-mode are used instead.)" + (interactive "M") + + (let* + ((agda-buffers + (mapcan (lambda (buf) + (with-current-buffer buf + (when (equal major-mode 'agda2-mode) + (list buf)))) + (buffer-list))) + + (version-suffix (if (or (equal version "") + (equal version nil)) + "" + (concat "-" version))) + + ;; Run agda-mode and make sure that it returns + ;; successfully. + (coding-system-for-read 'utf-8) + (agda-mode-prog (concat "agda-mode" version-suffix)) + (agda-mode-path + (condition-case nil + (with-temp-buffer + (unless + (equal 0 (call-process agda-mode-prog + nil (current-buffer) nil + "locate")) + (error "%s" (concat "Error when running " + agda-mode-prog))) + (buffer-string)) + (file-error + (error "%s" (concat "Could not find " agda-mode-prog)))))) + + ;; Make sure that agda-mode returns a valid file. + (unless (file-readable-p agda-mode-path) + (error "%s" (concat "Could not read " agda-mode-path))) + + ;; Kill some processes/buffers related to Agda. + (when (and agda2-process + (process-status agda2-process)) + (kill-process agda2-process)) + (when (buffer-live-p agda2-process-buffer) + (kill-buffer agda2-process-buffer)) + (when (buffer-live-p agda2-info-buffer) + (kill-buffer agda2-info-buffer)) + (when (and agda2-debug-buffer-name + (get-buffer agda2-debug-buffer-name)) + (kill-buffer agda2-debug-buffer-name)) + + ;; Remove the Agda mode directory from the load path. + (setq load-path (delete agda2-directory load-path)) + + ;; Unload the Agda mode and its dependencies. + (unload-feature 'agda2-mode 'force) + (unload-feature 'agda2 'force) + (unload-feature 'eri 'force) + (unload-feature 'annotation 'force) + (unload-feature 'agda-input 'force) + (unload-feature 'agda2-highlight 'force) + (unload-feature 'agda2-abbrevs 'force) + (unload-feature 'agda2-queue 'force) + + ;; Load the new version of Agda. + (load-file agda-mode-path) + (require 'agda2-mode) + (setq agda2-program-name (concat "agda" version-suffix)) + + ;; Restart the Agda mode in all former Agda mode buffers. + (mapc (lambda (buf) + (with-current-buffer buf + (agda2-mode))) + agda-buffers))) (provide 'agda2-mode) ;;; agda2-mode.el ends here diff --git a/src/data/emacs-mode/agda2.el b/src/data/emacs-mode/agda2.el --- a/src/data/emacs-mode/agda2.el +++ b/src/data/emacs-mode/agda2.el @@ -2,8 +2,10 @@ ;; Agda mode code which should run before the first Agda file is ;; loaded -(add-to-list 'load-path - (or (file-name-directory load-file-name) (car load-path))) +(defvar agda2-directory (file-name-directory load-file-name) + "Path to the directory that contains agda2.el(c).") + +(add-to-list 'load-path (or agda2-directory (car load-path))) (autoload 'agda2-mode "agda2-mode" "Major mode for editing Agda files (version ≥ 2)." t) diff --git a/src/full/Agda/Auto/Auto.hs b/src/full/Agda/Auto/Auto.hs --- a/src/full/Agda/Auto/Auto.hs +++ b/src/full/Agda/Auto/Auto.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.Auto.Auto (auto) where import Prelude hiding (null) @@ -15,14 +19,16 @@ import qualified Data.Traversable as Trav import Agda.Utils.Permutation (permute, takeP) -import Agda.TypeChecking.Monad.Base -import Agda.TypeChecking.Monad.MetaVars -import Agda.TypeChecking.Monad.Context -import Agda.TypeChecking.Monad.Signature +import Agda.TypeChecking.Monad hiding (withCurrentModule) +-- import Agda.TypeChecking.Monad.Base +-- import Agda.TypeChecking.Monad.MetaVars +-- import Agda.TypeChecking.Monad.Context +-- import Agda.TypeChecking.Monad.Signature import Agda.TypeChecking.Substitute import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pretty (prettyA) import qualified Text.PrettyPrint as PP +import qualified Agda.TypeChecking.Pretty as TCM import Agda.Syntax.Position import qualified Agda.Syntax.Internal as I import Agda.Syntax.Translation.InternalToAbstract @@ -143,17 +149,23 @@ let (mainm, _, _, _) = tccons Map.! mi case mode of MNormal listmode disprove -> do + let numsols = if listmode then 10 else 1 + -- Andreas, 2015-05-17 Issue 1504: + -- wish to produce several solutions, as + -- the first one might be ill-typed. + -- However, currently changing the 1 to something higher makes Agsy loop. sols <- liftIO $ newIORef ([] :: [[I.Term]]) - nsol <- liftIO $ newIORef $ if listmode then pick + 10 else pick + 1 + nsol <- liftIO $ newIORef $ pick + numsols let hsol = do nsol' <- readIORef nsol - let cond = if listmode then nsol' <= 10 else nsol' == 1 + let cond = nsol' <= numsols when cond $ do trms <- runExceptT $ mapM (\ (m, _, _, _) -> frommy (Meta m)) $ Map.elems tccons case trms of Left{} -> writeIORef nsol $! nsol' + 1 - Right trms -> if listmode then modifyIORef sols (trms :) - else writeIORef sols [trms] + Right trms -> modifyIORef sols (trms :) + -- Right trms -> if listmode then modifyIORef sols (trms :) + -- else writeIORef sols [trms] ticks <- liftIO $ newIORef 0 let exsearch initprop recinfo defdfv = @@ -207,7 +219,7 @@ rsols <- liftM reverse $ liftIO $ readIORef sols if null rsols then do nsol' <- liftIO $ readIORef nsol - dispmsg $ insuffsols (pick + (if listmode then 10 else 1) - nsol') + dispmsg $ insuffsols (pick + numsols - nsol') else do aexprss <- mapM getsols rsols cexprss <- forM aexprss $ mapM $ \(mi, e) -> do @@ -261,55 +273,77 @@ rsols <- liftM reverse $ liftIO $ readIORef sols if null rsols then do nsol' <- liftIO $ readIORef nsol - dispmsg $ insuffsols (pick + 10 - nsol') ++ timeoutString + dispmsg $ insuffsols (pick + numsols - nsol') ++ timeoutString else do aexprss <- mapM getsols rsols - cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss + -- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss + cexprss <- forM aexprss $ do + mapM $ \ (mi, e) -> do + mv <- lookupMeta mi + withMetaInfo (getMetaInfo mv) $ do + e' <- abstractToConcrete_ e + return (mi, e') let disp [(_, cexpr)] = show cexpr - disp cexprs = concat (map (\(mi, cexpr) -> case lookup mi riis of {Nothing -> show mi; Just ii -> show ii} ++ " := " ++ show cexpr ++ " ") cexprs) + disp cexprs = concat $ for cexprs $ \ (mi, cexpr) -> + maybe (show mi) show (lookup mi riis) + ++ " := " ++ show cexpr ++ " " ticks <- liftIO $ readIORef ticks dispmsg $ "Listing solution(s) " ++ show pick ++ "-" ++ show (pick + length rsols - 1) ++ timeoutString ++ "\n" ++ unlines (map (\(x, y) -> show y ++ " " ++ disp x) $ zip cexprss [pick..]) - else + else {- not listmode -} case res of Nothing -> do nsol' <- liftIO $ readIORef nsol - dispmsg $ insuffsols (pick + 1 - nsol') ++ timeoutString + dispmsg $ insuffsols (pick + numsols - nsol') ++ timeoutString Just depthreached -> do ticks <- liftIO $ readIORef ticks rsols <- liftIO $ readIORef sols case rsols of - [] -> do - nsol' <- liftIO $ readIORef nsol - dispmsg $ insuffsols (pick + 1 - nsol') - (term : _) -> do - exprs <- getsols term - giveress <- - mapM (\(mi, expr) -> - case lookup mi riis of - Nothing -> - catchError - (giveExpr mi expr >>= \_ -> return (Nothing, Nothing)) - (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi))) - Just ii' -> do ae <- give ii' Nothing expr - mv <- lookupMeta mi - let scope = getMetaScope mv - ce <- abstractToConcreteEnv (makeEnv scope) ae - let cmnt = if ii' == ii then agsyinfo ticks else "" - return (Just (ii', show ce ++ cmnt), Nothing) - ) exprs - let msg = if length exprs == 1 then - Nothing - else - Just $ "Also gave solution(s) for hole(s)" ++ - concatMap (\(mi', _) -> - if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii}) - ) exprs - let msgs = catMaybes $ msg : map snd giveress - msg' = case msgs of - [] -> Nothing - _ -> Just $ unlines msgs - return (Left $ catMaybes $ map fst giveress, msg') + [] -> do + nsol' <- liftIO $ readIORef nsol + dispmsg $ insuffsols (pick + numsols - nsol') + terms -> loop terms where + -- Andreas, 2015-05-17 Issue 1504 + -- If giving a solution failed (e.g. ill-typed) + -- we could try the next one. + -- However, currently @terms@ is always a singleton list. + -- Thus, the following @loop@ is not doing something very + -- meaningful. + loop [] = return (Left [], Just "") + loop (term : terms') = do + -- On exception, try next solution + flip catchError (const $ loop terms') $ do + exprs <- getsols term + reportSDoc "auto" 20 $ TCM.text "Trying solution " TCM.<+> TCM.prettyTCM exprs + giveress <- forM exprs $ \ (mi, expr) -> + case lookup mi riis of + Nothing -> + -- catchError + (giveExpr mi expr >> return (Nothing, Nothing)) + -- (const retry) + -- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi))) + Just ii' -> do ae <- give ii' Nothing expr + mv <- lookupMeta mi + let scope = getMetaScope mv + ce <- abstractToConcreteEnv (makeEnv scope) ae + let cmnt = if ii' == ii then agsyinfo ticks else "" + return (Just (ii', show ce ++ cmnt), Nothing) + -- Andreas, 2015-05-17, Issue 1504 + -- When Agsy produces an ill-typed solution, return nothing. + -- TODO: try other solution. + -- `catchError` const retry -- (return (Nothing, Nothing)) + let msg = if length exprs == 1 then + Nothing + else + Just $ "Also gave solution(s) for hole(s)" ++ + concatMap (\(mi', _) -> + if mi' == mi then "" else (" " ++ case lookup mi' riis of {Nothing -> show mi'; Just ii -> show ii}) + ) exprs + let msgs = catMaybes $ msg : map snd giveress + msg' = case msgs of + [] -> Nothing + _ -> Just $ unlines msgs + return (Left $ catMaybes $ map fst giveress, msg') MCaseSplit -> do case thisdefinfo of diff --git a/src/full/Agda/Auto/CaseSplit.hs b/src/full/Agda/Auto/CaseSplit.hs --- a/src/full/Agda/Auto/CaseSplit.hs +++ b/src/full/Agda/Auto/CaseSplit.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} +{-# 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 --- a/src/full/Agda/Auto/Convert.hs +++ b/src/full/Agda/Auto/Convert.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.Auto.Convert where import Control.Applicative hiding (getConst, Const(..)) @@ -462,7 +466,7 @@ fmLevel m I.ClosedLevel{} = False fmLevel m (I.Plus _ l) = case l of I.MetaLevel m' _ -> m == m' - I.NeutralLevel v -> fmExp m v + I.NeutralLevel _ v -> fmExp m v I.BlockedLevel _ v -> fmExp m v I.UnreducedLevel v -> fmExp m v @@ -667,7 +671,7 @@ let (Just ndrop, name) = cdorigin cdef ps' <- cnvps ndrop ps let con = I.ConHead name Common.Inductive [] -- TODO: restore record fields! - return (I.ConP con Nothing ps') + return (I.ConP con I.noConPatternInfo ps') CSPatExp e -> do e' <- frommyExp e {- renm e -} -- renaming before adding to clause below return (I.DotP e') diff --git a/src/full/Agda/Auto/NarrowingSearch.hs b/src/full/Agda/Auto/NarrowingSearch.hs --- a/src/full/Agda/Auto/NarrowingSearch.hs +++ b/src/full/Agda/Auto/NarrowingSearch.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} --- {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} module Agda.Auto.NarrowingSearch where @@ -19,10 +18,10 @@ type Prio = Int class Trav a blk | a -> blk where - traverse :: Monad m => (forall b . Trav b blk => MM b blk -> m ()) -> a -> m () + trav :: Monad m => (forall b . Trav b blk => MM b blk -> m ()) -> a -> m () instance Trav a blk => Trav (MM a blk) blk where - traverse f me = f me + trav f me = f me data Term blk = forall a . Trav a blk => Term a diff --git a/src/full/Agda/Auto/SearchControl.hs b/src/full/Agda/Auto/SearchControl.hs --- a/src/full/Agda/Auto/SearchControl.hs +++ b/src/full/Agda/Auto/SearchControl.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Agda.Auto.SearchControl where @@ -350,33 +349,27 @@ -- --------------------------------- instance Trav a blk => Trav [a] blk where - traverse _ [] = return () - traverse f (x:xs) = traverse f x >> traverse f xs + trav _ [] = return () + trav f (x:xs) = trav f x >> trav f xs instance Trav (MId, CExp o) (RefInfo o) where - traverse f (_, ce) = traverse f ce + trav f (_, ce) = trav f ce instance Trav (TrBr a o) (RefInfo o) where - traverse f (TrBr es _) = traverse f es + trav f (TrBr es _) = trav f es instance Trav (Exp o) (RefInfo o) where - traverse f e = case e of - App _ _ _ args -> traverse f args - Lam _ (Abs _ b) -> traverse f b - Pi _ _ _ it (Abs _ ot) -> traverse f it >> traverse f ot - Sort _ -> return () - - AbsurdLambda{} -> return () - + trav f e = case e of + App _ _ _ args -> trav f args + Lam _ (Abs _ b) -> trav f b + Pi _ _ _ it (Abs _ ot) -> trav f it >> trav f ot + Sort _ -> return () + AbsurdLambda{} -> return () instance Trav (ArgList o) (RefInfo o) where - traverse _ ALNil = return () - traverse f (ALCons _ arg args) = traverse f arg >> traverse f args - - traverse f (ALProj eas _ _ as) = traverse f eas >> traverse f as - - - traverse f (ALConPar args) = traverse f args - + trav _ ALNil = return () + trav f (ALCons _ arg args) = trav f arg >> trav f args + trav f (ALProj eas _ _ as) = trav f eas >> trav f as + trav f (ALConPar args) = trav f args -- --------------------------------- diff --git a/src/full/Agda/Auto/Syntax.hs b/src/full/Agda/Auto/Syntax.hs --- a/src/full/Agda/Auto/Syntax.hs +++ b/src/full/Agda/Auto/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} module Agda.Auto.Syntax where diff --git a/src/full/Agda/Auto/Typecheck.hs b/src/full/Agda/Auto/Typecheck.hs --- a/src/full/Agda/Auto/Typecheck.hs +++ b/src/full/Agda/Auto/Typecheck.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} module Agda.Auto.Typecheck where diff --git a/src/full/Agda/Compiler/CallCompiler.hs b/src/full/Agda/Compiler/CallCompiler.hs --- a/src/full/Agda/Compiler/CallCompiler.hs +++ b/src/full/Agda/Compiler/CallCompiler.hs @@ -75,7 +75,7 @@ exitcode <- liftIO $ do -- Ensure that the output has been read before waiting for the -- process. - E.evaluate (length errors) + _ <- E.evaluate (length errors) waitForProcess p case exitcode of diff --git a/src/full/Agda/Compiler/Epic/Erasure.hs b/src/full/Agda/Compiler/Epic/Erasure.hs --- a/src/full/Agda/Compiler/Epic/Erasure.hs +++ b/src/full/Agda/Compiler/Epic/Erasure.hs @@ -24,7 +24,7 @@ import Agda.TypeChecking.Monad.Base (TCM) import qualified Agda.Syntax.Internal as SI -import qualified Agda.Syntax.Common as SC +import qualified Agda.Syntax.Common as Common import Agda.TypeChecking.Monad (reportSDoc) import Agda.TypeChecking.Pretty as P @@ -133,20 +133,19 @@ Nothing -> return () initialRels :: SI.Type -> Relevance -> [Relevance] -initialRels ty rel = - case SI.unEl ty of - SI.Pi a b -> mkRel a : initialRels (SI.unAbs b) rel - _ -> [] +initialRels ty rel = case SI.unEl ty of + SI.Pi a b -> mkRel a : initialRels (SI.unAbs b) rel + _ -> [] where mkRel :: SI.Dom SI.Type -> Relevance - mkRel a | ignoreForced (SC.getRelevance a) = Irr - mkRel a = case SI.unEl (SC.unDom a) of - SI.Sort _ -> Irr - _ -> rel + mkRel a | ignoreForced (Common.getRelevance a) = Irr + mkRel a = case SI.unEl (Common.unDom a) of + SI.Sort _ -> Irr + _ -> rel -ignoreForced :: SC.Relevance -> Bool -ignoreForced SC.Relevant = False -ignoreForced _ = True +ignoreForced :: Common.Relevance -> Bool +ignoreForced Common.Relevant = False +ignoreForced _ = True -- | Calculate if a variable is relevant in an expression relevant :: (Functor m, Monad m) => Var -> Expr -> Erasure m Relevance diff --git a/src/full/Agda/Compiler/Epic/ForceConstrs.hs b/src/full/Agda/Compiler/Epic/ForceConstrs.hs --- a/src/full/Agda/Compiler/Epic/ForceConstrs.hs +++ b/src/full/Agda/Compiler/Epic/ForceConstrs.hs @@ -9,7 +9,7 @@ import Agda.Compiler.Epic.CompileState import Agda.Compiler.Epic.Interface -import qualified Agda.Syntax.Common as S +import qualified Agda.Syntax.Common as Common import qualified Agda.Syntax.Internal as T import Agda.TypeChecking.Monad (TCM) @@ -19,16 +19,16 @@ -- | Check which arguments are forced makeForcedArgs :: T.Type -> ForcedArgs makeForcedArgs (T.El _ term) = case term of - T.Pi arg ab -> isRel arg : makeForcedArgs (T.unAbs ab) - _ -> [] + T.Pi arg ab -> isRel arg : makeForcedArgs (T.unAbs ab) + _ -> [] where isRel :: T.Dom T.Type -> Forced - isRel arg = case S.getRelevance arg of - S.Relevant -> NotForced - S.Irrelevant -> Forced - S.UnusedArg -> Forced - S.NonStrict -> Forced -- can never be executed - S.Forced -> Forced -- It can be inferred + isRel arg = case Common.getRelevance arg of + Common.Relevant -> NotForced + Common.Irrelevant -> Forced + Common.UnusedArg -> Forced + Common.NonStrict -> Forced -- can never be executed + Common.Forced{} -> Forced -- It can be inferred -- | Remove forced arguments from constructors and branches forceConstrs :: [Fun] -> Compile TCM [Fun] diff --git a/src/full/Agda/Compiler/Epic/Forcing.hs b/src/full/Agda/Compiler/Epic/Forcing.hs --- a/src/full/Agda/Compiler/Epic/Forcing.hs +++ b/src/full/Agda/Compiler/Epic/Forcing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Agda.Compiler.Epic.Forcing where diff --git a/src/full/Agda/Compiler/Epic/FromAgda.hs b/src/full/Agda/Compiler/Epic/FromAgda.hs --- a/src/full/Agda/Compiler/Epic/FromAgda.hs +++ b/src/full/Agda/Compiler/Epic/FromAgda.hs @@ -47,7 +47,6 @@ f@(Function{}) -> do let projArgs = projectionArgs f cc = fromMaybe __IMPOSSIBLE__ $ funCompiled f - -- let projArgs = maybe 0 (pred . projIndex) (funProjection f) ccs <- reverseCCBody projArgs <$> normaliseStatic cc let len = (+ projArgs) . length . clausePats . head . funClauses $ f toEta = arity (defType defini) - len @@ -242,11 +241,6 @@ del <- getDelayed q def <- theDef <$> lift (getConstInfo q) let nr = projectionArgs def -{- MOVED to Signature.hs - case def of - Function{funProjection = Just p} -> pred $ projIndex p - _ -> 0 - -} f <- apps name . (replicate nr UNIT ++) <$> mapM (substTerm env . unArg) args return $ case del of True -> Lazy f diff --git a/src/full/Agda/Compiler/Epic/Injection.hs b/src/full/Agda/Compiler/Epic/Injection.hs --- a/src/full/Agda/Compiler/Epic/Injection.hs +++ b/src/full/Agda/Compiler/Epic/Injection.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} module Agda.Compiler.Epic.Injection where @@ -26,7 +23,7 @@ import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Builtin -import Agda.TypeChecking.Pretty hiding (empty) +import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.Utils.List @@ -69,8 +66,8 @@ replaceFunCC :: QName -> CompiledClauses -> Compile TCM () replaceFunCC name cc = lift $ do - stSignature %= \sig -> sig {sigDefinitions = HM.adjust replaceDef name (sigDefinitions sig)} - stImports %= \imp -> imp {sigDefinitions = HM.adjust replaceDef name (sigDefinitions imp)} + stSignature %= updateDefinition name replaceDef + stImports %= updateDefinition name replaceDef where replaceDef :: Definition -> Definition replaceDef def = case theDef def of @@ -123,7 +120,7 @@ where makeSubst i accum [] = raiseS (i + accum) makeSubst i accum (True : ps) = makeSubst i (accum +1) ps - makeSubst i accum (False : ps) = var (i + accum) :# makeSubst (i+1) accum ps + makeSubst i accum (False : ps) = consS (var $ i + accum) $ makeSubst (i+1) accum ps calcDots = concatMap calcDots' . map namedArg calcDots' p = case p of @@ -186,8 +183,8 @@ litInt _ = False insertAt :: (Nat,Term) -> Term -> Term -insertAt (index, ins) = - applySubst ([var i | i <- [0 .. index - 1]] ++# ins :# raiseS (index + 1)) +insertAt (index, ins) = applySubst $ + [var i | i <- [0 .. index - 1]] ++# consS ins (raiseS $ index + 1) solve :: [QName] -> [((QName, InjectiveFun), [(QName,QName)])] -> Compile TCM [(QName, InjectiveFun)] solve newNames xs = do @@ -216,7 +213,7 @@ let (hasTags, eqs) = Map.partition isTag (constrGroup tags) isTag (IsTag _) = True isTag _ = False - forM (Map.toList hasTags) $ \ (c, tagged) -> case tagged of + forM_ (Map.toList hasTags) $ \ (c, tagged) -> case tagged of IsTag tag -> putCon c tag _ -> __IMPOSSIBLE__ case Map.toList eqs of diff --git a/src/full/Agda/Compiler/Epic/Interface.hs b/src/full/Agda/Compiler/Epic/Interface.hs --- a/src/full/Agda/Compiler/Epic/Interface.hs +++ b/src/full/Agda/Compiler/Epic/Interface.hs @@ -10,7 +10,7 @@ import Data.Map(Map) import Data.Monoid import Data.Set (Set) -import Data.Typeable +import Data.Typeable ( Typeable ) import Agda.Syntax.Common (Nat) import Agda.Syntax.Internal diff --git a/src/full/Agda/Compiler/Epic/Static.hs b/src/full/Agda/Compiler/Epic/Static.hs --- a/src/full/Agda/Compiler/Epic/Static.hs +++ b/src/full/Agda/Compiler/Epic/Static.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} -- | Find the places where the builtin static is used and do some normalisation -- there. diff --git a/src/full/Agda/Compiler/JS/Compiler.hs b/src/full/Agda/Compiler/JS/Compiler.hs --- a/src/full/Agda/Compiler/JS/Compiler.hs +++ b/src/full/Agda/Compiler/JS/Compiler.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} module Agda.Compiler.JS.Compiler where @@ -443,21 +443,6 @@ Just <$> qname (conName con) _ -> return (Nothing) _ -> return (Nothing) - -{- OBSOLETE, see Signature.hs -defProjection :: Definition -> Maybe (QName, Int) -defProjection Defn { theDef = Function { funProjection = p } } = p -defProjection _ = Nothing --} - -{- -args :: Maybe Projection -> Args -> TCM [Exp] -args Nothing as = - mapM (term . unArg) as -args (Just p) as = do - es <- mapM (term . unArg) as - return (replicate (projIndex p - 1) Undefined ++ es) --} args :: Int -> Args -> TCM [Exp] args n as = (replicate n Undefined ++) <$> diff --git a/src/full/Agda/Compiler/MAlonzo/Compiler.hs b/src/full/Agda/Compiler/MAlonzo/Compiler.hs --- a/src/full/Agda/Compiler/MAlonzo/Compiler.hs +++ b/src/full/Agda/Compiler/MAlonzo/Compiler.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards #-} module Agda.Compiler.MAlonzo.Compiler where @@ -111,11 +111,8 @@ ((++) <$> importsForPrim <*> (List.map mazMod <$> mnames)) decl :: HS.ModuleName -> HS.ImportDecl -#if MIN_VERSION_haskell_src_exts(1,16,0) decl m = HS.ImportDecl dummy m True False False Nothing Nothing Nothing -#else - decl m = HS.ImportDecl dummy m True False Nothing Nothing Nothing -#endif + mnames :: TCM [ModuleName] mnames = (++) <$> (Set.elems <$> use stImportedModules) <*> (List.map fst . iImportedModules <$> curIF) @@ -149,7 +146,7 @@ definition :: Maybe CoinductionKit -> Definition -> TCM [HS.Decl] -- ignore irrelevant definitions {- Andreas, 2012-10-02: Invariant no longer holds -definition kit (Defn Forced _ _ _ _ _ _ _ _) = __IMPOSSIBLE__ +definition kit (Defn Forced{} _ _ _ _ _ _ _ _) = __IMPOSSIBLE__ definition kit (Defn UnusedArg _ _ _ _ _ _ _ _) = __IMPOSSIBLE__ definition kit (Defn NonStrict _ _ _ _ _ _ _ _) = __IMPOSSIBLE__ -} @@ -282,11 +279,8 @@ (a, _) <- conArityAndPars c Just (HsDefn _ hsc) <- compiledHaskell . defCompiledRep <$> getConstInfo c let pat = HS.PApp (HS.UnQual $ HS.Ident hsc) $ genericReplicate a HS.PWildCard -#if MIN_VERSION_haskell_src_exts(1,16,0) return $ HS.Alt dummy pat (HS.UnGuardedRhs $ HS.unit_con) (HS.BDecls []) -#else - return $ HS.Alt dummy pat (HS.UnGuardedAlt $ HS.unit_con) (HS.BDecls []) -#endif + cs <- mapM makeClause cs let rhs = case cs of [] -> fakeExp "()" -- There is no empty case statement in Haskell @@ -336,11 +330,9 @@ pat (ProjP _ ) = lift $ typeError $ NotImplemented $ "Compilation of copatterns" pat (VarP _ ) = do v <- gets head; modify tail; return v pat (DotP _ ) = pat (VarP dummy) -- WHY NOT: return HS.PWildCard -- SEE ABOVE -#if MIN_VERSION_haskell_src_exts(1,16,0) + pat (LitP (LitQName _ x)) = return $ litqnamepat x pat (LitP l ) = return $ HS.PLit HS.Signless $ hslit l -#else - pat (LitP l ) = return $ HS.PLit $ hslit l -#endif + pat p@(ConP c _ ps) = do -- Note that irr is applied once for every subpattern, so in the -- worst case it is quadratic in the size of the pattern. I @@ -431,7 +423,7 @@ LitInt _ _ -> do toN <- bltQual "NATURAL" mazIntegerToNat return $ HS.Var toN `HS.App` typed "Integer" LitFloat _ _ -> return $ typed "Double" - LitQName _ x -> litqname x + LitQName _ x -> return $ litqname x _ -> return $ l' where l' = HS.Lit $ hslit l typed = HS.ExpTypeSig dummy l' . HS.TyCon . rtmQual @@ -443,16 +435,28 @@ LitChar _ x -> HS.Char x LitQName _ x -> __IMPOSSIBLE__ -litqname :: QName -> TCM HS.Exp -litqname x = return $ +litqname :: QName -> HS.Exp +litqname x = HS.Con (HS.Qual mazRTE $ HS.Ident "QName") `HS.App` HS.Lit (HS.Int n) `HS.App` HS.Lit (HS.Int m) `HS.App` (rtmError "primQNameType: not implemented") `HS.App` - (rtmError "primQNameDefinition: not implemented") + (rtmError "primQNameDefinition: not implemented") `HS.App` + HS.Lit (HS.String $ show x ) where NameId n m = nameId $ qnameName x +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.PWildCard + , HS.PWildCard] + where + NameId n m = nameId $ qnameName x + condecl :: QName -> TCM (Nat, HS.ConDecl) condecl q = do (ar, np) <- conArityAndPars q @@ -460,11 +464,7 @@ cdecl :: QName -> Nat -> HS.ConDecl cdecl q n = HS.ConDecl (unqhname "C" q) -#if MIN_VERSION_haskell_src_exts(1,16,0) [ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ] -#else - [ HS.UnBangedTy $ HS.TyVar $ ihname "a" i | i <- [0 .. n - 1] ] -#endif tvaldecl :: QName -> Induction @@ -548,9 +548,9 @@ , "{-# RULES \"coerce-id\" forall (x :: a) . mazCoerce x = x #-}" , "" , "-- Builtin QNames, the third field is for the type." - , "data QName a b = QName { nameId, moduleId :: Integer, qnameType :: a, qnameDefinition :: b }" + , "data QName a b = QName { nameId, moduleId :: Integer, qnameType :: a, qnameDefinition :: b, qnameString :: String}" , "instance Eq (QName a b) where" - , " QName a b _ _ == QName c d _ _ = (a, b) == (c, d)" + , " QName a b _ _ _ == QName c d _ _ _ = (a, b) == (c, d)" , "" , "mazIncompleteMatch :: String -> a" , "mazIncompleteMatch s = error (\"MAlonzo Runtime Error: incomplete pattern matching: \" ++ s)" @@ -558,23 +558,12 @@ where parse :: String -> HS.ParseResult HS.Module parse = HS.parseModuleWithMode - HS.defaultParseMode{HS.extensions = [explicitForAll]} + HS.defaultParseMode + { HS.extensions = [ HS.EnableExtension HS.ExplicitForAll ] } ok :: HS.ParseResult HS.Module -> HS.Module ok (HS.ParseOk d) = d ok HS.ParseFailed{} = __IMPOSSIBLE__ - -explicitForAll :: HS.Extension -explicitForAll = --- GHC 7.0.1 cannot parse the following CPP conditional --- error: missing binary operator before token "(" -#if MIN_VERSION_haskell_src_exts(1,14,0) - HS.EnableExtension HS.ExplicitForAll -#elif MIN_VERSION_haskell_src_exts(1,12,0) - HS.ExplicitForAll -#else - HS.ExplicitForall -#endif compileDir :: TCM FilePath compileDir = do diff --git a/src/full/Agda/Compiler/MAlonzo/Pretty.hs b/src/full/Agda/Compiler/MAlonzo/Pretty.hs --- a/src/full/Agda/Compiler/MAlonzo/Pretty.hs +++ b/src/full/Agda/Compiler/MAlonzo/Pretty.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} ------------------------------------------------------------------------ -- Pretty-printing of Haskell modules diff --git a/src/full/Agda/Compiler/MAlonzo/Primitives.hs b/src/full/Agda/Compiler/MAlonzo/Primitives.hs --- a/src/full/Agda/Compiler/MAlonzo/Primitives.hs +++ b/src/full/Agda/Compiler/MAlonzo/Primitives.hs @@ -240,6 +240,7 @@ -- Reflection , "primQNameEquality" |-> rel "(==)" "MAlonzo.RTE.QName () ()" + , "primShowQName" |-> return "MAlonzo.RTE.qnameString" , "primQNameType" |-> return "MAlonzo.RTE.qnameType" , "primQNameDefinition" |-> return "MAlonzo.RTE.qnameDefinition" diff --git a/src/full/Agda/Interaction/BasicOps.hs b/src/full/Agda/Interaction/BasicOps.hs --- a/src/full/Agda/Interaction/BasicOps.hs +++ b/src/full/Agda/Interaction/BasicOps.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} module Agda.Interaction.BasicOps where @@ -136,7 +136,7 @@ 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 - giveExpr mi e `catchError` \ err -> case err of + _ <- catchError (giveExpr mi e) $ \ err -> case err of -- Turn PatternErr into proper error: PatternErr{} -> do err <- withInteractionId ii $ TP.text "Failed to give" TP.<+> prettyTCM e @@ -277,44 +277,48 @@ return $ Guard o pid reify (UnBlock m) = do mi <- mvInstantiation <$> lookupMeta m + m' <- reify (MetaV m []) case mi of BlockedConst t -> do e <- reify t - m' <- reify (MetaV m []) return $ Assign m' e PostponedTypeCheckingProblem cl _ -> enterClosure cl $ \p -> case p of CheckExpr e a -> do a <- reify a - m' <- reify (MetaV m []) return $ TypedAssign m' e a + CheckLambda (Arg ai (xs, mt)) body target -> do + domType <- maybe (return underscore) reify mt + target <- reify target + let bs = TypedBindings noRange $ Arg (mapArgInfoColors (const []) ai) $ + TBind noRange xs domType + e = A.Lam Info.exprNoRange (DomainFull bs) body + return $ TypedAssign m' e target CheckArgs _ _ _ args t0 t1 _ -> do t0 <- reify t0 t1 <- reify t1 - m <- reify (MetaV m []) - return $ PostponedCheckArgs m (map (namedThing . unArg) args) t0 t1 + return $ PostponedCheckArgs m' (map (namedThing . unArg) args) t0 t1 Open{} -> __IMPOSSIBLE__ OpenIFS{} -> __IMPOSSIBLE__ InstS{} -> __IMPOSSIBLE__ InstV{} -> __IMPOSSIBLE__ - reify (FindInScope m mcands) = do - let cands = caseMaybe mcands [] (\ x -> x) - m' <- reify (MetaV m []) - ctxArgs <- getContextArgs - t <- getMetaType m - t' <- reify t - cands' <- mapM (\(tm,ty) -> (,) <$> reify tm <*> reify ty) cands - return $ FindInScopeOF m' t' cands' -- IFSTODO + reify (FindInScope m mcands) = FindInScopeOF + <$> (reify $ MetaV m []) + <*> (reify =<< getMetaType m) + <*> (forM (fromMaybe [] mcands) $ \ (tm, ty) -> do + (,) <$> reify tm <*> reify ty) reify (IsEmpty r a) = IsEmptyType <$> reify a +-- ASR TODO (28 December 2014): This function will be unnecessary when +-- using a Pretty instance for OutputConstraint instead of the Show +-- instance. showComparison :: Comparison -> String -showComparison CmpEq = " = " -showComparison CmpLeq = " =< " +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 -> "[" ++ show pid ++ "] " ++ show c ++ range r + OutputForm r pid c -> "[" ++ prettyShow pid ++ "] " ++ show c ++ range r where range r | null s = "" | otherwise = " [ at " ++ s ++ " ]" @@ -330,7 +334,7 @@ show (CmpLevels cmp t t') = show t ++ showComparison cmp ++ show t' show (CmpTeles cmp t t') = show t ++ showComparison cmp ++ show t' show (CmpSorts cmp s s') = show s ++ showComparison cmp ++ show s' - show (Guard o pid) = show o ++ " [blocked by problem " ++ show pid ++ "]" + show (Guard o pid) = show o ++ " [blocked by problem " ++ prettyShow pid ++ "]" show (Assign m e) = show m ++ " := " ++ show e show (TypedAssign m e a) = show m ++ " := " ++ show e ++ " :? " ++ show a show (PostponedCheckArgs m es t0 t1) = show m ++ " := (_ : " ++ show t0 ++ ") " ++ unwords (map (paren . show) es) @@ -338,9 +342,11 @@ where paren s | elem ' ' s = "(" ++ s ++ ")" | otherwise = s show (IsEmptyType a) = "Is empty: " ++ show a - show (FindInScopeOF s t cs) = "Resolve instance argument " ++ showCand (s,t) ++ ". Candidates: [" ++ - intercalate ", " (map showCand cs) ++ "]" - where showCand (tm,ty) = show tm ++ " : " ++ show ty + show (FindInScopeOF s t cs) = "Resolve instance argument " ++ showCand (s,t) ++ ".\n Candidates:\n [ " ++ + intercalate "\n , " (map showCand cs) ++ " ]" + where showCand (tm,ty) = indent 6 $ show tm ++ " : " ++ show ty + indent n s = intercalate ("\n" ++ replicate n ' ') (l:ls) + where l:ls = lines s instance (ToConcrete a c, ToConcrete b d) => ToConcrete (OutputForm a b) (OutputForm c d) where @@ -387,11 +393,7 @@ instance ToConcrete NamedMeta C.Expr where toConcrete i = do - return $ C.Underscore noRange (Just $ show i) - -judgToOutputForm :: Judgement a c -> OutputConstraint a c -judgToOutputForm (HasType e t) = OfType e t -judgToOutputForm (IsSort s t) = JustSort s + return $ C.Underscore noRange (Just $ prettyShow i) getConstraints :: TCM [OutputForm C.Expr C.Expr] getConstraints = liftTCM $ do @@ -445,7 +447,7 @@ withMetaInfo (getMetaInfo mv) $ rewriteJudg mv (mvJudgement mv) where - rewriteJudg :: MetaVariable -> Judgement Type MetaId -> + rewriteJudg :: MetaVariable -> Judgement MetaId -> TCM (OutputConstraint Expr NamedMeta) rewriteJudg mv (HasType i t) = do ms <- getMetaNameSuggestion i @@ -458,7 +460,7 @@ [ TP.text "len =" TP.<+> TP.text (show $ length vs) , TP.text "args =" TP.<+> prettyTCM vs , TP.text "t =" TP.<+> prettyTCM t - , TP.text "x =" TP.<+> TP.text (show x) + , TP.text "x =" TP.<+> TP.pretty x ] ] OfType x <$> reify (t `piApply` permute (takeP (size vs) $ mvPermutation mv) vs) @@ -483,9 +485,14 @@ store <- Map.filterWithKey (openAndImplicit is) <$> getMetaStore mapM (typeOfMetaMI norm) $ Map.keys store where - openAndImplicit is x (MetaVar{mvInstantiation = M.Open}) = x `notElem` is - openAndImplicit is x (MetaVar{mvInstantiation = M.BlockedConst _}) = True - openAndImplicit _ _ _ = False + 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 + M.PostponedTypeCheckingProblem{} -> False metaHelperType :: Rewrite -> InteractionId -> Range -> String -> TCM (OutputConstraint' Expr Expr) metaHelperType norm ii rng s = case words s of @@ -720,17 +727,14 @@ Left err -> return [] Right cov -> mapM showTCM $ concatMap (conName . scPats) $ splitClauses cov + introRec :: QName -> TCM [String] introRec d = do hfs <- getRecordFieldNames d fs <- ifM showImplicitArguments (return $ map unArg hfs) (return [ unArg a | a <- hfs, getHiding a == NotHidden ]) - return - [ concat $ - "record {" : - intersperse ";" (map (\ f -> show f ++ " = ?") fs) ++ - ["}"] - ] + let e = C.Rec noRange $ map (, C.QuestionMark noRange Nothing) fs + return [ prettyShow e ] -- | Runs the given computation as if in an anonymous goal at the end -- of the top-level module. diff --git a/src/full/Agda/Interaction/CommandLine.hs b/src/full/Agda/Interaction/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Interaction/CommandLine.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE CPP #-} + +module Agda.Interaction.CommandLine where + +import Control.Monad.Reader +import Control.Applicative + +import Data.List as List +import Data.Maybe + +import Agda.Interaction.BasicOps as BasicOps hiding (parseExpr) +import Agda.Interaction.Monad + +import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Common +import qualified Agda.Syntax.Internal as I +import Agda.Syntax.Parser +import Agda.Syntax.Position +import Agda.Syntax.Scope.Base +import Agda.Syntax.Translation.ConcreteToAbstract +import Agda.Syntax.Abstract.Pretty + +import Text.PrettyPrint + +import Agda.TheTypeChecker +import Agda.TypeChecking.Constraints +import Agda.TypeChecking.Monad +import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Errors +import Agda.TypeChecking.Pretty ( PrettyTCM(prettyTCM) ) +import Agda.TypeChecking.Substitute + +import Agda.Utils.Except ( MonadError(catchError) ) +import Agda.Utils.Monad + +#include "undefined.h" +import Agda.Utils.Impossible + +data ExitCode a = Continue | ContinueIn TCEnv | Return a + +type Command a = (String, [String] -> TCM (ExitCode a)) + +matchCommand :: String -> [Command a] -> Either [String] ([String] -> TCM (ExitCode a)) +matchCommand x cmds = + case List.filter (isPrefixOf x . fst) cmds of + [(_,m)] -> Right m + xs -> Left $ List.map fst xs + +interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> IM a +interaction prompt cmds eval = loop + where + go (Return x) = return x + go Continue = loop + go (ContinueIn env) = local (const env) loop + + loop = + do ms <- readline prompt + case fmap words ms of + Nothing -> return $ error "** EOF **" + Just [] -> loop + Just ((':':cmd):args) -> + do case matchCommand cmd cmds of + Right c -> go =<< liftTCM (c args) + Left [] -> + do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "'" + loop + Left xs -> + do liftIO $ putStrLn $ "More than one command match: " ++ concat (intersperse ", " xs) + loop + Just _ -> + do go =<< liftTCM (eval $ fromJust ms) + `catchError` \e -> + do s <- liftTCM $ prettyError e + liftIO $ putStrLn s + loop + +-- | The interaction loop. +interactionLoop :: TCM (Maybe Interface) -> IM () +interactionLoop doTypeCheck = + do liftTCM reload + interaction "Main> " commands evalTerm + where + reload = do + mi <- doTypeCheck + -- Note that mi is Nothing if (1) there is no input file or + -- (2) the file type checked with unsolved metas and + -- --allow-unsolved-metas was used. In the latter case the + -- behaviour of agda -I may be surprising. If agda -I ever + -- becomes properly supported again, then this behaviour + -- should perhaps be fixed. + setScope $ case mi of + Just i -> iInsideScope i + Nothing -> emptyScopeInfo + `catchError` \e -> do + s <- prettyError e + liftIO $ putStrLn s + liftIO $ putStrLn "Failed." + + commands = + [ "quit" |> \_ -> return $ Return () + , "?" |> \_ -> continueAfter $ liftIO $ help commands + , "reload" |> \_ -> do reload + ContinueIn <$> ask + , "constraints" |> \args -> continueAfter $ showConstraints args + , "Context" |> \args -> continueAfter $ showContext args + , "give" |> \args -> continueAfter $ giveMeta args + , "Refine" |> \args -> continueAfter $ refineMeta args + , "metas" |> \args -> continueAfter $ showMetas args + , "load" |> \args -> continueAfter $ loadFile reload args + , "eval" |> \args -> continueAfter $ evalIn args + , "typeOf" |> \args -> continueAfter $ typeOf args + , "typeIn" |> \args -> continueAfter $ typeIn args + , "wakeup" |> \_ -> continueAfter $ retryConstraints + , "scope" |> \_ -> continueAfter $ showScope + ] + where + (|>) = (,) + +continueAfter :: TCM a -> TCM (ExitCode b) +continueAfter m = withCurrentFile $ do + m >> return Continue + +-- | Set 'envCurrentPath' to 'optInputFile'. +withCurrentFile :: TCM a -> TCM a +withCurrentFile cont = do + mpath <- getInputFile' + local (\ e -> e { envCurrentPath = mpath }) cont + +loadFile :: TCM () -> [String] -> TCM () +loadFile reload [file] = do + setInputFile file + withCurrentFile reload +loadFile _ _ = liftIO $ putStrLn ":load file" + +showConstraints :: [String] -> TCM () +showConstraints [] = + do cs <- BasicOps.getConstraints + liftIO $ putStrLn $ unlines (List.map show cs) +showConstraints _ = liftIO $ putStrLn ":constraints [cid]" + + +showMetas :: [String] -> TCM () +showMetas [m] = + do i <- InteractionId <$> readM m + withInteractionId i $ do + s <- typeOfMeta AsIs i + r <- getInteractionRange i + d <- showA s + liftIO $ putStrLn $ d ++ " " ++ show r +showMetas [m,"normal"] = + do i <- InteractionId <$> readM m + withInteractionId i $ do + s <- showA =<< typeOfMeta Normalised i + r <- getInteractionRange i + liftIO $ putStrLn $ s ++ " " ++ show r +showMetas [] = + do interactionMetas <- typesOfVisibleMetas AsIs + hiddenMetas <- typesOfHiddenMetas AsIs + mapM_ (liftIO . putStrLn) =<< mapM showII interactionMetas + mapM_ print' hiddenMetas + where + showII o = withInteractionId (outputFormId $ OutputForm noRange 0 o) $ showA o + showM o = withMetaId (nmid $ outputFormId $ OutputForm noRange 0 o) $ showA o + + metaId (OfType i _) = i + metaId (JustType i) = i + metaId (JustSort i) = i + metaId (Assign i e) = i + metaId _ = __IMPOSSIBLE__ + print' x = do + r <- getMetaRange $ nmid $ metaId x + d <- showM x + liftIO $ putStrLn $ d ++ " [ at " ++ show r ++ " ]" +showMetas _ = liftIO $ putStrLn $ ":meta [metaid]" + + +showScope :: TCM () +showScope = do + scope <- getScope + liftIO $ print scope + +metaParseExpr :: InteractionId -> String -> TCM A.Expr +metaParseExpr ii s = + do m <- lookupInteractionId ii + scope <- getMetaScope <$> lookupMeta m + r <- getRange <$> lookupMeta m + --liftIO $ putStrLn $ show scope + let pos = case rStart r of + Nothing -> __IMPOSSIBLE__ + Just pos -> pos + e <- liftIO $ parsePosString exprParser pos s + concreteToAbstract scope e + +actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a +actOnMeta (is:es) f = + do i <- readM is + let ii = InteractionId i + e <- metaParseExpr ii (unwords es) + withInteractionId ii $ f ii e +actOnMeta _ _ = __IMPOSSIBLE__ + + +giveMeta :: [String] -> TCM () +giveMeta s | length s >= 2 = do + _ <- actOnMeta s (\ii -> \e -> give ii Nothing e) + return () +giveMeta _ = liftIO $ putStrLn $ ": give" ++ " metaid expr" + + + +refineMeta :: [String] -> TCM () +refineMeta s | length s >= 2 = do + _ <- actOnMeta s (\ii -> \e -> refine ii Nothing e) + return () +refineMeta _ = liftIO $ putStrLn $ ": refine" ++ " metaid expr" + + + +retryConstraints :: TCM () +retryConstraints = liftTCM wakeupConstraints_ + + +evalIn :: [String] -> TCM () +evalIn s | length s >= 2 = + do d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent e + liftIO $ print d +evalIn _ = liftIO $ putStrLn ":eval metaid expr" + +parseExpr :: String -> TCM A.Expr +parseExpr s = do + e <- liftIO $ parse exprParser s + localToAbstract e return + +evalTerm :: String -> TCM (ExitCode a) +evalTerm s = + do e <- parseExpr s + v <- evalInCurrent e + e <- prettyTCM v + liftIO $ putStrLn $ show e + return Continue + where + evalInCurrent e = do + (v,t) <- inferExpr e + v' <- normalise v + return v' + + +typeOf :: [String] -> TCM () +typeOf s = + do e <- parseExpr (unwords s) + e0 <- typeInCurrent Normalised e + e1 <- typeInCurrent AsIs e + liftIO . putStrLn =<< showA e1 + +typeIn :: [String] -> TCM () +typeIn s@(_:_:_) = + actOnMeta s $ \i e -> + do e1 <- typeInMeta i Normalised e + e2 <- typeInMeta i AsIs e + liftIO . putStrLn =<< showA e1 +typeIn _ = liftIO $ putStrLn ":typeIn meta expr" + +showContext :: [String] -> TCM () +showContext (meta:args) = do + i <- InteractionId <$> readM meta + mi <- lookupMeta =<< lookupInteractionId i + withMetaInfo (getMetaInfo mi) $ do + ctx <- List.map unDom . telToList <$> getContextTelescope + zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx + where + display (x, t) n = do + t <- case args of + ["normal"] -> normalise $ raise n t + _ -> return $ raise n t + d <- prettyTCM t + liftIO $ print $ text (I.argNameToString x) <+> text ":" <+> d +showContext _ = liftIO $ putStrLn ":Context meta" + +-- | The logo that prints when Agda is started in interactive mode. +splashScreen :: String +splashScreen = unlines + [ " _ " + , " ____ | |" + , " / __ \\ | |" + , " | |__| |___ __| | ___" + , " | __ / _ \\/ _ |/ __\\ Agda Interactive" + , " | | |/ /_\\ \\/_| / /_| \\" + , " |_| |\\___ /____\\_____/ Type :? for help." + , " __/ /" + , " \\__/" + , "" + , "The interactive mode is no longer supported. Don't complain if it doesn't work." + ] + +-- | The help message +help :: [Command a] -> IO () +help cs = putStr $ unlines $ + [ "Command overview" ] ++ List.map explain cs ++ + [ " Infer type of expression and evaluate it." ] + where + explain (x,_) = ":" ++ x diff --git a/src/full/Agda/Interaction/CommandLine/CommandLine.hs b/src/full/Agda/Interaction/CommandLine/CommandLine.hs deleted file mode 100644 --- a/src/full/Agda/Interaction/CommandLine/CommandLine.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Agda.Interaction.CommandLine.CommandLine where - -import Control.Monad.Reader -import Control.Applicative - -import Data.List as List -import Data.Maybe - -import Agda.Interaction.BasicOps as BasicOps hiding (parseExpr) -import Agda.Interaction.Monad - -import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Common -import qualified Agda.Syntax.Internal as I -import Agda.Syntax.Parser -import Agda.Syntax.Position -import Agda.Syntax.Scope.Base -import Agda.Syntax.Translation.ConcreteToAbstract -import Agda.Syntax.Abstract.Pretty - -import Text.PrettyPrint - -import Agda.TheTypeChecker -import Agda.TypeChecking.Constraints -import Agda.TypeChecking.Monad -import Agda.TypeChecking.Reduce -import Agda.TypeChecking.Errors -import Agda.TypeChecking.Substitute - -import Agda.Utils.Except ( MonadError(catchError) ) -import Agda.Utils.Monad - -#include "undefined.h" -import Agda.Utils.Impossible - -data ExitCode a = Continue | ContinueIn TCEnv | Return a - -type Command a = (String, [String] -> TCM (ExitCode a)) - -matchCommand :: String -> [Command a] -> Either [String] ([String] -> TCM (ExitCode a)) -matchCommand x cmds = - case List.filter (isPrefixOf x . fst) cmds of - [(_,m)] -> Right m - xs -> Left $ List.map fst xs - -interaction :: String -> [Command a] -> (String -> TCM (ExitCode a)) -> IM a -interaction prompt cmds eval = loop - where - go (Return x) = return x - go Continue = loop - go (ContinueIn env) = local (const env) loop - - loop = - do ms <- readline prompt - case fmap words ms of - Nothing -> return $ error "** EOF **" - Just [] -> loop - Just ((':':cmd):args) -> - do case matchCommand cmd cmds of - Right c -> go =<< liftTCM (c args) - Left [] -> - do liftIO $ putStrLn $ "Unknown command '" ++ cmd ++ "'" - loop - Left xs -> - do liftIO $ putStrLn $ "More than one command match: " ++ concat (intersperse ", " xs) - loop - Just _ -> - do go =<< liftTCM (eval $ fromJust ms) - `catchError` \e -> - do s <- liftTCM $ prettyError e - liftIO $ putStrLn s - loop - --- | The interaction loop. -interactionLoop :: TCM (Maybe Interface) -> IM () -interactionLoop doTypeCheck = - do liftTCM reload - interaction "Main> " commands evalTerm - where - reload = do - mi <- doTypeCheck - -- Note that mi is Nothing if (1) there is no input file or - -- (2) the file type checked with unsolved metas and - -- --allow-unsolved-metas was used. In the latter case the - -- behaviour of agda -I may be surprising. If agda -I ever - -- becomes properly supported again, then this behaviour - -- should perhaps be fixed. - setScope $ case mi of - Just i -> iInsideScope i - Nothing -> emptyScopeInfo - `catchError` \e -> do - s <- prettyError e - liftIO $ putStrLn s - liftIO $ putStrLn "Failed." - - commands = - [ "quit" |> \_ -> return $ Return () - , "?" |> \_ -> continueAfter $ liftIO $ help commands - , "reload" |> \_ -> do reload - ContinueIn <$> ask - , "constraints" |> \args -> continueAfter $ showConstraints args - , "Context" |> \args -> continueAfter $ showContext args - , "give" |> \args -> continueAfter $ giveMeta args - , "Refine" |> \args -> continueAfter $ refineMeta args - , "metas" |> \args -> continueAfter $ showMetas args - , "load" |> \args -> continueAfter $ loadFile reload args - , "eval" |> \args -> continueAfter $ evalIn args - , "typeOf" |> \args -> continueAfter $ typeOf args - , "typeIn" |> \args -> continueAfter $ typeIn args - , "wakeup" |> \_ -> continueAfter $ retryConstraints - , "scope" |> \_ -> continueAfter $ showScope - ] - where - (|>) = (,) - -continueAfter :: TCM a -> TCM (ExitCode b) -continueAfter m = m >> return Continue - -loadFile :: TCM () -> [String] -> TCM () -loadFile reload [file] = - do setInputFile file - reload -loadFile _ _ = liftIO $ putStrLn ":load file" - -showConstraints :: [String] -> TCM () -showConstraints [] = - do cs <- BasicOps.getConstraints - liftIO $ putStrLn $ unlines (List.map show cs) -showConstraints _ = liftIO $ putStrLn ":constraints [cid]" - - -showMetas :: [String] -> TCM () -showMetas [m] = - do i <- InteractionId <$> readM m - withInteractionId i $ do - s <- typeOfMeta AsIs i - r <- getInteractionRange i - d <- showA s - liftIO $ putStrLn $ d ++ " " ++ show r -showMetas [m,"normal"] = - do i <- InteractionId <$> readM m - withInteractionId i $ do - s <- showA =<< typeOfMeta Normalised i - r <- getInteractionRange i - liftIO $ putStrLn $ s ++ " " ++ show r -showMetas [] = - do interactionMetas <- typesOfVisibleMetas AsIs - hiddenMetas <- typesOfHiddenMetas AsIs - mapM_ (liftIO . putStrLn) =<< mapM showII interactionMetas - mapM_ print' hiddenMetas - where - showII o = withInteractionId (outputFormId $ OutputForm noRange 0 o) $ showA o - showM o = withMetaId (nmid $ outputFormId $ OutputForm noRange 0 o) $ showA o - - metaId (OfType i _) = i - metaId (JustType i) = i - metaId (JustSort i) = i - metaId (Assign i e) = i - metaId _ = __IMPOSSIBLE__ - print' x = do - r <- getMetaRange $ nmid $ metaId x - d <- showM x - liftIO $ putStrLn $ d ++ " [ at " ++ show r ++ " ]" -showMetas _ = liftIO $ putStrLn $ ":meta [metaid]" - - -showScope :: TCM () -showScope = do - scope <- getScope - liftIO $ print scope - -metaParseExpr :: InteractionId -> String -> TCM A.Expr -metaParseExpr ii s = - do m <- lookupInteractionId ii - scope <- getMetaScope <$> lookupMeta m - r <- getRange <$> lookupMeta m - --liftIO $ putStrLn $ show scope - let pos = case rStart r of - Nothing -> __IMPOSSIBLE__ - Just pos -> pos - e <- liftIO $ parsePosString exprParser pos s - concreteToAbstract scope e - -actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a -actOnMeta (is:es) f = - do i <- readM is - let ii = InteractionId i - e <- metaParseExpr ii (unwords es) - withInteractionId ii $ f ii e -actOnMeta _ _ = __IMPOSSIBLE__ - - -giveMeta :: [String] -> TCM () -giveMeta s | length s >= 2 = - do actOnMeta s (\ii -> \e -> give ii Nothing e) - return () -giveMeta _ = liftIO $ putStrLn $ ": give" ++ " metaid expr" - - - -refineMeta :: [String] -> TCM () -refineMeta s | length s >= 2 = - do actOnMeta s (\ii -> \e -> refine ii Nothing e) - return () -refineMeta _ = liftIO $ putStrLn $ ": refine" ++ " metaid expr" - - - -retryConstraints :: TCM () -retryConstraints = liftTCM wakeupConstraints_ - - -evalIn :: [String] -> TCM () -evalIn s | length s >= 2 = - do d <- actOnMeta s $ \_ e -> prettyA =<< evalInCurrent e - liftIO $ print d -evalIn _ = liftIO $ putStrLn ":eval metaid expr" - -parseExpr :: String -> TCM A.Expr -parseExpr s = do - e <- liftIO $ parse exprParser s - localToAbstract e return - -evalTerm :: String -> TCM (ExitCode a) -evalTerm s = - do e <- parseExpr s - v <- evalInCurrent e - e <- prettyTCM v - liftIO $ putStrLn $ show e - return Continue - where - evalInCurrent e = do - (v,t) <- inferExpr e - v' <- normalise v - return v' - - -typeOf :: [String] -> TCM () -typeOf s = - do e <- parseExpr (unwords s) - e0 <- typeInCurrent Normalised e - e1 <- typeInCurrent AsIs e - liftIO . putStrLn =<< showA e1 - -typeIn :: [String] -> TCM () -typeIn s@(_:_:_) = - actOnMeta s $ \i e -> - do e1 <- typeInMeta i Normalised e - e2 <- typeInMeta i AsIs e - liftIO . putStrLn =<< showA e1 -typeIn _ = liftIO $ putStrLn ":typeIn meta expr" - -showContext :: [String] -> TCM () -showContext (meta:args) = do - i <- InteractionId <$> readM meta - mi <- lookupMeta =<< lookupInteractionId i - withMetaInfo (getMetaInfo mi) $ do - ctx <- List.map unDom . telToList <$> getContextTelescope - zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx - where - display (x, t) n = do - t <- case args of - ["normal"] -> normalise $ raise n t - _ -> return $ raise n t - d <- prettyTCM t - liftIO $ print $ text (I.argNameToString x) <+> text ":" <+> d -showContext _ = liftIO $ putStrLn ":Context meta" - --- | The logo that prints when Agda is started in interactive mode. -splashScreen :: String -splashScreen = unlines - [ " _ " - , " ____ | |" - , " / __ \\ | |" - , " | |__| |___ __| | ___" - , " | __ / _ \\/ _ |/ __\\ Agda Interactive" - , " | | |/ /_\\ \\/_| / /_| \\" - , " |_| |\\___ /____\\_____/ Type :? for help." - , " __/ /" - , " \\__/" - , "" - , "The interactive mode is no longer supported. Don't complain if it doesn't work." - ] - --- | The help message -help :: [Command a] -> IO () -help cs = putStr $ unlines $ - [ "Command overview" ] ++ List.map explain cs ++ - [ " Infer type of expression and evaluate it." ] - where - explain (x,_) = ":" ++ x diff --git a/src/full/Agda/Interaction/EmacsCommand.hs b/src/full/Agda/Interaction/EmacsCommand.hs --- a/src/full/Agda/Interaction/EmacsCommand.hs +++ b/src/full/Agda/Interaction/EmacsCommand.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------ -- | Code for instructing Emacs to do things diff --git a/src/full/Agda/Interaction/Exceptions.hs b/src/full/Agda/Interaction/Exceptions.hs --- a/src/full/Agda/Interaction/Exceptions.hs +++ b/src/full/Agda/Interaction/Exceptions.hs @@ -8,12 +8,14 @@ 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 -> String -> IO a) -> IO a -> IO a +failOnException :: (Range -> Doc -> IO a) -> IO a -> IO a failOnException h m = m `E.catch` handleParseException handler where - handler x = h (getRange x) (show x) + handler x = h (getRange x) (pretty x) diff --git a/src/full/Agda/Interaction/Highlighting/Generate.hs b/src/full/Agda/Interaction/Highlighting/Generate.hs --- a/src/full/Agda/Interaction/Highlighting/Generate.hs +++ b/src/full/Agda/Interaction/Highlighting/Generate.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RelaxedPolyRec #-} +{-# LANGUAGE RelaxedPolyRec #-} -- | Generates data used for precise syntax highlighting. @@ -20,10 +20,29 @@ import Prelude hiding (null) +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +import Control.Monad.Reader +import Control.Applicative +import Control.Arrow ((***), first, second) + +import Data.Monoid +import Data.Generics.Geniplate +import Data.HashSet (HashSet) +import qualified Data.HashSet as HSet +import qualified Data.Map as Map +import Data.Maybe +import Data.List ((\\), isPrefixOf) +import qualified Data.Foldable as Fold (toList, fold, foldMap) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + import Agda.Interaction.FindFile import Agda.Interaction.Response (Response(Resp_HighlightingInfo)) import Agda.Interaction.Highlighting.Precise hiding (tests) import Agda.Interaction.Highlighting.Range hiding (tests) + import qualified Agda.TypeChecking.Errors as E import Agda.TypeChecking.MetaVars (isBlockedTerm) import Agda.TypeChecking.Monad @@ -31,9 +50,10 @@ import qualified Agda.TypeChecking.Monad as M import Agda.TypeChecking.Pretty import qualified Agda.TypeChecking.Reduce as R + import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common (Delayed(..)) -import qualified Agda.Syntax.Common as SC +import qualified Agda.Syntax.Common as Common import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Info as SI import qualified Agda.Syntax.Internal as I @@ -41,33 +61,17 @@ import qualified Agda.Syntax.Parser as Pa import qualified Agda.Syntax.Parser.Tokens as T import qualified Agda.Syntax.Position as P + +import Agda.Utils.FileName +import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List +import Agda.Utils.Maybe +import Agda.Utils.Null import Agda.Utils.TestHelpers import Agda.Utils.HashMap (HashMap) import qualified Agda.Utils.HashMap as HMap -import Control.Monad -import Control.Monad.Trans -import Control.Monad.State -import Control.Monad.Reader -import Control.Applicative -import Control.Arrow ((***), first, second) -import Data.Monoid -import Data.Generics.Geniplate -import Agda.Utils.FileName -import Data.HashSet (HashSet) -import qualified Data.HashSet as HSet -import qualified Data.Map as Map -import Data.Maybe -import Data.List ((\\), isPrefixOf) -import qualified Data.Foldable as Fold (toList, fold, foldMap) -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Agda.Utils.Functor -import Agda.Utils.Maybe -import Agda.Utils.Null - #include "undefined.h" import Agda.Utils.Impossible @@ -144,7 +148,7 @@ generateAndPrintSyntaxInfo :: A.Declaration -> Level -> TCM () generateAndPrintSyntaxInfo decl _ | P.noRange == P.getRange decl = return () generateAndPrintSyntaxInfo decl hlLevel = do - file <- envCurrentPath <$> ask + file <- fromMaybe __IMPOSSIBLE__ <$> asks envCurrentPath reportSLn "import.iface.create" 15 $ "Generating syntax info for " ++ filePath file ++ ' ' : @@ -223,8 +227,10 @@ bound n = nameToFile modMap file [] (A.nameConcrete n) (\isOp -> mempty { aspect = Just $ Name (Just Bound) isOp }) (Just $ A.nameBindingSite n) + patsyn n = nameToFileA modMap file n True $ \isOp -> - mempty { aspect = Just $ Name (Just $ Constructor SC.Inductive) isOp } + mempty { aspect = Just $ Name (Just $ Constructor Common.Inductive) isOp } + field m n = nameToFile modMap file m n (\isOp -> mempty { aspect = Just $ Name (Just Field) isOp }) Nothing @@ -232,6 +238,7 @@ n (\isOp -> mempty { aspect = Just $ Name (Just Module) isOp }) Nothing + mod isTopLevelModule n = nameToFile modMap file [] (A.nameConcrete n) @@ -246,7 +253,7 @@ -- Ulf, 2014-04-09: It would be nicer to have it on Named_ a, but -- you can't have polymorphic functions in universeBi. - getNamedArg :: SC.RString -> File + getNamedArg :: Common.RString -> File getNamedArg x = singleton (rToR $ P.getRange x) mempty{ aspect = Just $ Name (Just Argument) False } getLet :: A.LetBinding -> File @@ -260,11 +267,11 @@ getLam (A.DomainFull {}) = mempty getTyped :: A.TypedBinding -> File - getTyped (A.TBind _ xs _) = mconcat $ map bound xs + getTyped (A.TBind _ xs _) = mconcat $ map (bound . dget) xs getTyped A.TLet{} = mempty getPatSynArgs :: A.Declaration -> File - getPatSynArgs (A.PatternSynDef _ xs _) = mconcat $ map (bound . SC.unArg) xs + getPatSynArgs (A.PatternSynDef _ xs _) = mconcat $ map (bound . Common.unArg) xs getPatSynArgs _ = mempty getPattern :: A.Pattern -> File @@ -416,20 +423,20 @@ declToKind (A.Pragma {}) = id declToKind (A.ScopedDecl {}) = id declToKind (A.Open {}) = id - declToKind (A.PatternSynDef q _ _) = insert q (Constructor SC.Inductive) + declToKind (A.PatternSynDef q _ _) = insert q (Constructor Common.Inductive) declToKind (A.FunDef _ q _ _) = insert q Function declToKind (A.UnquoteDecl _ _ q _) = insert q Function declToKind (A.DataSig _ q _ _) = insert q Datatype declToKind (A.DataDef _ q _ cs) = \m -> insert q Datatype $ foldr (\d -> insert (A.axiomName d) - (Constructor SC.Inductive)) + (Constructor Common.Inductive)) m cs declToKind (A.RecSig _ q _ _) = insert q Record declToKind (A.RecDef _ q _ c _ _ _) = insert q Record . case c of Nothing -> id - Just q -> insert q (Constructor SC.Inductive) + Just q -> insert q (Constructor Common.Inductive) -- | Generates syntax highlighting information for all constructors -- occurring in patterns and expressions in the given declaration. diff --git a/src/full/Agda/Interaction/Highlighting/HTML.hs b/src/full/Agda/Interaction/Highlighting/HTML.hs --- a/src/full/Agda/Interaction/Highlighting/HTML.hs +++ b/src/full/Agda/Interaction/Highlighting/HTML.hs @@ -5,6 +5,13 @@ module Agda.Interaction.Highlighting.HTML ( generateHTML + -- Reused by PandocAgda + , defaultCSSFile + , generateHTMLWithPageGen + , generatePage + , page + , tokenStream + , code ) where import Control.Applicative @@ -57,7 +64,22 @@ -- completed successfully. generateHTML :: TCM () -generateHTML = do +generateHTML = generateHTMLWithPageGen pageGen + where + pageGen dir mod hinfo = generatePage renderer dir mod + where + renderer css _ contents = page css mod $ code $ tokenStream contents hinfo + +-- | Prepare information for HTML page generation. +-- +-- The page generator receives the file path of the module, +-- the top level module name of the module +-- and the highlighting information of the module. + +generateHTMLWithPageGen + :: (FilePath -> C.TopLevelModuleName -> CompressedFile -> TCM ()) -- ^ Page generator + -> TCM () +generateHTMLWithPageGen generatePage = do options <- TCM.commandLineOptions -- There is a default directory given by 'defaultHTMLDir' @@ -87,15 +109,14 @@ modToFile :: C.TopLevelModuleName -> FilePath modToFile m = render (pretty m) <.> "html" --- | Generates an HTML file with a highlighted, hyperlinked version of --- the given module. +-- | Generates a highlighted, hyperlinked version of the given module. generatePage - :: FilePath -- ^ Directory in which to create files. + :: (FilePath -> FilePath -> String -> String) -- ^ Page renderer + -> FilePath -- ^ Directory in which to create files. -> C.TopLevelModuleName -- ^ Module to be highlighted. - -> HighlightingInfo -- ^ Syntax highlighting info for the module. -> TCM () -generatePage dir mod highlighting = do +generatePage renderpage dir mod = do mf <- Map.lookup mod <$> use TCM.stModuleToSource case mf of Nothing -> __IMPOSSIBLE__ @@ -103,21 +124,20 @@ contents <- liftIO $ UTF8.readTextFile $ filePath f css <- maybe defaultCSSFile id . optCSSFile <$> TCM.commandLineOptions - let html = page css mod contents highlighting + let html = renderpage css (filePath f) contents TCM.reportSLn "html" 1 $ "Generating HTML for " ++ render (pretty mod) ++ " (" ++ target ++ ")." - liftIO $ UTF8.writeFile target (renderHtml html) + liftIO $ UTF8.writeFile target html where target = dir modToFile mod -- | Constructs the web page, including headers. page :: FilePath -- ^ URL to the CSS file. -> C.TopLevelModuleName -- ^ Module to be highlighted. - -> String -- ^ The contents of the module. - -> CompressedFile -- ^ Highlighting information. -> Html -page css modName contents info = + -> String +page css modName pagecontent = renderHtml $ header (thetitle << render (pretty modName) +++ meta ! [ httpequiv "Content-Type" @@ -133,16 +153,15 @@ , thetype "text/css" ]) +++ - body << pre << code contents info + body << pre << pagecontent --- | Constructs the HTML displaying the code. +-- | Constructs token stream ready to print. -code :: String -- ^ The contents of the module. +tokenStream + :: String -- ^ The contents of the module. -> CompressedFile -- ^ Highlighting information. - -> Html -code contents info = - mconcat $ - map (\(pos, s, mi) -> annotate pos mi (stringToHtml s)) $ + -> [(Int, String, Aspects)] -- ^ (position, contents, info) +tokenStream contents info = map (\cs -> case cs of (mi, (pos, _)) : _ -> (pos, map (snd . snd) cs, maybe mempty id mi) @@ -153,6 +172,12 @@ where infoMap = toMap (decompress info) +-- | Constructs the HTML displaying the code. + +code :: [(Int, String, Aspects)] + -> Html +code = mconcat . map (\(pos, s, mi) -> annotate pos mi (stringToHtml s)) + where annotate :: Int -> Aspects -> Html -> Html annotate pos mi = anchor ! attributes where diff --git a/src/full/Agda/Interaction/Highlighting/LaTeX.hs b/src/full/Agda/Interaction/Highlighting/LaTeX.hs --- a/src/full/Agda/Interaction/Highlighting/LaTeX.hs +++ b/src/full/Agda/Interaction/Highlighting/LaTeX.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} -- | Function for generating highlighted and aligned LaTeX from literate diff --git a/src/full/Agda/Interaction/Highlighting/Precise.hs b/src/full/Agda/Interaction/Highlighting/Precise.hs --- a/src/full/Agda/Interaction/Highlighting/Precise.hs +++ b/src/full/Agda/Interaction/Highlighting/Precise.hs @@ -47,7 +47,7 @@ import qualified Data.Map as Map import Data.Typeable (Typeable) -import qualified Agda.Syntax.Common as C +import qualified Agda.Syntax.Common as Common import qualified Agda.Syntax.Concrete as SC import Agda.Interaction.Highlighting.Range @@ -72,16 +72,16 @@ -- | @NameKind@s are figured our during scope checking. data NameKind - = Bound -- ^ Bound variable. - | Constructor C.Induction -- ^ Inductive or coinductive constructor. + = Bound -- ^ Bound variable. + | Constructor Common.Induction -- ^ Inductive or coinductive constructor. | Datatype - | Field -- ^ Record field. + | Field -- ^ Record field. | Function - | Module -- ^ Module name. + | Module -- ^ Module name. | Postulate - | Primitive -- ^ Primitive. - | Record -- ^ Record type. - | Argument -- ^ Named argument, like x in {x = v} + | Primitive -- ^ Primitive. + | Record -- ^ Record type. + | Argument -- ^ Named argument, like x in {x = v} deriving (Eq, Show, Typeable) -- | Other aspects, generated by type checking. @@ -449,7 +449,7 @@ instance Arbitrary CompressedFile where arbitrary = do rs <- (\ns1 ns2 -> toRanges $ sort $ - ns1 ++ concatMap (\n -> [n, succ n]) ns2) <$> + ns1 ++ concatMap (\n -> [n, succ n]) (ns2 :: [Int])) <$> arbitrary <*> arbitrary CompressedFile <$> mapM (\r -> (,) r <$> arbitrary) rs where diff --git a/src/full/Agda/Interaction/Imports.hs b/src/full/Agda/Interaction/Imports.hs --- a/src/full/Agda/Interaction/Imports.hs +++ b/src/full/Agda/Interaction/Imports.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + {-| This module deals with finding imported modules and loading their interface files. -} @@ -28,8 +32,6 @@ import qualified Text.PrettyPrint.Boxes as Boxes -import Paths_Agda (getDataFileName) - import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Abstract.Name @@ -46,12 +48,12 @@ import Agda.TypeChecking.Serialise import Agda.TypeChecking.Telescope import Agda.TypeChecking.Primitive -import Agda.TypeChecking.Monad.Benchmark (billTop, reimburseTop) import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TheTypeChecker import Agda.Interaction.FindFile +import {-# SOURCE #-} Agda.Interaction.InteractionTop (showOpenMetas) import Agda.Interaction.Options import qualified Agda.Interaction.Options.Lenses as Lens import Agda.Interaction.Highlighting.Precise (HighlightingInfo) @@ -131,7 +133,7 @@ " visited: " ++ intercalate ", " (map (render . pretty) visited) -- Since scopeCheckImport is called from the scope checker, -- we need to reimburse her account. - i <- reimburseTop Bench.Scoping $ getInterface x + i <- Bench.billTo [] $ getInterface x addImport x return (iModuleName i `withRangesOfQ` mnameToConcrete x, iScope i) @@ -179,11 +181,11 @@ -- liftIO $ putStrLn $ "This is typeCheckMain " ++ show f -- liftIO . putStrLn . show =<< getVerbosity reportSLn "import.main" 10 $ "Importing the primitive modules." - libpath <- liftIO $ getDataFileName "lib" - reportSLn "import.main" 20 $ "Library path = " ++ show libpath + libdir <- liftIO defaultLibDir + reportSLn "import.main" 20 $ "Library dir = " ++ show libdir -- To allow posulating the built-ins, check the primitive module -- in unsafe mode - bracket_ (gets $ Lens.getSafeMode) Lens.putSafeMode $ do + _ <- bracket_ (gets $ Lens.getSafeMode) Lens.putSafeMode $ do Lens.putSafeMode False -- Turn off import-chasing messages. -- We have to modify the persistent verbosity setting, since @@ -194,7 +196,7 @@ withHighlightingLevel None $ getInterface_ =<< do moduleName $ mkAbsolute $ - libpath "prim" "Agda" "Primitive.agda" + libdir "prim" "Agda" "Primitive.agda" reportSLn "import.main" 10 $ "Done importing the primitive modules." -- Now do the type checking via getInterface. @@ -245,7 +247,7 @@ reportSLn "import.iface" 10 $ " Check for cycle" checkForImportCycle - uptodate <- billTop Bench.Import $ 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 @@ -279,7 +281,7 @@ else " New module. Let's check it out." unless (visited || stateChangesIncluded) $ do mergeInterface i - billTop Bench.Highlighting $ + Bench.billTo [Bench.Highlighting] $ ifTopLevelAndHighlightingLevelIs NonInteractive $ highlightFromInterface i file @@ -324,7 +326,7 @@ let ifile = filePath $ toIFile file h <- fmap snd <$> getInterfaceFileHashes ifile mm <- getDecodedModule x - (cached, mi) <- billTop Bench.Deserialization $ case mm of + (cached, mi) <- Bench.billTo [Bench.Deserialization] $ case mm of Just mi -> if Just (iFullHash mi) /= h then do dropDecodedModule x @@ -516,9 +518,10 @@ -> C.TopLevelModuleName -- ^ The expected module name. -> TCM (Interface, MaybeWarnings) createInterface file mname = - local (\e -> e { envCurrentPath = file }) $ do + local (\e -> e { envCurrentPath = Just file }) $ do modFile <- use stModuleToSource - fileTokenInfo <- billTop Bench.Highlighting $ generateTokenInfo file + fileTokenInfo <- Bench.billTo [Bench.Highlighting] $ + generateTokenInfo file stTokens .= fileTokenInfo reportSLn "import.iface.create" 5 $ @@ -531,7 +534,7 @@ previousHsImports <- getHaskellImports -- Parsing. - (pragmas, top) <- billTop Bench.Parsing $ + (pragmas, top) <- Bench.billTo [Bench.Parsing] $ liftIO $ parseFile' moduleParser file pragmas <- concat <$> concreteToAbstract_ pragmas @@ -542,20 +545,20 @@ mapM_ setOptionsFromPragma options -- Scope checking. - topLevel <- billTop Bench.Scoping $ + topLevel <- Bench.billTo [Bench.Scoping] $ concreteToAbstract_ (TopLevel file top) let ds = topLevelDecls topLevel -- Highlighting from scope checker. - billTop Bench.Highlighting $ do + Bench.billTo [Bench.Highlighting] $ do ifTopLevelAndHighlightingLevelIs NonInteractive $ do -- Generate and print approximate syntax highlighting info. printHighlightingInfo fileTokenInfo mapM_ (\ d -> generateAndPrintSyntaxInfo d Partial) ds -- Type checking. - billTop Bench.Typing $ checkDecls ds + Bench.billTo [Bench.Typing] $ checkDecls ds -- Ulf, 2013-11-09: Since we're rethrowing the error, leave it up to the -- code that handles that error to reset the state. @@ -573,7 +576,7 @@ tickN "metas" (fromIntegral n) -- Highlighting from type checker. - billTop Bench.Highlighting $ do + Bench.billTo [Bench.Highlighting] $ do -- Move any remaining token highlighting to stSyntaxInfo. toks <- use stTokens @@ -591,13 +594,16 @@ -- Serialization. syntaxInfo <- use stSyntaxInfo - i <- billTop Bench.Serialization $ do + i <- Bench.billTo [Bench.Serialization] $ do buildInterface file topLevel syntaxInfo previousHsImports options -- TODO: It would be nice if unsolved things were highlighted -- after every mutual block. - unsolvedMetas <- List.nub <$> (mapM getMetaRange =<< getOpenMetas) + openMetas <- getOpenMetas + unless (null openMetas) $ do + reportSLn "import.metas" 10 . unlines =<< showOpenMetas + unsolvedMetas <- List.nub <$> mapM getMetaRange openMetas unsolvedConstraints <- getAllConstraints interactionPoints <- getInteractionPoints @@ -605,7 +611,7 @@ printUnsolvedInfo r <- if and [ null unsolvedMetas, null unsolvedConstraints, null interactionPoints ] - then billTop Bench.Serialization $ do + 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 @@ -655,7 +661,10 @@ ms <- getImports mhs <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms hsImps <- getHaskellImports - patsyns <- getPatternSyns + -- Andreas, 2015-02-09 kill ranges in pattern synonyms before + -- serialization to avoid error locations pointing to external files + -- when expanding a pattern synoym. + patsyns <- killRange <$> getPatternSyns h <- liftIO $ hashFile file let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin reportSLn "import.iface" 7 " instantiating all meta variables" diff --git a/src/full/Agda/Interaction/InteractionTop.hs b/src/full/Agda/Interaction/InteractionTop.hs --- a/src/full/Agda/Interaction/InteractionTop.hs +++ b/src/full/Agda/Interaction/InteractionTop.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} - {-# OPTIONS -fno-cse #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + module Agda.Interaction.InteractionTop ( module Agda.Interaction.InteractionTop ) where +import Prelude hiding (null) + import Control.Applicative hiding (empty) import qualified Control.Exception as E import Control.Monad.Identity @@ -25,7 +26,7 @@ import qualified Data.Char as Char import Data.Foldable (Foldable) import Data.Function -import Data.List as List +import Data.List as List hiding (null) import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map @@ -58,6 +59,7 @@ import Agda.Interaction.FindFile import Agda.Interaction.Options +import Agda.Interaction.Options.Lenses as Lenses import Agda.Interaction.MakeCase import Agda.Interaction.Response hiding (Function, ExtendedLambda) import qualified Agda.Interaction.Response as R @@ -84,7 +86,9 @@ import Agda.Utils.Hash import qualified Agda.Utils.HashMap as HMap import Agda.Utils.Lens +import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.Pretty import Agda.Utils.String import Agda.Utils.Time @@ -217,7 +221,7 @@ when (not (independent cmd) && Just current /= (fst <$> cf)) $ lift $ typeError $ GenericError "Error: First load the file." - interpret cmd + withCurrentFile $ interpret cmd cf <- gets theCurrentFile when (Just current == (fst <$> cf)) $ @@ -234,7 +238,10 @@ -- If an independent command fails we should reset theCurrentFile (Issue853). let sErr | independent cmd = s { theCurrentFile = Nothing } | otherwise = s - (x, s') <- lift (runStateT m s `catchError_` \e -> runStateT (h e) sErr) + (x, s') <- lift $ do + disableDestructiveUpdate (runStateT m s) + `catchError_` \ e -> + runStateT (h e) sErr put s' return x @@ -246,8 +253,9 @@ -- | Handle nasty errors like stack space overflow (issue 637) -- We assume that the input action handles other kind of errors. handleNastyErrors :: CommandM () -> CommandM () - handleNastyErrors m = commandMToIO $ \toIO -> - toIO m `E.catch` (toIO . handleErr . Exception noRange . (show :: E.SomeException -> String)) + handleNastyErrors m = commandMToIO $ \ toIO -> + toIO m `E.catch` \ (e :: E.SomeException) -> + toIO $ handleErr $ Exception noRange $ text $ show e -- | Displays an error and instructs Emacs to jump to the site of the -- error. Because this function may switch the focus to another file @@ -517,31 +525,11 @@ display_info . Info_Constraints . unlines . map show =<< lift B.getConstraints interpret Cmd_metas = do -- CL.showMetas [] - ims <- lift $ B.typesOfVisibleMetas B.AsIs - -- Show unsolved implicit arguments simplified. - hms <- lift $ B.typesOfHiddenMetas B.Simplified - if not $ null ims && null hms - then do - di <- lift $ forM ims $ \i -> B.withInteractionId (B.outputFormId $ B.OutputForm noRange 0 i) (showATop i) - dh <- lift $ mapM showA' hms - display_info $ Info_AllGoals $ unlines $ di ++ dh - else do - cs <- lift B.getConstraints - if null cs - then display_info $ Info_AllGoals "" - else interpret Cmd_constraints - where - metaId (B.OfType i _) = i - metaId (B.JustType i) = i - metaId (B.JustSort i) = i - metaId (B.Assign i e) = i - metaId _ = __IMPOSSIBLE__ - showA' :: B.OutputConstraint A.Expr NamedMeta -> TCM String - showA' m = do - let i = nmid $ metaId m - r <- getMetaRange i - d <- B.withMetaId i (showATop m) - return $ d ++ " [ at " ++ show r ++ " ]" + 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) interpret (Cmd_show_module_contents_toplevel norm s) = liftCommandMT B.atTopLevel $ showModuleContents norm noRange s @@ -606,7 +594,7 @@ return Nothing mapM_ putResponse resp -interpret (Cmd_highlight ii rng s) = withCurrentFile $ do +interpret (Cmd_highlight ii rng s) = do scope <- getOldInteractionScope ii removeOldInteractionScope ii handle $ do @@ -647,7 +635,8 @@ ] interpret (Cmd_refine_or_intro pmLambda ii r s) = interpret $ - (if null s then Cmd_intro pmLambda else Cmd_refine) ii r s + let s' = trim s + in (if null s' then Cmd_intro pmLambda else Cmd_refine) ii r s' interpret (Cmd_auto ii rng s) = do -- Andreas, 2014-07-05 Issue 1226: @@ -762,10 +751,33 @@ interpret Cmd_show_version = display_info Info_Version -type GoalCommand = InteractionId -> Range -> String -> Interaction +-- | 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) $ + showATop i + -- Show unsolved implicit arguments simplified. + dh <- mapM showA' =<< B.typesOfHiddenMetas B.Simplified + return $ di ++ dh + where + metaId (B.OfType i _) = i + metaId (B.JustType i) = i + metaId (B.JustSort i) = i + metaId (B.Assign i e) = i + metaId _ = __IMPOSSIBLE__ + showA' :: B.OutputConstraint A.Expr NamedMeta -> TCM String + showA' m = do + let i = nmid $ metaId m + r <- getMetaRange i + d <- B.withMetaId i (showATop m) + return $ d ++ " [ at " ++ show r ++ " ]" --- | @cmd_load' m includes cmd cmd2@ loads the module in file @m@, --- using @includes@ as the include directories. + +-- | @cmd_load' file includes unsolvedOk cmd@ +-- loads the module in file @file@, +-- using @includes@ as the include directories. -- -- If type checking completes without any exceptions having been -- encountered then the command @cmd r@ is executed, where @r@ is the @@ -778,7 +790,7 @@ cmd_load' file includes unsolvedOK cmd = do f <- liftIO $ absolute file ex <- liftIO $ doesFileExist $ filePath f - lift $ setIncludeDirs includes $ + lift $ TM.setIncludeDirs includes $ if ex then ProjectRoot f else CurrentDir -- Forget the previous "current file" and interaction points. @@ -795,12 +807,9 @@ opts <- lift $ commandLineOptions defaultOptions <- gets optionsOnReload setCommandLineOptions' $ - defaultOptions { optIncludeDirs = optIncludeDirs opts - , optPragmaOptions = - (optPragmaOptions defaultOptions) - { optAllowUnsolved = unsolvedOK - } - } + Lenses.setIncludeDirs (optIncludeDirs opts) $ + mapPragmaOptions (\ o -> o { optAllowUnsolved = unsolvedOK }) $ + defaultOptions -- Reset the state, preserving options and decoded modules. Note -- that if the include directories have changed, then the decoded @@ -828,10 +837,11 @@ cmd ok +-- | Set 'envCurrentPath' to 'theCurrentFile', if any. withCurrentFile :: CommandM a -> CommandM a withCurrentFile m = do - Just (file, _) <- gets $ theCurrentFile - local (\e -> e { envCurrentPath = file }) m + mfile <- fmap fst <$> gets theCurrentFile + local (\ e -> e { envCurrentPath = mfile }) m -- | Available backends. @@ -857,8 +867,12 @@ -> String -> GiveRefine -> CommandM () -give_gen ii rng s giveRefine = withCurrentFile $ do +give_gen ii rng s0 giveRefine = do + let s = trim s0 lift $ reportSLn "interaction.give" 20 $ "give_gen " ++ s + -- Andreas, 2015-02-26 if string is empty do nothing rather + -- than giving a parse error. + unless (null s) $ do let give_ref = case giveRefine of Give -> B.give @@ -981,7 +995,7 @@ showModuleContents norm rng s = do (modules, types) <- lift $ B.moduleContents norm rng s types' <- lift $ forM types $ \ (x, t) -> do - t <- prettyTCM t + t <- TCP.prettyTCM t return (show x, text ":" <+> t) display_info $ Info_ModuleContents $ text "Modules" $$ @@ -1021,7 +1035,7 @@ where asVar :: TCM Doc asVar = do - TCP.text "* a variable bound at" TCP.<+> prettyTCM (nameBindingSite $ localVar x) + TCP.text "* a variable bound at" TCP.<+> TCP.prettyTCM (nameBindingSite $ localVar x) shadowing :: LocalVar -> TCM Doc shadowing LocalVar{} = TCP.text "shadowing" shadowing ShadowedVar{} = TCP.text "in conflict with" @@ -1050,20 +1064,20 @@ TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a)) pWhy :: Range -> WhyInScope -> TCM Doc - pWhy r Defined = TCP.text "- its definition at" TCP.<+> prettyTCM r + pWhy r Defined = TCP.text "- its definition at" TCP.<+> TCP.prettyTCM r pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w pWhy r (Opened m w) = TCP.text "- the opening of" TCP.<+> TCP.text (show m) TCP.<+> TCP.text "at" - TCP.<+> prettyTCM (getRange m) + TCP.<+> TCP.prettyTCM (getRange m) TCP.$$ pWhy r w pWhy r (Applied m w) = TCP.text "- the application of" TCP.<+> TCP.text (show m) TCP.<+> TCP.text "at" - TCP.<+> prettyTCM (getRange m) + TCP.<+> TCP.prettyTCM (getRange m) TCP.$$ pWhy r w diff --git a/src/full/Agda/Interaction/InteractionTop.hs-boot b/src/full/Agda/Interaction/InteractionTop.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/Interaction/InteractionTop.hs-boot @@ -0,0 +1,5 @@ +module Agda.Interaction.InteractionTop where + +import Agda.TypeChecking.Monad.Base (TCM) + +showOpenMetas :: TCM [String] diff --git a/src/full/Agda/Interaction/MakeCase.hs b/src/full/Agda/Interaction/MakeCase.hs --- a/src/full/Agda/Interaction/MakeCase.hs +++ b/src/full/Agda/Interaction/MakeCase.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Agda.Interaction.MakeCase where @@ -28,6 +28,7 @@ import Agda.TypeChecking.Irrelevance import Agda.TheTypeChecker +import Agda.Interaction.Options import Agda.Interaction.BasicOps import Agda.Utils.Functor @@ -164,18 +165,24 @@ let vars = words s if null vars then do -- split result - (newPats, sc) <- fixTarget (clauseToSplitClause clause) - res <- splitResult f sc - scs <- case res of - Nothing -> if newPats then return [sc] else - typeError $ GenericError $ "Cannot split on result here" - Just cov -> mapM (snd <.> fixTarget) $ splitClauses cov + (newPats, 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. + -- To split on result, he can then C-c C-c again. + scs <- if newPats then return [sc] else do + res <- splitResult f sc + 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 else do -- split on variables vars <- parseVariables hole rng vars (casectxt,) <$> split f vars clause where + failNoCop = typeError $ GenericError $ + "OPTION --copatterns needed to split on result here" split :: QName -> [Nat] -> Clause -> TCM [A.Clause] split f [] clause = (:[]) <$> makeAbstractClause f (clauseToSplitClause clause) diff --git a/src/full/Agda/Interaction/Monad.hs b/src/full/Agda/Interaction/Monad.hs --- a/src/full/Agda/Interaction/Monad.hs +++ b/src/full/Agda/Interaction/Monad.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} module Agda.Interaction.Monad where diff --git a/src/full/Agda/Interaction/Options.hs b/src/full/Agda/Interaction/Options.hs --- a/src/full/Agda/Interaction/Options.hs +++ b/src/full/Agda/Interaction/Options.hs @@ -1,10 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ <= 706 -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE StandaloneDeriving #-} -#endif - module Agda.Interaction.Options ( CommandLineOptions(..) , PragmaOptions(..) @@ -26,40 +21,51 @@ , mapFlag , usage , tests + , defaultLibDir + -- Reused by PandocAgda + , inputFlag + , standardOptions + , getOptSimple ) where import Control.Monad ( when ) -import Data.Maybe ( isJust ) + +-- base-4.7 defines the Functor instances for OptDescr and ArgDescr +#if !(MIN_VERSION_base(4,7,0)) +import Data.Orphans () +#endif + +import Data.Maybe import Data.List ( isSuffixOf , intercalate ) -import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(ReturnInOrder) +import System.Console.GetOpt ( getOpt', usageInfo, ArgOrder(ReturnInOrder) , OptDescr(..), ArgDescr(..) ) +import System.Directory ( doesDirectoryExist ) +import Text.EditDistance + import Agda.Termination.CutOff ( CutOff(..) ) import Agda.Utils.TestHelpers ( runTests ) import Agda.Utils.QuickCheck ( quickCheck' ) -import Agda.Utils.FileName ( AbsolutePath ) -import Agda.Utils.Monad ( readM ) -import Agda.Utils.List ( wordsBy ) +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 qualified Agda.Utils.Trie as Trie import Agda.Utils.Except ( MonadError(catchError, throwError) ) +-- Paths_Agda.hs is in $(BUILD_DIR)/build/autogen/. +import Paths_Agda ( getDataFileName ) + -- | This should probably go somewhere else. isLiterate :: FilePath -> Bool isLiterate file = ".lagda" `isSuffixOf` file -- OptDescr is a Functor -------------------------------------------------- --- base-4.7 defines these -#if !(MIN_VERSION_base(4,7,0)) -deriving instance Functor OptDescr -deriving instance Functor ArgDescr -#endif - type Verbosity = Trie String Int type IncludeDirs = Either [FilePath] [AbsolutePath] @@ -390,8 +396,10 @@ compileFlagNoMain :: Flag CommandLineOptions compileFlagNoMain o = return $ o { optCompileNoMain = True } +-- The Epic backend has been disabled. See Issue 1481. compileEpicFlag :: Flag CommandLineOptions -compileEpicFlag o = return $ o { optEpicCompile = True} +-- compileEpicFlag o = return $ o { optEpicCompile = True} +compileEpicFlag o = throwError "the Epic backend has been disabled" compileJSFlag :: Flag CommandLineOptions compileJSFlag o = return $ o { optJSCompile = True } @@ -404,8 +412,10 @@ ghcFlag f o = return $ o { optGhcFlags = optGhcFlags o ++ [f] } -- NOTE: Quadratic in number of flags. +-- The Epic backend has been disabled. See Issue 1481. epicFlagsFlag :: String -> Flag CommandLineOptions -epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] } +-- epicFlagsFlag s o = return $ o { optEpicFlags = optEpicFlags o ++ [s] } +epicFlagsFlag s o = throwError "the Epic backend has been disabled" htmlFlag :: Flag CommandLineOptions htmlFlag o = return $ o { optGenerateHTML = True } @@ -459,14 +469,23 @@ "compile program using the MAlonzo backend (experimental)" , Option [] ["no-main"] (NoArg compileFlagNoMain) "when compiling using the MAlonzo backend (experimental), do not treat the requested module as the main module of a program" - , Option [] ["epic"] (NoArg compileEpicFlag) "compile program using the Epic backend" + + -- The Epic backend has been disabled. See Issue 1481. + , Option [] ["epic"] (NoArg compileEpicFlag) + -- "compile program using the Epic backend" + "the Epic backend has been disabled" + , Option [] ["js"] (NoArg compileJSFlag) "compile program using the JS backend" , Option [] ["compile-dir"] (ReqArg compileDirFlag "DIR") ("directory for compiler output (default: the project root)") , Option [] ["ghc-flag"] (ReqArg ghcFlag "GHC-FLAG") "give the flag GHC-FLAG to GHC when compiling using MAlonzo" + + -- The Epic backend has been disabled. See Issue 1481. , Option [] ["epic-flag"] (ReqArg epicFlagsFlag "EPIC-FLAG") - "give the flag EPIC-FLAG to Epic when compiling using Epic" + -- "give the flag EPIC-FLAG to Epic when compiling using Epic" + "the Epic backend has been disabled" + , Option [] ["test"] (NoArg runTestsFlag) "run internal test suite" , Option [] ["vim"] (NoArg vimFlag) @@ -552,19 +571,59 @@ standardOptions_ :: [OptDescr ()] standardOptions_ = map (fmap $ const ()) standardOptions --- | Don't export -parseOptions' :: - [String] -> [OptDescr (Flag opts)] -> (String -> Flag opts) -> Flag opts -parseOptions' argv opts fileArg = \defaults -> - case getOpt (ReturnInOrder fileArg) opts argv of - (o,_,[]) -> foldl (>>=) (return defaults) o - (_,_,errs) -> throwError $ concat errs +-- | Simple interface for System.Console.GetOpt +-- Could be moved to Agda.Utils.Options (does not exist yet) +getOptSimple + :: [String] -- ^ command line argument words + -> [OptDescr (Flag opts)] -- ^ options handlers + -> (String -> Flag opts) -- ^ handler of non-options (only one is allowed) + -> Flag opts -- ^ combined opts data structure transformer +getOptSimple argv opts fileArg = \ defaults -> + case getOpt' (ReturnInOrder fileArg) opts argv of + (o, _, [] , [] ) -> foldl (>>=) (return defaults) o + (_, _, unrecognized, errs) -> throwError $ umsg ++ emsg + where + ucap = "Unrecognized " ++ plural unrecognized "option" ++ ":" + ecap = plural errs "Option error" ++ ":" + umsg = if null unrecognized then "" else unlines $ + ucap : map suggest unrecognized + emsg = if null errs then "" else unlines $ + ecap : errs + plural [_] x = x + plural _ x = x ++ "s" + + -- Suggest alternatives that are at most 3 typos away + + longopts :: [String] + longopts = map ("--" ++) $ concat $ map (\ (Option _ long _ _) -> long) opts + + dist :: String -> String -> Int + dist s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t + + close :: String -> String -> Maybe (Int, String) + close s t = let d = dist s t in if d <= 3 then Just (d, t) else Nothing + + closeopts :: String -> [(Int, String)] + closeopts s = mapMaybe (close s) longopts + + alts :: String -> [[String]] + alts s = map (map snd) $ groupOn fst $ closeopts s + + suggest :: String -> String + suggest s = case alts s of + [] -> s + as : _ -> s ++ " (did you mean " ++ sugs as ++ " ?)" + + sugs :: [String] -> String + sugs [a] = a + sugs as = "any of " ++ intercalate " " as + -- | Parse the standard options. parseStandardOptions :: [String] -> Either String CommandLineOptions parseStandardOptions argv = checkOpts =<< - parseOptions' argv standardOptions inputFlag defaultOptions + getOptSimple argv standardOptions inputFlag defaultOptions -- | Parse options from an options pragma. parsePragmaOptions @@ -574,16 +633,16 @@ -- ^ Command-line options which should be updated. -> Either String PragmaOptions parsePragmaOptions argv opts = do - ps <- parseOptions' argv pragmaOptions + ps <- getOptSimple argv pragmaOptions (\s _ -> throwError $ "Bad option in pragma: " ++ s) (optPragmaOptions opts) - checkOpts (opts { optPragmaOptions = ps }) + _ <- checkOpts (opts { optPragmaOptions = ps }) return ps -- | Parse options for a plugin. parsePluginOptions :: [String] -> [OptDescr (Flag opts)] -> Flag opts parsePluginOptions argv opts = - parseOptions' argv opts + getOptSimple argv opts (\s _ -> throwError $ "Internal error: Flag " ++ s ++ " passed to a plugin") @@ -612,6 +671,18 @@ inheritedOptions [] = "" inheritedOptions pls = "\n Inherits options from: " ++ unwords pls + +------------------------------------------------------------------------ +-- Some paths + +-- | Returns the absolute default lib dir. This directory is used to +-- store the Primitive.agda file. +defaultLibDir :: IO FilePath +defaultLibDir = do + libdir <- fmap filePath (absolute =<< getDataFileName "lib") + ifM (doesDirectoryExist libdir) + (return libdir) + (error $ "The lib directory " ++ libdir ++ " does not exist") ------------------------------------------------------------------------ -- All tests diff --git a/src/full/Agda/Interaction/Response.hs b/src/full/Agda/Interaction/Response.hs --- a/src/full/Agda/Interaction/Response.hs +++ b/src/full/Agda/Interaction/Response.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------ -- | Data type for all interactive responses diff --git a/src/full/Agda/Main.hs b/src/full/Agda/Main.hs --- a/src/full/Agda/Main.hs +++ b/src/full/Agda/Main.hs @@ -7,18 +7,15 @@ import Control.Monad.State import Control.Applicative -import qualified Data.List as List import Data.Maybe import System.Environment import System.Exit -import qualified Text.PrettyPrint.Boxes as Boxes - import Agda.Syntax.Concrete.Pretty () import Agda.Syntax.Abstract.Name (toTopLevelModuleName) -import Agda.Interaction.CommandLine.CommandLine +import Agda.Interaction.CommandLine import Agda.Interaction.Options import Agda.Interaction.Monad import Agda.Interaction.EmacsTop (mimicGHCi) @@ -29,7 +26,6 @@ import Agda.Interaction.Highlighting.HTML import Agda.TypeChecking.Monad -import Agda.TypeChecking.Monad.Benchmark import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Errors @@ -39,9 +35,7 @@ import Agda.Utils.Lens import Agda.Utils.Monad -import Agda.Utils.Pretty (prettyShow) import Agda.Utils.String -import qualified Agda.Utils.Trie as Trie import Agda.Tests import Agda.Version @@ -59,38 +53,32 @@ let opts = parseStandardOptions argv case opts of Left err -> liftIO $ optionError err - Right opts - | optShowHelp opts -> liftIO printUsage - | optShowVersion opts -> liftIO printVersion - | optRunTests opts -> liftIO $ do + Right opts -> runAgdaWithOptions generateHTML progName opts + +-- | Run Agda with parsed command line options and with a custom HTML generator +runAgdaWithOptions + :: TCM () -- ^ HTML generating action + -> String -- ^ program name + -> CommandLineOptions -- ^ parsed command line options + -> TCM () +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) - -> liftIO printUsage - | otherwise -> do + = liftIO printUsage + | otherwise = do setCommandLineOptions opts -- Main function. -- Bill everything to root of Benchmark trie. - billTo [] $ checkFile + Bench.billTo [] $ checkFile -- Print benchmarks. - whenM benchmarking $ do - (accounts, times) <- List.unzip . Trie.toList <$> getBenchmark - -- Generate a table. - let showAccount [] = "Total time" - showAccount ks = List.concat . List.intersperse "." . map show $ ks - -- First column is accounts. - col1 = Boxes.vcat Boxes.left $ - map (Boxes.text . showAccount) $ - accounts - -- Second column is times. - col2 = Boxes.vcat Boxes.right $ - map (Boxes.text . prettyShow) $ - times - table = Boxes.hsep 1 Boxes.left [col1, col2] - reportBenchmarkingLn $ Boxes.render table + Bench.print -- Print accumulated statistics. printStatistics 20 Nothing =<< use lensAccumStatistics @@ -179,10 +167,10 @@ printUsage exitFailure --- | Main -main :: IO () -main = do - r <- runTCMTop $ runAgda `catchError` \err -> do +-- | Run a TCM action in IO; catch and pretty print errors. +runTCMPrettyErrors :: TCM () -> IO () +runTCMPrettyErrors tcm = do + r <- runTCMTop $ tcm `catchError` \err -> do s <- prettyError err liftIO $ putStrLn s throwError err @@ -192,3 +180,7 @@ `catchImpossible` \e -> do putStr $ show e exitFailure + +-- | Main +main :: IO () +main = runTCMPrettyErrors runAgda diff --git a/src/full/Agda/Syntax/Abstract.hs b/src/full/Agda/Syntax/Abstract.hs --- a/src/full/Agda/Syntax/Abstract.hs +++ b/src/full/Agda/Syntax/Abstract.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + DeriveFoldable, + DeriveFunctor, + DeriveTraversable, + FlexibleInstances, + MultiParamTypeClasses, + TemplateHaskell #-} {-| The abstract syntax. This is what you get after desugaring and scope analysis of the concrete syntax. The type checker works on abstract syntax, @@ -117,7 +117,7 @@ deriving (Typeable, Eq, Ord, Show) -- | Renaming (generic). -type Ren a = Map a a +type Ren a = [(a, a)] data Declaration = Axiom Axiom DefInfo ArgInfo QName Expr -- ^ type signature (can be irrelevant and colored, but not hidden) @@ -170,6 +170,9 @@ data Pragma = OptionsPragma [String] | BuiltinPragma String Expr + | BuiltinNoDefPragma String QName + -- ^ Builtins that do not come with a definition, + -- but declare a name for an Agda concept. | RewritePragma QName | CompiledPragma QName String | CompiledExportPragma QName String @@ -209,20 +212,25 @@ -- ^ . @(xs : e)@ or @{xs : e}@ deriving (Typeable, Show) --- | A typed binding. Appears in dependent function spaces, typed lambdas, and --- telescopes. I might be tempting to simplify this to only bind a single --- name at a time. This would mean that we would have to typecheck the type --- several times (@(x y : A)@ vs. @(x : A)(y : A)@). --- In most cases this wouldn't really be a problem, but it's good --- principle to not do extra work unless you have to. +-- | A typed binding. Appears in dependent function spaces, typed lambdas, and +-- telescopes. It might be tempting to simplify this to only bind a single +-- name at a time, and translate, say, @(x y : A)@ to @(x : A)(y : A)@ +-- before type-checking. However, this would be slightly problematic: -- --- (Andreas, 2013-12-10: The more serious problem would that the translation --- from @(x y : ?)@ to @(x : ?) (y : ?)@ duplicates the hole @?@. +-- 1. We would have to typecheck the type @A@ several times. +-- +-- 2. If @A@ contains a meta variable or hole, it would be duplicated +-- by such a translation. +-- +-- While 1. is only slightly inefficient, 2. would be an outright bug. +-- Duplicating @A@ could not be done naively, we would have to make sure +-- that the metas of the copy are aliases of the metas of the original. + data TypedBinding - = TBind Range [Name] Expr + = TBind Range [WithHiding Name] Expr -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@. | TLet Range [LetBinding] - -- ^ + -- ^ E.g. @(let x = e)@ or @(let open M)@. deriving (Typeable, Show) type Telescope = [TypedBindings] @@ -244,7 +252,7 @@ | AbsurdRHS | WithRHS QName [Expr] [Clause] -- ^ The 'QName' is the name of the with function. - | RewriteRHS [QName] [Expr] RHS [Declaration] + | 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@. @@ -399,6 +407,16 @@ Instances --------------------------------------------------------------------------} +instance LensHiding TypedBindings where + getHiding (TypedBindings _ a) = getHiding a + mapHiding f (TypedBindings r a) = TypedBindings r $ mapHiding f a + +instance LensHiding LamBinding where + getHiding (DomainFree ai _) = getHiding ai + getHiding (DomainFull tb) = getHiding tb + mapHiding f (DomainFree ai x) = mapHiding f ai `DomainFree` x + mapHiding f (DomainFull tb) = DomainFull $ mapHiding f tb + instance HasRange LamBinding where getRange (DomainFree _ x) = getRange x getRange (DomainFull b) = getRange b @@ -488,7 +506,7 @@ getRange AbsurdRHS = noRange getRange (RHS e) = getRange e getRange (WithRHS _ e cs) = fuseRange e cs - getRange (RewriteRHS _ es rhs wh) = getRange (es, rhs, wh) + getRange (RewriteRHS xes rhs wh) = getRange (map snd xes, rhs, wh) instance HasRange LetBinding where getRange (LetBind i _ _ _ _ ) = getRange i @@ -531,17 +549,15 @@ killRange (App i e1 e2) = killRange3 App i e1 e2 killRange (WithApp i e es) = killRange3 WithApp i e es killRange (Lam i b e) = killRange3 Lam i b e - killRange (AbsurdLam i h) = killRange1 AbsurdLam i h + killRange (AbsurdLam i h) = killRange2 AbsurdLam i h killRange (ExtendedLam i n d ps) = killRange4 ExtendedLam i n d ps killRange (Pi i a b) = killRange3 Pi i a b killRange (Fun i a b) = killRange3 Fun i a b - killRange (Set i n) = Set (killRange i) n + killRange (Set i n) = killRange2 Set i n killRange (Prop i) = killRange1 Prop i killRange (Let i ds e) = killRange3 Let i ds e - killRange (Rec i fs) = Rec (killRange i) (map (id -*- killRange) fs) - killRange (RecUpdate i e fs) = RecUpdate (killRange i) - (killRange e) - (map (id -*- killRange) fs) + killRange (Rec i fs) = killRange2 Rec i fs + killRange (RecUpdate i e fs) = killRange3 RecUpdate i e fs killRange (ETel tel) = killRange1 ETel tel killRange (ScopedExpr s e) = killRange1 (ScopedExpr s) e killRange (QuoteGoal i x e) = killRange3 QuoteGoal i x e @@ -549,7 +565,7 @@ killRange (Quote i) = killRange1 Quote i killRange (QuoteTerm i) = killRange1 QuoteTerm i killRange (Unquote i) = killRange1 Unquote i - killRange (DontCare e) = DontCare e + killRange (DontCare e) = killRange1 DontCare e killRange (PatternSyn x) = killRange1 PatternSyn x instance KillRange Declaration where @@ -608,7 +624,7 @@ killRange AbsurdRHS = AbsurdRHS killRange (RHS e) = killRange1 RHS e killRange (WithRHS q e cs) = killRange3 WithRHS q e cs - killRange (RewriteRHS x es rhs wh) = killRange4 RewriteRHS x es rhs wh + 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 @@ -685,7 +701,7 @@ allNames (RHS e) = allNames e allNames AbsurdRHS{} = Seq.empty allNames (WithRHS q _ cls) = q <| allNames cls - allNames (RewriteRHS qs _ rhs cls) = Seq.fromList qs >< allNames rhs >< allNames cls + allNames (RewriteRHS qes rhs cls) = Seq.fromList (map fst qes) >< allNames rhs >< allNames cls instance AllNames Expr where allNames Var{} = Seq.empty @@ -892,4 +908,3 @@ matchArgs r (n:ns) as = do (p, as) <- matchNextArg r n as first ((unArg n, p) :) <$> matchArgs (getRange p) ns as - diff --git a/src/full/Agda/Syntax/Abstract/Copatterns.hs b/src/full/Agda/Syntax/Abstract/Copatterns.hs --- a/src/full/Agda/Syntax/Abstract/Copatterns.hs +++ b/src/full/Agda/Syntax/Abstract/Copatterns.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} module Agda.Syntax.Abstract.Copatterns (translateCopatternClauses) where @@ -263,6 +262,10 @@ rename' :: NameMap -> e -> e rename' rho = rename (flip lookup rho) +-- | 'QName's are not renamed. +instance Rename QName where + rename _ q = q + instance Rename Expr where rename rho e = case e of @@ -325,19 +328,13 @@ RHS e -> RHS (rename rho e) AbsurdRHS -> e WithRHS n es cs -> WithRHS n (rename rho es) (rename rho cs) - RewriteRHS ns es r ds -> RewriteRHS ns (rename rho es) (rename rho r) (rename rho ds) + RewriteRHS nes r ds -> RewriteRHS (rename rho nes) (rename rho r) (rename rho ds) instance Rename LHS where rename rho (LHS i core ps) = LHS i (rename rho core) (rename rho ps) instance Rename LHSCore where rename rho = fmap (rename rho) -- only rename in dot patterns -{- - rename rho = ren where - ren e = case e of - LHSHead f ps -> LHSHead f (ren ps) - LHSProj d ps1 core ps2 -> LHSProj d (ren ps1) (ren core) (ren ps2) --} instance Rename Pattern where rename rho = fmap (rename rho) -- only rename in dot patterns @@ -354,6 +351,8 @@ instance Rename a => Rename [a] where rename rho = map (rename rho) +instance (Rename a, Rename b) => Rename (a, b) where + rename rho (a,b) = (rename rho a, rename rho b) diff --git a/src/full/Agda/Syntax/Abstract/Name.hs b/src/full/Agda/Syntax/Abstract/Name.hs --- a/src/full/Agda/Syntax/Abstract/Name.hs +++ b/src/full/Agda/Syntax/Abstract/Name.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} {-| Abstract names carry unique identifiers and stuff. -} @@ -288,6 +287,9 @@ instance Pretty QName where pretty = hcat . punctuate (text ".") . map pretty . qnameToList +instance Pretty AmbiguousQName where + pretty (AmbQ qs) = hcat $ punctuate (text " | ") $ map pretty qs + ------------------------------------------------------------------------ -- * Range instances ------------------------------------------------------------------------ @@ -326,23 +328,25 @@ -- ** KillRange instance KillRange Name where - killRange x = x { nameConcrete = killRange $ nameConcrete x - -- Andreas, 2014-03-30 - -- An experiment: what happens if we preserve - -- the range of the binding site, but kill all - -- other ranges before serialization? - -- Andreas, Makoto, 2014-10-18 AIM XX - -- Kill all ranges in signature, including nameBindingSite. - , nameBindingSite = noRange - } + killRange (Name a b c d) = killRange4 Name a b c d + -- killRange x = x { nameConcrete = killRange $ nameConcrete x + -- -- Andreas, 2014-03-30 + -- -- An experiment: what happens if we preserve + -- -- the range of the binding site, but kill all + -- -- other ranges before serialization? + -- -- Andreas, Makoto, 2014-10-18 AIM XX + -- -- Kill all ranges in signature, including nameBindingSite. + -- , nameBindingSite = noRange + -- } instance KillRange ModuleName where killRange (MName xs) = MName $ killRange xs instance KillRange QName where - killRange q = q { qnameModule = killRange $ qnameModule q - , qnameName = killRange $ qnameName q - } + killRange (QName a b) = killRange2 QName a b + -- killRange q = q { qnameModule = killRange $ qnameModule q + -- , qnameName = killRange $ qnameName q + -- } instance KillRange AmbiguousQName where killRange (AmbQ xs) = AmbQ $ killRange xs diff --git a/src/full/Agda/Syntax/Abstract/Name.hs-boot b/src/full/Agda/Syntax/Abstract/Name.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/Abstract/Name.hs-boot @@ -0,0 +1,10 @@ +module Agda.Syntax.Abstract.Name where + +import {-# SOURCE #-} Agda.Syntax.Fixity (Fixity') + +data Name + +instance Show Name +instance Ord Name + +nameFixity :: Name -> Fixity' diff --git a/src/full/Agda/Syntax/Abstract/Views.hs b/src/full/Agda/Syntax/Abstract/Views.hs --- a/src/full/Agda/Syntax/Abstract/Views.hs +++ b/src/full/Agda/Syntax/Abstract/Views.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} module Agda.Syntax.Abstract.Views where @@ -59,7 +59,7 @@ -- * Traversal -- | Apply an expression rewriting to every subexpression, inside-out. --- See 'Agda.Syntax.Internal.Generic' +-- See "Agda.Syntax.Internal.Generic". class ExprLike a where foldExpr :: Monoid m => (Expr -> m) -> a -> m traverseExpr :: (Monad m, Applicative m) => (Expr -> m Expr) -> a -> m a @@ -214,7 +214,7 @@ RHS e -> fold e AbsurdRHS{} -> mempty WithRHS _ es cs -> fold es `mappend` fold cs - RewriteRHS _ es rhs ds -> fold es `mappend` fold rhs `mappend` fold ds + RewriteRHS xes rhs ds -> fold xes `mappend` fold rhs `mappend` fold ds where fold e = foldExpr f e traverseExpr f rhs = @@ -222,7 +222,7 @@ RHS e -> RHS <$> trav e AbsurdRHS{} -> pure rhs WithRHS x es cs -> WithRHS x <$> trav es <*> trav cs - RewriteRHS xs es rhs ds -> RewriteRHS xs <$> trav es <*> trav rhs <*> trav ds + RewriteRHS xes rhs ds -> RewriteRHS <$> trav xes <*> trav rhs <*> trav ds where trav e = traverseExpr f e instance ExprLike Declaration where diff --git a/src/full/Agda/Syntax/Common.hs b/src/full/Agda/Syntax/Common.hs --- a/src/full/Agda/Syntax/Common.hs +++ b/src/full/Agda/Syntax/Common.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} {-| Some common syntactic entities are defined in this module. -} @@ -17,16 +16,16 @@ import qualified Data.ByteString.Char8 as ByteString import Data.Foldable import Data.Hashable +import Data.Monoid import Data.Traversable import Data.Typeable (Typeable) -import Test.QuickCheck +import Test.QuickCheck hiding (Small) import Agda.Syntax.Position import Agda.Utils.Functor import Agda.Utils.Pretty -import Agda.Utils.Size #include "undefined.h" import Agda.Utils.Impossible @@ -73,9 +72,39 @@ data Hiding = Hidden | Instance | NotHidden deriving (Typeable, Show, Eq, Ord) +-- | 'Hiding' is an idempotent partial monoid, with unit 'NotHidden'. +-- 'Instance' and 'NotHidden' are incompatible. +instance Monoid Hiding where + mempty = NotHidden + mappend NotHidden h = h + mappend h NotHidden = h + mappend Hidden Hidden = Hidden + mappend Instance Instance = Instance + mappend _ _ = __IMPOSSIBLE__ + instance KillRange Hiding where killRange = id +-- | Decorating something with 'Hiding' information. +data WithHiding a = WithHiding Hiding a + deriving (Typeable, Eq, Ord, Show, Functor, Foldable, Traversable) + +instance Decoration WithHiding where + traverseF f (WithHiding h a) = WithHiding h <$> f a + +instance Applicative WithHiding where + pure = WithHiding mempty + WithHiding h f <*> WithHiding h' a = WithHiding (mappend h h') (f a) + +instance HasRange a => HasRange (WithHiding a) where + getRange = getRange . dget + +instance SetRange a => SetRange (WithHiding a) where + setRange = fmap . setRange + +instance KillRange a => KillRange (WithHiding a) where + killRange = fmap killRange + -- | A lens to access the 'Hiding' attribute in data structures. -- Minimal implementation: @getHiding@ and one of @setHiding@ or @mapHiding@. class LensHiding a where @@ -93,6 +122,15 @@ setHiding = const mapHiding = id +instance LensHiding (WithHiding a) where + getHiding (WithHiding h _) = h + setHiding h (WithHiding _ a) = WithHiding h a + mapHiding f (WithHiding h a) = WithHiding (f h) a + +-- | Monoidal composition of 'Hiding' information in some data. +mergeHiding :: LensHiding a => WithHiding a -> a +mergeHiding (WithHiding h a) = mapHiding (mappend h) a + -- | @isHidden@ does not apply to 'Instance', only to 'Hidden'. isHidden :: LensHiding a => a -> Bool isHidden a = getHiding a == Hidden @@ -119,27 +157,55 @@ -- * Relevance --------------------------------------------------------------------------- +-- | An constructor argument is big if the sort of its type is bigger than +-- the sort of the data type. Only parameters (and maybe forced arguments) +-- are allowed to be big. +-- @ +-- List : Set -> Set +-- nil : (A : Set) -> List A +-- @ +-- @A@ is big in constructor @nil@ as the sort @Set1@ of its type @Set@ +-- is bigger than the sort @Set@ of the data type @List@. +data Big = Big | Small + deriving (Typeable, Show, Eq, Enum, Bounded) + +instance Ord Big where + Big <= Small = False + _ <= _ = True + -- | A function argument can be relevant or irrelevant. --- See 'Agda.TypeChecking.Irrelevance'. +-- See "Agda.TypeChecking.Irrelevance". data Relevance = Relevant -- ^ The argument is (possibly) relevant at compile-time. | NonStrict -- ^ The argument may never flow into evaluation position. -- Therefore, it is irrelevant at run-time. -- It is treated relevantly during equality checking. | Irrelevant -- ^ The argument is irrelevant at compile- and runtime. - | Forced -- ^ The argument can be skipped during equality checking + | Forced Big -- ^ The argument can be skipped during equality checking -- because its value is already determined by the type. + -- If a constructor argument is big, it has to be regarded + -- absent, otherwise we get into paradoxes. | UnusedArg -- ^ The polarity checker has determined that this argument -- is unused in the definition. It can be skipped during -- equality checking but should be mined for solutions -- of meta-variables with relevance 'UnusedArg' - deriving (Typeable, Show, Eq, Enum, Bounded) + deriving (Typeable, Show, Eq) +allRelevances :: [Relevance] +allRelevances = + [ Relevant + , NonStrict + , Irrelevant + , Forced Small + , Forced Big + , UnusedArg + ] + instance KillRange Relevance where killRange rel = rel -- no range to kill instance Arbitrary Relevance where - arbitrary = elements [minBound..maxBound] + arbitrary = elements allRelevances instance Ord Relevance where (<=) = moreRelevant @@ -186,8 +252,8 @@ (UnusedArg, _) -> True (_, UnusedArg) -> False -- third bottom - (Forced, _) -> True - (_, Forced) -> False + (Forced{}, _) -> True + (_, Forced{}) -> False -- remaining case (NonStrict,NonStrict) -> True @@ -206,7 +272,7 @@ instance KillRange c => KillRange (ArgInfo c) where killRange (ArgInfo h r cs) = killRange3 ArgInfo h r cs -{- FAILED to define a less for ArgInfo, since it is parametrized by c +{- FAILED to define a lens for ArgInfo, since it is parametrized by c can't instantiate the following to f c = Arg c e since Haskell does not have lambda abstraction @@ -270,12 +336,12 @@ instance HasRange a => HasRange (Arg c a) where getRange = getRange . unArg +instance SetRange a => SetRange (Arg c a) where + setRange r = fmap $ setRange r + instance (KillRange c, KillRange a) => KillRange (Arg c a) where killRange (Arg info a) = killRange2 Arg info a -instance Sized a => Sized (Arg c a) where - size = size . unArg - instance (Eq a, Eq c) => Eq (Arg c a) where Arg (ArgInfo h1 _ cs1) x1 == Arg (ArgInfo h2 _ cs2) x2 = (h1, cs1, x1) == (h2, cs2, x2) @@ -285,11 +351,13 @@ showH Hidden s = "{" ++ s ++ "}" showH NotHidden s = "(" ++ s ++ ")" showH Instance s = "{{" ++ s ++ "}}" - showR Irrelevant s = "." ++ s - showR NonStrict s = "?" ++ s - showR Forced s = "!" ++ s - showR UnusedArg s = "k" ++ s -- constant - showR Relevant s = "r" ++ s -- Andreas: I want to see it explicitly + showR r s = case r of + Irrelevant -> "." ++ s + NonStrict -> "?" ++ s + Forced Big -> "!b" ++ s + Forced Small -> "!" ++ s + UnusedArg -> "k" ++ s -- constant + Relevant -> "r" ++ s -- Andreas: I want to see it explicitly showC cs s = show cs ++ s instance LensHiding (Arg c e) where @@ -392,9 +460,6 @@ instance (KillRange c, KillRange a) => KillRange (Dom c a) where killRange (Dom info a) = killRange2 Dom info a -instance Sized a => Sized (Dom c a) where - size = size . unDom - instance (Show a, Show c) => Show (Dom c a) where show = show . argFromDom @@ -447,12 +512,12 @@ instance HasRange a => HasRange (Named name a) where getRange = getRange . namedThing +instance SetRange a => SetRange (Named name a) where + setRange r = fmap $ setRange r + instance (KillRange name, KillRange a) => KillRange (Named name a) where killRange (Named n a) = Named (killRange n) (killRange a) -instance Sized a => Sized (Named name a) where - size = size . namedThing - instance Show a => Show (Named_ a) where show (Named Nothing x) = show x show (Named (Just n) x) = rawNameToString (rangedThing n) ++ " = " ++ show x @@ -554,6 +619,9 @@ -- identifier. data NameId = NameId Integer Integer deriving (Eq, Ord, Typeable) + +instance KillRange NameId where + killRange = id instance Show NameId where show (NameId x i) = show x ++ "@" ++ show i diff --git a/src/full/Agda/Syntax/Concrete.hs b/src/full/Agda/Syntax/Concrete.hs --- a/src/full/Agda/Syntax/Concrete.hs +++ b/src/full/Agda/Syntax/Concrete.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + DeriveFoldable, + DeriveFunctor, + DeriveTraversable, + FlexibleInstances #-} {-| The concrete syntax is a raw representation of the program text without any desugaring at all. This is what the parser produces. @@ -62,6 +62,8 @@ import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Data.List +import Data.Set (Set) + import Agda.Syntax.Position import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo) import qualified Agda.Syntax.Common as Common @@ -70,6 +72,7 @@ import Agda.Syntax.Literal import Agda.Syntax.Concrete.Name +import qualified Agda.Syntax.Abstract.Name as A import Agda.Utils.Lens @@ -101,7 +104,14 @@ | Underscore !Range (Maybe String) -- ^ ex: @_@ or @_A_5@ | RawApp !Range [Expr] -- ^ before parsing operators | App !Range Expr (NamedArg Expr) -- ^ ex: @e e@, @e {e}@, or @e {x = e}@ - | OpApp !Range QName [NamedArg (OpApp Expr)] -- ^ ex: @e + e@ + | OpApp !Range QName (Set A.Name) + [NamedArg (OpApp Expr)] -- ^ ex: @e + e@ + -- The 'QName' is + -- possibly ambiguous, + -- but it must + -- correspond to one of + -- the names in the + -- set. | WithApp !Range Expr [Expr] -- ^ ex: @e | e1 | .. | en@ | HiddenArg !Range (Named_ Expr) -- ^ ex: @{e}@ or @{x=e}@ | InstanceArg !Range (Named_ Expr) -- ^ ex: @{{e}}@ or @{{x=e}}@ @@ -131,7 +141,7 @@ | Equal !Range Expr Expr -- ^ ex: @a = b@, used internally in the parser deriving (Typeable) -instance NFData Expr +instance NFData Expr where rnf x = seq x () -- | Concrete patterns. No literals in patterns at the moment. data Pattern @@ -139,7 +149,12 @@ | QuoteP !Range -- ^ @quote@ | AppP Pattern (NamedArg Pattern) -- ^ @p p'@ or @p {x = p'}@ | RawAppP !Range [Pattern] -- ^ @p1..pn@ before parsing operators - | OpAppP !Range QName [NamedArg Pattern] -- ^ eg: @p => p'@ for operator @_=>_@ + | OpAppP !Range QName (Set A.Name) + [NamedArg Pattern] -- ^ eg: @p => p'@ for operator @_=>_@ + -- The 'QName' is possibly + -- ambiguous, but it must + -- correspond to one of + -- the names in the set. | HiddenP !Range (Named_ Pattern) -- ^ @{p}@ or @{x = p}@ | InstanceP !Range (Named_ Pattern) -- ^ @{{p}}@ or @{{x = p}}@ | ParenP !Range Pattern -- ^ @(p)@ @@ -150,7 +165,7 @@ | LitP Literal -- ^ @0@, @1@, etc. deriving (Typeable) -instance NFData Pattern +instance NFData Pattern where rnf x = seq x () -- | A lambda binding is either domain free or typed. type LamBinding = LamBinding' TypedBindings @@ -162,11 +177,14 @@ -- | A sequence of typed bindings with hiding information. Appears in dependent -- function spaces, typed lambdas, and telescopes. +-- +-- If the individual binding contains hiding information as well, the +-- 'Hiding' in @TypedBindings@ must be the unit 'NotHidden'. type TypedBindings = TypedBindings' TypedBinding data TypedBindings' a = TypedBindings !Range (Arg a) - -- ^ . @(xs : e)@ or @{xs : e}@ + -- ^ . @(xs : e)@ or @{xs : e}@ or something like @(x {y} _ : e)@. deriving (Typeable, Functor, Foldable, Traversable) data BoundName = BName @@ -187,7 +205,7 @@ type TypedBinding = TypedBinding' Expr data TypedBinding' e - = TBind !Range [BoundName] e -- ^ Binding @(x1 ... xn : A)@. + = TBind !Range [WithHiding BoundName] e -- ^ Binding @(x1 ... xn : A)@. | TLet !Range [Declaration] -- ^ Let binding @(let Ds)@ or @(open M args)@. deriving (Typeable, Functor, Foldable, Traversable) @@ -239,15 +257,7 @@ } deriving (Typeable) -instance NFData LHSCore - -{- TRASH -lhsCoreToPattern :: LHSCore -> Pattern -lhsCoreToPattern (LHSHead f args) = OpAppP (fuseRange f args) (unqualify f) args -lhsCoreToPattern (LHSProj d ps1 lhscore ps2) = OpAppP (fuseRange d ps) (unqualify) ps - where p = lhsCoreToPattern lhscore - ps = ps1 ++ p : ps2 --} +instance NFData LHSCore where rnf x = seq x () type RHS = RHS' Expr data RHS' e @@ -440,7 +450,7 @@ AppP p p' -> patternHead p RawAppP _ [] -> __IMPOSSIBLE__ RawAppP _ (p:_) -> patternHead p - OpAppP _ name ps -> return $ unqualify name + OpAppP _ name _ ps -> return $ unqualify name HiddenP _ (namedPat) -> patternHead (namedThing namedPat) ParenP _ p -> patternHead p WildP _ -> Nothing @@ -460,7 +470,7 @@ IdentP x -> [unqualify x] AppP p p' -> concatMap patternNames [p, namedArg p'] RawAppP _ ps -> concatMap patternNames ps - OpAppP _ name ps -> unqualify name : concatMap (patternNames . namedArg) ps + OpAppP _ name _ ps -> unqualify name : concatMap (patternNames . namedArg) ps HiddenP _ (namedPat) -> patternNames (namedThing namedPat) ParenP _ p -> patternNames p WildP _ -> [] @@ -475,6 +485,26 @@ Instances --------------------------------------------------------------------------} +-- Lenses +------------------------------------------------------------------------ + +instance LensRelevance TypedBindings where + getRelevance (TypedBindings _ b) = getRelevance b + mapRelevance f (TypedBindings r b) = TypedBindings r $ mapRelevance f b + +instance LensHiding TypedBindings where + getHiding (TypedBindings _ b) = getHiding b + mapHiding f (TypedBindings r b) = TypedBindings r $ mapHiding f b + +instance LensHiding LamBinding where + getHiding (DomainFree ai _) = getHiding ai + getHiding (DomainFull a) = getHiding a + mapHiding f (DomainFree ai x) = DomainFree (mapHiding f ai) x + mapHiding f (DomainFull a) = DomainFull $ mapHiding f a + +-- HasRange instances +------------------------------------------------------------------------ + instance HasRange e => HasRange (OpApp e) where getRange e = case e of Ordinary e -> getRange e @@ -489,7 +519,7 @@ Underscore r _ -> r App r _ _ -> r RawApp r _ -> r - OpApp r _ _ -> r + OpApp r _ _ _ -> r WithApp r _ _ -> r Lam r _ _ -> r AbsurdLam r _ -> r @@ -617,7 +647,7 @@ instance HasRange Pattern where getRange (IdentP x) = getRange x getRange (AppP p q) = fuseRange p q - getRange (OpAppP r _ _) = r + getRange (OpAppP r _ _ _) = r getRange (RawAppP r _) = r getRange (ParenP r _) = r getRange (WildP r) = r @@ -629,6 +659,30 @@ getRange (InstanceP r _) = r getRange (DotP r _) = r +-- SetRange instances +------------------------------------------------------------------------ + +instance SetRange TypedBindings where + setRange r (TypedBindings _ b) = TypedBindings r b + +instance SetRange Pattern where + setRange r (IdentP x) = IdentP (setRange r x) + setRange r (AppP p q) = AppP (setRange r p) (setRange r q) + setRange r (OpAppP _ x ns ps) = OpAppP r x ns ps + setRange r (RawAppP _ ps) = RawAppP r ps + setRange r (ParenP _ p) = ParenP r p + setRange r (WildP _) = WildP r + setRange r (AsP _ x p) = AsP r (setRange r x) p + setRange r (AbsurdP _) = AbsurdP r + setRange r (LitP l) = LitP (setRange r l) + setRange r (QuoteP _) = QuoteP r + setRange r (HiddenP _ p) = HiddenP r p + setRange r (InstanceP _ p) = InstanceP r p + setRange r (DotP _ e) = DotP r e + +-- KillRange instances +------------------------------------------------------------------------ + instance KillRange AsName where killRange (AsName n _) = killRange1 (flip AsName noRange) n @@ -666,7 +720,7 @@ killRange (Underscore _ n) = Underscore noRange n killRange (RawApp _ e) = killRange1 (RawApp noRange) e killRange (App _ e a) = killRange2 (App noRange) e a - killRange (OpApp _ n o) = killRange2 (OpApp noRange) n o + killRange (OpApp _ n ns o) = killRange3 (OpApp noRange) n ns o killRange (WithApp _ e es) = killRange2 (WithApp noRange) e es killRange (HiddenArg _ n) = killRange1 (HiddenArg noRange) n killRange (InstanceArg _ n) = killRange1 (InstanceArg noRange) n @@ -720,19 +774,19 @@ killRange (Ordinary e) = killRange1 Ordinary e instance KillRange Pattern where - killRange (IdentP q) = killRange1 IdentP q - killRange (AppP p n) = killRange2 AppP p n - killRange (RawAppP _ p) = killRange1 (RawAppP noRange) p - killRange (OpAppP _ n p) = killRange2 (OpAppP noRange) n p - killRange (HiddenP _ n) = killRange1 (HiddenP noRange) n - killRange (InstanceP _ n) = killRange1 (InstanceP noRange) n - killRange (ParenP _ p) = killRange1 (ParenP noRange) p - killRange (WildP _) = WildP noRange - killRange (AbsurdP _) = AbsurdP noRange - killRange (AsP _ n p) = killRange2 (AsP noRange) n p - killRange (DotP _ e) = killRange1 (DotP noRange) e - killRange (LitP l) = killRange1 LitP l - killRange (QuoteP _) = QuoteP noRange + killRange (IdentP q) = killRange1 IdentP q + killRange (AppP p n) = killRange2 AppP p n + killRange (RawAppP _ p) = killRange1 (RawAppP noRange) p + killRange (OpAppP _ n ns p) = killRange3 (OpAppP noRange) n ns p + killRange (HiddenP _ n) = killRange1 (HiddenP noRange) n + killRange (InstanceP _ n) = killRange1 (InstanceP noRange) n + killRange (ParenP _ p) = killRange1 (ParenP noRange) p + killRange (WildP _) = WildP noRange + killRange (AbsurdP _) = AbsurdP noRange + killRange (AsP _ n p) = killRange2 (AsP noRange) n p + killRange (DotP _ e) = killRange1 (DotP noRange) e + killRange (LitP l) = killRange1 LitP l + killRange (QuoteP _) = QuoteP noRange instance KillRange Pragma where killRange (OptionsPragma _ s) = OptionsPragma noRange s diff --git a/src/full/Agda/Syntax/Concrete/Definitions.hs b/src/full/Agda/Syntax/Concrete/Definitions.hs --- a/src/full/Agda/Syntax/Concrete/Definitions.hs +++ b/src/full/Agda/Syntax/Concrete/Definitions.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + FlexibleInstances, + PatternGuards, + TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + -- | Preprocess 'Agda.Syntax.Concrete.Declaration's, producing 'NiceDeclaration's. -- -- * Attach fixity and syntax declarations to the definition they refer to. @@ -39,15 +43,28 @@ , Measure ) where +import Prelude hiding (null) + import Control.Arrow ((***)) -import Control.Applicative +import Control.Applicative hiding (empty) import Control.Monad.State -import Data.Foldable hiding (concatMap, mapM_, notElem, elem, all) +import Data.Foldable hiding + ( all + , concatMap + , elem + , mapM_ + , notElem +#if MIN_VERSION_base(4,8,0) + , null +#endif + ) + import qualified Data.Map as Map import Data.Map (Map) +import Data.Maybe import Data.Monoid ( Monoid(mappend, mempty) ) -import Data.List as List +import Data.List as List hiding (null) import Data.Traversable (traverse) import Data.Typeable (Typeable) @@ -63,6 +80,7 @@ import Agda.Utils.Lens import Agda.Utils.List (headMaybe, isSublistOf) import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.Pretty import Agda.Utils.Update @@ -79,28 +97,32 @@ modifiers have been distributed to the individual declarations. -} data NiceDeclaration - = Axiom Range Fixity' Access IsInstance ArgInfo Name Expr - -- ^ Axioms and functions can be declared irrelevant. (Hiding should be NotHidden) - | NiceField Range Fixity' Access IsAbstract Name (Arg Expr) - | PrimitiveFunction Range Fixity' Access IsAbstract Name Expr - | NiceMutual Range TerminationCheck [NiceDeclaration] - | NiceModule Range Access IsAbstract QName Telescope [Declaration] - | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective - | NiceOpen Range QName ImportDirective - | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective - | NicePragma Range Pragma - | NiceRecSig Range Fixity' Access Name [LamBinding] Expr - | NiceDataSig Range Fixity' Access Name [LamBinding] Expr - | NiceFunClause Range Access IsAbstract TerminationCheck Declaration - -- ^ a uncategorized function clause, could be a function clause - -- without type signature or a pattern lhs (e.g. for irrefutable let)x - | FunSig Range Fixity' Access IsInstance ArgInfo TerminationCheck Name Expr - | FunDef Range [Declaration] Fixity' IsAbstract TerminationCheck Name [Clause] -- ^ block of function clauses (we have seen the type signature before) - | DataDef Range Fixity' IsAbstract Name [LamBinding] [NiceConstructor] - | RecDef Range Fixity' IsAbstract Name (Maybe (Ranged Induction)) (Maybe (ThingWithFixity Name)) [LamBinding] [NiceDeclaration] - | NicePatternSyn Range Fixity' Name [Arg Name] Pattern - | NiceUnquoteDecl Range Fixity' Access IsAbstract TerminationCheck Name Expr - deriving (Typeable, Show) + = Axiom Range Fixity' Access IsInstance ArgInfo Name Expr + -- ^ Axioms and functions can be declared irrelevant. (Hiding should be NotHidden) + | NiceField Range Fixity' Access IsAbstract Name (Arg Expr) + | PrimitiveFunction Range Fixity' Access IsAbstract Name Expr + | NiceMutual Range TerminationCheck [NiceDeclaration] + | NiceModule Range Access IsAbstract QName Telescope [Declaration] + | NiceModuleMacro Range Access Name ModuleApplication OpenShortHand ImportDirective + | NiceOpen Range QName ImportDirective + | NiceImport Range QName (Maybe AsName) OpenShortHand ImportDirective + | NicePragma Range Pragma + | NiceRecSig Range Fixity' Access Name [LamBinding] Expr + | NiceDataSig Range Fixity' Access Name [LamBinding] Expr + | NiceFunClause Range Access IsAbstract TerminationCheck 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 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] [NiceConstructor] + | RecDef Range Fixity' IsAbstract Name (Maybe (Ranged Induction)) (Maybe (ThingWithFixity Name)) [LamBinding] [NiceDeclaration] + | NicePatternSyn Range Fixity' Name [Arg Name] Pattern + | NiceUnquoteDecl Range Fixity' Access IsInstance IsAbstract TerminationCheck Name Expr + deriving (Typeable, Show) type TerminationCheck = Common.TerminationCheck Measure @@ -121,6 +143,8 @@ -- | The exception type. data DeclarationException = MultipleFixityDecls [(Name, [Fixity'])] + | InvalidName Name + | DuplicateDefinition Name | MissingDefinition Name | MissingWithClauses Name | MissingTypeSignature LHS -- Andreas 2012-06-02: currently unused, remove after a while -- Fredrik 2012-09-20: now used, can we keep it? @@ -147,6 +171,8 @@ 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 @@ -184,7 +210,7 @@ getRange (NiceDataSig r _ _ _ _ _) = r getRange (NicePatternSyn r _ _ _ _) = r getRange (NiceFunClause r _ _ _ _) = r - getRange (NiceUnquoteDecl r _ _ _ _ _ _) = r + getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r instance Error DeclarationException where noMsg = strMsg "" @@ -192,46 +218,53 @@ -- These error messages can (should) be terminated by a dot ".", -- there is no error context printed after them. -instance Show DeclarationException where - show (MultipleFixityDecls xs) = show $ +instance Pretty DeclarationException where + pretty (MultipleFixityDecls xs) = sep [ fsep $ pwords "Multiple fixity or syntax declarations for" , vcat $ map f xs ] where f (x, fs) = pretty x <> text ": " <+> fsep (map pretty fs) - show (MissingDefinition x) = show $ fsep $ + pretty (InvalidName x) = fsep $ + pwords "Invalid name:" ++ [pretty x] + pretty (DuplicateDefinition x) = fsep $ + pwords "Duplicate definition of" ++ [pretty x] + pretty (MissingDefinition x) = fsep $ pwords "Missing definition for" ++ [pretty x] - show (MissingWithClauses x) = show $ fsep $ + pretty (MissingWithClauses x) = fsep $ pwords "Missing with-clauses for function" ++ [pretty x] - show (MissingTypeSignature x) = show $ fsep $ + pretty (MissingTypeSignature x) = fsep $ pwords "Missing type signature for left hand side" ++ [pretty x] - show (MissingDataSignature x) = show $ fsep $ + pretty (MissingDataSignature x) = fsep $ pwords "Missing type signature for " ++ [pretty x] - show (WrongDefinition x k k') = show $ fsep $ pretty x : + pretty (WrongDefinition x k k') = fsep $ pretty x : pwords ("has been declared as a " ++ show k ++ ", but is being defined as a " ++ show k') - show (WrongParameters x) = show $ fsep $ + pretty (WrongParameters x) = fsep $ pwords "List of parameters does not match previous signature for" ++ [pretty x] - show (AmbiguousFunClauses lhs xs) = show $ fsep $ - pwords "More than one matching type signature for left hand side" ++ [pretty lhs] ++ - pwords "it could belong to any of:" ++ map pretty xs - show (UnknownNamesInFixityDecl xs) = show $ fsep $ + pretty (AmbiguousFunClauses lhs xs) = sep + [ fsep $ + pwords "More than one matching type signature for left hand side " ++ [pretty lhs] ++ + pwords "it could belong to any of:" + , vcat $ map (pretty . PrintRange) xs + ] + pretty (UnknownNamesInFixityDecl xs) = fsep $ pwords "The following names are not declared in the same scope as their syntax or fixity declaration (i.e., either not in scope at all, imported from another module, or declared in a super module):" ++ map pretty xs - show (UselessPrivate _) = show $ fsep $ + 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." - show (UselessAbstract _) = show $ fsep $ + pretty (UselessAbstract _) = fsep $ pwords "Using abstract here has no effect. Abstract applies only definitions like data definitions, record type definitions and function clauses." - show (UselessInstance _) = show $ fsep $ + pretty (UselessInstance _) = fsep $ pwords "Using instance here has no effect. Instance applies only to declarations that introduce new identifiers into the module, like type signatures and axioms." - show (WrongContentPostulateBlock _) = show $ fsep $ + pretty (WrongContentPostulateBlock _) = fsep $ pwords "A postulate block can only contain type signatures or instance blocks" - show (PragmaNoTerminationCheck _) = show $ fsep $ + pretty (PragmaNoTerminationCheck _) = fsep $ pwords "Pragma {-# NO_TERMINATION_CHECK #-} has been removed. To skip the termination check, label your definitions either as {-# TERMINATING #-} or {-# NON_TERMINATING #-}." - show (InvalidTerminationCheckPragma _) = show $ fsep $ + pretty (InvalidTerminationCheckPragma _) = fsep $ pwords "Termination checking pragmas can only precede a mutual block or a function definition." - show (InvalidMeasureMutual _) = show $ fsep $ + pretty (InvalidMeasureMutual _) = fsep $ pwords "In a mutual block, either all functions must have the same (or no) termination checking pragma." - show (NotAllowedInMutual nd) = show $ fsep $ + pretty (NotAllowedInMutual nd) = fsep $ [text $ decl nd] ++ pwords "are not allowed in mutual blocks" where decl Axiom{} = "Postulates" @@ -252,10 +285,10 @@ decl FunDef{} = __IMPOSSIBLE__ decl RecDef{} = __IMPOSSIBLE__ decl DataDef{} = __IMPOSSIBLE__ - show (Codata _) = + pretty (Codata _) = text $ "The codata construction has been removed. " ++ "Use the INFINITY builtin instead." - show (DeclarationPanic s) = s + pretty (DeclarationPanic s) = text s {-------------------------------------------------------------------------- The niceifier @@ -336,15 +369,15 @@ , fixs :: Fixities } -type LoneSigs = [(DataRecOrFun, Name)] +type LoneSigs = Map Name DataRecOrFun type Fixities = Map Name Fixity' -- | Initial nicifier state. initNiceEnv :: NiceEnv initNiceEnv = NiceEnv - { _loneSigs = [] - , fixs = Map.empty + { _loneSigs = empty + , fixs = empty } -- * Handling the lone signatures, stored to infer mutual blocks. @@ -356,18 +389,22 @@ -- | Adding a lone signature to the state. -addLoneSig :: DataRecOrFun -> Name -> Nice () -addLoneSig k x = loneSigs %= ((k, x) :) +addLoneSig :: Name -> DataRecOrFun -> Nice () +addLoneSig x k = loneSigs %== \ s -> do + let (mr, s') = Map.insertLookupWithKey (\ k new old -> new) x k s + case mr of + Nothing -> return s' + Just{} -> throwError $ DuplicateDefinition x -- | Remove a lone signature from the state. removeLoneSig :: Name -> Nice () -removeLoneSig x = loneSigs %= filter (\ (k', x') -> x /= x') +removeLoneSig x = loneSigs %= Map.delete x -- | Search for forward type signature. getSig :: Name -> Nice (Maybe DataRecOrFun) -getSig n = fmap fst . List.find (\ (k, x) -> x == n) <$> use loneSigs +getSig x = Map.lookup x <$> use loneSigs -- | Check that no lone signatures are left in the state. @@ -376,15 +413,17 @@ -- | Ensure that all forward declarations have been given a definition. -checkLoneSigs :: LoneSigs -> Nice () +checkLoneSigs :: [(Name, a)] -> Nice () checkLoneSigs xs = case xs of [] -> return () - (_, x):_ -> throwError $ MissingDefinition x - + (x, _):_ -> throwError $ MissingDefinition x +-- | Check whether name is not "_" and return its fixity. getFixity :: Name -> Nice Fixity' -getFixity x = gets $ Map.findWithDefault defaultFixity' x . fixs +getFixity x = do + when (isUnderscore x) $ throwError $ InvalidName x + gets $ Map.findWithDefault defaultFixity' x . fixs runNice :: Nice a -> Either DeclarationException a runNice nice = nice `evalStateT` initNiceEnv @@ -425,7 +464,7 @@ put $ initNiceEnv { fixs = fixs } ds <- nice ds -- Check that every signature got its definition. - checkLoneSigs =<< use loneSigs + checkLoneSigs . Map.toList =<< use loneSigs -- Note that loneSigs is ensured to be empty. -- (Important, since inferMutualBlocks also uses loneSigs state). inferMutualBlocks ds @@ -467,7 +506,7 @@ OtherDecl -> (d :) <$> inferMutualBlocks ds LoneDef _ x -> __IMPOSSIBLE__ LoneSig k x -> do - addLoneSig k x + addLoneSig x k (tcs, (ds0, ds1)) <- untilAllDefined [terminationCheck k] ds tc <- combineTermChecks (getRange d) tcs @@ -486,9 +525,9 @@ done <- noLoneSigs if done then return (tc, ([], ds)) else case ds of - [] -> __IMPOSSIBLE__ <$ (checkLoneSigs =<< use loneSigs) + [] -> __IMPOSSIBLE__ <$ (checkLoneSigs . Map.toList =<< use loneSigs) d : ds -> case declKind d of - LoneSig k x -> addLoneSig k x >> cons d (untilAllDefined (terminationCheck k : tc) ds) + LoneSig k x -> addLoneSig x k >> cons d (untilAllDefined (terminationCheck k : tc) ds) LoneDef k x -> removeLoneSig x >> cons d (untilAllDefined (terminationCheck k : tc) ds) OtherDecl -> cons d (untilAllDefined tc ds) where @@ -512,8 +551,8 @@ nice (Pragma (TerminationCheckPragma r tc) : d@FunClause{} : ds) | notMeasure tc = niceFunClause tc d ds nice (Pragma (TerminationCheckPragma r tc) : ds@(UnquoteDecl{} : _)) | notMeasure tc = do - NiceUnquoteDecl r f p a _ x e : ds <- nice ds - return $ NiceUnquoteDecl r f p a tc x e : ds + NiceUnquoteDecl r f p a i _ x e : ds <- nice ds + return $ NiceUnquoteDecl r f p a i tc x e : ds nice (d@TypeSig{} : Pragma (TerminationCheckPragma r (TerminationMeasure _ x)) : ds) = niceTypeSig (TerminationMeasure r x) d ds @@ -528,7 +567,7 @@ DataSig r CoInductive x tel t -> throwError (Codata r) Data r CoInductive x tel t cs -> throwError (Codata r) DataSig r Inductive x tel t -> do - addLoneSig (DataName $ parameters tel) x + addLoneSig x (DataName $ parameters tel) (++) <$> dataOrRec DataDef NiceDataSig niceAxioms r x tel (Just t) Nothing <*> nice ds Data r Inductive x tel t cs -> do @@ -536,7 +575,7 @@ (++) <$> dataOrRec DataDef NiceDataSig niceAxioms r x tel t (Just cs) <*> nice ds RecordSig r x tel t -> do - addLoneSig (RecName $ parameters tel) x + addLoneSig x (RecName $ parameters tel) fx <- getFixity x (NiceRecSig r fx PublicAccess x tel t :) <$> nice ds Record r x i c tel t cs -> do @@ -580,7 +619,7 @@ UnquoteDecl r x e -> do fx <- getFixity x - (NiceUnquoteDecl r fx PublicAccess ConcreteDef TerminationCheck x e :) <$> nice ds + (NiceUnquoteDecl r fx PublicAccess NotInstanceDef ConcreteDef TerminationCheck x e :) <$> nice ds -- Andreas, AIM XX: do not forbid NO_TERMINATION_CHECK in maintenance version. -- Pragma (TerminationCheckPragma r NoTerminationCheck) -> -- throwError $ PragmaNoTerminationCheck r @@ -590,7 +629,7 @@ niceFunClause :: TerminationCheck -> Declaration -> [Declaration] -> Nice [NiceDeclaration] niceFunClause termCheck d@(FunClause lhs _ _) ds = do - xs <- map snd . filter (isFunName . fst) <$> use loneSigs + 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 @@ -626,14 +665,14 @@ return $ d : ds1 -- case: clauses match more than one sigs (ambiguity) - l -> throwError $ AmbiguousFunClauses lhs (map fst l) -- "ambiguous function clause; cannot assign it uniquely to one type signature" + l -> throwError $ AmbiguousFunClauses lhs $ reverse $ map fst l -- "ambiguous function clause; cannot assign it uniquely to one type signature" niceFunClause _ _ _ = __IMPOSSIBLE__ 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 (FunName termCheck) x + addLoneSig x (FunName termCheck) ds <- nice ds return $ FunSig (getRange d) fx PublicAccess NotInstanceDef info termCheck x t : ds niceTypeSig _ _ _ = __IMPOSSIBLE__ @@ -653,13 +692,15 @@ dataOrRec mkDef mkSig niceD r x tel mt mcs = do mds <- traverse niceD mcs f <- getFixity x - return $ - [mkSig (fuseRange x t) f PublicAccess x tel t | Just t <- [mt] ] ++ - [mkDef (getRange x) f ConcreteDef x (concatMap dropType tel) ds | Just ds <- [mds] ] + return $ catMaybes $ + [ mt <&> \ t -> mkSig (fuseRange x t) f PublicAccess x tel t + , mkDef r f ConcreteDef x (concatMap dropType tel) <$> mds + ] where - dropType (DomainFull (TypedBindings r (Common.Arg i (TBind _ xs _)))) = - map (DomainFree i) xs - dropType (DomainFull (TypedBindings _ (Common.Arg _ TLet{}))) = [] + dropType :: LamBinding -> [LamBinding] + dropType (DomainFull (TypedBindings _r (Common.Arg ai (TBind _ xs _)))) = + map (mergeHiding . fmap (DomainFree ai)) xs + dropType (DomainFull (TypedBindings _r (Common.Arg _ TLet{}))) = [] dropType b@DomainFree{} = [b] -- Translate axioms @@ -702,10 +743,10 @@ d : expand p ps ds where expand _ _ [] = [] - expand p ps (FunClause (Ellipsis _ ps' eqs []) rhs wh : ds) = - FunClause (LHS p (ps ++ ps') eqs []) rhs wh : expand p ps ds - expand p ps (FunClause (Ellipsis _ ps' eqs es) rhs wh : ds) = - FunClause (LHS p (ps ++ ps') eqs es) rhs wh : expand p (ps ++ ps') ds + expand p ps (FunClause (Ellipsis r ps' eqs []) rhs wh : ds) = + FunClause (LHS (setRange r p) ((setRange r ps) ++ ps') eqs []) rhs wh : expand p ps ds + expand p ps (FunClause (Ellipsis r ps' eqs es) rhs wh : ds) = + FunClause (LHS (setRange r p) ((setRange r ps) ++ ps') eqs es) rhs wh : expand p (ps ++ ps') ds expand p ps (d@(FunClause (LHS _ _ _ []) _ _) : ds) = d : expand p ps ds expand _ _ (d@(FunClause (LHS p ps _ (_ : _)) _ _) : ds) = @@ -807,10 +848,10 @@ isTypeSig d | LoneSig{} <- declKind d = True isTypeSig _ = False - sigNames = [ (k, x) | LoneSig k x <- map declKind ds ] - defNames = [ (k, x) | LoneDef k x <- map declKind ds ] + sigNames = [ (x, k) | LoneSig k x <- map declKind ds ] + defNames = [ (x, k) | LoneDef k x <- map declKind ds ] -- compute the set difference with equality just on names - loneNames = [ (k, x) | (k, x) <- sigNames, List.all ((x /=) . snd) defNames ] + loneNames = [ (x, k) | (x, k) <- sigNames, List.all ((x /=) . fst) defNames ] -- Andreas, 2013-02-28 (issue 804): -- do not termination check a mutual block if any of its @@ -818,7 +859,7 @@ termCheck (FunSig _ _ _ _ _ tc _ _) = tc termCheck (FunDef _ _ _ _ tc _ _) = tc termCheck (NiceMutual _ tc _) = tc - termCheck (NiceUnquoteDecl _ _ _ _ tc _ _) = tc + termCheck (NiceUnquoteDecl _ _ _ _ _ tc _ _) = tc termCheck _ = TerminationCheck -- A mutual block cannot have a measure, @@ -844,7 +885,7 @@ -- no effect on fields or primitives, the InAbstract field there is unused NiceField r f p _ x e -> return $ NiceField r f p AbstractDef x e PrimitiveFunction r f p _ x e -> return $ PrimitiveFunction r f p AbstractDef x e - NiceUnquoteDecl r f p _ t x e -> return $ NiceUnquoteDecl r f p AbstractDef t x e + NiceUnquoteDecl r f p i _ t x e -> return $ NiceUnquoteDecl r f p i AbstractDef t x e NiceModule{} -> return $ d NiceModuleMacro{} -> return $ d Axiom{} -> return $ d @@ -895,7 +936,7 @@ NiceRecSig r f p x ls t -> (\ p -> NiceRecSig r f p x ls t) <$> setPrivate p NiceDataSig r f p x ls t -> (\ p -> NiceDataSig r f p x ls t) <$> setPrivate p NiceFunClause r p a termCheck d -> (\ p -> NiceFunClause r p a termCheck d) <$> setPrivate p - NiceUnquoteDecl r f p a t x e -> (\ p -> NiceUnquoteDecl r f p a t x e) <$> setPrivate p + NiceUnquoteDecl r f p i a t x e -> (\ p -> NiceUnquoteDecl r f p i a t x e) <$> setPrivate p NicePragma _ _ -> return $ d NiceOpen _ _ _ -> return $ d NiceImport _ _ _ _ _ -> return $ d @@ -933,12 +974,12 @@ 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 rel tc x e -> (\ i -> FunSig r f p i 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 NiceMutual{} -> return $ d NiceFunClause{} -> return $ d FunDef{} -> return $ d NiceField{} -> return $ d PrimitiveFunction{} -> return $ d - NiceUnquoteDecl{} -> return $ d NiceRecSig{} -> return $ d NiceDataSig{} -> return $ d NiceModuleMacro{} -> return $ d @@ -1055,5 +1096,4 @@ RecDef r _ _ x i c bs ds -> Record r x i (unThing <$> c) bs Nothing $ map notSoNiceDeclaration ds where unThing (ThingWithFixity c _) = c NicePatternSyn r _ n as p -> PatternSyn r n as p - NiceUnquoteDecl r _ _ _ _ x e -> UnquoteDecl r x e - + NiceUnquoteDecl r _ _ _ _ _ x e -> UnquoteDecl r x e diff --git a/src/full/Agda/Syntax/Concrete/Generic.hs b/src/full/Agda/Syntax/Concrete/Generic.hs --- a/src/full/Agda/Syntax/Concrete/Generic.hs +++ b/src/full/Agda/Syntax/Concrete/Generic.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} -- | Generic traversal and reduce for concrete syntax, --- in the style of 'Agda.Syntax.Internal.Generic'. +-- in the style of "Agda.Syntax.Internal.Generic". -- -- However, here we use the terminology of 'Data.Traversable'. @@ -100,7 +99,7 @@ Underscore{} -> f $ e0 RawApp r es -> f $ RawApp r $ mapE es App r e es -> f $ App r (mapE e) $ mapE es - OpApp r q es -> f $ OpApp r q $ mapE es + OpApp r q ns es -> f $ OpApp r q ns $ mapE es WithApp r e es -> f $ WithApp r (mapE e) $ mapE es HiddenArg r e -> f $ HiddenArg r $ mapE e InstanceArg r e -> f $ InstanceArg r $ mapE e diff --git a/src/full/Agda/Syntax/Concrete/Name.hs b/src/full/Agda/Syntax/Concrete/Name.hs --- a/src/full/Agda/Syntax/Concrete/Name.hs +++ b/src/full/Agda/Syntax/Concrete/Name.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} {-| Names in the concrete syntax are just strings (or lists of strings for qualified names). @@ -42,7 +41,7 @@ | NoName !Range NameId -- ^ @_@. deriving (Typeable) -instance NFData Name +instance NFData Name where rnf x = seq x () instance Underscore Name where underscore = NoName noRange __IMPOSSIBLE__ @@ -249,32 +248,32 @@ -- instead. Later, simply derive Show for these types: instance Show Name where - show (Name _ xs) = concatMap show xs - show (NoName _ _) = "_" + show (Name _ xs) = concatMap show xs + show (NoName _ _) = "_" instance Show NamePart where - show Hole = "_" - show (Id s) = rawNameToString s + show Hole = "_" + show (Id s) = rawNameToString s instance Show QName where - show (Qual m x) = show m ++ "." ++ show x - show (QName x) = show x + show (Qual m x) = show m ++ "." ++ show x + show (QName x) = show x ------------------------------------------------------------------------ -- * Printing names ------------------------------------------------------------------------ instance Pretty Name where - pretty (Name _ xs) = hcat $ map pretty xs - pretty (NoName _ _) = text $ "_" + pretty (Name _ xs) = hcat $ map pretty xs + pretty (NoName _ _) = text $ "_" instance Pretty NamePart where - pretty Hole = text $ "_" - pretty (Id s) = text $ rawNameToString s + pretty Hole = text $ "_" + pretty (Id s) = text $ rawNameToString s instance Pretty QName where - pretty (Qual m x) = pretty m <> pretty "." <> pretty x - pretty (QName x) = pretty x + pretty (Qual m x) = pretty m <> pretty "." <> pretty x + pretty (QName x) = pretty x instance Pretty TopLevelModuleName where pretty (TopLevelModuleName ms) = text $ intercalate "." ms diff --git a/src/full/Agda/Syntax/Concrete/Operators.hs b/src/full/Agda/Syntax/Concrete/Operators.hs --- a/src/full/Agda/Syntax/Concrete/Operators.hs +++ b/src/full/Agda/Syntax/Concrete/Operators.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-| The parser doesn't know about operators and parses everything as normal @@ -45,57 +45,54 @@ import Agda.Syntax.Scope.Monad import Agda.TypeChecking.Monad.Base (typeError, TypeError(..), LHSOrPatSyn(..)) -import Agda.TypeChecking.Monad.Benchmark (billSub) import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Monad.State (getScope) import Agda.TypeChecking.Monad.Options import Agda.Utils.Either import Agda.Utils.ReadP +#if MIN_VERSION_base(4,8,0) +import Agda.Utils.List hiding ( uncons ) +#else import Agda.Utils.List +#endif #include "undefined.h" import Agda.Utils.Impossible --------------------------------------------------------------------------- --- * Building the parser +-- * Billing --------------------------------------------------------------------------- -partsInScope :: FlatScope -> ScopeM (Set QName) -partsInScope flat = do - (names, ops) <- localNames flat - let xs = concatMap parts names ++ concatMap notationNames ops - return $ Set.fromList xs - where - qual xs x = foldr Qual (QName x) xs - parts q = parts' (init $ qnameParts q) (unqualify q) - parts' ms (NoName _ _) = [] - parts' ms x@(Name _ [_]) = [qual ms x] - -- The first part should be qualified, but not the rest - parts' ms x@(Name _ xs) = qual ms x : qual ms (Name noRange [first]) : [ QName $ Name noRange [i] | i <- iparts ] - where - first:iparts = [ i | i@(Id {}) <- xs ] +-- | Bills the operator parser. +billToParser :: ScopeM a -> ScopeM a +billToParser = Bench.billTo [Bench.Parsing, Bench.Operators] + +--------------------------------------------------------------------------- +-- * Building the parser +--------------------------------------------------------------------------- + type FlatScope = Map QName [AbstractName] --- | Compute all unqualified defined names in scope and their fixities. --- Note that overloaded names (constructors) can have several fixities. --- Then we 'chooseFixity'. (See issue 1194.) -getDefinedNames :: [KindOfName] -> FlatScope -> [(QName, Fixity')] +-- | Compute all defined names in scope and their fixities/notations. +-- Note that overloaded names (constructors) can have several +-- fixities/notations. Then we 'mergeNotations'. (See issue 1194.) +getDefinedNames :: [KindOfName] -> FlatScope -> [[NewNotation]] getDefinedNames kinds names = - [ (x, chooseFixity fixs) + [ mergeNotations $ + map (\d -> namesToNotation x (A.qnameName $ anameName d)) ds | (x, ds) <- Map.toList names , any ((`elem` kinds) . anameKind) ds - , let fixs = map (A.nameFixity . A.qnameName . anameName) ds - , not (null fixs) + , not (null ds) -- Andreas, 2013-03-21 see Issue 822 -- Names can have different kinds, i.e., 'defined' and 'constructor'. -- We need to consider all names that have *any* matching kind, -- not only those whose first appearing kind is matching. - ] + ] --- | Compute all names (first component) and operators (second component) in --- scope. +-- | Compute all names (first component) and operators/notations +-- (second component) in scope. localNames :: FlatScope -> ScopeM ([QName], [NewNotation]) localNames flat = do let defs = getDefinedNames allKindsOfNames flat @@ -106,17 +103,16 @@ , "defs = " ++ show defs , "locals= " ++ show locals ] - return $ split $ uniqOn fst $ map localOp locals ++ defs + let localNots = map localOp locals + localNames = Set.fromList $ map notaName localNots + otherNots = filter (\n -> not (Set.member (notaName n) localNames)) + (concat defs) + return $ split $ localNots ++ otherNots where - localOp (x, y) = (QName x, A.nameFixity y) - split ops = partitionEithers $ concatMap opOrNot ops - - opOrNot (q, Fixity' fx syn) = Left q : map Right (notaFromName ++ nota) - where - notaFromName = case unqualify q of - Name _ [_] -> [] - x -> [NewNotation q fx $ syntaxOf x] - nota = if null syn then [] else [NewNotation q fx syn] + localOp (x, y) = namesToNotation (QName x) y + split ops = partitionEithers $ concatMap opOrNot ops + opOrNot n = Left (notaName n) : + if null (notation n) then [] else [Right n] -- | Data structure filled in by @buildParsers@. -- The top-level parser @pTop@ is of primary interest, @@ -167,10 +163,10 @@ [ "names = " ++ show names , "ops = " ++ show ops , "cons = " ++ show cons ] - let conparts = Set.fromList $ concatMap notationNames $ map oldToNewNotation cons - opsparts = Set.fromList $ concatMap notationNames $ ops + let conparts = Set.fromList $ concatMap notationNames $ concat cons + opsparts = Set.fromList $ concatMap notationNames ops allParts = Set.union conparts opsparts - connames = Set.fromList $ map fst cons + connames = Set.fromList $ map (notaName . head) cons (non, fix) = partition nonfix ops set = Set.fromList names isAtom x = case use of @@ -192,23 +188,16 @@ level :: NewNotation -> Integer level = fixityLevel . notaFixity - isinfixl, isinfixr, isinfix, nonfix, isprefix, ispostfix :: NewNotation -> Bool - - isinfixl (NewNotation _ (LeftAssoc _ _) syn) = isInfix syn - isinfixl _ = False - - isinfixr (NewNotation _ (RightAssoc _ _) syn) = isInfix syn - isinfixr _ = False - - isinfix (NewNotation _ (NonAssoc _ _) syn) = isInfix syn - isinfix _ = False - - nonfix (NewNotation _ _ syn) = notationKind syn == NonfixNotation - isprefix (NewNotation _ _ syn) = notationKind syn == PrefixNotation - ispostfix (NewNotation _ _ syn) = notationKind syn == PostfixNotation + nonfix, isprefix, ispostfix :: NewNotation -> Bool + nonfix = (== NonfixNotation) . notationKind . notation + isprefix = (== PrefixNotation) . notationKind . notation + ispostfix = (== PostfixNotation) . notationKind . notation - isInfix :: Notation -> Bool - isInfix syn = notationKind syn == InfixNotation + isinfix :: Associativity -> NewNotation -> Bool + isinfix ass syn = + notationKind (notation syn) == InfixNotation + && + fixityAssoc (notaFixity syn) == ass -- | Group operators by precedence level order :: [NewNotation] -> [[NewNotation]] @@ -221,9 +210,9 @@ [] -> [id] fs -> fs where - inlfx = fixP infixlP isinfixl - inrfx = fixP infixrP isinfixr - infx = fixP infixP isinfix + inlfx = fixP infixlP (isinfix LeftAssoc) + inrfx = fixP infixrP (isinfix RightAssoc) + infx = fixP infixP (isinfix NonAssoc) prefx = fixP prefixP isprefix postfx = fixP postfixP ispostfix @@ -242,7 +231,7 @@ exprView e = case e of Ident x -> LocalV x App _ e1 e2 -> AppV e1 e2 - OpApp r d es -> OpAppV d es + OpApp r d ns es -> OpAppV d ns es HiddenArg _ e -> HiddenArgV e InstanceArg _ e -> InstanceArgV e Paren _ e -> ParenV e @@ -250,33 +239,33 @@ Underscore{} -> WildV e _ -> OtherV e unExprView e = case e of - LocalV x -> Ident x - AppV e1 e2 -> App (fuseRange e1 e2) e1 e2 - OpAppV d es -> OpApp (fuseRange d es) d es - HiddenArgV e -> HiddenArg (getRange e) e + LocalV x -> Ident x + AppV e1 e2 -> App (fuseRange e1 e2) e1 e2 + OpAppV d ns es -> OpApp (fuseRange d es) d ns es + HiddenArgV e -> HiddenArg (getRange e) e InstanceArgV e -> InstanceArg (getRange e) e - ParenV e -> Paren (getRange e) e - LamV bs e -> Lam (fuseRange bs e) bs e - WildV e -> e - OtherV e -> e + ParenV e -> Paren (getRange e) e + LamV bs e -> Lam (fuseRange bs e) bs e + WildV e -> e + OtherV e -> e instance IsExpr Pattern where exprView e = case e of - IdentP x -> LocalV x - AppP e1 e2 -> AppV e1 e2 - OpAppP r d es -> OpAppV d ((map . fmap . fmap) Ordinary es) - HiddenP _ e -> HiddenArgV e - InstanceP _ e -> InstanceArgV e - ParenP _ e -> ParenV e - WildP{} -> WildV e - _ -> OtherV e + IdentP x -> LocalV x + AppP e1 e2 -> AppV e1 e2 + OpAppP r d ns es -> OpAppV d ns ((map . fmap . fmap) Ordinary es) + HiddenP _ e -> HiddenArgV e + InstanceP _ e -> InstanceArgV e + ParenP _ e -> ParenV e + WildP{} -> WildV e + _ -> OtherV e unExprView e = case e of LocalV x -> IdentP x AppV e1 e2 -> AppP e1 e2 - OpAppV d es -> let ess :: [NamedArg Pattern] + OpAppV d ns es -> let ess :: [NamedArg Pattern] ess = (map . fmap . fmap) (fromOrdinary __IMPOSSIBLE__) es - in OpAppP (fuseRange d es) d ess + in OpAppP (fuseRange d es) d ns ess HiddenArgV e -> HiddenP (getRange e) e InstanceArgV e -> InstanceP (getRange e) e ParenV e -> ParenP (getRange e) e @@ -284,46 +273,21 @@ WildV e -> e OtherV e -> e -{- TRASH -instance IsExpr LHSCore where - exprView e = case e of - LHSHead f ps -> foldl AppV (LocalV f) $ map exprView ps - LHSProj d ps1 e ps2 -> foldl AppV (LocalV d) $ - map exprView ps1 ++ exprView e : map exprView ps2 - unExprView e = LHSHead f ps - where p :: Pattern - p = unExprView - (f, ps) = lhsArgs p --} - --------------------------------------------------------------------------- -- * Helpers for pattern and lhs parsing --------------------------------------------------------------------------- --- Andreas, 2011-11-24 moved here from ConcreteToAbstract -lhsArgs :: Pattern -> (Name, [NamedArg Pattern]) -lhsArgs p = case lhsArgs' p of - Just (x, args) -> (x, args) - Nothing -> __IMPOSSIBLE__ - --- | @lhsArgs' p@ splits a lhs @f ps@, given as a pattern @p@, --- into @(f, ps)@. -lhsArgs' :: Pattern -> Maybe (Name, [NamedArg Pattern]) -lhsArgs' p = case patternAppView p of - Common.Arg _ (Named _ (IdentP (QName x))) : ps -> Just (x, ps) - _ -> Nothing - -- | View a pattern @p@ as a list @p0 .. pn@ where @p0@ is the identifier -- (in most cases a constructor). -- -- Pattern needs to be parsed already (operators resolved). patternAppView :: Pattern -> [NamedArg Pattern] patternAppView p = case p of - AppP p arg -> patternAppView p ++ [arg] - OpAppP _ x ps -> defaultNamedArg (IdentP x) : ps - ParenP _ p -> patternAppView p - RawAppP _ _ -> __IMPOSSIBLE__ - _ -> [ defaultNamedArg p ] + AppP p arg -> patternAppView p ++ [arg] + OpAppP _ x _ ps -> defaultNamedArg (IdentP x) : ps + ParenP _ p -> patternAppView p + RawAppP _ _ -> __IMPOSSIBLE__ + _ -> [ defaultNamedArg p ] --------------------------------------------------------------------------- @@ -336,7 +300,7 @@ AppP p (Common.Arg info q) -> fullParen' <$> (AppP <$> parsePat prs p <*> (Common.Arg info <$> traverse (parsePat prs) q)) RawAppP _ ps -> fullParen' <$> (parsePat prs =<< parse prs ps) - OpAppP r d ps -> fullParen' . OpAppP r d <$> (mapM . traverse . traverse) (parsePat prs) ps + OpAppP r d ns ps -> fullParen' . OpAppP r d ns <$> (mapM . traverse . traverse) (parsePat prs) ps HiddenP _ _ -> fail "bad hidden argument" InstanceP _ _ -> fail "bad instance argument" AsP r x p -> AsP r x <$> parsePat prs p @@ -402,7 +366,8 @@ rs -> typeError $ AmbiguousParseForLHS lhsOrPatSyn p $ map (fullParen . fst) rs where - getNames kinds flat = map fst $ getDefinedNames kinds flat + getNames kinds flat = + map (notaName . head) $ getDefinedNames kinds flat -- validPattern returns an empty or singleton list (morally a Maybe) validPattern :: PatternCheckConfig -> Pattern -> [(Pattern, ParseLHS)] @@ -461,7 +426,7 @@ -- intended _* applied to true, or as true applied to a variable *. If we -- check arities this problem won't appear. parseLHS :: Name -> Pattern -> ScopeM LHSCore -parseLHS top p = do +parseLHS top p = billToParser $ do res <- parseLHS' IsLHS (Just top) p case res of Right (f, lhs) -> return lhs @@ -480,7 +445,7 @@ parsePatternSyn = parsePatternOrSyn IsPatSyn parsePatternOrSyn :: LHSOrPatSyn -> Pattern -> ScopeM Pattern -parsePatternOrSyn lhsOrPatSyn p = do +parsePatternOrSyn lhsOrPatSyn p = billToParser $ do res <- parseLHS' lhsOrPatSyn Nothing p case res of Left p -> return p @@ -502,7 +467,7 @@ appView :: Pattern -> [Pattern] appView p = case p of AppP p a -> appView p ++ [namedArg a] - OpAppP _ op ps -> IdentP op : map namedArg ps + OpAppP _ op _ ps -> IdentP op : map namedArg ps ParenP _ p -> appView p RawAppP _ _ -> __IMPOSSIBLE__ HiddenP _ _ -> __IMPOSSIBLE__ @@ -517,7 +482,7 @@ ParenP _ p -> patternQNames p HiddenP _ p -> patternQNames (namedThing p) InstanceP _ p -> patternQNames (namedThing p) - OpAppP r d ps -> __IMPOSSIBLE__ + OpAppP r d _ ps -> __IMPOSSIBLE__ AppP{} -> __IMPOSSIBLE__ AsP r x p -> patternQNames p AbsurdP{} -> [] @@ -536,25 +501,16 @@ -- | Parse a list of expressions into an application. parseApplication :: [Expr] -> ScopeM Expr parseApplication [e] = return e -parseApplication es = do +parseApplication es = billToParser $ do -- Build the parser let ms = qualifierModules [ q | Ident q <- es ] flat <- flattenScope ms <$> getScope - -- Andreas, 2014-04-27 Time for building the parser is negligible - p <- -- billSub [Bench.Parsing, Bench.Operators, Bench.BuildParser] $ - buildParsers (getRange es) flat UseBoundNames + p <- buildParsers (getRange es) flat UseBoundNames -- Parse case force $ parse (pTop p) es of [e] -> return e - [] -> do - -- When the parser fails and a name is not in scope, it is more - -- useful to say that to the user rather than just "failed". - inScope <- partsInScope flat - case [ x | Ident x <- es, not (Set.member x inScope) ] of - [] -> typeError $ NoParseForApplication es - xs -> typeError $ NotInScope xs - + [] -> typeError $ NoParseForApplication es es' -> typeError $ AmbiguousParseForApplication es $ map fullParen es' parseModuleIdentifier :: Expr -> ScopeM QName @@ -562,7 +518,7 @@ parseModuleIdentifier e = typeError $ NotAModuleExpr e parseRawModuleApplication :: [Expr] -> ScopeM (QName, [NamedArg Expr]) -parseRawModuleApplication es = do +parseRawModuleApplication es = billToParser $ do let e : es_args = es m <- parseModuleIdentifier e @@ -574,12 +530,7 @@ -- Parse case {-force $-} parse (pArgs p) es_args of -- TODO: not sure about forcing [as] -> return (m, as) - [] -> do - inScope <- partsInScope flat - case [ x | Ident x <- es_args, not (Set.member x inScope) ] of - [] -> typeError $ NoParseForApplication es - xs -> typeError $ NotInScope xs - + [] -> typeError $ NoParseForApplication es ass -> do let f = fullParen . foldl (App noRange) (Ident m) typeError $ AmbiguousParseForApplication es @@ -619,7 +570,7 @@ Hidden -> e2 Instance -> e2 NotHidden -> fullParen' <$> e2 - OpAppV x es -> par $ unExprView $ OpAppV x $ (map . fmap . fmap . fmap) fullParen' es + OpAppV x ns es -> par $ unExprView $ OpAppV x ns $ (map . fmap . fmap . fmap) fullParen' es LamV bs e -> par $ unExprView $ LamV bs (fullParen e) where par = unExprView . ParenV diff --git a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs --- a/src/full/Agda/Syntax/Concrete/Operators/Parser.hs +++ b/src/full/Agda/Syntax/Concrete/Operators/Parser.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Agda.Syntax.Concrete.Operators.Parser where @@ -6,15 +6,20 @@ import Control.Exception (throw) import Data.Maybe +import Data.Set (Set) import Agda.Syntax.Position +import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) import Agda.Syntax.Fixity import Agda.Syntax.Notation import Agda.Syntax.Concrete + import Agda.TypeChecking.Monad.Base (TCErr(Exception)) -import Agda.Utils.ReadP + import Agda.Utils.Monad +import Agda.Utils.Pretty +import Agda.Utils.ReadP #include "undefined.h" import Agda.Utils.Impossible @@ -24,7 +29,9 @@ | WildV e | OtherV e | AppV e (NamedArg e) - | OpAppV QName [NamedArg (OpApp e)] + | OpAppV QName (Set A.Name) [NamedArg (OpApp e)] + -- ^ The 'QName' is possibly ambiguous, but it must correspond + -- to one of the names in the set. | HiddenArgV (Named_ e) | InstanceArgV (Named_ e) | LamV [LamBinding] e @@ -79,8 +86,9 @@ -- Note: it would be better to take the decision of "postprocessing" at the same -- place as where the holes are discarded, however that would require a dependently -- typed function (or duplicated code) -opP :: IsExpr e => ReadP e e -> NewNotation -> ReadP e (NewNotation,Range,[e]) -opP p nsyn@(NewNotation q _ syn) = do +opP :: IsExpr e => + ReadP e e -> NewNotation -> ReadP e (NewNotation,Range,[e]) +opP p nsyn@(NewNotation q _ _ syn) = do (range,es) <- worker (init $ qnameParts q) $ removeExternalHoles syn return (nsyn,range,es) where worker ms [IdPart x] = do r <- partP ms x; return (r,[]) @@ -97,7 +105,8 @@ -- | Given a name with a syntax spec, and a list of parsed expressions -- fitting it, rebuild the expression. rebuild :: forall e. IsExpr e => NewNotation -> Range -> [e] -> e -rebuild (NewNotation name _ syn) r es = unExprView $ OpAppV (setRange r name) exprs +rebuild (NewNotation name names _ syn) r es = + unExprView $ OpAppV (setRange r name) names exprs where exprs = map findExprFor [0..lastHole] filledHoles = zip es (filter isAHole syn) @@ -118,7 +127,8 @@ rebuildBinding (LocalV (QName name)) = DomainFree defaultArgInfo $ mkBoundName_ name rebuildBinding (WildV e) = DomainFree defaultArgInfo $ mkBoundName_ $ Name noRange [Hole] -rebuildBinding e = throw $ Exception (getRange e) "Expected variable name in binding position" +rebuildBinding e = throw $ Exception (getRange e) $ + text "Expected variable name in binding position" -- | Parse using the appropriate fixity, given a parser parsing the -- operator part, the name of the operator, and a parser of diff --git a/src/full/Agda/Syntax/Concrete/Pretty.hs b/src/full/Agda/Syntax/Concrete/Pretty.hs --- a/src/full/Agda/Syntax/Concrete/Pretty.hs +++ b/src/full/Agda/Syntax/Concrete/Pretty.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + {-| Pretty printer for the concrete syntax. -} module Agda.Syntax.Concrete.Pretty where +import Prelude hiding (null) + import Data.Char import Data.Functor import Data.Maybe @@ -20,6 +21,8 @@ import Agda.Syntax.Notation import Agda.Syntax.Position +import Agda.Utils.Functor +import Agda.Utils.Null import Agda.Utils.Pretty import Agda.Utils.String @@ -64,28 +67,19 @@ arrow = text "\x2192" lambda = text "\x03bb" -pHidden :: Pretty a => ArgInfo -> a -> Doc -pHidden i = bracks h . pretty - where bracks Hidden = braces' - bracks Instance = dbraces - bracks NotHidden= id - h = argInfoHiding i +-- | @prettyHiding info visible doc@ puts the correct braces +-- around @doc@ according to info @info@ and returns +-- @visible doc@ if the we deal with a visible thing. +prettyHiding :: LensHiding a => a -> (Doc -> Doc) -> Doc -> Doc +prettyHiding a parens = + case getHiding a of + Hidden -> braces' + Instance -> dbraces + NotHidden -> parens -pRelevance :: Pretty a => ArgInfo -> a -> Doc -pRelevance i a = - let d = pretty a - in if render d == "_" then d else pretty (argInfoRelevance i) <> d -{- -pRelevance Forced a = pretty a -pRelevance UnusedArg a = pretty a -pRelevance Relevant a = pretty a -pRelevance Irrelevant a = - let d = pretty a - in if render d == "_" then d else text "." <> d -pRelevance NonStrict a = - let d = pretty a - in if render d == "_" then d else text ".." <> d --} +prettyRelevance :: LensRelevance a => a -> Doc -> Doc +prettyRelevance a d = + if render d == "_" then d else pretty (getRelevance a) <> d instance (Pretty a, Pretty b) => Pretty (a, b) where pretty (a, b) = parens $ pretty a <> comma <+> pretty b @@ -93,8 +87,11 @@ instance Pretty (ThingWithFixity Name) where pretty (ThingWithFixity n _) = pretty n +instance Pretty a => Pretty (WithHiding a) where + pretty w = prettyHiding w id $ pretty $ dget w + instance Pretty Relevance where - pretty Forced = empty + pretty Forced{} = empty pretty UnusedArg = empty pretty Relevant = empty pretty Irrelevant = text "." @@ -123,8 +120,8 @@ -- sep [ pretty e1 -- , nest 2 $ fsep $ map pretty args -- ] - RawApp _ es -> fsep $ map pretty es - OpApp _ q es -> fsep $ prettyOpApp q es + RawApp _ es -> fsep $ map pretty es + OpApp _ q _ es -> fsep $ prettyOpApp q es WithApp _ e es -> fsep $ pretty e : map ((text "|" <+>) . pretty) es @@ -193,21 +190,18 @@ instance Pretty LamBinding where -- TODO guilhem: colors are unused (colored syntax disallowed) - pretty (DomainFree i x) = pRelevance i $ pHidden i $ pretty x + pretty (DomainFree i x) = prettyRelevance i $ prettyHiding i id $ pretty x pretty (DomainFull b) = pretty b instance Pretty TypedBindings where - pretty (TypedBindings _ a) = - pRelevance (argInfo a) $ bracks $ pretty $ WithColors (argColors a) $ unArg a + pretty (TypedBindings _ a) = prettyRelevance a $ prettyHiding a p $ + pretty $ WithColors (argColors a) $ unArg a where - bracks = case getHiding a of - Hidden -> braces' - Instance -> dbraces - NotHidden | isMeta (unArg a) -> id - | otherwise -> parens + p | isUnderscore (unArg a) = id + | otherwise = parens - isMeta (TBind _ _ (Underscore _ Nothing)) = True - isMeta _ = False + isUnderscore (TBind _ _ (Underscore _ Nothing)) = True + isUnderscore _ = False newtype Tel = Tel Telescope @@ -247,7 +241,7 @@ smashTel :: Telescope -> Telescope smashTel (TypedBindings r (Common.Arg i (TBind r' xs e)) : TypedBindings _ (Common.Arg i' (TBind _ ys e')) : tel) - | show i == show i' && show e == show e' && all isUnnamed (xs ++ ys) = + | show i == show i' && show e == show e' && all (isUnnamed . dget) (xs ++ ys) = smashTel (TypedBindings r (Common.Arg i (TBind r' (xs ++ ys) e)) : tel) where isUnnamed x = boundLabel x == boundName x @@ -305,13 +299,13 @@ pretty d = case d of TypeSig i x e -> - sep [ pRelevance i $ pretty x <+> pColors ":" (argInfoColors i) + sep [ prettyRelevance i $ pretty x <+> pColors ":" (argInfoColors i) , nest 2 $ pretty e ] Field x (Common.Arg i e) -> sep [ text "field" - , nest 2 $ pRelevance i $ pHidden i $ - TypeSig (i {argInfoRelevance = Relevant}) x e + , nest 2 $ prettyRelevance i $ prettyHiding i id $ + pretty $ TypeSig (i {argInfoRelevance = Relevant}) x e ] FunClause lhs rhs wh -> sep [ pretty lhs @@ -456,9 +450,12 @@ TerminationMeasure _ x -> hsep $ [text "MEASURE", pretty x] instance Pretty Fixity where - pretty (LeftAssoc _ n) = text "infixl" <+> text (show n) - pretty (RightAssoc _ n) = text "infixr" <+> text (show n) - pretty (NonAssoc _ n) = text "infix" <+> text (show n) + pretty (Fixity _ n ass) = text s <+> text (show n) + where + s = case ass of + LeftAssoc -> "infixl" + RightAssoc -> "infixr" + NonAssoc -> "infix" instance Pretty GenPart where pretty (IdPart x) = text x @@ -478,7 +475,7 @@ -- Andreas 2010-09-24: and in record fields pretty a = -- pRelevance r $ -- TODO guilhem: print colors - pHidden (argInfo a) $ unArg a + prettyHiding (argInfo a) id $ pretty $ unArg a instance Pretty e => Pretty (Named_ e) where pretty (Named Nothing e) = pretty e @@ -490,19 +487,19 @@ instance Pretty Pattern where pretty p = case p of - IdentP x -> pretty x - AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ] - RawAppP _ ps -> fsep $ map pretty ps - OpAppP _ q ps -> fsep $ prettyOpApp q ps - HiddenP _ p -> braces' $ pretty p - InstanceP _ p -> dbraces $ pretty p - ParenP _ p -> parens $ pretty p - WildP _ -> underscore - AsP _ x p -> pretty x <> text "@" <> pretty p - DotP _ p -> text "." <> pretty p - AbsurdP _ -> text "()" - LitP l -> pretty l - QuoteP _ -> text "quote" + IdentP x -> pretty x + AppP p1 p2 -> sep [ pretty p1, nest 2 $ pretty p2 ] + RawAppP _ ps -> fsep $ map pretty ps + OpAppP _ q _ ps -> fsep $ prettyOpApp q ps + HiddenP _ p -> braces' $ pretty p + InstanceP _ p -> dbraces $ pretty p + ParenP _ p -> parens $ pretty p + WildP _ -> underscore + AsP _ x p -> pretty x <> text "@" <> pretty p + DotP _ p -> text "." <> pretty p + AbsurdP _ -> text "()" + LitP l -> pretty l + QuoteP _ -> text "quote" prettyOpApp :: Pretty a => QName -> [a] -> [Doc] prettyOpApp q es = prOp ms xs es diff --git a/src/full/Agda/Syntax/Fixity.hs b/src/full/Agda/Syntax/Fixity.hs --- a/src/full/Agda/Syntax/Fixity.hs +++ b/src/full/Agda/Syntax/Fixity.hs @@ -1,24 +1,32 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-| Definitions for fixity, precedence levels, and declared syntax. -} module Agda.Syntax.Fixity where import Data.Foldable +import Data.Function import Data.List as List +import Data.Set (Set) +import qualified Data.Set as Set import Data.Traversable import Data.Typeable (Typeable) import Agda.Syntax.Position import Agda.Syntax.Common +import {-# SOURCE #-} qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Concrete.Name import Agda.Syntax.Notation import Agda.Utils.List +#include "undefined.h" +import Agda.Utils.Impossible + -- * Notation coupled with 'Fixity' -- | The notation is handled as the fixity in the renamer. @@ -36,27 +44,34 @@ -- | All the notation information related to a name. data NewNotation = NewNotation { notaName :: QName - -- ^ The concrete name the syntax or fixity belongs to. + , notaNames :: Set A.Name + -- ^ The names the syntax and/or fixity belong to. + -- + -- Invariant: The set is non-empty. Every name in the list matches + -- 'notaName'. , notaFixity :: Fixity - -- ^ Associativity and precedence (fixity) of the name. + -- ^ Associativity and precedence (fixity) of the names. , notation :: Notation - -- ^ Syntax associated with the name. + -- ^ Syntax associated with the names. } deriving (Typeable, Show) --- | If an operator has no specific notation, recover it from its name. -oldToNewNotation :: (QName, Fixity') -> NewNotation -oldToNewNotation (name, Fixity' f syn) = NewNotation - { notaName = name +-- | If an operator has no specific notation, then it is computed from +-- its name. +namesToNotation :: QName -> A.Name -> NewNotation +namesToNotation q n = NewNotation + { notaName = q + , notaNames = Set.singleton n , notaFixity = f - , notation = if null syn then syntaxOf $ unqualify name else syn + , notation = if null syn then syntaxOf $ unqualify q else syn } + where Fixity' f syn = A.nameFixity n -- | Return the 'IdPart's of a notation, the first part qualified, -- the other parts unqualified. -- This allows for qualified use of operators, e.g., -- @M.for x ∈ xs return e@, or @x ℕ.+ y@. notationNames :: NewNotation -> [QName] -notationNames (NewNotation q _ parts) = +notationNames (NewNotation q _ _ parts) = zipWith ($) (reQualify : repeat QName) [Name noRange [Id x] | IdPart x <- parts ] where -- The qualification of @q@. @@ -84,44 +99,59 @@ defaultFixity' :: Fixity' defaultFixity' = Fixity' defaultFixity defaultNotation --- | Removes copies of @defaultFixity'@ from a list of fixities. --- Never returns an empty list, though, rather a singleton list --- consisting of @defaultFixity'@. -interestingFixities :: [Fixity'] -> [Fixity'] -interestingFixities fixs = if null fixs' then [defaultFixity'] else fixs' - where fixs' = filter (not . (== defaultFixity')) fixs +-- | Merges all 'NewNotation's that have the same notation. +-- +-- If all 'NewNotation's with a given notation have the same fixity, +-- then this fixity is preserved, and otherwise it is replaced by +-- 'defaultFixity'. +-- +-- Precondition: No 'A.Name' may occur in more than one list element. +-- Every 'NewNotation' must have the same 'notaName'. +-- +-- Postcondition: No 'A.Name' occurs in more than one list element. +mergeNotations :: [NewNotation] -> [NewNotation] +mergeNotations = map (merge . fixFixities) . groupOn notation + where + fixFixities ns + | allEqual (map notaFixity ns) = ns + | otherwise = + map (\n -> n { notaFixity = defaultFixity }) ns --- | If different interesting fixities are available for the same symbol, --- we take none of them. -chooseFixity :: [Fixity'] -> Fixity' -chooseFixity fixs = if allEqual fixs' then head fixs' else defaultFixity' - where fixs' = interestingFixities fixs + merge :: [NewNotation] -> NewNotation + merge [] = __IMPOSSIBLE__ + merge ns@(n : _) = n { notaNames = Set.unions $ map notaNames ns } -- * Fixity +-- | Associativity. + +data Associativity = NonAssoc | LeftAssoc | RightAssoc + deriving (Eq, Ord, Show, Typeable) + -- | Fixity of operators. -data Fixity - = LeftAssoc { fixityRange :: Range, fixityLevel :: Integer } - | RightAssoc { fixityRange :: Range, fixityLevel :: Integer } - | NonAssoc { fixityRange :: Range, fixityLevel :: Integer } +data Fixity = + Fixity { fixityRange :: Range + , fixityLevel :: Integer + , fixityAssoc :: Associativity + } deriving (Typeable, Show) instance Eq Fixity where - LeftAssoc _ n == LeftAssoc _ m = n == m - RightAssoc _ n == RightAssoc _ m = n == m - NonAssoc _ n == NonAssoc _ m = n == m - _ == _ = False + f1 == f2 = compare f1 f2 == EQ +instance Ord Fixity where + compare = compare `on` (\f -> (fixityLevel f, fixityAssoc f)) + -- For @instance Pretty Fixity@, see Agda.Syntax.Concrete.Pretty -- | The default fixity. Currently defined to be @'NonAssoc' 20@. defaultFixity :: Fixity -defaultFixity = NonAssoc noRange 20 +defaultFixity = Fixity noRange 20 NonAssoc -- | Hack used for @syntax@ facility. noFixity :: Fixity -noFixity = NonAssoc noRange (negate 666) +noFixity = Fixity noRange (negate 666) NonAssoc -- Ts,ts,ts, why the number of the beast? Revelation 13, 18 -- -- It's not the number of the beast, it's the negation of the @@ -150,10 +180,10 @@ -- | Do we need to bracket an operator application of the given fixity -- in a context with the given precedence. opBrackets :: Fixity -> Precedence -> Bool -opBrackets (LeftAssoc _ n1) - (LeftOperandCtx (LeftAssoc _ n2)) | n1 >= n2 = False -opBrackets (RightAssoc _ n1) - (RightOperandCtx (RightAssoc _ n2)) | n1 >= n2 = False +opBrackets (Fixity _ n1 LeftAssoc) + (LeftOperandCtx (Fixity _ n2 LeftAssoc)) | n1 >= n2 = False +opBrackets (Fixity _ n1 RightAssoc) + (RightOperandCtx (Fixity _ n2 RightAssoc)) | n1 >= n2 = False opBrackets f1 (LeftOperandCtx f2) | fixityLevel f1 > fixityLevel f2 = False opBrackets f1 @@ -204,9 +234,7 @@ getRange = fixityRange instance KillRange Fixity where - killRange (LeftAssoc _ n) = LeftAssoc noRange n - killRange (RightAssoc _ n) = RightAssoc noRange n - killRange (NonAssoc _ n) = NonAssoc noRange n + killRange f = f { fixityRange = noRange } instance KillRange Fixity' where - killRange (Fixity' f n) = killRange1 (flip Fixity' n) f + killRange (Fixity' f n) = killRange2 Fixity' f n diff --git a/src/full/Agda/Syntax/Fixity.hs-boot b/src/full/Agda/Syntax/Fixity.hs-boot new file mode 100644 --- /dev/null +++ b/src/full/Agda/Syntax/Fixity.hs-boot @@ -0,0 +1,3 @@ +module Agda.Syntax.Fixity where + +data Fixity' diff --git a/src/full/Agda/Syntax/Info.hs b/src/full/Agda/Syntax/Info.hs --- a/src/full/Agda/Syntax/Info.hs +++ b/src/full/Agda/Syntax/Info.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-| An info object contains additional information about a piece of abstract diff --git a/src/full/Agda/Syntax/Internal.hs b/src/full/Agda/Syntax/Internal.hs --- a/src/full/Agda/Syntax/Internal.hs +++ b/src/full/Agda/Syntax/Internal.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + DeriveFoldable, + DeriveFunctor, + DeriveTraversable, + FlexibleInstances, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + StandaloneDeriving, + TemplateHaskell #-} module Agda.Syntax.Internal ( module Agda.Syntax.Internal @@ -18,15 +19,22 @@ import Prelude hiding (foldr, mapM, null) import Control.Arrow ((***)) -import Control.Applicative +import Control.Applicative hiding (empty) import Control.Monad.Identity hiding (mapM) import Control.Monad.State hiding (mapM) import Control.Parallel -import Data.Foldable +import Data.Foldable ( Foldable, foldMap ) import Data.Function import qualified Data.List as List import Data.Maybe +import Data.Monoid + +-- base-4.7 defines the Num instance for Sum +#if !(MIN_VERSION_base(4,7,0)) +import Data.Orphans () +#endif + import Data.Traversable import Data.Typeable (Typeable) @@ -39,6 +47,7 @@ import Agda.Utils.Empty import Agda.Utils.Functor import Agda.Utils.Geniplate +import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Null import Agda.Utils.Permutation @@ -157,9 +166,13 @@ | NoAbs { absName :: ArgName, unAbs :: a } deriving (Typeable, Functor, Foldable, Traversable) +instance Decoration Abs where + traverseF f (Abs x a) = Abs x <$> f a + traverseF f (NoAbs x a) = NoAbs x <$> f a + -- | Types are terms with a sort annotation. -- -data Type' a = El { getSort :: Sort, unEl :: a } +data Type' a = El { _getSort :: Sort, unEl :: a } deriving (Typeable, Show, Functor, Foldable, Traversable) type Type = Type' Term @@ -167,6 +180,22 @@ instance Decoration Type' where traverseF f (El s a) = El s <$> f a +class LensSort a where + lensSort :: Lens' Sort a + getSort :: a -> Sort + getSort a = a ^. lensSort + +instance LensSort (Type' a) where + lensSort f (El s a) = f s <&> \ s' -> El s' a + +-- General instance leads to overlapping instances. +-- instance (Decoration f, LensSort a) => LensSort (f a) where +instance LensSort a => LensSort (Common.Dom c a) where + lensSort = traverseF . lensSort + +instance LensSort a => LensSort (Abs a) where + lensSort = traverseF . lensSort + -- | Sequence of types. An argument of the first type is bound in later types -- and so on. data Tele a = EmptyTel @@ -175,14 +204,10 @@ type Telescope = Tele (Dom Type) -instance Null (Tele a) where - null EmptyTel = True - null ExtendTel{} = False - empty = EmptyTel - +-- | A traversal for the names in a telescope. mapAbsNamesM :: Applicative m => (ArgName -> m ArgName) -> Tele a -> m (Tele a) mapAbsNamesM f EmptyTel = pure EmptyTel -mapAbsNamesM f (ExtendTel a (Abs x b)) = ExtendTel a <$> (Abs <$> f x <*> mapAbsNamesM f b) +mapAbsNamesM f (ExtendTel a ( Abs x b)) = ExtendTel a <$> ( Abs <$> f x <*> mapAbsNamesM f b) mapAbsNamesM f (ExtendTel a (NoAbs x b)) = ExtendTel a <$> (NoAbs <$> f x <*> mapAbsNamesM f b) -- Ulf, 2013-11-06: Last case is really impossible but I'd rather find out we -- violated that invariant somewhere other than here. @@ -203,13 +228,16 @@ -- | Sorts. -- -data Sort = Type Level - | Prop -- ignore me - | Inf - | DLub Sort (Abs Sort) - -- ^ if the free variable occurs in the second sort - -- the whole thing should reduce to Inf, otherwise - -- it's the normal Lub +data Sort + = Type Level -- ^ @Set ℓ@. + | Prop -- ^ Dummy sort. + | Inf -- ^ @Setω@. + | SizeUniv -- ^ @SizeUniv@, a sort inhabited by type @Size@. + | DLub Sort (Abs Sort) + -- ^ Dependent least upper bound. + -- If the free variable occurs in the second sort, + -- the whole thing should reduce to Inf, + -- otherwise it's the normal lub. deriving (Typeable, Show) -- | A level is a maximum expression of 0..n 'PlusLevel' expressions @@ -219,14 +247,19 @@ newtype Level = Max [PlusLevel] deriving (Show, Typeable) -data PlusLevel = ClosedLevel Integer - | Plus Integer LevelAtom +data PlusLevel + = ClosedLevel Integer -- ^ @n@, to represent @Setₙ@. + | Plus Integer LevelAtom -- ^ @n + ℓ@. deriving (Show, Typeable) +-- | An atomic term of type @Level@. data LevelAtom = MetaLevel MetaId Elims + -- ^ A meta variable targeting @Level@ under some eliminations. | BlockedLevel MetaId Term - | NeutralLevel Term + -- ^ A term of type @Level@ whose reduction is blocked by a meta. + | NeutralLevel NotBlocked Term + -- ^ A neutral term of type @Level@. | UnreducedLevel Term -- ^ Introduced by 'instantiate', removed by 'reduce'. deriving (Show, Typeable) @@ -236,17 +269,113 @@ newtype MetaId = MetaId { metaId :: Nat } deriving (Eq, Ord, Num, Real, Enum, Integral, Typeable) +-- | Even if we are not stuck on a meta during reduction +-- we can fail to reduce a definition by pattern matching +-- for another reason. +data NotBlocked + = StuckOn Elim + -- ^ The 'Elim' is neutral and block a pattern match. + | Underapplied + -- ^ Not enough arguments were supplied to complete the matching. + | AbsurdMatch + -- ^ We matched an absurd clause, results in a neutral 'Def'. + | MissingClauses + -- ^ We ran out of clauses, all considered clauses + -- produced an actual mismatch. + -- This can happen when try to reduce a function application + -- but we are still missing some function clauses. + -- See "Agda.TypeChecking.Patterns.Match". + | ReallyNotBlocked + -- ^ Reduction was not blocked, we reached a whnf + -- which can be anything but a stuck @'Def'@. + deriving (Show, Typeable) + +-- | 'ReallyNotBlocked' is the unit. +-- 'MissingClauses' is dominant. +-- @'StuckOn'{}@ should be propagated, if tied, we take the left. +instance Monoid NotBlocked where + -- ReallyNotBlocked is neutral + mempty = ReallyNotBlocked + ReallyNotBlocked `mappend` b = b + -- MissingClauses is dominant (absorptive) + b@MissingClauses `mappend` _ = b + _ `mappend` b@MissingClauses = b + -- StuckOn is second strongest + b@StuckOn{} `mappend` _ = b + _ `mappend` b@StuckOn{} = b + b `mappend` _ = b + -- | Something where a meta variable may block reduction. -data Blocked t = Blocked MetaId t - | NotBlocked t - deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable) +data Blocked t + = Blocked { theBlockingMeta :: MetaId , ignoreBlocking :: t } + | NotBlocked { blockingStatus :: NotBlocked, ignoreBlocking :: t } + deriving (Typeable, Show, Functor, Foldable, Traversable) + -- deriving (Typeable, Eq, Ord, Functor, Foldable, Traversable) +-- | Blocking by a meta is dominant. instance Applicative Blocked where pure = notBlocked - Blocked x f <*> e = Blocked x $ f (ignoreBlocking e) - NotBlocked f <*> e = f <$> e + f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e) +-- -- | Blocking by a meta is dominant. +-- instance Applicative Blocked where +-- pure = notBlocked +-- Blocked x f <*> e = Blocked x $ f (ignoreBlocking e) +-- NotBlocked nb f <*> Blocked x e = Blocked x $ f e +-- NotBlocked nb f <*> NotBlocked nb' e = NotBlocked (nb `mappend` nb') $ f e +-- | @'Blocked' t@ without the @t@. +type Blocked_ = Blocked () + +instance Monoid Blocked_ where + mempty = notBlocked () + -- ReallyNotBlocked is neutral + NotBlocked ReallyNotBlocked _ `mappend` b = b + b `mappend` NotBlocked ReallyNotBlocked _ = b + -- StuckOn is strongest + b@(NotBlocked StuckOn{} _) `mappend` _ = b + _ `mappend` b@(NotBlocked StuckOn{} _) = b + -- Blocked is weakest + b@Blocked{} `mappend` Blocked{} = b + Blocked{} `mappend` b = b + b `mappend` Blocked{} = b + -- For the other cases, we take the left + b `mappend` _ = b + +-- | When trying to reduce @f es@, on match failed on one +-- elimination @e ∈ es@ that came with info @r :: NotBlocked@. +-- @stuckOn e r@ produces the new @NotBlocked@ info. +-- +-- 'MissingClauses' must be propagated, as this is blockage +-- that can be lifted in the future (as more clauses are added). +-- +-- @'StuckOn' e0@ is also propagated, since it provides more +-- precise information as @StuckOn e@ (as @e0@ is the original +-- reason why reduction got stuck and usually a subterm of @e@). +-- An information like @StuckOn (Apply (Arg info (Var i [])))@ +-- (stuck on a variable) could be used by the lhs/coverage checker +-- to trigger a split on that (pattern) variable. +-- +-- In the remaining cases for @r@, we are terminally stuck +-- due to @StuckOn e@. Propagating @'AbsurdMatch'@ does not +-- seem useful. +-- +-- 'Underapplied' must not be propagated, as this would mean +-- that @f es@ is underapplied, which is not the case (it is stuck). +-- Note that 'Underapplied' can only arise when projection patterns were +-- missing to complete the original match (in @e@). +-- (Missing ordinary pattern would mean the @e@ is of function type, +-- but we cannot match against something of function type.) +stuckOn :: Elim -> NotBlocked -> NotBlocked +stuckOn e r = + case r of + MissingClauses -> r + StuckOn{} -> r + Underapplied -> r' + AbsurdMatch -> r' + ReallyNotBlocked -> r' + where r' = StuckOn e + --------------------------------------------------------------------------- -- * Definitions --------------------------------------------------------------------------- @@ -258,7 +387,7 @@ -- the patterns to the order they occur in the telescope. The body -- binds the variables in the order they appear in the patterns. -- --- @clauseTel ~ permute clausePerm (patternVars clausPats)@ +-- @clauseTel ~ permute clausePerm (patternVars namedClausePats)@ -- -- Terms in dot patterns are valid in the clause telescope. -- @@ -266,12 +395,16 @@ -- as variables. TODO: Change this! data Clause = Clause { clauseRange :: Range - , clauseTel :: Telescope -- ^ The types of the pattern variables. + , clauseTel :: Telescope + -- ^ @Δ@: The types of the pattern variables. , clausePerm :: Permutation + -- ^ @π@ with @Γ ⊢ renamingR π : Δ@, which means @Δ ⊢ renaming π : Γ@. , namedClausePats :: [NamedArg Pattern] + -- ^ @let Γ = patternVars namedClausePats@ , clauseBody :: ClauseBody + -- ^ @λΓ.v@ , clauseType :: Maybe (Arg Type) - -- ^ The type of the rhs under @clauseTel@. + -- ^ @Δ ⊢ 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. @@ -342,6 +475,8 @@ type Pattern = Pattern' PatVarName -- ^ The @PatVarName@ is a name suggestion. +-- | Type used when numbering pattern variables. +type DeBruijnPattern = Pattern' (Int, PatVarName) namedVarP :: PatVarName -> Named (Ranged PatVarName) Pattern namedVarP x = Named named $ VarP x @@ -354,8 +489,24 @@ -- The @Type@ is the type of the whole record pattern. -- The scope used for the type is given by any outer scope -- plus the clause's telescope ('clauseTel'). -type ConPatternInfo = Maybe (Bool, Arg Type) +data ConPatternInfo = ConPatternInfo + { conPRecord :: Maybe Bool + -- ^ @Nothing@ if data constructor. + -- @Just@ if record constructor, then @True@ if pattern + -- was expanded from an implicit pattern. + , conPType :: Maybe (Arg Type) + -- ^ The type of the whole constructor pattern. + -- Should be present (@Just@) if constructor pattern is + -- is generated ordinarily by type-checking. + -- Could be absent (@Nothing@) if pattern comes from some + -- plugin (like Agsy). + -- Needed e.g. for with-clause stripping. + } + deriving (Typeable, Show) +noConPatternInfo :: ConPatternInfo +noConPatternInfo = ConPatternInfo Nothing Nothing + -- | Extract pattern variables in left-to-right order. -- A 'DotP' is also treated as variable (see docu for 'Clause'). patternVars :: Arg Pattern -> [Arg (Either PatVarName Term)] @@ -370,7 +521,7 @@ properlyMatching VarP{} = False properlyMatching DotP{} = False properlyMatching LitP{} = True -properlyMatching (ConP _ mt ps) = isNothing mt || -- not a record cons +properlyMatching (ConP _ ci ps) = isNothing (conPRecord ci) || -- not a record cons List.any (properlyMatching . namedArg) ps -- or one of subpatterns is a proper m properlyMatching ProjP{} = True @@ -380,30 +531,56 @@ -- | Substitutions. -infixr 4 :# data Substitution - = IdS -- Γ ⊢ IdS : Γ + = IdS + -- ^ Identity substitution. + -- @Γ ⊢ IdS : Γ@ - | EmptyS -- Γ ⊢ EmptyS : () + | EmptyS + -- ^ Empty substitution, lifts from the empty context. + -- Apply this to closed terms you want to use in a non-empty context. + -- @Γ ⊢ EmptyS : ()@ - -- Γ ⊢ ρ : Δ - | Wk !Int Substitution -- ------------------- - -- Γ, Ψ ⊢ Wk |Ψ| ρ : Δ + | Term :# Substitution + -- ^ Substitution extension, ``cons''. + -- @ + -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ + -- ---------------------- + -- Γ ⊢ u :# ρ : Δ, A + -- @ - -- Γ ⊢ u : Aρ Γ ⊢ ρ : Δ - | Term :# Substitution -- --------------------- - -- Γ ⊢ u :# ρ : Δ, A + | Strengthen Empty Substitution + -- ^ Strengthening substitution. First argument is @__IMPOSSIBLE__@. + -- Apply this to a term which does not contain variable 0 + -- to lower all de Bruijn indices by one. + -- @ + -- Γ ⊢ ρ : Δ + -- --------------------------- + -- Γ ⊢ Strengthen ρ : Δ, A + -- @ - -- First argument is __IMPOSSIBLE__ -- Γ ⊢ ρ : Δ - | Strengthen Empty Substitution -- --------------------------- - -- Γ ⊢ Strengthen ρ : Δ, A + | Wk !Int Substitution + -- ^ Weakning substitution, lifts to an extended context. + -- @ + -- Γ ⊢ ρ : Δ + -- ------------------- + -- Γ, Ψ ⊢ Wk |Ψ| ρ : Δ + -- @ - -- Γ ⊢ ρ : Δ - | Lift !Int Substitution -- ------------------------- - -- Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ + + | Lift !Int Substitution + -- ^ Lifting substitution. Use this to go under a binder. + -- @Lift 1 ρ == var 0 :# Wk 1 ρ@. + -- @ + -- Γ ⊢ ρ : Δ + -- ------------------------- + -- Γ, Ψρ ⊢ Lift |Ψ| ρ : Δ, Ψ + -- @ deriving (Show) +infixr 4 :# + --------------------------------------------------------------------------- -- * Absurd Lambda --------------------------------------------------------------------------- @@ -518,12 +695,13 @@ sort s = El (sSuc s) $ Sort s varSort :: Int -> Sort -varSort n = Type $ Max [Plus 0 $ NeutralLevel $ Var n []] +varSort n = Type $ Max [Plus 0 $ NeutralLevel mempty $ Var n []] -- | Get the next higher sort. sSuc :: Sort -> Sort sSuc Prop = mkType 1 sSuc Inf = Inf +sSuc SizeUniv = SizeUniv sSuc (DLub a b) = DLub (sSuc a) (fmap sSuc b) sSuc (Type l) = Type $ levelSuc l @@ -542,6 +720,7 @@ , "Location of the error: " ++ file ++ ":" ++ show line ] +-- | Constructing a singleton telescope. class SgTel a where sgTel :: a -> Telescope @@ -564,17 +743,13 @@ blockingMeta :: Blocked t -> Maybe MetaId blockingMeta (Blocked m _) = Just m -blockingMeta (NotBlocked _) = Nothing +blockingMeta NotBlocked{} = Nothing blocked :: MetaId -> a -> Blocked a blocked x = Blocked x notBlocked :: a -> Blocked a -notBlocked = NotBlocked - -ignoreBlocking :: Blocked a -> a -ignoreBlocking (Blocked _ x) = x -ignoreBlocking (NotBlocked x) = x +notBlocked = NotBlocked ReallyNotBlocked --------------------------------------------------------------------------- -- * Simple operations on terms and types. @@ -610,6 +785,12 @@ instance Suggest (Abs a) (Abs b) where suggest b1 b2 = suggest (absName b1) (absName b2) +instance Suggest String (Abs b) where + suggest x b = suggest x (absName b) + +instance Suggest Name (Abs b) where + suggest n b = suggest (nameToArgName n) (absName b) + --------------------------------------------------------------------------- -- * Eliminations. --------------------------------------------------------------------------- @@ -703,6 +884,30 @@ -} --------------------------------------------------------------------------- +-- * Null instances. +--------------------------------------------------------------------------- + +instance Null (Tele a) where + empty = EmptyTel + 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 + empty = Clause empty empty empty empty empty empty + null (Clause r tel perm pats body t) + = null tel + && null pats + && null body + + +--------------------------------------------------------------------------- -- * Show instances. --------------------------------------------------------------------------- @@ -712,49 +917,21 @@ showsPrec p (NoAbs x a) = showParen (p > 0) $ showString "NoAbs " . shows x . showString " " . showsPrec 10 a +-- | Show non-record version of this newtype. instance Show MetaId where - show (MetaId n) = "_" ++ show n + showsPrec p (MetaId n) = showParen (p > 0) $ + showString "MetaId " . shows n -instance Show t => Show (Blocked t) where - showsPrec p (Blocked m x) = showParen (p > 0) $ - showString "Blocked " . shows m . showString " " . showsPrec 10 x - showsPrec p (NotBlocked x) = showsPrec p x +-- instance Show t => Show (Blocked t) where +-- showsPrec p (Blocked m x) = showParen (p > 0) $ +-- showString "Blocked " . shows m . showString " " . showsPrec 10 x +-- showsPrec p (NotBlocked x) = showsPrec p x --------------------------------------------------------------------------- --- * Sized instances. +-- * Sized instances and TermSize. --------------------------------------------------------------------------- -instance Sized Term where - size v = case v of - Var _ vs -> 1 + Prelude.sum (map size vs) - Def _ vs -> 1 + Prelude.sum (map size vs) - Con _ vs -> 1 + Prelude.sum (map size vs) - MetaV _ vs -> 1 + Prelude.sum (map size vs) - Level l -> size l - Lam _ f -> 1 + size f - Lit _ -> 1 - Pi a b -> 1 + size a + size b - Sort s -> 1 - DontCare mv -> size mv - Shared p -> size (derefPtr p) - ExtLam{} -> __IMPOSSIBLE__ - -instance Sized Type where - size = size . unEl - -instance Sized Level where - size (Max as) = 1 + Prelude.sum (map size as) - -instance Sized PlusLevel where - size (ClosedLevel _) = 1 - size (Plus _ a) = size a - -instance Sized LevelAtom where - size (MetaLevel _ vs) = 1 + Prelude.sum (map size vs) - size (BlockedLevel _ v) = size v - size (NeutralLevel v) = size v - size (UnreducedLevel v) = size v - +-- | The size of a telescope is its length (as a list). instance Sized (Tele a) where size EmptyTel = 0 size (ExtendTel _ tel) = 1 + size tel @@ -762,10 +939,69 @@ instance Sized a => Sized (Abs a) where size = size . unAbs -instance Sized a => Sized (Elim' a) where - size (Apply v) = size v - size Proj{} = 1 +-- | The size of a term is roughly the number of nodes in its +-- syntax tree. This number need not be precise for logical +-- correctness of Agda, it is only used for reporting +-- (and maybe decisions regarding performance). +-- +-- Not counting towards the term size are: +-- +-- * sort and color annotations, +-- * projections. +-- +class TermSize a where + termSize :: a -> Int + termSize = getSum . tsize + tsize :: a -> Sum Int + +instance (Foldable t, TermSize a) => TermSize (t a) where + tsize = foldMap tsize + +instance TermSize Term where + tsize v = case v of + Var _ vs -> 1 + tsize vs + Def _ vs -> 1 + tsize vs + Con _ vs -> 1 + tsize vs + MetaV _ vs -> 1 + tsize vs + Level l -> tsize l + Lam _ f -> 1 + tsize f + Lit _ -> 1 + Pi a b -> 1 + tsize a + tsize b + Sort s -> tsize s + DontCare mv -> tsize mv + Shared p -> tsize (derefPtr p) + ExtLam{} -> __IMPOSSIBLE__ + +instance TermSize Sort where + tsize s = case s of + Type l -> 1 + tsize l + Prop -> 1 + Inf -> 1 + SizeUniv -> 1 + DLub s s' -> 1 + tsize s + tsize s' + +instance TermSize Level where + tsize (Max as) = 1 + tsize as + +instance TermSize PlusLevel where + tsize (ClosedLevel _) = 1 + tsize (Plus _ a) = tsize a + +instance TermSize LevelAtom where + tsize (MetaLevel _ vs) = 1 + tsize vs + tsize (BlockedLevel _ v) = tsize v + tsize (NeutralLevel _ v) = tsize v + tsize (UnreducedLevel v) = tsize v + +instance TermSize Substitution where + tsize IdS = 1 + tsize EmptyS = 1 + tsize (Wk _ rho) = 1 + tsize rho + tsize (t :# rho) = 1 + tsize t + tsize rho + tsize (Strengthen _ rho) = 1 + tsize rho + tsize (Lift _ rho) = 1 + tsize rho + --------------------------------------------------------------------------- -- * KillRange instances. --------------------------------------------------------------------------- @@ -798,7 +1034,7 @@ instance KillRange LevelAtom where killRange (MetaLevel n as) = killRange1 (MetaLevel n) as killRange (BlockedLevel m v) = killRange1 (BlockedLevel m) v - killRange (NeutralLevel v) = killRange1 NeutralLevel v + killRange (NeutralLevel r v) = killRange1 (NeutralLevel r) v killRange (UnreducedLevel v) = killRange1 UnreducedLevel v instance KillRange Type where @@ -808,9 +1044,21 @@ killRange s = case s of Prop -> Prop Inf -> Inf + SizeUniv -> SizeUniv Type a -> killRange1 Type a DLub s1 s2 -> killRange2 DLub s1 s2 +instance KillRange Substitution where + killRange IdS = IdS + killRange EmptyS = EmptyS + killRange (Wk n rho) = killRange1 (Wk n) rho + killRange (t :# rho) = killRange2 (:#) t rho + killRange (Strengthen err rho) = killRange1 (Strengthen err) rho + killRange (Lift n rho) = killRange1 (Lift n) rho + +instance KillRange ConPatternInfo where + killRange (ConPatternInfo mr mt) = killRange1 (ConPatternInfo mr) mt + instance KillRange Pattern where killRange p = case p of @@ -857,9 +1105,20 @@ -- * Simple pretty printing ----------------------------------------------------------------------------- -showTerm :: Term -> String -showTerm = show . pretty +instance Pretty MetaId where + pretty (MetaId n) = text $ "_" ++ show n +instance Pretty Substitution where + prettyPrec p rho = brackets $ pr rho + where + pr 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 + instance Pretty Term where prettyPrec p v = case ignoreSharing v of @@ -879,7 +1138,7 @@ , nest 2 $ pretty (unAbs b) ] Sort s -> pretty s Level l -> pretty l - MetaV x els -> text (show x) `pApp` els + MetaV x els -> pretty x `pApp` els DontCare v -> pretty v Shared{} -> __IMPOSSIBLE__ ExtLam{} -> __IMPOSSIBLE__ @@ -914,7 +1173,7 @@ case a of MetaLevel x els -> prettyPrec p (MetaV x els) BlockedLevel _ v -> prettyPrec p v - NeutralLevel v -> prettyPrec p v + NeutralLevel _ v -> prettyPrec p v UnreducedLevel v -> prettyPrec p v instance Pretty Sort where @@ -925,6 +1184,7 @@ Type l -> mparens (p > 9) $ text "Set" <+> prettyPrec 10 l Prop -> text "Prop" Inf -> text "Setω" + SizeUniv -> text "SizeUniv" DLub s b -> mparens (p > 9) $ text "dlub" <+> prettyPrec 10 s <+> parens (sep [ text ("λ " ++ show (absName b) ++ " ->") diff --git a/src/full/Agda/Syntax/Internal/Defs.hs b/src/full/Agda/Syntax/Internal/Defs.hs --- a/src/full/Agda/Syntax/Internal/Defs.hs +++ b/src/full/Agda/Syntax/Internal/Defs.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} -- | Extract used definitions from terms. module Agda.Syntax.Internal.Defs where @@ -82,6 +81,7 @@ Type l -> getDefs l Prop -> return () Inf -> return () + SizeUniv -> return () DLub s s' -> getDefs s >> getDefs s' instance GetDefs Level where @@ -95,7 +95,7 @@ getDefs a = case a of MetaLevel x vs -> getDefs x >> getDefs vs BlockedLevel _ v -> getDefs v - NeutralLevel v -> getDefs v + NeutralLevel _ v -> getDefs v UnreducedLevel v -> getDefs v -- collection instances diff --git a/src/full/Agda/Syntax/Internal/Generic.hs b/src/full/Agda/Syntax/Internal/Generic.hs --- a/src/full/Agda/Syntax/Internal/Generic.hs +++ b/src/full/Agda/Syntax/Internal/Generic.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} module Agda.Syntax.Internal.Generic where @@ -160,17 +159,17 @@ instance TermLike LevelAtom where traverseTerm f l = case l of MetaLevel m vs -> MetaLevel m $ traverseTerm f vs - NeutralLevel v -> NeutralLevel $ traverseTerm f v + NeutralLevel r v -> NeutralLevel r $ traverseTerm f v BlockedLevel m v -> BlockedLevel m $ traverseTerm f v UnreducedLevel v -> UnreducedLevel $ traverseTerm f v traverseTermM f l = case l of MetaLevel m vs -> MetaLevel m <$> traverseTermM f vs - NeutralLevel v -> NeutralLevel <$> traverseTermM f v + NeutralLevel r v -> NeutralLevel r <$> traverseTermM f v BlockedLevel m v -> BlockedLevel m <$> traverseTermM f v UnreducedLevel v -> UnreducedLevel <$> traverseTermM f v foldTerm f l = case l of MetaLevel m vs -> foldTerm f vs - NeutralLevel v -> foldTerm f v + NeutralLevel _ v -> foldTerm f v BlockedLevel _ v -> foldTerm f v UnreducedLevel v -> foldTerm f v diff --git a/src/full/Agda/Syntax/Internal/Pattern.hs b/src/full/Agda/Syntax/Internal/Pattern.hs --- a/src/full/Agda/Syntax/Internal/Pattern.hs +++ b/src/full/Agda/Syntax/Internal/Pattern.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -- because of func. deps. +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} -- because of func. deps. +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + module Agda.Syntax.Internal.Pattern where import Control.Applicative @@ -49,7 +51,12 @@ funArity :: a -> Int -- | Get the number of initial 'Apply' patterns. + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} IsProjP p => FunArity [p] where +#else instance IsProjP p => FunArity [p] where +#endif funArity = length . takeWhile (isNothing . isProjP) -- | Get the number of initial 'Apply' patterns in a clause. @@ -57,7 +64,11 @@ funArity = funArity . clausePats -- | Get the number of common initial 'Apply' patterns in a list of clauses. +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} FunArity [Clause] where +#else instance FunArity [Clause] where +#endif funArity [] = 0 funArity cls = minimum $ map funArity cls @@ -90,7 +101,8 @@ where next = do (x:xs) <- get; put xs; return x -- | Augment pattern variables with their de Bruijn index. -{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [(NamedArg (Pattern' (Int, x)))] #-} +{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg (Pattern' x)] -> [NamedArg (Pattern' (Int, x))] #-} +{-# SPECIALIZE numberPatVars :: Permutation -> [NamedArg Pattern] -> [NamedArg DeBruijnPattern] #-} numberPatVars :: LabelPatVars a b Int => Permutation -> a -> b numberPatVars perm ps = evalState (labelPatVars ps) $ permute (invertP __IMPOSSIBLE__ perm) $ downFrom $ size perm diff --git a/src/full/Agda/Syntax/Notation.hs b/src/full/Agda/Syntax/Notation.hs --- a/src/full/Agda/Syntax/Notation.hs +++ b/src/full/Agda/Syntax/Notation.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + ScopedTypeVariables #-} {-| As a concrete name, a notation is a non-empty list of alternating 'IdPart's and holes. In contrast to concrete names, holes can be binders. @@ -23,6 +24,7 @@ import Data.Typeable (Typeable) import Agda.Syntax.Common +import Agda.Syntax.Position import Agda.Utils.Except ( MonadError(throwError) ) import Agda.Utils.List @@ -54,8 +56,14 @@ | NormalHole (NamedArg () Int) -- ^ Argument is where the expression should go. | IdPart RawName - deriving (Typeable, Show, Eq) + deriving (Typeable, Show, Eq, Ord) +instance KillRange GenPart where + killRange p = case p of + IdPart x -> IdPart x + BindHole i -> BindHole i + NormalHole x -> NormalHole $ killRange x + -- | Get a flat list of identifier parts of a notation. stringParts :: Notation -> [RawName] stringParts gs = [ x | IdPart x <- gs ] @@ -83,7 +91,7 @@ | PostfixNotation -- ^ Ex: @bla_blub_@. | NonfixNotation -- ^ Ex: @bla_blub@. | NoNotation - deriving (Eq) + deriving (Eq, Show) -- | Classify a notation by presence of leading and/or trailing hole. notationKind :: Notation -> NotationKind diff --git a/src/full/Agda/Syntax/Parser/LookAhead.hs b/src/full/Agda/Syntax/Parser/LookAhead.hs --- a/src/full/Agda/Syntax/Parser/LookAhead.hs +++ b/src/full/Agda/Syntax/Parser/LookAhead.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} {-| When lexing by hands (for instance string literals) we need to do some looking ahead. The 'LookAhead' monad keeps track of the position we are diff --git a/src/full/Agda/Syntax/Parser/Monad.hs b/src/full/Agda/Syntax/Parser/Monad.hs --- a/src/full/Agda/Syntax/Parser/Monad.hs +++ b/src/full/Agda/Syntax/Parser/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} module Agda.Syntax.Parser.Monad @@ -32,7 +32,7 @@ import Control.Exception import Data.Int -import Data.Typeable +import Data.Typeable ( Typeable ) import Control.Monad.State import Control.Applicative @@ -44,6 +44,8 @@ import Agda.Utils.FileName import qualified Agda.Utils.IO.UTF8 as UTF8 +import Agda.Utils.Pretty + {-------------------------------------------------------------------------- The parse monad --------------------------------------------------------------------------} @@ -90,12 +92,11 @@ -- | What you get if parsing fails. data ParseError = ParseError - { errPos :: Position -- ^ where the error occured - , errInput :: String -- ^ the remaining input - , errPrevToken :: String -- ^ the previous token - , errMsg :: String -- ^ hopefully an explanation - -- of what happened - } + { errPos :: Position -- ^ where the error occured + , errInput :: String -- ^ the remaining input + , errPrevToken :: String -- ^ the previous token + , errMsg :: String -- ^ hopefully an explanation of what happened + } deriving (Typeable) instance Exception ParseError @@ -109,55 +110,49 @@ --------------------------------------------------------------------------} instance Monad Parser where - return x = P $ \s -> ParseOk s x - P m >>= f = P $ \s -> case m s of - ParseFailed e -> ParseFailed e - ParseOk s' x -> unP (f x) s' - fail msg = P $ \s -> ParseFailed $ - ParseError { errPos = parseLastPos s - , errInput = parseInp s - , errPrevToken = parsePrevToken s - , errMsg = msg - } + return x = P $ \s -> ParseOk s x + P m >>= f = P $ \s -> case m s of + ParseFailed e -> ParseFailed e + ParseOk s' x -> unP (f x) s' + + fail msg = P $ \s -> ParseFailed $ + ParseError { errPos = parseLastPos s + , errInput = parseInp s + , errPrevToken = parsePrevToken s + , errMsg = msg + } + instance Functor Parser where - fmap = liftM + fmap = liftM instance Applicative Parser where - pure = return - (<*>) = ap + pure = return + (<*>) = ap instance MonadError ParseError Parser where - throwError e = P $ \_ -> ParseFailed e - P m `catchError` h = P $ \s -> case m s of - ParseFailed err -> unP (h err) s - m' -> m' + throwError e = P $ \_ -> ParseFailed e + P m `catchError` h = P $ \s -> case m s of + ParseFailed err -> unP (h err) s + m' -> m' + instance MonadState ParseState Parser where - get = P $ \s -> ParseOk s s - put s = P $ \_ -> ParseOk s () + get = P $ \s -> ParseOk s s + put s = P $ \_ -> ParseOk s () instance Show ParseError where - show err = - unlines - [ pos ++ ": " ++ errMsg err - --, replicate (length pos + 2) ' ' ++ "on '" ++ errPrevToken err ++ "'" - , errPrevToken err ++ "\n" ++ take 30 (errInput err) ++ "..." - ] - where - pos = show (errPos err) + show = prettyShow --- showInp "" = "at end of file" --- showInp t = "on input " ++ elide 5 t --- --- elide 3 s --- | length (take 4 s) < 4 = s --- | otherwise = "..." --- elide n (c:s) = c : elide (n - 1) s --- elide _ "" = "" +instance Pretty ParseError where + pretty err = vcat + [ pretty (errPos err) <> colon <+> text (errMsg err) + , text $ errPrevToken err ++ "" + , text $ take 30 (errInput err) ++ "..." + ] instance HasRange ParseError where - getRange err = posToRange (errPos err) (errPos err) + getRange err = posToRange (errPos err) (errPos err) {-------------------------------------------------------------------------- Running the parser diff --git a/src/full/Agda/Syntax/Parser/Parser.y b/src/full/Agda/Syntax/Parser/Parser.y --- a/src/full/Agda/Syntax/Parser/Parser.y +++ b/src/full/Agda/Syntax/Parser/Parser.y @@ -1,4 +1,6 @@ { +{-# LANGUAGE TupleSections #-} + {-| The parser is generated by Happy (). - - Ideally, ranges should be as precise as possible, to get messages that @@ -43,6 +45,7 @@ import Agda.Utils.List (spanJust) import Agda.Utils.Monad import Agda.Utils.QuickCheck +import Agda.Utils.Singleton import Agda.Utils.TestHelpers import Agda.Utils.Tuple @@ -456,33 +459,56 @@ Left ns -> ns Right _ -> fail $ "expected sequence of bound identifiers, not absurd pattern" } -{- - let getName (Ident (QName x)) = Just x + +CommaBIdAndAbsurds :: { Either [Name] [Expr] } +CommaBIdAndAbsurds : Application {% + let getName :: Expr -> Maybe Name + getName (Ident (QName x)) = Just x getName (Underscore r _) = Just (Name r [Hole]) getName _ = Nothing + + isAbsurd :: Expr -> Bool + isAbsurd (Absurd _) = True + isAbsurd (HiddenArg _ (Named _ e)) = isAbsurd e + isAbsurd (InstanceArg _ (Named _ e)) = isAbsurd e + isAbsurd (Paren _ expr) = isAbsurd expr + isAbsurd (RawApp _ exprs) = any isAbsurd exprs + isAbsurd _ = False in - case partition isJust $ map getName $1 of - (good, []) -> return $ map fromJust good - _ -> fail $ "expected sequence of bound identifiers" --} + if any isAbsurd $1 then return $ Right $1 else + case mapM getName $1 of + Just good -> return $ Left good + Nothing -> fail $ "expected sequence of bound identifiers" + } -CommaBIdAndAbsurds :: { Either [Name] [Expr] } -CommaBIdAndAbsurds : Application {% - let getName (Ident (QName x)) = Just x +-- Parse a sequence of identifiers, including hiding info. +-- Does not include instance arguments. +-- E.g. x {y z} _ {v} +-- To be used in typed bindings, like (x {y z} _ {v} : Nat). +BIdsWithHiding :: { [WithHiding Name] } +BIdsWithHiding : Application {% + let -- interpret an expression as name + getName :: Expr -> Maybe Name + getName (Ident (QName x)) = Just x getName (Underscore r _) = Just (Name r [Hole]) getName _ = Nothing - containsAbsurd (Absurd _) = True - containsAbsurd (HiddenArg _ (Named _ e)) = containsAbsurd e - containsAbsurd (InstanceArg _ (Named _ e)) = containsAbsurd e - containsAbsurd (Paren _ expr) = containsAbsurd expr - containsAbsurd (RawApp _ exprs) = any containsAbsurd exprs - containsAbsurd _ = False + getNames :: Expr -> Maybe [Name] + getNames (RawApp _ es) = mapM getName es + getNames e = singleton `fmap` getName e + + -- interpret an expression as name or list of hidden names + getName1 :: Expr -> Maybe [WithHiding Name] + getName1 (Ident (QName x)) = Just [WithHiding NotHidden x] + getName1 (Underscore r _) = Just [WithHiding NotHidden $ Name r [Hole]] + getName1 (HiddenArg _ (Named Nothing e)) + = map (WithHiding Hidden) `fmap` getNames e + getName1 _ = Nothing + in - if isJust $ find containsAbsurd $1 then return $ Right $1 else - case partition isJust $ map getName $1 of - (good, []) -> return $ Left $ map fromJust good - _ -> fail $ "expected sequence of bound identifiers" + case mapM getName1 $1 of + Just good -> return $ concat good + Nothing -> fail $ "expected sequence of possibly hidden bound identifiers" } @@ -646,32 +672,41 @@ -- Andreas, 2011-04-27: or ..(x1 .. xn : A) or ..{y1 .. ym : B} TypedBindings :: { TypedBindings } TypedBindings - : '.' '(' TBind ')' { TypedBindings (getRange ($2,$3,$4)) - (setRelevance Irrelevant $ defaultColoredArg $3) } - | '.' '{' TBind '}' { TypedBindings (getRange ($2,$3,$4)) - (hide $ setRelevance Irrelevant $ defaultColoredArg $3) } - | '.' '{{' TBind DoubleCloseBrace { TypedBindings (getRange ($2,$3,$4)) - (makeInstance $ setRelevance Irrelevant $ defaultColoredArg $3) } - | '..' '(' TBind ')' { TypedBindings (getRange ($2,$3,$4)) - (setRelevance NonStrict $ defaultColoredArg $3) } - | '..' '{' TBind '}' { TypedBindings (getRange ($2,$3,$4)) - (hide $ setRelevance NonStrict $ defaultColoredArg $3) } - | '..' '{{' TBind DoubleCloseBrace { TypedBindings (getRange ($2,$3,$4)) - (makeInstance $ setRelevance NonStrict $ defaultColoredArg $3) } - | '(' TBind ')' { TypedBindings (getRange ($1,$2,$3)) - (defaultColoredArg $2) } - | '{{' TBind DoubleCloseBrace { TypedBindings (getRange ($1,$2,$3)) - (makeInstance $ defaultColoredArg $2) } - | '{' TBind '}' { TypedBindings (getRange ($1,$2,$3)) - (hide $ defaultColoredArg $2) } + : '.' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $ + setRelevance Irrelevant $3 } + | '.' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $ + setHiding Hidden $ + setRelevance Irrelevant $3 } + | '.' '{{' TBind DoubleCloseBrace + { setRange (getRange ($2,$3,$4)) $ + setHiding Instance $ + setRelevance Irrelevant $3 } + | '..' '(' TBindWithHiding ')' { setRange (getRange ($2,$3,$4)) $ + setRelevance NonStrict $3 } + | '..' '{' TBind '}' { setRange (getRange ($2,$3,$4)) $ + setHiding Hidden $ + setRelevance NonStrict $3 } + | '..' '{{' TBind DoubleCloseBrace + { setRange (getRange ($2,$3,$4)) $ + setHiding Instance $ + setRelevance NonStrict $3 } + | '(' TBindWithHiding ')' { setRange (getRange ($1,$2,$3)) $2 } + | '{{' TBind DoubleCloseBrace + { setRange (getRange ($1,$2,$3)) $ + setHiding Instance $2 } + | '{' TBind '}' { setRange (getRange ($1,$2,$3)) $ + setHiding Hidden $2 } | '(' Open ')' { tLet (getRange ($1,$3)) $2 } | '(' 'let' Declarations ')' { tLet (getRange ($1,$4)) $3 } -- x1 .. xn : A -- x1 .. xn :{i1 i2 ..} A -TBind :: { ( [Color], TypedBinding ) } -TBind : CommaBIds ':' Expr { ( [], TBind (getRange ($1,$2,$3)) (map mkBoundName_ $1) $3 ) } +TBind :: { TypedBindings } +TBind : CommaBIds ':' Expr { + let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings + in TypedBindings r $ defaultArg $ TBind r (map (pure . mkBoundName_) $1) $3 + } -- | Colors are not yet allowed in the syntax. -- | CommaBIds ':{' Colors '}' Expr { ( $3, TBind (getRange ($1,$2,$3,$4,$5)) (map mkBoundName_ $1) $5 ) } {- @@ -679,6 +714,14 @@ Colors : QId Colors { Ident $1 : $2 } | QId { [Ident $1] } -} + +-- x {y z} _ {v} : A +TBindWithHiding :: { TypedBindings } +TBindWithHiding : BIdsWithHiding ':' Expr { + let r = getRange ($1,$2,$3) -- the range is approximate only for TypedBindings + in TypedBindings r $ defaultArg $ TBind r (map (fmap mkBoundName_) $1) $3 + } + -- A non-empty sequence of lambda bindings. LamBindings :: { [LamBinding] } LamBindings @@ -696,7 +739,7 @@ Left lb -> case reverse lb of Right _ : _ -> parseError "Missing body for lambda" Left h : _ -> return $ Left ([ b | Right b <- init lb], h) - _ -> parsePanic "Empty LamBindsAbsurd" + _ -> parseError "Unsupported variant of lambda" Right es -> return $ Right es } @@ -814,13 +857,6 @@ Modules and imports --------------------------------------------------------------------------} --- You can rename imports --- ImportImportDirective :: { (Maybe AsName, ImportDirective) } --- ImportImportDirective --- : ImportDirective { (Nothing, $1) } --- | id Id ImportDirective {% isName "as" $1 >> --- return (Just (AsName $2 (getRange (fst $1))), $3) } - -- Import directives ImportDirective :: { ImportDirective } ImportDirective : ImportDirectives {% mergeImportDirectives $1 } @@ -841,7 +877,6 @@ -- using can have an empty list | 'hiding' '(' CommaImportNames ')' { (Hiding $3 , getRange ($1,$2,$3,$4)) } -- if you want to hide nothing that's fine, isn't it? --- | 'hiding' '(' CommaImportNames1 ')' { (Hiding $3 , getRange ($1,$2,$3,$4)) } RenamingDir :: { ([Renaming] , Range) } RenamingDir @@ -956,13 +991,13 @@ -- Type signatures of the form "n1 n2 n3 ... : Type", with at least -- one bound name. TypeSigs :: { [Declaration] } -TypeSigs : SpaceIds ':' Expr { map (flip (TypeSig defaultArgInfo) $3) $1 } +TypeSigs : SpaceIds ':' Expr { map (\ x -> TypeSig defaultArgInfo x $3) $1 } -- A variant of TypeSigs where any sub-sequence of names can be marked -- as hidden or irrelevant using braces and dots: -- {n1 .n2} n3 .n4 {n5} .{n6 n7} ... : Type. ArgTypeSigs :: { [Arg Declaration] } -ArgTypeSigs : ArgIds ':' Expr { map (fmap (flip (TypeSig defaultArgInfo) $3)) $1 } +ArgTypeSigs : ArgIds ':' Expr { map (fmap (\ x -> TypeSig defaultArgInfo x $3)) $1 } -- Function declarations. The left hand side is parsed as an expression to allow -- declarations like 'x::xs ++ ys = e', when '::' has higher precedence than '++'. @@ -1017,9 +1052,9 @@ -- Fixity declarations. Infix :: { Declaration } -Infix : 'infix' Int SpaceBIds { Infix (NonAssoc (getRange ($1,$3)) $2) $3 } - | 'infixl' Int SpaceBIds { Infix (LeftAssoc (getRange ($1,$3)) $2) $3 } - | 'infixr' Int SpaceBIds { Infix (RightAssoc (getRange ($1,$3)) $2) $3 } +Infix : 'infix' Int SpaceBIds { Infix (Fixity (getRange ($1,$3)) $2 NonAssoc) $3 } + | 'infixl' Int SpaceBIds { Infix (Fixity (getRange ($1,$3)) $2 LeftAssoc) $3 } + | 'infixr' Int SpaceBIds { Infix (Fixity (getRange ($1,$3)) $2 RightAssoc) $3 } -- Field declarations. Fields :: { [Declaration] } @@ -1256,6 +1291,7 @@ BuiltinPragma : '{-#' 'BUILTIN' string PragmaQName '#-}' { BuiltinPragma (getRange ($1,$2,fst $3,$4,$5)) (snd $3) (Ident $4) } + -- Extra rule to accept keword REWRITE also as built-in: | '{-#' 'BUILTIN' 'REWRITE' PragmaQName '#-}' { BuiltinPragma (getRange ($1,$2,$3,$4,$5)) "REWRITE" (Ident $4) } @@ -1507,7 +1543,7 @@ -- | Converts lambda bindings to typed bindings. addType :: LamBinding -> TypedBindings addType (DomainFull b) = b -addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [x] $ Underscore r Nothing +addType (DomainFree info x) = TypedBindings r $ Common.Arg info $ TBind r [pure x] $ Underscore r Nothing where r = getRange x mergeImportDirectives :: [ImportDirective] -> Parser ImportDirective diff --git a/src/full/Agda/Syntax/Position.hs b/src/full/Agda/Syntax/Position.hs --- a/src/full/Agda/Syntax/Position.hs +++ b/src/full/Agda/Syntax/Position.hs @@ -1,19 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoMonomorphismRestriction #-} - -#if __GLASGOW_HASKELL__ <= 700 -{-# LANGUAGE OverlappingInstances #-} -#endif - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + DeriveFoldable, + DeriveFunctor, + DeriveTraversable, + FlexibleInstances, + GeneralizedNewtypeDeriving, + NoMonomorphismRestriction, + ScopedTypeVariables, + TemplateHaskell #-} {-| Position information for syntax. Crucial for giving good error messages. -} @@ -47,6 +42,7 @@ , rangeToInterval , continuous , continuousPerLine + , PrintRange(..) , HasRange(..) , SetRange(..) , KillRange(..) @@ -66,13 +62,15 @@ import Prelude hiding (null) -import Control.Applicative +import Control.Applicative hiding (empty) import Control.Monad import Data.Foldable (Foldable) import Data.Function import Data.Int import Data.List hiding (null) +import Data.Map (Map) +import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Traversable (Traversable) @@ -83,7 +81,7 @@ import Agda.Utils.FileName hiding (tests) import Agda.Utils.Maybe import Agda.Utils.Null -import Agda.Utils.Pretty ( (<>), Pretty(pretty) ) +import Agda.Utils.Pretty import Agda.Utils.TestHelpers import Agda.Utils.QuickCheck @@ -171,6 +169,10 @@ if null is then r else let i = last is in Range [ i { iStart = iEnd i } ] +-- | Wrapper to indicate that range should be printed. +newtype PrintRange a = PrintRange a + deriving (Eq, Ord, HasRange, SetRange, KillRange) + -- | Things that have a range are instances of this class. class HasRange t where getRange :: t -> Range @@ -215,6 +217,9 @@ instance SetRange Range where setRange = const +instance SetRange a => SetRange [a] where + setRange r = fmap $ setRange r + -- | Killing the range of an object sets all range information to 'noRange'. class KillRange a where killRange :: KillRangeT a @@ -356,9 +361,30 @@ instance KillRange Int where killRange = id +instance KillRange Integer where + killRange = id + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} KillRange a => KillRange [a] where +#else instance KillRange a => KillRange [a] where +#endif killRange = map killRange +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} KillRange a => KillRange (Map k a) where +#else +instance KillRange a => KillRange (Map k a) where +#endif + killRange = fmap killRange + +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} (Ord a, KillRange a) => KillRange (Set a) where +#else +instance (Ord a, KillRange a) => KillRange (Set a) where +#endif + killRange = Set.map killRange + instance (KillRange a, KillRange b) => KillRange (a, b) where killRange (x, y) = (killRange x, killRange y) @@ -366,6 +392,10 @@ KillRange (a, b, c) where killRange (x, y, z) = killRange3 (,,) x y z +instance (KillRange a, KillRange b, KillRange c, KillRange d) => + KillRange (a, b, c, d) where + killRange (x, y, z, u) = killRange4 (,,,) x y z u + instance KillRange a => KillRange (Maybe a) where killRange = fmap killRange @@ -379,28 +409,35 @@ -- TODO: 'Show' should output Haskell-parseable representations. -- The following instances are deprecated, and Pretty should be used --- instead. Later, simply derive Show for these types: +-- instead. Later, simply derive Show for these types. +-- ASR (02 December 2014). This instance is not used anymore (module +-- the test suite) when reporting errors. See Issue 1293. instance Show a => Show (Position' (Maybe a)) where - show (Pn Nothing _ l c) = show l ++ "," ++ show c - show (Pn (Just f) _ l c) = show f ++ ":" ++ show l ++ "," ++ show c + show (Pn Nothing _ l c) = show l ++ "," ++ show c + show (Pn (Just f) _ l c) = show f ++ ":" ++ show l ++ "," ++ show c instance Show a => Show (Interval' (Maybe a)) where - show (Interval s e) = file ++ start ++ "-" ++ end - where - f = srcFile s - sl = posLine s - el = posLine e - sc = posCol s - ec = posCol e - file = case f of - Nothing -> "" - Just f -> show f ++ ":" - start = show sl ++ "," ++ show sc - end - | sl == el = show ec - | otherwise = show el ++ "," ++ show ec + show (Interval s e) = file ++ start ++ "-" ++ end + where + f = srcFile s + sl = posLine s + el = posLine e + sc = posCol s + ec = posCol e + file :: String + file = case f of + Nothing -> "" + Just f -> show f ++ ":" + + start :: String + start = show sl ++ "," ++ show sc + + end :: String + end | sl == el = show ec + | otherwise = show el ++ "," ++ show ec + instance Show a => Show (Range' (Maybe a)) where show r = case rangeToInterval r of Nothing -> "" @@ -411,9 +448,38 @@ ------------------------------------------------------------------------ instance Pretty a => Pretty (Position' (Maybe a)) where - pretty (Pn Nothing _ l c) = pretty l <> pretty "," <> pretty c - pretty (Pn (Just f) _ l c) = - pretty f <> pretty ":" <> pretty l <> pretty "," <> pretty c + pretty (Pn Nothing _ l c) = pretty l <> pretty "," <> pretty c + pretty (Pn (Just f) _ l c) = + pretty f <> pretty ":" <> pretty l <> pretty "," <> pretty c + +instance Pretty a => Pretty (Interval' (Maybe a)) where + pretty (Interval s e) = file <> start <> pretty "-" <> end + where + f = srcFile s + sl = posLine s + el = posLine e + sc = posCol s + ec = posCol e + + file :: Doc + file = case f of + Nothing -> empty + Just f -> pretty f <> colon + + start :: Doc + start = pretty sl <> comma <> pretty sc + + end :: Doc + | sl == el = pretty ec + | otherwise = pretty el <> comma <> pretty ec + +instance Pretty a => Pretty (Range' (Maybe a)) where + pretty r = case rangeToInterval r of + Nothing -> empty + Just i -> pretty i + +instance (Pretty a, HasRange a) => Pretty (PrintRange a) where + pretty (PrintRange a) = pretty a <+> parens (text "at" <+> pretty (getRange a)) {-------------------------------------------------------------------------- Functions on postitions and ranges diff --git a/src/full/Agda/Syntax/Scope/Base.hs b/src/full/Agda/Syntax/Scope/Base.hs --- a/src/full/Agda/Syntax/Scope/Base.hs +++ b/src/full/Agda/Syntax/Scope/Base.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} - +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-| This module defines the notion of a scope and operations on scopes. -} @@ -113,7 +112,7 @@ -- (List not empty). deriving (Typeable) -instance NFData LocalVar +instance NFData LocalVar where rnf x = seq x () instance Eq LocalVar where (==) = (==) `on` localVar diff --git a/src/full/Agda/Syntax/Scope/Monad.hs b/src/full/Agda/Syntax/Scope/Monad.hs --- a/src/full/Agda/Syntax/Scope/Monad.hs +++ b/src/full/Agda/Syntax/Scope/Monad.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + {-| The scope monad with operations. -} @@ -16,6 +20,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set import Data.Traversable import Agda.Syntax.Common @@ -197,29 +203,43 @@ | ConstructorName [AbstractName] | PatternSynResName AbstractName | UnknownName - deriving (Show) + deriving (Show, Eq) -- | Look up the abstract name referred to by a given concrete name. resolveName :: C.QName -> ScopeM ResolvedName -resolveName = resolveName' allKindsOfNames +resolveName = resolveName' allKindsOfNames Nothing -- | Look up the abstract name corresponding to a concrete name of --- a certain kind. +-- a certain kind and/or from a given set of names. -- Sometimes we know already that we are dealing with a constructor -- or pattern synonym (e.g. when we have parsed a pattern). -- Then, we can ignore conflicting definitions of that name -- of a different kind. (See issue 822.) -resolveName' :: [KindOfName] -> C.QName -> ScopeM ResolvedName -resolveName' kinds x = do +resolveName' :: + [KindOfName] -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName +resolveName' kinds names x = do scope <- getScope - let vars = AssocList.mapKeysMonotonic C.QName $ scopeLocals scope + let vars = AssocList.mapKeysMonotonic C.QName $ scopeLocals scope + retVar y = return $ VarName $ y { nameConcrete = unqualify x } + aName = A.qnameName . anameName case lookup x vars of -- Case: we have a local variable x. - Just (LocalVar y) -> return $ VarName $ y { nameConcrete = unqualify x } - -- Case: ... but is shadowed by some imports. - Just (ShadowedVar y ys) -> typeError $ AmbiguousName x $ A.qualify_ y : map anameName ys + Just (LocalVar y) -> retVar y + -- Case: ... but is (perhaps) shadowed by some imports. + Just (ShadowedVar y ys) -> case names of + Nothing -> shadowed ys + Just ns -> case filter (\y -> aName y `Set.member` ns) ys of + [] -> retVar y + ys -> shadowed ys + where + shadowed ys = + typeError $ AmbiguousName x $ A.qualify_ y : map anameName ys -- Case: we do not have a local variable x. - Nothing -> case filter ((`elem` kinds) . anameKind . fst) $ scopeLookup' x scope of + Nothing -> case filter (\y -> anameKind (fst y) `elem` kinds + && + maybe True (Set.member (aName (fst y))) + names) + (scopeLookup' x scope) of [] -> return UnknownName ds | all ((==ConName) . anameKind . fst) ds -> return $ ConstructorName @@ -243,19 +263,25 @@ [] -> typeError $ NoSuchModule x ms -> typeError $ AmbiguousModule x (map amodName ms) --- | Get the fixity of a name. The name is assumed to be in scope. -getFixity :: C.QName -> ScopeM Fixity' -getFixity x = do - r <- resolveName x +-- | Get the notation of a name. The name is assumed to be in scope. +getNotation + :: C.QName + -> Set A.Name + -- ^ The name must correspond to one of the names in this set. + -> ScopeM NewNotation +getNotation x ns = do + r <- resolveName' allKindsOfNames (Just ns) x case r of - VarName y -> return $ nameFixity y - DefinedName _ d -> return $ aFixity d - FieldName d -> return $ aFixity d - ConstructorName ds -> return $ chooseFixity $ map aFixity ds - PatternSynResName n -> return $ aFixity n + VarName y -> return $ namesToNotation x y + DefinedName _ d -> return $ notation d + FieldName d -> return $ notation d + ConstructorName ds -> case mergeNotations $ map notation ds of + [n] -> return n + _ -> __IMPOSSIBLE__ + PatternSynResName n -> return $ notation n UnknownName -> __IMPOSSIBLE__ where - aFixity = nameFixity . qnameName . anameName + notation = namesToNotation x . qnameName . anameName -- * Binding names @@ -319,7 +345,7 @@ -- alternative to qualification by their module). -- (See Issue 836). copyScope :: C.QName -> A.ModuleName -> Scope -> ScopeM (Scope, (A.Ren A.ModuleName, A.Ren A.QName)) -copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy new s) (Map.empty, Map.empty) +copyScope oldc new s = first (inScopeBecause $ Applied oldc) <$> runStateT (copy new s) ([], []) where -- | A memoizing algorithm, the renamings serving as memo structure. copy :: A.ModuleName -> Scope -> StateT (A.Ren A.ModuleName, A.Ren A.QName) ScopeM Scope @@ -351,35 +377,29 @@ _ -> lensAnameName f d -- Adding to memo structure. - addName x y = modify $ second $ Map.insert x y - addMod x y = modify $ first $ Map.insert x y + addName x y = modify $ second $ ((x, y):) + addMod x y = modify $ first $ ((x, y):) -- Querying the memo structure. - findName x = Map.lookup x <$> gets snd - findMod x = Map.lookup x <$> gets fst + findName x = lookup x <$> gets snd + findMod x = lookup x <$> gets fst -- Change a binding M.x -> old.M'.y to M.x -> new.M'.y renName :: A.QName -> WSM A.QName renName x = do - lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x - -- If we've seen it already, just return its copy. - (`fromMaybeM` findName x) $ do - -- We have not processed this name @x@, so copy it to some @y@. -- Check whether we have already seen a module of the same name. -- If yes, use its copy as @y@. y <- ifJustM (findMod $ qnameToMName x) (return . mnameToQName) $ {- else -} do -- First time, generate a fresh name for it. i <- lift fresh return $ A.qualify new' $ (qnameName x) { nameId = i } + lift $ reportSLn "scope.copy" 50 $ " Copying " ++ show x ++ " to " ++ show y addName x y return y -- Change a binding M.x -> old.M'.y to M.x -> new.M'.y renMod :: A.ModuleName -> WSM A.ModuleName renMod x = do - -- If we've seen it already, just return its copy. - (`fromMaybeM` findMod x) $ do - -- We have not processed this name @x@, so copy it to some @y@. -- Check whether we have seen it already, yet as name. -- If yes, use its copy as @y@. y <- ifJustM (findName $ mnameToQName x) (return . qnameToMName) $ {- else -} do diff --git a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs --- a/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs +++ b/src/full/Agda/Syntax/Translation/AbstractToConcrete.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} -- {-# OPTIONS -fwarn-unused-binds #-} @@ -35,10 +34,11 @@ import Control.Monad.Reader import Data.List as List hiding (null) -import Data.Maybe import qualified Data.Map as Map -import qualified Data.Set as Set +import Data.Maybe +import Data.Monoid import Data.Set (Set) +import qualified Data.Set as Set import Data.Traversable (traverse) import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) @@ -58,9 +58,11 @@ import Agda.TypeChecking.Monad.Options import qualified Agda.Utils.AssocList as AssocList +import Agda.Utils.Functor import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Tuple +import Agda.Utils.Pretty (prettyShow) #include "undefined.h" import Agda.Utils.Impossible @@ -77,14 +79,12 @@ } makeEnv :: ScopeInfo -> Env -makeEnv scope = Env { takenNames = taken +makeEnv scope = Env { takenNames = Set.union vars defs , currentScope = scope } where - ns = everythingInScope scope - taken = Set.union vars defs vars = Set.fromList $ map fst $ scopeLocals scope - defs = Set.fromList [ x | (x, _) <- Map.toList $ nsNames ns ] + defs = Map.keysSet $ nsNames $ everythingInScope scope currentPrecedence :: AbsToCon Precedence currentPrecedence = asks $ scopePrecedence . currentScope @@ -121,37 +121,6 @@ abstractToConcrete_ :: ToConcrete a c => a -> TCM c abstractToConcrete_ = runAbsToCon . toConcrete -{- --- | We make the translation monadic for modularity purposes. -type AbsToCon = Reader Env - -runAbsToCon :: AbsToCon a -> TCM a -runAbsToCon m = do - scope <- getScope - return $ runReader m (makeEnv scope) - -abstractToConcreteEnv :: ToConcrete a c => Env -> a -> TCM c -abstractToConcreteEnv flags a = return $ runReader (toConcrete a) flags - -{- Andreas, 2013-02-26 discontinue non-monadic version in favor of debug msg. -abstractToConcrete :: ToConcrete a c => Env -> a -> c -abstractToConcrete flags a = runReader (toConcrete a) flags --} - -abstractToConcreteCtx :: ToConcrete a c => Precedence -> a -> TCM c -abstractToConcreteCtx ctx x = do - scope <- getScope - let scope' = scope { scopePrecedence = ctx } - return $ abstractToConcrete (makeEnv scope') x - where - scope = (currentScope defaultEnv) { scopePrecedence = ctx } - -abstractToConcrete_ :: ToConcrete a c => a -> TCM c -abstractToConcrete_ x = do - scope <- getScope - return $ abstractToConcrete (makeEnv scope) x --} - -- Dealing with names ----------------------------------------------------- -- | Names in abstract syntax are fully qualified, but the concrete syntax @@ -287,6 +256,30 @@ bindToConcreteCtx :: ToConcrete a c => Precedence -> a -> (c -> AbsToCon b) -> AbsToCon b bindToConcreteCtx p x ret = withPrecedence p $ bindToConcrete x ret +-- | Translate something in the top context. +toConcreteTop :: ToConcrete a c => a -> AbsToCon c +toConcreteTop = toConcreteCtx TopCtx + +-- | Translate something in the top context. +bindToConcreteTop :: ToConcrete a c => a -> (c -> AbsToCon b) -> AbsToCon b +bindToConcreteTop = bindToConcreteCtx TopCtx + +-- | Translate something in a context indicated by 'Hiding' info. +toConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> AbsToCon c +toConcreteHiding h = + case getHiding h of + NotHidden -> toConcrete + Hidden -> toConcreteTop + Instance -> toConcreteTop + +-- | Translate something in a context indicated by 'Hiding' info. +bindToConcreteHiding :: (LensHiding h, ToConcrete a c) => h -> a -> (c -> AbsToCon b) -> AbsToCon b +bindToConcreteHiding h = + case getHiding h of + NotHidden -> bindToConcrete + Hidden -> bindToConcreteTop + Instance -> bindToConcreteTop + -- General instances ------------------------------------------------------ instance ToConcrete a c => ToConcrete [a] [c] where @@ -315,16 +308,20 @@ return $ info { argInfoColors = [] } -- TODO: zapping ignoring colours instance ToConcrete a c => ToConcrete (Common.Arg ac a) (C.Arg c) where - toConcrete (Common.Arg info x) = liftM2 Common.Arg (toConcrete info) (f x) - where f = case getHiding info of - Hidden -> toConcreteCtx TopCtx - Instance -> toConcreteCtx TopCtx - NotHidden -> toConcrete + toConcrete (Common.Arg info x) = Common.Arg + <$> toConcrete info + <*> toConcreteHiding info x - bindToConcrete (Common.Arg info x) ret = do info <- toConcrete info - bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $ - ret . Common.Arg info + bindToConcrete (Common.Arg info x) ret = do + info <- toConcrete info + bindToConcreteCtx (hiddenArgumentCtx $ getHiding info) x $ + ret . Common.Arg info +instance ToConcrete a c => ToConcrete (WithHiding a) (WithHiding c) where + toConcrete (WithHiding h a) = WithHiding h <$> toConcreteHiding h a + bindToConcrete (WithHiding h a) ret = bindToConcreteHiding h a $ \ a -> + ret $ WithHiding h a + instance ToConcrete a c => ToConcrete (Named name a) (Named name c) where toConcrete (Named n x) = Named n <$> toConcrete x bindToConcrete (Named n x) ret = bindToConcrete x $ ret . Named n @@ -371,7 +368,7 @@ toConcrete (A.Underscore i) = return $ C.Underscore (getRange i) $ - show . NamedMeta (metaNameSuggestion i) . MetaId <$> metaNumber i + prettyShow . NamedMeta (metaNameSuggestion i) . MetaId <$> metaNumber i toConcrete e@(A.App i e1 e2) = tryToRecoverOpApp e @@ -394,7 +391,7 @@ $ case lamView e of (bs, e) -> bindToConcrete (map makeDomainFree bs) $ \bs -> do - e <- toConcreteCtx TopCtx e + e <- toConcreteTop e return $ C.Lam (getRange i) (concat bs) e where lamView (A.Lam _ b@(A.DomainFree _ _) e) = @@ -438,7 +435,7 @@ (tel, e) -> bracket piBrackets $ bindToConcrete tel $ \b' -> do - e' <- toConcreteCtx TopCtx e + e' <- toConcreteTop e return $ C.Pi (concat b') e' where piTel (A.Pi _ tel e) = (tel ++) -*- id $ piTel e @@ -447,7 +444,7 @@ toConcrete (A.Fun i a b) = bracket piBrackets $ do a' <- toConcreteCtx (if irr then DotPatternCtx else FunctionSpaceDomainCtx) a - b' <- toConcreteCtx TopCtx b + b' <- toConcreteTop b return $ C.Fun (getRange i) (addRel a' $ mkArg a') b' where irr = getRelevance a `elem` [Irrelevant, NonStrict] @@ -468,20 +465,20 @@ toConcrete (A.Let i ds e) = bracket lamBrackets $ bindToConcrete ds $ \ds' -> do - e' <- toConcreteCtx TopCtx e + e' <- toConcreteTop e return $ C.Let (getRange i) (concat ds') e' toConcrete (A.Rec i fs) = bracket appBrackets $ do let (xs, es) = unzip fs - es <- toConcreteCtx TopCtx es + es <- toConcreteTop es return $ C.Rec (getRange i) $ zip xs es toConcrete (A.RecUpdate i e fs) = bracket appBrackets $ do let (xs, es) = unzip fs e <- toConcrete e - es <- toConcreteCtx TopCtx es + es <- toConcreteTop es return $ C.RecUpdate (getRange i) e $ zip xs es toConcrete (A.ETel tel) = do @@ -508,7 +505,7 @@ -- Andreas, 2010-10-05 print irrelevant things as ordinary things toConcrete (A.DontCare e) = C.Dot r . C.Paren r <$> toConcrete e where r = getRange e --- toConcrete (A.DontCare e) = C.DontCare <$> toConcreteCtx TopCtx e +-- toConcrete (A.DontCare e) = C.DontCare <$> toConcreteTop e {- -- Andreas, 2010-09-21 abuse C.Underscore to print irrelevant things toConcrete (A.DontCare) = return $ C.Underscore noRange Nothing @@ -516,9 +513,9 @@ toConcrete (A.PatternSyn n) = C.Ident <$> toConcrete n makeDomainFree :: A.LamBinding -> A.LamBinding -makeDomainFree b@(A.DomainFull (A.TypedBindings r (Common.Arg info (A.TBind _ [x] t)))) = +makeDomainFree b@(A.DomainFull (A.TypedBindings r (Common.Arg info (A.TBind _ [WithHiding h x] t)))) = case unScope t of - A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree info x + A.Underscore MetaInfo{metaNumber = Nothing} -> A.DomainFree (mapHiding (mappend h) info) x _ -> b makeDomainFree b = b @@ -547,20 +544,20 @@ tbinds r e xs = [ C.TBind r xs e ] tbind r e xs = - case span (\x -> boundLabel x == boundName x) xs of + case span ((\ x -> boundLabel x == boundName x) . dget) xs of (xs, x:ys) -> tbinds r e xs ++ [ C.TBind r [x] e ] ++ tbind r e ys (xs, []) -> tbinds r e xs - label x y = y { boundLabel = nameConcrete x } + label x = fmap $ \ y -> y { boundLabel = nameConcrete $ dget x } instance ToConcrete A.TypedBinding C.TypedBinding where bindToConcrete (A.TBind r xs e) ret = - bindToConcrete xs $ \xs -> do - e <- toConcreteCtx TopCtx e - ret (C.TBind r (map mkBoundName_ xs) e) + bindToConcrete xs $ \ xs -> do + e <- toConcreteTop e + ret $ C.TBind r (map (fmap mkBoundName_) xs) e bindToConcrete (A.TLet r lbs) ret = - bindToConcrete lbs $ \ds -> do - ret (C.TLet r (concat ds)) + bindToConcrete lbs $ \ ds -> do + ret $ C.TLet r $ concat ds instance ToConcrete LetBinding [C.Declaration] where bindToConcrete (LetBind i info x t e) ret = @@ -637,12 +634,12 @@ es <- toConcrete es cs <- concat <$> toConcrete cs return (C.AbsurdRHS, [], es, cs) - toConcrete (A.RewriteRHS _ eqs rhs wh) = do + toConcrete (A.RewriteRHS xeqs rhs wh) = do wh <- declsToConcrete wh (rhs, eqs', es, whs) <- toConcrete rhs unless (null eqs') __IMPOSSIBLE__ - eqs <- toConcrete eqs + eqs <- toConcrete $ map snd xeqs return (rhs, eqs, es, wh ++ whs) instance ToConcrete (Maybe A.QName) (Maybe C.Name) where @@ -669,7 +666,7 @@ withScope scope $ toConcrete (Constr d) toConcrete (Constr (A.Axiom _ i info x t)) = do x' <- unsafeQNameToName <$> toConcrete x - t' <- toConcreteCtx TopCtx t + t' <- toConcreteTop t info <- toConcrete info return $ C.TypeSig info x' t' toConcrete (Constr d) = head <$> toConcrete d @@ -680,7 +677,7 @@ case lhs of C.LHS p wps _ _ -> do bindToConcrete (AsWhereDecls wh) $ \wh' -> do - (rhs', eqs, with, wcs) <- toConcreteCtx TopCtx rhs + (rhs', eqs, with, wcs) <- toConcreteTop rhs return $ FunClause (C.LHS p wps eqs with) rhs' wh' : wcs C.Ellipsis {} -> __IMPOSSIBLE__ -- TODO: Is the case above impossible? Previously there was @@ -691,9 +688,10 @@ toConcrete (A.SectionApp tel y es) = do y <- toConcreteCtx FunctionCtx y bindToConcrete tel $ \tel -> do - es <- toConcreteCtx ArgumentCtx es - let r = fuseRange y es - return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es) + es <- toConcreteCtx ArgumentCtx es + let r = fuseRange y es + return $ C.SectionApp r (concat tel) (foldl (C.App r) (C.Ident y) es) + toConcrete (A.RecordModuleIFS recm) = do recm <- toConcrete recm return $ C.RecordModuleIFS (getRange recm) recm @@ -706,7 +704,7 @@ x' <- unsafeQNameToName <$> toConcrete x withAbstractPrivate i $ withInfixDecl i x' $ do - t' <- toConcreteCtx TopCtx t + t' <- toConcreteTop t info <- toConcrete info return [C.Postulate (getRange i) [C.TypeSig info x' t']] @@ -714,14 +712,14 @@ x' <- unsafeQNameToName <$> toConcrete x withAbstractPrivate i $ withInfixDecl i x' $ do - t' <- toConcreteCtx TopCtx t + t' <- toConcreteTop t return [C.Field x' t'] toConcrete (A.Primitive i x t) = do x' <- unsafeQNameToName <$> toConcrete x withAbstractPrivate i $ withInfixDecl i x' $ do - t' <- toConcreteCtx TopCtx t + t' <- toConcreteTop t return [C.Primitive (getRange i) [C.TypeSig defaultArgInfo x' t']] -- Primitives are always relevant. @@ -732,7 +730,7 @@ withAbstractPrivate i $ bindToConcrete bs $ \tel' -> do x' <- unsafeQNameToName <$> toConcrete x - t' <- toConcreteCtx TopCtx t + t' <- toConcreteTop t return [ C.DataSig (getRange i) Inductive x' (map C.DomainFull $ concat tel') t' ] toConcrete (A.DataDef i x bs cs) = @@ -745,7 +743,7 @@ withAbstractPrivate i $ bindToConcrete bs $ \tel' -> do x' <- unsafeQNameToName <$> toConcrete x - t' <- toConcreteCtx TopCtx t + t' <- toConcreteTop t return [ C.RecordSig (getRange i) x' (map C.DomainFull $ concat tel') t' ] toConcrete (A.RecDef i x ind c bs t cs) = @@ -759,8 +757,8 @@ toConcrete (A.Section i x tel ds) = do x <- toConcrete x bindToConcrete tel $ \tel -> do - ds <- declsToConcrete ds - return [ C.Module (getRange i) x (concat tel) ds ] + ds <- declsToConcrete ds + return [ C.Module (getRange i) x (concat tel) ds ] toConcrete (A.Apply i x modapp _ _) = do x <- unsafeQNameToName <$> toConcrete x @@ -796,36 +794,32 @@ data RangeAndPragma = RangeAndPragma Range A.Pragma instance ToConcrete RangeAndPragma C.Pragma where - toConcrete (RangeAndPragma r p) = case p of - A.OptionsPragma xs -> return $ C.OptionsPragma r xs - A.BuiltinPragma b x -> do - x <- toConcrete x - return $ C.BuiltinPragma r b x - A.RewritePragma x -> do - x <- toConcrete x - return $ C.RewritePragma r x - A.CompiledTypePragma x hs -> do - x <- toConcrete x - return $ C.CompiledTypePragma r x hs - A.CompiledDataPragma x hs hcs -> do - x <- toConcrete x - return $ C.CompiledDataPragma r x hs hcs - A.CompiledPragma x hs -> do - x <- toConcrete x - return $ C.CompiledPragma r x hs - A.CompiledExportPragma x hs -> do - x <- toConcrete x - return $ C.CompiledExportPragma r x hs - A.CompiledEpicPragma x e -> do - x <- toConcrete x - return $ C.CompiledEpicPragma r x e - A.CompiledJSPragma x e -> do - x <- toConcrete x - return $ C.CompiledJSPragma r x e - A.StaticPragma x -> do - x <- toConcrete x - return $ C.StaticPragma r x - A.EtaPragma x -> C.EtaPragma r <$> toConcrete x + toConcrete (RangeAndPragma r p) = case p of + A.OptionsPragma xs -> return $ C.OptionsPragma r xs + A.BuiltinPragma b e -> C.BuiltinPragma r b <$> toConcrete e + A.BuiltinNoDefPragma b x -> C.BuiltinPragma r b . C.Ident <$> + toConcrete x + A.RewritePragma x -> C.RewritePragma r <$> toConcrete x + A.CompiledTypePragma x hs -> do + x <- toConcrete x + return $ C.CompiledTypePragma r x hs + A.CompiledDataPragma x hs hcs -> do + x <- toConcrete x + return $ C.CompiledDataPragma r x hs hcs + A.CompiledPragma x hs -> do + x <- toConcrete x + return $ C.CompiledPragma r x hs + A.CompiledExportPragma x hs -> do + x <- toConcrete x + return $ C.CompiledExportPragma r x hs + A.CompiledEpicPragma x e -> do + x <- toConcrete x + return $ C.CompiledEpicPragma r x e + A.CompiledJSPragma x e -> do + x <- toConcrete x + return $ C.CompiledJSPragma r x e + A.StaticPragma x -> C.StaticPragma r <$> toConcrete x + A.EtaPragma x -> C.EtaPragma r <$> toConcrete x -- Left hand sides -------------------------------------------------------- @@ -847,28 +841,9 @@ bindToConcreteCtx TopCtx lhscore $ \lhs -> bindToConcreteCtx TopCtx (noImplicitPats wps) $ \wps -> ret $ C.LHS lhs wps [] [] -{- - bindToConcrete (A.LHS i (A.LHSHead x args) wps) ret = do - bindToConcreteCtx TopCtx (A.DefP info x args) $ \lhs -> - bindToConcreteCtx TopCtx (noImplicitPats wps) $ \wps -> - ret $ C.LHS lhs wps [] [] - where info = PatRange (getRange i) --} instance ToConcrete A.LHSCore C.Pattern where bindToConcrete = bindToConcrete . lhsCoreToPattern -{- - bindToConcrete (A.LHSHead x args) ret = do - bindToConcreteCtx TopCtx (A.DefP info x args) $ \ lhs -> - ret $ lhs - where info = PatRange noRange -- seems to be unused anyway - bindToConcrete (A.LHSProj d ps1 lhscore ps2) ret = do - d <- toConcrete d - bindToConcrete ps1 $ \ ps1 -> - bindToConcrete lhscore $ \ p -> - bindToConcrete ps2 $ \ ps2 -> - ret $ makePattern d ps1 p ps2 - -} appBrackets' :: [arg] -> Precedence -> Bool appBrackets' [] _ = False @@ -912,8 +887,9 @@ data Hd = HdVar A.Name | HdCon A.QName | HdDef A.QName -cOpApp :: Range -> C.QName -> [C.Expr] -> C.Expr -cOpApp r n es = C.OpApp r n (map (defaultNamedArg . Ordinary) es) +cOpApp :: Range -> C.QName -> A.Name -> [C.Expr] -> C.Expr +cOpApp r x n es = + C.OpApp r x (Set.singleton n) (map (defaultNamedArg . Ordinary) es) tryToRecoverOpApp :: A.Expr -> AbsToCon C.Expr -> AbsToCon C.Expr tryToRecoverOpApp e def = recoverOpApp bracket cOpApp view e def @@ -930,7 +906,9 @@ tryToRecoverOpAppP :: A.Pattern -> AbsToCon C.Pattern -> AbsToCon C.Pattern tryToRecoverOpAppP p def = recoverOpApp bracketP_ opApp view p def where - opApp r x ps = C.OpAppP r x (map defaultNamedArg ps) + opApp r x n ps = + C.OpAppP r x (Set.singleton n) (map defaultNamedArg ps) + view p = case p of ConP _ (AmbQ (c:_)) ps -> Just (HdCon c, ps) DefP _ f ps -> Just (HdDef f, ps) @@ -938,7 +916,7 @@ recoverOpApp :: (ToConcrete a c, HasRange c) => ((Precedence -> Bool) -> AbsToCon c -> AbsToCon c) - -> (Range -> C.QName -> [c] -> c) + -> (Range -> C.QName -> A.Name -> [c] -> c) -> (a -> Maybe (Hd, [A.NamedArg a])) -> a -> AbsToCon c @@ -959,19 +937,20 @@ doQNameHelper fixityHelper conHelper n as = do x <- toConcrete n - doQName (theFixity $ nameFixity $ fixityHelper n) (conHelper x) as + doQName (theFixity $ nameFixity n') (conHelper x) n' as + where n' = fixityHelper n -- fall-back (wrong number of arguments or no holes) - doQName _ n es + doQName _ x _ es | length xs == 1 = mDefault | length es /= numHoles = mDefault | null es = mDefault where - xs = C.nameParts $ C.unqualify n + xs = C.nameParts $ C.unqualify x numHoles = length (filter (== Hole) xs) -- binary case - doQName fixity n as + doQName fixity x n as | Hole <- head xs , Hole <- last xs = do let a1 = head as @@ -983,12 +962,12 @@ es <- mapM (toConcreteCtx InsideOperandCtx) as' en <- toConcreteCtx (RightOperandCtx fixity) an bracket (opBrackets fixity) - $ return $ opApp (getRange (e1, en)) n ([e1] ++ es ++ [en]) + $ return $ opApp (getRange (e1, en)) x n ([e1] ++ es ++ [en]) where - xs = C.nameParts $ C.unqualify n + xs = C.nameParts $ C.unqualify x -- prefix - doQName fixity n as + doQName fixity x n as | Hole <- last xs = do let an = last as as' = case as of @@ -997,24 +976,24 @@ es <- mapM (toConcreteCtx InsideOperandCtx) as' en <- toConcreteCtx (RightOperandCtx fixity) an bracket (opBrackets fixity) - $ return $ opApp (getRange (n, en)) n (es ++ [en]) + $ return $ opApp (getRange (n, en)) x n (es ++ [en]) where - xs = C.nameParts $ C.unqualify n + xs = C.nameParts $ C.unqualify x -- postfix - doQName fixity n as + doQName fixity x n as | Hole <- head xs = do let a1 = head as as' = tail as e1 <- toConcreteCtx (LeftOperandCtx fixity) a1 es <- mapM (toConcreteCtx InsideOperandCtx) as' bracket (opBrackets fixity) - $ return $ opApp (getRange (e1, n)) n ([e1] ++ es) + $ return $ opApp (getRange (e1, n)) x n ([e1] ++ es) where - xs = C.nameParts $ C.unqualify n + xs = C.nameParts $ C.unqualify x -- roundfix - doQName _ n as = do + doQName _ x n as = do es <- mapM (toConcreteCtx InsideOperandCtx) as bracket roundFixBrackets - $ return $ opApp (getRange n) n es + $ return $ opApp (getRange x) x n es diff --git a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs --- a/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +++ b/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + {-| Translation from "Agda.Syntax.Concrete" to "Agda.Syntax.Abstract". Involves scope analysis, figuring out infix operator precedences and tidying up definitions. -} @@ -34,6 +38,8 @@ import Data.Foldable (Foldable, traverse_) import Data.Traversable (mapM, traverse) import Data.List ((\\), nub, foldl') +import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Map as Map import Data.Maybe @@ -41,6 +47,7 @@ import Agda.Syntax.Concrete.Generic import Agda.Syntax.Concrete.Operators import Agda.Syntax.Abstract as A +import Agda.Syntax.Abstract.Pretty import Agda.Syntax.Position import Agda.Syntax.Literal import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo) @@ -52,11 +59,12 @@ import Agda.Syntax.Scope.Base import Agda.Syntax.Scope.Monad -import Agda.TypeChecking.Monad.Base (TypeError(..), Call(..), typeError, - TCErr(..), extendedLambdaName, fresh, - freshName, freshName_, freshNoName) -import Agda.TypeChecking.Monad.Benchmark (billTo, billTop, reimburseTop) +import Agda.TypeChecking.Monad.Base + ( TypeError(..) , Call(..) , typeError , genericError , TCErr(..) + , fresh , freshName , freshName_ , freshNoName , extendedLambdaName + ) import qualified Agda.TypeChecking.Monad.Benchmark as Bench +import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange) import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint) @@ -124,11 +132,6 @@ s <- getScope return $ ScopedExpr s e -expandEllipsis :: C.Pattern -> [C.Pattern] -> C.Clause -> C.Clause -expandEllipsis _ _ c@(C.Clause _ C.LHS{} _ _ _) = c -expandEllipsis p ps (C.Clause x (C.Ellipsis _ ps' eqs es) rhs wh wcs) = - C.Clause x (C.LHS p (ps ++ ps') eqs es) rhs wh wcs - -- | Make sure that each variable occurs only once. checkPatternLinearity :: [A.Pattern' e] -> ScopeM () checkPatternLinearity ps = unlessNull (duplicates xs) $ \ ys -> do @@ -170,7 +173,7 @@ build (NiceModuleMacro r p x modapp open dir{ publicOpen = False } : fs) build (NiceField r f _ _ x (Common.Arg info e) : fs) = - C.Pi [C.TypedBindings r $ Common.Arg info (C.TBind r [mkBoundName x f] e)] $ build fs + C.Pi [C.TypedBindings r $ Common.Arg info (C.TBind r [pure $ mkBoundName x f] e)] $ build fs where r = getRange x build (d : fs) = C.Let (getRange d) [notSoNiceDeclaration d] $ build fs @@ -302,6 +305,12 @@ Precedence -> concrete -> ScopeM abstract toAbstractCtx ctx c = withContextPrecedence ctx $ toAbstract c +toAbstractTopCtx :: ToAbstract c a => c -> ScopeM a +toAbstractTopCtx = toAbstractCtx TopCtx + +toAbstractHiding :: (LensHiding h, ToAbstract c a) => h -> c -> ScopeM a +toAbstractHiding h = toAbstractCtx $ hiddenArgumentCtx $ getHiding h + setContextCPS :: Precedence -> (a -> ScopeM b) -> ((a -> ScopeM b) -> ScopeM b) -> ScopeM b setContextCPS p ret f = do @@ -325,8 +334,7 @@ withScope scope $ ret =<< toAbstract x instance (ToAbstract c1 a1, ToAbstract c2 a2) => ToAbstract (c1,c2) (a1,a2) where - toAbstract (x,y) = - (,) <$> toAbstract x <*> toAbstract y + toAbstract (x,y) = (,) <$> toAbstract x <*> toAbstract y instance (ToAbstract c1 a1, ToAbstract c2 a2, ToAbstract c3 a3) => ToAbstract (c1,c2,c3) (a1,a2,a3) where @@ -334,19 +342,26 @@ where flatten (x,(y,z)) = (x,y,z) +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} ToAbstract c a => ToAbstract [c] [a] where +#else instance ToAbstract c a => ToAbstract [c] [a] where - toAbstract = mapM toAbstract +#endif + toAbstract = mapM toAbstract instance ToAbstract c a => ToAbstract (Maybe c) (Maybe a) where - toAbstract Nothing = return Nothing - toAbstract (Just x) = Just <$> toAbstract x + toAbstract = traverse toAbstract -- Names ------------------------------------------------------------------ newtype NewName a = NewName a -newtype OldQName = OldQName C.QName +data OldQName = OldQName C.QName (Maybe (Set A.Name)) + -- ^ If a set is given, then the first name must correspond to one + -- of the names in the set. newtype OldName = OldName C.Name -newtype PatName = PatName C.QName +data PatName = PatName C.QName (Maybe (Set A.Name)) + -- ^ If a set is given, then the first name must correspond to one + -- of the names in the set. instance ToAbstract (NewName C.Name) A.Name where toAbstract (NewName x) = do @@ -371,8 +386,8 @@ where i = ExprRange (getRange x) instance ToAbstract OldQName A.Expr where - toAbstract (OldQName x) = do - qx <- resolveName x + toAbstract (OldQName x ns) = do + qx <- resolveName' allKindsOfNames ns x reportSLn "scope.name" 10 $ "resolved " ++ show x ++ ": " ++ show qx case qx of VarName x' -> return $ A.Var x' @@ -387,9 +402,11 @@ | PatternSynPatName AbstractName instance ToAbstract PatName APatName where - toAbstract (PatName x) = do + toAbstract (PatName x ns) = do reportSLn "scope.pat" 10 $ "checking pattern name: " ++ show x - rx <- resolveName' [ConName, PatternSynName] x -- Andreas, 2013-03-21 ignore conflicting names which cannot be meant since we are in a pattern + rx <- resolveName' [ConName, PatternSynName] ns x + -- Andreas, 2013-03-21 ignore conflicting names which cannot + -- be meant since we are in a pattern z <- case (rx, x) of -- TODO: warn about shadowing (VarName y, C.QName x) -> return $ Left x -- typeError $ RepeatedVariableInPattern y x @@ -398,9 +415,7 @@ (UnknownName, C.QName x) -> return $ Left x (ConstructorName ds, _) -> return $ Right (Left ds) (PatternSynResName d, _) -> return $ Right (Right d) - _ -> - typeError $ GenericError $ - "Cannot pattern match on " ++ show x ++ ", because it is not a constructor" + _ -> genericError $ "Cannot pattern match on non-constructor " ++ prettyShow x case z of Left x -> do reportSLn "scope.pat" 10 $ "it was a var: " ++ show x @@ -436,7 +451,7 @@ ms <- scopeLookup (C.QName x) <$> getScope unless (null ms) $ do reportSLn "scope.clash" 20 $ "clashing modules ms = " ++ show ms - setCurrentRange (getRange x) $ + setCurrentRange x $ typeError $ ShadowedModule x $ map ((`withRangeOf` x) . amodName) ms @@ -460,7 +475,8 @@ toAbs m' q instance ToAbstract OldModuleName A.ModuleName where - toAbstract (OldModuleName q) = amodName <$> resolveModule q + toAbstract (OldModuleName q) = setCurrentRange q $ do + amodName <$> resolveModule q -- Expressions ------------------------------------------------------------ @@ -518,7 +534,7 @@ e <- toAbstractCtx ctx e -- We have at least one binder. Get first @b@ and rest @bs@. caseList bs __IMPOSSIBLE__ $ \ b bs -> do - return $ A.Lam (ExprRange r) b $ foldr mkLam e bs + return $ A.Lam (ExprRange r) b $ foldr mkLam e bs where mkLam b e = A.Lam (ExprRange $ fuseRange b e) b e @@ -526,7 +542,7 @@ scopeCheckExtendedLam :: Range -> [(C.LHS, C.RHS, WhereClause)] -> ScopeM A.Expr scopeCheckExtendedLam r cs = do whenM isInsideDotPattern $ - typeError $ GenericError "Extended lambdas are not allowed in dot patterns" + genericError "Extended lambdas are not allowed in dot patterns" -- Find an unused name for the extended lambda definition. cname <- nextlamname r 0 extendedLambdaName @@ -570,7 +586,7 @@ traceCall (ScopeCheckExpr e) $ annotateExpr $ case e of -- Names - Ident x -> toAbstract (OldQName x) + Ident x -> toAbstract (OldQName x Nothing) -- Literals C.Lit l -> return $ A.Lit l @@ -598,8 +614,7 @@ -- Raw application C.RawApp r es -> do - e <- reimburseTop Bench.Scoping $ billTo [Bench.Parsing, Bench.Operators] $ - parseApplication es + e <- parseApplication es toAbstract e -- Application @@ -609,7 +624,7 @@ return $ A.App (ExprRange r) e1 e2 -- Operator application - C.OpApp r op es -> toAbstractOpApp op es + C.OpApp r op ns es -> toAbstractOpApp op ns es -- With application C.WithApp r e es -> do @@ -652,7 +667,7 @@ -- Let e0@(C.Let _ ds e) -> - ifM isInsideDotPattern (typeError $ GenericError $ "Let-expressions are not allowed in dot patterns") $ + ifM isInsideDotPattern (genericError $ "Let-expressions are not allowed in dot patterns") $ localToAbstract (LetDefs ds) $ \ds' -> do e <- toAbstractCtx TopCtx e let info = ExprRange (getRange e0) @@ -681,7 +696,7 @@ -- Impossible things C.ETel _ -> __IMPOSSIBLE__ - C.Equal{} -> typeError $ GenericError "Parse error: unexpected '='" + C.Equal{} -> genericError "Parse error: unexpected '='" -- Quoting C.QuoteGoal _ x e -> do @@ -713,7 +728,7 @@ makeDomainFull :: C.LamBinding -> C.TypedBindings makeDomainFull (C.DomainFull b) = b makeDomainFull (C.DomainFree info x) = - C.TypedBindings r $ Common.Arg info $ C.TBind r [x] $ C.Underscore r Nothing + C.TypedBindings r $ Common.Arg info $ C.TBind r [pure x] $ C.Underscore r Nothing where r = getRange x instance ToAbstract C.TypedBindings A.TypedBindings where @@ -722,11 +737,9 @@ instance ToAbstract C.TypedBinding A.TypedBinding where toAbstract (C.TBind r xs t) = do t' <- toAbstractCtx TopCtx t - xs' <- toAbstract (map NewName xs) + xs' <- toAbstract $ map (fmap NewName) xs return $ A.TBind r xs' t' - toAbstract (C.TLet r ds) = do - ds' <- toAbstract (LetDefs ds) - return $ A.TLet r ds' + toAbstract (C.TLet r ds) = A.TLet r <$> toAbstract (LetDefs ds) -- | Scope check a module (top level function). -- @@ -915,10 +928,14 @@ -- | runs Syntax.Concrete.Definitions.niceDeclarations on main module niceDecls :: [C.Declaration] -> ScopeM [NiceDeclaration] niceDecls ds = case runNice $ niceDeclarations ds of - Left e -> throwError $ Exception (getRange e) (show e) + Left e -> throwError $ Exception (getRange e) $ pretty e Right ds -> return ds +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} ToAbstract [C.Declaration] [A.Declaration] where +#else instance ToAbstract [C.Declaration] [A.Declaration] where +#endif toAbstract ds = do -- don't allow to switch off termination checker in --safe mode ds <- ifM (optSafe <$> commandLineOptions) (mapM noNoTermCheck ds) (return ds) @@ -944,9 +961,9 @@ case d of NiceMutual _ _ d@[C.FunSig _ fx _ instanc info _ x t, C.FunDef _ _ _ abstract _ _ [cl]] -> do when (abstract == AbstractDef) $ do - typeError $ GenericError $ "abstract not allowed in let expressions" + genericError $ "abstract not allowed in let expressions" when (instanc == InstanceDef) $ do - typeError $ GenericError $ "Using instance is useless here, let expressions are always eligible for instance search." + genericError $ "Using instance is useless here, let expressions are always eligible for instance search." e <- letToAbstract cl t <- toAbstract t x <- toAbstract (NewName $ mkBoundName x fx) @@ -955,7 +972,10 @@ -- irrefutable let binding, like (x , y) = rhs NiceFunClause r PublicAccess ConcreteDef termCheck d@(C.FunClause lhs@(C.LHS p [] [] []) (C.RHS rhs) NoWhere) -> do - mp <- setCurrentRange (getRange p) $ (Right <$> parsePattern p) `catchError` (return . Left) + mp <- setCurrentRange p $ + (Right <$> parsePattern p) + `catchError` + (return . Left) case mp of Right p -> do rhs <- toAbstract rhs @@ -1015,10 +1035,10 @@ localToAbstract (snd $ lhsArgs p) $ \args -> -} (x, args) <- do - res <- setCurrentRange (getRange p) $ parseLHS top p + res <- setCurrentRange p $ parseLHS top p case res of C.LHSHead x args -> return (x, args) - C.LHSProj{} -> typeError $ GenericError $ "copatterns not allowed in let bindings" + C.LHSProj{} -> genericError $ "copatterns not allowed in let bindings" localToAbstract args $ \args -> do rhs <- toAbstract rhs @@ -1060,7 +1080,7 @@ -- Fields C.NiceField r f p a x t -> do - unless (p == PublicAccess) $ typeError $ GenericError "Record fields can not be private" + unless (p == PublicAccess) $ genericError "Record fields can not be private" -- Interaction points for record fields have already been introduced -- when checking the type of the record constructor. -- To avoid introducing interaction points (IP) twice, we turn @@ -1121,7 +1141,7 @@ -- Uncategorized function clauses C.NiceFunClause r acc abs termCheck (C.FunClause lhs rhs wcls) -> - typeError $ GenericError $ + genericError $ "Missing type signature for left hand side " ++ show lhs C.NiceFunClause{} -> __IMPOSSIBLE__ @@ -1134,7 +1154,7 @@ dups = nub $ cs \\ nub cs bad = filter (`elem` dups) cs unless (distinct cs) $ - setCurrentRange (getRange bad) $ + setCurrentRange bad $ typeError $ DuplicateConstructors dups pars <- toAbstract pars @@ -1186,7 +1206,7 @@ scopeCheckNiceModule r p name tel $ toAbstract ds NiceModule _ _ _ m@C.Qual{} _ _ -> - typeError $ GenericError $ "Local modules cannot have qualified names" + genericError $ "Local modules cannot have qualified names" NiceModuleMacro r p x modapp open dir -> checkModuleMacro Apply r p x modapp open dir @@ -1209,7 +1229,7 @@ ps <- toAbstract p return $ map (A.Pragma r) ps - NiceImport r x as open dir -> traceCall (SetRange r) $ do + NiceImport r x as open dir -> setCurrentRange r $ do notPublicWithoutOpen open dir -- First scope check the imported module and return its name and @@ -1254,13 +1274,13 @@ } return [ A.Import minfo m ] - NiceUnquoteDecl r fx p a tc x e -> do + NiceUnquoteDecl r fx p i a tc x e -> do y <- freshAbstractQName fx x bindName p QuotableName x y e <- toAbstract e rebindName p DefName x y let mi = MutualInfo tc r - return [A.UnquoteDecl mi (mkDefInfo x fx p a r) y e] + return [A.UnquoteDecl mi (mkDefInfoInstance x fx p a i r) y e] NicePatternSyn r fx n as p -> do reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ show r @@ -1328,81 +1348,100 @@ toAbstract (C.ImpossiblePragma _) = impossibleTest toAbstract (C.OptionsPragma _ opts) = return [ A.OptionsPragma opts ] toAbstract (C.RewritePragma _ x) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing case e of A.Def x -> return [ A.RewritePragma x ] A.Proj x -> return [ A.RewritePragma x ] A.Con (AmbQ [x]) -> return [ A.RewritePragma x ] - A.Con x -> fail $ "REWRITE used on ambiguous name " ++ show x + A.Con x -> genericError $ "REWRITE used on ambiguous name " ++ show x + A.Var x -> genericError $ "REWRITE used on parameter " ++ show x ++ " instead of on a defined symbol" _ -> __IMPOSSIBLE__ toAbstract (C.CompiledTypePragma _ x hs) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing case e of A.Def x -> return [ A.CompiledTypePragma x hs ] - _ -> fail $ "Bad compiled type: " ++ show x -- TODO: error message + _ -> genericError $ "Bad compiled type: " ++ prettyShow x -- TODO: error message toAbstract (C.CompiledDataPragma _ x hs hcs) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing case e of A.Def x -> return [ A.CompiledDataPragma x hs hcs ] - _ -> fail $ "Not a datatype: " ++ show x -- TODO: error message + _ -> genericError $ "Not a datatype: " ++ prettyShow x -- TODO: error message toAbstract (C.CompiledPragma _ x hs) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing y <- case e of A.Def x -> return x A.Proj x -> return x -- TODO: do we need to do s.th. special for projections? (Andreas, 2014-10-12) - A.Con _ -> fail "Use COMPILED_DATA for constructors" -- TODO + A.Con _ -> genericError "Use COMPILED_DATA for constructors" -- TODO _ -> __IMPOSSIBLE__ return [ A.CompiledPragma y hs ] toAbstract (C.CompiledExportPragma _ x hs) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing y <- case e of A.Def x -> return x _ -> __IMPOSSIBLE__ return [ A.CompiledExportPragma y hs ] toAbstract (C.CompiledEpicPragma _ x ep) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing y <- case e of A.Def x -> return x _ -> __IMPOSSIBLE__ return [ A.CompiledEpicPragma y ep ] toAbstract (C.CompiledJSPragma _ x ep) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing y <- case e of A.Def x -> return x A.Proj x -> return x A.Con (AmbQ [x]) -> return x - A.Con x -> fail ("COMPILED_JS used on ambiguous name " ++ show x) + A.Con x -> genericError $ + "COMPILED_JS used on ambiguous name " ++ prettyShow x _ -> __IMPOSSIBLE__ return [ A.CompiledJSPragma y ep ] toAbstract (C.StaticPragma _ x) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing y <- case e of A.Def x -> return x _ -> __IMPOSSIBLE__ return [ A.StaticPragma y ] toAbstract (C.BuiltinPragma _ b e) = do + -- Andreas, 2015-02-14 + -- Some builtins cannot be given a valid Agda type, + -- thus, they do not come with accompanying postulate or definition. + if b `elem` builtinsNoDef then do + case e of + C.Ident q@(C.QName x) -> do + unlessM ((UnknownName ==) <$> resolveName q) $ genericError $ + "BUILTIN " ++ b ++ " declares an identifier " ++ + "(no longer expects an already defined identifier)" + y <- freshAbstractQName defaultFixity' x + bindName PublicAccess DefName x y + return [ A.BuiltinNoDefPragma b y ] + _ -> genericError $ + "Pragma BUILTIN " ++ b ++ ": expected unqualified identifier, " ++ + "but found expression " ++ prettyShow e + else do e <- toAbstract e return [ A.BuiltinPragma b e ] toAbstract (C.ImportPragma _ i) = do addHaskellImport i return [] toAbstract (C.EtaPragma _ x) = do - e <- toAbstract $ OldQName x + e <- toAbstract $ OldQName x Nothing case e of A.Def x -> return [ A.EtaPragma x ] - _ -> fail "Bad ETA pragma" + _ -> do + e <- showA e + genericError $ "Pragma ETA: expected identifier, " ++ + "but found expression " ++ e -- Termination checking pragmes are handled by the nicifier toAbstract C.TerminationCheckPragma{} = __IMPOSSIBLE__ instance ToAbstract C.Clause A.Clause where - toAbstract (C.Clause top C.Ellipsis{} _ _ _) = fail "bad '...'" -- TODO: errors message + toAbstract (C.Clause top C.Ellipsis{} _ _ _) = genericError "bad '...'" -- TODO: error message toAbstract (C.Clause top lhs@(C.LHS p wps eqs with) rhs wh wcs) = withLocalVars $ do -- Andreas, 2012-02-14: need to reset local vars before checking subclauses vars <- getLocalVars - let wcs' = for wcs $ \ c -> do - setLocalVars vars - return $ expandEllipsis p wps c - lhs' <- toAbstract (LeftHandSide top p wps) + let wcs' = for wcs $ \ c -> setLocalVars vars $> c + lhs' <- toAbstract $ LeftHandSide top p wps printLocals 10 "after lhs:" let (whname, whds) = case wh of NoWhere -> (Nothing, []) @@ -1420,16 +1459,12 @@ return $ A.Clause lhs' rhs ds whereToAbstract :: Range -> Maybe C.Name -> [C.Declaration] -> ScopeM a -> ScopeM (a, [A.Declaration]) -whereToAbstract _ _ [] inner = do - x <- inner - return (x, []) +whereToAbstract _ _ [] inner = (,[]) <$> inner whereToAbstract r whname whds inner = do - m <- maybe (nameConcrete <$> freshNoName noRange) return whname - m <- if (maybe False isNoName whname) - then do - (i :: NameId) <- fresh - return (C.NoName (getRange m) i) - else return m + -- Create a fresh concrete name if there isn't (a proper) one. + m <- case whname of + Just m | not (isNoName m) -> return m + _ -> C.NoName (getRange whname) <$> fresh let acc = maybe PrivateAccess (const PublicAccess) whname -- unnamed where's are private let tel = [] old <- getCurrentModule @@ -1440,23 +1475,25 @@ setCurrentModule old bindModule acc m am -- Issue 848: if the module was anonymous (module _ where) open it public - when (maybe False isNoName whname) $ + let anonymous = maybe False isNoName whname + when anonymous $ openModule_ (C.QName m) $ defaultImportDir { publicOpen = True } return (x, ds) data RightHandSide = RightHandSide - { rhsRewriteEqn :: [C.RewriteEqn] -- ^ @rewrite e@ (many) - , rhsWithExpr :: [C.WithExpr] -- ^ @with e@ (many) + { rhsRewriteEqn :: [C.RewriteEqn] -- ^ @rewrite e@ (many) + , rhsWithExpr :: [C.WithExpr] -- ^ @with e@ (many) , rhsSubclauses :: [ScopeM C.Clause] -- ^ the subclauses spawned by a with (monadic because we need to reset the local vars before checking these clauses) , rhs :: C.RHS , rhsWhereDecls :: [C.Declaration] } -data AbstractRHS = AbsurdRHS' - | WithRHS' [A.Expr] [ScopeM C.Clause] -- ^ The with clauses haven't been translated yet - | RHS' A.Expr - | RewriteRHS' [A.Expr] AbstractRHS [A.Declaration] +data AbstractRHS + = AbsurdRHS' + | WithRHS' [A.Expr] [ScopeM C.Clause] -- ^ The with clauses haven't been translated yet + | RHS' A.Expr + | RewriteRHS' [A.Expr] AbstractRHS [A.Declaration] qualifyName_ :: A.Name -> ScopeM A.QName qualifyName_ x = do @@ -1474,7 +1511,7 @@ toAbstract (RewriteRHS' eqs rhs wh) = do auxs <- replicateM (length eqs) $ withFunctionName "rewrite-" rhs <- toAbstract rhs - return $ RewriteRHS auxs eqs rhs wh + return $ RewriteRHS (zip auxs eqs) rhs wh toAbstract (WithRHS' es cs) = do aux <- withFunctionName "with-" A.WithRHS aux es <$> do toAbstract =<< sequence cs @@ -1539,7 +1576,7 @@ d <- case qx of FieldName d -> return $ anameName d UnknownName -> notInScope d - _ -> typeError $ GenericError $ + _ -> genericError $ "head of copattern needs to be a field identifier, but " ++ show d ++ " isn't one" args1 <- toAbstract ps1 @@ -1547,9 +1584,12 @@ args2 <- toAbstract ps2 return $ A.LHSProj d args1 l args2 +instance ToAbstract c a => ToAbstract (WithHiding c) (WithHiding a) where + toAbstract (WithHiding h a) = WithHiding h <$> toAbstractHiding h a + instance ToAbstract c a => ToAbstract (C.Arg c) (A.Arg a) where toAbstract (Common.Arg info e) = - Common.Arg <$> toAbstract info <*> toAbstractCtx (hiddenArgumentCtx $ getHiding info) e + Common.Arg <$> toAbstract info <*> toAbstractHiding info e instance ToAbstract c a => ToAbstract (Named name c) (Named name a) where toAbstract (Named n e) = Named n <$> toAbstract e @@ -1587,32 +1627,37 @@ toAbstract (A.ImplicitP i) = return $ A.ImplicitP i toAbstract (A.PatternSynP i x as) = A.PatternSynP i x <$> mapM toAbstract as +resolvePatternIdentifier :: + Range -> C.QName -> Maybe (Set A.Name) -> ScopeM (A.Pattern' C.Expr) +resolvePatternIdentifier r x ns = do + px <- toAbstract (PatName x ns) + case px of + VarPatName y -> return $ VarP y + ConPatName ds -> return $ ConP (ConPatInfo False $ PatRange r) + (AmbQ $ map anameName ds) + [] + PatternSynPatName d -> return $ PatternSynP (PatRange r) + (anameName d) [] + instance ToAbstract C.Pattern (A.Pattern' C.Expr) where - toAbstract p@(C.IdentP x) = do - px <- toAbstract (PatName x) - case px of - VarPatName y -> return $ VarP y - ConPatName ds -> return $ ConP (ConPatInfo False $ PatRange (getRange p)) - (AmbQ $ map anameName ds) - [] - PatternSynPatName d -> return $ PatternSynP (PatRange (getRange p)) - (anameName d) [] + toAbstract (C.IdentP x) = + resolvePatternIdentifier (getRange x) x Nothing toAbstract (AppP (QuoteP _) p) | IdentP x <- namedArg p, getHiding p == NotHidden = do - e <- toAbstract (OldQName x) + e <- toAbstract (OldQName x Nothing) let quoted (A.Def x) = return x quoted (A.Proj x) = return x quoted (A.Con (AmbQ [x])) = return x - quoted (A.Con (AmbQ xs)) = typeError $ GenericError $ "quote: Ambigous name: " ++ show xs + quoted (A.Con (AmbQ xs)) = genericError $ "quote: Ambigous name: " ++ show xs quoted (A.ScopedExpr _ e) = quoted e - quoted _ = typeError $ GenericError $ "quote: not a defined name" + quoted _ = genericError $ "quote: not a defined name" A.LitP . LitQName (getRange x) <$> quoted e toAbstract (QuoteP r) = - typeError $ GenericError "quote must be applied to an identifier" + genericError "quote must be applied to an identifier" toAbstract p0@(AppP p q) = do (p', q') <- toAbstract (p,q) @@ -1625,20 +1670,16 @@ r = getRange p0 info = PatSource r $ \pr -> if appBrackets pr then ParenP r p0 else p0 - toAbstract p0@(OpAppP r op ps) = do - p <- toAbstract (IdentP op) + toAbstract p0@(OpAppP r op ns ps) = do + p <- resolvePatternIdentifier (getRange op) op (Just ns) ps <- toAbstract ps case p of - ConP i x as -> return $ ConP (i {patInfo = info}) x - (as ++ ps) - DefP _ x as -> return $ DefP info x - (as ++ ps) - PatternSynP _ x as -> return $ PatternSynP info x - (as ++ ps) + ConP i x as -> return $ ConP (i {patInfo = info}) x (as ++ ps) + DefP _ x as -> return $ DefP info x (as ++ ps) + PatternSynP _ x as -> return $ PatternSynP info x (as ++ ps) _ -> __IMPOSSIBLE__ where - r = getRange p0 - info = PatSource r $ \pr -> if appBrackets pr then ParenP r p0 else p0 + info = PatSource r $ \pr -> if appBrackets pr then ParenP r p0 else p0 -- Removed when parsing toAbstract (HiddenP _ _) = __IMPOSSIBLE__ @@ -1664,11 +1705,11 @@ -- | Turn an operator application into abstract syntax. Make sure to record the -- right precedences for the various arguments. -toAbstractOpApp :: C.QName -> [C.NamedArg (OpApp C.Expr)] -> ScopeM A.Expr -toAbstractOpApp op es = do +toAbstractOpApp :: C.QName -> Set A.Name -> [C.NamedArg (OpApp C.Expr)] -> ScopeM A.Expr +toAbstractOpApp op ns es = do -- Get the notation for the operator. - f <- getFixity op - let parts = notation . oldToNewNotation $ (op, f) + nota <- getNotation op ns + let parts = notation nota -- We can throw away the @BindingHoles@, since binders -- have been preprocessed into @OpApp C.Expr@. let nonBindingParts = filter (not . isBindingHole) parts @@ -1676,8 +1717,8 @@ -- If not, crash. unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__ -- Translate operator and its arguments (each in the right context). - op <- toAbstract (OldQName op) - foldl' app op <$> left (theFixity f) nonBindingParts es + op <- toAbstract (OldQName op (Just ns)) + foldl' app op <$> left (notaFixity nota) nonBindingParts es where -- Build an application in the abstract syntax, with correct Range. app e arg = A.App (ExprRange (fuseRange e arg)) e (setArgColors [] arg) diff --git a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs --- a/src/full/Agda/Syntax/Translation/InternalToAbstract.hs +++ b/src/full/Agda/Syntax/Translation/InternalToAbstract.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} {-| Translating from internal syntax to abstract syntax. Enables nice @@ -51,6 +50,7 @@ import qualified Agda.Utils.VarSet as VSet import Agda.TypeChecking.Monad as M hiding (MetaInfo) +import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Reduce import {-# SOURCE #-} Agda.TypeChecking.Records import Agda.TypeChecking.CompiledClause (CompiledClauses(Fail)) @@ -99,6 +99,22 @@ reifyIArgs' :: [I.Arg e] -> TCM [A.Arg e] reifyIArgs' = mapM reifyIArg' +-- Composition of reified eliminations ------------------------------------ + +elims :: Expr -> [I.Elim' Expr] -> TCM Expr +elims e [] = return e +elims e (I.Apply arg : es) = do + arg <- reifyIArg' arg + elims (A.App exprInfo e $ fmap unnamed arg) es +elims e (I.Proj d : es) = elims (A.App exprInfo (A.Proj d) $ defaultNamedArg e) es + +reifyIElim :: Reify i a => I.Elim' i -> TCM (I.Elim' a) +reifyIElim (I.Apply i) = I.Apply <$> traverse reify i +reifyIElim (I.Proj d) = return $ I.Proj d + +reifyIElims :: Reify i a => [I.Elim' i] -> TCM [I.Elim' a] +reifyIElims = mapM reifyIElim + -- Omitting information --------------------------------------------------- exprInfo :: ExprInfo @@ -146,13 +162,18 @@ caseMaybeM (isInteractionMeta x) underscore $ \ ii@InteractionId{} -> return $ A.QuestionMark (mi' {metaNumber = Just n}) ii +-- Does not print with-applications correctly: +-- instance Reify DisplayTerm Expr where +-- reifyWhen = reifyWhenE +-- reify d = reifyTerm False $ dtermToTerm d + instance Reify DisplayTerm Expr where reifyWhen = reifyWhenE reify d = case d of DTerm v -> reifyTerm False v DDot v -> reify v DCon c vs -> apps (A.Con (AmbQ [conName c])) =<< reifyIArgs vs - DDef f vs -> apps (A.Def f) =<< reifyIArgs vs + DDef f es -> elims (A.Def f) =<< reifyIElims es DWithApp u us vs -> do (e, es) <- reify (u, us) reifyApp (if null es then e else A.WithApp exprInfo e es) vs @@ -164,7 +185,7 @@ reifyDisplayForm :: QName -> I.Args -> TCM A.Expr -> TCM A.Expr reifyDisplayForm f vs fallback = do ifNotM displayFormsEnabled fallback $ {- else -} do - caseMaybeM (liftTCM $ displayForm f vs) fallback reify + caseMaybeM (liftTCM $ displayForm f vs) fallback reify -- | @reifyDisplayFormP@ tries to recursively -- rewrite a lhs with a display form. @@ -197,10 +218,12 @@ reifyDisplayFormP =<< displayLHS (map namedArg ps) wps d _ -> return lhs where + -- Andreas, 2015-05-03: Ulf, please comment on what + -- is the idea behind okDisplayForm. okDisplayForm (DWithApp d ds []) = okDisplayForm d && all okDisplayTerm ds okDisplayForm (DTerm (I.Def f vs)) = all okElim vs - okDisplayForm (DDef f vs) = all okDArg vs + okDisplayForm (DDef f es) = all okDElim es okDisplayForm DDot{} = False okDisplayForm DCon{} = False okDisplayForm DTerm{} = True -- False? @@ -212,7 +235,8 @@ okDisplayTerm DDef{} = False okDisplayTerm _ = False - okDArg = okDisplayTerm . unArg + okDElim (I.Apply v) = okDisplayTerm $ unArg v + okDElim I.Proj{} = True -- True, man, or False? No clue what I am implementing here --Andreas, 2015-05-03 okArg = okTerm . unArg okElim (I.Apply a) = okArg a @@ -223,27 +247,27 @@ okTerm (I.Def x []) = isNoName $ qnameToConcrete x -- Handling wildcards in display forms okTerm _ = True -- False - -- Flatten a dt into (parentName, parentArgs, withArgs). - flattenWith :: DisplayTerm -> (QName, [I.Arg DisplayTerm], [DisplayTerm]) + -- Flatten a dt into (parentName, parentElims, withArgs). + flattenWith :: DisplayTerm -> (QName, [I.Elim' DisplayTerm], [DisplayTerm]) flattenWith (DWithApp d ds1 ds2) = case flattenWith d of - (f, vs, ds0) -> (f, vs, ds0 ++ ds1 ++ map (DTerm . unArg) ds2) - flattenWith (DDef f vs) = (f, vs, []) -- .^ hacky, but we should only hit this when printing debug info - flattenWith (DTerm (I.Def f es)) = - let vs = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es - in (f, map (fmap DTerm) vs, []) + (f, es, ds0) -> (f, es, ds0 ++ ds1 ++ map (DTerm . unArg) ds2) + flattenWith (DDef f es) = (f, es, []) -- .^ hacky, but we should only hit this when printing debug info + flattenWith (DTerm (I.Def f es)) = (f, map (fmap DTerm) es, []) flattenWith _ = __IMPOSSIBLE__ displayLHS :: [A.Pattern] -> [A.Pattern] -> DisplayTerm -> TCM A.SpineLHS displayLHS ps wps d = case flattenWith d of (f, vs, ds) -> do ds <- mapM termToPat ds - vs <- mapM argToPat vs + vs <- mapM elimToPat vs vs <- reifyIArgs' vs return $ SpineLHS i f vs (ds ++ wps) --- return $ LHS i (LHSHead f vs) (ds ++ wps) where ci = ConPatInfo False patNoRange + argToPat arg = fmap unnamed <$> traverse termToPat arg + elimToPat (I.Apply arg) = argToPat arg + elimToPat (I.Proj d) = return $ defaultNamedArg $ A.DefP patNoRange d [] termToPat :: DisplayTerm -> TCM A.Pattern @@ -302,42 +326,41 @@ reifyTerm :: Bool -> Term -> TCM Expr reifyTerm expandAnonDefs0 v = do - hasDisplayForms <- displayFormsEnabled - -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled - -- (i.e. when we don't care about nice printing) - let expandAnonDefs = expandAnonDefs0 && hasDisplayForms - v <- unSpine <$> instantiate v - case v of - _ | isHackReifyToMeta v -> return $ A.Underscore emptyMetaInfo - I.Var n es -> do - let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - x <- liftTCM $ nameOfBV n `catchError` \_ -> freshName_ ("@" ++ show n) - reifyApp (A.Var x) vs - I.Def x es -> do + -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled + -- (i.e. when we don't care about nice printing) + expandAnonDefs <- return expandAnonDefs0 `and2M` displayFormsEnabled + v <- unSpine <$> instantiate v + case v of + _ | isHackReifyToMeta v -> return $ A.Underscore emptyMetaInfo + I.Var n es -> do let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - reifyDisplayForm x vs $ reifyDef expandAnonDefs x vs - I.Con c vs -> do - let x = conName c - isR <- isGeneratedRecordConstructor x - case isR of - True -> do - showImp <- showImplicitArguments - let keep (a, v) = showImp || notHidden a - r <- getConstructorData x - xs <- getRecordFieldNames r - vs <- map unArg <$> reifyIArgs vs - return $ A.Rec exprInfo $ map (unArg *** id) $ filter keep $ zip xs vs - False -> reifyDisplayForm x vs $ do - ci <- getConstInfo x - let Constructor{conPars = np} = theDef ci - -- if we are the the module that defines constructor x - -- then we have to drop at least the n module parameters - n <- getDefFreeVars x - -- the number of parameters is greater (if the data decl has - -- extra parameters) or equal (if not) to n - when (n > np) __IMPOSSIBLE__ - let h = A.Con (AmbQ [x]) - if null vs then return h else do + x <- liftTCM $ nameOfBV n `catchError` \_ -> freshName_ ("@" ++ show n) + reifyApp (A.Var x) vs + I.Def x es -> do + let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es + reifyDisplayForm x vs $ reifyDef expandAnonDefs x vs + I.Con c vs -> do + let x = conName c + isR <- isGeneratedRecordConstructor x + case isR of + True -> do + showImp <- showImplicitArguments + let keep (a, v) = showImp || notHidden a + r <- getConstructorData x + xs <- getRecordFieldNames r + vs <- map unArg <$> reifyIArgs vs + return $ A.Rec exprInfo $ map (unArg *** id) $ filter keep $ zip xs vs + False -> reifyDisplayForm x vs $ do + ci <- getConstInfo x + let Constructor{conPars = np} = theDef ci + -- if we are the the module that defines constructor x + -- then we have to drop at least the n module parameters + n <- getDefFreeVars x + -- the number of parameters is greater (if the data decl has + -- extra parameters) or equal (if not) to n + when (n > np) __IMPOSSIBLE__ + let h = A.Con (AmbQ [x]) + if null vs then return h else do es <- reifyIArgs vs -- Andreas, 2012-04-20: do not reify parameter arguments of constructor -- if the first regular constructor argument is hidden @@ -379,86 +402,86 @@ ] napps h $ genericDrop (n - np) $ nameFirstIfHidden doms es -} --- I.Lam info b | isAbsurdBody b -> return $ A.AbsurdLam exprInfo $ getHiding info - I.Lam info b -> do - (x,e) <- reify b - info <- reify info - return $ A.Lam exprInfo (DomainFree info x) e - -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda - I.Lit l -> reify l - I.Level l -> reify l - I.Pi a b -> case b of - NoAbs _ b' - | notHidden a -> uncurry (A.Fun $ exprInfo) <$> reify (a, b') - -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi - -- since (a) the syntax {A} -> B or {{A}} -> B is not legal - -- and (b) the name of the binder might matter. - -- See issue 951 (a) and 952 (b). - | otherwise -> mkPi b =<< reify a - b -> mkPi b =<< do - ifM (domainFree a (absBody b)) - {- then -} (Common.Arg <$> reify (domInfo a) <*> pure underscore) - {- else -} (reify a) - where - mkPi b (Common.Arg info a) = do - (x, b) <- reify b - return $ A.Pi exprInfo [TypedBindings noRange $ Common.Arg info (TBind noRange [x] a)] b - -- We can omit the domain type if it doesn't have any free variables - -- and it's mentioned in the target type. - domainFree a b = do - df <- asks envPrintDomainFreePi - return $ and [df, freeIn 0 b, VSet.null $ allVars $ freeVars a] +-- I.Lam info b | isAbsurdBody b -> return $ A.AbsurdLam exprInfo $ getHiding info + I.Lam info b -> do + (x,e) <- reify b + info <- reify info + return $ A.Lam exprInfo (DomainFree info x) e + -- Andreas, 2011-04-07 we do not need relevance information at internal Lambda + I.Lit l -> reify l + I.Level l -> reify l + I.Pi a b -> case b of + NoAbs _ b' + | notHidden a -> uncurry (A.Fun $ exprInfo) <$> reify (a, b') + -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi + -- since (a) the syntax {A} -> B or {{A}} -> B is not legal + -- and (b) the name of the binder might matter. + -- See issue 951 (a) and 952 (b). + | otherwise -> mkPi b =<< reify a + b -> mkPi b =<< do + ifM (domainFree a (absBody b)) + {- then -} (Common.Arg <$> reify (domInfo a) <*> pure underscore) + {- else -} (reify a) + where + mkPi b (Common.Arg info a) = do + (x, b) <- reify b + return $ A.Pi exprInfo [TypedBindings noRange $ Common.Arg info (TBind noRange [pure x] a)] b + -- We can omit the domain type if it doesn't have any free variables + -- and it's mentioned in the target type. + domainFree a b = do + df <- asks envPrintDomainFreePi + return $ and [df, freeIn 0 b, VSet.null $ allVars $ freeVars a] - I.Sort s -> reify s - I.MetaV x es -> do - let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - x' <- reify x - apps x' =<< reifyIArgs vs - I.DontCare v -> A.DontCare <$> reifyTerm expandAnonDefs v - I.Shared p -> reifyTerm expandAnonDefs $ derefPtr p - I.ExtLam cls args -> do - x <- freshName_ "extlam" - reifyExtLam (qnameFromList [x]) 0 cls (map (fmap unnamed) args) - where - -- Andreas, 2012-10-20 expand a copy in an anonymous module - -- to improve error messages. - -- Don't do this if we have just expanded into a display form, - -- otherwise we loop! - reifyDef :: Bool -> QName -> I.Args -> TCM Expr - reifyDef True x@(QName m name) vs | A.isAnonymousModuleName m = do - r <- reduceDefCopy x vs - case r of - YesReduction _ v -> do - reportSLn "reify.anon" 60 $ unlines - [ "reduction on defined ident. in anonymous module" - , "x = " ++ show x - , "v = " ++ show v - ] - reify v - NoReduction () -> do - reportSLn "reify.anon" 60 $ unlines - [ "no reduction on defined ident. in anonymous module" - , "x = " ++ show x - , "vs = " ++ show vs - ] - reifyDef' x vs - reifyDef _ x vs = reifyDef' x vs + I.Sort s -> reify s + I.MetaV x es -> do + let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es + x' <- reify x + apps x' =<< reifyIArgs vs + I.DontCare v -> A.DontCare <$> reifyTerm expandAnonDefs v + I.Shared p -> reifyTerm expandAnonDefs $ derefPtr p + I.ExtLam cls args -> do + x <- freshName_ "extlam" + reifyExtLam (qnameFromList [x]) 0 cls (map (fmap unnamed) args) + where + -- Andreas, 2012-10-20 expand a copy in an anonymous module + -- to improve error messages. + -- Don't do this if we have just expanded into a display form, + -- otherwise we loop! + reifyDef :: Bool -> QName -> I.Args -> TCM Expr + reifyDef True x@(QName m name) vs | A.isAnonymousModuleName m = do + r <- reduceDefCopy x vs + case r of + YesReduction _ v -> do + reportSLn "reify.anon" 60 $ unlines + [ "reduction on defined ident. in anonymous module" + , "x = " ++ show x + , "v = " ++ show v + ] + reify v + NoReduction () -> do + reportSLn "reify.anon" 60 $ unlines + [ "no reduction on defined ident. in anonymous module" + , "x = " ++ show x + , "vs = " ++ show vs + ] + reifyDef' x vs + reifyDef _ x vs = reifyDef' x vs - reifyDef' :: QName -> I.Args -> TCM Expr - reifyDef' x@(QName _ name) vs = do - -- We should drop this many arguments from the local context. - n <- getDefFreeVars x - mdefn <- liftTCM $ (Just <$> getConstInfo x) `catchError` \_ -> return Nothing - -- check if we have an absurd lambda - let reifyAbsurdLambda cont = - case theDef <$> mdefn of - Just Function{ funCompiled = Just Fail, funClauses = [cl] } - | isAbsurdLambdaName x -> do - -- get hiding info from last pattern, which should be () - let h = getHiding $ last (clausePats cl) - apps (A.AbsurdLam exprInfo h) =<< reifyIArgs vs - _ -> cont - reifyAbsurdLambda $ do + reifyDef' :: QName -> I.Args -> TCM Expr + reifyDef' x@(QName _ name) vs = do + -- We should drop this many arguments from the local context. + n <- getDefFreeVars x + mdefn <- liftTCM $ (Just <$> getConstInfo x) `catchError` \_ -> return Nothing + -- check if we have an absurd lambda + let reifyAbsurdLambda cont = + case theDef <$> mdefn of + Just Function{ funCompiled = Just Fail, funClauses = [cl] } + | isAbsurdLambdaName x -> do + -- get hiding info from last pattern, which should be () + let h = getHiding $ last (clausePats cl) + apps (A.AbsurdLam exprInfo h) =<< reifyIArgs vs + _ -> cont + reifyAbsurdLambda $ do (pad, vs :: [I.NamedArg Term]) <- do case mdefn of Nothing -> return ([], map (fmap unnamed) $ genericDrop n vs) @@ -475,7 +498,7 @@ -- These are the dropped projection arguments (np, pad, dom) <- case def of - Function{ funProjection = Just Projection{ projIndex = np } } -> do + Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do TelV tel _ <- telView (defType defn) scope <- getScope let (as, dom:_) = splitAt (np - 1) $ telToList tel @@ -507,14 +530,14 @@ let apps = foldl' (\e a -> A.App exprInfo e (fmap unnamed a)) napps (A.Def x `apps` pad) =<< reifyIArgs vs - reifyExtLam :: QName -> Int -> [I.Clause] -> [I.NamedArg Term] -> TCM Expr - reifyExtLam x n cls vs = do - reportSLn "reify.def" 10 $ "reifying extended lambda with definition: x = " ++ show x - -- drop lambda lifted arguments - cls <- mapM (reify . QNamed x . dropArgs n) $ cls - let cx = nameConcrete $ qnameName x - dInfo = mkDefInfo cx defaultFixity' PublicAccess ConcreteDef (getRange x) - napps (A.ExtendedLam exprInfo dInfo x cls) =<< reifyIArgs vs + reifyExtLam :: QName -> Int -> [I.Clause] -> [I.NamedArg Term] -> TCM Expr + reifyExtLam x n cls vs = do + reportSLn "reify.def" 10 $ "reifying extended lambda with definition: x = " ++ show x + -- drop lambda lifted arguments + cls <- mapM (reify . QNamed x . dropArgs n) $ cls + let cx = nameConcrete $ qnameName x + dInfo = mkDefInfo cx defaultFixity' PublicAccess ConcreteDef (getRange x) + napps (A.ExtendedLam exprInfo dInfo x cls) =<< reifyIArgs vs -- | @nameFirstIfHidden n (a1->...an->{x:a}->b) ({e} es) = {x = e} es@ nameFirstIfHidden :: [I.Dom (ArgName, t)] -> [I.Arg a] -> [I.NamedArg a] @@ -647,95 +670,95 @@ TCM ([A.NamedArg A.Pattern], [A.Pattern]) stripImplicits (ps, wps) = do -- v if show-implicit we don't need the names ifM showImplicitArguments (return (map (unnamed . namedThing <$>) ps, wps)) $ do - let vars = dotVars (ps, wps) - reportSLn "reify.implicit" 30 $ unlines - [ "stripping implicits" - , " ps = " ++ show ps - , " wps = " ++ show wps - , " vars = " ++ show vars - ] - let allps = ps ++ map defaultNamedArg wps - sps = blankDots $ foldl (.) (strip Set.empty) (map rearrangeBinding $ Set.toList vars) $ allps - (ps', wps') = splitAt (length sps - length wps) sps - reportSLn "reify.implicit" 30 $ unlines - [ " ps' = " ++ show ps' - , " wps' = " ++ show (map namedArg wps') - ] - return (ps', map namedArg wps') - where - argsVars = Set.unions . map argVars - argVars = patVars . namedArg - patVars p = case p of - A.VarP x -> Set.singleton x - A.ConP _ _ ps -> argsVars ps - A.DefP _ _ ps -> Set.empty - A.DotP _ e -> Set.empty - A.WildP _ -> Set.empty - A.AbsurdP _ -> Set.empty - A.LitP _ -> Set.empty - A.ImplicitP _ -> Set.empty - A.AsP _ _ p -> patVars p - A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- Set.empty + let vars = dotVars (ps, wps) + reportSLn "reify.implicit" 30 $ unlines + [ "stripping implicits" + , " ps = " ++ show ps + , " wps = " ++ show wps + , " vars = " ++ show vars + ] + let allps = ps ++ map defaultNamedArg wps + sps = blankDots $ foldl (.) (strip Set.empty) (map rearrangeBinding $ Set.toList vars) $ allps + (ps', wps') = splitAt (length sps - length wps) sps + reportSLn "reify.implicit" 30 $ unlines + [ " ps' = " ++ show ps' + , " wps' = " ++ show (map namedArg wps') + ] + return (ps', map namedArg wps') + where + argsVars = Set.unions . map argVars + argVars = patVars . namedArg + patVars p = case p of + A.VarP x -> Set.singleton x + A.ConP _ _ ps -> argsVars ps + A.DefP _ _ ps -> Set.empty + A.DotP _ e -> Set.empty + A.WildP _ -> Set.empty + A.AbsurdP _ -> Set.empty + A.LitP _ -> Set.empty + A.ImplicitP _ -> Set.empty + A.AsP _ _ p -> patVars p + A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- Set.empty - -- Replace dot variables by ._ if they use implicitly bound variables. This - -- is slightly nicer than making the implicts explicit. - blankDots ps = (map . fmap . fmap . fmap) blank ps - where - bound = argsVars ps - blank e | Set.null (Set.difference (dotVars e) bound) = e - | otherwise = A.Underscore emptyMetaInfo + -- Replace dot variables by ._ if they use implicitly bound variables. This + -- is slightly nicer than making the implicts explicit. + blankDots ps = (map . fmap . fmap . fmap) blank ps + where + bound = argsVars ps + blank e | Set.null (Set.difference (dotVars e) bound) = e + | otherwise = A.Underscore emptyMetaInfo - -- Pick the "best" place to bind the variable. Best in this case - -- is the left-most explicit binding site. But, of course we can't - -- do this since binding site might be forced by a parent clause. - -- Why? Because the binding site we pick might not exist in the - -- generated with function if it corresponds to a dot pattern. - rearrangeBinding x ps = ps + -- Pick the "best" place to bind the variable. Best in this case + -- is the left-most explicit binding site. But, of course we can't + -- do this since binding site might be forced by a parent clause. + -- Why? Because the binding site we pick might not exist in the + -- generated with function if it corresponds to a dot pattern. + rearrangeBinding x ps = ps - strip dvs ps = stripArgs True ps - where - stripArgs _ [] = [] - stripArgs fixedPos (a : as) = - case getHiding a of - Hidden | canStrip a as -> stripArgs False as - Instance | canStrip a as -> stripArgs False as - _ -> stripName fixedPos (stripArg a) : - stripArgs True as + strip dvs ps = stripArgs True ps + where + stripArgs _ [] = [] + stripArgs fixedPos (a : as) = + case getHiding a of + Hidden | canStrip a as -> stripArgs False as + Instance | canStrip a as -> stripArgs False as + _ -> stripName fixedPos (stripArg a) : + stripArgs True as - stripName True = fmap (unnamed . namedThing) - stripName False = id + stripName True = fmap (unnamed . namedThing) + stripName False = id - canStrip a as = and - [ varOrDot p - , noInterestingBindings p - , all (flip canStrip []) $ takeWhile isUnnamedHidden as - ] - where p = namedArg a + canStrip a as = and + [ varOrDot p + , noInterestingBindings p + , all (flip canStrip []) $ takeWhile isUnnamedHidden as + ] + where p = namedArg a - isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing + isUnnamedHidden x = notVisible x && nameOf (unArg x) == Nothing - stripArg a = fmap (fmap stripPat) a + stripArg a = fmap (fmap stripPat) a - stripPat p = case p of - A.VarP _ -> p - A.ConP i c ps -> A.ConP i c $ stripArgs True ps - A.DefP _ _ _ -> p - A.DotP _ e -> p - A.WildP _ -> p - A.AbsurdP _ -> p - A.LitP _ -> p - A.ImplicitP _ -> p - A.AsP i x p -> A.AsP i x $ stripPat p - A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p + stripPat p = case p of + A.VarP _ -> p + A.ConP i c ps -> A.ConP i c $ stripArgs True ps + A.DefP _ _ _ -> p + A.DotP _ e -> p + A.WildP _ -> p + A.AbsurdP _ -> p + A.LitP _ -> p + A.ImplicitP _ -> p + A.AsP i x p -> A.AsP i x $ stripPat p + A.PatternSynP _ _ _ -> __IMPOSSIBLE__ -- p - noInterestingBindings p = - Set.null $ dvs `Set.intersection` patVars p + noInterestingBindings p = + Set.null $ dvs `Set.intersection` patVars p - varOrDot A.VarP{} = True - varOrDot A.WildP{} = True - varOrDot A.DotP{} = True - varOrDot A.ImplicitP{} = True - varOrDot _ = False + varOrDot A.VarP{} = True + varOrDot A.WildP{} = True + varOrDot A.DotP{} = True + varOrDot A.ImplicitP{} = True + varOrDot _ = False -- | @dotVars ps@ gives all the variables inside of dot patterns of @ps@ -- It is only invoked for patternish things. (Ulf O-tone!) @@ -820,7 +843,7 @@ dotVars (RHS e) = dotVars e dotVars AbsurdRHS = Set.empty dotVars (WithRHS _ es clauses) = __IMPOSSIBLE__ -- NZ - dotVars (RewriteRHS _ es rhs _) = __IMPOSSIBLE__ -- NZ + dotVars (RewriteRHS xes rhs _) = __IMPOSSIBLE__ -- NZ instance DotVars TypedBindings where dotVars (TypedBindings _ bs) = dotVars bs @@ -858,14 +881,14 @@ lift $ A.VarP <$> nameOfBV (size tel - 1 - j) I.DotP v -> do t <- lift $ reify v - tick + _ <- tick let vars = Set.map show (dotVars t) t' = if Set.member "()" vars then underscore else t return $ A.DotP patNoRange t' I.LitP l -> return $ A.LitP l I.ProjP d -> return $ A.DefP patNoRange d [] - I.ConP c mt ps -> A.ConP ci (AmbQ [conName c]) <$> reifyArgs ps - where ci = flip ConPatInfo patNoRange $ maybe False fst mt + I.ConP c cpi ps -> A.ConP ci (AmbQ [conName c]) <$> reifyArgs ps + where ci = flip ConPatInfo patNoRange $ fromMaybe False $ I.conPRecord cpi instance Reify NamedClause A.Clause where reify (QNamed f (I.Clause _ tel perm ps body _)) = addCtxTel tel $ do @@ -893,21 +916,24 @@ instance Reify Sort Expr where reifyWhen = reifyWhenE - reify s = - do s <- instantiateFull s - case s of - I.Type (I.Max []) -> return $ A.Set exprInfo 0 - I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set exprInfo n - I.Type a -> do - a <- reify a - return $ A.App exprInfo (A.Set exprInfo 0) (defaultNamedArg a) - I.Prop -> return $ A.Prop exprInfo - I.Inf -> A.Var <$> freshName_ ("Setω" :: String) - I.DLub s1 s2 -> do - lub <- freshName_ ("dLub" :: String) -- TODO: hack - (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2) - let app x y = A.App exprInfo x (defaultNamedArg y) - return $ A.Var lub `app` e1 `app` e2 + reify s = do + s <- instantiateFull s + case s of + I.Type (I.Max []) -> return $ A.Set exprInfo 0 + I.Type (I.Max [I.ClosedLevel n]) -> return $ A.Set exprInfo n + I.Type a -> do + a <- reify a + return $ A.App exprInfo (A.Set exprInfo 0) (defaultNamedArg a) + I.Prop -> return $ A.Prop exprInfo + I.Inf -> A.Var <$> freshName_ ("Setω" :: String) + I.SizeUniv -> do + I.Def sizeU [] <- primSizeUniv + return $ A.Def sizeU + I.DLub s1 s2 -> do + lub <- freshName_ ("dLub" :: String) -- TODO: hack + (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2) + let app x y = A.App exprInfo x (defaultNamedArg y) + return $ A.Var lub `app` e1 `app` e2 instance Reify Level Expr where reifyWhen = reifyWhenE @@ -932,7 +958,7 @@ Common.Arg info e <- reify arg (x,bs) <- reify tel let r = getRange e - return $ TypedBindings r (Common.Arg info (TBind r [x] e)) : bs + return $ TypedBindings r (Common.Arg info (TBind r [pure x] e)) : bs instance Reify I.ArgInfo A.ArgInfo where reify i = flip (mapArgInfoColors.const) i <$> reify (argInfoColors i) @@ -951,8 +977,3 @@ instance (Reify i1 a1, Reify i2 a2, Reify i3 a3, Reify i4 a4) => Reify (i1,i2,i3,i4) (a1,a2,a3,a4) where reify (x,y,z,w) = (,,,) <$> reify x <*> reify y <*> reify z <*> reify w - -instance (Reify t t', Reify a a') - => Reify (Judgement t a) (Judgement t' a') where - reify (HasType i t) = HasType <$> reify i <*> reify t - reify (IsSort i t) = IsSort <$> reify i <*> reify t diff --git a/src/full/Agda/Termination/CallGraph.hs b/src/full/Agda/Termination/CallGraph.hs --- a/src/full/Agda/Termination/CallGraph.hs +++ b/src/full/Agda/Termination/CallGraph.hs @@ -1,11 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} -- | Call graphs and related concepts, more or less as defined in -- \"A Predicative Analysis of Structural Recursion\" by @@ -23,8 +22,6 @@ , targetNodes , fromList , toList - , empty - , null , union , insert , complete, completionStep @@ -65,10 +62,11 @@ import Agda.Utils.Map import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.PartialOrd -import Agda.Utils.Pretty hiding (empty) -import qualified Agda.Utils.Pretty as P +import Agda.Utils.Pretty import Agda.Utils.QuickCheck hiding (label) +import Agda.Utils.Singleton import Agda.Utils.TestHelpers import Agda.Utils.Tuple @@ -96,7 +94,7 @@ -- | Make a call with a single matrix. mkCall :: Node -> Node -> CallMatrix -> cinfo -> Call cinfo -mkCall s t m cinfo = Edge s t $ CMSet.singleton $ CallMatrixAug m cinfo +mkCall s t m cinfo = Edge s t $ singleton $ CallMatrixAug m cinfo -- | Make a call with empty @cinfo@. mkCall' :: Monoid cinfo => Node -> Node -> CallMatrix -> Call cinfo @@ -145,15 +143,10 @@ fromList :: Monoid cinfo => [Call cinfo] -> CallGraph cinfo fromList = CallGraph . Graph.fromListWith CMSet.union --- | Creates an empty call graph. - -empty :: CallGraph cinfo -empty = CallGraph Graph.empty - --- | Check whether the call graph is completely disconnected. - -null :: CallGraph cinfo -> Bool -null = List.all (CMSet.null . label) . toList +-- | 'null' checks whether the call graph is completely disconnected. +instance Null (CallGraph cinfo) where + empty = CallGraph Graph.empty + null = List.all (null . label) . toList -- | Takes the union of two call graphs. @@ -202,7 +195,7 @@ -- -- | otherwise = __IMPOSSIBLE__ -- Filter unlabelled edges from the resulting new graph. - -- filt = Graph.filterEdges (not . CMSet.null) + -- filt = Graph.filterEdges (not . null) -- | Call graph combination. -- @@ -263,7 +256,7 @@ instance Pretty cinfo => Pretty (CallGraph cinfo) where pretty = vcat . map prettyCall . toList where - prettyCall e = if CMSet.null (callMatrixSet e) then P.empty else align 20 $ + prettyCall e = if null (callMatrixSet e) then empty else align 20 $ [ ("Source:", text $ show $ source e) , ("Target:", text $ show $ target e) , ("Matrix:", pretty $ callMatrixSet e) diff --git a/src/full/Agda/Termination/CallMatrix.hs b/src/full/Agda/Termination/CallMatrix.hs --- a/src/full/Agda/Termination/CallMatrix.hs +++ b/src/full/Agda/Termination/CallMatrix.hs @@ -1,13 +1,12 @@ --- {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +-- {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} module Agda.Termination.CallMatrix where @@ -34,9 +33,11 @@ import Agda.Utils.Favorites (Favorites) import qualified Agda.Utils.Favorites as Fav import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.PartialOrd hiding (tests) import Agda.Utils.Pretty hiding ((<>)) import Agda.Utils.QuickCheck +import Agda.Utils.Singleton import Agda.Utils.TestHelpers ------------------------------------------------------------------------ @@ -181,30 +182,17 @@ -- * Sets of incomparable call matrices augmented with path information. ------------------------------------------------------------------------ +-- | Sets of incomparable call matrices augmented with path information. +-- Use overloaded 'null', 'empty', 'singleton', 'mappend'. newtype CMSet cinfo = CMSet { cmSet :: Favorites (CallMatrixAug cinfo) } - deriving (Show, Arbitrary, CoArbitrary, Monoid) + deriving ( Show, Arbitrary, CoArbitrary + , Monoid, Null, Singleton (CallMatrixAug cinfo) ) -- | Call matrix set product is the Cartesian product. instance Monoid cinfo => CallComb (CMSet cinfo) where CMSet as >*< CMSet bs = CMSet $ Fav.fromList $ [ a >*< b | a <- Fav.toList as, b <- Fav.toList bs ] - --- | An empty call matrix set. - -empty :: CMSet cinfo -empty = mempty --- empty = CMSet $ Fav.empty - --- | Call matrix is empty? - -null :: CMSet cinfo -> Bool -null (CMSet as) = Fav.null as - --- | A singleton call matrix set. - -singleton :: CallMatrixAug cinfo -> CMSet cinfo -singleton = CMSet . Fav.singleton -- | Insert into a call matrix set. diff --git a/src/full/Agda/Termination/CutOff.hs b/src/full/Agda/Termination/CutOff.hs --- a/src/full/Agda/Termination/CutOff.hs +++ b/src/full/Agda/Termination/CutOff.hs @@ -1,6 +1,6 @@ --- | Defines 'CutOff' type which is used in 'Agda.Interaction.Options'. +-- | Defines 'CutOff' type which is used in "Agda.Interaction.Options". -- This module's purpose is to eliminate the dependency of --- 'Agda.TypeChecking.Monad.Base' on the termination checker and +-- "Agda.TypeChecking.Monad.Base" on the termination checker and -- everything it imports. module Agda.Termination.CutOff where diff --git a/src/full/Agda/Termination/Inlining.hs b/src/full/Agda/Termination/Inlining.hs --- a/src/full/Agda/Termination/Inlining.hs +++ b/src/full/Agda/Termination/Inlining.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + -- Author: Ulf Norell -- Created: 2013-11-09 @@ -54,7 +58,7 @@ import Data.Traversable (traverse) import Data.List as List -import Agda.Syntax.Common hiding (NamedArg) +import Agda.Syntax.Common as Common hiding (NamedArg) import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern import Agda.TypeChecking.Monad @@ -187,12 +191,11 @@ where n' = n - 1 dispToPats :: DisplayTerm -> TCM ([NamedArg Pattern], Permutation) - dispToPats (DWithApp (DDef _ vs) ws zs) = do - let us = vs ++ map defaultArg ws ++ map (fmap DTerm) zs - (ps, (j, ren)) <- (`runStateT` (0, [])) $ - map (fmap unnamed) <$> mapM (traverse dtermToPat) us + dispToPats (DWithApp (DDef _ es) ws zs) = do + let es' = es ++ map Apply (map defaultArg ws ++ map (fmap DTerm) zs) + (ps, (j, ren)) <- (`runStateT` (0, [])) $ mapM (traverse dtermToPat) es' let perm = Perm j (map snd $ List.sort ren) - return (ps, perm) + return (map ePatToPat ps, perm) dispToPats t = __IMPOSSIBLE__ bindVar i = do @@ -204,17 +207,26 @@ skip = modify $ \(j, is) -> (j + 1, is) + ePatToPat :: Elim' Pattern -> NamedArg Pattern + ePatToPat (Apply p) = fmap unnamed p + ePatToPat (Proj d) = defaultNamedArg $ ProjP d + + dtermToPat :: DisplayTerm -> StateT (Int, [(Int, Int)]) TCM Pattern dtermToPat v = case v of DWithApp{} -> __IMPOSSIBLE__ -- I believe - DCon c vs -> ConP c Nothing . map (fmap unnamed) + DCon c vs -> ConP c noConPatternInfo . map (fmap unnamed) <$> mapM (traverse dtermToPat) vs - DDef{} -> DotP (dtermToTerm v) <$ skip + DDef d es -> do + ifM (return (null es) `and2M` do isJust <$> lift (isProjection d)) + {-then-} (return $ ProjP d) + {-else-} (DotP (dtermToTerm v) <$ skip) DDot v -> DotP v <$ skip DTerm (Var i []) -> ifM (bindVar i) (VarP . nameToPatVarName <$> lift (nameOfBV i)) (pure $ DotP (Var i [])) - DTerm (Con c vs) -> ConP c Nothing . map (fmap unnamed) <$> mapM (traverse (dtermToPat . DTerm)) vs + DTerm (Con c vs) -> ConP c noConPatternInfo . map (fmap unnamed) <$> + mapM (traverse (dtermToPat . DTerm)) vs DTerm v -> DotP v <$ skip isWithFunction :: MonadTCM tcm => QName -> tcm (Maybe QName) @@ -230,11 +242,3 @@ return $ dtermToTerm disp `applyE` es' where (vs, es') = splitApplyElims es - -dtermToTerm :: DisplayTerm -> Term -dtermToTerm (DWithApp d ds vs) = dtermToTerm d `apply` (map (defaultArg . dtermToTerm) ds ++ vs) -dtermToTerm (DCon c args) = Con c $ map (fmap dtermToTerm) args -dtermToTerm (DDef f args) = Def f $ map (Apply . fmap dtermToTerm) args -dtermToTerm (DDot v) = v -dtermToTerm (DTerm v) = v - diff --git a/src/full/Agda/Termination/Monad.hs b/src/full/Agda/Termination/Monad.hs --- a/src/full/Agda/Termination/Monad.hs +++ b/src/full/Agda/Termination/Monad.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | The monad for the termination checker. -- @@ -13,17 +14,21 @@ module Agda.Termination.Monad where -import Control.Applicative +import Prelude hiding (null) + +import Control.Applicative hiding (empty) import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.State +import Data.Foldable (Foldable) import Data.Functor ((<$>)) import qualified Data.List as List +import Data.Traversable (Traversable) import Agda.Interaction.Options -import Agda.Syntax.Abstract (QName,IsProjP(..)) +import Agda.Syntax.Abstract (QName, IsProjP(..), AllNames) import Agda.Syntax.Common (Delayed(..), Induction(..), Dom(..)) import Agda.Syntax.Internal import Agda.Syntax.Literal @@ -37,12 +42,17 @@ import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records +import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.Utils.Except ( MonadError(catchError, throwError) ) +import Agda.Utils.Function +import Agda.Utils.Functor +import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad -import Agda.Utils.Pretty (Pretty) +import Agda.Utils.Null +import Agda.Utils.Pretty (Pretty, prettyShow) import qualified Agda.Utils.Pretty as P import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet @@ -102,10 +112,14 @@ , terDelayed :: Delayed -- ^ Are we checking a delayed definition? , terMaskArgs :: [Bool] - -- ^ Only consider the 'True' arguments for establishing termination. + -- ^ Only consider the 'notMasked' 'False' arguments for establishing termination. , terMaskResult :: Bool - -- ^ Only consider guardedness if 'True'. - , terPatterns :: [DeBruijnPat] + -- ^ Only consider guardedness if 'False' (not masked). + , _terSizeDepth :: Int -- lazy by intention! + -- ^ How many @SIZELT@ relations do we have in the context + -- (= clause telescope). Used to approximate termination + -- for metas in call args. + , terPatterns :: MaskedDeBruijnPats -- ^ The patterns of the clause we are checking. , terPatternsRaise :: !Int -- ^ Number of additional binders we have gone under @@ -149,8 +163,9 @@ , terCurrent = __IMPOSSIBLE__ -- needs to be set! , terTarget = Nothing , terDelayed = NotDelayed - , terMaskArgs = repeat True -- use all arguments - , terMaskResult = True -- use result + , terMaskArgs = repeat False -- use all arguments (mask none) + , terMaskResult = False -- use result (do not mask) + , _terSizeDepth = __IMPOSSIBLE__ -- needs to be set! , terPatterns = __IMPOSSIBLE__ -- needs to be set! , terPatternsRaise = 0 , terGuarded = le -- not initially guarded @@ -292,10 +307,13 @@ terSetMaskResult :: Bool -> TerM a -> TerM a terSetMaskResult b = terLocal $ \ e -> e { terMaskResult = b } -terGetPatterns :: TerM DeBruijnPats -terGetPatterns = raiseDBP <$> terAsks terPatternsRaise <*> terAsks terPatterns +terGetPatterns :: TerM (MaskedDeBruijnPats) +terGetPatterns = do + n <- terAsks terPatternsRaise + mps <- terAsks terPatterns + return $ if n == 0 then mps else map (fmap (fmap (n +))) mps -terSetPatterns :: DeBruijnPats -> TerM a -> TerM a +terSetPatterns :: MaskedDeBruijnPats -> TerM a -> TerM a terSetPatterns ps = terLocal $ \ e -> e { terPatterns = ps } terRaise :: TerM a -> TerM a @@ -317,6 +335,11 @@ terPiGuarded :: TerM a -> TerM a terPiGuarded m = ifM terGetGuardingTypeConstructors m $ terUnguarded m +-- | Lens for '_terSizeDepth'. + +terSizeDepth :: Lens' Int TerEnv +terSizeDepth f e = f (_terSizeDepth e) <&> \ i -> e { _terSizeDepth = i } + -- | Lens for 'terUsableVars'. terGetUsableVars :: TerM VarSet @@ -343,6 +366,7 @@ withUsableVars :: UsableSizeVars a => a -> TerM b -> TerM b withUsableVars pats m = do vars <- usableSizeVars pats + reportSLn "term.size" 20 $ "usableSizeVars = " ++ show vars terSetUsableVars vars $ m -- | Set 'terUseSizeLt' when going under constructor @c@. @@ -353,12 +377,14 @@ (const $ terSetUseSizeLt False m) -- | Set 'terUseSizeLt' for arguments following projection @q@. +-- We disregard j TerM a -> TerM a -projUseSizeLt q m = isCoinductiveProjection q >>= (`terSetUseSizeLt` m) --- projUseSizeLt q m = do --- ifM (liftTCM $ isProjectionButNotCoinductive q) --- (terSetUseSizeLt False m) --- (terSetUseSizeLt True m) +projUseSizeLt q m = do + co <- isCoinductiveProjection False q + reportSLn "term.size" 20 $ applyUnless co ("not " ++) $ + "using SIZELT vars after projection " ++ prettyShow q + terSetUseSizeLt co m -- | For termination checking purposes flat should not be considered a -- projection. That is, it flat doesn't preserve either structural order @@ -393,29 +419,44 @@ -- -- isCoinductiveProjection (Stream.tail) = return True -- @ -isCoinductiveProjection :: MonadTCM tcm => QName -> tcm Bool -isCoinductiveProjection q = liftTCM $ do +isCoinductiveProjection :: MonadTCM tcm => Bool -> QName -> tcm Bool +isCoinductiveProjection mustBeRecursive q = liftTCM $ do + reportSLn "term.guardedness" 40 $ "checking isCoinductiveProjection " ++ prettyShow q flat <- fmap nameOfFlat <$> coinductionKit -- yes for ♭ if Just q == flat then return True else do - pdef <- getConstInfo q - case isProjection_ (theDef pdef) of - Just Projection{ projProper = Just{}, projFromType = r, projIndex = n } - -> caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do - -- no for inductive or non-recursive record - if recInduction rdef /= Just CoInductive then return False else do - if not (recRecursive rdef) then return False else do - -- TODO: the following test for recursiveness of a projection should be cached. - -- E.g., it could be stored in the @Projection@ component. - -- Now check if type of field mentions mutually recursive symbol. - -- Get the type of the field by dropping record parameters and record argument. - let TelV tel core = telView' (defType pdef) - tel' = drop n $ telToList tel - -- Check if any recursive symbols appear in the record type. - -- Q (2014-07-01): Should we normalize the type? - names <- anyDefs (r : recMutual rdef) (map (snd . unDom) tel', core) - return $ not $ null names - _ -> return False + pdef <- getConstInfo q + case isProjection_ (theDef pdef) of + Just Projection{ projProper = Just{}, projFromType = r, projIndex = n } -> + caseMaybeM (isRecord r) __IMPOSSIBLE__ $ \ rdef -> do + -- no for inductive or non-recursive record + if recInduction rdef /= Just CoInductive then return False else do + reportSLn "term.guardedness" 40 $ prettyShow q ++ " is coinductive" + if not mustBeRecursive then return True else do + reportSLn "term.guardedness" 40 $ prettyShow q ++ " must be recursive" + if not (recRecursive rdef) then return False else do + reportSLn "term.guardedness" 40 $ prettyShow q ++ " has been declared recursive, doing actual check now..." + -- TODO: the following test for recursiveness of a projection should be cached. + -- E.g., it could be stored in the @Projection@ component. + -- Now check if type of field mentions mutually recursive symbol. + -- Get the type of the field by dropping record parameters and record argument. + let TelV tel core = telView' (defType pdef) + tel' = drop n $ telToList tel + -- Check if any recursive symbols appear in the record type. + -- Q (2014-07-01): Should we normalize the type? + reportSDoc "term.guardedness" 40 $ sep + [ text "looking for recursive occurrences in" + , prettyTCM (telFromList tel') + , text "and" + , prettyTCM core + ] + names <- anyDefs (r : recMutual rdef) (map (snd . unDom) tel', core) + reportSDoc "term.guardedness" 40 $ + text "found" <+> sep (map prettyTCM names) + return $ not $ null names + _ -> do + reportSLn "term.guardedness" 40 $ prettyShow q ++ " is not a proper projection" + return False -- * De Bruijn patterns. @@ -485,21 +526,61 @@ usableSizeVars :: a -> TerM VarSet instance UsableSizeVars DeBruijnPat where - usableSizeVars p = + usableSizeVars p = do + let none = return mempty case p of - VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) (return $ mempty) + VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) {- else -} none ConDBP c ps -> conUseSizeLt c $ usableSizeVars ps - LitDBP{} -> return mempty - TermDBP{} -> return mempty - ProjDBP{} -> return mempty + LitDBP{} -> none + TermDBP{} -> none + ProjDBP{} -> none -instance UsableSizeVars [DeBruijnPat] where +instance UsableSizeVars DeBruijnPats where usableSizeVars ps = case ps of [] -> return mempty (ProjDBP q : ps) -> projUseSizeLt q $ usableSizeVars ps (p : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps +instance UsableSizeVars (Masked DeBruijnPat) where + usableSizeVars (Masked m p) = do + let none = return mempty + case p of + VarDBP i -> ifM terGetUseSizeLt (return $ VarSet.singleton i) {- else -} none + ConDBP c ps -> if m then none else conUseSizeLt c $ usableSizeVars ps + LitDBP{} -> none + TermDBP{} -> none + ProjDBP{} -> none + +instance UsableSizeVars MaskedDeBruijnPats where + usableSizeVars ps = + case ps of + [] -> return mempty + (Masked _ (ProjDBP q) : ps) -> projUseSizeLt q $ usableSizeVars ps + (p : ps) -> mappend <$> usableSizeVars p <*> usableSizeVars ps + +-- * Masked patterns (which are not eligible for structural descent, only for size descent) + +type MaskedDeBruijnPats = [Masked DeBruijnPat] + +data Masked a = Masked + { getMask :: Bool -- ^ True if thing not eligible for structural descent. + , getMasked :: a -- ^ Thing. + } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +masked :: a -> Masked a +masked = Masked True + +notMasked :: a -> Masked a +notMasked = Masked False + +instance Decoration Masked where + traverseF f (Masked m a) = Masked m <$> f a + +-- | Print masked things in double parentheses. +instance PrettyTCM a => PrettyTCM (Masked a) where + prettyTCM (Masked m a) = applyWhen m (parens . parens) $ prettyTCM a + -- * Call pathes -- | The call information is stored as free monoid @@ -513,12 +594,31 @@ -- Performance-wise, I could not see a difference between Set and list. newtype CallPath = CallPath { callInfos :: [CallInfo] } - deriving (Show, Monoid) + deriving (Show, Monoid, AllNames) -- | Only show intermediate nodes. (Drop last 'CallInfo'). instance Pretty CallPath where - pretty (CallPath cis0) = if List.null cis then P.empty else + pretty (CallPath cis0) = if null cis then empty else P.hsep (map (\ ci -> arrow P.<+> P.pretty ci) cis) P.<+> arrow where cis = init cis0 arrow = P.text "-->" + +-- * Size depth estimation + +-- | A very crude way of estimating the @SIZELT@ chains +-- @i > j > k@ in context. Returns 3 in this case. +-- Overapproximates. + +-- TODO: more precise analysis, constructing a tree +-- of relations between size variables. +terSetSizeDepth :: Telescope -> TerM a -> TerM a +terSetSizeDepth tel cont = do + n <- liftTCM $ sum <$> do + forM (telToList tel) $ \ dom -> do + a <- reduce $ snd $ unDom dom + ifM (isJust <$> isSizeType a) (return 1) {- else -} $ do + case ignoreSharing $ unEl a of + MetaV{} -> return 1 + _ -> return 0 + terLocal (set terSizeDepth n) cont diff --git a/src/full/Agda/Termination/Order.hs b/src/full/Agda/Termination/Order.hs --- a/src/full/Agda/Termination/Order.hs +++ b/src/full/Agda/Termination/Order.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImplicitParams #-} -- | An Abstract domain of relative sizes, i.e., differences -- between size of formal function parameter and function argument @@ -31,7 +30,7 @@ import qualified Agda.Termination.Semiring as Semiring import Agda.Utils.PartialOrd hiding (tests) -import Agda.Utils.Pretty hiding (empty) +import Agda.Utils.Pretty import Agda.Utils.QuickCheck import Agda.Utils.TestHelpers diff --git a/src/full/Agda/Termination/SparseMatrix.hs b/src/full/Agda/Termination/SparseMatrix.hs --- a/src/full/Agda/Termination/SparseMatrix.hs +++ b/src/full/Agda/Termination/SparseMatrix.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {- | Sparse matrices. diff --git a/src/full/Agda/Termination/TermCheck.hs b/src/full/Agda/Termination/TermCheck.hs --- a/src/full/Agda/Termination/TermCheck.hs +++ b/src/full/Agda/Termination/TermCheck.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {- Checking for Structural recursion Authors: Andreas Abel, Nils Anders Danielsson, Ulf Norell, @@ -22,9 +21,10 @@ import Prelude hiding (null) -import Control.Applicative +import Control.Applicative hiding (empty) import Control.Monad.State +import Data.Foldable (toList) import Data.List hiding (null) import qualified Data.List as List import Data.Maybe (mapMaybe, isJust, fromMaybe) @@ -34,7 +34,7 @@ import qualified Data.Set as Set import Data.Traversable (traverse) -import Agda.Syntax.Abstract (IsProjP(..)) +import Agda.Syntax.Abstract (IsProjP(..), AllNames(..)) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Internal as I import qualified Agda.Syntax.Info as Info @@ -44,9 +44,9 @@ import Agda.Termination.CutOff import Agda.Termination.Monad -import Agda.Termination.CallGraph hiding (null) +import Agda.Termination.CallGraph hiding (toList) import qualified Agda.Termination.CallGraph as CallGraph -import Agda.Termination.CallMatrix hiding (null) +import Agda.Termination.CallMatrix hiding (toList) import Agda.Termination.Order as Order import qualified Agda.Termination.SparseMatrix as Matrix import Agda.Termination.Termination (endos, idempotent) @@ -79,8 +79,8 @@ import Agda.Utils.Monad -- (mapM', forM', ifM, or2M, and2M) import Agda.Utils.Null import Agda.Utils.Permutation -import Agda.Utils.Pointed import Agda.Utils.Pretty (render) +import Agda.Utils.Singleton import Agda.Utils.VarSet (VarSet) import qualified Agda.Utils.VarSet as VarSet @@ -92,14 +92,14 @@ type Calls = CallGraph CallPath -- | The result of termination checking a module. --- Must be 'Pointed' and a 'Monoid'. +-- Must be a 'Monoid' and have 'Singleton'. type Result = [TerminationError] --- | Termination check a single declaration. +-- | Entry point: Termination check a single declaration. termDecl :: A.Declaration -> TCM Result -termDecl d = ignoreAbstractMode $ termDecl' d +termDecl d = inTopContext $ ignoreAbstractMode $ termDecl' d -- | Termination check a sequence of declarations. @@ -112,28 +112,27 @@ -- (without necessarily ignoring @abstract@). termDecl' :: A.Declaration -> TCM Result -termDecl' (A.ScopedDecl scope ds) = do - setScope scope - termDecls ds termDecl' d = case d of A.Axiom {} -> return mempty A.Field {} -> return mempty A.Primitive {} -> return mempty A.Mutual _ ds - | [A.RecSig{}, A.RecDef _ r _ _ _ _ rds] <- unscopeDefs ds - -> checkRecDef ds r rds + | [A.RecSig{}, A.RecDef _ _ _ _ _ _ rds] <- unscopeDefs ds + -> termDecls rds A.Mutual i ds -> termMutual i ds - A.Section _ x _ ds -> termSection x ds + A.Section _ _ _ ds -> termDecls ds + -- section structure can be ignored as we are termination checking + -- definitions lifted to the top-level A.Apply {} -> return mempty A.Import {} -> return mempty A.Pragma {} -> return mempty A.Open {} -> return mempty A.PatternSynDef {} -> return mempty -- open and pattern synonym defs are just artifacts from the concrete syntax - A.ScopedDecl{} -> __IMPOSSIBLE__ - -- taken care of above + A.ScopedDecl _ ds -> termDecls ds + -- scope is irrelevant as we are termination checking Syntax.Internal A.RecSig{} -> return mempty - A.RecDef _ r _ _ _ _ ds -> checkRecDef [] r ds + A.RecDef _ r _ _ _ _ ds -> termDecls ds -- These should all be wrapped in mutual blocks A.FunDef{} -> __IMPOSSIBLE__ A.DataSig{} -> __IMPOSSIBLE__ @@ -141,40 +140,19 @@ -- This should have been expanded to a proper declaration before termination checking A.UnquoteDecl{} -> __IMPOSSIBLE__ where - setScopeFromDefs = mapM_ setScopeFromDef - setScopeFromDef (A.ScopedDecl scope d) = setScope scope - setScopeFromDef _ = return () - unscopeDefs = concatMap unscopeDef unscopeDef (A.ScopedDecl _ ds) = unscopeDefs ds unscopeDef d = [d] - checkRecDef ds r rds = do - setScopeFromDefs ds - termSection (mnameFromList $ qnameToList r) rds - --- | Termination check a module. - -termSection :: ModuleName -> [A.Declaration] -> TCM Result -termSection x ds = do - tel <- lookupSection x - reportSDoc "term.section" 10 $ - sep [ text "termination checking section" - , prettyTCM x - , prettyTCM tel - ] - withCurrentModule x $ addCtxTel tel $ termDecls ds - - -- | Termination check a bunch of mutually inductive recursive definitions. termMutual :: Info.MutualInfo -> [A.Declaration] -> TCM Result termMutual i ds = if names == [] then return mempty else -- We set the range to avoid panics when printing error messages. - traceCall (SetRange (Info.mutualRange i)) $ do + setCurrentRange i $ do -- Get set of mutually defined names from the TCM. -- This includes local and auxiliary functions introduced @@ -226,7 +204,7 @@ (runTerm $ termMutual') -- record result of termination check in signature - let terminates = List.null res + let terminates = null res forM_ allNames $ \ q -> setTerminates q terminates return res @@ -274,16 +252,18 @@ -- the names the user has declared. This is for error reporting. names <- terGetUserNames case r of - Left calls -> do - return $ point $ TerminationError - { termErrFunctions = names - , termErrCalls = callInfos calls - } + Left calls -> return $ singleton $ terminationError names $ callInfos calls Right{} -> do liftTCM $ reportSLn "term.warn.yes" 2 $ show (names) ++ " does termination check" return mempty +-- | Smart constructor for 'TerminationError'. +-- Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'. +terminationError :: [QName] -> [CallInfo] -> TerminationError +terminationError names calls = TerminationError names' calls + where names' = names `intersect` toList (allNames calls) + -- ASR (08 November 2014). The type of the function could be -- -- @Either a b -> TerM (Either a b)@. @@ -296,124 +276,120 @@ reportCalls :: String -> Calls -> TerM () reportCalls no calls = do - cutoff <- terGetCutOff - let ?cutoff = cutoff + cutoff <- terGetCutOff + let ?cutoff = cutoff - -- We work in TCM exclusively. - liftTCM $ do + -- We work in TCM exclusively. + liftTCM $ do - reportS "term.lex" 20 $ unlines - [ "Calls (" ++ no ++ "dot patterns): " ++ show calls - ] + reportS "term.lex" 20 $ unlines + [ "Calls (" ++ no ++ "dot patterns): " ++ show calls + ] - -- Print the whole completion phase. - verboseS "term.matrices" 40 $ do - let header s = unlines - [ replicate n '=' - , replicate k '=' ++ s ++ replicate k' '=' - , replicate n '=' - ] - where n = 70 - r = n - length s - k = r `div` 2 - k' = r - k - let report s cs = reportSDoc "term.matrices" 40 $ vcat - [ text $ header s - , nest 2 $ pretty cs - ] - cs0 = calls - step cs = do - let (new, cs') = completionStep cs0 cs - report " New call matrices " new - return $ if CallGraph.null new then Left () else Right cs' - report " Initial call matrices " cs0 - trampolineM step cs0 + -- Print the whole completion phase. + verboseS "term.matrices" 40 $ do + let header s = unlines + [ replicate n '=' + , replicate k '=' ++ s ++ replicate k' '=' + , replicate n '=' + ] + where n = 70 + r = n - length s + k = r `div` 2 + k' = r - k + let report s cs = reportSDoc "term.matrices" 40 $ vcat + [ text $ header s + , nest 2 $ pretty cs + ] + cs0 = calls + step cs = do + let (new, cs') = completionStep cs0 cs + report " New call matrices " new + return $ if null new then Left () else Right cs' + report " Initial call matrices " cs0 + trampolineM step cs0 - -- Print the result of completion. - let calls' = CallGraph.complete calls - idems = filter idempotent $ endos $ CallGraph.toList calls' - -- TODO - -- reportSDoc "term.behaviours" 20 $ vcat - -- [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):" - -- , nest 2 $ return $ Term.prettyBehaviour calls' - -- ] - reportSDoc "term.matrices" 30 $ vcat - [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n" - , nest 2 $ vcat $ punctuate (text "\n") $ map pretty idems - ] - -- reportSDoc "term.matrices" 30 $ vcat - -- [ text $ "Other call matrices (" ++ no ++ "dot patterns):" - -- , nest 2 $ pretty $ CallGraph.fromList others - -- ] - return () + -- Print the result of completion. + let calls' = CallGraph.complete calls + idems = filter idempotent $ endos $ CallGraph.toList calls' + -- TODO + -- reportSDoc "term.behaviours" 20 $ vcat + -- [ text $ "Recursion behaviours (" ++ no ++ "dot patterns):" + -- , nest 2 $ return $ Term.prettyBehaviour calls' + -- ] + reportSDoc "term.matrices" 30 $ vcat + [ text $ "Idempotent call matrices (" ++ no ++ "dot patterns):\n" + , nest 2 $ vcat $ punctuate (text "\n") $ map pretty idems + ] + -- reportSDoc "term.matrices" 30 $ vcat + -- [ text $ "Other call matrices (" ++ no ++ "dot patterns):" + -- , nest 2 $ pretty $ CallGraph.fromList others + -- ] + return () -- | @termFunction name@ checks @name@ for termination. termFunction :: QName -> TerM Result termFunction name = do - -- Function @name@ is henceforth referred to by its @index@ - -- in the list of @allNames@ of the mutual block. - - allNames <- terGetMutual - let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames + -- Function @name@ is henceforth referred to by its @index@ + -- in the list of @allNames@ of the mutual block. - -- Retrieve the target type of the function to check. + allNames <- terGetMutual + let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames - target <- liftTCM $ do typeEndsInDef =<< typeOfConst name - reportTarget target - terSetTarget target $ do + -- Retrieve the target type of the function to check. - -- Collect the recursive calls in the block which (transitively) - -- involve @name@, - -- taking the target of @name@ into account for computing guardedness. + target <- liftTCM $ do typeEndsInDef =<< typeOfConst name + reportTarget target + terSetTarget target $ do - let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do - if null todo then return $ Left calls else do - -- Extract calls originating from indices in @todo@. - new <- forM' todo $ \ i -> - termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i - -- Mark those functions as processed and add the calls to the result. - let done' = done `mappend` todo - calls' = new `mappend` calls - -- Compute the new todo list: - todo' = CallGraph.targetNodes new Set.\\ done' - -- Jump the trampoline. - return $ Right (todo', done', calls') + -- Collect the recursive calls in the block which (transitively) + -- involve @name@, + -- taking the target of @name@ into account for computing guardedness. - -- First try to termination check ignoring the dot patterns - calls1 <- terSetUseDotPatterns False $ collect - reportCalls "no " calls1 + let collect = (`trampolineM` (Set.singleton index, mempty, mempty)) $ \ (todo, done, calls) -> do + if null todo then return $ Left calls else do + -- Extract calls originating from indices in @todo@. + new <- forM' todo $ \ i -> + termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i + -- Mark those functions as processed and add the calls to the result. + let done' = done `mappend` todo + calls' = new `mappend` calls + -- Compute the new todo list: + todo' = CallGraph.targetNodes new Set.\\ done' + -- Jump the trampoline. + return $ Right (todo', done', calls') - r <- do - cutoff <- terGetCutOff - let ?cutoff = cutoff - r <- billToTerGraph $ Term.terminatesFilter (== index) calls1 - case r of - Right () -> return $ Right () - Left{} -> do - -- Try again, but include the dot patterns this time. - calls2 <- terSetUseDotPatterns True $ collect - reportCalls "" calls2 - billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2 + -- First try to termination check ignoring the dot patterns + calls1 <- terSetUseDotPatterns False $ collect + reportCalls "no " calls1 - names <- terGetUserNames + r <- do + cutoff <- terGetCutOff + let ?cutoff = cutoff + r <- billToTerGraph $ Term.terminatesFilter (== index) calls1 case r of - Left calls -> do - return $ point $ TerminationError - { termErrFunctions = if name `elem` names then [name] else [] - , termErrCalls = calls - } - Right () -> do - liftTCM $ reportSLn "term.warn.yes" 2 $ - show (name) ++ " does termination check" - return mempty - where - reportTarget r = liftTCM $ - reportSLn "term.target" 20 $ " target type " ++ - caseMaybe r "not recognized" (\ q -> - "ends in " ++ show q) + Right () -> return $ Right () + Left{} -> do + -- Try again, but include the dot patterns this time. + calls2 <- terSetUseDotPatterns True $ collect + reportCalls "" calls2 + billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2 + names <- terGetUserNames + case r of + Left calls -> return $ singleton $ terminationError ([name] `intersect` names) calls + Right () -> do + liftTCM $ reportSLn "term.warn.yes" 2 $ + show name ++ " does termination check" + return mempty + where + reportTarget r = liftTCM $ + reportSLn "term.target" 20 $ " target type " ++ + caseMaybe r "not recognized" (\ q -> + "ends in " ++ show q) + -- | To process the target type. typeEndsInDef :: MonadTCM tcm => Type -> tcm (Maybe QName) typeEndsInDef t = liftTCM $ do @@ -451,13 +427,13 @@ applyWhen withoutKEnabled (setMasks t) $ do -- If the result should be disregarded, set all calls to unguarded. - applyUnlessM terGetMaskResult terUnguarded $ do + applyWhenM terGetMaskResult terUnguarded $ do case theDef def of Function{ funClauses = cls, funDelayed = delayed } -> terSetDelayed delayed $ forM' cls $ termClause - _ -> return CallGraph.empty + _ -> return empty -- | Mask arguments and result for termination checking -- according to type of function. @@ -469,13 +445,19 @@ -- Check argument types ds <- forM (telToList tel) $ \ t -> do TelV _ t <- telView $ snd $ unDom t - (isJust <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t) + d <- (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t) + when d $ + reportSDoc "term.mask" 20 $ do + text "argument type " + <+> prettyTCM t + <+> text " is not data or record type, ignoring structural descent for --without-K" + return d -- Check result types - d <- isJust <.> isDataOrRecord . unEl $ core - unless d $ + d <- isNothing <.> isDataOrRecord . unEl $ core + when d $ reportSLn "term.mask" 20 $ "result type is not data or record type, ignoring guardedness for --without-K" return (ds, d) - terSetMaskArgs (ds ++ repeat False) $ terSetMaskResult d $ cont + terSetMaskArgs (ds ++ repeat True) $ terSetMaskResult d $ cont {- Termination check clauses: @@ -560,11 +542,11 @@ ProjDBP{} -> return p -- | Masks all non-data/record type patterns if --without-K. -maskNonDataArgs :: [DeBruijnPat] -> TerM [DeBruijnPat] +maskNonDataArgs :: [DeBruijnPat] -> TerM [Masked DeBruijnPat] maskNonDataArgs ps = zipWith mask ps <$> terGetMaskArgs where - mask p@ProjDBP{} _ = p - mask p d = if d then p else unusedVar + mask p@ProjDBP{} _ = Masked False p + mask p d = Masked d p -- | cf. 'TypeChecking.Coverage.Match.buildMPatterns' openClause :: Permutation -> [Pattern] -> ClauseBody -> TerM ([DeBruijnPat], Maybe Term) @@ -595,9 +577,9 @@ termClause :: Clause -> TerM Calls termClause clause = do ifNotM (terGetInlineWithFunctions) (termClause' clause) $ {- else -} do - name <- terGetCurrent - ifM (isJust <$> do isWithFunction name) (return mempty) $ do - mapM' termClause' =<< do liftTCM $ inlineWithClauses name clause + name <- terGetCurrent + ifM (isJust <$> do isWithFunction name) (return mempty) $ do + mapM' termClause' =<< do liftTCM $ inlineWithClauses name clause termClause' :: Clause -> TerM Calls termClause' clause = do @@ -616,11 +598,12 @@ ps <- liftTCM $ normalise $ map unArg argPats' (dbpats, res) <- openClause perm ps body case res of - Nothing -> return CallGraph.empty + Nothing -> return empty Just v -> do dbpats <- mapM stripCoConstructors dbpats - dbpats <- maskNonDataArgs dbpats - terSetPatterns dbpats $ do + mdbpats <- maskNonDataArgs dbpats + terSetPatterns mdbpats $ do + terSetSizeDepth tel $ do reportBody v {- -- if we are checking a delayed definition, we treat it as if there were @@ -704,7 +687,7 @@ extract = extract . unDom instance ExtractCalls a => ExtractCalls (Elim' a) where - extract Proj{} = return CallGraph.empty + extract Proj{} = return empty extract (Apply a) = extract $ unArg a instance ExtractCalls a => ExtractCalls [a] where @@ -726,8 +709,9 @@ reportSDoc "term.sort" 50 $ text ("s = " ++ show s) case s of - Prop -> return CallGraph.empty - Inf -> return CallGraph.empty + Prop -> return empty + Inf -> return empty + SizeUniv -> return empty Type t -> terUnguarded $ extract t -- no guarded levels DLub s1 s2 -> extract (s1, s2) @@ -897,7 +881,10 @@ -- So we build a closure such that we can print the call -- whenever we really need to. -- This saves 30s (12%) on the std-lib! - doc <- liftTCM $ buildClosure gArgs + -- Andreas, 2015-01-21 Issue 1410: Go to the module where g is defined + -- otherwise its free variables with be prepended to the call + -- in the error message. + doc <- liftTCM $ withCurrentModule (qnameModule g) $ buildClosure gArgs let src = fromMaybe __IMPOSSIBLE__ $ List.elemIndex f names tgt = gInd @@ -967,14 +954,14 @@ <*> terPiGuarded (extract b) -- Literal. - Lit l -> return CallGraph.empty + Lit l -> return empty -- Sort. Sort s -> extract s -- Unsolved metas are not considered termination problems, there -- will be a warning for them anyway. - MetaV x args -> return CallGraph.empty + MetaV x args -> return empty -- Erased and not-yet-erased proof. DontCare t -> extract t @@ -998,7 +985,7 @@ instance ExtractCalls LevelAtom where extract (MetaLevel x es) = extract es extract (BlockedLevel x t) = extract t - extract (NeutralLevel t) = extract t + extract (NeutralLevel _ t) = extract t extract (UnreducedLevel t) = extract t -- | Rewrite type @tel -> Size< u@ to @tel -> Size@. @@ -1033,18 +1020,21 @@ -- matrix <- forM es $ \ e -> forM apats $ \ (b, p) -> terSetUseSizeLt b $ compareElim e p matrix <- withUsableVars pats $ forM es $ \ e -> forM pats $ \ p -> compareElim e p - -- Count the number of coinductive projection(pattern)s in caller and callee + -- Count the number of coinductive projection(pattern)s in caller and callee. + -- Only recursive coinductive projections are eligible (Issue 1209). projsCaller <- genericLength <$> do - filterM isCoinductiveProjection $ mapMaybe isProjP pats - -- filterM (not <.> isProjectionButNotCoinductive) $ mapMaybe isProjP pats + filterM (isCoinductiveProjection True) $ mapMaybe (isProjP . getMasked) pats projsCallee <- genericLength <$> do - filterM isCoinductiveProjection $ mapMaybe isProjElim es - -- filterM (not <.> isProjectionButNotCoinductive) $ mapMaybe isProjElim es + filterM (isCoinductiveProjection True) $ mapMaybe isProjElim es cutoff <- terGetCutOff let ?cutoff = cutoff let guardedness = decr $ projsCaller - projsCallee - liftTCM $ reportSLn "term.guardedness" 30 $ - "compareArgs: guardedness of call: " ++ show guardedness + liftTCM $ reportSDoc "term.guardedness" 30 $ sep + [ text "compareArgs:" + , nest 2 $ text $ "projsCaller = " ++ show projsCaller + , nest 2 $ text $ "projsCallee = " ++ show projsCallee + , nest 2 $ text $ "guardedness of call: " ++ show guardedness + ] return $ addGuardedness guardedness (size es) (size pats) matrix -- | Traverse patterns from left to right. @@ -1063,7 +1053,7 @@ -- | @compareElim e dbpat@ -compareElim :: Elim -> DeBruijnPat -> TerM Order +compareElim :: Elim -> Masked DeBruijnPat -> TerM Order compareElim e p = do liftTCM $ do reportSDoc "term.compare" 30 $ sep @@ -1075,11 +1065,11 @@ [ nest 2 $ text $ "e = " ++ show e , nest 2 $ text $ "p = " ++ show p ] - case (e, p) of + case (e, getMasked p) of (Proj d, ProjDBP d') -> compareProj d d' (Proj{}, _ ) -> return Order.unknown (Apply{}, ProjDBP{}) -> return Order.unknown - (Apply arg, p) -> compareTerm (unArg arg) p + (Apply arg, _) -> compareTerm (unArg arg) p -- | In dependent records, the types of later fields may depend on the -- values of earlier fields. Thus when defining an inhabitant of a @@ -1153,7 +1143,7 @@ TermDBP _ -> [] ProjDBP _ -> [] -compareTerm :: Term -> DeBruijnPat -> TerM Order +compareTerm :: Term -> Masked DeBruijnPat -> TerM Order compareTerm t p = do -- reportSDoc "term.compare" 25 $ -- text " comparing term " <+> prettyTCM t <+> @@ -1215,8 +1205,8 @@ -- -- Precondition: top meta variable resolved -compareTerm' :: Term -> DeBruijnPat -> TerM Order -compareTerm' v p = do +compareTerm' :: Term -> Masked DeBruijnPat -> TerM Order +compareTerm' v mp@(Masked m p) = do suc <- terGetSizeSuc cutoff <- terGetCutOff let ?cutoff = cutoff @@ -1225,21 +1215,47 @@ -- Andreas, 2013-11-20 do not drop projections, -- in any case not coinductive ones!: - (Var i es, p) | Just{} <- allApplyElims es -> - compareVar i p + (Var i es, _) | Just{} <- allApplyElims es -> + compareVar i mp - (DontCare t, p) -> - compareTerm' t p + (DontCare t, _) -> + compareTerm' t mp + -- Andreas, 2014-09-22, issue 1281: + -- For metas, termination checking should be optimistic. + -- If there is any instance of the meta making termination + -- checking succeed, then we should not fail. + -- Thus, we assume the meta will be instantiated with the + -- deepest variable in @p@. + -- For sized types, the depth is maximally + -- the number of SIZELT hypotheses one can have in a context. + (MetaV{}, p) -> Order.decr . max (if m then 0 else patternDepth p) . pred <$> + terAsks _terSizeDepth + + -- Successor on both sides cancel each other. + -- We ignore the mask for sizes. + (Def s [Apply t], ConDBP s' [p]) | s == s' && Just s == suc -> + compareTerm' (unArg t) (notMasked p) + + -- Register also size increase. + (Def s [Apply t], p) | Just s == suc -> + -- Andreas, 2012-10-19 do not cut off here + increase 1 <$> compareTerm' (unArg t) mp + + -- In all cases that do not concern sizes, + -- we cannot continue if pattern is masked. + + _ | m -> return Order.unknown + (Lit l, LitDBP l') | l == l' -> return Order.le | otherwise -> return Order.unknown - (Lit l, p) -> do + (Lit l, _) -> do v <- liftTCM $ constructorForm v case ignoreSharing v of Lit{} -> return Order.unknown - v -> compareTerm' v p + v -> compareTerm' v mp -- Andreas, 2011-04-19 give subterm priority over matrix order @@ -1249,30 +1265,13 @@ (Con c ts, ConDBP c' ps) | conName c == c'-> compareConArgs ts ps - (Def s [Apply t], ConDBP s' [p]) | s == s' && Just s == suc -> - compareTerm' (unArg t) p + (Con c [], _) -> return Order.le - -- new cases for counting constructors / projections + -- new case for counting constructors / projections -- register also increase - (Def s [Apply t], p) | Just s == suc -> - -- Andreas, 2012-10-19 do not cut off here - increase 1 <$> compareTerm' (unArg t) p - - (Con c [], p) -> return Order.le - - (Con c ts, p) -> do + (Con c ts, _) -> do increase <$> offsetFromConstructor (conName c) - <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) p) ts) - - -- Andreas, 2014-09-22, issue 1281: - -- For metas, termination checking should be optimistic. - -- If there is any instance of the meta making termination - -- checking succeed, then we should not fail. - -- Thus, we assume the meta will be instantiated with the - -- deepest variable in @p@. - -- For sized types, the depth is maximally context length - 1, - -- which is the number of SIZELT hypotheses one can have in a context. - (MetaV{}, p) -> Order.decr . max (patternDepth p) . pred <$> getContextSize + <*> (infimum <$> mapM (\ t -> compareTerm' (unArg t) mp) ts) (t, p) -> return $ subTerm t p @@ -1310,9 +1309,9 @@ (0,0) -> return Order.le -- c <= c (0,1) -> return Order.unknown -- c not<= c x (1,0) -> __IMPOSSIBLE__ - (1,1) -> compareTerm' (unArg (head ts)) (head ps) + (1,1) -> compareTerm' (unArg (head ts)) (notMasked (head ps)) (_,_) -> foldl (Order..*.) Order.le <$> - zipWithM compareTerm' (map unArg ts) ps + zipWithM compareTerm' (map unArg ts) (map notMasked ps) -- corresponds to taking the size, not the height -- allows examples like (x, y) < (Succ x, y) {- version which does an "order matrix" @@ -1329,25 +1328,34 @@ -- else Order.infimum (zipWith compareTerm' (map unArg ts) ps) -} -compareVar :: Nat -> DeBruijnPat -> TerM Order -compareVar i (VarDBP j) = compareVarVar i j -compareVar i (ConDBP c ps) = do +compareVar :: Nat -> Masked DeBruijnPat -> TerM Order +compareVar i (Masked m p) = do + suc <- terGetSizeSuc cutoff <- terGetCutOff let ?cutoff = cutoff - decrease <$> offsetFromConstructor c - <*> (Order.supremum <$> mapM (compareVar i) ps) -compareVar i LitDBP{} = return $ Order.unknown -compareVar i TermDBP{} = return $ Order.unknown -compareVar i ProjDBP{} = return $ Order.unknown + let no = return Order.unknown + case p of + ProjDBP{} -> no + LitDBP{} -> no + TermDBP{} -> no + VarDBP j -> compareVarVar i (Masked m j) + ConDBP s [p] | Just s == suc -> decrease 1 <$> compareVar i (notMasked p) + ConDBP c ps -> if m then no else do + decrease <$> offsetFromConstructor c + <*> (Order.supremum <$> mapM (compareVar i . notMasked) ps) -- | Compare two variables. -- -- The first variable comes from a term, the second from a pattern. -compareVarVar :: Nat -> Nat -> TerM Order -compareVarVar i j - | i == j = return Order.le +compareVarVar :: Nat -> Masked Nat -> TerM Order +compareVarVar i (Masked m j) + | i == j = if not m then return Order.le else liftTCM $ + -- If j is a size, we ignore the mask. + ifM (isJust <$> do isSizeType =<< reduce =<< typeOfBV j) + {- then -} (return Order.le) + {- else -} (return Order.unknown) | otherwise = ifNotM ((i `VarSet.member`) <$> terGetUsableVars) (return Order.unknown) $ {- else -} do res <- isBounded i case res of BoundedNo -> return Order.unknown - BoundedLt v -> decrease 1 <$> compareTerm' v (VarDBP j) + BoundedLt v -> decrease 1 <$> compareTerm' v (Masked m (VarDBP j)) diff --git a/src/full/Agda/Tests.hs b/src/full/Agda/Tests.hs --- a/src/full/Agda/Tests.hs +++ b/src/full/Agda/Tests.hs @@ -31,6 +31,7 @@ import Agda.Utils.Graph.AdjacencyMap as UtilGrap (tests) import Agda.Utils.Graph.AdjacencyMap.Unidirectional as UtilGraphUni (tests) import Agda.Utils.List as UtilList (tests) +import Agda.Utils.ListT.Tests as UtilListT (tests) import Agda.Utils.PartialOrd as UtilPOrd (tests) import Agda.Utils.Permutation.Tests as UtilPerm (tests) import Agda.Utils.Warshall as UtilWarsh (tests) @@ -40,6 +41,7 @@ [ Irrel.tests , SizedTypes.tests , UtilFav.tests + , UtilListT.tests , UtilPerm.tests , UtilPOrd.tests , CompEnco.tests diff --git a/src/full/Agda/TypeChecking/Abstract.hs b/src/full/Agda/TypeChecking/Abstract.hs --- a/src/full/Agda/TypeChecking/Abstract.hs +++ b/src/full/Agda/TypeChecking/Abstract.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} -- | Functions for abstracting terms over other terms. module Agda.TypeChecking.Abstract where @@ -49,14 +48,14 @@ (Def f us, Def g vs) | f == g -> us `isPrefixOf` vs (Con c us, Con d vs) | c == d -> us `isPrefixOf` vs (MetaV x us, MetaV y vs) | x == y -> us `isPrefixOf` vs - _ -> guard (u == v) >> return [] + (u, v) -> guard (u == v) >> return [] class AbstractTerm a where -- | @subst u . abstractTerm u == id@ abstractTerm :: Term -> a -> a instance AbstractTerm Term where - abstractTerm u v | Just es <- u `isPrefixOf` v = Var 0 $ raise 1 es + abstractTerm u v | Just es <- u `isPrefixOf` v = Var 0 $ absT es | otherwise = case v of -- Andreas, 2013-10-20: the original impl. works only at base types @@ -87,6 +86,7 @@ Type n -> Type $ absS n Prop -> Prop Inf -> Inf + SizeUniv -> SizeUniv DLub s1 s2 -> DLub (absS s1) (absS s2) where absS x = abstractTerm u x @@ -100,7 +100,7 @@ instance AbstractTerm LevelAtom where abstractTerm u l = case l of MetaLevel m vs -> MetaLevel m $ abstractTerm u vs - NeutralLevel v -> NeutralLevel $ abstractTerm u v + NeutralLevel r v -> NeutralLevel r $ abstractTerm u v BlockedLevel _ v -> UnreducedLevel $ abstractTerm u v -- abstracting might remove the blockage UnreducedLevel v -> UnreducedLevel $ abstractTerm u v diff --git a/src/full/Agda/TypeChecking/CheckInternal.hs b/src/full/Agda/TypeChecking/CheckInternal.hs --- a/src/full/Agda/TypeChecking/CheckInternal.hs +++ b/src/full/Agda/TypeChecking/CheckInternal.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} -- Initially authored by Andreas, 2013-10-22. @@ -38,28 +37,31 @@ #include "undefined.h" import Agda.Utils.Impossible +-- -- | Entry point for e.g. checking WithFunctionType. +-- checkType :: Type -> TCM () +-- checkType t = -- dontAssignMetas $ ignoreSorts $ +-- checkInternal (unEl t) (sort Inf) + -- | Entry point for e.g. checking WithFunctionType. checkType :: Type -> TCM () -checkType t = -- dontAssignMetas $ ignoreSorts $ - checkInternal (unEl t) (sort Inf) +checkType t = void $ checkType' t -{- Alternative algorithm (does not buy us much) +-- | Check a type and infer its sort. -- +-- Necessary because of PTS rule @(SizeUniv, Set i, Set i)@ +-- but @SizeUniv@ is not included in any @Set i@. +-- -- This algorithm follows --- Abel, Coquand, Dybjer, MPC 08 +-- Abel, Coquand, Dybjer, MPC 08, -- Verifying a Semantic βη-Conversion Test for Martin-Löf Type Theory - -checkType :: Type -> TCM () -checkType t = void $ checkType' t - --- | Check a type and infer its sort. +-- checkType' :: Type -> TCM Sort checkType' t = do reportSDoc "tc.check.internal" 20 $ sep [ text "checking internal type " , prettyTCM t ] - v <- elimView $ unEl t -- bring projection-like funs in post-fix form + v <- elimView True $ unEl t -- bring projection-like funs in post-fix form case ignoreSharing v of Pi a b -> do s1 <- checkType' $ unDom a @@ -84,11 +86,11 @@ v@Lit{} -> typeError $ InvalidType v v@Level{} -> typeError $ InvalidType v DontCare v -> checkType' $ t $> v + ExtLam{} -> __IMPOSSIBLE__ Shared{} -> __IMPOSSIBLE__ checkTypeSpine :: Type -> Term -> Elims -> TCM Sort checkTypeSpine a self es = shouldBeSort =<< inferSpine a self es --} -- | Entry point for term checking. checkInternal :: Term -> Type -> TCM () @@ -105,7 +107,7 @@ case ignoreSharing v of Var i es -> do a <- typeOfBV i - checkSpine a (Var i []) es t + checkSpine a (Var i []) es t Def f es -> do -- f is not projection(-like)! a <- defType <$> getConstInfo f checkSpine a (Def f []) es t @@ -128,8 +130,9 @@ checkInternal (absBody vb) (absBody b) Pi a b -> do s <- shouldBeSort t + when (s == SizeUniv) $ typeError $ FunctionTypeInSizeUniv v let st = sort s - checkInternal (unEl $ unDom a) st + checkInternal (unEl $ unDom a) st -- This does not work with SizeUniv addContext (absName b, a) $ do checkInternal (unEl $ absBody b) $ raise 1 st Sort s -> do @@ -169,11 +172,11 @@ checkDef' f a es t = do isProj <- isProjection f case isProj of - Nothing -> checkDef f (Apply a : es) t - Just Projection{} -> do + Just Projection{ projIndex = n} | n > 0 -> do let self = unArg a b <- infer self checkSpine b self (Proj f : es) t + _ -> checkDef f (Apply a : es) t -} checkSpine :: Type -> Term -> Elims -> Type -> TCM () @@ -209,7 +212,7 @@ where r = canon r0 r' = canon r0' - canon Forced = Relevant + canon Forced{} = Relevant canon UnusedArg = Relevant canon r = r @@ -245,11 +248,11 @@ inferDef' f a es = do isProj <- isProjection f case isProj of - Nothing -> inferDef f (Apply a : es) - Just Projection{} -> do + Just Projection{ projIndex = n } | n > 0 -> do let self = unArg a b <- infer self inferSpine b self (Proj f : es) + _ -> inferDef f (Apply a : es) -} -- | @inferSpine t self es@ checks that spine @es@ eliminates @@ -285,6 +288,7 @@ Pi a b -> return (a, b) _ -> typeError $ ShouldBePi t +-- | Result is in reduced form. shouldBeSort :: Type -> TCM Sort shouldBeSort t = ifIsSort t return (typeError $ ShouldBeASort t) @@ -304,6 +308,7 @@ -- the dummy Prop should not be part of a term we check Inf -> typeError $ SetOmegaNotValidType -- we cannot have Setω on the lhs of the colon + SizeUniv -> typeError $ InvalidTypeSort s DLub a b -> do checkSort a addContext (absName b, defaultDom (sort a) :: I.Dom Type) $ do @@ -320,8 +325,8 @@ lvl <- levelType case l of MetaLevel x es -> checkInternal (MetaV x es) lvl - BlockedLevel x v -> checkInternal v lvl - NeutralLevel v -> checkInternal v lvl + BlockedLevel _ v -> checkInternal v lvl + NeutralLevel _ v -> checkInternal v lvl UnreducedLevel v -> checkInternal v lvl -- | Type of a term or sort meta. diff --git a/src/full/Agda/TypeChecking/CompiledClause.hs b/src/full/Agda/TypeChecking/CompiledClause.hs --- a/src/full/Agda/TypeChecking/CompiledClause.hs +++ b/src/full/Agda/TypeChecking/CompiledClause.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TypeOperators #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveDataTypeable, + DeriveFoldable, + DeriveFunctor, + DeriveTraversable #-} -- | Case trees. -- diff --git a/src/full/Agda/TypeChecking/CompiledClause/Match.hs b/src/full/Agda/TypeChecking/CompiledClause/Match.hs --- a/src/full/Agda/TypeChecking/CompiledClause/Match.hs +++ b/src/full/Agda/TypeChecking/CompiledClause/Match.hs @@ -1,16 +1,24 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.CompiledClause.Match where import Control.Applicative import Control.Monad.Reader (asks) -import qualified Data.Map as Map + import Data.List +import Data.Monoid +import qualified Data.Map as Map + import Debug.Trace (trace) import Agda.Syntax.Internal import Agda.Syntax.Common + import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.Monad hiding (reportSDoc, reportSLn) import Agda.TypeChecking.Pretty @@ -73,116 +81,106 @@ sep $ prettyTCM f : map prettyTCM es , text $ "trying clause " ++ show c ] - let no es = return $ NoReduction $ NotBlocked $ patch $ map ignoreReduced es - noBlocked x es = return $ NoReduction $ Blocked x $ patch $ map ignoreReduced es - yes t = flip YesReduction t <$> asks envSimplification + let no blocking es = return $ NoReduction $ blocking $ patch $ map ignoreReduced es + yes t = flip YesReduction t <$> asks envSimplification -- traceSLn "reduce.compiled" 95 "CompiledClause.Match.match'" $ do debug $ do - case c of + case c of - -- impossible case - Fail -> no es + -- impossible case + Fail -> no (NotBlocked AbsurdMatch) es - -- done matching - Done xs t - -- if the function was partially applied, return a lambda - | m < n -> yes $ applySubst (toSubst es) $ foldr lam t (drop m xs) - -- otherwise, just apply instantiation to body - -- apply the result to any extra arguments - | otherwise -> yes $ applySubst (toSubst es0) t `applyE` map ignoreReduced es1 --- | otherwise -> yes $ applySubst (toSubst args0) t `apply` map ignoreReduced args1 - where - n = length xs - m = length es - -- at least the first @n@ elims must be @Apply@s, so we can - -- turn them into a subsitution - toSubst = parallelS . reverse . map (unArg . argFromElim . ignoreReduced) --- (args0, args1) = splitAt n $ map (fmap $ fmap shared) args --- (args0, es1) = takeArgsFromElims n $ map (fmap $ fmap shared) args - -- Andreas, 2013-05-21 why introduce sharing only here, - -- and not in underapplied case also? - (es0, es1) = splitAt n $ map (fmap $ fmap shared) es - lam x t = Lam (argInfo x) (Abs (unArg x) t) + -- done matching + Done xs t + -- if the function was partially applied, return a lambda + | m < n -> yes $ applySubst (toSubst es) $ foldr lam t (drop m xs) + -- otherwise, just apply instantiation to body + -- apply the result to any extra arguments + | otherwise -> yes $ applySubst (toSubst es0) t `applyE` map ignoreReduced es1 + where + n = length xs + m = length es + -- at least the first @n@ elims must be @Apply@s, so we can + -- turn them into a subsitution + toSubst = parallelS . reverse . map (unArg . argFromElim . ignoreReduced) + -- Andreas, 2013-05-21 why introduce sharing only here, + -- and not in underapplied case also? + (es0, es1) = splitAt n $ map (fmap $ fmap shared) es + lam x t = Lam (argInfo x) (Abs (unArg x) t) - -- splitting on the @n@th elimination - Case n bs -> do - case genericSplitAt n es of - -- if the @n@th elimination is not supplied, no match - (_, []) -> no es - -- if the @n@th elimination is @e0@ --- (args0, MaybeRed red (Arg info v0) : args1) -> do - (es0, MaybeRed red e0 : es1) -> do - -- get the reduced form of @e0@ -{- - w <- case red of - Reduced b -> return $ v0 <$ b - NotReduced -> unfoldCorecursion v0 - let v = ignoreBlocking w - args' = args0 ++ [MaybeRed red $ Arg info v] ++ args1 --} - eb :: Blocked Elim <- do - case red of - Reduced b -> return $ e0 <$ b - NotReduced -> unfoldCorecursionE e0 - let e = ignoreBlocking eb - -- replace the @n@th argument by its reduced form - es' = es0 ++ [MaybeRed red e] ++ es1 - -- if a catch-all clause exists, put it on the stack - catchAllFrame stack = maybe stack (\c -> (c, es', patch) : stack) (catchAllBranch bs) - -- If our argument is @Lit l@, we push @litFrame l@ onto the stack. - litFrame l stack = - case Map.lookup l (litBranches bs) of - Nothing -> stack - Just cc -> (cc, es0 ++ es1, patchLit) : stack - -- If our argument (or its constructor form) is @Con c vs@ - -- we push @conFrame c vs@ onto the stack. - conFrame c vs stack = - case Map.lookup (conName c) (conBranches bs) of + -- splitting on the @n@th elimination + Case n bs -> do + case genericSplitAt n es of + -- if the @n@th elimination is not supplied, no match + (_, []) -> no (NotBlocked Underapplied) es + -- if the @n@th elimination is @e0@ + (es0, MaybeRed red e0 : es1) -> do + -- get the reduced form of @e0@ + eb :: Blocked Elim <- do + case red of + Reduced b -> return $ e0 <$ b + NotReduced -> unfoldCorecursionE e0 + let e = ignoreBlocking eb + -- replace the @n@th argument by its reduced form + es' = es0 ++ [MaybeRed red e] ++ es1 + -- if a catch-all clause exists, put it on the stack + catchAllFrame stack = maybe stack (\c -> (c, es', patch) : stack) (catchAllBranch bs) + -- If our argument is @Lit l@, we push @litFrame l@ onto the stack. + litFrame l stack = + case Map.lookup l (litBranches bs) of Nothing -> stack + Just cc -> (cc, es0 ++ es1, patchLit) : stack + -- If our argument (or its constructor form) is @Con c vs@ + -- we push @conFrame c vs@ onto the stack. + conFrame c vs stack = + case Map.lookup (conName c) (conBranches bs) of + Nothing -> stack Just cc -> ( content cc , es0 ++ map (MaybeRed red . Apply) vs ++ es1 , patchCon c (length vs) ) : stack - -- If our argument is @Proj p@, we push @projFrame p@ onto the stack. - projFrame p stack = - case Map.lookup p (conBranches bs) of - Nothing -> stack - Just cc -> (content cc, es0 ++ es1, patchLit) : stack - -- The new patch function restores the @n@th argument to @v@: - -- In case we matched a literal, just put @v@ back. - patchLit es = patch (es0 ++ [e] ++ es1) - where (es0, es1) = splitAt n es - -- In case we matched constructor @c@ with @m@ arguments, - -- contract these @m@ arguments @vs@ to @Con c vs@. - patchCon c m es = patch (es0 ++ [Con c vs <$ e] ++ es2) - where (es0, rest) = splitAt n es - (es1, es2) = splitAt m rest - vs = map argFromElim es1 + -- If our argument is @Proj p@, we push @projFrame p@ onto the stack. + projFrame p stack = + case Map.lookup p (conBranches bs) of + Nothing -> stack + Just cc -> (content cc, es0 ++ es1, patchLit) : stack + -- The new patch function restores the @n@th argument to @v@: + -- In case we matched a literal, just put @v@ back. + patchLit es = patch (es0 ++ [e] ++ es1) + where (es0, es1) = splitAt n es + -- In case we matched constructor @c@ with @m@ arguments, + -- contract these @m@ arguments @vs@ to @Con c vs@. + patchCon c m es = patch (es0 ++ [Con c vs <$ e] ++ es2) + where (es0, rest) = splitAt n es + (es1, es2) = splitAt m rest + vs = map argFromElim es1 - -- Now do the matching on the @n@ths argument: - case fmap ignoreSharing <$> eb of - Blocked x _ -> noBlocked x es' - NotBlocked (Apply (Arg info (MetaV x _))) -> noBlocked x es' + -- Now do the matching on the @n@ths argument: + case fmap ignoreSharing <$> eb of + Blocked x _ -> no (Blocked x) es' + NotBlocked _ (Apply (Arg info (MetaV x _))) -> no (Blocked x) es' - -- In case of a literal, try also its constructor form - NotBlocked (Apply (Arg info v@(Lit l))) -> performedSimplification $ do - cv <- constructorForm v - let cFrame stack = case ignoreSharing cv of - Con c vs -> conFrame c vs stack - _ -> stack - match' $ litFrame l $ cFrame $ catchAllFrame stack + -- In case of a literal, try also its constructor form + NotBlocked _ (Apply (Arg info v@(Lit l))) -> performedSimplification $ do + cv <- constructorForm v + let cFrame stack = case ignoreSharing cv of + Con c vs -> conFrame c vs stack + _ -> stack + match' $ litFrame l $ cFrame $ catchAllFrame stack - -- In case of a constructor, push the conFrame - NotBlocked (Apply (Arg info (Con c vs))) -> performedSimplification $ - match' $ conFrame c vs $ catchAllFrame $ stack + -- In case of a constructor, push the conFrame + NotBlocked _ (Apply (Arg info (Con c vs))) -> performedSimplification $ + match' $ conFrame c vs $ catchAllFrame $ stack - -- In case of a projection, push the litFrame - NotBlocked (Proj p) -> performedSimplification $ - match' $ projFrame p $ stack + -- In case of a projection, push the litFrame + NotBlocked _ (Proj p) -> performedSimplification $ + match' $ projFrame p $ stack - NotBlocked _ -> no es' + -- Otherwise, we are stuck. If we were stuck before, + -- we keep the old reason, otherwise we give reason StuckOn here. + NotBlocked blocked e -> no (NotBlocked $ stuckOn e blocked) es' -- If we reach the empty stack, then pattern matching was incomplete match' [] = do {- new line here since __IMPOSSIBLE__ does not like the ' in match' -} @@ -193,7 +191,7 @@ -- Andreas, 2013-03-20 recursive invokations of unfoldCorecursion -- need also to instantiate metas, see Issue 826. unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim) -unfoldCorecursionE e@(Proj f) = return $ NotBlocked e +unfoldCorecursionE e@(Proj f) = return $ notBlocked e unfoldCorecursionE (Apply (Arg info v)) = fmap (Apply . Arg info) <$> unfoldCorecursion v diff --git a/src/full/Agda/TypeChecking/Constraints.hs b/src/full/Agda/TypeChecking/Constraints.hs --- a/src/full/Agda/TypeChecking/Constraints.hs +++ b/src/full/Agda/TypeChecking/Constraints.hs @@ -16,15 +16,15 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.LevelConstraints -import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr, checkArguments') +import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Conversion import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Empty --- import {-# SOURCE #-} Agda.TypeChecking.UniversePolymorphism -- RETIRED import Agda.Utils.Except ( MonadError(throwError) ) import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Pretty (prettyShow) #include "undefined.h" import Agda.Utils.Impossible @@ -173,7 +173,7 @@ case inst of BlockedConst t -> do reportSDoc "tc.constr.blocked" 15 $ - text ("blocked const " ++ show m ++ " :=") <+> prettyTCM t + text ("blocked const " ++ prettyShow m ++ " :=") <+> prettyTCM t assignTerm m [] t PostponedTypeCheckingProblem cl unblock -> enterClosure cl $ \prob -> do ifNotM unblock (addConstraint $ UnBlock m) $ do @@ -196,3 +196,4 @@ checkTypeCheckingProblem p = case p of CheckExpr e t -> checkExpr e t CheckArgs eh ei r args t0 t1 k -> checkArguments' eh ei r args t0 t1 k + CheckLambda args body target -> checkPostponedLambda args body target diff --git a/src/full/Agda/TypeChecking/Conversion.hs b/src/full/Agda/TypeChecking/Conversion.hs --- a/src/full/Agda/TypeChecking/Conversion.hs +++ b/src/full/Agda/TypeChecking/Conversion.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Conversion where @@ -45,7 +44,7 @@ import Agda.Interaction.Options import Agda.Utils.Except ( MonadError(catchError, throwError) ) -import Agda.Utils.Functor (($>)) +import Agda.Utils.Functor import Agda.Utils.Monad import Agda.Utils.Maybe import Agda.Utils.Size @@ -59,12 +58,20 @@ mlevel = liftTCM $ (Just <$> primLevel) `catchError` \_ -> return Nothing -} --- | Try whether a computation runs without errors or new constraints. +-- | Try whether a computation runs without errors or new constraints +-- (may create new metas, though). -- Restores state upon failure. tryConversion :: TCM () -> TCM Bool -tryConversion m = (noConstraints m $> True) - `catchError` \ _ -> return False +tryConversion = isJust <.> tryConversion' +-- | Try whether a computation runs without errors or new constraints +-- (may create new metas, though). +-- Return 'Just' the result upon success. +-- Return 'Nothing' and restore state upon failure. +tryConversion' :: TCM a -> TCM (Maybe a) +tryConversion' m = (Just <$> do disableDestructiveUpdate $ noConstraints m) + `catchError` \ _ -> return Nothing + -- | Check if to lists of arguments are the same (and all variables). -- Precondition: the lists have the same length. sameVars :: Elims -> Elims -> Bool @@ -168,7 +175,7 @@ ] ifM (isInstantiatedMeta x) patternViolation {-else-} $ do assignE dir x es v $ compareTermDir dir a - instantiate u + _ <- instantiate u -- () <- seq u' $ return () reportSLn "tc.conv.term.shortcut" 50 $ "shortcut successful\n result: " ++ show u @@ -249,17 +256,17 @@ -- isNeutral Blocked{} = False isNeutral = isNeutral' . fmap ignoreSharing isMeta = isMeta' . fmap ignoreSharing - isNeutral' (NotBlocked Con{}) = return False + isNeutral' (NotBlocked _ Con{}) = return False -- Andreas, 2013-09-18: this is expensive: -- should only do this when copatterns are on - isNeutral' (NotBlocked (Def q _)) = do + isNeutral' (NotBlocked r (Def q _)) = do -- Andreas, 2014-12-06 optimize this using r !! d <- getConstInfo q return $ case d of Defn {theDef = Function {funCopatternLHS = True}} -> False -- a def by copattern can reduce if projected _ -> True - isNeutral' _ = return True - isMeta' (NotBlocked MetaV{}) = True - isMeta' _ = False + isNeutral' _ = return True + isMeta' (NotBlocked _ MetaV{}) = True + isMeta' _ = False reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> text "is eta record type" m <- reduceB m @@ -398,7 +405,7 @@ , text ":" <+> prettyTCM t ] -- Andreas: what happens if I cut out the eta expansion here? -- Answer: Triggers issue 245, does not resolve 348 - (mb',nb') <- ifM (asks envCompareBlocked) ((NotBlocked -*- NotBlocked) <$> reduce (m,n)) $ do + (mb',nb') <- ifM (asks envCompareBlocked) ((notBlocked -*- notBlocked) <$> reduce (m,n)) $ do mb' <- etaExpandBlocked =<< reduceB m nb' <- etaExpandBlocked =<< reduceB n return (mb', nb') @@ -439,7 +446,7 @@ case (ignoreSharing <$> mb, ignoreSharing <$> nb) of -- equate two metas x and y. if y is the younger meta, -- try first y := x and then x := y - (NotBlocked (MetaV x xArgs), NotBlocked (MetaV y yArgs)) + (NotBlocked _ (MetaV x xArgs), NotBlocked _ (MetaV y yArgs)) | x == y -> case intersectVars xArgs yArgs of -- all relevant arguments are variables @@ -473,8 +480,8 @@ try solve1 solve2 -- one side a meta, the other an unblocked term - (NotBlocked (MetaV x es), _) -> assign dir x es n - (_, NotBlocked (MetaV x es)) -> assign rid x es m + (NotBlocked _ (MetaV x es), _) -> assign dir x es n + (_, NotBlocked _ (MetaV x es)) -> assign rid x es m (Blocked{}, Blocked{}) -> checkSyntacticEquality (Blocked{}, _) -> useInjectivity cmp t m n (_,Blocked{}) -> useInjectivity cmp t m n @@ -488,6 +495,7 @@ case (ignoreSharing m, ignoreSharing n) of (Pi{}, Pi{}) -> equalFun m n + (Sort s1, Sort Inf) -> return () (Sort s1, Sort s2) -> compareSort CmpEq s1 s2 (Lit l1, Lit l2) | l1 == l2 -> return () @@ -646,8 +654,8 @@ (Proj{} : _, [] ) -> failure -- could be x.p =?= x for projection p ([] , Apply{} : _) -> failure -- not impossible, see issue 878 (Apply{} : _, [] ) -> failure - (Apply{} : _, Proj{} : _) -> __IMPOSSIBLE__ -- NB: popped up in issue 889 - (Proj{} : _, Apply{} : _) -> __IMPOSSIBLE__ -- but should be impossible + (Apply{} : _, Proj{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- NB: popped up in issue 889 + (Proj{} : _, Apply{} : _) -> __IMPOSSIBLE__ <$ solveAwakeConstraints' True -- but should be impossible (but again in issue 1467) (Apply arg1 : els1, Apply arg2 : els2) -> verboseBracket "tc.conv.elim" 20 "compare Apply" $ do reportSDoc "tc.conv.elim" 10 $ nest 2 $ vcat @@ -683,7 +691,7 @@ -- compare arg1 and arg2 pid <- newProblem_ $ applyRelevanceToContext r $ case r of - Forced -> return () + Forced{} -> return () r | irrelevantOrUnused r -> compareIrrelevant b (unArg arg1) (unArg arg2) _ -> compareWithPol pol (flip compareTerm b) @@ -930,6 +938,10 @@ let fallback = v <$ leqType t1 t2 caseMaybeM (isSizeType t1) fallback $ \ b1 -> do caseMaybeM (isSizeType t2) fallback $ \ b2 -> do + -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203). + ifM (tryConversion $ dontAssignMetas $ leqType t1 t2) (return v) $ {- else -} do + -- A (most probably weaker) alternative is to just check syn.eq. + -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do case b2 of -- @t2 = Size@. We are done! BoundedNo -> return v @@ -963,33 +975,42 @@ compareSort CmpLeq = leqSort -- | Check that the first sort is less or equal to the second. +-- +-- We can put @SizeUniv@ below @Inf@, but otherwise, it is +-- unrelated to the other universes. +-- leqSort :: Sort -> Sort -> TCM () -leqSort s1 s2 = - ifM typeInType (return ()) $ - catchConstraint (SortCmp CmpLeq s1 s2) $ - do (s1,s2) <- reduce (s1,s2) - let postpone = addConstraint (SortCmp CmpLeq s1 s2) - reportSDoc "tc.conv.sort" 30 $ - sep [ text "leqSort" - , nest 2 $ fsep [ prettyTCM s1 <+> text "=<" - , prettyTCM s2 ] - ] - case (s1, s2) of +leqSort s1 s2 = catchConstraint (SortCmp CmpLeq s1 s2) $ do + (s1,s2) <- reduce (s1,s2) + let postpone = addConstraint (SortCmp CmpLeq s1 s2) + no = typeError $ NotLeqSort s1 s2 + yes = return () + reportSDoc "tc.conv.sort" 30 $ + sep [ text "leqSort" + , nest 2 $ fsep [ prettyTCM s1 <+> text "=<" + , prettyTCM s2 ] + ] + case (s1, s2) of - (Type a, Type b) -> leqLevel a b + (_ , Inf ) -> yes - (Prop , Prop ) -> return () - (Type _ , Prop ) -> notLeq s1 s2 + (SizeUniv, _ ) -> equalSort s1 s2 + (_ , SizeUniv) -> equalSort s1 s2 - (Prop , Type _ ) -> return () + (Type a , Type b ) -> unlessM typeInType $ leqLevel a b - (_ , Inf ) -> return () - (Inf , _ ) -> equalSort s1 s2 - (DLub{} , _ ) -> postpone - (_ , DLub{} ) -> postpone - where - notLeq s1 s2 = typeError $ NotLeqSort s1 s2 + (Prop , Prop ) -> yes + (Prop , Type _ ) -> yes + (Type _ , Prop ) -> no + -- (SizeUniv, SizeUniv) -> yes + -- (SizeUniv, _ ) -> no + -- (_ , SizeUniv) -> no + + (Inf , _ ) -> unlessM typeInType $ equalSort s1 s2 + (DLub{} , _ ) -> unlessM typeInType $ postpone + (_ , DLub{} ) -> unlessM typeInType $ postpone + leqLevel :: Level -> Level -> TCM () leqLevel a b = liftTCM $ do reportSDoc "tc.conv.nat" 30 $ @@ -1087,7 +1108,7 @@ meta (Plus _ MetaLevel{}) = True meta _ = False - unneutral (Plus _ (NeutralLevel v)) = v + unneutral (Plus _ (NeutralLevel _ v)) = v unneutral _ = __IMPOSSIBLE__ constant (ClosedLevel n) = n @@ -1246,7 +1267,7 @@ hasMeta ClosedLevel{} = False hasMeta (Plus _ MetaLevel{}) = True hasMeta (Plus _ (BlockedLevel _ v)) = not $ null $ allMetas v - hasMeta (Plus _ (NeutralLevel v)) = not $ null $ allMetas v + hasMeta (Plus _ (NeutralLevel _ v)) = not $ null $ allMetas v hasMeta (Plus _ (UnreducedLevel v)) = not $ null $ allMetas v isThisMeta x (Plus _ (MetaLevel y _)) = x == y @@ -1263,53 +1284,81 @@ -- | Check that the first sort equal to the second. equalSort :: Sort -> Sort -> TCM () -equalSort s1 s2 = +equalSort s1 s2 = do ifM typeInType (return ()) $ catchConstraint (SortCmp CmpEq s1 s2) $ do (s1,s2) <- reduce (s1,s2) let postpone = addConstraint (SortCmp CmpEq s1 s2) - reportSDoc "tc.conv.sort" 30 $ - sep [ text "equalSort" - , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> text "==" - , prettyTCM s2 ] - , nest 2 $ fsep [ text (show s1) <+> text "==" - , text (show s2) ] - ] - ] + yes = return () + no = typeError $ UnequalSorts s1 s2 + + -- Test whether a level is infinity. + isInf ClosedLevel{} = no + isInf (Plus _ l) = case l of + MetaLevel x es -> assignE DirEq x es (Sort Inf) $ equalAtom topSort + -- Andreas, 2015-02-14 + -- This seems to be a hack, as a level meta is instantiated + -- by a sort. + NeutralLevel _ v -> case ignoreSharing v of + Sort Inf -> yes + _ -> no + _ -> no + + -- Equate a level with SizeUniv. + eqSizeUniv l0 = case l0 of + Plus 0 l -> case l of + MetaLevel x es -> assignE DirEq x es (Sort SizeUniv) $ equalAtom topSort + NeutralLevel _ v -> case ignoreSharing v of + Sort SizeUniv -> yes + _ -> no + _ -> no + _ -> no + + reportSDoc "tc.conv.sort" 30 $ sep + [ text "equalSort" + , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> text "==" + , prettyTCM s2 ] + , nest 2 $ fsep [ text (show s1) <+> text "==" + , text (show s2) ] + ] + ] + case (s1, s2) of (Type a , Type b ) -> equalLevel a b - (Prop , Prop ) -> return () - (Type _ , Prop ) -> notEq s1 s2 - (Prop , Type _ ) -> notEq s1 s2 + (SizeUniv, SizeUniv) -> yes + (SizeUniv, Type (Max as@(_:_))) -> mapM_ eqSizeUniv as + (Type (Max as@(_:_)), SizeUniv) -> mapM_ eqSizeUniv as + (SizeUniv, _ ) -> no + (_ , SizeUniv) -> no - (Inf , Inf ) -> return () - (Inf , Type (Max as@(_:_))) -> mapM_ (isInf $ notEq s1 s2) as - (Type (Max as@(_:_)), Inf) -> mapM_ (isInf $ notEq s1 s2) as + (Prop , Prop ) -> yes + (Type _ , Prop ) -> no + (Prop , Type _ ) -> no + + (Inf , Inf ) -> yes + (Inf , Type (Max as@(_:_))) -> mapM_ isInf as + (Type (Max as@(_:_)), Inf) -> mapM_ isInf as -- Andreas, 2014-06-27: -- @Type (Max [])@ (which is Set0) falls through to error. - (Inf , _ ) -> notEq s1 s2 - (_ , Inf ) -> notEq s1 s2 + (Inf , _ ) -> no + (_ , Inf ) -> no -- Andreas, 2014-06-27: Why are there special cases for Set0? - (DLub s1 s2, s0@(Type (Max []))) -> do - equalSort s1 s0 - underAbstraction_ s2 $ \s2 -> equalSort s2 s0 - (s0@(Type (Max [])), DLub s1 s2) -> do - equalSort s0 s1 - underAbstraction_ s2 $ \s2 -> equalSort s0 s2 + -- Andreas, 2015-02-14: Probably because s ⊔ s' = Set0 + -- entailed that both s and s' are Set0. + -- This is no longer true if SizeUniv ⊔ s = s + + -- (DLub s1 s2, s0@(Type (Max []))) -> do + -- equalSort s1 s0 + -- underAbstraction_ s2 $ \s2 -> equalSort s2 s0 + -- (s0@(Type (Max [])), DLub s1 s2) -> do + -- equalSort s0 s1 + -- underAbstraction_ s2 $ \s2 -> equalSort s0 s2 + (DLub{} , _ ) -> postpone (_ , DLub{} ) -> postpone - where - notEq s1 s2 = typeError $ UnequalSorts s1 s2 - - isInf notok ClosedLevel{} = notok - isInf notok (Plus _ l) = case l of - MetaLevel x es -> assignE DirEq x es (Sort Inf) $ equalAtom topSort - NeutralLevel (Shared p) -> isInf notok (Plus 0 $ NeutralLevel $ derefPtr p) - NeutralLevel (Sort Inf) -> return () - _ -> notok --------------------------------------------------------------------------- -- * Definitions diff --git a/src/full/Agda/TypeChecking/Coverage.hs b/src/full/Agda/TypeChecking/Coverage.hs --- a/src/full/Agda/TypeChecking/Coverage.hs +++ b/src/full/Agda/TypeChecking/Coverage.hs @@ -1,9 +1,9 @@ {-# OPTIONS_GHC -fwarn-unused-imports #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} {-| Coverage checking, case splitting, and splitting for refine tactics. @@ -18,19 +18,22 @@ , splitResult ) where +import Prelude hiding (null) + import Control.Monad import Control.Monad.Trans ( lift ) + +#if !MIN_VERSION_base(4,8,0) import Control.Applicative hiding (empty) +#endif -import Data.List -import qualified Data.Set as Set +import Data.List hiding (null) import Data.Set (Set) +import qualified Data.Set as Set import qualified Data.Traversable as Trav -import Agda.Syntax.Position import qualified Agda.Syntax.Common as Common import Agda.Syntax.Common hiding (Arg,Dom) -import qualified Agda.Syntax.Common as C import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern @@ -42,7 +45,7 @@ import Agda.TypeChecking.Monad.Exception import Agda.TypeChecking.Monad.Context -import Agda.TypeChecking.Rules.LHS.Problem (FlexibleVar(..),flexibleVarFromHiding) +import Agda.TypeChecking.Rules.LHS.Problem (flexibleVarFromHiding) import Agda.TypeChecking.Rules.LHS.Unify import Agda.TypeChecking.Rules.LHS.Instantiate (instantiateTel) import Agda.TypeChecking.Rules.LHS (instantiatePattern) @@ -65,6 +68,7 @@ import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Utils.Size import Agda.Utils.Tuple @@ -150,14 +154,14 @@ whenM (optCompletenessCheck <$> pragmaOptions) $ -- report an error if there are uncovered cases unless (null pss) $ - setCurrentRange (getRange cs) $ + setCurrentRange cs $ typeError $ CoverageFailure f (map (map $ fmap namedThing) pss) -- is = indices of unreachable clauses let is = Set.toList $ Set.difference (Set.fromList [0..genericLength cs - 1]) used -- report an error if there are unreachable clauses unless (null is) $ do let unreached = map (cs !!) is - setCurrentRange (getRange unreached) $ + setCurrentRange unreached $ typeError $ UnreachableClauses f (map clausePats unreached) return splitTree @@ -209,7 +213,7 @@ r <- altM1 (split Inductive sc) xs case r of Left err -> case err of - CantSplit c tel us vs _ -> typeError $ CoverageCantSplitOn c tel us vs + CantSplit c tel us vs -> typeError $ CoverageCantSplitOn c tel us vs NotADatatype a -> enterClosure a $ typeError . CoverageCantSplitType IrrelevantDatatype a -> enterClosure a $ typeError . CoverageCantSplitIrrelevantType CoinductiveDatatype a -> enterClosure a $ typeError . CoverageCantSplitType @@ -286,6 +290,7 @@ [ text "split clause telescope: " <+> prettyTCM sctel , text "old permutation : " <+> prettyTCM perm , text "old patterns : " <+> sep (map (prettyTCM . namedArg) ps) + , text "substitution : " <+> text (show sigma) ] reportSDoc "tc.cover.target" 30 $ sep [ text "target type before substitution (variables may be wrong): " <+> do @@ -314,6 +319,23 @@ , scSubst = liftS n $ sigma , scTarget = newTarget } + -- Separate debug printing to find cause of crash (Issue 1374) + reportSDoc "tc.cover.target" 30 $ sep + [ text "new split clause telescope : " <+> prettyTCM sctel' + ] + reportSDoc "tc.cover.target" 30 $ sep + [ text "new split clause permutation : " <+> prettyTCM perm' + ] + reportSDoc "tc.cover.target" 30 $ sep + [ text "new split clause patterns : " <+> sep (map (prettyTCM . namedArg) ps') + ] + reportSDoc "tc.cover.target" 30 $ sep + [ text "new split clause substitution: " <+> text (show $ scSubst sc') + ] + reportSDoc "tc.cover.target" 30 $ sep + [ text "new split clause target : " <+> do + addContext sctel' $ prettyTCM $ fromJust newTarget + ] reportSDoc "tc.cover.target" 20 $ sep [ text "new split clause" , prettyTCM sc' @@ -395,14 +417,12 @@ unifyIndices flex (raise (size gamma) dtype) conIxs givenIxs case r of - NoUnify _ _ _ -> do - debugNoUnify - return Nothing - DontKnow _ -> do + NoUnify {} -> debugNoUnify $> Nothing + + DontKnow{} -> do debugCantSplit throwException $ CantSplit (conName con) (delta1 `abstract` gamma) conIxs givenIxs - (map (var . flexVar) flex) - Unifies sub -> do + Unifies sub -> do debugSubst "sub" sub -- Substitute the constructor for x in Δ₂: Δ₂' = Δ₂[conv/x] @@ -411,14 +431,16 @@ debugTel "delta2'" delta2' -- Compute a substitution ρ : Δ₁ΓΔ₂' → Δ₁(x:D)Δ₂' - let rho = liftS (size delta2') $ conv :# raiseS (size gamma) + let rho = liftS (size delta2') $ consS conv $ raiseS (size gamma) -- [ Var i [] | i <- [0..size delta2' - 1] ] -- ++ [ raise (size delta2') conv ] -- ++ [ Var i [] | i <- [size delta2' + size gamma ..] ] -- Plug the hole with the constructor and apply ρ - -- TODO: Is it really correct to use Nothing here? - let conp = ConP con Nothing $ map (fmap namedVarP) $ teleArgNames gamma + -- Andreas, 2015-05-01 I guess it is fine to use @noConPatternInfo@ + -- as the result of splitting is never used further down the pipeline. + -- After splitting, Agda reloads the file. + let conp = ConP con noConPatternInfo $ map (fmap namedVarP) $ teleArgNames gamma ps = plugHole conp hps ps' = applySubst rho ps -- Δ₁ΓΔ₂' ⊢ ps' debugPlugged ps ps' @@ -585,8 +607,8 @@ -- Split the telescope at the variable -- t = type of the variable, Δ₁ ⊢ t (n, t, delta1, delta2) <- do - let (tel1, C.Dom info (n, t) : tel2) = genericSplitAt (size tel - x - 1) $ telToList tel - return (n, C.Dom info t, telFromList tel1, telFromList tel2) + let (tel1, Common.Dom info (n, t) : tel2) = genericSplitAt (size tel - x - 1) $ telToList tel + return (n, Common.Dom info t, telFromList tel1, telFromList tel2) -- Compute the one hole context of the patterns at the variable (hps, hix) <- do @@ -741,8 +763,9 @@ , text "target = " <+> do caseMaybe target empty $ \ t -> do addContext tel $ prettyTCM t - , text "subst target = " <+> do - caseMaybe target empty $ \ t -> do - addContext tel $ prettyTCM $ applySubst sigma t + -- Triggers crash (see Issue 1374). + -- , text "subst target = " <+> do + -- caseMaybe target empty $ \ t -> do + -- addContext tel $ prettyTCM $ applySubst sigma t ] ] diff --git a/src/full/Agda/TypeChecking/Coverage/Match.hs b/src/full/Agda/TypeChecking/Coverage/Match.hs --- a/src/full/Agda/TypeChecking/Coverage/Match.hs +++ b/src/full/Agda/TypeChecking/Coverage/Match.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE PatternGuards #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveFunctor, + PatternGuards #-} module Agda.TypeChecking.Coverage.Match where @@ -37,10 +38,6 @@ In these substitutions, we look for a column that has only constructor patterns. We try to split on this column first. --} -{- -nonOverlappingCompleteMatches :: [Clause] -> [Arg Pattern] -> Permutation -> Match Nat -nonOverlappingCompleteMatches cs ps perm -} -- | Match the given patterns against a list of clauses diff --git a/src/full/Agda/TypeChecking/DisplayForm.hs b/src/full/Agda/TypeChecking/DisplayForm.hs --- a/src/full/Agda/TypeChecking/DisplayForm.hs +++ b/src/full/Agda/TypeChecking/DisplayForm.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Tools for 'DisplayTerm' and 'DisplayForm'. + module Agda.TypeChecking.DisplayForm where import Control.Applicative @@ -22,6 +23,15 @@ #include "undefined.h" import Agda.Utils.Impossible + +-- | Convert a 'DisplayTerm' into a 'Term'. +dtermToTerm :: DisplayTerm -> Term +dtermToTerm dt = case dt of + DWithApp d ds vs -> dtermToTerm d `apply` (map (defaultArg . dtermToTerm) ds ++ vs) + DCon c args -> Con c $ map (fmap dtermToTerm) args + DDef f es -> Def f $ map (fmap dtermToTerm) es + DDot v -> v + DTerm v -> v -- | Find a matching display form for @q vs@. -- In essence this tries to reqwrite @q vs@ with any diff --git a/src/full/Agda/TypeChecking/DropArgs.hs b/src/full/Agda/TypeChecking/DropArgs.hs --- a/src/full/Agda/TypeChecking/DropArgs.hs +++ b/src/full/Agda/TypeChecking/DropArgs.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} module Agda.TypeChecking.DropArgs where diff --git a/src/full/Agda/TypeChecking/Empty.hs b/src/full/Agda/TypeChecking/Empty.hs --- a/src/full/Agda/TypeChecking/Empty.hs +++ b/src/full/Agda/TypeChecking/Empty.hs @@ -1,4 +1,3 @@ --- {-# LANGUAGE CPP #-} module Agda.TypeChecking.Empty where @@ -15,39 +14,26 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -{- UNUSED --- | Make sure that a type is empty. -isReallyEmptyType :: Range -> Type -> TCM () -isReallyEmptyType r t = noConstraints $ isEmptyType r t --} +-- | Check whether a type is empty. +-- This check may be postponed as emptiness constraint. --- | Check whether a type is empty. Maybe postponed as emptyness constraint. isEmptyType :: Range -> Type -> TCM () isEmptyType r t = do - tb <- reduceB t - let t = ignoreBlocking tb - postpone = addConstraint (IsEmpty r t) - case ignoreSharing . unEl <$> tb of - -- if t is blocked or a meta, we cannot decide emptyness now. postpone - NotBlocked MetaV{} -> postpone - Blocked{} -> postpone - _ -> do + let postpone t = addConstraint $ IsEmpty r t + -- If t is blocked or a meta, we cannot decide emptiness now. Postpone. + ifBlockedType t (\ _ t -> postpone t) $ {- else -} \ t -> do -- from the current context xs:ts, create a pattern list -- xs _ : ts t and try to split on _ (the last variable) - tel0 <- getContextTelescope - let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)] - ps = [ Arg info $ namedVarP x | Dom info (x, _) <- gamma ] - tel = telFromList gamma + tel0 <- getContextTelescope + let gamma = telToList tel0 ++ [domFromArg $ defaultArg (underscore, t)] + ps = [ Arg info $ namedVarP x | Dom info (x, _) <- gamma ] + tel = telFromList gamma - dontAssignMetas $ do + dontAssignMetas $ do r <- splitLast Inductive tel ps - case r of - Left err -> case err of - CantSplit c tel us vs _ -> postpone - -- Andreas, 2012-03-15: allow postponement of emptyness check - -- OLD CODE: traceCall (CheckIsEmpty t) $ typeError $ CoverageCantSplitOn c tel us vs - _ -> typeError $ ShouldBeEmpty t [] + Left (CantSplit c tel us vs) -> postpone t + Left _ -> typeError $ ShouldBeEmpty t [] Right cov -> do let cs = splitClauses cov unless (null cs) $ diff --git a/src/full/Agda/TypeChecking/Errors.hs b/src/full/Agda/TypeChecking/Errors.hs --- a/src/full/Agda/TypeChecking/Errors.hs +++ b/src/full/Agda/TypeChecking/Errors.hs @@ -1,1023 +1,1231 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Agda.TypeChecking.Errors - ( prettyError - , PrettyTCM(..) - , tcErrString - , Warnings(..) - , warningsToError - ) where - -import Prelude hiding (null) - -import Control.Monad.State - -import Data.Function -import Data.List (nub, sortBy, intercalate) -import Data.Maybe -import qualified Data.Map as Map (empty) - -import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) -import qualified Agda.Syntax.Common as Common -import Agda.Syntax.Fixity -import Agda.Syntax.Position -import qualified Agda.Syntax.Info as A -import qualified Agda.Syntax.Concrete as C -import qualified Agda.Syntax.Concrete.Definitions as D -import Agda.Syntax.Abstract as A -import Agda.Syntax.Internal as I -import qualified Agda.Syntax.Abstract.Pretty as P -import Agda.Syntax.Translation.InternalToAbstract -import Agda.Syntax.Translation.AbstractToConcrete -import Agda.Syntax.Scope.Monad (isDatatypeModule) -import Agda.TypeChecking.Monad.Base -import Agda.TypeChecking.Monad.Closure -import Agda.TypeChecking.Monad.Context -import Agda.TypeChecking.Monad.Options -import Agda.TypeChecking.Pretty -import Agda.TypeChecking.Reduce (instantiate) - -import Agda.Utils.Except ( MonadError(catchError) ) -import Agda.Utils.FileName -import Agda.Utils.Function -import Agda.Utils.Monad -import Agda.Utils.Null hiding (empty) -import qualified Agda.Utils.Pretty as P - -#include "undefined.h" -import Agda.Utils.Impossible - ---------------------------------------------------------------------------- --- * Top level function ---------------------------------------------------------------------------- - -{-# SPECIALIZE prettyError :: TCErr -> TCM String #-} -prettyError :: MonadTCM tcm => TCErr -> tcm String -prettyError err = liftTCM $ show <$> prettyError' err [] - where - prettyError' :: TCErr -> [TCErr] -> TCM Doc - prettyError' err errs - | length errs > 3 = fsep ( - pwords "total panic: error when printing error from printing error from printing error." ++ - pwords "I give up! Approximations of errors (original error last):" ) - $$ vcat (map (text . tcErrString) errs) - | otherwise = applyUnless (null errs) (text "panic: error when printing error!" $$) $ do - (prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs)) - `catchError` \ err' -> prettyError' err' (err:errs) ---------------------------------------------------------------------------- --- * Warnings ---------------------------------------------------------------------------- - --- | Warnings. --- --- Invariant: The fields are never empty at the same time. - -data Warnings = Warnings - { unsolvedMetaVariables :: [Range] - -- ^ Meta-variable problems are reported as type errors unless - -- 'optAllowUnsolved' is 'True'. - , unsolvedConstraints :: Constraints - -- ^ Same as 'unsolvedMetaVariables'. - } - --- | Turns warnings into an error. Even if several errors are possible --- only one is raised. -warningsToError :: Warnings -> TCM a -warningsToError (Warnings [] []) = typeError $ SolvedButOpenHoles -warningsToError (Warnings w@(_:_) _) = typeError $ UnsolvedMetas w -warningsToError (Warnings _ w@(_:_)) = typeError $ UnsolvedConstraints w - - ---------------------------------------------------------------------------- --- * Helpers ---------------------------------------------------------------------------- - -sayWhere :: HasRange a => a -> TCM Doc -> TCM Doc -sayWhere x d = applyUnless (null r) (prettyTCM r $$) d - where r = getRange x - -sayWhen :: Range -> Maybe (Closure Call) -> TCM Doc -> TCM Doc -sayWhen r Nothing m = sayWhere r m -sayWhen r (Just cl) m = sayWhere r (m $$ prettyTCM cl) - -panic :: String -> TCM Doc -panic s = fwords $ "Panic: " ++ s - -nameWithBinding :: QName -> TCM Doc -nameWithBinding q = - sep [ prettyTCM q, text "bound at", prettyTCM r ] - where - r = nameBindingSite $ qnameName q - -tcErrString :: TCErr -> String -tcErrString err = show (getRange err) ++ " " ++ case err of - TypeError _ cl -> errorString $ clValue cl - Exception r s -> show r ++ " " ++ s - IOException r e -> show r ++ " " ++ show e - PatternErr{} -> "PatternErr" - {- AbortAssign _ -> "AbortAssign" -- UNUSED -} - -errorString :: TypeError -> String -errorString err = case err of - AmbiguousModule{} -> "AmbiguousModule" - AmbiguousName{} -> "AmbiguousName" - AmbiguousParseForApplication{} -> "AmbiguousParseForApplication" - AmbiguousParseForLHS{} -> "AmbiguousParseForLHS" --- AmbiguousParseForPatternSynonym{} -> "AmbiguousParseForPatternSynonym" - AmbiguousTopLevelModuleName {} -> "AmbiguousTopLevelModuleName" - BadArgumentsToPatternSynonym{} -> "BadArgumentsToPatternSynonym" - TooFewArgumentsToPatternSynonym{} -> "TooFewArgumentsToPatternSynonym" - BothWithAndRHS -> "BothWithAndRHS" - BuiltinInParameterisedModule{} -> "BuiltinInParameterisedModule" - BuiltinMustBeConstructor{} -> "BuiltinMustBeConstructor" - ClashingDefinition{} -> "ClashingDefinition" - ClashingFileNamesFor{} -> "ClashingFileNamesFor" - ClashingImport{} -> "ClashingImport" - ClashingModule{} -> "ClashingModule" - ClashingModuleImport{} -> "ClashingModuleImport" - CompilationError{} -> "CompilationError" - ConstructorPatternInWrongDatatype{} -> "ConstructorPatternInWrongDatatype" - CoverageFailure{} -> "CoverageFailure" - CoverageCantSplitOn{} -> "CoverageCantSplitOn" - CoverageCantSplitIrrelevantType{} -> "CoverageCantSplitIrrelevantType" - CoverageCantSplitType{} -> "CoverageCantSplitType" - CyclicModuleDependency{} -> "CyclicModuleDependency" - DataMustEndInSort{} -> "DataMustEndInSort" --- UNUSED: DataTooManyParameters{} -> "DataTooManyParameters" - CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype" - DifferentArities -> "DifferentArities" - DoesNotConstructAnElementOf{} -> "DoesNotConstructAnElementOf" - DuplicateBuiltinBinding{} -> "DuplicateBuiltinBinding" - DuplicateConstructors{} -> "DuplicateConstructors" - DuplicateFields{} -> "DuplicateFields" - DuplicateImports{} -> "DuplicateImports" - FieldOutsideRecord -> "FieldOutsideRecord" - FileNotFound{} -> "FileNotFound" - GenericError{} -> "GenericError" - GenericDocError{} -> "GenericDocError" - IFSNoCandidateInScope{} -> "IFSNoCandidateInScope" - IlltypedPattern{} -> "IlltypedPattern" - IllformedProjectionPattern{} -> "IllformedProjectionPattern" - CannotEliminateWithPattern{} -> "CannotEliminateWithPattern" - IllegalLetInTelescope{} -> "IllegalLetInTelescope" - IncompletePatternMatching{} -> "IncompletePatternMatching" - IndexVariablesNotDistinct{} -> "IndexVariablesNotDistinct" - IndicesFreeInParameters{} -> "IndicesFreeInParameters" - IndicesNotConstructorApplications{} -> "IndicesNotConstructorApplications" - InternalError{} -> "InternalError" - InvalidPattern{} -> "InvalidPattern" - LocalVsImportedModuleClash{} -> "LocalVsImportedModuleClash" - MetaCannotDependOn{} -> "MetaCannotDependOn" - MetaOccursInItself{} -> "MetaOccursInItself" - ModuleArityMismatch{} -> "ModuleArityMismatch" - ModuleDefinedInOtherFile {} -> "ModuleDefinedInOtherFile" - ModuleDoesntExport{} -> "ModuleDoesntExport" - ModuleNameDoesntMatchFileName {} -> "ModuleNameDoesntMatchFileName" - NeedOptionCopatterns{} -> "NeedOptionCopatterns" - NoBindingForBuiltin{} -> "NoBindingForBuiltin" - NoParseForApplication{} -> "NoParseForApplication" - NoParseForLHS{} -> "NoParseForLHS" --- NoParseForPatternSynonym{} -> "NoParseForPatternSynonym" - NoRHSRequiresAbsurdPattern{} -> "NoRHSRequiresAbsurdPattern" - NotInductive {} -> "NotInductive" - AbsurdPatternRequiresNoRHS{} -> "AbsurdPatternRequiresNoRHS" - NoSuchBuiltinName{} -> "NoSuchBuiltinName" - NoSuchModule{} -> "NoSuchModule" - NoSuchPrimitiveFunction{} -> "NoSuchPrimitiveFunction" - NotAModuleExpr{} -> "NotAModuleExpr" - NotAProperTerm -> "NotAProperTerm" - SetOmegaNotValidType{} -> "SetOmegaNotValidType" - InvalidType{} -> "InvalidType" - NotAValidLetBinding{} -> "NotAValidLetBinding" - NotAnExpression{} -> "NotAnExpression" - NotImplemented{} -> "NotImplemented" - NotSupported{} -> "NotSupported" - NotInScope{} -> "NotInScope" - NotLeqSort{} -> "NotLeqSort" - NotStrictlyPositive{} -> "NotStrictlyPositive" - NothingAppliedToHiddenArg{} -> "NothingAppliedToHiddenArg" - NothingAppliedToInstanceArg{} -> "NothingAppliedToInstanceArg" - OverlappingProjects {} -> "OverlappingProjects" - PatternShadowsConstructor {} -> "PatternShadowsConstructor" - PropMustBeSingleton -> "PropMustBeSingleton" - RepeatedVariablesInPattern{} -> "RepeatedVariablesInPattern" - SafeFlagPostulate{} -> "SafeFlagPostulate" - SafeFlagPragma{} -> "SafeFlagPragma" - SafeFlagNoTerminationCheck{} -> "SafeFlagNoTerminationCheck" - SafeFlagNonTerminating{} -> "SafeFlagNonTerminating" - SafeFlagTerminating{} -> "SafeFlagTerminating" - SafeFlagPrimTrustMe{} -> "SafeFlagPrimTrustMe" - ShadowedModule{} -> "ShadowedModule" - ShouldBeASort{} -> "ShouldBeASort" - ShouldBeApplicationOf{} -> "ShouldBeApplicationOf" - ShouldBeAppliedToTheDatatypeParameters{} -> "ShouldBeAppliedToTheDatatypeParameters" - ShouldBeEmpty{} -> "ShouldBeEmpty" - ShouldBePi{} -> "ShouldBePi" - ShouldBeRecordType{} -> "ShouldBeRecordType" - ShouldBeRecordPattern{} -> "ShouldBeRecordPattern" - NotAProjectionPattern{} -> "NotAProjectionPattern" - ShouldEndInApplicationOfTheDatatype{} -> "ShouldEndInApplicationOfTheDatatype" - SplitError{} -> "SplitError" - TerminationCheckFailed{} -> "TerminationCheckFailed" - TooFewFields{} -> "TooFewFields" - TooManyArgumentsInLHS{} -> "TooManyArgumentsInLHS" - TooManyFields{} -> "TooManyFields" - SplitOnIrrelevant{} -> "SplitOnIrrelevant" - DefinitionIsIrrelevant{} -> "DefinitionIsIrrelevant" - VariableIsIrrelevant{} -> "VariableIsIrrelevant" - UnequalBecauseOfUniverseConflict{} -> "UnequalBecauseOfUniverseConflict" - UnequalRelevance{} -> "UnequalRelevance" - UnequalHiding{} -> "UnequalHiding" --- UnequalLevel{} -> "UnequalLevel" -- UNUSED - UnequalSorts{} -> "UnequalSorts" - UnequalTerms{} -> "UnequalTerms" - UnequalTypes{} -> "UnequalTypes" --- UnequalTelescopes{} -> "UnequalTelescopes" -- UNUSED - UnequalColors{} -> "UnequalTelescopes" - HeterogeneousEquality{} -> "HeterogeneousEquality" - WithOnFreeVariable{} -> "WithOnFreeVariable" - UnexpectedWithPatterns{} -> "UnexpectedWithPatterns" - UninstantiatedDotPattern{} -> "UninstantiatedDotPattern" - UninstantiatedModule{} -> "UninstantiatedModule" - UnreachableClauses{} -> "UnreachableClauses" - UnsolvedConstraints{} -> "UnsolvedConstraints" - UnsolvedMetas{} -> "UnsolvedMetas" - SolvedButOpenHoles{} -> "SolvedButOpenHoles" - UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym" - UnquoteFailed{} -> "UnquoteFailed" - WithClausePatternMismatch{} -> "WithClausePatternMismatch" - WithoutKError{} -> "WithoutKError" - WrongHidingInApplication{} -> "WrongHidingInApplication" - WrongHidingInLHS{} -> "WrongHidingInLHS" - WrongHidingInLambda{} -> "WrongHidingInLambda" - WrongIrrelevanceInLambda{} -> "WrongIrrelevanceInLambda" - WrongNamedArgument{} -> "WrongNamedArgument" - WrongNumberOfConstructorArguments{} -> "WrongNumberOfConstructorArguments" - HidingMismatch{} -> "HidingMismatch" - RelevanceMismatch{} -> "RelevanceMismatch" - ColorMismatch{} -> "ColorMismatch" - -instance PrettyTCM TCErr where - prettyTCM err = case err of - -- Andreas, 2014-03-23 - -- This use of localState seems ok since we do not collect - -- Benchmark info during printing errors. - TypeError s e -> localState $ do - put s - sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e - Exception r s -> sayWhere r $ fwords s - IOException r e -> sayWhere r $ fwords $ show e - PatternErr{} -> sayWhere err $ panic "uncaught pattern violation" - {- AbortAssign _ -> sayWhere err $ panic "uncaught aborted assignment" -- UNUSED -} - -instance PrettyTCM CallInfo where - prettyTCM c = do - let call = prettyTCM $ callInfoCall c - r = callInfoRange c - case show r of - "" -> call - _ -> call $$ nest 2 (text "(at" <+> prettyTCM r <> text ")") - --- | Drops the filename component of the qualified name -dropTopLevelModule :: QName -> QName -dropTopLevelModule (QName (MName ns) n) = QName (MName (drop 1 ns)) n - -instance PrettyTCM TypeError where - prettyTCM err = do - case err of - InternalError s -> panic s - NotImplemented s -> fwords $ "Not implemented: " ++ s - NotSupported s -> fwords $ "Not supported: " ++ s - CompilationError s -> sep [fwords "Compilation error:", text s] - GenericError s -> fwords s - GenericDocError d -> return d - TerminationCheckFailed because -> - fwords "Termination checking failed for the following functions:" - $$ (nest 2 $ fsep $ punctuate comma $ - map (pretty . dropTopLevelModule) $ - concatMap termErrFunctions because) - $$ fwords "Problematic calls:" - $$ (nest 2 $ fmap (P.vcat . nub) $ - mapM prettyTCM $ sortBy (compare `on` callInfoRange) $ - concatMap termErrCalls because) - PropMustBeSingleton -> fwords - "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled" - DataMustEndInSort t -> fsep $ - pwords "The type of a datatype must end in a sort." - ++ [prettyTCM t] ++ pwords "isn't a sort." -{- UNUSED: - DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type." --} - ShouldEndInApplicationOfTheDatatype t -> fsep $ - pwords "The target of a constructor must be the datatype applied to its parameters," - ++ [prettyTCM t] ++ pwords "isn't" - ShouldBeAppliedToTheDatatypeParameters s t -> fsep $ - pwords "The target of the constructor should be" ++ [prettyTCM s] ++ - pwords "instead of" ++ [prettyTCM t] - ShouldBeApplicationOf t q -> fsep $ - pwords "The pattern constructs an element of" ++ [prettyTCM q] ++ - pwords "which is not the right datatype" - ShouldBeRecordType t -> fsep $ - pwords "Expected non-abstract record type, found " ++ [prettyTCM t] - ShouldBeRecordPattern p -> fsep $ - pwords "Expected record pattern" -- ", found " ++ [prettyTCM p] - NotAProjectionPattern p -> fsep $ - pwords "Not a valid projection for a copattern: " ++ [ prettyA p ] - DifferentArities -> - fwords "The number of arguments in the defining equations differ" - WrongHidingInLHS -> do - fwords "Unexpected implicit argument" - WrongHidingInLambda t -> do - fwords "Found an implicit lambda where an explicit lambda was expected" - WrongIrrelevanceInLambda t -> do - fwords "Found an irrelevant lambda where a relevant lambda was expected" - WrongNamedArgument a -> fsep $ - pwords "Function does not accept argument " ++ [prettyTCM a] -- ++ pwords " (wrong argument name)" - WrongHidingInApplication t -> do - fwords "Found an implicit application where an explicit application was expected" - HidingMismatch h h' -> fwords $ - "Expected " ++ verbalize (Indefinite h') ++ " argument, but found " ++ - verbalize (Indefinite h) ++ " argument" - RelevanceMismatch r r' -> fwords $ - "Expected " ++ verbalize (Indefinite r') ++ " argument, but found " ++ - verbalize (Indefinite r) ++ " argument" - ColorMismatch c c' -> fsep $ -- TODO guilhem - pwords "Expected argument color to be" ++ [prettyTCM c'] ++ - pwords "but found color" ++ [prettyTCM c] - NotInductive t -> fsep $ - [prettyTCM t] ++ pwords "is not an inductive data type" - UninstantiatedDotPattern e -> fsep $ - pwords "Failed to infer the value of dotted pattern" - IlltypedPattern p a -> fsep $ - pwords "Type mismatch" - IllformedProjectionPattern p -> fsep $ - pwords "Ill-formed projection pattern " ++ [prettyA p] - CannotEliminateWithPattern p a -> do - let isProj = isJust (isProjP p) - fsep $ - pwords "Cannot eliminate type" ++ prettyTCM a : - if isProj then - pwords "with projection pattern" ++ [prettyA p] - else - pwords "with pattern" ++ prettyA p : - pwords "(did you supply too many arguments?)" - TooManyArgumentsInLHS a -> fsep $ - pwords "Left hand side gives too many arguments to a function of type" ++ [prettyTCM a] - WrongNumberOfConstructorArguments c expect given -> fsep $ - pwords "The constructor" ++ [prettyTCM c] ++ pwords "expects" ++ - [text (show expect)] ++ pwords "arguments (including hidden ones), but has been given" ++ [text (show given)] ++ pwords "(including hidden ones)" - CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $ - pwords ("Can't resolve overloaded constructors targeting the same datatype (" - ++ show (qnameToConcrete d) ++ "):") - ++ map pretty cs - DoesNotConstructAnElementOf c t -> fsep $ - pwords "The constructor" ++ [prettyTCM c] ++ - pwords "does not construct an element of" ++ [prettyTCM t] - ConstructorPatternInWrongDatatype c d -> fsep $ - [prettyTCM c] ++ pwords "is not a constructor of the datatype" ++ [prettyTCM d] - IndicesNotConstructorApplications [i] -> - fwords "The index" - $$ nest 2 (prettyTCM i) - $$ fsep (pwords "is not a constructor (or literal) applied to variables" ++ - pwords "(note that parameters count as constructor arguments)") - IndicesNotConstructorApplications is -> - fwords "The indices" - $$ nest 2 (vcat $ map prettyTCM is) - $$ fsep (pwords "are not constructors (or literals) applied to variables" ++ - pwords "(note that parameters count as constructor arguments)") - IndexVariablesNotDistinct vs is -> - fwords "The variables" - $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs) - $$ fwords "in the indices" - $$ nest 2 (vcat $ map prettyTCM is) - $$ fwords "are not distinct (note that parameters count as constructor arguments)" - IndicesFreeInParameters vs indices pars -> - fwords "The variables" - $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs) - $$ fwords "which are used (perhaps as constructor parameters) in the index expressions" - $$ nest 2 (vcat $ map prettyTCM indices) - $$ fwords "are free in the parameters" - $$ nest 2 (vcat $ map prettyTCM pars) - ShadowedModule x [] -> __IMPOSSIBLE__ - ShadowedModule x ms@(m : _) -> fsep $ - pwords "Duplicate definition of module" ++ [prettyTCM x <> text "."] ++ - pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++ - pwords "at" ++ [prettyTCM r] - where - help m = do - b <- isDatatypeModule m - if b then text "datatype" else empty - - r = case [ r | r <- map (defSiteOfLast . mnameToList) ms - , r /= noRange ] of - [] -> noRange - r : _ -> r - - defSiteOfLast [] = noRange - defSiteOfLast ns = nameBindingSite (last ns) - ModuleArityMismatch m EmptyTel args -> fsep $ - pwords "The module" ++ [prettyTCM m] ++ - pwords "is not parameterized, but is being applied to arguments" - ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $ - pwords "The arguments to " ++ [prettyTCM m] ++ pwords "does not fit the telescope" ++ - [prettyTCM tel] - ShouldBeEmpty t [] -> fsep $ - [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me" - ShouldBeEmpty t ps -> fsep ( - [prettyTCM t] ++ - pwords "should be empty, but the following constructor patterns are valid:" - ) $$ nest 2 (vcat $ map (showPat 0) ps) - - ShouldBeASort t -> fsep $ - [prettyTCM t] ++ pwords "should be a sort, but it isn't" - ShouldBePi t -> fsep $ - [prettyTCM t] ++ pwords "should be a function type, but it isn't" - NotAProperTerm -> - fwords "Found a malformed term" - SetOmegaNotValidType -> - fwords "Setω is not a valid type" - InvalidType v -> fsep $ - [prettyTCM v] ++ pwords "is not a valid type" - SplitOnIrrelevant p t -> fsep $ - pwords "Cannot pattern match" ++ [prettyA p] ++ - pwords "against irrelevant type" ++ [prettyTCM t] - DefinitionIsIrrelevant x -> fsep $ - text "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here" - VariableIsIrrelevant x -> fsep $ - text "Variable" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here" - UnequalBecauseOfUniverseConflict cmp s t -> fsep $ - [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ] - UnequalTerms cmp s t a -> do - (d1, d2, d) <- prettyInEqual s t - fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d] --- UnequalLevel is UNUSED --- UnequalLevel cmp s t -> fsep $ --- [prettyTCM s, notCmp cmp, prettyTCM t] --- UnequalTelescopes is UNUSED --- UnequalTelescopes cmp a b -> fsep $ --- [prettyTCM a, notCmp cmp, prettyTCM b] - UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b --- fsep $ [prettyTCM a, notCmp cmp, prettyTCM b] - UnequalColors a b -> error "TODO guilhem 4" - HeterogeneousEquality u a v b -> fsep $ - pwords "Refuse to solve heterogeneous constraint" ++ - [prettyTCM u] ++ pwords ":" ++ [prettyTCM a] ++ pwords "=?=" ++ - [prettyTCM v] ++ pwords ":" ++ [prettyTCM b] - UnequalRelevance cmp a b -> fsep $ - [prettyTCM a, notCmp cmp, prettyTCM b] ++ --- Andreas 2010-09-21 to reveal Forced annotations, print also uglily --- [text $ show a, notCmp cmp, text $ show b] ++ - pwords "because one is a relevant function type and the other is an irrelevant function type" - UnequalHiding a b -> fsep $ - [prettyTCM a, text "!=", prettyTCM b] ++ - pwords "because one is an implicit function type and the other is an explicit function type" - UnequalSorts s1 s2 -> fsep $ - [prettyTCM s1, text "!=", prettyTCM s2] - NotLeqSort s1 s2 -> fsep $ - pwords "The type of the constructor does not fit in the sort of the datatype, since" - ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2] - TooFewFields r xs -> fsep $ - pwords "Missing fields" ++ punctuate comma (map pretty xs) ++ - pwords "in an element of the record" ++ [prettyTCM r] - TooManyFields r xs -> fsep $ - pwords "The record type" ++ [prettyTCM r] ++ - pwords "does not have the fields" ++ punctuate comma (map pretty xs) - DuplicateConstructors xs -> fsep $ - pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++ - pwords "in datatype" - DuplicateFields xs -> fsep $ - pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++ - pwords "in record" - WithOnFreeVariable e -> fsep $ - pwords "Cannot `with` on variable " ++ [prettyA e] ++ - pwords " bound in a module telescope (or patterns of a parent clause)" - UnexpectedWithPatterns ps -> fsep $ - pwords "Unexpected with patterns" ++ (punctuate (text " |") $ map prettyA ps) - WithClausePatternMismatch p q -> fsep $ - pwords "With clause pattern " ++ [prettyA p] ++ - pwords " is not an instance of its parent pattern " ++ [prettyTCM q] - -- TODO: prettier printing for internal patterns - MetaCannotDependOn m ps i -> fsep $ - pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++ pwords "cannot depend on" ++ [pvar i] ++ - pwords "because it" ++ deps - where - pvar = prettyTCM . I.var - deps = case map pvar ps of - [] -> pwords "does not depend on any variables" - [x] -> pwords "only depends on the variable" ++ [x] - xs -> pwords "only depends on the variables" ++ punctuate comma xs - - MetaOccursInItself m -> fsep $ - pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []] - BuiltinMustBeConstructor s e -> fsep $ - [prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [text s] - NoSuchBuiltinName s -> fsep $ - pwords "There is no built-in thing called" ++ [text s] - DuplicateBuiltinBinding b x y -> fsep $ - pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++ - pwords "previous binding to" ++ [prettyTCM x] - NoBindingForBuiltin x -> fsep $ - pwords "No binding for builtin thing" ++ [text x <> comma] ++ - pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'") - NoSuchPrimitiveFunction x -> fsep $ - pwords "There is no primitive function called" ++ [text x] - BuiltinInParameterisedModule x -> fwords $ - "The BUILTIN pragma cannot appear inside a bound context " ++ - "(for instance, in a parameterised module or as a local declaration)" - IllegalLetInTelescope tb -> fsep $ - -- pwords "The binding" ++ - [pretty tb] ++ - pwords " is not allowed in a telescope here." - NoRHSRequiresAbsurdPattern ps -> fwords $ - "The right-hand side can only be omitted if there " ++ - "is an absurd pattern, () or {}, in the left-hand side." - AbsurdPatternRequiresNoRHS ps -> fwords $ - "The right-hand side must be omitted if there " ++ - "is an absurd pattern, () or {}, in the left-hand side." - LocalVsImportedModuleClash m -> fsep $ - pwords "The module" ++ [text $ show m] ++ - pwords "can refer to either a local module or an imported module" - SolvedButOpenHoles -> text "Module cannot be imported since it has open interaction points" - UnsolvedMetas rs -> - fsep ( pwords "Unsolved metas at the following locations:" ) - $$ nest 2 (vcat $ map prettyTCM rs) - UnsolvedConstraints cs -> - fsep ( pwords "Failed to solve the following constraints:" ) - $$ nest 2 (vcat $ map prettyConstraint cs) - where prettyConstraint :: ProblemConstraint -> TCM Doc - prettyConstraint c = f (prettyTCM c) - where - r = getRange c - f d = if null (show r) then d else d $$ nest 4 (text "[ at" <+> prettyTCM r <+> text "]") - CyclicModuleDependency ms -> - fsep (pwords "cyclic module dependency:") - $$ nest 2 (vcat $ map pretty ms) - FileNotFound x files -> - fsep ( pwords "Failed to find source of module" ++ [pretty x] ++ - pwords "in any of the following locations:" - ) $$ nest 2 (vcat $ map (text . filePath) files) - OverlappingProjects f m1 m2 -> - fsep ( pwords "The file" ++ [text (filePath f)] ++ - pwords "can be accessed via several project roots. Both" ++ - [pretty m1] ++ pwords "and" ++ [pretty m2] ++ - pwords "point to this file." - ) - AmbiguousTopLevelModuleName x files -> - fsep ( pwords "Ambiguous module name. The module name" ++ - [pretty x] ++ - pwords "could refer to any of the following files:" - ) $$ nest 2 (vcat $ map (text . filePath) files) - ClashingFileNamesFor x files -> - fsep ( pwords "Multiple possible sources for module" ++ [text $ show x] ++ - pwords "found:" - ) $$ nest 2 (vcat $ map (text . filePath) files) - ModuleDefinedInOtherFile mod file file' -> fsep $ - pwords "You tried to load" ++ [text (filePath file)] ++ - pwords "which defines the module" ++ [pretty mod <> text "."] ++ - pwords "However, according to the include path this module should" ++ - pwords "be defined in" ++ [text (filePath file') <> text "."] - ModuleNameDoesntMatchFileName given files -> - fsep (pwords "The name of the top level module does not match the file name. The module" ++ - [ pretty given ] ++ pwords "should be defined in one of the following files:") - $$ nest 2 (vcat $ map (text . filePath) files) - BothWithAndRHS -> fsep $ - pwords "Unexpected right hand side" - NotInScope xs -> - fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map name xs) - where - name x = fsep [ pretty x, text "at" <+> prettyTCM (getRange x), suggestion (show x) ] - suggestion s - | elem ':' s = parens $ text "did you forget space around the ':'?" - | elem "->" two = parens $ text "did you forget space around the '->'?" - | otherwise = empty - where - two = zipWith (\a b -> [a,b]) s (tail s) - NoSuchModule x -> fsep $ - pwords "No such module" ++ [pretty x] - AmbiguousName x ys -> vcat - [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++ - pwords "It could refer to any one of" - , nest 2 $ vcat $ map nameWithBinding ys - , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)" - ] - AmbiguousModule x ys -> vcat - [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> text "."] ++ - pwords "It could refer to any one of" - , nest 2 $ vcat $ map help ys - , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)" - ] - where - help :: ModuleName -> TCM Doc - help m = do - b <- isDatatypeModule m - sep [prettyTCM m, if b then text "(datatype module)" else empty] - UninstantiatedModule x -> fsep ( - pwords "Cannot access the contents of the parameterised module" ++ [pretty x <> text "."] ++ - pwords "To do this the module first has to be instantiated. For instance:" - ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ]) - ClashingDefinition x y -> fsep $ - pwords "Multiple definitions of" ++ [pretty x <> text "."] ++ - pwords "Previous definition at" ++ [prettyTCM $ nameBindingSite $ qnameName y] - ClashingModule m1 m2 -> fsep $ - pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2] ++ pwords "clash." - ClashingImport x y -> fsep $ - pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y] - ClashingModuleImport x y -> fsep $ - pwords "Module import clash between" ++ [pretty x, text "and", prettyTCM y] - PatternShadowsConstructor x c -> fsep $ - pwords "The pattern variable" ++ [prettyTCM x] ++ - pwords "has the same name as the constructor" ++ [prettyTCM c] - DuplicateImports m xs -> fsep $ - pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++ - punctuate comma (map pretty xs) - ModuleDoesntExport m xs -> fsep $ - pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++ - punctuate comma (map pretty xs) - NotAModuleExpr e -> fsep $ - pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++ - pwords "where M is a module name. The expression" ++ [pretty e, text "doesn't."] - FieldOutsideRecord -> fsep $ - pwords "Field appearing outside record declaration." - InvalidPattern p -> fsep $ - pretty p : pwords "is not a valid pattern" - RepeatedVariablesInPattern xs -> fsep $ - pwords "Repeated variables in pattern:" ++ map pretty xs - NotAnExpression e -> fsep $ - [pretty e] ++ pwords "is not a valid expression." - NotAValidLetBinding nd -> fwords $ - "Not a valid let-declaration" - NothingAppliedToHiddenArg e -> fsep $ - [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++ - pwords "a function expecting an implicit argument." - NothingAppliedToInstanceArg e -> fsep $ - [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++ - pwords "a function expecting an instance argument." - NoParseForApplication es -> fsep $ - pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es] - AmbiguousParseForApplication es es' -> fsep ( - pwords "Don't know how to parse" ++ [pretty_es <> (text ".")] ++ - pwords "Could mean any one of:" - ) $$ nest 2 (vcat $ map pretty' es') - where - pretty_es :: TCM Doc - pretty_es = pretty $ C.RawApp noRange es - - pretty' :: C.Expr -> TCM Doc - pretty' e = do - p1 <- pretty_es - p2 <- pretty e - pretty $ if show p1 == show p2 then unambiguous e else e - - unambiguous :: C.Expr -> C.Expr - unambiguous (C.OpApp r op xs) | all (isOrdinary . namedArg) xs - = foldl (C.App r) (C.Ident op) $ (map . fmap . fmap) fromOrdinary xs - unambiguous e = e - - isOrdinary :: C.OpApp e -> Bool - isOrdinary (C.Ordinary _) = True - isOrdinary _ = False - - fromOrdinary :: C.OpApp e -> e - fromOrdinary (C.Ordinary e) = e - fromOrdinary _ = __IMPOSSIBLE__ - BadArgumentsToPatternSynonym x -> fsep $ - pwords "Bad arguments to pattern synonym " ++ [prettyTCM x] - TooFewArgumentsToPatternSynonym x -> fsep $ - pwords "Too few arguments to pattern synonym " ++ [prettyTCM x] - UnusedVariableInPatternSynonym -> fsep $ - pwords "Unused variable in pattern synonym." - NoParseForLHS IsLHS p -> fsep $ - pwords "Could not parse the left-hand side" ++ [pretty p] - NoParseForLHS IsPatSyn p -> fsep $ - pwords "Could not parse the pattern synonym" ++ [pretty p] -{- UNUSED - NoParseForPatternSynonym p -> fsep $ - pwords "Could not parse the pattern synonym" ++ [pretty p] --} - AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep ( - pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++ - pwords "Could mean any one of:" - ) $$ nest 2 (vcat $ map pretty' ps) - where - pretty_p :: TCM Doc - pretty_p = pretty p - - pretty' :: C.Pattern -> TCM Doc - pretty' p' = do - p1 <- pretty_p - p2 <- pretty p' - pretty $ if show p1 == show p2 then unambiguousP p' else p' - - -- the entire pattern is shown, not just the ambiguous part, - -- so we need to dig in order to find the OpAppP's. - unambiguousP :: C.Pattern -> C.Pattern - unambiguousP (C.AppP x y) = C.AppP (unambiguousP x) $ (fmap.fmap) unambiguousP y - unambiguousP (C.HiddenP r x) = C.HiddenP r $ fmap unambiguousP x - unambiguousP (C.InstanceP r x) = C.InstanceP r $ fmap unambiguousP x - unambiguousP (C.ParenP r x) = C.ParenP r $ unambiguousP x - unambiguousP (C.AsP r n x) = C.AsP r n $ unambiguousP x - unambiguousP (C.OpAppP r op xs) = foldl C.AppP (C.IdentP op) xs - unambiguousP e = e -{- UNUSED - AmbiguousParseForPatternSynonym p ps -> fsep ( - pwords "Don't know how to parse" ++ [pretty p <> text "."] ++ - pwords "Could mean any one of:" - ) $$ nest 2 (vcat $ map pretty ps) --} - IncompletePatternMatching v args -> fsep $ - pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++ - pwords "No match for" ++ map prettyTCM args - UnreachableClauses f pss -> fsep $ - pwords "Unreachable" ++ pwords (plural (length pss) "clause") - where - plural 1 thing = thing - plural n thing = thing ++ "s" - CoverageFailure f pss -> fsep ( - pwords "Incomplete pattern matching for" ++ [prettyTCM f <> text "."] ++ - pwords "Missing cases:") $$ nest 2 (vcat $ map display pss) - where - display ps = do - ps <- nicify f ps - prettyTCM f <+> fsep (map showArg ps) - - nicify f ps = do - showImp <- showImplicitArguments - if showImp - then return ps - else return ps -- TODO: remove implicit arguments which aren't constructors - - CoverageCantSplitOn c tel cIxs gIxs - | length cIxs /= length gIxs -> __IMPOSSIBLE__ - | otherwise -> addCtxTel tel $ vcat ( - [ fsep $ pwords "I'm not sure if there should be a case for the constructor" ++ - [prettyTCM c <> text ","] ++ - pwords "because I get stuck when trying to solve the following" ++ - pwords "unification problems (inferred index ≟ expected index):" - ] ++ - zipWith (\c g -> nest 2 $ prettyTCM c <+> text "≟" <+> prettyTCM g) cIxs gIxs) - CoverageCantSplitIrrelevantType a -> fsep $ - pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM a] - - CoverageCantSplitType a -> fsep $ - pwords "Cannot split on argument of non-datatype" ++ [prettyTCM a] - - SplitError e -> prettyTCM e - - WithoutKError a u v -> fsep $ - pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++ pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++ pwords "because K has been disabled." - - NotStrictlyPositive d ocs -> fsep $ - pwords "The datatype" ++ [prettyTCM d] ++ pwords "is not strictly positive, because" - ++ prettyOcc "it" ocs - where - prettyOcc _ [] = [] - prettyOcc it (OccCon d c r : ocs) = concat - [ pwords it, pwords "occurs", prettyR r - , pwords "in the constructor", [prettyTCM c], pwords "of" - , [prettyTCM d <> com ocs], prettyOcc "which" ocs - ] - prettyOcc it (OccClause f n r : ocs) = concat - [ pwords it, pwords "occurs", prettyR r - , pwords "in the", [th n], pwords "clause of" - , [prettyTCM f <> com ocs], prettyOcc "which" ocs - ] - prettyR NonPositively = pwords "negatively" - prettyR (ArgumentTo i q) = - pwords "as the" ++ [th i] ++ - pwords "argument to" ++ [prettyTCM q] - th 0 = text "first" - th 1 = text "second" - th 2 = text "third" - th n = text (show $ n - 1) <> text "th" - - com [] = empty - com (_:_) = comma - IFSNoCandidateInScope t -> fsep $ - pwords "No variable of type" ++ [prettyTCM t] ++ pwords "was found in scope." - UnquoteFailed e -> case e of - (BadVisibility msg arg) -> fsep $ - pwords $ "Unable to unquote the argument. It should be `" ++ msg ++ "'." - (ConInsteadOfDef x def con) -> do - fsep $ pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") ++ [prettyTCM x] - (DefInsteadOfCon x def con) -> do - fsep $ pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor") ++ [prettyTCM x] - (NotAConstructor kind t) -> - fwords "Unable to unquote the term" - $$ nest 2 (prettyTCM t) - $$ fwords ("of type " ++ kind ++ ". Reason: not a constructor.") - (NotALiteral kind t) -> - fwords "Unable to unquote the term" - $$ nest 2 (prettyTCM t) - $$ fwords ("of type " ++ kind ++ ". Reason: not a literal value.") - (RhsUsesDottedVar ixs t) -> - fwords "Unable to unquote the term" - $$ nest 2 (prettyTCM t) - $$ fwords "of type Clause. Reason: the right-hand side contains variables that are referring to a dot pattern." - $$ fwords ("Offending De Bruijn indices: " ++ intercalate ", " (map show ixs) ++ ".") - (BlockedOnMeta m) -> __IMPOSSIBLE__ - (UnquotePanic err) -> __IMPOSSIBLE__ - SafeFlagPostulate e -> fsep $ - pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag" - SafeFlagPragma xs -> - let plural | length xs == 1 = "" - | otherwise = "s" - in fsep $ [fwords ("Cannot set OPTION pragma" ++ plural)] - ++ map text xs ++ [fwords "with safe flag."] - SafeFlagNoTerminationCheck -> fsep (pwords "Cannot use NO_TERMINATION_CHECK pragma with safe flag.") - SafeFlagNonTerminating -> fsep (pwords "Cannot use NON_TERMINATING pragma with safe flag.") - SafeFlagTerminating -> fsep (pwords "Cannot use TERMINATING pragma with safe flag.") - SafeFlagPrimTrustMe -> fsep (pwords "Cannot use primTrustMe with safe flag") - NeedOptionCopatterns -> fsep (pwords "Option --copatterns needed to enable destructor patterns") - where - mpar n args - | n > 0 && not (null args) = parens - | otherwise = id - - showArg :: I.Arg I.Pattern -> TCM Doc - showArg (Common.Arg info x) = case getHiding info of - Hidden -> braces $ showPat 0 x - Instance -> dbraces $ showPat 0 x - NotHidden -> showPat 1 x - - showPat :: Integer -> I.Pattern -> TCM Doc - showPat _ (I.VarP _) = text "_" - showPat _ (I.DotP _) = text "._" - showPat n (I.ConP c _ args) = mpar n args $ prettyTCM c <+> fsep (map (showArg . fmap namedThing) args) - showPat _ (I.LitP l) = text (show l) - showPat _ (I.ProjP p) = text (show p) - -notCmp :: Comparison -> TCM Doc -notCmp cmp = text $ "!" ++ show cmp - --- | Print two terms that are supposedly unequal. --- If they print to the same identifier, add some explanation --- why they are different nevertheless. -prettyInEqual :: Term -> Term -> TCM (Doc, Doc, Doc) -prettyInEqual t1 t2 = do - d1 <- prettyTCM t1 - d2 <- prettyTCM t2 - (d1, d2,) <$> do - -- if printed differently, no extra explanation needed - if P.render d1 /= P.render d2 then return P.empty else do - (v1, v2) <- instantiate (t1, t2) - case (ignoreSharing v1, ignoreSharing v2) of - (I.Var i1 _, I.Var i2 _) - | i1 == i2 -> __IMPOSSIBLE__ -- if they're actually the same we would get the error on the arguments instead - | otherwise -> varVar i1 i2 - (I.Def{}, I.Con{}) -> __IMPOSSIBLE__ -- ambiguous identifiers - (I.Con{}, I.Def{}) -> __IMPOSSIBLE__ - (I.Var{}, I.Def{}) -> varDef - (I.Def{}, I.Var{}) -> varDef - (I.Var{}, I.Con{}) -> varCon - (I.Con{}, I.Var{}) -> varCon - _ -> return P.empty - where - varDef = return $ P.parens $ P.fwords "because one is a variable and one a defined identifier" - varCon = return $ P.parens $ P.fwords "because one is a variable and one a constructor" - varVar i j = return $ P.parens $ P.fwords $ "because one has deBruijn index " ++ show i ++ " and the other " ++ show j - -class PrettyUnequal a where - prettyUnequal :: a -> TCM Doc -> a -> TCM Doc - -instance PrettyUnequal Term where - prettyUnequal t1 ncmp t2 = do - (d1, d2, d) <- prettyInEqual t1 t2 - fsep $ return d1 : ncmp : return d2 : return d : [] - -instance PrettyUnequal Type where - prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2) - - -instance PrettyTCM SplitError where - prettyTCM err = case err of - NotADatatype t -> enterClosure t $ \ t -> fsep $ - pwords "Cannot pattern match on non-datatype" ++ [prettyTCM t] - IrrelevantDatatype t -> enterClosure t $ \ t -> fsep $ - pwords "Cannot pattern match on datatype" ++ [prettyTCM t] ++ - pwords "since it is declared irrelevant" - CoinductiveDatatype t -> enterClosure t $ \ t -> fsep $ - pwords "Cannot pattern match on the coinductive type" ++ [prettyTCM t] -{- UNUSED - NoRecordConstructor t -> fsep $ - pwords "Cannot pattern match on record" ++ [prettyTCM t] ++ - pwords "because it has no constructor" - -} - CantSplit c tel cIxs gIxs flex -> prettyTCM (CoverageCantSplitOn c tel cIxs gIxs) - GenericSplitError s -> fsep $ - pwords "Split failed:" ++ pwords s - -instance PrettyTCM Call where - prettyTCM c = case c of - CheckClause t cl _ -> fsep $ - pwords "when checking that the clause" - ++ [P.prettyA cl] ++ pwords "has type" ++ [prettyTCM t] - CheckPattern p tel t _ -> addCtxTel tel $ fsep $ - pwords "when checking that the pattern" - ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t] - CheckLetBinding b _ -> fsep $ - pwords "when checking the let binding" ++ [P.prettyA b] - InferExpr e _ -> fsep $ - pwords "when inferring the type of" ++ [prettyA e] - CheckExprCall e t _ -> fsep $ - pwords "when checking that the expression" - ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t] - IsTypeCall e s _ -> fsep $ - pwords "when checking that the expression" - ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s] - IsType_ e _ -> fsep $ - pwords "when checking that the expression" - ++ [prettyA e] ++ pwords "is a type" - CheckArguments r es t0 t1 _ -> fsep $ - pwords "when checking that" ++ - map hPretty es ++ pwords "are valid arguments to a function of type" ++ [prettyTCM t0] - CheckRecDef _ x ps cs _ -> - fsep $ pwords "when checking the definition of" ++ [prettyTCM x] - CheckDataDef _ x ps cs _ -> - fsep $ pwords "when checking the definition of" ++ [prettyTCM x] - CheckConstructor d _ _ (A.Axiom _ _ _ c _) _ -> fsep $ - pwords "when checking the constructor" ++ [prettyTCM c] ++ - pwords "in the declaration of" ++ [prettyTCM d] - CheckConstructor _ _ _ _ _ -> __IMPOSSIBLE__ - CheckFunDef _ f _ _ -> - fsep $ pwords "when checking the definition of" ++ [prettyTCM f] - CheckPragma _ p _ -> - fsep $ pwords "when checking the pragma" ++ [prettyA $ RangeAndPragma noRange p] - CheckPrimitive _ x e _ -> fsep $ - pwords "when checking that the type of the primitive function" ++ - [prettyTCM x] ++ pwords "is" ++ [prettyA e] - CheckWithFunctionType e _ -> fsep $ - pwords "when checking that the type" ++ - [prettyA e] ++ pwords "of the generated with function is well-formed" - CheckDotPattern e v _ -> fsep $ - pwords "when checking that the given dot pattern" ++ [prettyA e] ++ - pwords "matches the inferred value" ++ [prettyTCM v] - CheckPatternShadowing c _ -> fsep $ - pwords "when checking the clause" ++ [P.prettyA c] - InferVar x _ -> - fsep $ pwords "when inferring the type of" ++ [prettyTCM x] - InferDef _ x _ -> - fsep $ pwords "when inferring the type of" ++ [prettyTCM x] - CheckIsEmpty r t _ -> - fsep $ pwords "when checking that" ++ [prettyTCM t] ++ pwords "has no constructors" - ScopeCheckExpr e _ -> - fsep $ pwords "when scope checking" ++ [pretty e] - ScopeCheckDeclaration d _ -> - fwords "when scope checking the declaration" $$ - nest 2 (pretty $ simpleDecl d) - ScopeCheckLHS x p _ -> - fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++ - pwords "in the definition of" ++ [pretty x] - NoHighlighting _ -> empty - SetRange r _ -> - fsep (pwords "when doing something at") <+> prettyTCM r - CheckSectionApplication _ m1 modapp _ -> fsep $ - pwords "when checking the module application" ++ - [prettyA $ A.Apply info m1 modapp Map.empty Map.empty] - where - info = A.ModuleInfo noRange noRange Nothing Nothing Nothing - - where - hPretty :: I.Arg (Named_ Expr) -> TCM Doc - hPretty a = do - info <- reify $ argInfo a - pretty =<< (abstractToConcreteCtx (hiddenArgumentCtx (getHiding a)) - $ Common.Arg info $ unArg a) - - simpleDecl = D.notSoNiceDeclaration - ---------------------------------------------------------------------------- --- * Natural language ---------------------------------------------------------------------------- - -class Verbalize a where - verbalize :: a -> String - -instance Verbalize Hiding where - verbalize h = - case h of - Hidden -> "hidden" - NotHidden -> "visible" - Instance -> "instance" - -instance Verbalize Relevance where - verbalize r = - case r of - Relevant -> "relevant" - Irrelevant -> "irrelevant" - NonStrict -> "shape-irrelevant" - Forced -> __IMPOSSIBLE__ - UnusedArg -> __IMPOSSIBLE__ - --- | Indefinite article. -data Indefinite a = Indefinite a - -instance Verbalize a => Verbalize (Indefinite a) where - verbalize (Indefinite a) = - case verbalize a of - "" -> "" - w@(c:cs) | c `elem` ['a','e','i','o'] -> "an " ++ w - | otherwise -> "a " ++ w - -- Aarne Ranta would whip me if he saw this. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} + +module Agda.TypeChecking.Errors + ( prettyError + , tcErrString + , Warnings(..) + , warningsToError + ) where + +import Prelude hiding (null) + +import Control.Monad.State + +import Data.Function +import Data.List (nub, sortBy, intercalate) +import Data.Maybe + +import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) +import qualified Agda.Syntax.Common as Common +import Agda.Syntax.Fixity +import Agda.Syntax.Position +import qualified Agda.Syntax.Info as A +import qualified Agda.Syntax.Concrete as C +import qualified Agda.Syntax.Concrete.Definitions as D +import Agda.Syntax.Abstract as A +import Agda.Syntax.Internal as I +import qualified Agda.Syntax.Abstract.Pretty as AP +import Agda.Syntax.Translation.InternalToAbstract +import Agda.Syntax.Translation.AbstractToConcrete +import Agda.Syntax.Scope.Monad (isDatatypeModule) +import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Closure +import Agda.TypeChecking.Monad.Context +import Agda.TypeChecking.Monad.Options +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Reduce (instantiate) + +import Agda.Utils.Except ( MonadError(catchError) ) +import Agda.Utils.FileName +import Agda.Utils.Function +import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.Size +import qualified Agda.Utils.Pretty as P + +#include "undefined.h" +import Agda.Utils.Impossible + +--------------------------------------------------------------------------- +-- * Top level function +--------------------------------------------------------------------------- + +{-# SPECIALIZE prettyError :: TCErr -> TCM String #-} +prettyError :: MonadTCM tcm => TCErr -> tcm String +prettyError err = liftTCM $ show <$> prettyError' err [] + where + prettyError' :: TCErr -> [TCErr] -> TCM Doc + prettyError' err errs + | length errs > 3 = fsep ( + pwords "total panic: error when printing error from printing error from printing error." ++ + pwords "I give up! Approximations of errors (original error last):" ) + $$ vcat (map (text . tcErrString) errs) + | otherwise = applyUnless (null errs) (text "panic: error when printing error!" $$) $ do + (prettyTCM err $$ vcat (map (text . ("when printing error " ++) . tcErrString) errs)) + `catchError` \ err' -> prettyError' err' (err:errs) + +--------------------------------------------------------------------------- +-- * Warnings +--------------------------------------------------------------------------- + +-- | Warnings. +-- +-- Invariant: The fields are never empty at the same time. + +data Warnings = Warnings + { unsolvedMetaVariables :: [Range] + -- ^ Meta-variable problems are reported as type errors unless + -- 'optAllowUnsolved' is 'True'. + , unsolvedConstraints :: Constraints + -- ^ Same as 'unsolvedMetaVariables'. + } + +-- | Turns warnings into an error. Even if several errors are possible +-- only one is raised. +warningsToError :: Warnings -> TCM a +warningsToError (Warnings [] []) = typeError $ SolvedButOpenHoles +warningsToError (Warnings w@(_:_) _) = typeError $ UnsolvedMetas w +warningsToError (Warnings _ w@(_:_)) = typeError $ UnsolvedConstraints w + +--------------------------------------------------------------------------- +-- * Helpers +--------------------------------------------------------------------------- + +sayWhere :: HasRange a => a -> TCM Doc -> TCM Doc +sayWhere x d = applyUnless (null r) (prettyTCM r $$) d + where r = getRange x + +sayWhen :: Range -> Maybe (Closure Call) -> TCM Doc -> TCM Doc +sayWhen r Nothing m = sayWhere r m +sayWhen r (Just cl) m = sayWhere r (m $$ prettyTCM cl) + +panic :: String -> TCM Doc +panic s = fwords $ "Panic: " ++ s + +nameWithBinding :: QName -> TCM Doc +nameWithBinding q = + sep [ prettyTCM q, text "bound at", prettyTCM r ] + where + r = nameBindingSite $ qnameName q + +tcErrString :: TCErr -> String +tcErrString err = show (getRange err) ++ " " ++ case err of + TypeError _ cl -> errorString $ clValue cl + Exception r s -> show r ++ " " ++ show s + IOException r e -> show r ++ " " ++ show e + PatternErr{} -> "PatternErr" + {- AbortAssign _ -> "AbortAssign" -- UNUSED -} + +errorString :: TypeError -> String +errorString err = case err of + AmbiguousModule{} -> "AmbiguousModule" + AmbiguousName{} -> "AmbiguousName" + AmbiguousParseForApplication{} -> "AmbiguousParseForApplication" + AmbiguousParseForLHS{} -> "AmbiguousParseForLHS" +-- AmbiguousParseForPatternSynonym{} -> "AmbiguousParseForPatternSynonym" + AmbiguousTopLevelModuleName {} -> "AmbiguousTopLevelModuleName" + BadArgumentsToPatternSynonym{} -> "BadArgumentsToPatternSynonym" + TooFewArgumentsToPatternSynonym{} -> "TooFewArgumentsToPatternSynonym" + BothWithAndRHS -> "BothWithAndRHS" + BuiltinInParameterisedModule{} -> "BuiltinInParameterisedModule" + BuiltinMustBeConstructor{} -> "BuiltinMustBeConstructor" + ClashingDefinition{} -> "ClashingDefinition" + ClashingFileNamesFor{} -> "ClashingFileNamesFor" + ClashingImport{} -> "ClashingImport" + ClashingModule{} -> "ClashingModule" + ClashingModuleImport{} -> "ClashingModuleImport" + CompilationError{} -> "CompilationError" + ConstructorPatternInWrongDatatype{} -> "ConstructorPatternInWrongDatatype" + CoverageFailure{} -> "CoverageFailure" + CoverageCantSplitOn{} -> "CoverageCantSplitOn" + CoverageCantSplitIrrelevantType{} -> "CoverageCantSplitIrrelevantType" + CoverageCantSplitType{} -> "CoverageCantSplitType" + CyclicModuleDependency{} -> "CyclicModuleDependency" + DataMustEndInSort{} -> "DataMustEndInSort" +-- UNUSED: DataTooManyParameters{} -> "DataTooManyParameters" + CantResolveOverloadedConstructorsTargetingSameDatatype{} -> "CantResolveOverloadedConstructorsTargetingSameDatatype" + DifferentArities -> "DifferentArities" + DoesNotConstructAnElementOf{} -> "DoesNotConstructAnElementOf" + DuplicateBuiltinBinding{} -> "DuplicateBuiltinBinding" + DuplicateConstructors{} -> "DuplicateConstructors" + DuplicateFields{} -> "DuplicateFields" + DuplicateImports{} -> "DuplicateImports" + FieldOutsideRecord -> "FieldOutsideRecord" + FileNotFound{} -> "FileNotFound" + GenericError{} -> "GenericError" + GenericDocError{} -> "GenericDocError" + IFSNoCandidateInScope{} -> "IFSNoCandidateInScope" + IlltypedPattern{} -> "IlltypedPattern" + IllformedProjectionPattern{} -> "IllformedProjectionPattern" + CannotEliminateWithPattern{} -> "CannotEliminateWithPattern" + IllegalLetInTelescope{} -> "IllegalLetInTelescope" + IncompletePatternMatching{} -> "IncompletePatternMatching" + IndexVariablesNotDistinct{} -> "IndexVariablesNotDistinct" + IndicesFreeInParameters{} -> "IndicesFreeInParameters" + IndicesNotConstructorApplications{} -> "IndicesNotConstructorApplications" + InternalError{} -> "InternalError" + InvalidPattern{} -> "InvalidPattern" + LocalVsImportedModuleClash{} -> "LocalVsImportedModuleClash" + MetaCannotDependOn{} -> "MetaCannotDependOn" + MetaOccursInItself{} -> "MetaOccursInItself" + ModuleArityMismatch{} -> "ModuleArityMismatch" + ModuleDefinedInOtherFile {} -> "ModuleDefinedInOtherFile" + ModuleDoesntExport{} -> "ModuleDoesntExport" + ModuleNameDoesntMatchFileName {} -> "ModuleNameDoesntMatchFileName" + NeedOptionCopatterns{} -> "NeedOptionCopatterns" + NoBindingForBuiltin{} -> "NoBindingForBuiltin" + NoParseForApplication{} -> "NoParseForApplication" + NoParseForLHS{} -> "NoParseForLHS" +-- NoParseForPatternSynonym{} -> "NoParseForPatternSynonym" + NoRHSRequiresAbsurdPattern{} -> "NoRHSRequiresAbsurdPattern" + NotInductive {} -> "NotInductive" + AbsurdPatternRequiresNoRHS{} -> "AbsurdPatternRequiresNoRHS" + NoSuchBuiltinName{} -> "NoSuchBuiltinName" + NoSuchModule{} -> "NoSuchModule" + NoSuchPrimitiveFunction{} -> "NoSuchPrimitiveFunction" + NotAModuleExpr{} -> "NotAModuleExpr" + NotAProperTerm -> "NotAProperTerm" + SetOmegaNotValidType{} -> "SetOmegaNotValidType" + InvalidType{} -> "InvalidType" + InvalidTypeSort{} -> "InvalidTypeSort" + FunctionTypeInSizeUniv{} -> "FunctionTypeInSizeUniv" + NotAValidLetBinding{} -> "NotAValidLetBinding" + NotAnExpression{} -> "NotAnExpression" + NotImplemented{} -> "NotImplemented" + NotSupported{} -> "NotSupported" + NotInScope{} -> "NotInScope" + NotLeqSort{} -> "NotLeqSort" + NotStrictlyPositive{} -> "NotStrictlyPositive" + NothingAppliedToHiddenArg{} -> "NothingAppliedToHiddenArg" + NothingAppliedToInstanceArg{} -> "NothingAppliedToInstanceArg" + OverlappingProjects {} -> "OverlappingProjects" + PatternShadowsConstructor {} -> "PatternShadowsConstructor" + PropMustBeSingleton -> "PropMustBeSingleton" + RepeatedVariablesInPattern{} -> "RepeatedVariablesInPattern" + SafeFlagPostulate{} -> "SafeFlagPostulate" + SafeFlagPragma{} -> "SafeFlagPragma" + SafeFlagNoTerminationCheck{} -> "SafeFlagNoTerminationCheck" + SafeFlagNonTerminating{} -> "SafeFlagNonTerminating" + SafeFlagTerminating{} -> "SafeFlagTerminating" + SafeFlagPrimTrustMe{} -> "SafeFlagPrimTrustMe" + ShadowedModule{} -> "ShadowedModule" + ShouldBeASort{} -> "ShouldBeASort" + ShouldBeApplicationOf{} -> "ShouldBeApplicationOf" + ShouldBeAppliedToTheDatatypeParameters{} -> "ShouldBeAppliedToTheDatatypeParameters" + ShouldBeEmpty{} -> "ShouldBeEmpty" + ShouldBePi{} -> "ShouldBePi" + ShouldBeRecordType{} -> "ShouldBeRecordType" + ShouldBeRecordPattern{} -> "ShouldBeRecordPattern" + NotAProjectionPattern{} -> "NotAProjectionPattern" + ShouldEndInApplicationOfTheDatatype{} -> "ShouldEndInApplicationOfTheDatatype" + SplitError{} -> "SplitError" + TerminationCheckFailed{} -> "TerminationCheckFailed" + TooFewFields{} -> "TooFewFields" + TooManyArgumentsInLHS{} -> "TooManyArgumentsInLHS" + TooManyFields{} -> "TooManyFields" + SplitOnIrrelevant{} -> "SplitOnIrrelevant" + DefinitionIsIrrelevant{} -> "DefinitionIsIrrelevant" + VariableIsIrrelevant{} -> "VariableIsIrrelevant" + UnequalBecauseOfUniverseConflict{} -> "UnequalBecauseOfUniverseConflict" + UnequalRelevance{} -> "UnequalRelevance" + UnequalHiding{} -> "UnequalHiding" +-- UnequalLevel{} -> "UnequalLevel" -- UNUSED + UnequalSorts{} -> "UnequalSorts" + UnequalTerms{} -> "UnequalTerms" + UnequalTypes{} -> "UnequalTypes" +-- UnequalTelescopes{} -> "UnequalTelescopes" -- UNUSED + UnequalColors{} -> "UnequalTelescopes" + HeterogeneousEquality{} -> "HeterogeneousEquality" + WithOnFreeVariable{} -> "WithOnFreeVariable" + UnexpectedWithPatterns{} -> "UnexpectedWithPatterns" + UninstantiatedDotPattern{} -> "UninstantiatedDotPattern" + UninstantiatedModule{} -> "UninstantiatedModule" + UnreachableClauses{} -> "UnreachableClauses" + UnsolvedConstraints{} -> "UnsolvedConstraints" + UnsolvedMetas{} -> "UnsolvedMetas" + SolvedButOpenHoles{} -> "SolvedButOpenHoles" + UnusedVariableInPatternSynonym -> "UnusedVariableInPatternSynonym" + UnquoteFailed{} -> "UnquoteFailed" + WithClausePatternMismatch{} -> "WithClausePatternMismatch" + WithoutKError{} -> "WithoutKError" + WrongHidingInApplication{} -> "WrongHidingInApplication" + WrongHidingInLHS{} -> "WrongHidingInLHS" + WrongHidingInLambda{} -> "WrongHidingInLambda" + WrongIrrelevanceInLambda{} -> "WrongIrrelevanceInLambda" + WrongNamedArgument{} -> "WrongNamedArgument" + WrongNumberOfConstructorArguments{} -> "WrongNumberOfConstructorArguments" + HidingMismatch{} -> "HidingMismatch" + RelevanceMismatch{} -> "RelevanceMismatch" + ColorMismatch{} -> "ColorMismatch" + +instance PrettyTCM TCErr where + prettyTCM err = case err of + -- Andreas, 2014-03-23 + -- This use of localState seems ok since we do not collect + -- Benchmark info during printing errors. + TypeError s e -> localState $ do + put s + sayWhen (envRange $ clEnv e) (envCall $ clEnv e) $ prettyTCM e + Exception r s -> sayWhere r $ return s + IOException r e -> sayWhere r $ fwords $ show e + PatternErr{} -> sayWhere err $ panic "uncaught pattern violation" + {- AbortAssign _ -> sayWhere err $ panic "uncaught aborted assignment" -- UNUSED -} + +instance PrettyTCM CallInfo where + prettyTCM c = do + let call = prettyTCM $ callInfoCall c + r = callInfoRange c + if null $ P.pretty r + then call + else call $$ nest 2 (text "(at" <+> prettyTCM r <> text ")") + +-- | Drops the filename component of the qualified name. +dropTopLevelModule :: QName -> QName +dropTopLevelModule (QName (MName ns) n) = QName (MName (drop 1 ns)) n + +instance PrettyTCM TypeError where + prettyTCM err = case err of + InternalError s -> panic s + + NotImplemented s -> fwords $ "Not implemented: " ++ s + + NotSupported s -> fwords $ "Not supported: " ++ s + + CompilationError s -> sep [fwords "Compilation error:", text s] + + GenericError s -> fwords s + + GenericDocError d -> return d + + TerminationCheckFailed because -> + fwords "Termination checking failed for the following functions:" + $$ (nest 2 $ fsep $ punctuate comma $ + map (pretty . dropTopLevelModule) $ + concatMap termErrFunctions because) + $$ fwords "Problematic calls:" + $$ (nest 2 $ fmap (P.vcat . nub) $ + mapM prettyTCM $ sortBy (compare `on` callInfoRange) $ + concatMap termErrCalls because) + + PropMustBeSingleton -> fwords + "Datatypes in Prop must have at most one constructor when proof irrelevance is enabled" + + DataMustEndInSort t -> fsep $ + pwords "The type of a datatype must end in a sort." + ++ [prettyTCM t] ++ pwords "isn't a sort." + +{- UNUSED: + DataTooManyParameters -> fsep $ pwords "Too many parameters given to data type." +-} + + ShouldEndInApplicationOfTheDatatype t -> fsep $ + pwords "The target of a constructor must be the datatype applied to its parameters," + ++ [prettyTCM t] ++ pwords "isn't" + + ShouldBeAppliedToTheDatatypeParameters s t -> fsep $ + pwords "The target of the constructor should be" ++ [prettyTCM s] ++ + pwords "instead of" ++ [prettyTCM t] + + ShouldBeApplicationOf t q -> fsep $ + pwords "The pattern constructs an element of" ++ [prettyTCM q] ++ + pwords "which is not the right datatype" + + ShouldBeRecordType t -> fsep $ + pwords "Expected non-abstract record type, found " ++ [prettyTCM t] + + ShouldBeRecordPattern p -> fsep $ + pwords "Expected record pattern" -- ", found " ++ [prettyTCM p] + + NotAProjectionPattern p -> fsep $ + pwords "Not a valid projection for a copattern: " ++ [ prettyA p ] + + DifferentArities -> + fwords "The number of arguments in the defining equations differ" + + WrongHidingInLHS -> fwords "Unexpected implicit argument" + + WrongHidingInLambda t -> + fwords "Found an implicit lambda where an explicit lambda was expected" + + WrongIrrelevanceInLambda t -> + fwords "Found an irrelevant lambda where a relevant lambda was expected" + + WrongNamedArgument a -> fsep $ + pwords "Function does not accept argument " + ++ [prettyTCM a] -- ++ pwords " (wrong argument name)" + + WrongHidingInApplication t -> + fwords "Found an implicit application where an explicit application was expected" + + HidingMismatch h h' -> fwords $ + "Expected " ++ verbalize (Indefinite h') ++ " argument, but found " ++ + verbalize (Indefinite h) ++ " argument" + + RelevanceMismatch r r' -> fwords $ + "Expected " ++ verbalize (Indefinite r') ++ " argument, but found " ++ + verbalize (Indefinite r) ++ " argument" + + ColorMismatch c c' -> fsep $ -- TODO guilhem + pwords "Expected argument color to be" ++ [prettyTCM c'] ++ + pwords "but found color" ++ [prettyTCM c] + + NotInductive t -> fsep $ + [prettyTCM t] ++ pwords "is not an inductive data type" + + UninstantiatedDotPattern e -> fsep $ + pwords "Failed to infer the value of dotted pattern" + + IlltypedPattern p a -> fsep $ + pwords "Type mismatch" + + IllformedProjectionPattern p -> fsep $ + pwords "Ill-formed projection pattern " ++ [prettyA p] + + CannotEliminateWithPattern p a -> do + let isProj = isJust (isProjP p) + fsep $ + pwords "Cannot eliminate type" ++ prettyTCM a : + if isProj then + pwords "with projection pattern" ++ [prettyA p] + else + pwords "with pattern" ++ prettyA p : + pwords "(did you supply too many arguments?)" + + TooManyArgumentsInLHS a -> fsep $ + pwords "Left hand side gives too many arguments to a function of type" + ++ [prettyTCM a] + + WrongNumberOfConstructorArguments c expect given -> fsep $ + pwords "The constructor" ++ [prettyTCM c] ++ + pwords "expects" ++ [prettyTCM expect] ++ + pwords "arguments (including hidden ones), but has been given" + ++ [prettyTCM given] ++ pwords "(including hidden ones)" + + CantResolveOverloadedConstructorsTargetingSameDatatype d cs -> fsep $ + pwords "Can't resolve overloaded constructors targeting the same datatype" + ++ [(parens $ prettyTCM (qnameToConcrete d)) <> colon] + ++ map pretty cs + + DoesNotConstructAnElementOf c t -> fsep $ + pwords "The constructor" ++ [prettyTCM c] ++ + pwords "does not construct an element of" ++ [prettyTCM t] + + ConstructorPatternInWrongDatatype c d -> fsep $ + [prettyTCM c] ++ pwords "is not a constructor of the datatype" + ++ [prettyTCM d] + + IndicesNotConstructorApplications [i] -> + fwords "The index" + $$ nest 2 (prettyTCM i) + $$ fsep (pwords "is not a constructor (or literal) applied to variables" ++ + pwords "(note that parameters count as constructor arguments)") + + IndicesNotConstructorApplications is -> + fwords "The indices" + $$ nest 2 (vcat $ map prettyTCM is) + $$ fsep (pwords "are not constructors (or literals) applied to variables" ++ + pwords "(note that parameters count as constructor arguments)") + + IndexVariablesNotDistinct vs is -> + fwords "The variables" + $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs) + $$ fwords "in the indices" + $$ nest 2 (vcat $ map prettyTCM is) + $$ fwords "are not distinct (note that parameters count as constructor arguments)" + + IndicesFreeInParameters vs indices pars -> + fwords "The variables" + $$ nest 2 (vcat $ map (\v -> prettyTCM (I.Var v [])) vs) + $$ fwords "which are used (perhaps as constructor parameters) in the index expressions" + $$ nest 2 (vcat $ map prettyTCM indices) + $$ fwords "are free in the parameters" + $$ nest 2 (vcat $ map prettyTCM pars) + + ShadowedModule x [] -> __IMPOSSIBLE__ + + ShadowedModule x ms@(m : _) -> fsep $ + pwords "Duplicate definition of module" ++ [prettyTCM x <> text "."] ++ + pwords "Previous definition of" ++ [help m] ++ pwords "module" ++ [prettyTCM x] ++ + pwords "at" ++ [prettyTCM r] + where + help m = do + b <- isDatatypeModule m + if b then text "datatype" else empty + + r = case [ r | r <- map (defSiteOfLast . mnameToList) ms + , r /= noRange ] of + [] -> noRange + r : _ -> r + + defSiteOfLast [] = noRange + defSiteOfLast ns = nameBindingSite (last ns) + + ModuleArityMismatch m EmptyTel args -> fsep $ + pwords "The module" ++ [prettyTCM m] ++ + pwords "is not parameterized, but is being applied to arguments" + + ModuleArityMismatch m tel@(ExtendTel _ _) args -> fsep $ + pwords "The arguments to " ++ [prettyTCM m] ++ pwords "does not fit the telescope" ++ + [prettyTCM tel] + + ShouldBeEmpty t [] -> fsep $ + [prettyTCM t] ++ pwords "should be empty, but that's not obvious to me" + + ShouldBeEmpty t ps -> fsep ( + [prettyTCM t] ++ + pwords "should be empty, but the following constructor patterns are valid:" + ) $$ nest 2 (vcat $ map (prettyPat 0) ps) + + ShouldBeASort t -> fsep $ + [prettyTCM t] ++ pwords "should be a sort, but it isn't" + + ShouldBePi t -> fsep $ + [prettyTCM t] ++ pwords "should be a function type, but it isn't" + + NotAProperTerm -> fwords "Found a malformed term" + + SetOmegaNotValidType -> fwords "Setω is not a valid type" + + InvalidTypeSort s -> fsep $ [prettyTCM s] ++ pwords "is not a valid type" + InvalidType v -> fsep $ [prettyTCM v] ++ pwords "is not a valid type" + + FunctionTypeInSizeUniv v -> fsep $ + pwords "Functions may not return sizes, thus, function type " ++ + [ prettyTCM v ] ++ pwords " is illegal" + + SplitOnIrrelevant p t -> fsep $ + pwords "Cannot pattern match" ++ [prettyA p] ++ + pwords "against irrelevant type" ++ [prettyTCM t] + + DefinitionIsIrrelevant x -> fsep $ + text "Identifier" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here" + VariableIsIrrelevant x -> fsep $ + text "Variable" : prettyTCM x : pwords "is declared irrelevant, so it cannot be used here" + UnequalBecauseOfUniverseConflict cmp s t -> fsep $ + [prettyTCM s, notCmp cmp, prettyTCM t, text "because this would result in an invalid use of Setω" ] + + UnequalTerms cmp s t a -> do + (d1, d2, d) <- prettyInEqual s t + fsep $ [return d1, notCmp cmp, return d2] ++ pwords "of type" ++ [prettyTCM a] ++ [return d] + +-- UnequalLevel is UNUSED +-- UnequalLevel cmp s t -> fsep $ +-- [prettyTCM s, notCmp cmp, prettyTCM t] + +-- UnequalTelescopes is UNUSED +-- UnequalTelescopes cmp a b -> fsep $ +-- [prettyTCM a, notCmp cmp, prettyTCM b] + + UnequalTypes cmp a b -> prettyUnequal a (notCmp cmp) b +-- fsep $ [prettyTCM a, notCmp cmp, prettyTCM b] + + UnequalColors a b -> error "TODO guilhem 4" + + HeterogeneousEquality u a v b -> fsep $ + pwords "Refuse to solve heterogeneous constraint" ++ + [prettyTCM u] ++ pwords ":" ++ [prettyTCM a] ++ pwords "=?=" ++ + [prettyTCM v] ++ pwords ":" ++ [prettyTCM b] + + UnequalRelevance cmp a b -> fsep $ + [prettyTCM a, notCmp cmp, prettyTCM b] ++ +-- Andreas 2010-09-21 to reveal Forced annotations, print also uglily +-- [text $ show a, notCmp cmp, text $ show b] ++ + pwords "because one is a relevant function type and the other is an irrelevant function type" + + UnequalHiding a b -> fsep $ + [prettyTCM a, text "!=", prettyTCM b] ++ + pwords "because one is an implicit function type and the other is an explicit function type" + + UnequalSorts s1 s2 -> fsep $ + [prettyTCM s1, text "!=", prettyTCM s2] + + NotLeqSort s1 s2 -> fsep $ + pwords "The type of the constructor does not fit in the sort of the datatype, since" + ++ [prettyTCM s1] ++ pwords "is not less or equal than" ++ [prettyTCM s2] + + TooFewFields r xs -> fsep $ + pwords "Missing fields" ++ punctuate comma (map pretty xs) ++ + pwords "in an element of the record" ++ [prettyTCM r] + + TooManyFields r xs -> fsep $ + pwords "The record type" ++ [prettyTCM r] ++ + pwords "does not have the fields" ++ punctuate comma (map pretty xs) + + DuplicateConstructors xs -> fsep $ + pwords "Duplicate constructors" ++ punctuate comma (map pretty xs) ++ + pwords "in datatype" + + DuplicateFields xs -> fsep $ + pwords "Duplicate fields" ++ punctuate comma (map pretty xs) ++ + pwords "in record" + + WithOnFreeVariable e -> fsep $ + pwords "Cannot `with` on variable " ++ [prettyA e] ++ + pwords " bound in a module telescope (or patterns of a parent clause)" + + UnexpectedWithPatterns ps -> fsep $ + pwords "Unexpected with patterns" ++ (punctuate (text " |") $ map prettyA ps) + + WithClausePatternMismatch p q -> fsep $ + pwords "With clause pattern " ++ [prettyA p] ++ + pwords " is not an instance of its parent pattern " ++ [prettyTCM q] + -- TODO: prettier printing for internal patterns + + MetaCannotDependOn m ps i -> fsep $ + pwords "The metavariable" ++ [prettyTCM $ MetaV m []] ++ + pwords "cannot depend on" ++ [pvar i] ++ + pwords "because it" ++ deps + where + pvar = prettyTCM . I.var + deps = case map pvar ps of + [] -> pwords "does not depend on any variables" + [x] -> pwords "only depends on the variable" ++ [x] + xs -> pwords "only depends on the variables" ++ punctuate comma xs + + MetaOccursInItself m -> fsep $ + pwords "Cannot construct infinite solution of metavariable" ++ [prettyTCM $ MetaV m []] + + BuiltinMustBeConstructor s e -> fsep $ + [prettyA e] ++ pwords "must be a constructor in the binding to builtin" ++ [text s] + + NoSuchBuiltinName s -> fsep $ + pwords "There is no built-in thing called" ++ [text s] + + DuplicateBuiltinBinding b x y -> fsep $ + pwords "Duplicate binding for built-in thing" ++ [text b <> comma] ++ + pwords "previous binding to" ++ [prettyTCM x] + + NoBindingForBuiltin x -> fsep $ + pwords "No binding for builtin thing" ++ [text x <> comma] ++ + pwords ("use {-# BUILTIN " ++ x ++ " name #-} to bind it to 'name'") + + NoSuchPrimitiveFunction x -> fsep $ + pwords "There is no primitive function called" ++ [text x] + + BuiltinInParameterisedModule x -> fwords $ + "The BUILTIN pragma cannot appear inside a bound context " ++ + "(for instance, in a parameterised module or as a local declaration)" + + IllegalLetInTelescope tb -> fsep $ + -- pwords "The binding" ++ + [pretty tb] ++ + pwords " is not allowed in a telescope here." + + NoRHSRequiresAbsurdPattern ps -> fwords $ + "The right-hand side can only be omitted if there " ++ + "is an absurd pattern, () or {}, in the left-hand side." + + AbsurdPatternRequiresNoRHS ps -> fwords $ + "The right-hand side must be omitted if there " ++ + "is an absurd pattern, () or {}, in the left-hand side." + + LocalVsImportedModuleClash m -> fsep $ + pwords "The module" ++ [prettyTCM m] ++ + pwords "can refer to either a local module or an imported module" + + SolvedButOpenHoles -> + text "Module cannot be imported since it has open interaction points" + + UnsolvedMetas rs -> + fsep ( pwords "Unsolved metas at the following locations:" ) + $$ nest 2 (vcat $ map prettyTCM rs) + + UnsolvedConstraints cs -> + fsep ( pwords "Failed to solve the following constraints:" ) + $$ nest 2 (vcat $ map prettyConstraint cs) + + where prettyConstraint :: ProblemConstraint -> TCM Doc + prettyConstraint c = f (prettyTCM c) + where + r = getRange c + f d = if null $ P.pretty r + then d + else d $$ nest 4 (text "[ at" <+> prettyTCM r <+> text "]") + + CyclicModuleDependency ms -> + fsep (pwords "cyclic module dependency:") + $$ nest 2 (vcat $ map pretty ms) + + FileNotFound x files -> + fsep ( pwords "Failed to find source of module" ++ [pretty x] ++ + pwords "in any of the following locations:" + ) $$ nest 2 (vcat $ map (text . filePath) files) + + OverlappingProjects f m1 m2 -> + fsep ( pwords "The file" ++ [text (filePath f)] ++ + pwords "can be accessed via several project roots. Both" ++ + [pretty m1] ++ pwords "and" ++ [pretty m2] ++ + pwords "point to this file." + ) + + AmbiguousTopLevelModuleName x files -> + fsep ( pwords "Ambiguous module name. The module name" ++ + [pretty x] ++ + pwords "could refer to any of the following files:" + ) $$ nest 2 (vcat $ map (text . filePath) files) + + ClashingFileNamesFor x files -> + fsep ( pwords "Multiple possible sources for module" + ++ [prettyTCM x] ++ pwords "found:" + ) $$ nest 2 (vcat $ map (text . filePath) files) + + ModuleDefinedInOtherFile mod file file' -> fsep $ + pwords "You tried to load" ++ [text (filePath file)] ++ + pwords "which defines the module" ++ [pretty mod <> text "."] ++ + pwords "However, according to the include path this module should" ++ + pwords "be defined in" ++ [text (filePath file') <> text "."] + + ModuleNameDoesntMatchFileName given files -> + fsep (pwords "The name of the top level module does not match the file name. The module" ++ + [ pretty given ] ++ pwords "should be defined in one of the following files:") + $$ nest 2 (vcat $ map (text . filePath) files) + + BothWithAndRHS -> fsep $ pwords "Unexpected right hand side" + + NotInScope xs -> + fsep (pwords "Not in scope:") $$ nest 2 (vcat $ map name xs) + where + name x = fsep [ pretty x + , text "at" <+> prettyTCM (getRange x) + , suggestion (P.prettyShow x) + ] + suggestion s + | elem ':' s = parens $ text "did you forget space around the ':'?" + | elem "->" two = parens $ text "did you forget space around the '->'?" + | otherwise = empty + where + two = zipWith (\a b -> [a,b]) s (tail s) + + NoSuchModule x -> fsep $ pwords "No such module" ++ [pretty x] + + AmbiguousName x ys -> vcat + [ fsep $ pwords "Ambiguous name" ++ [pretty x <> text "."] ++ + pwords "It could refer to any one of" + , nest 2 $ vcat $ map nameWithBinding ys + , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)" + ] + + AmbiguousModule x ys -> vcat + [ fsep $ pwords "Ambiguous module name" ++ [pretty x <> text "."] ++ + pwords "It could refer to any one of" + , nest 2 $ vcat $ map help ys + , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)" + ] + where + help :: ModuleName -> TCM Doc + help m = do + b <- isDatatypeModule m + sep [prettyTCM m, if b then text "(datatype module)" else empty] + + UninstantiatedModule x -> fsep ( + pwords "Cannot access the contents of the parameterised module" + ++ [pretty x <> text "."] ++ + pwords "To do this the module first has to be instantiated. For instance:" + ) $$ nest 2 (hsep [ text "module", pretty x <> text "'", text "=", pretty x, text "e1 .. en" ]) + + ClashingDefinition x y -> fsep $ + pwords "Multiple definitions of" ++ [pretty x <> text "."] ++ + pwords "Previous definition at" + ++ [prettyTCM $ nameBindingSite $ qnameName y] + + ClashingModule m1 m2 -> fsep $ + pwords "The modules" ++ [prettyTCM m1, text "and", prettyTCM m2] + ++ pwords "clash." + + ClashingImport x y -> fsep $ + pwords "Import clash between" ++ [pretty x, text "and", prettyTCM y] + + ClashingModuleImport x y -> fsep $ + pwords "Module import clash between" ++ [pretty x, text "and", prettyTCM y] + + PatternShadowsConstructor x c -> fsep $ + pwords "The pattern variable" ++ [prettyTCM x] ++ + pwords "has the same name as the constructor" ++ [prettyTCM c] + + DuplicateImports m xs -> fsep $ + pwords "Ambiguous imports from module" ++ [pretty m] ++ pwords "for" ++ + punctuate comma (map pretty xs) + + ModuleDoesntExport m xs -> fsep $ + pwords "The module" ++ [pretty m] ++ pwords "doesn't export the following:" ++ + punctuate comma (map pretty xs) + + NotAModuleExpr e -> fsep $ + pwords "The right-hand side of a module definition must have the form 'M e1 .. en'" ++ + pwords "where M is a module name. The expression" + ++ [pretty e, text "doesn't."] + + FieldOutsideRecord -> fsep $ + pwords "Field appearing outside record declaration." + + InvalidPattern p -> fsep $ + pretty p : pwords "is not a valid pattern" + + RepeatedVariablesInPattern xs -> fsep $ + pwords "Repeated variables in pattern:" ++ map pretty xs + + NotAnExpression e -> fsep $ + [pretty e] ++ pwords "is not a valid expression." + + NotAValidLetBinding nd -> fwords $ + "Not a valid let-declaration" + + NothingAppliedToHiddenArg e -> fsep $ + [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++ + pwords "a function expecting an implicit argument." + + NothingAppliedToInstanceArg e -> fsep $ + [pretty e] ++ pwords "cannot appear by itself. It needs to be the argument to" ++ + pwords "a function expecting an instance argument." + + NoParseForApplication es -> fsep $ + pwords "Could not parse the application" ++ [pretty $ C.RawApp noRange es] + + AmbiguousParseForApplication es es' -> fsep ( + pwords "Don't know how to parse" ++ [pretty_es <> (text ".")] ++ + pwords "Could mean any one of:" + ) $$ nest 2 (vcat $ map pretty' es') + where + pretty_es :: TCM Doc + pretty_es = pretty $ C.RawApp noRange es + + pretty' :: C.Expr -> TCM Doc + pretty' e = do + p1 <- pretty_es + p2 <- pretty e + pretty $ if show p1 == show p2 then unambiguous e else e + + unambiguous :: C.Expr -> C.Expr + unambiguous (C.OpApp r op _ xs) | all (isOrdinary . namedArg) xs + = foldl (C.App r) (C.Ident op) $ (map . fmap . fmap) fromOrdinary xs + unambiguous e = e + + isOrdinary :: C.OpApp e -> Bool + isOrdinary (C.Ordinary _) = True + isOrdinary _ = False + + fromOrdinary :: C.OpApp e -> e + fromOrdinary (C.Ordinary e) = e + fromOrdinary _ = __IMPOSSIBLE__ + + BadArgumentsToPatternSynonym x -> fsep $ + pwords "Bad arguments to pattern synonym " ++ [prettyTCM x] + + TooFewArgumentsToPatternSynonym x -> fsep $ + pwords "Too few arguments to pattern synonym " ++ [prettyTCM x] + + UnusedVariableInPatternSynonym -> fsep $ + pwords "Unused variable in pattern synonym." + + NoParseForLHS IsLHS p -> fsep $ + pwords "Could not parse the left-hand side" ++ [pretty p] + + NoParseForLHS IsPatSyn p -> fsep $ + pwords "Could not parse the pattern synonym" ++ [pretty p] + +{- UNUSED + NoParseForPatternSynonym p -> fsep $ + pwords "Could not parse the pattern synonym" ++ [pretty p] +-} + + AmbiguousParseForLHS lhsOrPatSyn p ps -> fsep ( + pwords "Don't know how to parse" ++ [pretty_p <> text "."] ++ + pwords "Could mean any one of:" + ) $$ nest 2 (vcat $ map pretty' ps) + where + pretty_p :: TCM Doc + pretty_p = pretty p + + pretty' :: C.Pattern -> TCM Doc + pretty' p' = do + p1 <- pretty_p + p2 <- pretty p' + pretty $ if show p1 == show p2 then unambiguousP p' else p' + + -- the entire pattern is shown, not just the ambiguous part, + -- so we need to dig in order to find the OpAppP's. + unambiguousP :: C.Pattern -> C.Pattern + unambiguousP (C.AppP x y) = C.AppP (unambiguousP x) $ (fmap.fmap) unambiguousP y + unambiguousP (C.HiddenP r x) = C.HiddenP r $ fmap unambiguousP x + unambiguousP (C.InstanceP r x) = C.InstanceP r $ fmap unambiguousP x + unambiguousP (C.ParenP r x) = C.ParenP r $ unambiguousP x + unambiguousP (C.AsP r n x) = C.AsP r n $ unambiguousP x + unambiguousP (C.OpAppP r op _ xs) = foldl C.AppP (C.IdentP op) xs + unambiguousP e = e + +{- UNUSED + AmbiguousParseForPatternSynonym p ps -> fsep ( + pwords "Don't know how to parse" ++ [pretty p <> text "."] ++ + pwords "Could mean any one of:" + ) $$ nest 2 (vcat $ map pretty ps) +-} + + IncompletePatternMatching v args -> fsep $ + pwords "Incomplete pattern matching for" ++ [prettyTCM v <> text "."] ++ + pwords "No match for" ++ map prettyTCM args + + UnreachableClauses f pss -> fsep $ + pwords "Unreachable" ++ pwords (plural (length pss) "clause") + where + plural 1 thing = thing + plural n thing = thing ++ "s" + + CoverageFailure f pss -> fsep ( + pwords "Incomplete pattern matching for" ++ [prettyTCM f <> text "."] ++ + pwords "Missing cases:") $$ nest 2 (vcat $ map display pss) + where + display ps = do + ps <- nicify f ps + prettyTCM f <+> fsep (map prettyArg ps) + + nicify f ps = do + showImp <- showImplicitArguments + if showImp + then return ps + else return ps -- TODO: remove implicit arguments which aren't constructors + + CoverageCantSplitOn c tel cIxs gIxs + | length cIxs /= length gIxs -> __IMPOSSIBLE__ + | otherwise -> addCtxTel tel $ vcat ( + [ fsep $ pwords "I'm not sure if there should be a case for the constructor" ++ + [prettyTCM c <> text ","] ++ + pwords "because I get stuck when trying to solve the following" ++ + pwords "unification problems (inferred index ≟ expected index):" + ] ++ + zipWith (\c g -> nest 2 $ prettyTCM c <+> text "≟" <+> prettyTCM g) cIxs gIxs) + + CoverageCantSplitIrrelevantType a -> fsep $ + pwords "Cannot split on argument of irrelevant datatype" ++ [prettyTCM a] + + CoverageCantSplitType a -> fsep $ + pwords "Cannot split on argument of non-datatype" ++ [prettyTCM a] + + SplitError e -> prettyTCM e + + WithoutKError a u v -> fsep $ + pwords "Cannot eliminate reflexive equation" ++ [prettyTCM u] ++ + pwords "=" ++ [prettyTCM v] ++ pwords "of type" ++ [prettyTCM a] ++ + pwords "because K has been disabled." + + NotStrictlyPositive d ocs -> fsep $ + pwords "The datatype" ++ [prettyTCM d] ++ + pwords "is not strictly positive, because" ++ prettyOcc "it" ocs + where + prettyOcc _ [] = [] + prettyOcc it (OccCon d c r : ocs) = concat + [ pwords it, pwords "occurs", prettyR r + , pwords "in the constructor", [prettyTCM c], pwords "of" + , [prettyTCM d <> com ocs], prettyOcc "which" ocs + ] + prettyOcc it (OccClause f n r : ocs) = concat + [ pwords it, pwords "occurs", prettyR r + , pwords "in the", [th n], pwords "clause of" + , [prettyTCM f <> com ocs], prettyOcc "which" ocs + ] + + prettyR NonPositively = pwords "negatively" + prettyR (ArgumentTo i q) = + pwords "as the" ++ [th i] ++ + pwords "argument to" ++ [prettyTCM q] + + th 0 = text "first" + th 1 = text "second" + th 2 = text "third" + th n = prettyTCM (n - 1) <> text "th" + + com [] = empty + com (_:_) = comma + + IFSNoCandidateInScope t -> fsep $ + pwords "No variable of type" ++ [prettyTCM t] ++ pwords "was found in scope." + + UnquoteFailed e -> case e of + BadVisibility msg arg -> fsep $ + pwords $ "Unable to unquote the argument. It should be `" ++ msg ++ "'." + + ConInsteadOfDef x def con -> fsep $ + pwords ("Use " ++ con ++ " instead of " ++ def ++ " for constructor") ++ + [prettyTCM x] + + DefInsteadOfCon x def con -> fsep $ + pwords ("Use " ++ def ++ " instead of " ++ con ++ " for non-constructor") + ++ [prettyTCM x] + + NotAConstructor kind t -> + fwords "Unable to unquote the term" + $$ nest 2 (prettyTCM t) + $$ fwords ("of type " ++ kind ++ ". Reason: not a constructor.") + + NotALiteral kind t -> + fwords "Unable to unquote the term" + $$ nest 2 (prettyTCM t) + $$ fwords ("of type " ++ kind ++ ". Reason: not a literal value.") + + RhsUsesDottedVar ixs t -> + fwords "Unable to unquote the term" + $$ nest 2 (prettyTCM t) + $$ fwords "of type Clause. Reason: the right-hand side contains variables that are referring to a dot pattern." + $$ fwords ("Offending De Bruijn indices: " + ++ intercalate ", " (map P.prettyShow ixs) ++ ".") + + BlockedOnMeta m -> __IMPOSSIBLE__ + + UnquotePanic err -> __IMPOSSIBLE__ + + SafeFlagPostulate e -> fsep $ + pwords "Cannot postulate" ++ [pretty e] ++ pwords "with safe flag" + + SafeFlagPragma xs -> + let plural | length xs == 1 = "" + | otherwise = "s" + in fsep $ [fwords ("Cannot set OPTION pragma" ++ plural)] + ++ map text xs ++ [fwords "with safe flag."] + + SafeFlagNoTerminationCheck -> fsep $ + pwords "Cannot use NO_TERMINATION_CHECK pragma with safe flag." + + SafeFlagNonTerminating -> fsep $ + pwords "Cannot use NON_TERMINATING pragma with safe flag." + + SafeFlagTerminating -> fsep $ + pwords "Cannot use TERMINATING pragma with safe flag." + + SafeFlagPrimTrustMe -> fsep (pwords "Cannot use primTrustMe with safe flag") + + NeedOptionCopatterns -> fsep $ + pwords "Option --copatterns needed to enable destructor patterns" + + where + mpar n args + | n > 0 && not (null args) = parens + | otherwise = id + + prettyArg :: I.Arg I.Pattern -> TCM Doc + prettyArg (Common.Arg info x) = case getHiding info of + Hidden -> braces $ prettyPat 0 x + Instance -> dbraces $ prettyPat 0 x + NotHidden -> prettyPat 1 x + + prettyPat :: Integer -> I.Pattern -> TCM Doc + prettyPat _ (I.VarP _) = text "_" + prettyPat _ (I.DotP _) = text "._" + prettyPat n (I.ConP c _ args) = + mpar n args $ + prettyTCM c <+> fsep (map (prettyArg . fmap namedThing) args) + prettyPat _ (I.LitP l) = prettyTCM l + prettyPat _ (I.ProjP p) = prettyTCM p + +notCmp :: Comparison -> TCM Doc +notCmp cmp = text "!" <> prettyTCM cmp + +-- | Print two terms that are supposedly unequal. +-- If they print to the same identifier, add some explanation +-- why they are different nevertheless. +prettyInEqual :: Term -> Term -> TCM (Doc, Doc, Doc) +prettyInEqual t1 t2 = do + d1 <- prettyTCM t1 + d2 <- prettyTCM t2 + (d1, d2,) <$> do + -- if printed differently, no extra explanation needed + if P.render d1 /= P.render d2 then empty else do + (v1, v2) <- instantiate (t1, t2) + case (ignoreSharing v1, ignoreSharing v2) of + (I.Var i1 _, I.Var i2 _) + | i1 == i2 -> __IMPOSSIBLE__ -- if they're actually the same we would get the error on the arguments instead + | otherwise -> varVar i1 i2 + (I.Def{}, I.Con{}) -> __IMPOSSIBLE__ -- ambiguous identifiers + (I.Con{}, I.Def{}) -> __IMPOSSIBLE__ + (I.Var{}, I.Def{}) -> varDef + (I.Def{}, I.Var{}) -> varDef + (I.Var{}, I.Con{}) -> varCon + (I.Con{}, I.Var{}) -> varCon + _ -> empty + where + varDef, varCon :: TCM Doc + varDef = parens $ fwords "because one is a variable and one a defined identifier" + varCon = parens $ fwords "because one is a variable and one a constructor" + + varVar :: Int -> Int -> TCM Doc + varVar i j = parens $ fwords $ + "because one has deBruijn index " ++ show i + ++ " and the other " ++ show j + +class PrettyUnequal a where + prettyUnequal :: a -> TCM Doc -> a -> TCM Doc + +instance PrettyUnequal Term where + prettyUnequal t1 ncmp t2 = do + (d1, d2, d) <- prettyInEqual t1 t2 + fsep $ return d1 : ncmp : return d2 : return d : [] + +instance PrettyUnequal Type where + prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2) + +instance PrettyTCM SplitError where + prettyTCM err = case err of + NotADatatype t -> enterClosure t $ \ t -> fsep $ + pwords "Cannot pattern match on non-datatype" ++ [prettyTCM t] + + IrrelevantDatatype t -> enterClosure t $ \ t -> fsep $ + pwords "Cannot pattern match on datatype" ++ [prettyTCM t] ++ + pwords "since it is declared irrelevant" + + CoinductiveDatatype t -> enterClosure t $ \ t -> fsep $ + pwords "Cannot pattern match on the coinductive type" ++ [prettyTCM t] + +{- UNUSED + NoRecordConstructor t -> fsep $ + pwords "Cannot pattern match on record" ++ [prettyTCM t] ++ + pwords "because it has no constructor" + -} + + CantSplit c tel cIxs gIxs -> + prettyTCM $ CoverageCantSplitOn c tel cIxs gIxs + + GenericSplitError s -> fsep $ pwords "Split failed:" ++ pwords s + +instance PrettyTCM Call where + prettyTCM c = case c of + CheckClause t cl _ -> fsep $ + pwords "when checking that the clause" + ++ [AP.prettyA cl] ++ pwords "has type" ++ [prettyTCM t] + + CheckPattern p tel t _ -> addCtxTel tel $ fsep $ + pwords "when checking that the pattern" + ++ [prettyA p] ++ pwords "has type" ++ [prettyTCM t] + + CheckLetBinding b _ -> fsep $ + pwords "when checking the let binding" ++ [AP.prettyA b] + + InferExpr e _ -> fsep $ pwords "when inferring the type of" ++ [prettyA e] + + CheckExprCall e t _ -> fsep $ + pwords "when checking that the expression" + ++ [prettyA e] ++ pwords "has type" ++ [prettyTCM t] + + IsTypeCall e s _ -> fsep $ + pwords "when checking that the expression" + ++ [prettyA e] ++ pwords "is a type of sort" ++ [prettyTCM s] + + IsType_ e _ -> fsep $ + pwords "when checking that the expression" + ++ [prettyA e] ++ pwords "is a type" + + CheckArguments r es t0 t1 _ -> fsep $ + pwords "when checking that" ++ + map hPretty es ++ + pwords (singPlural es "is a valid argument" "are valid arguments") ++ + pwords "to a function of type" ++ + [prettyTCM t0] + + CheckRecDef _ x ps cs _ -> + fsep $ pwords "when checking the definition of" ++ [prettyTCM x] + + CheckDataDef _ x ps cs _ -> + fsep $ pwords "when checking the definition of" ++ [prettyTCM x] + + CheckConstructor d _ _ (A.Axiom _ _ _ c _) _ -> fsep $ + pwords "when checking the constructor" ++ [prettyTCM c] ++ + pwords "in the declaration of" ++ [prettyTCM d] + + CheckConstructor{} -> __IMPOSSIBLE__ + + CheckFunDef _ f _ _ -> + fsep $ pwords "when checking the definition of" ++ [prettyTCM f] + + CheckPragma _ p _ -> + fsep $ pwords "when checking the pragma" + ++ [prettyA $ RangeAndPragma noRange p] + + CheckPrimitive _ x e _ -> fsep $ + pwords "when checking that the type of the primitive function" ++ + [prettyTCM x] ++ pwords "is" ++ [prettyA e] + + CheckWithFunctionType e _ -> fsep $ + pwords "when checking that the type" ++ + [prettyA e] ++ pwords "of the generated with function is well-formed" + + CheckDotPattern e v _ -> fsep $ + pwords "when checking that the given dot pattern" ++ [prettyA e] ++ + pwords "matches the inferred value" ++ [prettyTCM v] + + CheckPatternShadowing c _ -> fsep $ + pwords "when checking the clause" ++ [AP.prettyA c] + + InferVar x _ -> + fsep $ pwords "when inferring the type of" ++ [prettyTCM x] + + InferDef _ x _ -> + fsep $ pwords "when inferring the type of" ++ [prettyTCM x] + + CheckIsEmpty r t _ -> + fsep $ pwords "when checking that" ++ [prettyTCM t] ++ + pwords "has no constructors" + + ScopeCheckExpr e _ -> fsep $ pwords "when scope checking" ++ [pretty e] + + ScopeCheckDeclaration d _ -> + fwords "when scope checking the declaration" $$ + nest 2 (pretty $ simpleDecl d) + + ScopeCheckLHS x p _ -> + fsep $ pwords "when scope checking the left-hand side" ++ [pretty p] ++ + pwords "in the definition of" ++ [pretty x] + + NoHighlighting _ -> empty + + SetRange r _ -> fsep (pwords "when doing something at") <+> prettyTCM r + + CheckSectionApplication _ m1 modapp _ -> fsep $ + pwords "when checking the module application" ++ + [prettyA $ A.Apply info m1 modapp empty empty] + where + info = A.ModuleInfo noRange noRange Nothing Nothing Nothing + + where + hPretty :: I.Arg (Named_ Expr) -> TCM Doc + hPretty a = do + info <- reify $ argInfo a + pretty =<< abstractToConcreteCtx (hiddenArgumentCtx (getHiding a)) + (Common.Arg info $ unArg a) + + simpleDecl = D.notSoNiceDeclaration + +--------------------------------------------------------------------------- +-- * Natural language +--------------------------------------------------------------------------- + +class Verbalize a where + verbalize :: a -> String + +instance Verbalize Hiding where + verbalize h = + case h of + Hidden -> "hidden" + NotHidden -> "visible" + Instance -> "instance" + +instance Verbalize Relevance where + verbalize r = + case r of + Relevant -> "relevant" + Irrelevant -> "irrelevant" + NonStrict -> "shape-irrelevant" + Forced{} -> __IMPOSSIBLE__ + UnusedArg -> __IMPOSSIBLE__ + +-- | Indefinite article. +data Indefinite a = Indefinite a + +instance Verbalize a => Verbalize (Indefinite a) where + verbalize (Indefinite a) = + case verbalize a of + "" -> "" + w@(c:cs) | c `elem` ['a','e','i','o'] -> "an " ++ w + | otherwise -> "a " ++ w + -- Aarne Ranta would whip me if he saw this. + +singPlural :: Sized a => a -> c -> c -> c +singPlural xs singular plural = if size xs == 1 then singular else plural diff --git a/src/full/Agda/TypeChecking/EtaContract.hs b/src/full/Agda/TypeChecking/EtaContract.hs --- a/src/full/Agda/TypeChecking/EtaContract.hs +++ b/src/full/Agda/TypeChecking/EtaContract.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards #-} -- | Compute eta short normal forms. module Agda.TypeChecking.EtaContract where @@ -57,7 +57,9 @@ | otherwise = noApp -- | Contracts all eta-redexes it sees without reducing. -etaContract :: TermLike a => a -> TCM a +{-# SPECIALIZE etaContract :: TermLike a => a -> TCM a #-} +{-# SPECIALIZE etaContract :: TermLike a => a -> ReduceM a #-} +etaContract :: (MonadReader TCEnv m, HasConstInfo m, TermLike a) => a -> m a etaContract = traverseTermM etaOnce {-# SPECIALIZE etaOnce :: Term -> TCM Term #-} @@ -81,7 +83,7 @@ isVar0 (Shared p) = __IMPOSSIBLE__ -- isVar0 (derefPtr p) isVar0 (Var 0 []) = True isVar0 (Level (Max [Plus 0 l])) = case l of - NeutralLevel v -> isVar0 v + NeutralLevel _ v -> isVar0 v UnreducedLevel v -> isVar0 v BlockedLevel{} -> False MetaLevel{} -> False diff --git a/src/full/Agda/TypeChecking/Forcing.hs b/src/full/Agda/TypeChecking/Forcing.hs --- a/src/full/Agda/TypeChecking/Forcing.hs +++ b/src/full/Agda/TypeChecking/Forcing.hs @@ -1,32 +1,113 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-| A constructor argument is forced if it appears as pattern variable +in an index of the target. + +For instance @x@ is forced in @sing@ and @n@ is forced in @zero@ and @suc@: + +@ + data Sing {a}{A : Set a} : A -> Set where + sing : (x : A) -> Sing x + + data Fin : Nat -> Set where + zero : (n : Nat) -> Fin (suc n) + suc : (n : Nat) (i : Fin n) -> Fin (suc n) +@ + +At runtime, forced constructor arguments may be erased as they can be +recovered from dot patterns. In the epic backend, +@ + unsing : {A : Set} (x : A) -> Sing x -> A + unsing .x (sing x) = x +@ +becomes +@ + unsing x sing = x +@ +and +@ + proj : (n : Nat) (i : Fin n) -> Nat + proj .(suc n) (zero n) = n + proj .(suc n) (suc n i) = n +@ +becomes +@ + proj (suc n) zero = n + proj (suc n) (suc i) = n +@ + +Forcing is a concept from pattern matching and thus builds on the +concept of equality (I) used there (closed terms, extensional) which is +different from the equality (II) used in conversion checking and the +constraint solver (open terms, intensional). + +Up to issue 1441 (Feb 2015), the forcing analysis here relied on the +wrong equality (II), considering type constructors as injective. This is +unsound for Epic's program extraction, but ok if forcing is only used +to decide which arguments to skip during conversion checking. + +From now on, forcing uses equality (I) and does not search for forced +variables under type constructors. This may lose some savings during +conversion checking. If this turns out to be a problem, the old +forcing could be brought back, using a new modality @Skip@ to indicate +that this is a relevant argument but still can be skipped during +conversion checking as it is forced by equality (II). + +-} + module Agda.TypeChecking.Forcing where +import Prelude hiding (elem, maximum) + import Control.Applicative +import Data.Foldable +import Data.Traversable +import Agda.Interaction.Options + import Agda.Syntax.Common import Agda.Syntax.Internal + import Agda.TypeChecking.Monad import Agda.TypeChecking.Irrelevance +import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import Agda.Utils.Size +import Agda.TypeChecking.Conversion + +import Agda.Utils.Function import Agda.Utils.Monad -import Agda.Interaction.Options +import Agda.Utils.Size #include "undefined.h" import Agda.Utils.Impossible +-- | Given the type of a constructor (excluding the parameters), +-- decide which arguments are forced. +-- Update the relevance info in the domains accordingly. +-- Precondition: the type is of the form @Γ → D vs@ and the @vs@ +-- are in normal form. addForcingAnnotations :: Type -> TCM Type addForcingAnnotations t = ifM (not . optForcing <$> commandLineOptions) (return t) $ do + -- Andreas, 2015-03-10 Normalization prevents Issue 1454. -- t <- normalise t - let TelV tel (El _ a) = telView' t + -- Andreas, 2015-03-28 Issue 1469: Normalization too costly. + -- Instantiation also fixes Issue 1454. + -- Note that normalization of s0 below does not help. + t <- instantiateFull t + let TelV tel (El s a) = telView' t + vs = case ignoreSharing a of + Def _ us -> us + _ -> __IMPOSSIBLE__ n = size tel indexToLevel x = n - x - 1 - xs <- filter (>=0) . map indexToLevel <$> forcedVariables a - let t' = force xs t - reportSLn "tc.force" 10 $ unlines + -- Note: data parameters will be negative levels. + let xs = filter (>=0) $ map indexToLevel $ forcedVariables vs + let s0 = raise (0 - size tel) s + t' <- force s0 xs t + reportSLn "tc.force" 60 $ unlines [ "Forcing analysis" , " xs = " ++ show xs , " t = " ++ show t @@ -34,43 +115,36 @@ ] return t' -forcedVariables :: Term -> TCM [Nat] -forcedVariables t = case t of - Var i [] -> return [i] - Con _ vs -> forcedArgs vs - Def d vs -> - ifM (isInj d) - (forcedElims vs) - (return []) - Pi a (NoAbs _ b) -> - (++) <$> forcedVariables (unEl $ unDom a) - <*> forcedVariables (unEl b) - Pi a b -> (++) <$> forcedVariables (unEl $ unDom a) - <*> (underBinder <$> forcedVariables (unEl $ absBody b)) - -- Sorts? - _ -> return [] - where - underBinder xs = [ x - 1 | x <- xs, x /= 0 ] - forcedArgs vs = concat <$> mapM (forcedVariables . unArg) vs - forcedElims es = concat <$> mapM (forcedVariables . unArg) (argsFromElims es) - isInj d = do - def <- getConstInfo d - return $ case theDef def of - Datatype{} -> True - Record{} -> True - -- Axiom{} -> True -- Postulates are not injective in general, right? /Olle 2011-05-05 - _ -> False +-- | Compute the pattern variables of a term or term-like thing. +class ForcedVariables a where + forcedVariables :: a -> [Nat] -force :: [Nat] -> Type -> Type -force xs t = aux 0 t +instance (ForcedVariables a, Foldable t) => ForcedVariables (t a) where + forcedVariables = foldMap forcedVariables + +-- | Assumes that the term is in normal form. +instance ForcedVariables Term where + forcedVariables t = case ignoreSharing t of + Var i [] -> [i] + Con _ vs -> forcedVariables vs + _ -> [] + +-- | @force s xs t@ marks the domains @xs@ in function type @t@ as forced. +-- Domains bigger than @s@ are marked as @'Forced' 'Big'@, others as +-- @'Forced' 'Small'@. +-- Counting left-to-right, starting with 0. +-- Precondition: function type is exposed. +force :: Sort -> [Nat] -> Type -> TCM Type +force s0 xs t = loop 0 t where - m = maximum (-1:xs) - aux i t | i > m = t - aux i t = case ignoreSharingType t of - El s (Pi a b) -> El s $ Pi (upd a) (fmap (aux (i + 1)) b) + m = maximum (-1:xs) -- number of domains to look at + loop i t | i > m = return t + loop i t = case ignoreSharingType t of + El s (Pi a b) -> do + a' <- if not (i `elem` xs) then return a else do + -- If the sort of the data type is >= the sort of the argument type + -- then the index is small, else big. + b <- ifM (tryConversion $ leqSort (getSort a) (raise i s0)) (return Small) (return Big) + return $ mapRelevance (composeRelevance $ Forced b) a + El s . Pi a' <$> traverse (loop $ i + 1) b _ -> __IMPOSSIBLE__ - where - upd a | i `elem` xs = a { domInfo = mapRelevance - (composeRelevance Forced) - (domInfo a) } - | otherwise = a diff --git a/src/full/Agda/TypeChecking/Free.hs b/src/full/Agda/TypeChecking/Free.hs --- a/src/full/Agda/TypeChecking/Free.hs +++ b/src/full/Agda/TypeChecking/Free.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} -- | Computing the free variables of a term. -- @@ -280,6 +279,7 @@ Type a -> freeVars' a Prop -> mempty Inf -> mempty + SizeUniv -> mempty DLub s1 s2 -> weakly <$> freeVars' (s1, s2) instance Free Level where @@ -292,7 +292,7 @@ instance Free LevelAtom where freeVars' l = case l of MetaLevel _ vs -> flexible <$> freeVars' vs - NeutralLevel v -> freeVars' v + NeutralLevel _ v -> freeVars' v BlockedLevel _ v -> freeVars' v UnreducedLevel v -> freeVars' v diff --git a/src/full/Agda/TypeChecking/Implicit.hs b/src/full/Agda/TypeChecking/Implicit.hs --- a/src/full/Agda/TypeChecking/Implicit.hs +++ b/src/full/Agda/TypeChecking/Implicit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-| Functions for inserting implicit arguments at the right places. @@ -52,26 +52,6 @@ newMeta Hidden = newNamedValueMeta RunMetaOccursCheck newMeta Instance = initializeIFSMeta newMeta _ = __IMPOSSIBLE__ - -{- UNUSED, BUT DONT REMOVE (Andreas, 2012-07-31) -introImplicits :: (Hiding -> Bool) -> Type -> (Int -> Type -> TCM a) -> TCM a -introImplicits expand t cont = do - TelV tel t0 <- telViewUpTo' (-1) (expand . domHiding) t - addCtxTel tel $ cont (size tel) t0 --} - -{- POINTLESS, NEEDS TO BE CONTINUATION-PASSING --- | @introImplicits expand t@ introduces domain types of @t@ --- into the context, as long as @expand@ holds on them. -introImplicits :: (Hiding -> Bool) -> Type -> TCM (Int, Type) -introImplicits expand t = do - t <- reduce t - case unEl t of - Pi dom@(Dom h rel a) b | expand h -> - addCtxString (absName b) dom $ do - mapFst (+1) <$> introImplicits expand (absBody b) - _ -> return (0, t) --} --------------------------------------------------------------------------- diff --git a/src/full/Agda/TypeChecking/Injectivity.hs b/src/full/Agda/TypeChecking/Injectivity.hs --- a/src/full/Agda/TypeChecking/Injectivity.hs +++ b/src/full/Agda/TypeChecking/Injectivity.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} module Agda.TypeChecking.Injectivity where @@ -193,9 +193,9 @@ , text " ps =" <+> prettyList (map (text . show) ps) ] -- and this is the order the variables occur in the patterns - let ms' = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms - let sub = parallelS (reverse ms) - margs <- runReaderT (evalStateT (mapM metaElim ps) ms') sub + let msAux = permute (invertP __IMPOSSIBLE__ $ compactP perm) ms + let sub = parallelS (reverse ms) + margs <- runReaderT (evalStateT (mapM metaElim ps) msAux) sub reportSDoc "tc.inj.invert" 20 $ vcat [ text "inversion" , nest 2 $ vcat diff --git a/src/full/Agda/TypeChecking/InstanceArguments.hs b/src/full/Agda/TypeChecking/InstanceArguments.hs --- a/src/full/Agda/TypeChecking/InstanceArguments.hs +++ b/src/full/Agda/TypeChecking/InstanceArguments.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.InstanceArguments where import Control.Applicative @@ -13,11 +17,13 @@ import Agda.Syntax.Scope.Base import Agda.Syntax.Internal as I +import Agda.TypeChecking.Errors () +import Agda.TypeChecking.Implicit (implicitArgs) import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty -import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import {-# SOURCE #-} Agda.TypeChecking.Constraints @@ -29,6 +35,7 @@ import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Pretty (prettyShow) #include "undefined.h" import Agda.Utils.Impossible @@ -120,92 +127,92 @@ -- its type again. findInScope :: MetaId -> Maybe Candidates -> TCM () findInScope m Nothing = do - reportSLn "tc.instance" 20 $ "The type of the FindInScope constraint isn't known, trying to find it again." - t <- getMetaType m - cands <- initialIFSCandidates t - case cands of - Nothing -> addConstraint $ FindInScope m Nothing - Just {} -> findInScope m cands + -- Andreas, 2015-02-07: New metas should be created with range of the + -- current instance meta, thus, we set the range. + mv <- lookupMeta m + setCurrentRange mv $ do + reportSLn "tc.instance" 20 $ "The type of the FindInScope constraint isn't known, trying to find it again." + t <- getMetaType m + cands <- initialIFSCandidates t + case cands of + Nothing -> addConstraint $ FindInScope m Nothing + Just {} -> findInScope m cands findInScope m (Just cands) = whenJustM (findInScope' m cands) $ addConstraint . FindInScope m . Just -- | Result says whether we need to add constraint, and if so, the set of -- remaining candidates. findInScope' :: MetaId -> Candidates -> TCM (Maybe Candidates) findInScope' m cands = ifM (isFrozen m) (return (Just cands)) $ do - -- Andreas, 2013-12-28 issue 1003: - -- If instance meta is already solved, simply discard the constraint. - ifM (isInstantiatedMeta m) (return Nothing) $ do - reportSLn "tc.instance" 15 $ - "findInScope 2: constraint: " ++ show m ++ "; candidates left: " ++ show (length cands) - t <- normalise =<< getMetaTypeInContext m - reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t - reportSLn "tc.instance" 70 $ "findInScope 3: t: " ++ show t + -- Andreas, 2013-12-28 issue 1003: + -- If instance meta is already solved, simply discard the constraint. + ifM (isInstantiatedMeta m) (return Nothing) $ do + -- Andreas, 2015-02-07: New metas should be created with range of the + -- current instance meta, thus, we set the range. mv <- lookupMeta m - -- If there are recursive instances, it's not safe to instantiate - -- metavariables in the goal, so we freeze them before checking candidates. - -- Metas that are rigidly constrained need not be frozen. - isRec <- orM $ map (isRecursive . unEl . snd) cands - let shouldFreeze rigid m - | elem m rigid = return False - | otherwise = not <$> isFrozen m - metas <- if not isRec then return [] else do - rigid <- rigidlyConstrainedMetas - filterM (shouldFreeze rigid) (allMetas t) - forM_ metas $ \ m -> updateMetaVar m $ \ mv -> mv { mvFrozen = Frozen } - cands <- checkCandidates m t cands - reportSLn "tc.instance" 15 $ - "findInScope 4: cands left: " ++ show (length cands) - unfreezeMeta metas - case cands of + setCurrentRange mv $ do + reportSLn "tc.instance" 15 $ + "findInScope 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands) + t <- normalise =<< getMetaTypeInContext m + reportSDoc "tc.instance" 15 $ text "findInScope 3: t =" <+> prettyTCM t + reportSLn "tc.instance" 70 $ "findInScope 3: t: " ++ show t + -- If there are recursive instances, it's not safe to instantiate + -- metavariables in the goal, so we freeze them before checking candidates. + -- Metas that are rigidly constrained need not be frozen. + isRec <- orM $ map (isRecursive . unEl . snd) cands + let shouldFreeze rigid m + | elem m rigid = return False + | otherwise = not <$> isFrozen m + metas <- if not isRec then return [] else do + rigid <- rigidlyConstrainedMetas + filterM (shouldFreeze rigid) (allMetas t) + forM_ metas $ \ m -> updateMetaVar m $ \ mv -> mv { mvFrozen = Frozen } + cands <- checkCandidates m t cands + reportSLn "tc.instance" 15 $ + "findInScope 4: cands left: " ++ show (length cands) + unfreezeMeta metas + case cands of - [] -> do - reportSDoc "tc.instance" 15 $ - text "findInScope 5: not a single candidate found..." - typeError $ IFSNoCandidateInScope t + [] -> do + reportSDoc "tc.instance" 15 $ + text "findInScope 5: not a single candidate found..." + typeError $ IFSNoCandidateInScope t - [(term, t')] -> do - reportSDoc "tc.instance" 15 $ vcat - [ text "findInScope 5: found one candidate" - , nest 2 $ prettyTCM term - , text "of type " <+> prettyTCM t' - , text "for type" <+> prettyTCM t - ] + [(term, t')] -> do + reportSDoc "tc.instance" 15 $ vcat + [ text "findInScope 5: found one candidate" + , nest 2 $ prettyTCM term + , text "of type " <+> prettyTCM t' + , text "for type" <+> prettyTCM t + ] - -- if t' takes initial hidden arguments, apply them - ca <- liftTCM $ runExceptT $ checkArguments ExpandLast ExpandInstanceArguments (getRange mv) [] t' t - case ca of - Left _ -> __IMPOSSIBLE__ - Right (args, t'') -> do - -- @args@ are the hidden arguments @t'@ takes, @t''@ is @t' `apply` args@ -{- TODO - (args, t'') <- implicitArgs (...) t' - do --} - leqType t'' t - ctxArgs <- getContextArgs - v <- (`applyDroppingParameters` args) =<< reduce term - assignV DirEq m ctxArgs v - reportSDoc "tc.instance" 10 $ vcat - [ text "solved by instance search:" - , prettyTCM m <+> text ":=" <+> prettyTCM v - ] - return Nothing + -- If t' takes initial hidden and instance arguments, apply them. + -- Taking also instance arguments facilitates recursive instance search. + (args, t'') <- implicitArgs (-1) notVisible t' + leqType t'' t + ctxArgs <- getContextArgs + v <- (`applyDroppingParameters` args) =<< reduce term + assignV DirEq m ctxArgs v + reportSDoc "tc.instance" 10 $ vcat + [ text "solved by instance search:" + , prettyTCM m <+> text ":=" <+> prettyTCM v + ] + return Nothing - cs -> do - reportSDoc "tc.instance" 15 $ - text ("findInScope 5: more than one candidate found: ") <+> - prettyTCM (List.map fst cs) - return (Just cs) - where - -- | Check whether a type is a function type with an instance domain. - isRecursive :: Term -> TCM Bool - isRecursive v = do - v <- reduce v - case ignoreSharing v of - Pi (Dom info _) t -> - if getHiding info == Instance then return True else - isRecursive $ unEl $ unAbs t - _ -> return False + cs -> do + reportSDoc "tc.instance" 15 $ + text ("findInScope 5: more than one candidate found: ") <+> + prettyTCM (List.map fst cs) + return (Just cs) + where + -- | Check whether a type is a function type with an instance domain. + isRecursive :: Term -> TCM Bool + isRecursive v = do + v <- reduce v + case ignoreSharing v of + Pi (Dom info _) t -> + if getHiding info == Instance then return True else + isRecursive $ unEl $ unAbs t + _ -> return False -- | A meta _M is rigidly constrained if there is a constraint _M us == D vs, -- for inert D. Such metas can safely be instantiated by recursive instance @@ -257,48 +264,53 @@ dropSameCandidates cands where checkCandidateForMeta :: MetaId -> Type -> Term -> Type -> TCM Bool - checkCandidateForMeta m t term t' = - verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ show m) $ do - liftTCM $ flip catchError handle $ do - reportSLn "tc.instance" 70 $ " t: " ++ show t ++ "\n t':" ++ show t' ++ "\n term: " ++ show term ++ "." - reportSDoc "tc.instance" 20 $ vcat - [ text "checkCandidateForMeta" - , text "t =" <+> prettyTCM t - , text "t' =" <+> prettyTCM t' - , text "term =" <+> prettyTCM term - ] - localTCState $ do - -- domi: we assume that nothing below performs direct IO (except - -- for logging and such, I guess) - ca <- runExceptT $ checkArguments ExpandLast ExpandInstanceArguments noRange [] t' t - case ca of - Left _ -> return False - Right (args, t'') -> do + checkCandidateForMeta m t term t' = do + -- Andreas, 2015-02-07: New metas should be created with range of the + -- current instance meta, thus, we set the range. + mv <- lookupMeta m + setCurrentRange mv $ do + verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $ do + liftTCM $ flip catchError handle $ do + reportSLn "tc.instance" 70 $ " t: " ++ show t ++ "\n t':" ++ show t' ++ "\n term: " ++ show term ++ "." + reportSDoc "tc.instance" 20 $ vcat + [ text "checkCandidateForMeta" + , text "t =" <+> prettyTCM t + , text "t' =" <+> prettyTCM t' + , text "term =" <+> prettyTCM term + ] + -- domi: we assume that nothing below performs direct IO + -- (except for logging and such, I guess) + localTCState $ do + + -- Apply hidden and instance arguments (recursive inst. search!). + (args, t'') <- implicitArgs (-1) notVisible t' + reportSDoc "tc.instance" 20 $ text "instance search: checking" <+> prettyTCM t'' <+> text "<=" <+> prettyTCM t -- if constraints remain, we abort, but keep the candidate flip (ifNoConstraints_ $ leqType t'' t) (const $ return True) $ do - --tel <- getContextTelescope - ctxArgs <- getContextArgs - v <- (`applyDroppingParameters` args) =<< reduce term - reportSDoc "tc.instance" 15 $ vcat - [ text "instance search: attempting" - , nest 2 $ prettyTCM m <+> text ":=" <+> prettyTCM v - ] - assign DirEq m ctxArgs v --- assign m ctxArgs (term `apply` args) - -- make a pass over constraints, to detect cases where some are made - -- unsolvable by the assignment, but don't do this for FindInScope's - -- to prevent loops. We currently also ignore UnBlock constraints - -- to be on the safe side. - solveAwakeConstraints' True - return True - where - handle err = do - reportSDoc "tc.instance" 50 $ - text "assignment failed:" <+> prettyTCM err - return False + ctxArgs <- getContextArgs + v <- (`applyDroppingParameters` args) =<< reduce term + reportSDoc "tc.instance" 15 $ vcat + [ text "instance search: attempting" + , nest 2 $ prettyTCM m <+> text ":=" <+> prettyTCM v + ] + assign DirEq m ctxArgs v + -- assign m ctxArgs (term `apply` args) + -- make a pass over constraints, to detect cases where some are made + -- unsolvable by the assignment, but don't do this for FindInScope's + -- to prevent loops. We currently also ignore UnBlock constraints + -- to be on the safe side. + solveAwakeConstraints' True + return True + where + handle :: TCErr -> TCM Bool + handle err = do + reportSDoc "tc.instance" 50 $ + text "assignment failed:" <+> prettyTCM err + return False + isIFSConstraint :: Constraint -> Bool isIFSConstraint FindInScope{} = True isIFSConstraint UnBlock{} = True -- otherwise test/fail/Issue723 loops diff --git a/src/full/Agda/TypeChecking/Irrelevance.hs b/src/full/Agda/TypeChecking/Irrelevance.hs --- a/src/full/Agda/TypeChecking/Irrelevance.hs +++ b/src/full/Agda/TypeChecking/Irrelevance.hs @@ -20,14 +20,14 @@ import Agda.Utils.TestHelpers -- | data 'Relevance' --- see 'Agda.Syntax.Common' +-- see "Agda.Syntax.Common". irrelevantOrUnused :: Relevance -> Bool irrelevantOrUnused Irrelevant = True irrelevantOrUnused UnusedArg = True irrelevantOrUnused NonStrict = False irrelevantOrUnused Relevant = False -irrelevantOrUnused Forced = False +irrelevantOrUnused Forced{} = False -- | @unusableRelevance rel == True@ iff we cannot use a variable of @rel@. unusableRelevance :: Relevance -> Bool @@ -42,8 +42,9 @@ (_, Irrelevant) -> Irrelevant (NonStrict, _) -> NonStrict (_, NonStrict) -> NonStrict - (Forced, _) -> Forced - (_, Forced) -> Forced + (Forced b, Forced b') -> Forced (max b b') -- prefer Big over Small + (Forced b, _) -> Forced b + (_, Forced b) -> Forced b (UnusedArg, _) -> UnusedArg (_, UnusedArg) -> UnusedArg (Relevant, Relevant) -> Relevant @@ -58,16 +59,17 @@ case (r, x) of (Relevant, x) -> x -- going to relevant arg.: nothing changes _ | r == x -> Relevant -- because Relevant is comp.-neutral + (Forced{}, Forced{}) -> Relevant -- same, but (==) does not ignore Big (UnusedArg, x) -> x - (Forced, UnusedArg) -> Relevant - (Forced, x) -> x + (Forced{}, UnusedArg) -> Relevant + (Forced{}, x) -> x (Irrelevant, x) -> Relevant -- going irrelevant: every thing usable (_, Irrelevant) -> Irrelevant -- otherwise: irrelevant things remain unusable (NonStrict, _) -> Relevant -- but @NonStrict@s become usable -- | For comparing @Relevance@ ignoring @Forced@ and @UnusedArg@. ignoreForced :: Relevance -> Relevance -ignoreForced Forced = Relevant +ignoreForced Forced{} = Relevant ignoreForced UnusedArg = Relevant ignoreForced Relevant = Relevant ignoreForced NonStrict = NonStrict @@ -129,7 +131,7 @@ applyRelevanceToContext rel = case rel of Relevant -> id - Forced -> id + Forced{} -> id _ -> local $ \ e -> e { envContext = modifyContextEntries (inverseApplyRelevance rel) (envContext e) , envLetBindings = Map.map diff --git a/src/full/Agda/TypeChecking/Level.hs b/src/full/Agda/TypeChecking/Level.hs --- a/src/full/Agda/TypeChecking/Level.hs +++ b/src/full/Agda/TypeChecking/Level.hs @@ -145,9 +145,9 @@ mkAtom a = do b <- reduceB' a return $ case ignoreSharing <$> b of - NotBlocked (MetaV m as) -> atom $ MetaLevel m as - NotBlocked _ -> atom $ NeutralLevel (ignoreBlocking b) - Blocked m _ -> atom $ BlockedLevel m (ignoreBlocking b) + NotBlocked _ (MetaV m as) -> atom $ MetaLevel m as + NotBlocked r _ -> atom $ NeutralLevel r $ ignoreBlocking b + Blocked m _ -> atom $ BlockedLevel m $ ignoreBlocking b atom a = Max [Plus 0 a] diff --git a/src/full/Agda/TypeChecking/MetaVars.hs b/src/full/Agda/TypeChecking/MetaVars.hs --- a/src/full/Agda/TypeChecking/MetaVars.hs +++ b/src/full/Agda/TypeChecking/MetaVars.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RelaxedPolyRec #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RelaxedPolyRec #-} +{-# LANGUAGE TupleSections #-} module Agda.TypeChecking.MetaVars where @@ -54,6 +53,7 @@ import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.Permutation +import Agda.Utils.Pretty (prettyShow) import qualified Agda.Utils.VarSet as Set #include "undefined.h" @@ -70,7 +70,7 @@ -- | Check whether a meta variable is a place holder for a blocked term. isBlockedTerm :: MetaId -> TCM Bool isBlockedTerm x = do - reportSLn "tc.meta.blocked" 12 $ "is " ++ show x ++ " a blocked term? " + reportSLn "tc.meta.blocked" 12 $ "is " ++ prettyShow x ++ " a blocked term? " i <- mvInstantiation <$> lookupMeta x let r = case i of BlockedConst{} -> True @@ -110,7 +110,7 @@ -- | Skip frozen check. Used for eta expanding frozen metas. assignTerm' :: MetaId -> [I.Arg ArgName] -> Term -> TCM () assignTerm' x tel v = do - reportSLn "tc.meta.assign" 70 $ show x ++ " := " ++ show v ++ "\n in " ++ show tel + reportSLn "tc.meta.assign" 70 $ prettyShow x ++ " := " ++ show v ++ "\n in " ++ show tel -- verify (new) invariants whenM (not <$> asks envAssignMetas) __IMPOSSIBLE__ @@ -133,7 +133,7 @@ modifyMetaStore $ ins x i etaExpandListeners x wakeupConstraints x - reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ show x + reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x where metaInstance tel v = InstV tel v ins x i store = Map.adjust (inst i) x store @@ -201,7 +201,7 @@ let perm = idP (size tel) x <- newMeta' OpenIFS i normalMetaPriority perm (HasType () t) reportSDoc "tc.meta.new" 50 $ fsep - [ nest 2 $ text (show x) <+> text ":" <+> prettyTCM t + [ nest 2 $ pretty x <+> text ":" <+> prettyTCM t ] addConstraint $ FindInScope x cands return $ MetaV x $ map Apply vs @@ -241,7 +241,7 @@ reportSDoc "tc.meta.new" 50 $ fsep [ text "new meta:" , nest 2 $ prettyTCM vs <+> text "|-" - , nest 2 $ text (show x) <+> text ":" <+> prettyTCM t + , nest 2 $ pretty x <+> text ":" <+> prettyTCM t ] etaExpandMetaSafe x -- Andreas, 2012-09-24: for Metas X : Size< u add constraint X+1 <= u @@ -362,7 +362,8 @@ postponeTypeCheckingProblem p (unblock p) where unblock (CheckExpr _ t) = unblockedTester t - unblock (CheckArgs _ _ _ _ t _ _) = unblockedTester t + unblock (CheckArgs _ _ _ _ t _ _) = unblockedTester t -- The type of the head of the application. + unblock (CheckLambda _ _ t) = unblockedTester t -- | Create a postponed type checking problem @e : t@ that waits for conditon -- @unblock@. A new meta is created in the current context that has as @@ -393,9 +394,11 @@ addConstraint (UnBlock m) return v +-- | Type of the term that is produced by solving the 'TypeCheckingProblem'. problemType :: TypeCheckingProblem -> Type -problemType (CheckExpr _ t) = t -problemType (CheckArgs _ _ _ _ _ t _) = t +problemType (CheckExpr _ t ) = t +problemType (CheckArgs _ _ _ _ _ t _ ) = t -- The target type of the application. +problemType (CheckLambda _ _ t ) = t -- | Eta expand metavariables listening on the current meta. etaExpandListeners :: MetaId -> TCM () @@ -437,7 +440,7 @@ -- Don't do anything if the metavariable is a blocked term. etaExpandMeta :: [MetaKind] -> MetaId -> TCM () etaExpandMeta kinds m = whenM (isEtaExpandable m) $ do - verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ show m) $ do + verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do let waitFor x = do reportSDoc "tc.meta.eta" 20 $ do text "postponing eta-expansion of meta variable" <+> @@ -466,7 +469,10 @@ inTopContext $ do verboseS "tc.meta.eta" 15 $ do du <- prettyTCM u - reportSLn "tc.meta.eta" 15 $ "eta expanding: " ++ show m ++ " --> " ++ show du + reportSDoc "tc.meta.eta" 15 $ sep + [ text "eta expanding: " <+> pretty m <+> text " --> " + , nest 2 $ prettyTCM u + ] -- Andreas, 2012-03-29: No need for occurrence check etc. -- we directly assign the solution for the meta -- 2012-05-23: We also bypass the check for frozen. @@ -639,7 +645,7 @@ reportSLn "tc.meta.assign" 15 "passed occursCheck" verboseS "tc.meta.assign" 30 $ do - let n = size v + let n = termSize v when (n > 200) $ reportSDoc "tc.meta.assign" 30 $ sep [ text "size" <+> text (show n) -- , nest 2 $ text "type" <+> prettyTCM t @@ -699,6 +705,7 @@ else "failed" patternViolation +{- UNUSED -- | When faced with @_X us == D vs@ for an inert D we can solve this by -- @_X xs := D _Ys@ with new constraints @_Yi us == vi@. This is important -- for instance arguments, where knowing the head D might enable progress. @@ -786,8 +793,8 @@ patternViolation | otherwise = return () case fmap ignoreSharing b of - Blocked{} -> notNeutral v - NotBlocked v -> + Blocked{} -> notNeutral v + NotBlocked r v -> -- Andrea(s) 2014-12-06 can r be useful? case v of Var x _ -> checkRHS (Var x []) Def f _ -> checkRHS (Def f []) @@ -801,7 +808,7 @@ Lam{} -> notNeutral v ExtLam{} -> __IMPOSSIBLE__ Shared{} -> __IMPOSSIBLE__ - +-- END UNUSED -} -- | @assignMeta m x t ids u@ solves @x ids = u@ for meta @x@ of type @t@, -- where term @u@ lives in a context of length @m@. @@ -1020,38 +1027,13 @@ (return [p]) (throwError ()) -{- UNNECESSARILY COMPLICATED --- | Turn non-det substitution into proper substitution, if possible. --- Writes a list of non-linear variables that need to be pruned. --- If a non-linear variable is @elemFVs@, hence, not prunable, --- the error is thrown. -checkLinearity :: (Nat -> Bool) -> SubstCand -> ErrorT () (WriterT [Nat] TCM) SubstCand -checkLinearity elemFVs ids0 = do - let ids = sortBy (compare `on` fst) ids0 - let grps = groupOn fst ids - concat <$> mapM makeLinear grps - where - -- | Non-determinism can be healed if type is singleton. [Issue 593] - -- (Same as for irrelevance.) - makeLinear :: SubstCand -> ErrorT () TCM SubstCand - makeLinear [] = __IMPOSSIBLE__ - makeLinear grp@[_] = return grp - makeLinear grp@(p@(i,t) : _) = do - ifM ((Right True ==) <$> do isSingletonTypeModuloRelevance =<< typeOfBV i) - {- then -} (return [p]) - {- else -} $ do - ifM (elemFVs i) - {- then -} (throwError ()) -- non-prunable non-linear var - {- else -} (tell [i] >> return grp) -- possibly prunable non-lin var --} - -- Intermediate result in the following function type Res = [(I.Arg Nat, Term)] -- | Exceptions raised when substitution cannot be inverted. data InvertExcept = CantInvert -- ^ Cannot recover. - | NeutralArg -- ^ A neutral arg: can't invert, but maybe prune. + | NeutralArg -- ^ A potentially neutral arg: can't invert, but can try pruning. | ProjectedVar Int [QName] -- ^ Try to eta-expand var to remove projs. instance Error InvertExcept where @@ -1100,20 +1082,13 @@ case isRC of Just (_, Record{ recFields = fs }) | length fs == length vs -> do - let aux (Arg _ v) (Arg info' f) = - (Arg (ArgInfo { argInfoColors = argInfoColors info -- TODO guilhem - , argInfoHiding = min (argInfoHiding info) - (argInfoHiding info') - , argInfoRelevance = max (argInfoRelevance info) - (argInfoRelevance info') - }) - v,) -- OLD: (stripDontCare v), - $ t `applyE` [Proj f] + let aux (Arg _ v) (Arg info' f) = (Arg ai v,) $ t `applyE` [Proj f] where + ai = ArgInfo + { argInfoColors = argInfoColors info -- TODO guilhem + , argInfoHiding = min (getHiding info) (getHiding info') + , argInfoRelevance = max (getRelevance info) (getRelevance info') + } res <- loop $ zipWith aux vs fs --- Andreas, 2013-09-22, applyDef not needed after all --- since f (because taken from recFields) is the original record projection. --- <$> do liftTCM $ applyDef f (defaultArg t) --- res <- loop =<< zipWithM aux vs fs return $ res `append` vars | otherwise -> fallback Just _ -> __IMPOSSIBLE__ @@ -1127,9 +1102,9 @@ Arg _ DontCare{} -> return vars -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure - -- from those that can only put somewhere as a whole ==> return Nothing + -- from those that can only put somewhere as a whole ==> neutralArg Arg _ Var{} -> neutralArg - Arg _ Def{} -> failure + Arg _ Def{} -> neutralArg -- Note that this Def{} is in normal form and might be prunable. Arg _ Lam{} -> failure Arg _ Lit{} -> failure Arg _ MetaV{} -> failure diff --git a/src/full/Agda/TypeChecking/MetaVars/Mention.hs b/src/full/Agda/TypeChecking/MetaVars/Mention.hs --- a/src/full/Agda/TypeChecking/MetaVars/Mention.hs +++ b/src/full/Agda/TypeChecking/MetaVars/Mention.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} module Agda.TypeChecking.MetaVars.Mention where @@ -43,7 +42,7 @@ MetaLevel m vs -> x == m || mentionsMeta x vs BlockedLevel m _ -> x == m -- if it's blocked on a different meta it doesn't matter if it mentions the meta somewhere else UnreducedLevel l -> mentionsMeta x l - NeutralLevel l -> mentionsMeta x l + NeutralLevel _ l -> mentionsMeta x l instance MentionsMeta Type where mentionsMeta x (El s t) = mentionsMeta x (s, t) @@ -53,6 +52,7 @@ Type l -> mentionsMeta x l Prop -> False Inf -> False + SizeUniv -> False DLub s1 s2 -> mentionsMeta x (s1, s2) instance MentionsMeta t => MentionsMeta (Abs t) where diff --git a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs --- a/src/full/Agda/TypeChecking/MetaVars/Occurs.hs +++ b/src/full/Agda/TypeChecking/MetaVars/Occurs.hs @@ -1,7 +1,19 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{- | The occurs check for unification. Does pruning on the fly. + + When hitting a meta variable: + + - Compute flex/rigid for its arguments. + - Compare to allowed variables. + - Mark arguments with rigid occurrences of disallowed variables for deletion. + - Attempt to delete marked arguments. + - We don't need to check for success, we can just continue occurs checking. +-} + module Agda.TypeChecking.MetaVars.Occurs where import Control.Applicative @@ -9,8 +21,10 @@ import Control.Monad.Reader import Control.Monad.State +import Data.Foldable (foldMap) import Data.List import Data.Maybe +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set @@ -38,6 +52,7 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Permutation +import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Size import qualified Agda.Utils.VarSet as VarSet @@ -114,7 +129,7 @@ defArgs YesUnfold ctx = weakly ctx unfold :: UnfoldStrategy -> Term -> TCM (Blocked Term) -unfold NoUnfold v = NotBlocked <$> instantiate v +unfold NoUnfold v = notBlocked <$> instantiate v unfold YesUnfold v = reduceB v -- | Leave the top position. @@ -166,7 +181,9 @@ -- | When assigning @m xs := v@, check that @m@ does not occur in @v@ -- and that the free variables of @v@ are contained in @xs@. -occursCheck :: MetaId -> Vars -> Term -> TCM Term +occursCheck + :: (Occurs a, InstantiateFull a, PrettyTCM a) + => MetaId -> Vars -> a -> TCM a occursCheck m xs v = liftTCM $ do mv <- lookupMeta m initOccursCheck mv @@ -180,19 +197,19 @@ TypeError _ cl -> case clValue cl of MetaOccursInItself{} -> typeError . GenericError . show =<< - fsep [ text ("Refuse to construct infinite term by instantiating " ++ show m ++ " to") + fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to") , prettyTCM =<< instantiateFull v ] MetaCannotDependOn _ _ i -> ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism)) ( typeError . GenericError . show =<< - fsep [ text ("Cannot instantiate the metavariable " ++ show m ++ " to") + fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to") , prettyTCM v , text "since universe polymorphism is disabled" ] ) {- else -} ( typeError . GenericError . show =<< - fsep [ text ("Cannot instantiate the metavariable " ++ show m ++ " to solution") + fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution") , prettyTCM v , text "since it contains the variable" , enterClosure cl $ \_ -> prettyTCM (Var i []) @@ -208,13 +225,13 @@ -- occurs' ctx $ ignoreBlocking v -- fails test/succeed/DontPruneBlocked case v of -- Don't fail on blocked terms or metas - NotBlocked v -> occurs' ctx v + NotBlocked _ v -> occurs' ctx v -- Blocked _ v@MetaV{} -> occurs' ctx v -- does not help with issue 856 Blocked _ v -> occurs' Flex v where occurs' ctx v = do reportSDoc "tc.meta.occurs" 45 $ - text ("occursCheck " ++ show m ++ " (" ++ show ctx ++ ") of ") <+> prettyTCM v + text ("occursCheck " ++ prettyShow m ++ " (" ++ show ctx ++ ") of ") <+> prettyTCM v reportSDoc "tc.meta.occurs" 70 $ nest 2 $ text $ show v case v of @@ -253,11 +270,10 @@ -- I guess the error was there from times when occurrence check -- was done after the "lhs=linear variables" check, but now -- occurrence check comes first. - {- - when (m == m') $ if ctx == Top then patternViolation else - abort ctx $ MetaOccursInItself m' - -} - when (m == m') $ patternViolation' 50 $ "occursCheck failed: Found " ++ show m + -- WAS: + -- when (m == m') $ if ctx == Top then patternViolation else + -- abort ctx $ MetaOccursInItself m' + when (m == m') $ patternViolation' 50 $ "occursCheck failed: Found " ++ prettyShow m -- The arguments of a meta are in a flexible position (MetaV m' <$> occurs red Flex m xs es) `catchError` \err -> do @@ -270,10 +286,9 @@ -- flexible occurrences (if not already in a flexible context) PatternErr{} | ctx /= Flex -> do reportSLn "tc.meta.kill" 20 $ - "oops, pattern violation for " ++ show m' + "oops, pattern violation for " ++ prettyShow m' -- Andreas, 2014-03-02, see issue 1070: -- Do not prune when meta is projected! - -- WAS: let vs = takeWhileJust isApplyElim es caseMaybe (allApplyElims es) (throwError err) $ \ vs -> do killResult <- prune m' vs (takeRelevant xs) if (killResult == PrunedEverything) @@ -307,7 +322,7 @@ Sort s -> metaOccurs m s Shared p -> metaOccurs m $ derefPtr p ExtLam{} -> __IMPOSSIBLE__ - MetaV m' vs | m == m' -> patternViolation' 50 $ "Found occurrence of " ++ show m + MetaV m' vs | m == m' -> patternViolation' 50 $ "Found occurrence of " ++ prettyShow m | otherwise -> metaOccurs m vs instance Occurs QName where @@ -361,16 +376,16 @@ MetaLevel m' args -> do MetaV m' args <- ignoreSharing <$> occurs red ctx m xs (MetaV m' args) return $ MetaLevel m' args - NeutralLevel v -> NeutralLevel <$> occurs red ctx m xs v + NeutralLevel r v -> NeutralLevel r <$> occurs red ctx m xs v BlockedLevel m' v -> BlockedLevel m' <$> occurs red Flex m xs v UnreducedLevel v -> UnreducedLevel <$> occurs red ctx m xs v metaOccurs m l = do l <- instantiate l case l of - MetaLevel m' args -> metaOccurs m (MetaV m' args) - NeutralLevel v -> metaOccurs m v - BlockedLevel m v -> metaOccurs m v + MetaLevel m' args -> metaOccurs m $ MetaV m' args + NeutralLevel _ v -> metaOccurs m v + BlockedLevel _ v -> metaOccurs m v UnreducedLevel v -> metaOccurs m v @@ -389,6 +404,7 @@ Type a -> Type <$> occurs red ctx m xs a Prop -> return s' Inf -> return s' + SizeUniv -> return s' metaOccurs m s = do s <- instantiate s @@ -397,6 +413,7 @@ Type a -> metaOccurs m a Prop -> return () Inf -> return () + SizeUniv -> return () instance Occurs a => Occurs (Elim' a) where occurs red ctx m xs e@Proj{} = return e @@ -452,20 +469,13 @@ reportSDoc "tc.meta.kill" 10 $ vcat [ text "attempting kills" , nest 2 $ vcat - [ text "m' =" <+> text (show m') - , text "xs =" <+> text (show xs) + [ text "m' =" <+> pretty m' + -- , text "xs =" <+> text (show xs) + , text "xs =" <+> prettyList (map (prettyTCM . var) xs) , text "vs =" <+> prettyList (map prettyTCM vs) , text "kills =" <+> text (show kills) ] ] -{- Andreas, 2011-05-11 REDUNDANT CODE - reportSLn "tc.meta.kill" 20 $ - "attempting to prune meta " ++ show m' ++ "\n" ++ - " kills: " ++ show kills - if not (or kills) - then return False -- nothing to kill - else do --} killArgs kills m' -- | @hasBadRigid xs v = Just True@ iff one of the rigid variables in @v@ is not in @xs@. @@ -479,7 +489,8 @@ hasBadRigid xs t = do -- We fail if we encounter a matchable argument. let failure = throwError () - t <- liftTCM $ reduce t + tb <- liftTCM $ reduceB t + let t = ignoreBlocking tb case ignoreSharing t of Var x _ -> return $ notElem x xs -- Issue 1153: A lambda has to be considered matchable. @@ -489,13 +500,13 @@ -- The following types of arguments cannot be eliminated by a pattern -- match: data, record, Pi, levels, sorts -- Thus, their offending rigid variables are bad. - v@(Def f es) -> ifNotM (isNeutral f es) failure $ {- else -} do - return $ es `rigidVarsNotContainedIn` xs + v@(Def f es) -> ifNotM (isNeutral tb f es) failure $ {- else -} do + es `rigidVarsNotContainedIn` xs -- Andreas, 2012-05-03: There is room for further improvement. -- We could also consider a defined f which is not blocked by a meta. - Pi a b -> return $ (a,b) `rigidVarsNotContainedIn` xs - Level v -> return $ v `rigidVarsNotContainedIn` xs - Sort s -> return $ s `rigidVarsNotContainedIn` xs + Pi a b -> (a,b) `rigidVarsNotContainedIn` xs + Level v -> v `rigidVarsNotContainedIn` xs + Sort s -> s `rigidVarsNotContainedIn` xs -- Since constructors can be eliminated by pattern-matching, -- offending variables under a constructor could be removed by -- the right instantiation of the meta variable. @@ -513,26 +524,131 @@ -- | Check whether a term @Def f es@ is finally stuck. -- Currently, we give only a crude approximation. -isNeutral :: MonadTCM tcm => QName -> Elims -> tcm Bool -isNeutral f es = liftTCM $ do +isNeutral :: MonadTCM tcm => Blocked t -> QName -> Elims -> tcm Bool +isNeutral b f es = liftTCM $ do let yes = return True + no = return False def <- getConstInfo f case theDef def of Axiom{} -> yes Datatype{} -> yes Record{} -> yes - _ -> return False - -- TODO: more precise analysis - -- We need to check whether a function is stuck on a variable - -- (not meta variable), but the API does not help us... + Function{} -> case b of + NotBlocked StuckOn{} _ -> yes + NotBlocked AbsurdMatch _ -> yes + _ -> no + _ -> no --- This could be optimized, by not computing the whole variable set --- at once, but allow early failure -rigidVarsNotContainedIn :: Free a => a -> [Nat] -> Bool -rigidVarsNotContainedIn v xs = - not $ rigidVars (freeVars v) `VarSet.isSubsetOf` VarSet.fromList xs +-- | Check whether any of the variables (given as de Bruijn indices) +-- occurs *definitely* in the term in a rigid position. +-- Reduces the term successively to remove variables in dead subterms. +-- This fixes issue 1386. +rigidVarsNotContainedIn :: (MonadTCM tcm, FoldRigid a) => a -> [Nat] -> tcm Bool +rigidVarsNotContainedIn v is = liftTCM $ do + n0 <- getContextSize + let -- allowed variables as de Bruijn levels + levels = Set.fromList $ map (n0-1 -) is + -- test if index is forbidden by converting it to level + test i = do + n <- getContextSize + -- get de Bruijn level for i + let l = n-1 - i + -- If l >= n0 then it is a bound variable and can be + -- ignored. Otherwise, it has to be in the allowed levels. + forbidden = l < n0 && not (l `Set.member` levels) + when forbidden $ + reportSLn "tc.meta.kill" 20 $ + "found forbidden de Bruijn level " ++ show l + return $ Any forbidden + getAny <$> foldRigid id test v +-- | Short-cutting disjunction forms a monoid. +instance Monoid (TCM Any) where + mempty = return mempty + ma `mappend` mb = Any <$> do (getAny <$> ma) `or2M` (getAny <$> mb) +-- | Collect the *definitely* rigid variables in a monoid. +-- We need to successively reduce the expression to do this. + +class FoldRigid a where +-- foldRigid :: (MonadTCM tcm, Monoid (tcm m)) => (tcm m -> tcm m) -> (Nat -> tcm m) -> a -> tcm m + foldRigid :: (Monoid (TCM m)) => (TCM m -> TCM m) -> (Nat -> TCM m) -> a -> TCM m + +instance FoldRigid Term where + foldRigid abs f t = do + b <- liftTCM $ reduceB t + case ignoreSharing $ ignoreBlocking b of + Var i es -> f i `mappend` fold es + Lam _ t -> fold t + Lit{} -> mempty + Def f es -> case b of + Blocked{} -> mempty + NotBlocked MissingClauses _ -> mempty + _ -> fold es + Con _ ts -> fold ts + Pi a b -> fold (a,b) + Sort s -> fold s + Level l -> fold l + MetaV{} -> mempty + DontCare{} -> mempty + Shared{} -> __IMPOSSIBLE__ + ExtLam{} -> __IMPOSSIBLE__ + where fold = foldRigid abs f + +instance FoldRigid Type where + foldRigid abs f (El s t) = foldRigid abs f (s,t) + +instance FoldRigid Sort where + foldRigid abs f s = + case s of + Type l -> fold l + Prop -> mempty + Inf -> mempty + SizeUniv -> mempty + DLub s1 s2 -> fold (s1, s2) + where fold = foldRigid abs f + +instance FoldRigid Level where + foldRigid abs f (Max ls) = foldRigid abs f ls + +instance FoldRigid PlusLevel where + foldRigid abs f ClosedLevel{} = mempty + foldRigid abs f (Plus _ l) = foldRigid abs f l + +instance FoldRigid LevelAtom where + foldRigid abs f l = + case l of + MetaLevel{} -> mempty + NeutralLevel MissingClauses _ -> mempty + NeutralLevel _ l -> fold l + BlockedLevel _ l -> fold l + UnreducedLevel l -> fold l + where fold = foldRigid abs f + +instance (Subst a, FoldRigid a) => FoldRigid (Abs a) where + foldRigid abs f b = underAbstraction_ b $ foldRigid abs f + +instance FoldRigid a => FoldRigid (I.Arg a) where + foldRigid abs f a = + case getRelevance a of + Irrelevant -> mempty + UnusedArg -> mempty + _ -> foldRigid abs f $ unArg a + +instance FoldRigid a => FoldRigid (I.Dom a) where + foldRigid abs f dom = foldRigid abs f $ unDom dom + +instance FoldRigid a => FoldRigid (Elim' a) where + foldRigid abs f (Apply a) = foldRigid abs f a + foldRigid abs f Proj{} = mempty + +instance FoldRigid a => FoldRigid [a] where + foldRigid abs f = foldMap $ foldRigid abs f + +instance (FoldRigid a, FoldRigid b) => FoldRigid (a,b) where + foldRigid abs f (a,b) = foldRigid abs f a `mappend` foldRigid abs f b + + data PruneResult = NothingToPrune -- ^ the kill list is empty or only @False@s | PrunedNothing -- ^ there is no possible kill (because of type dep.) @@ -550,11 +666,7 @@ mv <- lookupMeta m allowAssign <- asks envAssignMetas if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do -{- Andreas 2011-04-26, allow pruning in MetaS - case mvJudgement mv of - IsSort _ -> return False - HasType _ a -> do --} + -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS let a = jMetaType $ mvJudgement mv TelV tel b <- telView' <$> instantiateFull a let args = zip (telToList tel) (kills ++ repeat False) @@ -566,7 +678,6 @@ -- Only successful if all occurrences were killed -- Andreas, 2011-05-09 more precisely, check that at least -- the in 'kills' prescribed kills were carried out - -- OLD CODE: return (map unArg kills' == kills) return $ if (and $ zipWith implies kills $ map unArg kills') then PrunedEverything else PrunedSomething @@ -594,7 +705,7 @@ killedType :: [(I.Dom (ArgName, Type), Bool)] -> Type -> ([I.Arg Bool], Type) killedType [] b = ([], b) killedType ((arg@(Dom info _), kill) : kills) b - | dontKill = (Arg info False : args, mkPi arg b') -- OLD: telePi (telFromList [arg]) b') + | dontKill = (Arg info False : args, mkPi arg b') | otherwise = (Arg info True : args, strengthen __IMPOSSIBLE__ b') where (args, b') = killedType kills b @@ -615,32 +726,14 @@ lam b a = Lam (argInfo a) (Abs "v" b) tel = map ("v" <$) (reverse kills) u = MetaV m' $ map Apply vars -{- OLD CODE - hs = reverse [ argHiding a | a <- kills ] - lam h b = Lam h (Abs "v" b) - u = foldr lam (MetaV m' vars) hs --} dbg m' u assignTerm m tel u where dbg m' u = reportSDoc "tc.meta.kill" 10 $ vcat [ text "actual killing" , nest 2 $ vcat - [ text "new meta:" <+> text (show m') + [ text "new meta:" <+> pretty m' , text "kills :" <+> text (show kills) - , text "inst :" <+> text (show m) <+> text ":=" <+> prettyTCM u + , text "inst :" <+> pretty m <+> text ":=" <+> prettyTCM u ] ] - -{- - - When hitting a meta variable: - - - Compute flex/rigid for its arguments - - Compare to allowed variables - - Mark arguments with rigid occurrences of disallowed - variables for deletion - - Attempt to delete marked arguments - - We don't need to check for success, we can just - continue occurs checking. --} diff --git a/src/full/Agda/TypeChecking/Monad/Base.hs b/src/full/Agda/TypeChecking/Monad/Base.hs --- a/src/full/Agda/TypeChecking/Monad/Base.hs +++ b/src/full/Agda/TypeChecking/Monad/Base.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} module Agda.TypeChecking.Monad.Base where +import Prelude hiding (null) + import Control.Arrow ((***), first, second) import qualified Control.Concurrent as C import Control.DeepSeq @@ -24,7 +25,7 @@ import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Trans.Maybe -import Control.Applicative +import Control.Applicative hiding (empty) import Data.Function import Data.Int @@ -32,8 +33,10 @@ import qualified Data.IntMap as IntMap import qualified Data.List as List import Data.Maybe -import Data.Map as Map -import Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map -- hiding (singleton, null, empty) +import Data.Set (Set) +import qualified Data.Set as Set -- hiding (singleton, null, empty) import Data.Typeable (Typeable) import Data.Foldable import Data.Traversable @@ -45,6 +48,7 @@ import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Concrete.Definitions as D import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Abstract (AllNames) import Agda.Syntax.Internal as I import Agda.Syntax.Internal.Pattern () import Agda.Syntax.Fixity @@ -73,11 +77,14 @@ ) import Agda.Utils.FileName -import Agda.Utils.HashMap as HMap +import Agda.Utils.HashMap as HMap hiding (singleton) import Agda.Utils.Hash import Agda.Utils.Lens +import Agda.Utils.ListT +import Agda.Utils.Null import Agda.Utils.Permutation import Agda.Utils.Pretty +import Agda.Utils.Singleton import Agda.Utils.Time #include "undefined.h" @@ -445,9 +452,19 @@ newtype ProblemId = ProblemId Nat deriving (Typeable, Eq, Ord, Enum, Real, Integral, Num) +-- TODO: 'Show' should output Haskell-parseable representations. +-- The following instance is deprecated, and Pretty[TCM] should be used +-- instead. Later, simply derive Show for this type. + +-- ASR (28 December 2014). This instance is not used anymore (module +-- the test suite) when reporting errors. See Issue 1293. + instance Show ProblemId where show (ProblemId n) = show n +instance Pretty ProblemId where + pretty (ProblemId n) = pretty n + instance HasFresh ProblemId where freshLens = stFreshProblemId @@ -533,7 +550,7 @@ , iInsideScope :: ScopeInfo -- ^ Scope after we loaded this interface. -- Used in 'Agda.Interaction.BasicOps.AtTopLevel' - -- and 'Agda.Interaction.CommandLine.CommandLine.interactionLoop'. + -- and 'Agda.Interaction.CommandLine.interactionLoop'. -- -- Andreas, AIM XX: For performance reason, this field is -- not serialized, so if you deserialize an interface, @iInsideScope@ @@ -628,10 +645,20 @@ data Comparison = CmpEq | CmpLeq deriving (Eq, Typeable) +-- TODO: 'Show' should output Haskell-parseable representations. +-- The following instance is deprecated, and Pretty[TCM] should be used +-- instead. Later, simply derive Show for this type. + +-- ASR (27 December 2014). This instance is not used anymore (module +-- the test suite) when reporting errors. See Issue 1293. instance Show Comparison where show CmpEq = "=" show CmpLeq = "=<" +instance Pretty Comparison where + pretty CmpEq = text "=" + pretty CmpLeq = text "=<" + -- | An extension of 'Comparison' to @>=@. data CompareDirection = DirEq | DirLeq | DirGeq deriving (Eq, Typeable) @@ -674,12 +701,13 @@ -- Used exclusively for typing of meta variables. --------------------------------------------------------------------------- -data Judgement t a - = HasType { jMetaId :: a, jMetaType :: t } - | IsSort { jMetaId :: a, jMetaType :: t } -- Andreas, 2011-04-26: type needed for higher-order sort metas - deriving (Typeable, Functor, Foldable, Traversable) +-- | Parametrized since it is used without MetaId when creating a new meta. +data Judgement a + = HasType { jMetaId :: a, jMetaType :: Type } + | IsSort { jMetaId :: a, jMetaType :: Type } -- Andreas, 2011-04-26: type needed for higher-order sort metas + deriving (Typeable) -instance (Show t, Show a) => Show (Judgement t a) where +instance Show a => Show (Judgement a) where show (HasType a t) = show a ++ " : " ++ show t show (IsSort a t) = show a ++ " :sort " ++ show t @@ -694,7 +722,7 @@ -- ^ a metavariable doesn't have to depend on all variables -- in the context, this "permutation" will throw away the -- ones it does not depend on - , mvJudgement :: Judgement Type MetaId + , mvJudgement :: Judgement MetaId , mvInstantiation :: MetaInstantiation , mvListeners :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one , mvFrozen :: Frozen -- ^ are we past the point where we can instantiate this meta variable? @@ -737,6 +765,14 @@ data TypeCheckingProblem = CheckExpr A.Expr Type | CheckArgs ExpandHidden ExpandInstances Range [I.NamedArg A.Expr] Type Type (Args -> Type -> TCM Term) + | CheckLambda (Arg ([WithHiding Name], Maybe Type)) A.Expr Type + -- ^ @(λ (xs : t₀) → e) : t@ + -- This is not an instance of 'CheckExpr' as the domain type + -- has already been checked. + -- For example, when checking + -- @(λ (x y : Fin _) → e) : (x : Fin n) → ?@ + -- we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@ + -- is a 'Type' rather than an 'A.Expr'. deriving (Typeable) instance Show MetaInstantiation where @@ -779,9 +815,9 @@ , nmid :: MetaId } -instance Show NamedMeta where - show (NamedMeta "" x) = show x - show (NamedMeta s x) = "_" ++ s ++ show x +instance Pretty NamedMeta where + pretty (NamedMeta "" x) = pretty x + pretty (NamedMeta s x) = text $ "_" ++ s ++ prettyShow x type MetaStore = Map MetaId MetaVariable @@ -904,7 +940,7 @@ -- (possible in case the with-application is of function type). | DCon ConHead [Arg DisplayTerm] -- ^ @c vs@. - | DDef QName [Arg DisplayTerm] + | DDef QName [Elim' DisplayTerm] -- ^ @d vs@. | DDot Term -- ^ @.v@. @@ -922,6 +958,19 @@ defColors :: Definition -> [Color] defColors = argInfoColors . defArgInfo +-- | Non-linear (non-constructor) first-order pattern. +data NLPat + = PVar {-# UNPACK #-} !Int + -- ^ Matches anything (modulo non-linearity). + | PWild + -- ^ Matches anything (e.g. irrelevant terms). + | PDef QName PElims + -- ^ Matches @f es@ + | PTerm Term + -- ^ Matches the term modulo β (ideally βη). + deriving (Typeable, Show) +type PElims = [Elim' NLPat] + type RewriteRules = [RewriteRule] -- | Rewrite rules can be added independently from function clauses. @@ -929,7 +978,7 @@ { rewName :: QName -- ^ Name of rewrite rule @q : Γ → lhs ≡ rhs@ -- where @≡@ is the rewrite relation. , rewContext :: Telescope -- ^ @Γ@. - , rewLHS :: Term -- ^ @Γ ⊢ lhs : t@. + , rewLHS :: NLPat -- ^ @Γ ⊢ lhs : t@. , rewRHS :: Term -- ^ @Γ ⊢ rhs : t@. , rewType :: Type -- ^ @Γ ⊢ t@. } @@ -1012,7 +1061,7 @@ | Unused -- ^ No occurrence. deriving (Typeable, Show, Eq, Ord) -instance NFData Occurrence +instance NFData Occurrence where rnf x = seq x () -- | Additional information for projection 'Function's. data Projection = Projection @@ -1025,13 +1074,15 @@ , projIndex :: Int -- ^ Index of the record argument. -- Start counting with 1, because 0 means that - -- it is already applied to the record. - -- (Can happen in module instantiation.) + -- it is already applied to the record value. + -- This can happen in module instantiation, but + -- then either the record value is @var 0@, or @funProjection == Nothing@. , projDropPars :: Term -- ^ Term @t@ to be be applied to record parameters and record value. -- The parameters will be dropped. -- In case of a proper projection, a postfix projection application -- will be created: @t = \ pars r -> r .p@ + -- (Invariant: the number of abstractions equals 'projIndex'.) -- In case of a projection-like function, just the function symbol -- is returned as 'Def': @t = \ pars -> f@. , projArgInfo :: I.ArgInfo @@ -1161,7 +1212,7 @@ defIsDataOrRecord _ = False newtype Fields = Fields [(C.Name, Type)] - deriving (Typeable) + deriving (Typeable, Null) -- | Did we encounter a simplifying reduction? -- In terms of CIC, that would be a iota-reduction. @@ -1173,6 +1224,10 @@ data Simplification = YesSimplification | NoSimplification deriving (Typeable, Eq, Show) +instance Null Simplification where + empty = NoSimplification + null = (== NoSimplification) + instance Monoid Simplification where mempty = NoSimplification mappend YesSimplification _ = YesSimplification @@ -1203,8 +1258,8 @@ reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term) reduced b = case fmap ignoreSharing <$> b of - NotBlocked (Common.Arg _ (MetaV x _)) -> MaybeRed (Reduced $ Blocked x ()) v - _ -> MaybeRed (Reduced $ () <$ b) v + NotBlocked _ (Common.Arg _ (MetaV x _)) -> MaybeRed (Reduced $ Blocked x ()) v + _ -> MaybeRed (Reduced $ () <$ b) v where v = ignoreBlocking b @@ -1447,9 +1502,10 @@ TCEnv { envContext :: Context , envLetBindings :: LetBindings , envCurrentModule :: ModuleName - , envCurrentPath :: AbsolutePath + , envCurrentPath :: Maybe AbsolutePath -- ^ The path to the file that is currently being - -- type-checked. + -- type-checked. 'Nothing' if we do not have a file + -- (like in interactive mode see @CommandLine@). , envAnonymousModules :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables , envImportPath :: [C.TopLevelModuleName] -- ^ to detect import cycles , envMutualBlock :: Maybe MutualId -- ^ the current (if any) mutual block @@ -1535,7 +1591,7 @@ initEnv = TCEnv { envContext = [] , envLetBindings = Map.empty , envCurrentModule = noModuleName - , envCurrentPath = __IMPOSSIBLE__ + , envCurrentPath = Nothing , envAnonymousModules = [] , envImportPath = [] , envMutualBlock = Nothing @@ -1640,7 +1696,7 @@ data CallInfo = CallInfo { callInfoTarget :: QName - -- ^ Target function name pretty-printed. + -- ^ Target function name. , callInfoRange :: Range -- ^ Range of the target function. , callInfoCall :: Closure Term @@ -1652,7 +1708,24 @@ -- | We only 'show' the name of the callee. instance Show CallInfo where show = show . callInfoTarget instance Pretty CallInfo where pretty = text . show +instance AllNames CallInfo where allNames = singleton . callInfoTarget +-- UNUSED, but keep! +-- -- | Call pathes are sequences of 'CallInfo's starting from a 'callSource'. +-- data CallPath = CallPath +-- { callSource :: QName +-- -- ^ The originator of the first call. +-- , callInfos :: [CallInfo] +-- -- ^ The calls, in order from source to final target. +-- } +-- deriving (Show) + +-- -- | 'CallPath'es can be connected, but there is no empty callpath. +-- -- Thus, they form a semigroup, but we choose to abuse 'Monoid'. +-- instance Monoid CallPath where +-- mempty = __IMPOSSIBLE__ +-- mappend (CallPath src cs) (CallPath _ cs') = CallPath src $ cs ++ cs' + -- | Information about a mutual block which did not pass the -- termination checker. @@ -1664,15 +1737,20 @@ -- ^ The problematic call sites. } deriving (Typeable, Show) - -data SplitError = NotADatatype (Closure Type) -- ^ neither data type nor record - | IrrelevantDatatype (Closure Type) -- ^ data type, but in irrelevant position - | CoinductiveDatatype (Closure Type) -- ^ coinductive data type -{- UNUSED - | NoRecordConstructor Type -- ^ record type, but no constructor - -} - | CantSplit QName Telescope Args Args [Term] - | GenericSplitError String +-- | Error when splitting a pattern variable into possible constructor patterns. +data SplitError + = NotADatatype (Closure Type) -- ^ Neither data type nor record. + | IrrelevantDatatype (Closure Type) -- ^ Data type, but in irrelevant position. + | CoinductiveDatatype (Closure Type) -- ^ Split on codata not allowed. + -- UNUSED, but keep! + -- -- | NoRecordConstructor Type -- ^ record type, but no constructor + | CantSplit + { cantSplitConName :: QName -- ^ Constructor. + , cantSplitTel :: Telescope -- ^ Context for indices. + , cantSplitConIdx :: Args -- ^ Inferred indices (from type of constructor). + , cantSplitGivenIdx :: Args -- ^ Expected indices (from checking pattern). + } + | GenericSplitError String deriving (Show) instance Error SplitError where @@ -1762,8 +1840,13 @@ | NotAProjectionPattern (A.NamedArg A.Pattern) | NotAProperTerm | SetOmegaNotValidType + | InvalidTypeSort Sort + -- ^ This sort is not a type expression. | InvalidType Term -- ^ This term is not a type expression. + | FunctionTypeInSizeUniv Term + -- ^ This term, a function type constructor, lives in + -- @SizeUniv@, which is not allowed. | SplitOnIrrelevant A.Pattern (Dom Type) | DefinitionIsIrrelevant QName | VariableIsIrrelevant Name @@ -1905,7 +1988,7 @@ -- | Type-checking errors. data TCErr = TypeError TCState (Closure TypeError) - | Exception Range String + | Exception Range Doc | IOException Range E.IOException | PatternErr -- TCState -- ^ for pattern violations {- AbortAssign TCState -- ^ used to abort assignment to meta when there are instantiations -- UNUSED -} @@ -1913,11 +1996,11 @@ instance Error TCErr where noMsg = strMsg "" - strMsg = Exception noRange . strMsg + strMsg = Exception noRange . text . strMsg instance Show TCErr where show (TypeError _ e) = show (envRange $ clEnv e) ++ ": " ++ show (clValue e) - show (Exception r s) = show r ++ ": " ++ s + show (Exception r d) = show r ++ ": " ++ render d show (IOException r e) = show r ++ ": " ++ show e show PatternErr{} = "Pattern violation (you shouldn't see this)" {- show (AbortAssign _) = "Abort assignment (you shouldn't see this)" -- UNUSED -} @@ -2031,6 +2114,9 @@ instance MonadTCM tcm => MonadTCM (MaybeT tcm) where liftTCM = lift . liftTCM +instance MonadTCM tcm => MonadTCM (ListT tcm) where + liftTCM = lift . liftTCM + instance (Error err, MonadTCM tcm) => MonadTCM (ExceptT err tcm) where liftTCM = lift . liftTCM @@ -2095,9 +2181,9 @@ {-# INLINE apTCMT #-} instance MonadIO m => MonadIO (TCMT m) where - liftIO m = TCM $ \s e -> - do let r = envRange e - liftIO $ wrap r $ do + liftIO m = TCM $ \s e -> do + let r = envRange e + liftIO $ wrap r $ do x <- m x `seq` return x where @@ -2112,6 +2198,9 @@ internalError :: MonadTCM tcm => String -> tcm a internalError s = typeError $ InternalError s + +genericError :: MonadTCM tcm => String -> tcm a +genericError = typeError . GenericError {-# SPECIALIZE typeError :: TypeError -> TCM a #-} typeError :: MonadTCM tcm => TypeError -> tcm a diff --git a/src/full/Agda/TypeChecking/Monad/Base.hs-boot b/src/full/Agda/TypeChecking/Monad/Base.hs-boot --- a/src/full/Agda/TypeChecking/Monad/Base.hs-boot +++ b/src/full/Agda/TypeChecking/Monad/Base.hs-boot @@ -1,5 +1,3 @@ -{-# LANGUAGE KindSignatures #-} - module Agda.TypeChecking.Monad.Base where import Data.IORef (IORef) diff --git a/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs b/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs --- a/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs +++ b/src/full/Agda/TypeChecking/Monad/Base/Benchmark.hs @@ -2,6 +2,7 @@ module Agda.TypeChecking.Monad.Base.Benchmark where +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Trie as Trie import Agda.Utils.Time (CPUTime) @@ -53,8 +54,6 @@ -- ^ Subphase for 'Serialize'. | Operators -- ^ Subphase for 'Parsing'. - | BuildParser - -- ^ Subphase for 'Operators'. deriving (Eq, Ord, Show, Enum, Bounded) -- | Account we can bill computation time to. @@ -63,15 +62,31 @@ -- | Benchmark structure is a trie, mapping accounts (phases and subphases) -- to CPU time spent on their performance. -type Benchmark = Trie Phase CPUTime +data Benchmark = Benchmark + { currentAccount :: !(Strict.Maybe Account) + , timings :: !(Trie Phase CPUTime) + } +-- | Semantic editor combinator. +modifyCurrentAccount :: + (Strict.Maybe Account -> Strict.Maybe Account) -> + Benchmark -> Benchmark +modifyCurrentAccount f b = b { currentAccount = f (currentAccount b) } + +-- | Semantic editor combinator. +modifyTimings :: + (Trie Phase CPUTime -> Trie Phase CPUTime) -> + Benchmark -> Benchmark +modifyTimings f b = b { timings = f (timings b) } + -- | Initial benchmark structure (empty). empty :: Benchmark -empty = Trie.empty +empty = + Benchmark { currentAccount = Strict.Nothing, timings = Trie.empty } -- | Add to specified CPU time account. addCPUTime :: Account -> CPUTime -> Benchmark -> Benchmark -addCPUTime = Trie.insertWith (+) +addCPUTime acc t = modifyTimings (Trie.insertWith (+) acc t) -- -- | Lens modifier for specific entry in benchmark structure. -- mapCPUTime :: [Phase] → (CPUTime -> CPUTime) -> Benchmark -> Benchmark diff --git a/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs b/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs --- a/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs +++ b/src/full/Agda/TypeChecking/Monad/Base/KillRange.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + +#if __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +#endif --- | 'KillRange' instances for data structures from 'Agda.TypeChecking.Monad.Base'. +-- | 'KillRange' instances for data structures from "Agda.TypeChecking.Monad.Base". -- Andreas, 2014-05-03 module Agda.TypeChecking.Monad.Base.KillRange where @@ -35,6 +38,12 @@ killRange11 Defn ai name t pols occs displ mut compiled rew inst def -- TODO clarify: Keep the range in the defName field? +instance KillRange NLPat where + killRange (PVar x) = killRange1 PVar x + killRange (PWild) = PWild + killRange (PDef x y) = killRange2 PDef x y + killRange (PTerm x) = killRange1 PTerm x + instance KillRange RewriteRule where killRange (RewriteRule q gamma lhs rhs t) = killRange5 RewriteRule q gamma lhs rhs t @@ -111,7 +120,11 @@ killRange = fmap killRange -- | Overlaps with @KillRange [a]@. +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} KillRange String where +#else instance KillRange String where +#endif killRange = id -- | Remove ranges in keys and values of a map. diff --git a/src/full/Agda/TypeChecking/Monad/Benchmark.hs b/src/full/Agda/TypeChecking/Monad/Benchmark.hs --- a/src/full/Agda/TypeChecking/Monad/Benchmark.hs +++ b/src/full/Agda/TypeChecking/Monad/Benchmark.hs @@ -5,75 +5,87 @@ module Agda.TypeChecking.Monad.Benchmark ( module Agda.TypeChecking.Monad.Base.Benchmark , getBenchmark - , benchmarking, reportBenchmarkingLn, reportBenchmarkingDoc - , billTo, billTop, billPureTo, billSub - , reimburse, reimburseTop + , benchmarking + , billTo, billPureTo + , print ) where import qualified Control.Exception as E (evaluate) import Control.Monad.State +import Data.List +import Prelude hiding (print) +import qualified Text.PrettyPrint.Boxes as Boxes import Agda.TypeChecking.Monad.Base.Benchmark import Agda.TypeChecking.Monad.Base import{-# SOURCE #-} Agda.TypeChecking.Monad.Options import Agda.TypeChecking.Monad.State +import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad -import Agda.Utils.Pretty (Doc) +import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Time +import qualified Agda.Utils.Trie as Trie #include "undefined.h" import Agda.Utils.Impossible +benchmarkKey :: String +benchmarkKey = "profile" + +benchmarkLevel :: Int +benchmarkLevel = 7 + -- | Check whether benchmarking is activated. {-# SPECIALIZE benchmarking :: TCM Bool #-} benchmarking :: MonadTCM tcm => tcm Bool -benchmarking = liftTCM $ hasVerbosity "profile" 7 +benchmarking = liftTCM $ hasVerbosity benchmarkKey benchmarkLevel --- | Report benchmarking results. -reportBenchmarkingLn :: String -> TCM () -reportBenchmarkingLn = reportSLn "profile" 7 +-- | Prints the accumulated benchmark results. Does nothing if +-- profiling is not activated at level 7. +print :: MonadTCM tcm => tcm () +print = liftTCM $ whenM benchmarking $ do --- | Report benchmarking results. -reportBenchmarkingDoc :: TCM Doc -> TCM () -reportBenchmarkingDoc = reportSDoc "profile" 7 + (accounts, times) <- unzip . Trie.toList . timings <$> getBenchmark --- | Bill a computation to a specific account (True) or reimburse (False). -billTo' :: MonadTCM tcm => Bool -> Account -> tcm a -> tcm a -billTo' add k m = ifNotM benchmarking m {- else -} $ do - (res, time) <- measureTime $ liftIO . E.evaluate =<< m - addToAccount k $ if add then time else -time - return res + -- Generate a table. + let -- First column: Accounts. + col1 = Boxes.vcat Boxes.left $ + map Boxes.text $ + "Total" : map showAccount accounts + -- Second column: Times. + col2 = Boxes.vcat Boxes.right $ + map (Boxes.text . prettyShow) $ + sum times : times + table = Boxes.hsep 1 Boxes.left [col1, col2] + reportSLn benchmarkKey benchmarkLevel $ + Boxes.render table --- | Bill a computation to a specific account. -billTo :: MonadTCM tcm => Account -> tcm a -> tcm a -billTo = billTo' True + where + showAccount [] = "Miscellaneous" + showAccount ks = intercalate "." (map show ks) --- | Bill a top account. -billTop :: MonadTCM tcm => Phase -> tcm a -> tcm a -billTop k = billTo [k] +-- | Add CPU time to specified account. +addToAccount :: Account -> CPUTime -> TCM () +addToAccount k v = modifyBenchmark $ addCPUTime k v --- | Bill a sub account. -billSub :: MonadTCM tcm => Account -> tcm a -> tcm a -billSub [] = __IMPOSSIBLE__ -billSub k = reimburse (init k) . billTo k +-- | Bill a computation to a specific account. +billTo :: MonadTCM tcm => Account -> tcm a -> tcm a +billTo account m = ifNotM benchmarking m {- else -} $ do + oldAccount <- liftTCM $ do + oldAccount <- currentAccount <$> liftTCM getBenchmark + modifyBenchmark $ modifyCurrentAccount $ const (Strict.Just account) + return oldAccount + (res, time) <- measureTime $ liftIO . E.evaluate =<< m + liftTCM $ do + addToAccount account time + case oldAccount of + Strict.Just acc -> addToAccount acc (- time) + Strict.Nothing -> return () + modifyBenchmark $ modifyCurrentAccount $ const oldAccount + return res -- | Bill a pure computation to a specific account. {-# SPECIALIZE billPureTo :: Account -> a -> TCM a #-} billPureTo :: MonadTCM tcm => Account -> a -> tcm a -billPureTo k a = liftTCM $ billTo k $ return a --- billPureTo k a = liftTCM $ billTo k $ liftIO $ E.evaluate a - --- | Reimburse a specific account for computation costs. -reimburse :: MonadTCM tcm => Account -> tcm a -> tcm a -reimburse = billTo' False - --- | Reimburse a top account. -reimburseTop :: MonadTCM tcm => Phase -> tcm a -> tcm a -reimburseTop k = reimburse [k] - --- * Auxiliary functions - --- | Add CPU time to specified account. -addToAccount :: MonadTCM tcm => Account -> CPUTime -> tcm () -addToAccount k v = liftTCM $ modifyBenchmark $ addCPUTime k v +billPureTo k a = billTo k $ return a diff --git a/src/full/Agda/TypeChecking/Monad/Builtin.hs b/src/full/Agda/TypeChecking/Monad/Builtin.hs --- a/src/full/Agda/TypeChecking/Monad/Builtin.hs +++ b/src/full/Agda/TypeChecking/Monad/Builtin.hs @@ -29,14 +29,14 @@ litType :: Literal -> TCM Type litType l = case l of - LitInt _ n -> do - primZero - when_ (n > 0) $ primSuc - el <$> primNat - LitFloat _ _ -> el <$> primFloat - LitChar _ _ -> el <$> primChar - LitString _ _ -> el <$> primString - LitQName _ _ -> el <$> primQName + LitInt _ n -> do + _ <- primZero + when_ (n > 0) $ primSuc + el <$> primNat + LitFloat _ _ -> el <$> primFloat + LitChar _ _ -> el <$> primChar + LitString _ _ -> el <$> primString + LitQName _ _ -> el <$> primQName where el t = El (mkType 0) t @@ -109,12 +109,12 @@ primList, primNil, primCons, primIO, primNat, primSuc, primZero, primNatPlus, primNatMinus, primNatTimes, primNatDivSucAux, primNatModSucAux, primNatEquality, primNatLess, - primSize, primSizeLt, primSizeSuc, primSizeInf, + primSizeUniv, primSize, primSizeLt, primSizeSuc, primSizeInf, primSizeMax, primInf, primSharp, primFlat, primEquality, primRefl, primRewrite, -- Name of rewrite relation primLevel, primLevelZero, primLevelSuc, primLevelMax, - primIrrAxiom, primSizeMax, + primIrrAxiom, -- builtins for reflection: primQName, primArgInfo, primArgArgInfo, primArg, primArgArg, primAgdaTerm, primAgdaTermVar, primAgdaTermLam, primAgdaTermExtLam, primAgdaTermDef, primAgdaTermCon, primAgdaTermPi, @@ -153,6 +153,7 @@ primNatModSucAux = getBuiltin builtinNatModSucAux primNatEquality = getBuiltin builtinNatEquals primNatLess = getBuiltin builtinNatLess +primSizeUniv = getBuiltin builtinSizeUniv primSize = getBuiltin builtinSize primSizeLt = getBuiltin builtinSizeLt primSizeSuc = getBuiltin builtinSizeSuc @@ -228,9 +229,11 @@ builtinNat, builtinSuc, builtinZero, builtinNatPlus, builtinNatMinus, builtinNatTimes, builtinNatDivSucAux, builtinNatModSucAux, builtinNatEquals, builtinNatLess, builtinInteger, builtinFloat, builtinChar, builtinString, - builtinBool, builtinTrue, builtinFalse, builtinList, builtinNil, - builtinCons, builtinIO, builtinSize, builtinSizeLt, builtinSizeSuc, - builtinSizeInf, builtinSizeMax, builtinInf, builtinSharp, builtinFlat, + builtinBool, builtinTrue, builtinFalse, + builtinList, builtinNil, builtinCons, builtinIO, + builtinSizeUniv, builtinSize, builtinSizeLt, + builtinSizeSuc, builtinSizeInf, builtinSizeMax, + builtinInf, builtinSharp, builtinFlat, builtinEquality, builtinRefl, builtinRewrite, builtinLevelMax, builtinLevel, builtinLevelZero, builtinLevelSuc, builtinIrrAxiom, builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit, @@ -274,6 +277,7 @@ builtinNil = "NIL" builtinCons = "CONS" builtinIO = "IO" +builtinSizeUniv = "SIZEUNIV" builtinSize = "SIZE" builtinSizeLt = "SIZELT" builtinSizeSuc = "SIZESUC" @@ -345,6 +349,27 @@ builtinAgdaDefinitionPostulate = "AGDADEFINITIONPOSTULATE" builtinAgdaDefinitionPrimitive = "AGDADEFINITIONPRIMITIVE" builtinAgdaDefinition = "AGDADEFINITION" + +-- | Builtins that come without a definition in Agda syntax. +-- These are giving names to Agda internal concepts which +-- cannot be assigned an Agda type. +-- +-- An example would be a user-defined name for @Set@. +-- +-- {-# BUILTIN TYPE Type #-} +-- +-- The type of @Type@ would be @Type : Level → Setω@ +-- which is not valid Agda. + +builtinsNoDef :: [String] +builtinsNoDef = + [ builtinSizeUniv + , builtinSize + , builtinSizeLt + , builtinSizeSuc + , builtinSizeInf + , builtinSizeMax + ] -- | The coinductive primitives. diff --git a/src/full/Agda/TypeChecking/Monad/Constraints.hs b/src/full/Agda/TypeChecking/Monad/Constraints.hs --- a/src/full/Agda/TypeChecking/Monad/Constraints.hs +++ b/src/full/Agda/TypeChecking/Monad/Constraints.hs @@ -63,7 +63,7 @@ getAwakeConstraints :: TCM Constraints getAwakeConstraints = use stAwakeConstraints -wakeConstraints :: (ProblemConstraint-> Bool) -> TCM () +wakeConstraints :: (ProblemConstraint -> Bool) -> TCM () wakeConstraints wake = do (wakeup, sleepin) <- List.partition wake <$> use stSleepingConstraints reportSLn "tc.constr.wake" 50 $ diff --git a/src/full/Agda/TypeChecking/Monad/Context.hs b/src/full/Agda/TypeChecking/Monad/Context.hs --- a/src/full/Agda/TypeChecking/Monad/Context.hs +++ b/src/full/Agda/TypeChecking/Monad/Context.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} + +#if __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE OverlappingInstances #-} +#endif module Agda.TypeChecking.Monad.Context where @@ -9,6 +12,7 @@ import Data.List hiding (sort) import qualified Data.Map as Map +import Data.Monoid import Agda.Syntax.Abstract.Name import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo) @@ -88,7 +92,11 @@ class AddContext b where addContext :: MonadTCM tcm => b -> tcm a -> tcm a +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} AddContext a => AddContext [a] where +#else instance AddContext a => AddContext [a] where +#endif addContext = flip (foldr addContext) instance AddContext (Name, Dom Type) where @@ -101,6 +109,12 @@ instance AddContext ([Name], Dom Type) where addContext (xs, dom) = addContext (bindsToTel' id xs dom) +instance AddContext ([WithHiding Name], Dom Type) where + addContext ([] , dom) = id + addContext (WithHiding h x : xs, dom) = + addContext (x , mapHiding (mappend h) dom) . + addContext (xs, raise 1 dom) + instance AddContext (String, Dom Type) where addContext (s, dom) ret = do x <- freshName_ s @@ -113,7 +127,11 @@ instance AddContext Name where addContext x = addContext (x, dummyDom) +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} AddContext String where +#else instance AddContext String where +#endif addContext s = addContext (s, dummyDom) instance AddContext Telescope where diff --git a/src/full/Agda/TypeChecking/Monad/Exception.hs b/src/full/Agda/TypeChecking/Monad/Exception.hs --- a/src/full/Agda/TypeChecking/Monad/Exception.hs +++ b/src/full/Agda/TypeChecking/Monad/Exception.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} -- | Basically a copy of the ErrorT monad transformer. It's handy to slap -- onto TCM and still be a MonadTCM (which isn't possible with ErrorT). diff --git a/src/full/Agda/TypeChecking/Monad/MetaVars.hs b/src/full/Agda/TypeChecking/Monad/MetaVars.hs --- a/src/full/Agda/TypeChecking/Monad/MetaVars.hs +++ b/src/full/Agda/TypeChecking/Monad/MetaVars.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + FlexibleInstances, + TupleSections #-} module Agda.TypeChecking.Monad.MetaVars where import Control.Applicative import Control.Monad.State import Control.Monad.Reader +import Control.Monad.Writer import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,11 +27,13 @@ import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Substitute +import Agda.Utils.Map.Compat as MapC import Agda.Utils.Functor ((<.>)) import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Permutation +import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Tuple import Agda.Utils.Size @@ -51,7 +54,7 @@ -- | Lookup a meta variable lookupMeta :: MetaId -> TCM MetaVariable lookupMeta m = fromMaybeM failure $ Map.lookup m <$> getMetaStore - where failure = fail $ "no such meta variable " ++ show m + where failure = fail $ "no such meta variable " ++ prettyShow m updateMetaVar :: MetaId -> (MetaVariable -> MetaVariable) -> TCM () updateMetaVar m f = modifyMetaStore $ Map.adjust f m @@ -169,7 +172,7 @@ setMetaNameSuggestion :: MetaId -> MetaNameSuggestion -> TCM () setMetaNameSuggestion mi s = do reportSLn "tc.meta.name" 20 $ - "setting name of meta " ++ show mi ++ " to " ++ s + "setting name of meta " ++ prettyShow mi ++ " to " ++ s updateMetaVar mi $ \ mvar -> mvar { mvInfo = (mvInfo mvar) { miNameSuggestion = s }} @@ -251,16 +254,16 @@ err2 = typeError $ GenericError $ "No type nor action available for hole " ++ show ii -- | Generate new meta variable. -newMeta :: MetaInfo -> MetaPriority -> Permutation -> Judgement Type a -> TCM MetaId +newMeta :: MetaInfo -> MetaPriority -> Permutation -> Judgement a -> TCM MetaId newMeta = newMeta' Open -- | Generate a new meta variable with some instantiation given. -- For instance, the instantiation could be a 'PostponedTypeCheckingProblem'. newMeta' :: MetaInstantiation -> MetaInfo -> MetaPriority -> Permutation -> - Judgement Type a -> TCM MetaId + Judgement a -> TCM MetaId newMeta' inst mi p perm j = do x <- fresh - let j' = fmap (const x) j -- fill the identifier part of the judgement + let j' = j { jMetaId = x } -- fill the identifier part of the judgement mv = MetaVar mi p perm j' inst Set.empty Instantiable -- printing not available (import cycle) -- reportSDoc "tc.meta.new" 50 $ text "new meta" <+> prettyTCM j' @@ -332,18 +335,29 @@ -- * Freezing and unfreezing metas. --------------------------------------------------------------------------- --- | Freeze all meta variables. -freezeMetas :: TCM () -freezeMetas = modifyMetaStore $ Map.map freeze where - freeze :: MetaVariable -> MetaVariable - freeze mvar = mvar { mvFrozen = Frozen } +-- | Freeze all meta variables and return the list of metas that got frozen. +freezeMetas :: TCM [MetaId] +freezeMetas = execWriterT $ stMetaStore %== MapC.traverseWithKey freeze + where + freeze :: Monad m => MetaId -> MetaVariable -> WriterT [MetaId] m MetaVariable + freeze m mvar + | mvFrozen mvar == Frozen = return mvar + | otherwise = do + tell [m] + return $ mvar { mvFrozen = Frozen } -- | Thaw all meta variables. unfreezeMetas :: TCM () -unfreezeMetas = modifyMetaStore $ Map.map unfreeze where - unfreeze :: MetaVariable -> MetaVariable - unfreeze mvar = mvar { mvFrozen = Instantiable } +unfreezeMetas = unfreezeMetas' $ const True +-- | Thaw some metas, as indicated by the passed condition. +unfreezeMetas' :: (MetaId -> Bool) -> TCM () +unfreezeMetas' cond = modifyMetaStore $ Map.mapWithKey unfreeze where + unfreeze :: MetaId -> MetaVariable -> MetaVariable + unfreeze m mvar + | cond m = mvar { mvFrozen = Instantiable } + | otherwise = mvar + isFrozen :: MetaId -> TCM Bool isFrozen x = do mvar <- lookupMeta x @@ -385,7 +399,7 @@ instance UnFreezeMeta LevelAtom where unfreezeMeta (MetaLevel x _) = unfreezeMeta x unfreezeMeta (BlockedLevel _ t) = unfreezeMeta t - unfreezeMeta (NeutralLevel t) = unfreezeMeta t + unfreezeMeta (NeutralLevel _ t) = unfreezeMeta t unfreezeMeta (UnreducedLevel t) = unfreezeMeta t instance UnFreezeMeta a => UnFreezeMeta [a] where diff --git a/src/full/Agda/TypeChecking/Monad/Mutual.hs b/src/full/Agda/TypeChecking/Monad/Mutual.hs --- a/src/full/Agda/TypeChecking/Monad/Mutual.hs +++ b/src/full/Agda/TypeChecking/Monad/Mutual.hs @@ -4,14 +4,17 @@ import Control.Monad.Reader import Control.Monad.State + import qualified Data.Map as Map import Data.Set (Set) import Data.Functor ((<$>)) import qualified Data.Set as Set -import qualified Agda.Utils.HashMap as HMap import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.State + +import qualified Agda.Utils.HashMap as HMap import Agda.Utils.Lens noMutualBlock :: TCM a -> TCM a @@ -31,9 +34,7 @@ setMutualBlock :: MutualId -> QName -> TCM () setMutualBlock i x = do stMutualBlocks %= Map.insertWith Set.union i (Set.singleton x) - stSignature %= \sig -> sig { sigDefinitions = setMutId x i $ sigDefinitions sig } - where - setMutId x i = flip HMap.adjust x $ \defn -> defn { defMutual = i } + stSignature %= updateDefinition x (\ defn -> defn { defMutual = i }) -- | Get all mutual blocks getMutualBlocks :: TCM [Set QName] diff --git a/src/full/Agda/TypeChecking/Monad/Options.hs b/src/full/Agda/TypeChecking/Monad/Options.hs --- a/src/full/Agda/TypeChecking/Monad/Options.hs +++ b/src/full/Agda/TypeChecking/Monad/Options.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module Agda.TypeChecking.Monad.Options where +import Prelude hiding (mapM) + import Control.Applicative -import Control.Monad.Reader -import Control.Monad.State +import Control.Monad.Reader hiding (mapM) +import Control.Monad.State hiding (mapM) + import Data.Maybe +import Data.Traversable + import Text.PrettyPrint import System.Directory import System.FilePath -import Paths_Agda (getDataFileName) --- NB: find Paths_Agda.hs in dist/build/autogen/ - import Agda.Syntax.Concrete import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base @@ -25,6 +27,7 @@ import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.FileName +import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Lens import Agda.Utils.List @@ -182,7 +185,7 @@ incs <- return $ map (mkAbsolute . (filePath root )) incs -- Andreas, 2013-10-30 Add default include dir - libdir <- liftIO $ getDataFileName ("lib") + libdir <- liftIO $ defaultLibDir -- NB: This is an absolute file name, but -- Agda.Utils.FilePath wants to check absoluteness anyway. let primdir = mkAbsolute $ libdir "prim" @@ -216,11 +219,13 @@ -- | Should only be run if 'hasInputFile'. getInputFile :: TCM AbsolutePath -getInputFile = - do mf <- optInputFile <$> commandLineOptions - case mf of - Just file -> liftIO $ absolute file - Nothing -> __IMPOSSIBLE__ +getInputFile = fromMaybeM __IMPOSSIBLE__ $ + getInputFile' + +-- | Return the 'optInputFile' as 'AbsolutePath', if any. +getInputFile' :: TCM (Maybe AbsolutePath) +getInputFile' = mapM (liftIO . absolute) =<< do + optInputFile <$> commandLineOptions hasInputFile :: TCM Bool hasInputFile = isJust <$> optInputFile <$> commandLineOptions diff --git a/src/full/Agda/TypeChecking/Monad/Signature.hs b/src/full/Agda/TypeChecking/Monad/Signature.hs --- a/src/full/Agda/TypeChecking/Monad/Signature.hs +++ b/src/full/Agda/TypeChecking/Monad/Signature.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Monad.Signature where +import Control.Arrow (first, second, (***)) import Control.Applicative import Control.Monad.State import Control.Monad.Reader @@ -35,6 +36,7 @@ import {-# SOURCE #-} Agda.TypeChecking.Polarity import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike +import Agda.Utils.Functor import Agda.Utils.Map as Map import Agda.Utils.Maybe import Agda.Utils.Monad @@ -59,8 +61,7 @@ _ -> tel let d' = abstract tel' $ d { defName = q } reportSLn "tc.signature" 30 $ "lambda-lifted definition = " ++ show d' - modifySignature $ \sig -> sig - { sigDefinitions = HMap.insertWith (+++) q d' $ sigDefinitions sig } + modifySignature $ updateDefinitions $ HMap.insertWith (+++) q d' i <- currentOrFreshMutualBlock setMutualBlock i q where @@ -151,13 +152,6 @@ addDisplayForms x = do def <- getConstInfo x args <- getContextArgs -{- OLD - n <- do - proj <- isProjection x - return $ case proj of - Just (_, n) -> n - Nothing -> 0 --} add (drop (projectionArgs $ theDef def) args) x x [] where add args top x vs0 = do @@ -216,9 +210,9 @@ reportSLn "tc.mod.apply" 80 $ render $ vcat [ text "arguments: " <+> text (show ts) ] - mapM_ (copyDef ts) $ Map.toList rd - mapM_ (copySec ts) $ Map.toList rm - mapM_ computePolarity (Map.elems rd) + mapM_ (copyDef ts) rd + mapM_ (copySec ts) rm + mapM_ computePolarity (map snd rd) where -- Andreas, 2013-10-29 -- Here, if the name x is not imported, it persists as @@ -228,13 +222,13 @@ -- I guess it would make sense to mark non-imported names -- as such (out-of-scope) and let splitting fail if it would -- produce out-of-scope constructors. - copyName x = Map.findWithDefault x x rd + copyName x = fromMaybe x $ lookup x rd argsToUse new = do let m = mnameFromList $ commonPrefix (mnameToList old) (mnameToList new) reportSLn "tc.mod.apply" 80 $ "Common prefix: " ++ show m let ms = tail . map mnameFromList . inits . mnameToList $ m - ps <- sequence [ maybe 0 secFreeVars <$> getSection m | m <- ms ] + ps <- mapM (maybe 0 secFreeVars <.> getSection) ms reportSLn "tc.mod.apply" 80 $ " params: " ++ show (zip ms ps) return $ sum ps @@ -246,9 +240,10 @@ where copyDef' np d = do reportSLn "tc.mod.apply" 80 $ "making new def for " ++ show y ++ " from " ++ show x ++ " with " ++ show np ++ " args" - reportSLn "tc.mod.apply" 80 $ "args = " ++ show ts' ++ "\n" ++ - "old type = " ++ showTerm (unEl $ defType d) ++ "\n" ++ - "new type = " ++ showTerm (unEl t) + reportSLn "tc.mod.apply" 80 $ + "args = " ++ show ts' ++ "\n" ++ + "old type = " ++ prettyShow (defType d) ++ "\n" ++ + "new type = " ++ prettyShow t addConstant y =<< nd y makeProjection y -- Set display form for the old name if it's not a constructor. @@ -259,8 +254,7 @@ -- Issue1238: the copied def should be an 'instance' if the original -- def is one. Skip constructors since the original constructor will -- still work as an instance. - unless isCon $ flip (maybe (return ())) inst $ \c -> addNamedInstance y c - + unless isCon $ whenJust inst $ \ c -> addNamedInstance y c unless (isCon || size ptel > 0) $ do addDisplayForms y where @@ -278,27 +272,18 @@ mutual = case oldDef of { Function{funMutual = m} -> m ; _ -> [] } extlam = case oldDef of { Function{funExtLam = e} -> e ; _ -> Nothing } with = case oldDef of { Function{funWith = w} -> copyName <$> w ; _ -> Nothing } -{- THIS BREAKS A LOT OF THINGS: - -- Andreas, 2013-10-21: - -- Even if we apply the record argument, we stay a projection. + -- Andreas, 2015-05-11, to fix issue 1413: + -- Even if we apply the record argument (must be @var 0@), we stay a projection. -- This is because we may abstract the record argument later again. -- See succeed/ProjectionNotNormalized.agda + isVar0 t = case ignoreSharing $ unArg t of Var 0 [] -> True; _ -> False proj = case oldDef of Function{funProjection = Just p@Projection{projIndex = n}} - -> Just $ p { projIndex = n - size ts - , projDropPars = projDropPars p `apply` ts - } - _ -> Nothing --} - -- NB (Andreas, 2013-10-19): - -- If we apply the record argument, we are no longer a projection! - proj = case oldDef of - Function{funProjection = Just p@Projection{projIndex = n}} | size ts < n + | size ts < n || (size ts == n && isVar0 (last ts)) -> Just $ p { projIndex = n - size ts , projDropPars = projDropPars p `apply` ts } _ -> Nothing - def = case oldDef of Constructor{ conPars = np, conData = d } -> return $ @@ -350,26 +335,28 @@ copySec :: Args -> (ModuleName, ModuleName) -> TCM () copySec ts (x, y) = do - np <- argsToUse x - tel <- lookupSection x - let fv = size tel - np + totalArgs <- argsToUse x + tel <- lookupSection x + ptel <- lookupSection $ mnameFromList $ init $ mnameToList x + let parentParams = size ptel + childParams = size tel - parentParams + argsToChild = max 0 $ totalArgs - parentParams + let fv = childParams - argsToChild reportSLn "tc.mod.apply" 80 $ "Copying section " ++ show x ++ " to " ++ show y reportSLn "tc.mod.apply" 80 $ " free variables: " ++ show fv reportSLn "tc.mod.apply" 80 $ " ts = " ++ show ts - reportSLn "tc.mod.apply" 80 $ " tel = " ++ show tel - reportSLn "tc.mod.apply" 80 $ " np = " ++ show np - addCtxTel (apply tel $ take np ts) $ addSection y fv + reportSLn "tc.mod.apply" 80 $ " tel = " ++ show (map (second unEl . unDom) $ telToList tel) + reportSLn "tc.mod.apply" 80 $ " ptel = " ++ show (map (second unEl . unDom) $ telToList ptel) + reportSLn "tc.mod.apply" 80 $ " np = " ++ show totalArgs + addCtxTel (apply tel $ take totalArgs ts) $ addSection y fv +-- | Add a display form to a definition (could be in this or imported signature). addDisplayForm :: QName -> DisplayForm -> TCM () addDisplayForm x df = do d <- makeOpen df - modifyImportedSignature (add d) - modifySignature (add d) - where - add df sig = sig { sigDefinitions = HMap.adjust addDf x defs } - where - addDf def = def { defDisplay = df : defDisplay def } - defs = sigDefinitions sig + let add = updateDefinition x $ \ def -> def{ defDisplay = d : defDisplay def } + modifyImportedSignature add + modifySignature add canonicalName :: QName -> TCM QName canonicalName x = do @@ -668,7 +655,8 @@ _ -> fail $ "Expected " ++ show q ++ " to be a datatype." -- | Is it the name of a record projection? -isProjection :: QName -> TCM (Maybe Projection) +{-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-} +isProjection :: HasConstInfo m => QName -> m (Maybe Projection) isProjection qn = isProjection_ . theDef <$> getConstInfo qn isProjection_ :: Defn -> Maybe Projection @@ -677,23 +665,27 @@ Function { funProjection = result } -> result _ -> Nothing +-- | Returns @True@ if we are dealing with a proper projection, +-- i.e., not a projection-like function nor a record field value +-- (projection applied to argument). isProperProjection :: Defn -> Bool -isProperProjection = isJust . (projProper <=< isProjection_) --- isProperProjection = maybe False projProper . isProjection_ +isProperProjection d = caseMaybe (isProjection_ d) False $ \ isP -> + if projIndex isP <= 0 then False else isJust $ projProper isP -- | Number of dropped initial arguments. projectionArgs :: Defn -> Int -projectionArgs = maybe 0 (pred . projIndex) . isProjection_ +projectionArgs = maybe 0 (max 0 . pred . projIndex) . isProjection_ -- | Apply a function @f@ to its first argument, producing the proper -- postfix projection if @f@ is a projection. applyDef :: QName -> I.Arg Term -> TCM Term applyDef f a = do - -- get the original projection, if existing - res <- (projProper =<<) <$> isProjection f - case res of - Nothing -> return $ Def f [Apply a] - Just f' -> return $ unArg a `applyE` [Proj f'] + let fallback = return $ Def f [Apply a] + caseMaybeM (isProjection f) fallback $ \ isP -> do + if projIndex isP <= 0 then fallback else do + -- Get the original projection, if existing. + caseMaybe (projProper isP) fallback $ \ f' -> do + return $ unArg a `applyE` [Proj f'] -- | @getDefType f t@ computes the type of (possibly projection-(like)) -- function @t@ whose first argument has type @t@. @@ -709,8 +701,9 @@ def <- getConstInfo f let a = defType def -- if @f@ is not a projection (like) function, @a@ is the correct type - caseMaybe (isProjection_ $ theDef def) (return $ Just a) $ - \ (Projection{ projIndex = n }) -> do + fallback = return $ Just a + caseMaybe (isProjection_ $ theDef def) fallback $ + \ (Projection{ projIndex = n }) -> if n <= 0 then fallback else do -- otherwise, we have to instantiate @a@ to the "parameters" of @f@ let npars | n == 0 = __IMPOSSIBLE__ | otherwise = n - 1 diff --git a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs --- a/src/full/Agda/TypeChecking/Monad/SizedTypes.hs +++ b/src/full/Agda/TypeChecking/Monad/SizedTypes.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TupleSections #-} -- | Stuff for sized types that does not require modules --- 'Agda.TypeChecking.Reduce' or 'Agda.TypeChecking.Constraints' --- (which import 'Agda.TypeChecking.Monad'). +-- "Agda.TypeChecking.Reduce" or "Agda.TypeChecking.Constraints" +-- (which import "Agda.TypeChecking.Monad"). module Agda.TypeChecking.Monad.SizedTypes where @@ -85,8 +85,8 @@ `catchError` \_ -> return False -- | Add polarity info to a SIZE builtin. -builtinSizeHook :: String -> QName -> Term -> Type -> TCM () -builtinSizeHook s q e' t = do +builtinSizeHook :: String -> QName -> Type -> TCM () +builtinSizeHook s q t = do when (s `elem` [builtinSizeLt, builtinSizeSuc]) $ do modifySignature $ updateDefinition q $ updateDefPolarity (const [Covariant]) diff --git a/src/full/Agda/TypeChecking/Monad/State.hs b/src/full/Agda/TypeChecking/Monad/State.hs --- a/src/full/Agda/TypeChecking/Monad/State.hs +++ b/src/full/Agda/TypeChecking/Monad/State.hs @@ -30,7 +30,7 @@ import Agda.Utils.Hash import qualified Agda.Utils.HashMap as HMap import Agda.Utils.Lens -import Agda.Utils.Monad (bracket_) +import Agda.Utils.Monad (bracket_, modify') import Agda.Utils.Pretty import Agda.Utils.Tuple @@ -190,8 +190,11 @@ lookupDefinition :: QName -> Signature -> Maybe Definition lookupDefinition q sig = HMap.lookup q $ sigDefinitions sig +updateDefinitions :: (Definitions -> Definitions) -> Signature -> Signature +updateDefinitions f sig = sig { sigDefinitions = f (sigDefinitions sig) } + updateDefinition :: QName -> (Definition -> Definition) -> Signature -> Signature -updateDefinition q f sig = sig { sigDefinitions = HMap.adjust f q (sigDefinitions sig) } +updateDefinition q f = updateDefinitions $ HMap.adjust f q updateTheDef :: (Defn -> Defn) -> (Definition -> Definition) updateTheDef f def = def { theDef = f (theDef def) } @@ -309,7 +312,7 @@ -- | Lens modify for 'Benchmark'. modifyBenchmark :: (Benchmark -> Benchmark) -> TCM () -modifyBenchmark = modify . updateBenchmark +modifyBenchmark = modify' . updateBenchmark -- | Run a fresh instance of the TCM (with initial state). -- 'Benchmark' info is preserved. diff --git a/src/full/Agda/TypeChecking/Monad/Statistics.hs b/src/full/Agda/TypeChecking/Monad/Statistics.hs --- a/src/full/Agda/TypeChecking/Monad/Statistics.hs +++ b/src/full/Agda/TypeChecking/Monad/Statistics.hs @@ -61,11 +61,11 @@ printStatistics :: Int -> Maybe C.TopLevelModuleName -> Statistics -> TCM () printStatistics vl mmname stats = verboseS "profile" vl $ do unlessNull (Map.toList stats) $ \ stats -> do - let -- First column (left aligned) is accounts. - col1 = Boxes.vcat Boxes.left $ map (Boxes.text . fst) stats - -- Second column (right aligned) is numbers. - col2 = Boxes.vcat Boxes.right $ map (Boxes.text . showThousandSep . snd) stats - table = Boxes.hsep 1 Boxes.left [col1, col2] - reportSLn "profile" 1 $ caseMaybe mmname "Accumlated statistics" $ \ mname -> - "Statistics for " ++ prettyShow mname - reportSLn "profile" 1 $ Boxes.render table + let -- First column (left aligned) is accounts. + col1 = Boxes.vcat Boxes.left $ map (Boxes.text . fst) stats + -- Second column (right aligned) is numbers. + col2 = Boxes.vcat Boxes.right $ map (Boxes.text . showThousandSep . snd) stats + table = Boxes.hsep 1 Boxes.left [col1, col2] + reportSLn "profile" 1 $ caseMaybe mmname "Accumlated statistics" $ \ mname -> + "Statistics for " ++ prettyShow mname + reportSLn "profile" 1 $ Boxes.render table diff --git a/src/full/Agda/TypeChecking/Monad/Trace.hs b/src/full/Agda/TypeChecking/Monad/Trace.hs --- a/src/full/Agda/TypeChecking/Monad/Trace.hs +++ b/src/full/Agda/TypeChecking/Monad/Trace.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Agda.TypeChecking.Monad.Trace where import Prelude hiding (null) @@ -9,11 +11,17 @@ import Agda.Syntax.Position import Agda.TypeChecking.Monad.Base +import Agda.TypeChecking.Monad.Options import Agda.Utils.Function +import Agda.Utils.List +import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null +#include "undefined.h" +import Agda.Utils.Impossible + --------------------------------------------------------------------------- -- * Trace --------------------------------------------------------------------------- @@ -36,6 +44,16 @@ traceCall mkCall m = do let call = mkCall Nothing callRange = getRange call + -- Andreas, 2015-02-09 Make sure we do not set a range + -- outside the current file + unlessNull callRange $ \ (Range is) -> + unlessNull (mapMaybe srcFile $ map iStart is ++ map iEnd is) $ \ files -> do + whenJustM (asks envCurrentPath) $ \ currentFile -> do + unlessNull (filter (/= currentFile) files) $ \ wrongFiles -> do + reportSLn "impossible" 10 $ + "Someone is trying to set the current range to " ++ show callRange ++ + " which is outside of the current file " ++ show currentFile + __IMPOSSIBLE__ cl <- liftTCM $ buildClosure call let trace = local $ foldr (.) id $ [ \e -> e { envCall = Just cl } | interestingCall cl ] ++ @@ -97,5 +115,8 @@ getCurrentRange :: TCM Range getCurrentRange = asks envRange -setCurrentRange :: Range -> TCM a -> TCM a -setCurrentRange r = applyUnless (null r) $ traceCall $ SetRange r +-- | Sets the current range (for error messages etc.) to the range +-- of the given object, if it has a range (i.e., its range is not 'noRange'). +setCurrentRange :: HasRange x => x -> TCM a -> TCM a +setCurrentRange x = applyUnless (null r) $ traceCall $ SetRange r + where r = getRange x diff --git a/src/full/Agda/TypeChecking/Patterns/Abstract.hs b/src/full/Agda/TypeChecking/Patterns/Abstract.hs --- a/src/full/Agda/TypeChecking/Patterns/Abstract.hs +++ b/src/full/Agda/TypeChecking/Patterns/Abstract.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Tools to manipulate patterns in abstract syntax -- in the TCM (type checking monad). @@ -80,7 +79,7 @@ A.ConP i ds as -> A.ConP i ds <$> expandPatternSynonyms as A.DefP i q as -> A.DefP i q <$> expandPatternSynonyms as A.AsP i x p -> A.AsP i x <$> expandPatternSynonyms p - A.PatternSynP i x as -> setCurrentRange (getRange i) $ do + A.PatternSynP i x as -> setCurrentRange i $ do p <- killRange <$> lookupPatternSyn x -- Must expand arguments before instantiating otherwise pattern -- synonyms could get into dot patterns (which is __IMPOSSIBLE__) diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs b/src/full/Agda/TypeChecking/Patterns/Match.hs --- a/src/full/Agda/TypeChecking/Patterns/Match.hs +++ b/src/full/Agda/TypeChecking/Patterns/Match.hs @@ -1,9 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ScopedTypeVariables #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveFunctor, + ScopedTypeVariables #-} +-- | Pattern matcher used in the reducer for clauses that +-- have not been compiled to case trees yet. + module Agda.TypeChecking.Patterns.Match where +import Prelude hiding (null) + import Data.Monoid import Data.Traversable (traverse) @@ -18,6 +24,7 @@ import Agda.Utils.Functor (for, ($>)) import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Tuple @@ -28,25 +35,33 @@ -- it is due to a particular meta variable. data Match a = Yes Simplification [a] | No - | DontKnow (Maybe MetaId) + | DontKnow (Blocked ()) deriving Functor -instance Monoid (Match a) where - mempty = Yes mempty [] +instance Null (Match a) where + empty = Yes empty empty + null (Yes simpl as) = null simpl && null as + null _ = False - Yes s us `mappend` Yes s' vs = Yes (s `mappend` s') (us ++ vs) - Yes _ _ `mappend` No = No - Yes _ _ `mappend` DontKnow m = DontKnow m - No `mappend` _ = No +-- 'mappend' is UNUSED. +-- +-- instance Monoid (Match a) where +-- mempty = Yes mempty [] - -- Nothing means blocked by a variable. In this case no instantiation of - -- meta-variables will make progress. - DontKnow _ `mappend` DontKnow Nothing = DontKnow Nothing +-- Yes s us `mappend` Yes s' vs = Yes (s `mappend` s') (us ++ vs) +-- Yes _ _ `mappend` No = No +-- Yes _ _ `mappend` DontKnow m = DontKnow m +-- No `mappend` _ = No - -- One could imagine DontKnow _ `mappend` No = No, but would break the - -- equivalence to case-trees. - DontKnow m `mappend` _ = DontKnow m +-- -- @NotBlocked (StuckOn e)@ means blocked by a variable. +-- -- In this case, no instantiation of +-- -- meta-variables will make progress. +-- DontKnow b `mappend` DontKnow b' = DontKnow $ b `mappend` b' +-- -- One could imagine DontKnow _ `mappend` No = No, but would break the +-- -- equivalence to case-trees. +-- DontKnow m `mappend` _ = DontKnow m + -- | Instead of 'zipWithM', we need to use this lazy version -- of combining pattern matching computations. @@ -66,26 +81,26 @@ -- upon failure, no further matching is performed. foldMatch - :: forall a b . (a -> b -> ReduceM (Match Term, b)) - -> [a] -> [b] -> ReduceM (Match Term, [b]) + :: forall p v . (p -> v -> ReduceM (Match Term, v)) + -> [p] -> [v] -> ReduceM (Match Term, [v]) foldMatch match = loop where - loop :: [a] -> [b] -> ReduceM (Match Term, [b]) + loop :: [p] -> [v] -> ReduceM (Match Term, [v]) loop ps0 vs0 = do - case (ps0, vs0) of - ([], []) -> return (mempty, []) - (p : ps, v : vs) -> do - (r, v') <- match p v - case r of - No -> return (No , v' : vs) - DontKnow m -> return (DontKnow m, v' : vs) - Yes s us -> do - (r', vs') <- loop ps vs - let vs1 = v' : vs' - case r' of - Yes s' us' -> return (Yes (s `mappend` s') (us ++ us'), vs1) - No -> return (No , vs1) - DontKnow m -> return (DontKnow m , vs1) - _ -> __IMPOSSIBLE__ + case (ps0, vs0) of + ([], []) -> return (empty, []) + (p : ps, v : vs) -> do + (r, v') <- match p v + case r of + No -> return (No , v' : vs) + DontKnow m -> return (DontKnow m, v' : vs) + Yes s us -> do + (r', vs') <- loop ps vs + let vs1 = v' : vs' + case r' of + Yes s' us' -> return (Yes (s `mappend` s') (us ++ us'), vs1) + No -> return (No , vs1) + DontKnow m -> return (DontKnow m , vs1) + _ -> __IMPOSSIBLE__ -- | @matchCopatterns ps es@ matches spine @es@ against copattern spine @ps@. -- @@ -102,36 +117,35 @@ -- to come to a decision). matchCopatterns :: [I.NamedArg Pattern] -> [Elim] -> ReduceM (Match Term, [Elim]) matchCopatterns ps vs = do - traceSDoc "tc.match" 50 - (vcat [ text "matchCopatterns" - , nest 2 $ text "ps =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) ps) - , nest 2 $ text "vs =" <+> fsep (punctuate comma $ map prettyTCM vs) - ]) $ do - -- Buggy, see issue 1124: - -- mapFst mconcat . unzip <$> zipWithM' (matchCopattern . namedArg) ps vs - foldMatch (matchCopattern . namedArg) ps vs + traceSDoc "tc.match" 50 + (vcat [ text "matchCopatterns" + , nest 2 $ text "ps =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) ps) + , nest 2 $ text "vs =" <+> fsep (punctuate comma $ map prettyTCM vs) + ]) $ do + -- Buggy, see issue 1124: + -- mapFst mconcat . unzip <$> zipWithM' (matchCopattern . namedArg) ps vs + foldMatch (matchCopattern . namedArg) ps vs -- | Match a single copattern. matchCopattern :: Pattern -> Elim -> ReduceM (Match Term, Elim) matchCopattern (ProjP p) elim@(Proj q) | p == q = return (Yes YesSimplification [], elim) | otherwise = return (No , elim) -matchCopattern (ProjP p) elim@Apply{} - = return (DontKnow Nothing, elim) -matchCopattern _ elim@Proj{} = return (DontKnow Nothing, elim) -matchCopattern p (Apply v) = mapSnd Apply <$> matchPattern p v +matchCopattern ProjP{} Apply{} = __IMPOSSIBLE__ +matchCopattern _ Proj{} = __IMPOSSIBLE__ +matchCopattern p (Apply v) = mapSnd Apply <$> matchPattern p v matchPatterns :: [I.NamedArg Pattern] -> [I.Arg Term] -> ReduceM (Match Term, [I.Arg Term]) matchPatterns ps vs = do - traceSDoc "tc.match" 50 - (vcat [ text "matchPatterns" - , nest 2 $ text "ps =" <+> fsep (punctuate comma $ map (text . show) ps) - , nest 2 $ text "vs =" <+> fsep (punctuate comma $ map prettyTCM vs) - ]) $ do - -- Buggy, see issue 1124: - -- (ms,vs) <- unzip <$> zipWithM' (matchPattern . namedArg) ps vs - -- return (mconcat ms, vs) - foldMatch (matchPattern . namedArg) ps vs + traceSDoc "tc.match" 50 + (vcat [ text "matchPatterns" + , nest 2 $ text "ps =" <+> fsep (punctuate comma $ map (text . show) ps) + , nest 2 $ text "vs =" <+> fsep (punctuate comma $ map prettyTCM vs) + ]) $ do + -- Buggy, see issue 1124: + -- (ms,vs) <- unzip <$> zipWithM' (matchPattern . namedArg) ps vs + -- return (mconcat ms, vs) + foldMatch (matchPattern . namedArg) ps vs -- | Match a single pattern. matchPattern :: Pattern -> I.Arg Term -> ReduceM (Match Term, I.Arg Term) @@ -143,27 +157,18 @@ w <- reduceB' v let arg' = arg $> ignoreBlocking w case ignoreSharing <$> w of - NotBlocked (Lit l') - | l == l' -> return (Yes YesSimplification [] , arg') - | otherwise -> return (No , arg') - NotBlocked (MetaV x _) -> return (DontKnow $ Just x , arg') - Blocked x _ -> return (DontKnow $ Just x , arg') - _ -> return (DontKnow Nothing , arg') - -{- Andreas, 2012-04-02 NO LONGER UP-TO-DATE -matchPattern (Arg h' r' (ConP c _ ps)) (Arg h Irrelevant v) = do - -- Andreas, 2010-09-07 matching a record constructor against - -- something irrelevant will just continue matching against - -- irrelevant stuff - (m, vs) <- matchPatterns ps $ - repeat $ Arg NotHidden Irrelevant $ DontCare __IMPOSSIBLE__ - return (m, Arg h Irrelevant $ Con c vs) --} + NotBlocked _ (Lit l') + | l == l' -> return (Yes YesSimplification [] , arg') + | otherwise -> return (No , arg') + NotBlocked _ (MetaV x _) -> return (DontKnow $ Blocked x () , arg') + Blocked x _ -> return (DontKnow $ Blocked x () , arg') + NotBlocked r t -> return (DontKnow $ NotBlocked r' () , arg') + where r' = stuckOn (Apply arg') r -- Case record pattern: always succeed! -- This case is necessary if we want to use the clauses before -- record pattern translation (e.g., in type-checking definitions by copatterns). - (ConP con@(ConHead c _ ds) Just{} ps, arg@(Arg info v)) + (ConP con@(ConHead c _ ds) ConPatternInfo{conPRecord = Just{}} ps, arg@(Arg info v)) -- precondition: con actually comes with the record fields | size ds == size ps -> mapSnd (Arg info . Con con) <$> do matchPatterns ps $ for ds $ \ d -> Arg info $ v `applyE` [Proj d] @@ -180,35 +185,24 @@ -- an axiom at this stage (if we are checking the -- projection functions for a record type). w <- case ignoreSharing <$> w of - NotBlocked (Def f es) -> + NotBlocked r (Def f es) -> -- Andreas, 2014-06-12 TODO: r == ReallyNotBlocked sufficient? unfoldDefinitionE True reduceB' (Def f []) f es -- reduceB is used here because some constructors -- are actually definitions which need to be -- unfolded (due to open public). _ -> return w let v = ignoreBlocking w + arg = Arg info v -- the reduced argument case ignoreSharing <$> w of - -{- Andreas, 2013-10-27 the following considered HARMFUL: - -- Andreas, 2010-09-07 matching a record constructor against - -- something irrelevant will just continue matching against - -- irrelevant stuff - -- NotBlocked (Sort Prop) - _ | isIrrelevant info -> do - (m, vs) <- matchPatterns ps $ - repeat $ setRelevance Irrelevant $ defaultArg $ Sort Prop - -- repeat looks very bad here (non-termination!) - return (m, Arg info $ Con c vs) --} - NotBlocked (Con c' vs) - | c == c' -> do + NotBlocked _ (Con c' vs) + | c == c' -> do (m, vs) <- yesSimplification <$> matchPatterns ps vs return (m, Arg info $ Con c' vs) - | otherwise -> return (No, Arg info v) -- NOTE: v the reduced thing(shadowing!). Andreas, 2013-07-03 - NotBlocked (MetaV x vs) -> return (DontKnow $ Just x, Arg info v) - Blocked x _ -> return (DontKnow $ Just x, Arg info v) - _ -> return (DontKnow Nothing, Arg info v) - + | otherwise -> return (No , arg) + NotBlocked _ (MetaV x vs) -> return (DontKnow $ Blocked x () , arg) + Blocked x _ -> return (DontKnow $ Blocked x () , arg) + NotBlocked r _ -> return (DontKnow $ NotBlocked r' () , arg) + where r' = stuckOn (Apply arg) r -- ASR (08 November 2014). The type of the function could be -- -- @(Match Term, [I.Arg Term]) -> (Match Term, [I.Arg Term])@. diff --git a/src/full/Agda/TypeChecking/Patterns/Match.hs-boot b/src/full/Agda/TypeChecking/Patterns/Match.hs-boot --- a/src/full/Agda/TypeChecking/Patterns/Match.hs-boot +++ b/src/full/Agda/TypeChecking/Patterns/Match.hs-boot @@ -5,7 +5,7 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce.Monad -data Match a = Yes Simplification [a] | No | DontKnow (Maybe MetaId) +data Match a = Yes Simplification [a] | No | DontKnow (Blocked ()) matchPatterns :: [NamedArg Pattern] -> Args -> ReduceM (Match Term, Args) matchCopatterns :: [NamedArg Pattern] -> Elims -> ReduceM (Match Term, Elims) diff --git a/src/full/Agda/TypeChecking/Polarity.hs b/src/full/Agda/TypeChecking/Polarity.hs --- a/src/full/Agda/TypeChecking/Polarity.hs +++ b/src/full/Agda/TypeChecking/Polarity.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Polarity where @@ -401,5 +400,5 @@ polarities i l = case l of MetaLevel _ vs -> map (const Invariant) <$> polarities i vs BlockedLevel _ v -> polarities i v - NeutralLevel v -> polarities i v + NeutralLevel _ v -> polarities i v UnreducedLevel v -> polarities i v diff --git a/src/full/Agda/TypeChecking/Positivity.hs b/src/full/Agda/TypeChecking/Positivity.hs --- a/src/full/Agda/TypeChecking/Positivity.hs +++ b/src/full/Agda/TypeChecking/Positivity.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -- | Check that a datatype is strictly positive. module Agda.TypeChecking.Positivity where +import Prelude hiding (null) + import Control.Applicative hiding (empty) import Control.DeepSeq import Control.Monad.Reader @@ -15,9 +17,11 @@ import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map -import Data.List as List +import Data.List as List hiding (null) import Data.Maybe (mapMaybe, fromMaybe) +import Debug.Trace + import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Internal as I @@ -34,6 +38,8 @@ import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Null +import qualified Agda.Utils.Permutation as Perm import Agda.Utils.SemiRing import qualified Agda.Utils.Graph.AdjacencyMap as Graph import Agda.Utils.Graph.AdjacencyMap (Graph) @@ -93,7 +99,7 @@ err <- fsep $ [prettyTCM q] ++ pwords "is not strictly positive, because it occurs" ++ [prettyTCM how] - setCurrentRange (getRange q) $ typeError $ GenericDocError err + setCurrentRange q $ typeError $ GenericDocError err -- if we find an unguarded record, mark it as such when (dr == IsRecord) $ do @@ -118,7 +124,7 @@ -- Check whether the recursive record has been declared as -- 'Inductive' or 'Coinductive'. Otherwise, error. unlessM (isJust . recInduction . theDef <$> getConstInfo q) $ do - traceCall (SetRange $ nameBindingSite $ qnameName q) $ do + setCurrentRange (nameBindingSite $ qnameName q) $ do typeError . GenericDocError =<< text "Recursive record" <+> prettyTCM q <+> text "needs to be declared as either inductive or coinductive" @@ -157,8 +163,8 @@ getDefArity :: Definition -> TCM Int getDefArity def = case theDef def of - Function{ funClauses = cs, funProjection = proj } -> do - let dropped = maybe 0 (subtract 1 . projIndex) proj + defn@Function{} -> do + let dropped = projectionArgs defn subtract dropped . arity <$> instantiateFull (defType def) Datatype{ dataPars = n } -> return n Record{ recPars = n } -> return n @@ -354,8 +360,11 @@ withExtendedOccEnv i = local $ \ e -> e { vars = i : vars e } -- | Running the monad -getOccurrences :: ComputeOccurrences a => [Maybe Item] -> a -> TCM Occurrences +getOccurrences + :: (PrettyTCM a, ComputeOccurrences a) + => [Maybe Item] -> a -> TCM Occurrences getOccurrences vars a = do + reportSDoc "tc.pos.occ" 20 $ text "computing occurrences in " <+> prettyTCM a kit <- coinductionKit return $ runReader (occurrences a) $ OccEnv vars $ fmap nameOfInf kit @@ -364,21 +373,15 @@ instance ComputeOccurrences Clause where occurrences cl = do - let ps = map unArg $ clausePats cl + let ps = clausePats cl (concatOccurs (mapMaybe matching (zip [0..] ps)) >+<) <$> walk (patItems ps) (clauseBody cl) where matching (i, p) - | properlyMatching p = Just $ occursAs Matched $ here $ AnArg i - | otherwise = Nothing -{- - matching (i, VarP{}) = Nothing - matching (i, DotP{}) = Nothing - matching (i, ConP _ Just{} _) = Nothing -- record patterns are not matches - matching (i, _ ) = Just (occursAs Matched $ here (AnArg i)) --} + | properlyMatching (unArg p) = Just $ occursAs Matched $ here $ AnArg i + | otherwise = Nothing - walk _ NoBody = return $ Map.empty + walk _ NoBody = return empty walk [] (Body v) = occurrences v walk (i : pis) (Bind b) = withExtendedOccEnv i $ walk pis $ absBody b walk [] Bind{} = __IMPOSSIBLE__ @@ -390,24 +393,23 @@ patItems ps = concat $ zipWith patItem [0..] ps -- @patItem i p@ replicates index @i@ as often as there are - -- pattern variables in @p@ - patItem i p = replicate (nVars p) (Just (AnArg i)) - - -- @nVars p@ computes the number of variables bound by pattern @p@ - nVars p = case p of - VarP{} -> 1 - DotP{} -> 1 - ConP _ _ ps -> sum $ map (nVars . namedArg) ps - LitP{} -> 0 - ProjP{} -> 0 + -- pattern variables in @p@ (dot patterns count as variable) + patItem :: Int -> I.Arg Pattern -> [Maybe Item] + patItem i p = map (const $ Just $ AnArg i) $ patternVars p instance ComputeOccurrences Term where occurrences v = case v of Var i args -> do vars <- asks vars occs <- occurrences args - return $ maybe Map.empty here (index vars i) - >+< occursAs VarArg occs + -- Apparently some development version of GHC chokes if the + -- following line is replaced by vars ! i. + let mi | i < length vars = vars !! i + | otherwise = flip trace __IMPOSSIBLE__ $ + "impossible: occurrence of de Bruijn index " ++ show i ++ + " in vars " ++ show vars ++ " is unbound" + return $ maybe empty here mi >+< occursAs VarArg occs + Def d args -> do inf <- asks inf let occsAs = if Just d /= inf then occursAs . DefArg d else \ n -> @@ -424,37 +426,31 @@ return $ occursAs LeftOfArrow oa >+< ob Lam _ b -> occurrences b Level l -> occurrences l - Lit{} -> return $ Map.empty - Sort{} -> return $ Map.empty - DontCare _ -> return $ Map.empty -- Andreas, 2011-09-09: do we need to check for negative occurrences in irrelevant positions? + Lit{} -> return empty + Sort{} -> return empty + DontCare _ -> return empty -- Andreas, 2011-09-09: do we need to check for negative occurrences in irrelevant positions? Shared p -> occurrences $ derefPtr p ExtLam{} -> __IMPOSSIBLE__ - where - -- Apparently some development version of GHC chokes if the - -- following line is replaced by vs ! i. - index vs i - | i < length vs = vs !! i - | otherwise = __IMPOSSIBLE__ instance ComputeOccurrences Level where occurrences (Max as) = occurrences as instance ComputeOccurrences PlusLevel where - occurrences ClosedLevel{} = return $ Map.empty + occurrences ClosedLevel{} = return empty occurrences (Plus _ l) = occurrences l instance ComputeOccurrences LevelAtom where occurrences l = case l of MetaLevel _ vs -> occursAs MetaArg <$> occurrences vs BlockedLevel _ v -> occurrences v - NeutralLevel v -> occurrences v + NeutralLevel _ v -> occurrences v UnreducedLevel v -> occurrences v instance ComputeOccurrences Type where occurrences (El _ v) = occurrences v instance ComputeOccurrences a => ComputeOccurrences (Tele a) where - occurrences EmptyTel = return $ Map.empty + occurrences EmptyTel = return empty occurrences (ExtendTel a b) = occurrences (a, b) instance ComputeOccurrences a => ComputeOccurrences (Abs a) where @@ -462,7 +458,7 @@ occurrences (NoAbs _ b) = occurrences b instance ComputeOccurrences a => ComputeOccurrences (Elim' a) where - occurrences Proj{} = return $ Map.empty + occurrences Proj{} = return empty occurrences (Apply a) = occurrences a instance ComputeOccurrences a => ComputeOccurrences (I.Arg a) where @@ -515,9 +511,9 @@ getOccurrences vars =<< instantiateFull tel' -- Arguments to other kinds of definitions are hard-wired. - Constructor{} -> return Map.empty - Axiom{} -> return Map.empty - Primitive{} -> return Map.empty + Constructor{} -> return empty + Axiom{} -> return empty + Primitive{} -> return empty -- | Eta expand a clause to have the given number of variables. -- Warning: doesn't update telescope or permutation! @@ -526,11 +522,12 @@ etaExpandClause :: Nat -> Clause -> Clause etaExpandClause n c@Clause{ namedClausePats = ps, clauseBody = b } | m <= 0 = c - | otherwise = c { namedClausePats = ps ++ genericReplicate m (defaultArg $ unnamed $ VarP underscore) - , clauseBody = liftBody m b - , clauseTel = __IMPOSSIBLE__ - , clausePerm = __IMPOSSIBLE__ - } + | otherwise = c + { namedClausePats = ps ++ genericReplicate m (defaultArg $ unnamed $ VarP underscore) + , clauseBody = liftBody m b + , clauseTel = telFromList $ replicate n $ (underscore,) <$> dummyDom -- Not __IMPOSSIBLE__ because of debug printing + , clausePerm = Perm.idP n -- ditto + } where m = n - genericLength ps diff --git a/src/full/Agda/TypeChecking/Pretty.hs b/src/full/Agda/TypeChecking/Pretty.hs --- a/src/full/Agda/TypeChecking/Pretty.hs +++ b/src/full/Agda/TypeChecking/Pretty.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} module Agda.TypeChecking.Pretty where +import Prelude hiding (null) + import Control.Applicative hiding (empty) +import Data.Maybe import Agda.Syntax.Position import Agda.Syntax.Common hiding (Arg, Dom, NamedArg, ArgInfo) @@ -17,13 +20,15 @@ import Agda.Syntax.Translation.AbstractToConcrete import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C -import qualified Agda.Syntax.Abstract.Pretty as P -import qualified Agda.Syntax.Concrete.Pretty as P +import qualified Agda.Syntax.Abstract.Pretty as AP +import qualified Agda.Syntax.Concrete.Pretty as CP import Agda.TypeChecking.Monad -import qualified Agda.Utils.Pretty as P +import Agda.Utils.Maybe +import Agda.Utils.Null import Agda.Utils.Permutation (Permutation) +import qualified Agda.Utils.Pretty as P #include "undefined.h" import Agda.Utils.Impossible @@ -34,29 +39,32 @@ type Doc = P.Doc -empty, comma, colon, equals :: TCM Doc -empty = return P.empty +instance Null (TCM Doc) where + empty = return empty + null = __IMPOSSIBLE__ + +comma, colon, equals :: TCM Doc comma = return P.comma colon = return P.colon equals = return P.equals -pretty :: P.Pretty a => a -> TCM P.Doc +pretty :: P.Pretty a => a -> TCM Doc pretty x = return $ P.pretty x prettyA :: (P.Pretty c, ToConcrete a c) => a -> TCM Doc -prettyA x = P.prettyA x +prettyA x = AP.prettyA x prettyAs :: (P.Pretty c, ToConcrete a [c]) => a -> TCM Doc -prettyAs x = P.prettyAs x +prettyAs x = AP.prettyAs x text :: String -> TCM Doc text s = return $ P.text s -pwords :: String -> [TCM Doc] +pwords :: String -> [TCM Doc] pwords s = map return $ P.pwords s fwords :: String -> TCM Doc -fwords s = return $ P.fwords s +fwords s = return $ P.fwords s sep, fsep, hsep, hcat, vcat :: [TCM Doc] -> TCM Doc sep ds = P.sep <$> sequence ds @@ -76,13 +84,18 @@ braces, dbraces, brackets, parens :: TCM Doc -> TCM Doc braces d = P.braces <$> d -dbraces d = P.dbraces <$> d +dbraces d = CP.dbraces <$> d brackets d = P.brackets <$> d parens d = P.parens <$> d +-- | Comma-separated list in brackets. prettyList :: [TCM Doc] -> TCM Doc prettyList ds = brackets $ fsep $ punctuate comma ds +-- | 'prettyList' without the brackets. +prettyList_ :: [TCM Doc] -> TCM Doc +prettyList_ ds = fsep $ punctuate comma ds + punctuate :: TCM Doc -> [TCM Doc] -> [TCM Doc] punctuate _ [] = [] punctuate d ds = zipWith (<>) ds (replicate n d ++ [empty]) @@ -94,10 +107,21 @@ --------------------------------------------------------------------------- class PrettyTCM a where - prettyTCM :: a -> TCM Doc + prettyTCM :: a -> TCM Doc +instance PrettyTCM Bool where prettyTCM = pretty +instance PrettyTCM C.Name where prettyTCM = pretty +instance PrettyTCM C.QName where prettyTCM = pretty +instance PrettyTCM Comparison where prettyTCM = pretty +instance PrettyTCM Literal where prettyTCM = pretty +instance PrettyTCM Nat where prettyTCM = pretty +instance PrettyTCM ProblemId where prettyTCM = pretty +instance PrettyTCM Range where prettyTCM = pretty +-- instance PrettyTCM Interval where prettyTCM = pretty +-- instance PrettyTCM Position where prettyTCM = pretty + instance PrettyTCM a => PrettyTCM (Closure a) where - prettyTCM cl = enterClosure cl prettyTCM + prettyTCM cl = enterClosure cl prettyTCM instance PrettyTCM a => PrettyTCM [a] where prettyTCM = prettyList . map prettyTCM @@ -105,8 +129,10 @@ instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (a,b) where prettyTCM (a, b) = parens $ prettyTCM a <> comma <> prettyTCM b -instance PrettyTCM Nat where prettyTCM = text . show -instance PrettyTCM Bool where prettyTCM = text . show +instance (PrettyTCM a, PrettyTCM b, PrettyTCM c) => PrettyTCM (a,b,c) where + prettyTCM (a, b, c) = parens $ + prettyTCM a <> comma <> prettyTCM b <> comma <> prettyTCM c + instance PrettyTCM Term where prettyTCM x = prettyA =<< reify x instance PrettyTCM Type where prettyTCM x = prettyA =<< reify x instance PrettyTCM Sort where prettyTCM x = prettyA =<< reify x @@ -115,17 +141,10 @@ instance PrettyTCM Level where prettyTCM x = prettyA =<< reify (Level x) instance PrettyTCM Permutation where prettyTCM = text . show -instance PrettyTCM Position where - prettyTCM p = do - text $ show p - -instance PrettyTCM Interval where - prettyTCM i = do - text $ show i - -instance PrettyTCM Range where - prettyTCM r = do - text $ show r +instance PrettyTCM Clause where + prettyTCM cl = do + x <- qualify_ <$> freshName_ "" + prettyTCM (QNamed x cl) instance PrettyTCM ClauseBody where prettyTCM b = do @@ -133,32 +152,32 @@ sep [ brackets (fsep binds), return body ] where walk NoBody = return ([], P.text "()") - walk (Body v) = (,) [] <$> prettyTCM v + walk (Body v) = ([],) <$> prettyTCM v walk (Bind b) = do (bs, v) <- underAbstraction_ b walk return (text (argNameToString $ absName b) : bs, v) -instance (PrettyTCM a, PrettyTCM b) => PrettyTCM (Judgement a b) where +instance PrettyTCM a => PrettyTCM (Judgement a) where prettyTCM (HasType a t) = prettyTCM a <+> text ":" <+> prettyTCM t prettyTCM (IsSort a t) = text "Sort" <+> prettyTCM a <+> text ":" <+> prettyTCM t instance PrettyTCM MetaId where prettyTCM x = do - mn <- getMetaNameSuggestion x - text $ show (NamedMeta mn x) + mn <- getMetaNameSuggestion x + pretty $ NamedMeta mn x instance PrettyTCM a => PrettyTCM (Blocked a) where prettyTCM (Blocked x a) = text "[" <+> prettyTCM a <+> text "]" <> text (show x) - prettyTCM (NotBlocked x) = prettyTCM x + prettyTCM (NotBlocked _ x) = prettyTCM x instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Named_ a) where - prettyTCM x = prettyA =<< reify x + prettyTCM x = prettyA =<< reify x instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Arg a) where - prettyTCM x = prettyA =<< reify x + prettyTCM x = prettyA =<< reify x instance (Reify a e, ToConcrete e c, P.Pretty c) => PrettyTCM (Dom a) where - prettyTCM x = prettyA =<< reify x + prettyTCM x = prettyA =<< reify x -- instance (Reify a e, ToConcrete e c, P.Pretty c, PrettyTCM a) => PrettyTCM (Elim' a) where instance PrettyTCM Elim where @@ -169,24 +188,17 @@ prettyTCM = prettyTCM . ignoreReduced instance PrettyTCM A.Expr where - prettyTCM = prettyA - -instance PrettyTCM C.Name where - prettyTCM = text . show + prettyTCM = prettyA instance PrettyTCM Relevance where prettyTCM Irrelevant = text "." prettyTCM NonStrict = text ".." prettyTCM Relevant = empty - prettyTCM Forced = empty + prettyTCM Forced{} = empty prettyTCM UnusedArg = empty -instance PrettyTCM Comparison where - prettyTCM CmpEq = text "==" - prettyTCM CmpLeq = text "=<" - instance PrettyTCM ProblemConstraint where - prettyTCM (PConstr pid c) = brackets (text $ show pid) <+> prettyTCM c + prettyTCM (PConstr pid c) = brackets (prettyTCM pid) <+> prettyTCM c instance PrettyTCM Constraint where prettyTCM c = case c of @@ -219,18 +231,18 @@ ] Guarded c pid -> sep [ prettyTCM c - , nest 2 $ brackets $ text "blocked on problem" <+> text (show pid) + , nest 2 $ brackets $ text "blocked on problem" <+> prettyTCM pid ] UnBlock m -> do -- BlockedConst t <- mvInstantiation <$> lookupMeta m mi <- mvInstantiation <$> lookupMeta m case mi of BlockedConst t -> - sep [ text (show m) <+> text ":=" + sep [ pretty m <+> text ":=" , nest 2 $ prettyTCM t ] PostponedTypeCheckingProblem cl _ -> enterClosure cl $ \p -> - sep [ text (show m) <+> text ":=" + sep [ pretty m <+> text ":=" , nest 2 $ prettyTCM p ] Open{} -> __IMPOSSIBLE__ OpenIFS{} -> __IMPOSSIBLE__ @@ -238,11 +250,13 @@ InstV{} -> __IMPOSSIBLE__ FindInScope m Nothing -> do t <- getMetaType m - sep [ text $ "Find in scope " ++ (show m) ++ " :" ++ (show t) ++ " (no candidate for now)" + sep [ text "Find in scope" <+> pretty m <+> text ":" + , prettyTCM t + , text " (no candidate for now)" ] FindInScope m (Just cands) -> do t <- getMetaType m - sep [ text $ "Find in scope " ++ (show m) ++ " :" + sep [ text "Find in scope" <+> pretty m <+> text ":" , nest 2 $ prettyTCM t , sep $ flip map cands $ \(t,ty) -> prettyTCM t <+> text ": " <+> prettyTCM ty @@ -257,15 +271,28 @@ sep [ parens $ text "_ :" <+> prettyTCM t0 , nest 2 $ prettyList $ map prettyA es , nest 2 $ text ":?" <+> prettyTCM t1 ] + prettyTCM (CheckLambda (Common.Arg ai (xs, mt)) e t) = + sep [ return CP.lambda <+> + (CP.prettyRelevance ai . + CP.prettyHiding ai (if isNothing mt && length xs == 1 then id + else P.parens) <$> do + fsep $ + map prettyTCM xs ++ + caseMaybe mt [] (\ a -> [text ":", prettyTCM a])) <+> + return CP.arrow <+> + prettyTCM e <+> + text ":?" + , prettyTCM t + ] -instance PrettyTCM Literal where - prettyTCM = text . show +instance PrettyTCM a => PrettyTCM (WithHiding a) where + prettyTCM (WithHiding h a) = CP.prettyHiding h id <$> prettyTCM a instance PrettyTCM Name where - prettyTCM x = P.pretty <$> abstractToConcrete_ x + prettyTCM x = P.pretty <$> abstractToConcrete_ x instance PrettyTCM QName where - prettyTCM x = P.pretty <$> abstractToConcrete_ x + prettyTCM x = P.pretty <$> abstractToConcrete_ x instance PrettyTCM ModuleName where prettyTCM x = P.pretty <$> abstractToConcrete_ x @@ -283,42 +310,58 @@ instance PrettyTCM PrettyContext where prettyTCM (PrettyContext ctx) = P.fsep . reverse <$> pr (map ctxEntry ctx) - where - pr :: [Dom (Name, Type)] -> TCM [P.Doc] - pr [] = return [] - pr (Common.Dom info (x,t) : ctx) = escapeContext 1 $ do - d <- prettyTCM t - x <- prettyTCM x - dctx <- pr ctx - -- TODO guilhem: show colors - return $ P.pRelevance info' (par (P.hsep [ x, P.text ":", d])) : dctx - where - info' = mapArgInfoColors (const []) info - par = case argInfoHiding info of - NotHidden -> P.parens - Hidden -> P.braces - Instance -> P.dbraces + where + pr :: [Dom (Name, Type)] -> TCM [P.Doc] + pr [] = return [] + pr (Common.Dom info (x,t) : ctx) = escapeContext 1 $ do + -- TODO guilhem: show colors + d <- CP.prettyRelevance info . CP.prettyHiding info P.parens <$> do + prettyTCM x <+> text ":" <+> prettyTCM t + (d :) <$> pr ctx instance PrettyTCM Context where prettyTCM = prettyTCM . PrettyContext instance PrettyTCM Pattern where - prettyTCM = showPat - where - showPat (VarP x) = text $ patVarNameToString x - showPat (DotP t) = text $ ".(" ++ show t ++ ")" - showPat (ConP c Nothing ps) = parens $ + prettyTCM = showPat' (text . patVarNameToString) + +instance PrettyTCM DeBruijnPattern where + prettyTCM = showPat' $ \ (i, x) -> text $ patVarNameToString x ++ "@" ++ show i + +-- | Show a pattern, given a method how to show pattern variables. +showPat' :: (a -> TCM Doc) -> Pattern' a -> TCM Doc +showPat' showVar = showPat + where + showPat (VarP x) = showVar x + showPat (DotP t) = text $ ".(" ++ show t ++ ")" + showPat (ConP c i ps) = (if b then braces else parens) $ prTy $ prettyTCM c <+> fsep (map (showPat . namedArg) ps) - showPat (ConP c (Just (b, t)) ps) = (if b then braces else parens) $ - prettyTCM c <+> fsep (map (showPat . namedArg) ps) <+> text ":" <+> prettyTCM t - showPat (LitP l) = text (show l) - showPat (ProjP q) = text (show q) + where + b = fromMaybe False $ conPRecord i + prTy d = caseMaybe (conPType i) d $ \ t -> d <+> text ":" <+> prettyTCM t + showPat (LitP l) = text (show l) + showPat (ProjP q) = text (show q) +instance PrettyTCM (Elim' DisplayTerm) where + prettyTCM (Apply v) = text "$" <+> prettyTCM (unArg v) + prettyTCM (Proj f) = text "." <> prettyTCM f + +instance PrettyTCM (Elim' NLPat) where + prettyTCM (Apply v) = text "$" <+> prettyTCM (unArg v) + prettyTCM (Proj f) = text "." <> prettyTCM f + +instance PrettyTCM NLPat where + prettyTCM (PVar x) = prettyTCM (var x) + prettyTCM (PWild) = text $ "_" + prettyTCM (PDef f es) = parens $ + prettyTCM f <+> fsep (map prettyTCM es) + prettyTCM (PTerm t) = text "." <> parens (prettyTCM t) + instance PrettyTCM RewriteRule where prettyTCM (RewriteRule q gamma lhs rhs b) = inTopContext $ do - prettyTCM q <+> text " rule " <+> do - prettyTCM gamma <+> text " |- " <+> do - addContext gamma $ do - prettyTCM lhs <+> text " --> " <+> do - prettyTCM rhs <+> text " : " <+> do - prettyTCM b + prettyTCM q <+> text " rule " <+> do + prettyTCM gamma <+> text " |- " <+> do + addContext gamma $ do + prettyTCM lhs <+> text " --> " <+> do + prettyTCM rhs <+> text " : " <+> do + prettyTCM b diff --git a/src/full/Agda/TypeChecking/Pretty.hs-boot b/src/full/Agda/TypeChecking/Pretty.hs-boot --- a/src/full/Agda/TypeChecking/Pretty.hs-boot +++ b/src/full/Agda/TypeChecking/Pretty.hs-boot @@ -1,5 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} module Agda.TypeChecking.Pretty where diff --git a/src/full/Agda/TypeChecking/Primitive.hs b/src/full/Agda/TypeChecking/Primitive.hs --- a/src/full/Agda/TypeChecking/Primitive.hs +++ b/src/full/Agda/TypeChecking/Primitive.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} {-| Primitive functions, such as addition on builtin integers. -} @@ -53,32 +52,32 @@ -- Haskell type to Agda type newtype Nat = Nat { unNat :: Integer } - deriving (Eq, Ord, Num, Enum, Real) + deriving (Eq, Ord, Num, Enum, Real) --- TODO: ghc-7.7 bug: deriving Integral causes an unnecessary toInteger --- warning. Once 7.8 is out check if we can go back to deriving. +-- In GHC > 7.8 deriving Integral causes an unnecessary toInteger +-- warning. instance Integral Nat where toInteger = unNat quotRem (Nat a) (Nat b) = (Nat q, Nat r) where (q, r) = quotRem a b +instance Show Nat where + show = show . toInteger + newtype Lvl = Lvl { unLvl :: Integer } deriving (Eq, Ord) instance Show Lvl where show = show . unLvl -instance Show Nat where - show = show . unNat - class PrimType a where - primType :: a -> TCM Type + primType :: a -> TCM Type instance (PrimType a, PrimType b) => PrimTerm (a -> b) where - primTerm _ = unEl <$> (primType (undefined :: a) --> primType (undefined :: b)) + primTerm _ = unEl <$> (primType (undefined :: a) --> primType (undefined :: b)) instance PrimTerm a => PrimType a where - primType _ = el $ primTerm (undefined :: a) + primType _ = el $ primTerm (undefined :: a) class PrimTerm a where primTerm :: a -> TCM Term instance PrimTerm Integer where primTerm _ = primInteger @@ -92,21 +91,21 @@ instance PrimTerm Type where primTerm _ = primAgdaType instance PrimTerm a => PrimTerm [a] where - primTerm _ = list (primTerm (undefined :: a)) + primTerm _ = list (primTerm (undefined :: a)) instance PrimTerm a => PrimTerm (IO a) where - primTerm _ = io (primTerm (undefined :: a)) + primTerm _ = io (primTerm (undefined :: a)) -- From Agda term to Haskell value class ToTerm a where - toTerm :: TCM (a -> Term) - toTermR :: TCM (a -> ReduceM Term) + toTerm :: TCM (a -> Term) + toTermR :: TCM (a -> ReduceM Term) - toTermR = (pure .) <$> toTerm + toTermR = (pure .) <$> toTerm instance ToTerm Integer where toTerm = return $ Lit . LitInt noRange -instance ToTerm Nat where toTerm = return $ Lit . LitInt noRange . unNat +instance ToTerm Nat where toTerm = return $ Lit . LitInt noRange . toInteger instance ToTerm Lvl where toTerm = return $ Level . Max . (:[]) . ClosedLevel . unLvl instance ToTerm Double where toTerm = return $ Lit . LitFloat noRange instance ToTerm Char where toTerm = return $ Lit . LitChar noRange @@ -114,18 +113,18 @@ instance ToTerm QName where toTerm = return $ Lit . LitQName noRange instance ToTerm Bool where - toTerm = do - true <- primTrue - false <- primFalse - return $ \b -> if b then true else false + toTerm = do + true <- primTrue + false <- primFalse + return $ \b -> if b then true else false instance ToTerm Term where - toTerm = do kit <- quotingKit; runReduceF (quoteTermWithKit kit) - toTermR = do kit <- quotingKit; return (quoteTermWithKit kit) + toTerm = do kit <- quotingKit; runReduceF (quoteTermWithKit kit) + toTermR = do kit <- quotingKit; return (quoteTermWithKit kit) instance ToTerm Type where - toTerm = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit) - toTermR = do kit <- quotingKit; return (quoteTypeWithKit kit) + toTerm = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit) + toTermR = do kit <- quotingKit; return (quoteTypeWithKit kit) instance ToTerm I.ArgInfo where toTerm = do @@ -145,7 +144,7 @@ Relevant -> rel Irrelevant -> irr NonStrict -> rel - Forced -> irr + Forced{} -> irr UnusedArg -> irr ] @@ -160,52 +159,53 @@ return $ foldr cons nil instance (PrimTerm a, ToTerm a) => ToTerm [a] where - toTerm = do - mkList <- buildList - fromA <- toTerm - return $ mkList . map fromA + toTerm = do + mkList <- buildList + fromA <- toTerm + return $ mkList . map fromA -- From Haskell value to Agda term -type FromTermFunction a = I.Arg Term -> ReduceM (Reduced (MaybeReduced (I.Arg Term)) a) +type FromTermFunction a = I.Arg Term -> + ReduceM (Reduced (MaybeReduced (I.Arg Term)) a) class FromTerm a where - fromTerm :: TCM (FromTermFunction a) + fromTerm :: TCM (FromTermFunction a) instance FromTerm Integer where - fromTerm = fromLiteral $ \l -> case l of - LitInt _ n -> Just n - _ -> Nothing + fromTerm = fromLiteral $ \l -> case l of + LitInt _ n -> Just n + _ -> Nothing instance FromTerm Nat where - fromTerm = fromLiteral $ \l -> case l of - LitInt _ n -> Just $ Nat n - _ -> Nothing + fromTerm = fromLiteral $ \l -> case l of + LitInt _ n -> Just $ fromInteger n + _ -> Nothing instance FromTerm Lvl where - fromTerm = fromReducedTerm $ \l -> case l of - Level (Max [ClosedLevel n]) -> Just $ Lvl n - _ -> Nothing + fromTerm = fromReducedTerm $ \l -> case l of + Level (Max [ClosedLevel n]) -> Just $ Lvl n + _ -> Nothing instance FromTerm Double where - fromTerm = fromLiteral $ \l -> case l of - LitFloat _ x -> Just x - _ -> Nothing + fromTerm = fromLiteral $ \l -> case l of + LitFloat _ x -> Just x + _ -> Nothing instance FromTerm Char where - fromTerm = fromLiteral $ \l -> case l of - LitChar _ c -> Just c - _ -> Nothing + fromTerm = fromLiteral $ \l -> case l of + LitChar _ c -> Just c + _ -> Nothing instance FromTerm Str where - fromTerm = fromLiteral $ \l -> case l of - LitString _ s -> Just $ Str s - _ -> Nothing + fromTerm = fromLiteral $ \l -> case l of + LitString _ s -> Just $ Str s + _ -> Nothing instance FromTerm QName where - fromTerm = fromLiteral $ \l -> case l of - LitQName _ x -> Just x - _ -> Nothing + fromTerm = fromLiteral $ \l -> case l of + LitQName _ x -> Just x + _ -> Nothing instance FromTerm Bool where fromTerm = do @@ -258,7 +258,7 @@ -- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@ redBind :: ReduceM (Reduced a a') -> (a -> b) -> - (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b') + (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b') redBind ma f k = do r <- ma case r of @@ -293,7 +293,8 @@ primEquality <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0 Con rf [] <- ignoreSharing <$> primRefl n <- conPars . theDef <$> getConInfo rf - let refl x | n == 2 = Con rf [setRelevance Forced $ hide $ defaultArg x] + -- Andreas, 2015-02-27 Forced Big vs. Forced Small should not matter here + let refl x | n == 2 = Con rf [setRelevance (Forced Small) $ hide $ defaultArg x] | n == 3 = Con rf [] | otherwise = __IMPOSSIBLE__ return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ts -> @@ -388,7 +389,8 @@ Max bs <- levelView' $ unArg b redReturn $ Level $ levelMax $ as ++ bs -mkPrimFun1TCM :: (FromTerm a, ToTerm b) => TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl +mkPrimFun1TCM :: (FromTerm a, ToTerm b) => + TCM Type -> (a -> ReduceM b) -> TCM PrimitiveImpl mkPrimFun1TCM mt f = do toA <- fromTerm fromB <- toTermR @@ -402,7 +404,7 @@ _ -> __IMPOSSIBLE__ -- Tying the knot -mkPrimFun1 :: (PrimType a, PrimType b, FromTerm a, ToTerm b) => +mkPrimFun1 :: (PrimType a, FromTerm a, PrimType b, ToTerm b) => (a -> b) -> TCM PrimitiveImpl mkPrimFun1 f = do toA <- fromTerm @@ -416,7 +418,9 @@ redReturn $ fromB $ f x _ -> __IMPOSSIBLE__ -mkPrimFun2 :: (PrimType a, PrimType b, PrimType c, FromTerm a, ToTerm a, FromTerm b, ToTerm c) => +mkPrimFun2 :: ( PrimType a, FromTerm a, ToTerm a + , PrimType b, FromTerm b + , PrimType c, ToTerm c ) => (a -> b -> c) -> TCM PrimitiveImpl mkPrimFun2 f = do toA <- fromTerm @@ -439,7 +443,7 @@ , PrimType b, FromTerm b, ToTerm b , PrimType c, FromTerm c, ToTerm c , PrimType d, FromTerm d - , PrimType e, ToTerm e) => + , PrimType e, ToTerm e ) => (a -> b -> c -> d -> e) -> TCM PrimitiveImpl mkPrimFun4 f = do (toA, fromA) <- (,) <$> fromTerm <*> toTerm @@ -471,23 +475,23 @@ _ -> __IMPOSSIBLE__ -- Type combinators -infixr 4 --> -(-->) :: TCM Type -> TCM Type -> TCM Type -a --> b = do - a' <- a - b' <- b - return $ El (getSort a' `sLub` getSort b') $ Pi (Dom defaultArgInfo a') (NoAbs "_" b') - +infixr 4 --> infixr 4 .--> +infixr 4 ..--> -(.-->) :: TCM Type -> TCM Type -> TCM Type -a .--> b = do - a' <- a - b' <- b - return $ El (getSort a' `sLub` getSort b') $ - Pi (Dom (setRelevance Irrelevant defaultArgInfo) a') (NoAbs "_" b') +(-->), (.-->), (..-->) :: TCM Type -> TCM Type -> TCM Type +a --> b = garr id a b +a .--> b = garr (const $ Irrelevant) a b +a ..--> b = garr (const $ NonStrict) a b +garr :: (Relevance -> Relevance) -> TCM Type -> TCM Type -> TCM Type +garr f a b = do + a' <- a + b' <- b + return $ El (getSort a' `sLub` getSort b') $ + Pi (Dom (mapRelevance f defaultArgInfo) a') (NoAbs "_" b') + gpi :: I.ArgInfo -> String -> TCM Type -> TCM Type -> TCM Type gpi info name a b = do a <- a @@ -527,6 +531,17 @@ tset :: TCM Type tset = return $ sort (mkType 0) +tSetOmega :: TCM Type +tSetOmega = return $ sort Inf + +tSizeUniv :: TCM Type +tSizeUniv = return $ El SizeUniv $ Sort SizeUniv +-- Andreas, 2015-03-16 Since equality checking for types +-- includes equality checking for sorts, we cannot put +-- SizeUniv in Setω. (SizeUniv : Setω) == (_0 : suc _0) +-- will first instantiate _0 := Setω, which is wrong. +-- tSizeUniv = return $ El Inf $ Sort SizeUniv + -- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@. argN :: e -> I.Arg e argN = Arg defaultArgInfo @@ -553,85 +568,87 @@ primitiveFunctions :: Map String (TCM PrimitiveImpl) primitiveFunctions = Map.fromList - -- Integer functions - [ "primIntegerPlus" |-> mkPrimFun2 ((+) :: Op Integer) - , "primIntegerMinus" |-> mkPrimFun2 ((-) :: Op Integer) - , "primIntegerTimes" |-> mkPrimFun2 ((*) :: Op Integer) - , "primIntegerDiv" |-> mkPrimFun2 (div :: Op Integer) -- partial - , "primIntegerMod" |-> mkPrimFun2 (mod :: Op Integer) -- partial - , "primIntegerEquality" |-> mkPrimFun2 ((==) :: Rel Integer) - , "primIntegerLess" |-> mkPrimFun2 ((<) :: Rel Integer) - , "primIntegerAbs" |-> mkPrimFun1 (Nat . abs :: Integer -> Nat) - , "primNatToInteger" |-> mkPrimFun1 (unNat :: Nat -> Integer) - , "primShowInteger" |-> mkPrimFun1 (Str . show :: Integer -> Str) + -- Integer functions + [ "primIntegerPlus" |-> mkPrimFun2 ((+) :: Op Integer) + , "primIntegerMinus" |-> mkPrimFun2 ((-) :: Op Integer) + , "primIntegerTimes" |-> mkPrimFun2 ((*) :: Op Integer) + , "primIntegerDiv" |-> mkPrimFun2 (div :: Op Integer) -- partial + , "primIntegerMod" |-> mkPrimFun2 (mod :: Op Integer) -- partial + , "primIntegerEquality" |-> mkPrimFun2 ((==) :: Rel Integer) + , "primIntegerLess" |-> mkPrimFun2 ((<) :: Rel Integer) + , "primIntegerAbs" |-> mkPrimFun1 (Nat . abs :: Integer -> Nat) + , "primNatToInteger" |-> mkPrimFun1 (toInteger :: Nat -> Integer) + , "primShowInteger" |-> mkPrimFun1 (Str . show :: Integer -> Str) - -- Natural number functions - , "primNatPlus" |-> mkPrimFun2 ((+) :: Op Nat) - , "primNatMinus" |-> mkPrimFun2 ((\x y -> max 0 (x - y)) :: Op Nat) - , "primNatTimes" |-> mkPrimFun2 ((*) :: Op Nat) - , "primNatDivSucAux" |-> mkPrimFun4 ((\k m n j -> k + div (max 0 $ n + m - j) (m + 1)) :: Nat -> Nat -> Nat -> Nat -> Nat) - , "primNatModSucAux" |-> - let aux :: Nat -> Nat -> Nat -> Nat -> Nat - aux k m n j | n > j = mod (n - j - 1) (m + 1) - | otherwise = k + n - in mkPrimFun4 aux - , "primNatEquality" |-> mkPrimFun2 ((==) :: Rel Nat) - , "primNatLess" |-> mkPrimFun2 ((<) :: Rel Nat) - , "primLevelZero" |-> mkPrimLevelZero - , "primLevelSuc" |-> mkPrimLevelSuc - , "primLevelMax" |-> mkPrimLevelMax + -- Natural number functions + , "primNatPlus" |-> mkPrimFun2 ((+) :: Op Nat) + , "primNatMinus" |-> mkPrimFun2 ((\x y -> max 0 (x - y)) :: Op Nat) + , "primNatTimes" |-> mkPrimFun2 ((*) :: Op Nat) + , "primNatDivSucAux" |-> mkPrimFun4 ((\k m n j -> k + div (max 0 $ n + m - j) (m + 1)) :: Nat -> Nat -> Nat -> Nat -> Nat) + , "primNatModSucAux" |-> + let aux :: Nat -> Nat -> Nat -> Nat -> Nat + aux k m n j | n > j = mod (n - j - 1) (m + 1) + | otherwise = k + n + in mkPrimFun4 aux + , "primNatEquality" |-> mkPrimFun2 ((==) :: Rel Nat) + , "primNatLess" |-> mkPrimFun2 ((<) :: Rel Nat) - -- Floating point functions - , "primIntegerToFloat" |-> mkPrimFun1 (fromIntegral :: Integer -> Double) - , "primFloatPlus" |-> mkPrimFun2 ((+) :: Op Double) - , "primFloatMinus" |-> mkPrimFun2 ((-) :: Op Double) - , "primFloatTimes" |-> mkPrimFun2 ((*) :: Op Double) - , "primFloatDiv" |-> mkPrimFun2 ((/) :: Op Double) - , "primFloatEquality" |-> mkPrimFun2 ((==) :: Rel Double) - , "primFloatLess" |-> mkPrimFun2 ((<) :: Rel Double) - , "primRound" |-> mkPrimFun1 (round :: Double -> Integer) - , "primFloor" |-> mkPrimFun1 (floor :: Double -> Integer) - , "primCeiling" |-> mkPrimFun1 (ceiling :: Double -> Integer) - , "primExp" |-> mkPrimFun1 (exp :: Fun Double) - , "primLog" |-> mkPrimFun1 (log :: Fun Double) -- partial - , "primSin" |-> mkPrimFun1 (sin :: Fun Double) - , "primShowFloat" |-> mkPrimFun1 (Str . show :: Double -> Str) + -- Level functions + , "primLevelZero" |-> mkPrimLevelZero + , "primLevelSuc" |-> mkPrimLevelSuc + , "primLevelMax" |-> mkPrimLevelMax - -- Character functions - , "primCharEquality" |-> mkPrimFun2 ((==) :: Rel Char) - , "primIsLower" |-> mkPrimFun1 isLower - , "primIsDigit" |-> mkPrimFun1 isDigit - , "primIsAlpha" |-> mkPrimFun1 isAlpha - , "primIsSpace" |-> mkPrimFun1 isSpace - , "primIsAscii" |-> mkPrimFun1 isAscii - , "primIsLatin1" |-> mkPrimFun1 isLatin1 - , "primIsPrint" |-> mkPrimFun1 isPrint - , "primIsHexDigit" |-> mkPrimFun1 isHexDigit - , "primToUpper" |-> mkPrimFun1 toUpper - , "primToLower" |-> mkPrimFun1 toLower - , "primCharToNat" |-> mkPrimFun1 (fromIntegral . fromEnum :: Char -> Nat) - , "primNatToChar" |-> mkPrimFun1 (toEnum . fromIntegral :: Nat -> Char) - , "primShowChar" |-> mkPrimFun1 (Str . show . pretty . LitChar noRange) + -- Floating point functions + , "primIntegerToFloat" |-> mkPrimFun1 (fromIntegral :: Integer -> Double) + , "primFloatPlus" |-> mkPrimFun2 ((+) :: Op Double) + , "primFloatMinus" |-> mkPrimFun2 ((-) :: Op Double) + , "primFloatTimes" |-> mkPrimFun2 ((*) :: Op Double) + , "primFloatDiv" |-> mkPrimFun2 ((/) :: Op Double) + , "primFloatEquality" |-> mkPrimFun2 ((==) :: Rel Double) + , "primFloatLess" |-> mkPrimFun2 ((<) :: Rel Double) + , "primRound" |-> mkPrimFun1 (round :: Double -> Integer) + , "primFloor" |-> mkPrimFun1 (floor :: Double -> Integer) + , "primCeiling" |-> mkPrimFun1 (ceiling :: Double -> Integer) + , "primExp" |-> mkPrimFun1 (exp :: Fun Double) + , "primLog" |-> mkPrimFun1 (log :: Fun Double) -- partial + , "primSin" |-> mkPrimFun1 (sin :: Fun Double) + , "primShowFloat" |-> mkPrimFun1 (Str . show :: Double -> Str) - -- String functions - , "primStringToList" |-> mkPrimFun1 unStr - , "primStringFromList" |-> mkPrimFun1 Str - , "primStringAppend" |-> mkPrimFun2 (\s1 s2 -> Str $ unStr s1 ++ unStr s2) - , "primStringEquality" |-> mkPrimFun2 ((==) :: Rel Str) - , "primShowString" |-> mkPrimFun1 (Str . show . pretty . LitString noRange . unStr) + -- Character functions + , "primCharEquality" |-> mkPrimFun2 ((==) :: Rel Char) + , "primIsLower" |-> mkPrimFun1 isLower + , "primIsDigit" |-> mkPrimFun1 isDigit + , "primIsAlpha" |-> mkPrimFun1 isAlpha + , "primIsSpace" |-> mkPrimFun1 isSpace + , "primIsAscii" |-> mkPrimFun1 isAscii + , "primIsLatin1" |-> mkPrimFun1 isLatin1 + , "primIsPrint" |-> mkPrimFun1 isPrint + , "primIsHexDigit" |-> mkPrimFun1 isHexDigit + , "primToUpper" |-> mkPrimFun1 toUpper + , "primToLower" |-> mkPrimFun1 toLower + , "primCharToNat" |-> mkPrimFun1 (fromIntegral . fromEnum :: Char -> Nat) + , "primNatToChar" |-> mkPrimFun1 (toEnum . fromIntegral :: Nat -> Char) + , "primShowChar" |-> mkPrimFun1 (Str . show . pretty . LitChar noRange) - -- Reflection - , "primQNameType" |-> primQNameType - , "primQNameDefinition" |-> primQNameDefinition - , "primDataConstructors"|-> primDataConstructors + -- String functions + , "primStringToList" |-> mkPrimFun1 unStr + , "primStringFromList" |-> mkPrimFun1 Str + , "primStringAppend" |-> mkPrimFun2 (\s1 s2 -> Str $ unStr s1 ++ unStr s2) + , "primStringEquality" |-> mkPrimFun2 ((==) :: Rel Str) + , "primShowString" |-> mkPrimFun1 (Str . show . pretty . LitString noRange . unStr) - -- Other stuff - , "primTrustMe" |-> primTrustMe - , "primQNameEquality" |-> mkPrimFun2 ((==) :: Rel QName) - , "primShowQName" |-> mkPrimFun1 (Str . show :: QName -> Str) - ] - where - (|->) = (,) + -- Reflection + , "primQNameType" |-> primQNameType + , "primQNameDefinition" |-> primQNameDefinition + , "primDataConstructors"|-> primDataConstructors + + -- Other stuff + , "primTrustMe" |-> primTrustMe + , "primQNameEquality" |-> mkPrimFun2 ((==) :: Rel QName) + , "primShowQName" |-> mkPrimFun1 (Str . show :: QName -> Str) + ] + where + (|->) = (,) lookupPrimitiveFunction :: String -> TCM PrimitiveImpl lookupPrimitiveFunction x = diff --git a/src/full/Agda/TypeChecking/ProjectionLike.hs b/src/full/Agda/TypeChecking/ProjectionLike.hs --- a/src/full/Agda/TypeChecking/ProjectionLike.hs +++ b/src/full/Agda/TypeChecking/ProjectionLike.hs @@ -1,8 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + FlexibleInstances, + PatternGuards #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.ProjectionLike where import Control.Monad @@ -55,11 +59,13 @@ NoProjection v -> v -- | Top-level 'ProjectionView' (no reduction). -projView :: Term -> TCM ProjectionView +{-# SPECIALIZE projView :: Term -> TCM ProjectionView #-} +projView :: HasConstInfo m => Term -> m ProjectionView projView v = do let fallback = return $ NoProjection v case ignoreSharing v of Def f es -> caseMaybeM (isProjection f) fallback $ \ isP -> do + if projIndex isP <= 0 then fallback else do case es of [] -> return $ LoneProjectionLike f $ projArgInfo isP Apply a : es -> return $ ProjectionView f a es @@ -85,7 +91,7 @@ -- This does just one layer, such that the top spine contains -- the projection-like functions as projections. -- Used in 'compareElims' in @TypeChecking.Conversion@ --- and in 'Agda.TypeChecking.CheckInternal'. +-- and in "Agda.TypeChecking.CheckInternal". -- -- If the 'Bool' is 'True', a lone projection like function will be -- turned into a lambda-abstraction, expecting the principal argument. @@ -109,18 +115,6 @@ | otherwise -> return v ProjectionView f a es -> (`applyE` (Proj f : es)) <$> elimView loneProjToLambda (unArg a) -{- Andreas, 2013-11-01: Use of unLevel no longer necessary, since we do not reduce! - case ignoreSharing v of - Def f (Apply (Arg _ rv) : es) -> do - flip (maybeM (return v)) (isProjection f) $ \ _ -> do - (`applyE` (Proj f : es)) <$> do elimView =<< unLevel =<< reduce rv - -- domi 2012-7-24: Add unLevel to handle neutral levels. - -- The problem is that reduce turns @suc (neutral)@ - -- into @Level (Max [Plus 1 (NeutralLevel neutral)])@ - -- which the below pattern match does not handle. - _ -> return v --} - -- | Which @Def@types are eligible for the principle argument -- of a projection-like function? eligibleForProjectionLike :: QName -> TCM Bool @@ -282,17 +276,3 @@ where candidateRec NoAbs{} = [] candidateRec (Abs x t) = candidateArgs (var (size vs) : vs) t - -{- - candidateArgs :: [Term] -> Term -> [(QName,Int)] - candidateArgs vs (Shared p) = candidateArgs vs $ derefPtr p - candidateArgs vs (Pi (Dom info (El _ def)) b) - | Def d es <- ignoreSharing def, - Just us <- allApplyElims es, - vs == map unArg us = (d, length vs) : candidateRec vs b - candidateArgs vs (Pi _ b) = candidateRec vs b - candidateArgs _ _ = [] - - candidateRec vs NoAbs{} = [] - candidateRec vs b = candidateArgs (var (size vs) : vs) (unEl $ absBody b) --} diff --git a/src/full/Agda/TypeChecking/Quote.hs b/src/full/Agda/TypeChecking/Quote.hs --- a/src/full/Agda/TypeChecking/Quote.hs +++ b/src/full/Agda/TypeChecking/Quote.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Quote where @@ -111,7 +110,7 @@ quoteRelevance Relevant = pure relevant quoteRelevance Irrelevant = pure irrelevant quoteRelevance NonStrict = pure relevant - quoteRelevance Forced = pure relevant + quoteRelevance Forced{} = pure relevant quoteRelevance UnusedArg = pure relevant -- quoteColors _ = nil -- TODO guilhem @@ -139,6 +138,7 @@ quoteSort (Type t) = quoteSortLevelTerm t quoteSort Prop = pure unsupportedSort quoteSort Inf = pure unsupportedSort + quoteSort SizeUniv = pure unsupportedSort quoteSort DLub{} = pure unsupportedSort quoteType :: Type -> ReduceM Term diff --git a/src/full/Agda/TypeChecking/RecordPatterns.hs b/src/full/Agda/TypeChecking/RecordPatterns.hs --- a/src/full/Agda/TypeChecking/RecordPatterns.hs +++ b/src/full/Agda/TypeChecking/RecordPatterns.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + FlexibleInstances, + GeneralizedNewtypeDeriving, + PatternGuards, + TupleSections #-} -- | Code which replaces pattern matching on record constructors with -- uses of projection functions. @@ -21,6 +22,7 @@ import Control.Monad.State import Data.List +import Data.Maybe import qualified Data.Map as Map import qualified Data.Traversable as Trav @@ -60,15 +62,16 @@ recordPatternToProjections :: Pattern -> TCM [Term -> Term] recordPatternToProjections p = case p of - VarP{} -> return [ \ x -> x ] - LitP{} -> typeError $ ShouldBeRecordPattern p - DotP{} -> typeError $ ShouldBeRecordPattern p - ConP c Nothing ps -> typeError $ ShouldBeRecordPattern p - ConP c (Just (_, t)) ps -> do - t <- reduce t + VarP{} -> return [ \ x -> x ] + LitP{} -> typeError $ ShouldBeRecordPattern p + DotP{} -> typeError $ ShouldBeRecordPattern p + ConP c ci ps -> do + unless (isJust $ conPRecord ci) $ + typeError $ ShouldBeRecordPattern p + t <- reduce $ fromMaybe __IMPOSSIBLE__ $ conPType ci fields <- getRecordTypeFields (unArg t) concat <$> zipWithM comb (map proj fields) (map namedArg ps) - ProjP{} -> __IMPOSSIBLE__ -- copattern cannot appear here + ProjP{} -> __IMPOSSIBLE__ -- copattern cannot appear here where proj p = (`applyE` [Proj $ unArg p]) -- proj p = \ x -> Def (unArg p) [defaultArg x] @@ -646,14 +649,15 @@ -- This function assumes that literals are never of record type. translatePattern :: Pattern -> RecPatM (Pattern, [Term], Changes) -translatePattern (ConP c Nothing ps) = do - (ps, s, cs) <- translatePatterns ps - return (ConP c Nothing ps, s, cs) -translatePattern p@(ConP _ (Just _) _) = do - r <- recordTree p - case r of - Left r -> r - Right t -> removeTree t +translatePattern p@(ConP c ci ps) + | Nothing <- conPRecord ci = do + (ps, s, cs) <- translatePatterns ps + return (ConP c ci ps, s, cs) + | otherwise = do + r <- recordTree p + case r of + Left r -> r + Right t -> removeTree t translatePattern p@VarP{} = removeTree (Leaf p) translatePattern p@DotP{} = removeTree (Leaf p) translatePattern p@LitP{} = return (p, [], []) @@ -681,8 +685,9 @@ recordTree :: Pattern -> RecPatM (Either (RecPatM (Pattern, [Term], Changes)) RecordTree) -recordTree p@(ConP _ Nothing _) = return $ Left $ translatePattern p -recordTree (ConP c ci@(Just (_, t)) ps) = do +recordTree p@(ConP _ ci _) | Nothing <- conPRecord ci = return $ Left $ translatePattern p +recordTree (ConP c ci ps) = do + let t = fromMaybe __IMPOSSIBLE__ $ conPType ci rs <- mapM (recordTree . namedArg) ps case allRight rs of Nothing -> diff --git a/src/full/Agda/TypeChecking/Records.hs b/src/full/Agda/TypeChecking/Records.hs --- a/src/full/Agda/TypeChecking/Records.hs +++ b/src/full/Agda/TypeChecking/Records.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} @@ -272,38 +272,38 @@ text " is not a record type" return Nothing caseMaybeM (isRecordType a) failure $ \ (r, pars, def) -> do - if not (recEtaEquality def) then return Nothing else Just <$> do - -- Get the record fields @Γ₁ ⊢ tel@ (@tel = Γ'@). - -- TODO: compose argInfo ai with tel. - let tel = recTel def `apply` pars - m = size tel - fs = recFields def - -- Construct the record pattern @Γ₁, Γ' ⊢ u := c ys@. - ys = zipWith (\ f i -> f $> var i) fs $ downFrom m - u = Con (recConHead def) ys - -- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@ - tau0 = u :# raiseS m - -- @Γ₁, Γ', Γ₂ ⊢ τ₀ : Γ₁, x:_, Γ₂@ - tau = liftS (size gamma2) tau0 + if not (recEtaEquality def) then return Nothing else Just <$> do + -- Get the record fields @Γ₁ ⊢ tel@ (@tel = Γ'@). + -- TODO: compose argInfo ai with tel. + let tel = recTel def `apply` pars + m = size tel + fs = recFields def + -- Construct the record pattern @Γ₁, Γ' ⊢ u := c ys@. + ys = zipWith (\ f i -> f $> var i) fs $ downFrom m + u = Con (recConHead def) ys + -- @Γ₁, Γ' ⊢ τ₀ : Γ₁, x:_@ + tau0 = consS u $ raiseS m + -- @Γ₁, Γ', Γ₂ ⊢ τ₀ : Γ₁, x:_, Γ₂@ + tau = liftS (size gamma2) tau0 - -- Fields are in order first-first. - zs = for fs $ fmap $ \ f -> Var 0 [Proj f] - -- We need to reverse the field sequence to build the substitution. - -- @Γ₁, x:_ ⊢ σ₀ : Γ₁, Γ'@ - sigma0 = parallelS $ reverse $ map unArg zs - -- @Γ₁, x:_, Γ₂ ⊢ σ₀ : Γ₁, Γ', Γ₂@ - sigma = liftS (size gamma2) sigma0 + -- Fields are in order first-first. + zs = for fs $ fmap $ \ f -> Var 0 [Proj f] + -- We need to reverse the field sequence to build the substitution. + -- @Γ₁, x:_ ⊢ σ₀ : Γ₁, Γ'@ + sigma0 = parallelS $ reverse $ map unArg zs + -- @Γ₁, x:_, Γ₂ ⊢ σ₀ : Γ₁, Γ', Γ₂@ + sigma = liftS (size gamma2) sigma0 - -- Construct @Δ@ as telescope. - -- Note @Γ₁, x:_ ⊢ Γ₂@, thus, @Γ₁, Γ' ⊢ [τ₀]Γ₂@ + -- Construct @Δ@ as telescope. + -- Note @Γ₁, x:_ ⊢ Γ₂@, thus, @Γ₁, Γ' ⊢ [τ₀]Γ₂@ - rev = foldl (\ l (Dom ai (n, t)) -> Dom ai (nameToArgName n, t) : l) [] - -- Use "f(x)" as variable name for the projection f(x). - s = prettyShow x - tel' = mapAbsNames (\ f -> stringToArgName $ argNameToString f ++ "(" ++ s ++ ")") tel - delta = telFromList $ rev gamma1 ++ telToList tel' ++ rev (applySubst tau0 gamma2) + rev = foldl (\ l (Dom ai (n, t)) -> Dom ai (nameToArgName n, t) : l) [] + -- Use "f(x)" as variable name for the projection f(x). + s = prettyShow x + tel' = mapAbsNames (\ f -> stringToArgName $ argNameToString f ++ "(" ++ s ++ ")") tel + delta = telFromList $ rev gamma1 ++ telToList tel' ++ rev (applySubst tau0 gamma2) - return (delta, sigma, tau) + return (delta, sigma, tau) -- | @curryAt v (Γ (y : R pars) -> B) n = -- ( \ v -> λ Γ ys → v Γ (c ys) {- curry -} diff --git a/src/full/Agda/TypeChecking/Reduce.hs b/src/full/Agda/TypeChecking/Reduce.hs --- a/src/full/Agda/TypeChecking/Reduce.hs +++ b/src/full/Agda/TypeChecking/Reduce.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.Reduce where import Prelude hiding (mapM) @@ -30,13 +33,16 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.EtaContract -import {-# SOURCE #-} Agda.TypeChecking.Pretty -import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match -import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match - import Agda.TypeChecking.Reduce.Monad +import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match +import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match +import {-# SOURCE #-} Agda.TypeChecking.Pretty +import {-# SOURCE #-} Agda.TypeChecking.Rewriting + +import Agda.Utils.Function +import Agda.Utils.Functor import Agda.Utils.Monad import Agda.Utils.HashMap (HashMap) import Agda.Utils.Maybe @@ -190,14 +196,17 @@ -- * Reduction to weak head normal form. --------------------------------------------------------------------------- +-- | Case on whether a term is blocked on a meta (or is a meta). +-- That means it can change its shape when the meta is instantiated. ifBlocked :: MonadTCM tcm => Term -> (MetaId -> Term -> tcm a) -> (Term -> tcm a) -> tcm a ifBlocked t blocked unblocked = do t <- liftTCM $ reduceB t case ignoreSharing <$> t of - Blocked m _ -> blocked m (ignoreBlocking t) - NotBlocked (MetaV m _) -> blocked m (ignoreBlocking t) - NotBlocked _ -> unblocked (ignoreBlocking t) + Blocked m _ -> blocked m (ignoreBlocking t) + NotBlocked _ (MetaV m _) -> blocked m (ignoreBlocking t) + NotBlocked{} -> unblocked (ignoreBlocking t) +-- | Case on whether a type is blocked on a meta (or is a meta). ifBlockedType :: MonadTCM tcm => Type -> (MetaId -> Type -> tcm a) -> (Type -> tcm a) -> tcm a ifBlockedType (El s t) blocked unblocked = ifBlocked t (\ m v -> blocked m $ El s v) (\ v -> unblocked $ El s v) @@ -228,6 +237,7 @@ Prop -> return s Type s' -> levelSort <$> reduce' s' Inf -> return Inf + SizeUniv -> return SizeUniv instance Reduce Elim where reduce' (Apply v) = Apply <$> reduce' v @@ -244,7 +254,7 @@ instance Reduce LevelAtom where reduceB' l = case l of MetaLevel m vs -> fromTm (MetaV m vs) - NeutralLevel v -> return $ NotBlocked $ NeutralLevel v + NeutralLevel r v -> return $ NotBlocked r $ NeutralLevel r v BlockedLevel m v -> ifM (isInstantiatedMeta m) (fromTm v) (return $ Blocked m $ BlockedLevel m v) UnreducedLevel v -> fromTm v @@ -253,9 +263,9 @@ bv <- reduceB' v let v = ignoreBlocking bv case ignoreSharing <$> bv of - NotBlocked (MetaV m vs) -> return $ NotBlocked $ MetaLevel m vs - Blocked m _ -> return $ Blocked m $ BlockedLevel m v - NotBlocked _ -> return $ NotBlocked $ NeutralLevel v + NotBlocked r (MetaV m vs) -> return $ NotBlocked r $ MetaLevel m vs + Blocked m _ -> return $ Blocked m $ BlockedLevel m v + NotBlocked r _ -> return $ NotBlocked r $ NeutralLevel r v instance (Subst t, Reduce t) => Reduce (Abs t) where @@ -285,7 +295,7 @@ reduce' (x,y,z) = (,,) <$> reduce' x <*> reduce' y <*> reduce' z instance Reduce Term where - reduceB' v = {-# SCC "reduce'" #-} do + reduceB' = {-# SCC "reduce'" #-} rewriteAfter $ \ v -> do v <- instantiate' v let done = return $ notBlocked v case v of @@ -311,6 +321,11 @@ ExtLam{} -> __IMPOSSIBLE__ Shared{} -> __IMPOSSIBLE__ -- updateSharedTermF reduceB' v where + rewriteAfter :: (Term -> ReduceM (Blocked Term)) -> Term -> ReduceM (Blocked Term) + rewriteAfter f = trampolineM $ \ v -> do + vb <- f v + caseMaybeM (rewrite $ ignoreBlocking vb) (return $ Left vb) $ \ u -> + return $ Right u -- NOTE: reduceNat can traverse the entire term. reduceNat v@Shared{} = __IMPOSSIBLE__ -- updateSharedTerm reduceNat v reduceNat v@(Con c []) = do @@ -374,14 +389,14 @@ reduceNormalE keepGoing v0 f (map notReduced es) dontUnfold (defClauses info) (defCompiled info) - else retSimpl $ notBlocked v + else retSimpl $ notBlocked v -- Andrea(s), 2014-12-05 OK? where retSimpl v = (,v) <$> getSimplification reducePrimitive x v0 f es pf dontUnfold cls mcc | genericLength es < ar - = retSimpl $ notBlocked $ v0 `applyE` es -- not fully applied + = retSimpl $ NotBlocked Underapplied $ v0 `applyE` es -- not fully applied | otherwise = {-# SCC "reducePrimitive" #-} do let (es1,es2) = genericSplitAt ar es args1 = fromMaybe __IMPOSSIBLE__ $ mapM isApplyElim es1 @@ -408,7 +423,7 @@ reduceNormalE :: (Term -> ReduceM (Simplification, Blocked Term)) -> Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause] -> Maybe CompiledClauses -> ReduceM (Simplification, Blocked Term) reduceNormalE keepGoing v0 f es dontUnfold def mcc = {-# SCC "reduceNormal" #-} do case def of - _ | dontUnfold -> defaultResult + _ | dontUnfold -> defaultResult -- non-terminating or delayed [] -> defaultResult -- no definition for head cls -> do ev <- appDefE_ f v0 cls mcc es @@ -419,13 +434,13 @@ , text " es = " <+> sep (map (prettyTCM . ignoreReduced) es) -- [ text "*** tried to reduce' " <+> prettyTCM vfull , text " stuck on" <+> prettyTCM (ignoreBlocking v) ]) $ do - retSimpl v + retSimpl v YesReduction simpl v -> performedSimplification' simpl $ do traceSDoc "tc.reduce'" 90 (text "*** reduced definition: " <+> prettyTCM f) $ do - traceSDoc "tc.reduce'" 95 (text " result" <+> prettyTCM v) $ do - traceSDoc "tc.reduce'" 100 (text " raw " <+> text (show v)) $ do - keepGoing v - where defaultResult = retSimpl $ notBlocked $ vfull + traceSDoc "tc.reduce'" 95 (text " result" <+> prettyTCM v) $ do + traceSDoc "tc.reduce'" 100 (text " raw " <+> text (show v)) $ do + keepGoing v + where defaultResult = retSimpl $ NotBlocked AbsurdMatch vfull vfull = v0 `applyE` map ignoreReduced es -- | Reduce a non-primitive definition if it is a copy linking to another def. @@ -520,25 +535,24 @@ goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term) goCls cl es = do reportSLn "tc.reduce'" 95 $ "Reduce.goCls tries reduction, #clauses = " ++ show (length cl) - let cantReduce es = return $ NoReduction $ notBlocked $ v `applyE` es case cl of -- Andreas, 2013-10-26 In case of an incomplete match, - -- we just do not reduce'. This allows adding single function + -- we just do not reduce. This allows adding single function -- clauses after they have been type-checked, to type-check -- the remaining clauses (see Issue 907). - [] -> cantReduce es -- WAS: typeError $ IncompletePatternMatching v es - cl @ Clause { clauseBody = body } : cls -> do - let pats = namedClausePats cl - n = length pats + -- Andrea(s), 2014-12-05: We return 'MissingClauses' here, since this + -- is the most conservative reason. + [] -> return $ NoReduction $ NotBlocked MissingClauses $ v `applyE` es + Clause{ namedClausePats = pats, clauseBody = body } : cls -> do + let n = length pats -- if clause is underapplied, skip to next clause if length es < n then goCls cls es else do let (es0, es1) = splitAt n es (m, es0) <- matchCopatterns pats es0 es <- return $ es0 ++ es1 case m of - No -> goCls cls es - DontKnow Nothing -> cantReduce es - DontKnow (Just m) -> return $ NoReduction $ blocked m $ v `applyE` es + No -> goCls cls es + DontKnow b -> return $ NoReduction $ b $> v `applyE` es Yes simpl vs -- vs is the subst. for the variables bound in body | isJust (getBodyUnraised body) -- clause has body? -> return $ YesReduction simpl $ @@ -546,7 +560,7 @@ -- of the original arguments! -- Andreas, 2013-05-19 isn't this done now? app vs body EmptyS `applyE` es1 - | otherwise -> cantReduce es + | otherwise -> return $ NoReduction $ NotBlocked AbsurdMatch $ v `applyE` es -- Build an explicit substitution from arguments -- and execute it using parallel substitution. @@ -560,7 +574,7 @@ -- Δ.A ⊢ b : B app :: [Term] -> ClauseBody -> Substitution -> Term app [] (Body v) sigma = applySubst sigma v - app (v : vs) (Bind (Abs _ b)) sigma = app vs b (v :# sigma) -- CBN + app (v : vs) (Bind (Abs _ b)) sigma = app vs b $ consS v sigma -- CBN app (v : vs) (Bind (NoAbs _ b)) sigma = app vs b sigma app _ NoBody sigma = __IMPOSSIBLE__ app (_ : _) (Body _) sigma = __IMPOSSIBLE__ @@ -606,7 +620,7 @@ v <- instantiate' v case v of Def f vs -> do - let keepGoing v = (,NotBlocked v) <$> getSimplification + let keepGoing v = (,notBlocked v) <$> getSimplification -- Andrea(s), 2014-12-05 OK? (simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs reportSDoc "tc.simplify'" 20 $ text ("simplify': unfolding definition returns " ++ show simpl) @@ -627,8 +641,8 @@ Shared{} -> __IMPOSSIBLE__ -- updateSharedTerm simplify' v simplifyBlocked' :: Simplify t => Blocked t -> ReduceM t -simplifyBlocked' (Blocked _ t) = return t -simplifyBlocked' (NotBlocked t) = simplify' t +simplifyBlocked' (Blocked _ t) = return t +simplifyBlocked' (NotBlocked _ t) = simplify' t -- Andrea(s), 2014-12-05 OK? instance Simplify Type where simplify' (El s t) = El <$> simplify' s <*> simplify' t @@ -644,6 +658,7 @@ Type s -> levelSort <$> simplify' s Prop -> return s Inf -> return s + SizeUniv -> return s instance Simplify Level where simplify' (Max as) = levelMax <$> simplify' as @@ -658,7 +673,7 @@ case l of MetaLevel m vs -> MetaLevel m <$> simplify' vs BlockedLevel m v -> BlockedLevel m <$> simplify' v - NeutralLevel v -> NeutralLevel <$> simplify' v -- ?? + NeutralLevel r v -> NeutralLevel r <$> simplify' v -- ?? UnreducedLevel v -> UnreducedLevel <$> simplify' v -- ?? instance (Subst t, Simplify t) => Simplify (Abs t) where @@ -721,14 +736,19 @@ instance Simplify Bool where simplify' = return -instance Simplify Pattern where - simplify' p = case p of - VarP _ -> return p - LitP _ -> return p - ConP c mt ps -> ConP c <$> simplify' mt <*> simplify' ps - DotP v -> DotP <$> simplify' v - ProjP _ -> return p +-- UNUSED +-- instance Simplify ConPatternInfo where +-- simplify' (ConPatternInfo mr mt) = ConPatternInfo mr <$> simplify' mt +-- UNUSED +-- instance Simplify Pattern where +-- simplify' p = case p of +-- VarP _ -> return p +-- LitP _ -> return p +-- ConP c ci ps -> ConP c <$> simplify' ci <*> simplify' ps +-- DotP v -> DotP <$> simplify' v +-- ProjP _ -> return p + instance Simplify ClauseBody where simplify' (Body t) = Body <$> simplify' t simplify' (Bind b) = Bind <$> simplify' b @@ -753,6 +773,7 @@ Prop -> return s Type s -> levelSort <$> normalise' s Inf -> return Inf + SizeUniv -> return SizeUniv instance Normalise Type where normalise' (El s t) = El <$> normalise' s <*> normalise' t @@ -791,7 +812,7 @@ case l of MetaLevel m vs -> MetaLevel m <$> normalise' vs BlockedLevel m v -> BlockedLevel m <$> normalise' v - NeutralLevel v -> NeutralLevel <$> normalise' v + NeutralLevel r v -> NeutralLevel r <$> normalise' v UnreducedLevel{} -> __IMPOSSIBLE__ -- I hope instance Normalise ClauseBody where @@ -854,6 +875,9 @@ instance Normalise Bool where normalise' = return +instance Normalise ConPatternInfo where + normalise' (ConPatternInfo mr mt) = ConPatternInfo mr <$> normalise' mt + instance Normalise Pattern where normalise' p = case p of VarP _ -> return p @@ -894,6 +918,7 @@ Prop -> return s DLub s1 s2 -> dLub <$> instantiateFull' s1 <*> instantiateFull' s2 Inf -> return s + SizeUniv -> return s instance InstantiateFull Type where instantiateFull' (El s t) = @@ -931,7 +956,7 @@ case ignoreSharing v of MetaV m vs -> return $ MetaLevel m vs _ -> return $ UnreducedLevel v - NeutralLevel v -> NeutralLevel <$> instantiateFull' v + NeutralLevel r v -> NeutralLevel r <$> instantiateFull' v BlockedLevel m v -> ifM (isInstantiatedMeta m) (UnreducedLevel <$> instantiateFull' v) @@ -946,12 +971,15 @@ Wk n sigma -> Wk n <$> instantiateFull' sigma Lift n sigma -> Lift n <$> instantiateFull' sigma Strengthen bot sigma -> Strengthen bot <$> instantiateFull' sigma - t :# sigma -> (:#) <$> instantiateFull' t - <*> instantiateFull' sigma + t :# sigma -> consS <$> instantiateFull' t + <*> instantiateFull' sigma instance InstantiateFull Bool where instantiateFull' = return +instance InstantiateFull ConPatternInfo where + instantiateFull' (ConPatternInfo mr mt) = ConPatternInfo mr <$> instantiateFull' mt + instance InstantiateFull Pattern where instantiateFull' v@VarP{} = return v instantiateFull' (DotP t) = DotP <$> instantiateFull' t @@ -1012,7 +1040,7 @@ FindInScope m cands -> FindInScope m <$> mapM instantiateFull' cands IsEmpty r t -> IsEmpty r <$> instantiateFull' t -instance InstantiateFull Elim where +instance (InstantiateFull a) => InstantiateFull (Elim' a) where instantiateFull' (Apply v) = Apply <$> instantiateFull' v instantiateFull' (Proj f) = pure $ Proj f @@ -1046,6 +1074,12 @@ (t, (df, d, rew)) <- instantiateFull' (t, (df, d, rew)) return $ Defn rel x t pol occ df i c rew inst d +instance InstantiateFull NLPat where + instantiateFull' (PVar x) = return $ PVar x + instantiateFull' (PWild) = return PWild + instantiateFull' (PDef x y) = PDef <$> instantiateFull' x <*> instantiateFull' y + instantiateFull' (PTerm x) = PTerm <$> instantiateFull' x + instance InstantiateFull RewriteRule where instantiateFull' (RewriteRule q gamma lhs rhs t) = RewriteRule q @@ -1064,7 +1098,7 @@ instantiateFull' (DTerm v) = DTerm <$> instantiateFull' v instantiateFull' (DDot v) = DDot <$> instantiateFull' v instantiateFull' (DCon c vs) = DCon c <$> instantiateFull' vs - instantiateFull' (DDef c vs) = DDef c <$> instantiateFull' vs + instantiateFull' (DDef c es) = DDef c <$> instantiateFull' es instantiateFull' (DWithApp v vs ws) = uncurry3 DWithApp <$> instantiateFull' (v, vs, ws) instance InstantiateFull Defn where @@ -1133,4 +1167,3 @@ instance InstantiateFull a => InstantiateFull (Maybe a) where instantiateFull' = mapM instantiateFull' - diff --git a/src/full/Agda/TypeChecking/Reduce/Monad.hs b/src/full/Agda/TypeChecking/Reduce/Monad.hs --- a/src/full/Agda/TypeChecking/Reduce/Monad.hs +++ b/src/full/Agda/TypeChecking/Reduce/Monad.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} module Agda.TypeChecking.Reduce.Monad ( constructorForm @@ -12,6 +12,7 @@ , lookupMeta , reportSDoc, reportSLn , traceSLn, traceSDoc + , askR, applyWhenVerboseS ) where import Control.Arrow ((***), first, second) diff --git a/src/full/Agda/TypeChecking/Rewriting.hs b/src/full/Agda/TypeChecking/Rewriting.hs --- a/src/full/Agda/TypeChecking/Rewriting.hs +++ b/src/full/Agda/TypeChecking/Rewriting.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} -- | Rewriting with arbitrary rules. -- @@ -41,9 +43,16 @@ module Agda.TypeChecking.Rewriting where +import Prelude hiding (null) + import Control.Monad import Control.Monad.Reader (local) +import Data.Foldable ( Foldable, foldMap ) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import qualified Data.List as List + import Agda.Syntax.Common import Agda.Syntax.Internal as I @@ -56,9 +65,14 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +import Agda.TypeChecking.Rewriting.NonLinMatch +import qualified Agda.TypeChecking.Reduce.Monad as Red + import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Null +import Agda.Utils.Singleton import Agda.Utils.Size #include "undefined.h" @@ -119,16 +133,10 @@ -- to the signature where @B = A[us/Δ]@. -- Remember that @rel : Δ → A → A → Set i@, so -- @rel us : (lhs rhs : A[us/Δ]) → Set i@. +-- +-- Makes only sense in empty context. addRewriteRule :: QName -> TCM () -addRewriteRule q = do - let failureWrongTarget = typeError . GenericDocError =<< sep - [ prettyTCM q , text " does not target rewrite relation" ] - let failureMetas = typeError . GenericDocError =<< sep - [ prettyTCM q , text " is not a legal rewrite rule, since it contains unsolved meta variables" ] - let failureFreeVars = typeError . GenericDocError =<< sep - [ prettyTCM q , text " is not a legal rewrite rule, since not all variables are bound by the left hand side" ] - let failureIllegalRule = typeError . GenericDocError =<< sep - [ prettyTCM q , text " is not a legal rewrite rule" ] +addRewriteRule q = inTopContext $ do Def rel _ <- primRewrite -- We know that the type of rel is that of a relation. Just (RelView _tel delta a _a' _core) <- relView =<< do @@ -140,6 +148,22 @@ -- Get rewrite rule (type of q). t <- defType <$> getConstInfo q TelV gamma core <- telView t + + let failureWrongTarget = typeError . GenericDocError =<< hsep + [ prettyTCM q , text " does not target rewrite relation" ] + let failureMetas = typeError . GenericDocError =<< hsep + [ prettyTCM q , text " is not a legal rewrite rule, since it contains unsolved meta variables" ] + let failureNotDefOrCon = typeError . GenericDocError =<< hsep + [ prettyTCM q , text " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ] + let failureFreeVars xs = typeError . GenericDocError =<< do + addContext gamma $ hsep $ + [ prettyTCM q , text " is not a legal rewrite rule, since the following variables are not bound by the left hand side: " , prettyList_ (map (prettyTCM . var) xs) ] + let failureLhsReduction lhs = typeError . GenericDocError =<< do + addContext gamma $ hsep $ + [ prettyTCM q , text " is not a legal rewrite rule, since the left-hand side " , prettyTCM lhs , text " has top-level reductions" ] + let failureIllegalRule = typeError . GenericDocError =<< hsep + [ prettyTCM q , text " is not a legal rewrite rule" ] + -- Check that type of q targets rel. case ignoreSharing $ unEl core of Def rel' es@(_:_:_) | rel == rel' -> do @@ -150,31 +174,65 @@ (us, [lhs, rhs]) = splitAt (n - 2) vs unless (size delta == size us) __IMPOSSIBLE__ let b = applySubst (parallelS $ reverse us) a + + -- Find head symbol f of the lhs. + f <- case ignoreSharing lhs of + Def f es -> return f + Con c vs -> return $ conName c + _ -> failureNotDefOrCon + -- Normalize lhs: we do not want to match redexes. - lhs <- etaContract =<< normalise lhs + lhs <- normaliseArgs lhs + unlessM (isNormal lhs) $ failureLhsReduction lhs + -- Normalize rhs: might be more efficient. rhs <- etaContract =<< normalise rhs unless (null $ allMetas (telToList gamma, lhs, rhs, b)) failureMetas - let rew = RewriteRule q gamma lhs rhs b - reportSDoc "rewriting" 10 $ + pat <- patternFrom lhs + let rew = RewriteRule q gamma pat rhs b + reportSDoc "rewriting" 10 $ addContext gamma $ text "considering rewrite rule " <+> prettyTCM rew - -- Check whether lhs can be rewritten with itself. - -- Otherwise, there are unbound variables in either gamma or rhs. - addContext gamma $ - unlessM (isJust <$> rewriteWith (Just b) lhs rew) $ - failureFreeVars - -- Find head symbol f of the lhs. - case ignoreSharing lhs of - Def f _ -> do - -- Add rewrite rule gamma ⊢ lhs ↦ rhs : b for f. - addRewriteRules f [rew] - _ -> failureIllegalRule + + -- Check that all variables of Γ are pattern variables in the lhs. + unlessNull ([0 .. size gamma - 1] List.\\ IntSet.toList (nlPatVars pat)) failureFreeVars + + -- -- check that FV(rhs) ⊆ nlPatVars(lhs) + -- unless (allVars (freeVars rhs) `IntSet.isSubsetOf` nlPatVars pat) $ + -- failureFreeVars + + -- NO LONGER WORKS: + -- -- Check whether lhs can be rewritten with itself. + -- -- Otherwise, there are unbound variables in either gamma or rhs. + -- addContext gamma $ + -- unlessM (isJust <$> runReduceM (rewriteWith (Just b) lhs rew)) $ + -- failureFreeVars + + -- Add rewrite rule gamma ⊢ lhs ↦ rhs : b for f. + addRewriteRules f [rew] + _ -> failureWrongTarget + where + normaliseArgs :: Term -> TCM Term + normaliseArgs v = case ignoreSharing v of + Def f es -> Def f <$> do etaContract =<< normalise es + Con c vs -> Con c <$> do etaContract =<< normalise vs + _ -> __IMPOSSIBLE__ + isNormal :: Term -> TCM Bool + isNormal v = do + v' <- normalise v + return $ v == v' + -- | Append rewrite rules to a definition. addRewriteRules :: QName -> RewriteRules -> TCM () -addRewriteRules f rews = +addRewriteRules f rews = do + reportSDoc "rewriting" 10 $ text "rewrite rule ok, adding it to the definition of " <+> prettyTCM f modifySignature $ updateDefinition f $ updateRewriteRules $ (++ rews) + rules <- defRewriteRules <$> getConstInfo f + reportSDoc "rewriting" 20 $ vcat + [ text "rewrite rules for " <+> prettyTCM f <+> text ":" + , vcat (map prettyTCM rules) + ] -- | Lens for 'RewriteRules'. updateRewriteRules :: (RewriteRules -> RewriteRules) -> Definition -> Definition @@ -182,12 +240,32 @@ -- | @rewriteWith t v rew@ -- tries to rewrite @v : t@ with @rew@, returning the reduct if successful. -rewriteWith :: Maybe Type -> Term -> RewriteRule -> TCM (Maybe Term) +rewriteWith :: Maybe Type -> Term -> RewriteRule -> ReduceM (Maybe Term) rewriteWith mt v (RewriteRule q gamma lhs rhs b) = do - xs <- newTelMeta gamma - let sigma = parallelS $ map unArg xs - (lhs', rhs', b') = applySubst sigma (lhs, rhs, b) - ok <- tryConversion $ do + Red.traceSDoc "rewriting" 95 (sep + [ text "attempting to rewrite term " <+> prettyTCM v + , text " with rule " <+> prettyTCM q + ]) $ do + let no = return Nothing + caseMaybeM (nonLinMatch lhs v) no $ \ sub -> do + let v' = applySubst sub rhs + Red.traceSDoc "rewriting" 90 (sep + [ text "rewrote " <+> prettyTCM v + , text " to " <+> prettyTCM v' + ]) $ do + return $ Just v' + + {- OLD CODE: + -- Freeze all metas, remember which one where not frozen before. + -- This ensures that we do not instantiate metas while matching + -- on the rewrite lhs. + ms <- freezeMetas + res <- tryConversion' $ do + + -- Create new metas for the lhs variables of the rewriting rule. + xs <- newTelMeta gamma + let sigma = parallelS $ map unArg xs + (lhs', rhs', b') = applySubst sigma (lhs, rhs, b) -- Unify type and term with type and lhs of rewrite rule. whenJust mt $ \ t -> leqType t b' local (\ e -> e {envCompareBlocked = True}) $ equalTerm b' lhs' v @@ -197,19 +275,53 @@ sep $ map prettyTCM xs -- The following error is caught immediately by tryConversion. typeError $ GenericError $ "free variables not bound by left hand side" - if ok then return $ Just rhs' else return Nothing + return rhs' + -- Thaw metas that were frozen by a call to this function. + unfreezeMetas' (`elem` ms) + return res-} + -- | @rewrite t@ tries to rewrite a reduced term. -rewrite :: Term -> TCM (Maybe Term) +rewrite :: Term -> ReduceM (Maybe Term) rewrite v = do case ignoreSharing v of - -- We only rewrite @Def@s. - Def f es -> do - -- Get the rewrite rules for f. - rews <- defRewriteRules <$> getConstInfo f - loop rews - where - loop [] = return Nothing - loop (rew:rews) = do - caseMaybeM (rewriteWith Nothing v rew) (loop rews) (return . Just) + -- We only rewrite @Def@s and @Con@s. + Def f es -> rew f (Def f) es + Con c vs -> rew (conName c) hd (Apply <$> vs) + where hd es = Con c $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es _ -> return Nothing + where + -- Try all rewrite rules for f. + rew :: QName -> (Elims -> Term) -> Elims -> ReduceM (Maybe Term) + rew f hd es = loop =<< do defRewriteRules <$> getConstInfo f + where + loop [] = return Nothing + loop (rew:rews) + | let n = rewArity rew, length es >= n = do + let (es1, es2) = List.genericSplitAt n es + caseMaybeM (rewriteWith Nothing (hd es1) rew) (loop rews) $ \ w -> + return $ Just $ w `applyE` es2 + | otherwise = loop rews + +------------------------------------------------------------------------ +-- * Auxiliary functions +------------------------------------------------------------------------ + +class NLPatVars a where + nlPatVars :: a -> IntSet + +instance (Foldable f, NLPatVars a) => NLPatVars (f a) where + nlPatVars = foldMap nlPatVars + +instance NLPatVars NLPat where + nlPatVars p = + case p of + PVar i -> singleton i + PDef _ es -> nlPatVars es + PWild -> empty + PTerm{} -> empty + +rewArity :: RewriteRule -> Int +rewArity rew = case rewLHS rew of + PDef _f es -> length es + _ -> __IMPOSSIBLE__ diff --git a/src/full/Agda/TypeChecking/Rewriting.hs-boot b/src/full/Agda/TypeChecking/Rewriting.hs-boot --- a/src/full/Agda/TypeChecking/Rewriting.hs-boot +++ b/src/full/Agda/TypeChecking/Rewriting.hs-boot @@ -4,4 +4,4 @@ import Agda.TypeChecking.Monad.Base verifyBuiltinRewrite :: Term -> Type -> TCM () -rewrite :: Term -> TCM (Maybe Term) +rewrite :: Term -> ReduceM (Maybe Term) diff --git a/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs b/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs @@ -0,0 +1,266 @@ +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + FlexibleInstances, + MultiParamTypeClasses #-} + +{- | Non-linear matching of the lhs of a rewrite rule against a + neutral term. + +Given a lhs + + Δ ⊢ lhs : B + +and a candidate term + + Γ ⊢ t : A + +we seek a substitution Γ ⊢ σ : Δ such that + + Γ ⊢ B[σ] = A and + Γ ⊢ lhs[σ] = t : A + +-} + +module Agda.TypeChecking.Rewriting.NonLinMatch where + +import Prelude hiding (sequence) + +import Control.Monad.Trans.Maybe +import Control.Monad.Writer hiding (forM, sequence) + +import Debug.Trace +import System.IO.Unsafe + +import Data.Maybe +import Data.Functor +import Data.Traversable hiding (for) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import Agda.Syntax.Common (unArg) +import Agda.Syntax.Internal + +import Agda.TypeChecking.EtaContract +import Agda.TypeChecking.Monad +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Reduce.Monad +import Agda.TypeChecking.Substitute + +import Agda.Utils.Functor +import Agda.Utils.Maybe +import Agda.Utils.Monad hiding (sequence) +import Agda.Utils.Singleton + +#include "undefined.h" +import Agda.Utils.Impossible + +-- nonLinMatch :: NLPat -> Term -> ReduceM (Maybe Substitution) +-- nonLinMatch p v = do +-- let no = return Nothing +-- caseMaybeM (execNLM $ ambMatch p v) no $ \ (sub, eqs) -> do +-- -- Check that the substitution is non-ambiguous and total. +-- msub <- runWriterT $ Map.forM sub $ \case +-- [v] -> return v +-- [] -> mzero +-- (v : vs) -> v <$ forM_ vs $ \ u -> do +-- ifM (equal v u) (return ()) mzero +-- caseMaybe msub no $ \ sub' -> do +-- -- +-- -- Check that the equations are satisfied. + +-- -- | Non-linear (non-constructor) first-order pattern. +-- data NLPat +-- = PVar {-# UNPACK #-} !Int +-- -- ^ Matches anything (modulo non-linearity). +-- | PWild +-- -- ^ Matches anything (e.g. irrelevant terms). +-- | PDef QName PElims +-- -- ^ Matches @f es@ +-- | PTerm Term +-- -- ^ Matches the term modulo β (ideally βη). +-- type PElims = [Elim' NLPat] + +-- | Turn a term into a non-linear pattern, treating the +-- free variables as pattern variables. + +class PatternFrom a b where + patternFrom :: a -> TCM b + +instance (Traversable f, PatternFrom a b) => PatternFrom (f a) (f b) where + patternFrom = traverse patternFrom + +instance PatternFrom Term NLPat where + patternFrom v = do + v <- etaContract =<< reduce v + let done = return $ PTerm v + case ignoreSharing v of + Var i [] -> return $ PVar i + Var{} -> done + Lam{} -> done + Lit{} -> done + Def f es -> PDef f <$> patternFrom es + Con c vs -> PDef (conName c) <$> patternFrom (Apply <$> vs) + Pi{} -> done + Sort{} -> done + Level{} -> return PWild -- TODO: unLevel and continue + DontCare{} -> return PWild + MetaV{} -> __IMPOSSIBLE__ + Shared{} -> __IMPOSSIBLE__ + ExtLam{} -> __IMPOSSIBLE__ + + +-- | Monad for non-linear matching. +type NLM = MaybeT (WriterT NLMOut ReduceM) + +type NLMOut = (AmbSubst, PostponedEquations) + +liftRed :: ReduceM a -> NLM a +liftRed = lift . lift + +instance HasOptions NLM where + pragmaOptions = liftRed pragmaOptions + commandLineOptions = liftRed commandLineOptions + +runNLM :: NLM () -> ReduceM (Maybe NLMOut) +runNLM nlm = do + (ok, sub) <- runWriterT $ runMaybeT nlm + return $ const sub <$> ok + +traceSDocNLM :: VerboseKey -> Int -> TCM Doc -> NLM a -> NLM a +traceSDocNLM k n doc = applyWhenVerboseS k n $ \ cont -> do + ReduceEnv env st <- liftRed askR + trace (show $ fst $ unsafePerformIO $ runTCM env st doc) cont + + +-- execNLM :: NLM a -> ReduceM (Maybe NLMOut) +-- execNLM m = runMaybeT $ execWriterT m + +-- | Add substitution @i |-> v@ to result of matching. +tellSubst :: Int -> Term -> NLM () +tellSubst i v = tell (singleton (i, v), mempty) + +tellEq :: Term -> Term -> NLM () +tellEq u v = tell (mempty, singleton $ PostponedEquation u v) + +-- | Non-linear matching returns first an ambiguous substitution, +-- mapping one de Bruijn index to possibly several terms. +newtype AmbSubst = AmbSubst { ambSubst :: IntMap [Term] } + +instance Monoid AmbSubst where + mempty = AmbSubst mempty + AmbSubst m `mappend` AmbSubst n = AmbSubst $ IntMap.unionWith (++) m n + +instance Singleton (Int,Term) AmbSubst where + singleton (i, v) = AmbSubst $ IntMap.singleton i [v] + +-- sgSubst :: Int -> Term -> AmbSubst +-- sgSubst i v = AmbSubst $ IntMap.singleton i [v] + +-- | Matching against a term produces a constraint +-- which we have to verify after applying +-- the substitution computed by matching. +data PostponedEquation = PostponedEquation + { eqLhs :: Term -- ^ Term from pattern, living in pattern context. + , eqRhs :: Term -- ^ Term from scrutinee, living in context where matching was invoked. + } +type PostponedEquations = [PostponedEquation] + +instance Subst PostponedEquation where + applySubst rho (PostponedEquation lhs rhs) = + PostponedEquation (applySubst rho lhs) (applySubst rho rhs) + +-- | Match a non-linear pattern against a neutral term, +-- returning a substitution. + +class AmbMatch a b where + ambMatch :: a -> b -> NLM () + +instance AmbMatch a b => AmbMatch [a] [b] where + ambMatch ps vs + | length ps == length vs = zipWithM_ ambMatch ps vs + | otherwise = traceSDocNLM "rewriting" 100 (sep + [ text $ "mismatching number of arguments: " ++ + show (length ps) ++ " vs " ++ show (length vs) ]) mzero + +instance AmbMatch a b => AmbMatch (Arg a) (Arg b) where + ambMatch p v = ambMatch (unArg p) (unArg v) + +instance AmbMatch a b => AmbMatch (Elim' a) (Elim' b) where + ambMatch p v = + case (p, v) of + (Apply p, Apply v) -> ambMatch p v + (Proj x , Proj y ) -> if x == y then return () else + traceSDocNLM "rewriting" 100 (sep + [ text "mismatch between projections " <+> prettyTCM x + , text " and " <+> prettyTCM y ]) mzero + (Apply{}, Proj{} ) -> __IMPOSSIBLE__ + (Proj{} , Apply{}) -> __IMPOSSIBLE__ + +instance AmbMatch NLPat Term where + ambMatch p v = do + let yes = return () + no x y = + traceSDocNLM "rewriting" 100 (sep + [ text "mismatch between" <+> prettyTCM x + , text " and " <+> prettyTCM y]) mzero + case p of + PWild -> yes + PVar i -> tellSubst i v + PDef f ps -> do + v <- liftRed $ constructorForm v + case ignoreSharing v of + Def f' es + | f == f' -> matchArgs ps es + | otherwise -> no f f' + Con c vs + | f == conName c -> matchArgs ps (Apply <$> vs) + | otherwise -> no f c + _ -> no p v + PTerm u -> tellEq u v + where + matchArgs :: [Elim' NLPat] -> Elims -> NLM () + matchArgs ps es = ambMatch ps =<< liftRed (etaContract =<< reduce' es) + +makeSubstitution :: IntMap Term -> Substitution +makeSubstitution sub + | IntMap.null sub = idS + | otherwise = map val [0 .. highestIndex] ++# raiseS (highestIndex + 1) + where + highestIndex = fst $ IntMap.findMax sub -- find highest key + val i = fromMaybe (var i) $ IntMap.lookup i sub + +disambiguateSubstitution :: AmbSubst -> ReduceM (Maybe Substitution) +disambiguateSubstitution as = do + mvs <- forM (ambSubst as) $ \vs -> case vs of + [] -> __IMPOSSIBLE__ -- unbound variable + (v:vs) -> do + ok <- andM (equal v <$> vs) + if ok then return (Just v) else return Nothing + case sequence mvs of + Nothing -> return Nothing + Just vs -> return $ Just $ makeSubstitution vs + +checkPostponedEquations :: Substitution -> PostponedEquations -> ReduceM Bool +checkPostponedEquations sub eqs = andM $ for (applySubst sub eqs) $ + \ (PostponedEquation lhs rhs) -> equal lhs rhs + +-- main function +nonLinMatch :: (AmbMatch a b) => a -> b -> ReduceM (Maybe Substitution) +nonLinMatch p v = do + let no msg = traceSDoc "rewriting" 100 (sep + [ text "matching failed during" <+> text msg ]) $ return Nothing + caseMaybeM (runNLM $ ambMatch p v) (no "ambiguous matching") $ \ (asub, eqs) -> do + caseMaybeM (disambiguateSubstitution asub) (no "disambiguation") $ \ sub -> do + ifM (checkPostponedEquations sub eqs) (return $ Just sub) (no "checking of postponed equations") + +-- | Untyped βη-equality, does not handle things like empty record types. +equal :: Term -> Term -> ReduceM Bool +equal u v = do + (u, v) <- etaContract =<< normalise' (u, v) + let ok = u == v + if ok then return True else + traceSDoc "rewriting" 100 (sep + [ text "mismatch between " <+> prettyTCM u + , text " and " <+> prettyTCM v + ]) $ return False diff --git a/src/full/Agda/TypeChecking/Rules/Builtin.hs b/src/full/Agda/TypeChecking/Rules/Builtin.hs --- a/src/full/Agda/TypeChecking/Rules/Builtin.hs +++ b/src/full/Agda/TypeChecking/Rules/Builtin.hs @@ -1,34 +1,43 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -module Agda.TypeChecking.Rules.Builtin (bindBuiltin, bindPostulatedName) where +module Agda.TypeChecking.Rules.Builtin + ( bindBuiltin + , bindBuiltinNoDef + , bindPostulatedName + ) where -import Control.Applicative +import Control.Applicative hiding (empty) import Control.Monad import Data.List (find) import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Internal import Agda.Syntax.Common +import Agda.Syntax.Internal import Agda.Syntax.Position -import Agda.TypeChecking.EtaContract import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Builtin +import Agda.TypeChecking.Monad.SizedTypes ( builtinSizeHook ) + import Agda.TypeChecking.Conversion -import Agda.TypeChecking.Substitute -import Agda.TypeChecking.Primitive import Agda.TypeChecking.Constraints -import Agda.TypeChecking.Reduce +import Agda.TypeChecking.EtaContract import Agda.TypeChecking.Irrelevance -import Agda.TypeChecking.Monad.SizedTypes ( builtinSizeHook ) +import Agda.TypeChecking.Primitive +import Agda.TypeChecking.Reduce +import Agda.TypeChecking.Substitute import Agda.TypeChecking.Rules.Term ( checkExpr , inferExpr ) + import {-# SOURCE #-} Agda.TypeChecking.Rules.Builtin.Coinduction import {-# SOURCE #-} Agda.TypeChecking.Rewriting import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.Maybe +import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.Size #include "undefined.h" @@ -114,8 +123,11 @@ , (builtinVisible |-> BuiltinDataCons thiding) , (builtinRelevant |-> BuiltinDataCons trelevance) , (builtinIrrelevant |-> BuiltinDataCons trelevance) - , (builtinSize |-> builtinPostulate tset) - , (builtinSizeLt |-> builtinPostulate (tsize --> tset)) + , (builtinSizeUniv |-> builtinPostulate tSizeUniv) -- SizeUniv : SizeUniv +-- See comment on tSizeUniv: the following does not work currently. +-- , (builtinSizeUniv |-> builtinPostulate tSetOmega) -- SizeUniv : Setω + , (builtinSize |-> builtinPostulate tSizeUniv) + , (builtinSizeLt |-> builtinPostulate (tsize ..--> tSizeUniv)) , (builtinSizeSuc |-> builtinPostulate (tsize --> tsize)) , (builtinSizeInf |-> builtinPostulate tsize) -- postulate max : {i : Size} -> Size< i -> Size< i -> Size< i @@ -180,7 +192,7 @@ tchar = el primChar tstring = el primString tqname = el primQName - tsize = el primSize + tsize = El SizeUniv <$> primSize tbool = el primBool thiding = el primHiding trelevance = el primRelevance @@ -432,7 +444,7 @@ def <- ignoreAbstractMode $ getConstInfo q case theDef def of Axiom {} -> do - builtinSizeHook s q e' t' + builtinSizeHook s q t' bindBuiltinName s e' _ -> err _ -> err @@ -447,15 +459,39 @@ -- | Bind a builtin thing to an expression. bindBuiltin :: String -> A.Expr -> TCM () bindBuiltin b e = do - top <- (== 0) . size <$> getContextTelescope - unless top $ typeError $ BuiltinInParameterisedModule b - bind b e - where - bind b e - | b == builtinZero = typeError $ GenericError "Builtin ZERO does no longer exist. It is now bound by BUILTIN NATURAL" - | b == builtinSuc = typeError $ GenericError "Builtin SUC does no longer exist. It is now bound by BUILTIN NATURAL" - | b == builtinInf = bindBuiltinInf e - | b == builtinSharp = bindBuiltinSharp e - | b == builtinFlat = bindBuiltinFlat e - | Just i <- find ((==b) . builtinName) coreBuiltins = bindBuiltinInfo i e - | otherwise = typeError $ NoSuchBuiltinName b + unlessM ((0 ==) <$> getContextSize) $ typeError $ BuiltinInParameterisedModule b + case b of + _ | b == builtinZero -> nowNat b + _ | b == builtinSuc -> nowNat b + _ | b == builtinInf -> bindBuiltinInf e + _ | b == builtinSharp -> bindBuiltinSharp e + _ | b == builtinFlat -> bindBuiltinFlat e + _ | Just i <- find ((b ==) . builtinName) coreBuiltins -> bindBuiltinInfo i e + _ -> typeError $ NoSuchBuiltinName b + where + nowNat b = genericError $ + "Builtin " ++ b ++ " does no longer exist. " ++ + "It is now bound by BUILTIN " ++ builtinNat + + +-- | Bind a builtin thing to a new name. +bindBuiltinNoDef :: String -> A.QName -> TCM () +bindBuiltinNoDef b q = do + unlessM ((0 ==) <$> getContextSize) $ typeError $ BuiltinInParameterisedModule b + case lookup b $ map (\ (BuiltinInfo b i) -> (b, i)) coreBuiltins of + Just (BuiltinPostulate rel mt) -> do + t <- mt + addConstant q $ defaultDefn (setRelevance rel defaultArgInfo) q t def + builtinSizeHook b q t + bindBuiltinName b $ Def q [] + where + -- Andreas, 2015-02-14 + -- Special treatment of SizeUniv, should maybe be a primitive. + def | b == builtinSizeUniv = emptyFunction + { funClauses = [ (empty :: Clause) { clauseBody = Body $ Sort SizeUniv } ] + , funTerminates = Just True + } + | otherwise = Axiom + + Just{} -> __IMPOSSIBLE__ + Nothing -> __IMPOSSIBLE__ -- typeError $ NoSuchBuiltinName b diff --git a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs --- a/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs +++ b/src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs @@ -122,11 +122,14 @@ ExtendTel (domH $ sort $ varSort 0) $ Abs "A" $ ExtendTel (domN $ El (varSort 1) $ var 0) $ Abs "x" $ EmptyTel + infA = El (varSort 2) $ Def inf [ Apply $ defaultArg $ var 1 ] + cpi = ConPatternInfo Nothing $ Just $ defaultArg infA let clause = Clause { clauseRange = noRange , clauseTel = tel , clausePerm = idP 1 - , namedClausePats = [ argN $ Named Nothing $ ConP sharpCon Nothing [ argN $ Named Nothing $ VarP "x" ] ] + , namedClausePats = [ argN $ Named Nothing $ + ConP sharpCon cpi [ argN $ Named Nothing $ VarP "x" ] ] , clauseBody = Bind $ Abs "x" $ Body $ var 0 , clauseType = Just $ defaultArg $ El (varSort 2) $ var 1 } diff --git a/src/full/Agda/TypeChecking/Rules/Data.hs b/src/full/Agda/TypeChecking/Rules/Data.hs --- a/src/full/Agda/TypeChecking/Rules/Data.hs +++ b/src/full/Agda/TypeChecking/Rules/Data.hs @@ -47,7 +47,7 @@ -- checked. checkDataDef :: Info.DefInfo -> QName -> [A.LamBinding] -> [A.Constructor] -> TCM () checkDataDef i name ps cs = - traceCall (CheckDataDef (getRange i) (qnameName name) ps cs) $ do -- TODO!! (qnameName) + traceCall (CheckDataDef (getRange name) (qnameName name) ps cs) $ do -- TODO!! (qnameName) let countPars A.DomainFree{} = 1 countPars (A.DomainFull (A.TypedBindings _ (Arg _ b))) = case b of A.TLet{} -> 0 @@ -144,7 +144,7 @@ -- Prop contain at most one element. do proofIrr <- proofIrrelevance case (proofIrr, s, cs) of - (True, Prop, _:_:_) -> setCurrentRange (getRange cons) $ + (True, Prop, _:_:_) -> setCurrentRange cons $ typeError PropMustBeSingleton _ -> return () @@ -193,8 +193,13 @@ -- | Type check a constructor declaration. Checks that the constructor targets -- the datatype and that it fits inside the declared sort. -- Returns the non-linear parameters. -checkConstructor :: QName -> Telescope -> Nat -> Sort - -> A.Constructor -> TCM [Int] +checkConstructor + :: QName -- ^ Name of data type. + -> Telescope -- ^ Parameter telescope. + -> Nat -- ^ Number of indices of the data type. + -> Sort -- ^ Sort of the data type. + -> A.Constructor -- ^ Constructor declaration (type signature). + -> TCM [Int] -- ^ Non-linear parameters. checkConstructor d tel nofIxs s (A.ScopedDecl scope [con]) = do setScope scope checkConstructor d tel nofIxs s con @@ -265,7 +270,7 @@ bindParameters :: [A.LamBinding] -> Type -> (Telescope -> Type -> TCM a) -> TCM a bindParameters [] a ret = ret EmptyTel a bindParameters (A.DomainFull (A.TypedBindings _ (Arg info (A.TBind _ xs _))) : bs) a ret = - bindParameters ([ A.DomainFree info x | x <- xs ] ++ bs) a ret + bindParameters (map (mergeHiding . fmap (A.DomainFree info)) xs ++ bs) a ret bindParameters (A.DomainFull (A.TypedBindings _ (Arg info (A.TLet _ lbs))) : bs) a ret = __IMPOSSIBLE__ bindParameters ps0@(A.DomainFree info x : ps) (El _ (Pi arg@(Dom info' a) b)) ret @@ -299,7 +304,8 @@ t <- reduce t case ignoreSharing $ unEl t of Pi dom b -> do - getSort (unDom dom) `leqSort` s + sa <- reduce $ getSort dom + unless (sa == SizeUniv) $ sa `leqSort` s addContext (absName b, dom) $ fitsIn (absBody b) (raise 1 s) _ -> return () -- getSort t `leqSort` s -- Andreas, 2013-04-13 not necessary since constructor type ends in data type diff --git a/src/full/Agda/TypeChecking/Rules/Decl.hs b/src/full/Agda/TypeChecking/Rules/Decl.hs --- a/src/full/Agda/TypeChecking/Rules/Decl.hs +++ b/src/full/Agda/TypeChecking/Rules/Decl.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.Rules.Decl where import Control.Monad @@ -28,17 +32,17 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Builtin -import Agda.TypeChecking.Monad.Benchmark (billTop, reimburseTop) import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion import Agda.TypeChecking.Errors import Agda.TypeChecking.Injectivity +import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.Positivity import Agda.TypeChecking.Polarity import Agda.TypeChecking.Pretty -import Agda.TypeChecking.Primitive hiding (Nat) +import Agda.TypeChecking.Primitive import Agda.TypeChecking.ProjectionLike import Agda.TypeChecking.Quote import Agda.TypeChecking.Records @@ -53,7 +57,7 @@ import Agda.TypeChecking.Rules.Data ( checkDataDef ) import Agda.TypeChecking.Rules.Record ( checkRecDef ) import Agda.TypeChecking.Rules.Def ( checkFunDef, useTerPragma ) -import Agda.TypeChecking.Rules.Builtin ( bindBuiltin ) +import Agda.TypeChecking.Rules.Builtin import Agda.Termination.TermCheck @@ -76,14 +80,14 @@ -- | Type check a single declaration. checkDecl :: A.Declaration -> TCM () -checkDecl d = traceCall (SetRange (getRange d)) $ do +checkDecl d = setCurrentRange d $ do reportSDoc "tc.decl" 10 $ vcat [ text "checking declaration" , prettyA d ] -- Issue 418 fix: freeze metas before checking an abstract thing - when isAbstract freezeMetas + when_ isAbstract freezeMetas let -- What kind of final checks/computations should be performed -- if we're not inside a mutual block? @@ -135,8 +139,7 @@ whenJust finalChecks $ \ theMutualChecks -> do solveSizeConstraints wakeupConstraints_ -- solve emptiness constraints - freezeMetas - + _ <- freezeMetas theMutualChecks where @@ -170,7 +173,11 @@ -- to avoid making the injectivity checker loop. checkTermination_ d checkPositivity_ names - checkCoinductiveRecords ds + -- Andreas, 2015-03-26 Issue 1470: + -- Restricting coinduction to recursive does not solve the + -- actual problem, and prevents interesting sound applications + -- of sized types. + -- checkCoinductiveRecords ds -- Andreas, 2012-09-11: Injectivity check stores clauses -- whose 'Relevance' is affected by polarity computation, -- so do it here. @@ -239,7 +246,7 @@ highlight_ :: A.Declaration -> TCM () highlight_ d = do let highlight d = generateAndPrintSyntaxInfo d Full - reimburseTop Bench.Typing $ billTop Bench.Highlighting $ case d of + Bench.billTo [Bench.Highlighting] $ case d of A.Axiom{} -> highlight d A.Field{} -> __IMPOSSIBLE__ A.Primitive{} -> highlight d @@ -270,7 +277,7 @@ -- | Termination check a declaration. checkTermination_ :: A.Declaration -> TCM () -checkTermination_ d = reimburseTop Bench.Typing $ billTop Bench.Termination $ do +checkTermination_ d = Bench.billTo [Bench.Termination] $ do reportSLn "tc.decl" 20 $ "checkDecl: checking termination..." whenM (optTerminationCheck <$> pragmaOptions) $ do case d of @@ -283,7 +290,7 @@ -- | Check a set of mutual names for positivity. checkPositivity_ :: Set QName -> TCM () -checkPositivity_ names = reimburseTop Bench.Typing $ billTop Bench.Positivity $ do +checkPositivity_ names = Bench.billTo [Bench.Positivity] $ do -- Positivity checking. reportSLn "tc.decl" 20 $ "checkDecl: checking positivity..." checkStrictlyPositive names @@ -309,14 +316,14 @@ -- for the old coinduction.) checkCoinductiveRecords :: [A.Declaration] -> TCM () checkCoinductiveRecords ds = forM_ ds $ \ d -> case d of - A.RecDef _ q (Just (Ranged r CoInductive)) _ _ _ _ -> traceCall (SetRange r) $ do + A.RecDef _ q (Just (Ranged r CoInductive)) _ _ _ _ -> setCurrentRange r $ do unlessM (isRecursiveRecord q) $ typeError $ GenericError $ "Only recursive records can be coinductive" _ -> return () -- | Check a set of mutual names for constructor-headedness. checkInjectivity_ :: Set QName -> TCM () -checkInjectivity_ names = reimburseTop Bench.Typing $ billTop Bench.Injectivity $ do +checkInjectivity_ names = Bench.billTo [Bench.Injectivity] $ do reportSLn "tc.decl" 20 $ "checkDecl: checking injectivity..." -- OLD CODE, REFACTORED using for-loop @@ -339,7 +346,7 @@ -- | Check a set of mutual names for projection likeness. checkProjectionLikeness_ :: Set QName -> TCM () -checkProjectionLikeness_ names = reimburseTop Bench.Typing $ billTop Bench.ProjectionLikeness $ do +checkProjectionLikeness_ names = Bench.billTo [Bench.ProjectionLikeness] $ do -- Non-mutual definitions can be considered for -- projection likeness reportSLn "tc.decl" 20 $ "checkDecl: checking projection-likeness..." @@ -359,11 +366,18 @@ rel <- max (getRelevance info0) <$> asks envRelevance let info = setRelevance rel $ convColor info0 -- rel <- ifM ((Irrelevant ==) <$> asks envRelevance) (return Irrelevant) (return rel0) - t <- isType_ e + t <- workOnTypes $ isType_ e reportSDoc "tc.decl.ax" 10 $ sep [ text $ "checked type signature" , nest 2 $ prettyTCM rel <> prettyTCM x <+> text ":" <+> prettyTCM t + , nest 2 $ text "of sort " <+> prettyTCM (getSort t) ] + -- Andreas, 2015-03-17 Issue 1428: Do not postulate sizes in parametrized + -- modules! + when (funSig == A.NoFunSig) $ do + whenM ((== SizeUniv) <$> do reduce $ getSort t) $ do + whenM ((> 0) <$> getContextSize) $ do + typeError $ GenericError $ "We don't like postulated sizes in parametrized modules." -- Not safe. See Issue 330 -- t <- addForcingAnnotations t addConstant x =<< do @@ -379,7 +393,7 @@ traceCall (IsType_ e) $ solveSizeConstraints -- need Range for error message -- Andreas, 2011-05-31, that freezing below is probably wrong: - -- when (Info.defAbstract i == AbstractDef) $ freezeMetas + -- when_ (Info.defAbstract i == AbstractDef) $ freezeMetas -- | Type check a primitive function declaration. checkPrimitive :: Info.DefInfo -> QName -> A.Expr -> TCM () @@ -399,6 +413,7 @@ checkPragma r p = traceCall (CheckPragma r p) $ case p of A.BuiltinPragma x e -> bindBuiltin x e + A.BuiltinNoDefPragma b x -> bindBuiltinNoDef b x A.RewritePragma q -> addRewriteRule q A.CompiledTypePragma x hs -> do def <- getConstInfo x @@ -534,7 +549,7 @@ -- | Type check a module. checkSection :: Info.ModuleInfo -> ModuleName -> A.Telescope -> [A.Declaration] -> TCM () checkSection i x tel ds = - checkTelescope_ tel $ \tel' -> do + checkTelescope tel $ \ tel' -> do addSection x (size tel') verboseS "tc.mod.check" 10 $ do dx <- prettyTCM x @@ -613,7 +628,7 @@ return (fv - mfv) when (extraParams > 0) $ reportSLn "tc.mod.apply" 30 $ "Extra parameters to " ++ show m1 ++ ": " ++ show extraParams -- Type-check the LHS (ptel) of the module macro. - checkTelescope_ ptel $ \ ptel -> do + checkTelescope ptel $ \ ptel -> do -- We are now in the context @ptel@. -- Get the correct parameter telescope of @m2@. tel <- lookupSection m2 diff --git a/src/full/Agda/TypeChecking/Rules/Def.hs b/src/full/Agda/TypeChecking/Rules/Def.hs --- a/src/full/Agda/TypeChecking/Rules/Def.hs +++ b/src/full/Agda/TypeChecking/Rules/Def.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Rules.Def where @@ -25,7 +25,6 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Builtin (primRefl, primEqualityName) -import Agda.TypeChecking.Monad.Benchmark (billTop, reimburseTop) import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Constraints @@ -45,7 +44,7 @@ import Agda.TypeChecking.CompiledClause (CompiledClauses(..)) import Agda.TypeChecking.CompiledClause.Compile -import Agda.TypeChecking.Rules.Term ( checkExpr, inferExpr, inferExprForWith, checkDontExpandLast, checkTelescope_, ConvColor(..) ) +import Agda.TypeChecking.Rules.Term ( checkExpr, inferExpr, inferExprForWith, checkDontExpandLast, checkTelescope, ConvColor(..) ) import Agda.TypeChecking.Rules.LHS ( checkLeftHandSide, LHSResult(..) ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl ( checkDecls ) @@ -219,7 +218,7 @@ -- Check if the function is injective reportSLn "tc.inj.def" 20 $ "checkFunDef': checking injectivity..." - inv <- reimburseTop Bench.Typing $ billTop Bench.Injectivity $ + inv <- Bench.billTo [Bench.Injectivity] $ checkInjectivity name cs -- inv <- return NotInjective @@ -232,7 +231,7 @@ addClauses name cs -- Coverage check and compile the clauses - cc <- reimburseTop Bench.Typing $ billTop Bench.Coverage $ + cc <- Bench.billTo [Bench.Coverage] $ compileClauses (Just (name, t)) cs reportSDoc "tc.cc" 10 $ do @@ -293,26 +292,26 @@ insertPatterns pats (A.WithRHS aux es cs) = A.WithRHS aux es (map insertToClause cs) where insertToClause (A.Clause (A.LHS i lhscore ps) rhs ds) = A.Clause (A.LHS i lhscore (pats ++ ps)) (insertPatterns pats rhs) ds -insertPatterns pats (A.RewriteRHS qs eqs rhs wh) = A.RewriteRHS qs eqs (insertPatterns pats rhs) wh +insertPatterns pats (A.RewriteRHS qes rhs wh) = A.RewriteRHS qes (insertPatterns pats rhs) wh insertPatterns pats rhs = rhs -- | Parameters for creating a @with@-function. data WithFunctionProblem = NoWithFunction | WithFunction - { wfParentName :: QName -- ^ parent function name - , wfName :: QName -- ^ with function name - , wfParentTel :: Telescope -- ^ arguments to parent function - , wfBeforeTel :: Telescope -- ^ arguments to the with function before the with expressions - , wfAfterTel :: Telescope -- ^ arguments to the with function after the with expressions - , wfExprs :: [Term] -- ^ with expressions - , wfExprTypes :: [Type] -- ^ types of the with expressions - , wfRHSType :: Type -- ^ type of the right hand side - , wfParentPats :: [I.NamedArg Pattern] -- ^ parent patterns - , wfPermSplit :: Permutation -- ^ permutation resulting from splitting the telescope into needed and unneeded vars - , wfPermParent :: Permutation -- ^ permutation reordering the variables in the parent pattern - , wfPermFinal :: Permutation -- ^ final permutation (including permutation for the parent clause) - , wfClauses :: [A.Clause] -- ^ the given clauses for the with function + { wfParentName :: QName -- ^ Parent function name. + , wfName :: QName -- ^ With function name. + , wfParentType :: Type -- ^ Type of the parent function. + , wfBeforeTel :: Telescope -- ^ Types of arguments to the with function before the with expressions (needed vars). + , wfAfterTel :: Telescope -- ^ Types of arguments to the with function after the with expressions (unneeded vars). + , wfExprs :: [Term] -- ^ With expressions. + , wfExprTypes :: [Type] -- ^ Types of the with expressions. + , wfRHSType :: Type -- ^ Type of the right hand side. + , wfParentPats :: [I.NamedArg Pattern] -- ^ Parent patterns. + , wfPermSplit :: Permutation -- ^ Permutation resulting from splitting the telescope into needed and unneeded vars. + , wfPermParent :: Permutation -- ^ Permutation reordering the variables in the parent pattern. + , wfPermFinal :: Permutation -- ^ Final permutation (including permutation for the parent clause). + , wfClauses :: [A.Clause] -- ^ The given clauses for the with function } -- | Type check a function clause. @@ -321,16 +320,25 @@ unless (null withPats) $ typeError $ UnexpectedWithPatterns withPats traceCall (CheckClause t c) $ do - aps <- (traverse . traverse . traverse) expandPatternSynonyms aps - checkLeftHandSide (CheckPatternShadowing c) (Just x) aps t $ \ (LHSResult mgamma delta sub xs ps trhs perm) -> do + aps <- expandPatternSynonyms aps + checkLeftHandSide (CheckPatternShadowing c) (Just x) aps t $ \ (LHSResult delta ps trhs perm) -> do -- Note that we might now be in irrelevant context, -- in case checkLeftHandSide walked over an irrelevant projection pattern. - let mkBody v = foldr (\x t -> Bind $ Abs x t) (Body $ applySubst sub v) xs + + -- As we will be type-checking the @rhs@ in @delta@, but the final + -- body should have bindings in the order of the pattern variables, + -- we need to apply the permutation to the checked rhs @v@. + let mkBody v = foldr (\ x t -> Bind $ Abs x t) b xs + where b = Body $ applySubst (renamingR perm) v + xs = [ stringToArgName $ "h" ++ show n + | n <- [0..permRange perm - 1] ] + -- introduce trailing implicits for checking the where decls TelV htel t0 <- telViewUpTo' (-1) (not . visible) $ unArg trhs let n = size htel aps' = convColor aps - (body, with) <- addCtxTel htel $ checkWhere (size delta + n) wh $ escapeContext (size htel) $ let + checkWhere' wh = addCtxTel htel . checkWhere (size delta + n) wh . escapeContext (size htel) + (body, with) <- checkWhere' wh $ let -- for the body, we remove the implicits again handleRHS rhs = case rhs of @@ -344,11 +352,12 @@ | any (containsAbsurdPattern . namedArg) aps -> return (NoBody, NoWithFunction) | otherwise -> typeError $ NoRHSRequiresAbsurdPattern aps' - A.RewriteRHS [] (_:_) _ _ -> __IMPOSSIBLE__ - A.RewriteRHS (_:_) [] _ _ -> __IMPOSSIBLE__ - A.RewriteRHS [] [] rhs [] -> handleRHS rhs - A.RewriteRHS [] [] _ (_:_) -> __IMPOSSIBLE__ - A.RewriteRHS (qname:names) (eq:eqs) rhs wh -> do + A.RewriteRHS [] rhs [] -> handleRHS rhs + -- Andreas, 2014-01-17, Issue 1402: + -- If the rewrites are discarded since lhs=rhs, then + -- we can actually have where clauses. + A.RewriteRHS [] rhs wh -> checkWhere' wh $ handleRHS rhs + A.RewriteRHS ((qname,eq):qes) rhs wh -> do -- Action for skipping this rewrite. -- We do not want to create unsolved metas in case of @@ -365,7 +374,7 @@ -- 3. and a large overall number of ?s. let sameIP = (==) `on` (^.stInteractionPoints) when (sameIP st st') $ put st - handleRHS $ A.RewriteRHS names eqs rhs wh + handleRHS $ A.RewriteRHS qes rhs wh -- Get value and type of rewrite-expression. @@ -391,7 +400,7 @@ return (El (getSort t') rewriteType, rewriteFrom, rewriteTo) _ -> do err <- text "Cannot rewrite by equation of type" <+> prettyTCM t' - typeError $ GenericError $ show err + typeError $ GenericDocError err -- Andreas, 2014-05-17 Issue 1110: -- Rewriting with a reflexive equation has no effect, but gives an @@ -410,11 +419,13 @@ let cinfo = ConPatInfo False patNoRange underscore = A.Underscore Info.emptyMetaInfo - (rewriteFromExpr,rewriteToExpr,rewriteTypeExpr, proofExpr) <- + -- Andreas, 2015-02-09 Issue 1421: kill ranges + -- as reify puts in ranges that may point to other files. + (rewriteFromExpr,rewriteToExpr,rewriteTypeExpr, proofExpr) <- killRange <$> do disableDisplayForms $ withShowAllArguments $ reify (rewriteFrom, rewriteTo, rewriteType , proof) let (inner, outer) -- the where clauses should go on the inner-most with - | null eqs = ([], wh) + | null qes = ([], wh) | otherwise = (wh, []) -- Andreas, 2014-03-05 kill range of copied patterns -- since they really do not have a source location. @@ -422,18 +433,18 @@ [A.Clause (A.LHS i (A.LHSHead x (killRange aps)) pats) -- Note: handleRHS (A.RewriteRHS _ eqs _ _) -- is defined by induction on eqs. - (A.RewriteRHS names eqs (insertPatterns pats rhs) inner) + (A.RewriteRHS qes (insertPatterns pats rhs) inner) outer] pats = [ A.DotP patNoRange underscore , A.ConP cinfo (AmbQ [conName reflCon]) []] reportSDoc "tc.rewrite.top" 25 $ vcat - [ text "rewrite" - , text " from = " <+> prettyTCM rewriteFromExpr - , text " to = " <+> prettyTCM rewriteToExpr - , text " typ = " <+> prettyTCM rewriteType - , text " proof = " <+> prettyTCM proofExpr - , text " equ = " <+> prettyTCM t' - ] + [ text "rewrite" + , text " from = " <+> prettyTCM rewriteFromExpr + , text " to = " <+> prettyTCM rewriteToExpr + , text " typ = " <+> prettyTCM rewriteType + , text " proof = " <+> prettyTCM proofExpr + , text " equ = " <+> prettyTCM t' + ] handleRHS newRhs A.WithRHS aux es cs -> do @@ -520,8 +531,7 @@ reportSDoc "tc.with.top" 20 $ text " body" <+> (addCtxTel delta $ prettyTCM $ mkBody v) - gamma <- maybe (typeError $ NotImplemented "with clauses for functions with unfolding arity") return mgamma - return (mkBody v, WithFunction x aux gamma delta1 delta2 vs as t' ps perm' perm finalPerm cs) + return (mkBody v, WithFunction x aux t delta1 delta2 vs as t' ps perm' perm finalPerm cs) in handleRHS rhs0 escapeContext (size delta) $ checkWithFunction with @@ -548,14 +558,14 @@ checkWithFunction :: WithFunctionProblem -> TCM () checkWithFunction NoWithFunction = return () -checkWithFunction (WithFunction f aux gamma delta1 delta2 vs as b qs perm' perm finalPerm cs) = do +checkWithFunction (WithFunction f aux t delta1 delta2 vs as b qs perm' perm finalPerm cs) = do reportSDoc "tc.with.top" 10 $ vcat [ text "checkWithFunction" , nest 2 $ vcat [ text "delta1 =" <+> prettyTCM delta1 , text "delta2 =" <+> addCtxTel delta1 (prettyTCM delta2) - , text "gamma =" <+> prettyTCM gamma + , text "t =" <+> prettyTCM t , text "as =" <+> addCtxTel delta1 (prettyTCM as) , text "vs =" <+> addCtxTel delta1 (prettyTCM vs) , text "b =" <+> do addCtxTel delta1 $ addCtxTel delta2 $ prettyTCM b @@ -597,7 +607,7 @@ , nest 2 $ text $ show absAuxType ] -- The ranges in the generated type are completely bogus, so we kill them. - auxType <- setCurrentRange (getRange cs) + auxType <- setCurrentRange cs (traceCall NoHighlighting $ -- To avoid flicker. isType_ $ killRange absAuxType) `catchError` \err -> case err of @@ -608,7 +618,7 @@ -- Check generated type directly in internal syntax. absAuxType <- reify candidateType let auxType = candidateType - setCurrentRange (getRange cs) + setCurrentRange cs (traceCall NoHighlighting $ -- To avoid flicker. checkType auxType) `catchError` \err -> case err of @@ -636,7 +646,7 @@ -- Construct the body for the with function cs <- return $ map (A.lhsToSpine) cs - cs <- buildWithFunction aux gamma qs finalPerm (size delta1) (size as) cs + cs <- buildWithFunction aux t qs finalPerm (size delta1) (size as) cs cs <- return $ map (A.spineToLhs) cs -- Check the with function @@ -651,7 +661,7 @@ checkWhere _ [] ret = ret checkWhere n [A.ScopedDecl scope ds] ret = withScope_ scope $ checkWhere n ds ret checkWhere n [A.Section _ m tel ds] ret = do - checkTelescope_ tel $ \tel' -> do + checkTelescope tel $ \ tel' -> do reportSDoc "tc.def.where" 10 $ text "adding section:" <+> prettyTCM m <+> text (show (size tel')) <+> text (show n) addSection m (size tel' + n) -- the variables bound in the lhs diff --git a/src/full/Agda/TypeChecking/Rules/LHS.hs b/src/full/Agda/TypeChecking/Rules/LHS.hs --- a/src/full/Agda/TypeChecking/Rules/LHS.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS.hs @@ -48,7 +48,9 @@ import Agda.TypeChecking.Rules.LHS.Instantiate import Agda.TypeChecking.Rules.Data +import Agda.Utils.Except (MonadError(..)) import Agda.Utils.Functor (($>)) +import Agda.Utils.ListT import Agda.Utils.Monad import Agda.Utils.Permutation import Agda.Utils.Size @@ -152,6 +154,7 @@ merge (Just qs) ps = zipWith mergeA qs ps where mergeA a1 a2 = fmap (mergeP (namedArg a1) (namedArg a2) <$) a1 + mergeP (DotP s) (DotP t) | s == t = DotP s | otherwise = __IMPOSSIBLE__ @@ -161,8 +164,9 @@ -- the rest is homomorphical mergeP (DotP _) _ = __IMPOSSIBLE__ mergeP _ (DotP _) = __IMPOSSIBLE__ - mergeP (ConP c1 mt1 ps) (ConP c2 mt2 qs) - | c1 == c2 = ConP (c1 `withRangeOf` c2) (mplus mt1 mt2) $ zipWith mergeA ps qs + mergeP (ConP c1 i1 ps) (ConP c2 i2 qs) + | c1 == c2 = ConP (c1 `withRangeOf` c2) (mergeCPI i1 i2) $ + zipWith mergeA ps qs | otherwise = __IMPOSSIBLE__ mergeP (LitP l1) (LitP l2) | l1 == l2 = LitP (l1 `withRangeOf` l2) @@ -182,7 +186,10 @@ mergeP ProjP{} _ = __IMPOSSIBLE__ mergeP _ ProjP{} = __IMPOSSIBLE__ + mergeCPI (ConPatternInfo mr1 mt1) (ConPatternInfo mr2 mt2) = + ConPatternInfo (mplus mr1 mr2) (mplus mt1 mt2) + -- | In an internal pattern, replace some pattern variables -- by dot patterns, according to the given substitution. instantiatePattern' @@ -244,7 +251,7 @@ let pat = map (snd . asView . namedArg) $ problemInPat problem tel = map (unEl . snd . unDom) $ telToList $ problemTel problem - zipWithM noShadowing pat tel -- TODO: does not work for flexible arity and projection patterns + zipWithM_ noShadowing pat tel -- TODO: does not work for flexible arity and projection patterns return () where noShadowing (A.WildP {}) t = return () @@ -270,7 +277,7 @@ Datatype { dataCons = cs } -> do case filter ((A.nameConcrete x ==) . A.nameConcrete . A.qnameName) cs of [] -> return () - (c : _) -> setCurrentRange (getRange x) $ + (c : _) -> setCurrentRange x $ typeError $ PatternShadowsConstructor x c Axiom {} -> return () Function {} -> return () @@ -361,27 +368,24 @@ ] addLetBinding defaultArgInfo x v a $ bindAsPatterns asb ret - +-- | Result of checking the LHS of a clause. data LHSResult = LHSResult - { lhsPatternTele :: Maybe Telescope -- ^ Γ: The types of the patterns. - -- 'Nothing' if more patterns than domain types in @a@. - -- Used only to construct a @with@ function; see 'stripwithClausePatterns'. - , lhsVarTele :: Telescope -- ^ Δ : The types of the pattern variables. - , lhsSubstitution :: S.Substitution -- ^ σ : The patterns in form of a substitution Δ ⊢ σ : Γ - , lhsVarNames :: [String] -- ^ Names for the variables in Δ, for binding the body. - , lhsPatterns :: [I.NamedArg Pattern] -- ^ The patterns in internal syntax. - , lhsBodyType :: I.Arg Type -- ^ The type of the body. Is @bσ@ if @Γ@ is defined. - -- 'Irrelevant' to indicate the rhs must be checked - -- in irrelevant mode. - , lhsPermutation :: Permutation -- ^ The permutation from pattern vars to @Δ@. + { lhsVarTele :: Telescope + -- ^ Δ : The types of the pattern variables, in internal dependency order. + -- Corresponds to 'clauseTel'. + , lhsPatterns :: [I.NamedArg Pattern] + -- ^ The patterns in internal syntax. + , lhsBodyType :: I.Arg Type + -- ^ The type of the body. Is @bσ@ if @Γ@ is defined. + -- 'Irrelevant' to indicate the rhs must be checked in irrelevant mode. + , lhsPermutation :: Permutation + -- ^ The permutation from pattern vars to @Δ@. + -- Corresponds to 'clausePerm'. } instance InstantiateFull LHSResult where - instantiateFull' (LHSResult mtel tel sub xs ps t perm) = LHSResult - <$> instantiateFull' mtel - <*> instantiateFull' tel - <*> instantiateFull' sub - <*> return xs + instantiateFull' (LHSResult tel ps t perm) = LHSResult + <$> instantiateFull' tel <*> instantiateFull' ps <*> instantiateFull' t <*> return perm @@ -409,7 +413,6 @@ -- Andreas, 2013-03-15 deactivating the following test allows -- flexible arity -- unless (noProblemRest problem) $ typeError $ TooManyArgumentsInLHS a - let mgamma = if noProblemRest problem0 then Just $ problemTel problem0 else Nothing -- doing the splits: LHSState problem@(Problem ps (perm, qs) delta rest) sigma dpi asb @@ -441,9 +444,7 @@ -- Check dot patterns mapM_ checkDotPattern dpi - let rho = renamingR perm -- I'm not certain about this... - xs = [ stringToArgName $ "h" ++ show n | n <- [0..permRange perm - 1] ] - lhsResult <- return $ LHSResult mgamma delta rho xs qs b' perm + lhsResult <- return $ LHSResult delta qs b' perm applyRelevanceToContext (getRelevance b') $ ret lhsResult -- | The loop (tail-recursive): split at a variable in the problem until problem is solved @@ -461,18 +462,17 @@ unlessM (optPatternMatching <$> gets getPragmaOptions) $ typeError $ GenericError $ "Pattern matching is disabled" - sp <- splitProblem f problem + sp <- runListT $ splitProblem f problem reportSDoc "tc.lhs.split" 20 $ text "splitting completed" - case sp of - Left NothingToSplit -> do + foldListT trySplit nothingToSplit $ ListT $ return sp + where + + nothingToSplit = do reportSLn "tc.lhs.split" 50 $ "checkLHS: nothing to split in problem " ++ show problem nothingToSplitError problem - Left (SplitPanic err) -> do - reportSLn "impossible" 10 $ "checkLHS: panic: " ++ err - __IMPOSSIBLE__ -- Split problem rest (projection pattern) - Right (SplitRest projPat projType) -> do + trySplit (SplitRest projPat projType) _ = do -- Compute the new problem let Problem ps1 (iperm, ip) delta (ProblemRest (p:ps2) b) = problem @@ -489,7 +489,7 @@ checkLHS f st' -- Split on literal pattern - Right (Split p0 xs (Arg _ (LitFocus lit iph hix a)) p1) -> do + trySplit (Split p0 xs (Arg _ (LitFocus lit iph hix a)) p1) _ = do -- plug the hole with a lit pattern let ip = plugHole (LitP lit) iph @@ -517,8 +517,33 @@ checkLHS f st' -- Split on constructor pattern - Right (Split p0 xs (Arg info - ( Focus { focusCon = c + + trySplit (Split p0 xs focus@(Arg info Focus{}) p1) tryNextSplit = do + res <- trySplitConstructor p0 xs focus p1 + case res of + -- Success. Continue checking LHS. + Unifies st' -> checkLHS f st' + -- Mismatch. Report and abort. + NoUnify tcerr -> throwError tcerr + -- Unclear situation. Try next split. + -- If no split works, give error from first split. + -- This is conservative, but might not be the best behavior. + -- It might be better to collect all the errors and print all of them. + DontKnow tcerr -> tryNextSplit `catchError` \ _ -> throwError tcerr + + whenUnifies + :: UnificationResult' a + -> (a -> TCM (UnificationResult' b)) + -> TCM (UnificationResult' b) + whenUnifies res cont = do + case res of + Unifies a -> cont a + NoUnify tcerr -> return $ NoUnify tcerr + DontKnow tcerr -> return $ DontKnow tcerr + + trySplitConstructor p0 xs (Arg info LitFocus{}) p1 = __IMPOSSIBLE__ + trySplitConstructor p0 xs (Arg info + (Focus { focusCon = c , focusImplicit = impl , focusConArgs = qs , focusRange = r @@ -529,8 +554,8 @@ , focusIndices = ws , focusType = a } - )) p1 - ) -> traceCall (CheckPattern (A.ConP (ConPatInfo impl $ PatRange r) (A.AmbQ [c]) qs) + )) p1 = do + traceCall (CheckPattern (A.ConP (ConPatInfo impl $ PatRange r) (A.AmbQ [c]) qs) (problemTel p0) (El Prop $ Def d $ map Apply $ vs ++ ws)) $ do @@ -553,11 +578,6 @@ ] ] -{- - c <- conSrcCon . theDef <$> getConstInfo c - Con c' [] <- ignoreSharing <$> (constructorForm =<< normalise (Con c [])) - c <- return $ c' `withRangeOf` c --} c <- (`withRangeOf` c) <$> getConForm c ca <- defType <$> getConInfo c @@ -584,8 +604,7 @@ -- ] -- Andreas 2010-09-07 propagate relevance info to new vars - -- Andreas 2014-11-25 clear 'Forced' and 'Unused' - let updRel = ignoreForced . composeRelevance (getRelevance info) + let updRel = composeRelevance (getRelevance info) gamma' <- return $ mapRelevance updRel <$> gamma' -- Insert implicit patterns @@ -619,13 +638,18 @@ ] -- Unify constructor target and given type (in Δ₁Γ) - sub0 <- addCtxTel (delta1 `abstract` gamma) $ - unifyIndices_ flex (raise (size gamma) da) us' (raise (size gamma) ws) + res <- addCtxTel (delta1 `abstract` gamma) $ + unifyIndices flex (raise (size gamma) da) us' (raise (size gamma) ws) + whenUnifies res $ \ sub0 -> do + -- Andreas 2014-11-25 clear 'Forced' and 'Unused' + -- Andreas 2015-01-19 ... only after unification + gamma <- return $ mapRelevance ignoreForced <$> gamma + -- We should substitute c ys for x in Δ₂ and sigma let ys = teleArgs gamma delta2 = absApp (raise (size gamma) $ fmap problemTel p1) (Con c ys) - rho0 = liftS (size delta2) $ Con c ys :# raiseS (size gamma) + rho0 = liftS (size delta2) $ consS (Con c ys) $ raiseS (size gamma) -- rho0 = [ var i | i <- [0..size delta2 - 1] ] -- ++ [ raise (size delta2) $ Con c ys ] -- ++ [ var i | i <- [size delta2 + size gamma ..] ] @@ -644,18 +668,19 @@ , text "asb0 = " <+> brackets (fsep $ punctuate comma $ map prettyTCM asb0) ] - -- Andreas, 2010-09-09, save the type a of record pattern. + -- Andreas, 2010-09-09, save the type. -- It is relative to delta1, but it should be relative to -- all variables which will be bound by patterns. -- Thus, it has to be raised by 1 (the "hole" variable) -- plus the length of delta2 (the variables coming after the hole). - storedPatternType <- ifM (isJust <$> isRecord d) - (return $ Just (impl, raise (1 + size delta2) typeOfSplitVar)) - (return $ Nothing) + let storedPatternType = raise (1 + size delta2) typeOfSplitVar + -- Also remember if we are a record pattern and from an implicit pattern. + isRec <- isRecord d + let cpi = ConPatternInfo (isRec $> impl) (Just storedPatternType) -- Plug the hole in the out pattern with c ys let ysp = map (argFromDom . fmap (namedVarP . fst)) $ telToList gamma - ip = plugHole (ConP c storedPatternType ysp) iph + ip = plugHole (ConP c cpi ysp) iph ip0 = applySubst rho0 ip -- Δ₁Γ ⊢ sub0, we need something in Δ₁ΓΔ₂ @@ -768,8 +793,7 @@ , text "iperm' =" <+> text (show iperm') ] ] - -- Continue splitting - checkLHS f st' + return $ Unifies st' -- | Ensures that we are not performing pattern matching on codata. diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs b/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Rules.LHS.Implicit where @@ -10,6 +10,7 @@ import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Internal as I +import Agda.Syntax.Abstract (IsProjP(..)) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Translation.InternalToAbstract (reify) @@ -23,6 +24,7 @@ import Agda.TypeChecking.Rules.LHS.Problem +import Agda.Utils.Function import Agda.Utils.Maybe #include "undefined.h" @@ -86,6 +88,13 @@ insertImplicitPatternsT DontExpandLast [] a = return [] insertImplicitPatternsT exh ps a = do TelV tel b <- telViewUpTo' (-1) (not . visible) a + reportSDoc "tc.lhs.imp" 20 $ + sep [ text "insertImplicitPatternsT" + , nest 2 $ text "ps = " <+> do + brackets $ fsep $ punctuate comma $ map prettyA ps + , nest 2 $ text "tel = " <+> prettyTCM tel + , nest 2 $ text "b = " <+> prettyTCM b + ] case ps of [] -> do i <- insImp dummy tel @@ -94,7 +103,11 @@ Just hs -> return hs Nothing -> return [] p : ps -> do - i <- insImp p tel + -- Andreas, 2015-05-11. + -- If p is a projection pattern, make it visible for the purpose of + -- calling insImp / insertImplicit, to get correct behavior. + let p' = applyWhen (isJust $ isProjP p) (setHiding NotHidden) p + i <- insImp p' tel case i of Just [] -> __IMPOSSIBLE__ Just hs -> insertImplicitPatternsT exh (hs ++ p : ps) (telePi tel b) @@ -106,12 +119,13 @@ (p :) <$> insertImplicitPatternsT exh ps (absBody b) _ -> return (p : ps) where - dummy = defaultNamedArg () + dummy = defaultNamedArg (A.VarP __IMPOSSIBLE__) - insImp x EmptyTel - | visible x = return Nothing - | otherwise = typeError WrongHidingInLHS - insImp x tel = case insertImplicit x $ map (argFromDom . fmap fst) $ telToList tel of + insImp p EmptyTel + | visible p = return Nothing + | isJust (isProjP p) = __IMPOSSIBLE__ + | otherwise = typeError WrongHidingInLHS + insImp p tel = case insertImplicit p $ map (argFromDom . fmap fst) $ telToList tel of BadImplicits -> typeError WrongHidingInLHS NoSuchName x -> typeError WrongHidingInLHS ImpInsert n -> return $ Just (map implicitArg n) diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs b/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Instantiate.hs @@ -155,8 +155,8 @@ mkSubst :: [Maybe Term] -> S.Substitution mkSubst s = rho 0 s' where s' = s - rho i (Nothing : s) = var i :# rho (i + 1) s - rho i (Just u : s) = u :# rho i s + rho i (Nothing : s) = consS (var i) $ rho (i + 1) s + rho i (Just u : s) = consS u $ rho i s rho i [] = raiseS i -- | Produce a nice error message when splitting failed diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs b/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Problem.hs @@ -1,6 +1,6 @@ -- {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,7 +8,7 @@ import Prelude hiding (null) -import Data.Foldable +import Data.Foldable ( Foldable ) import Data.Traversable import Agda.Syntax.Common @@ -19,7 +19,7 @@ import qualified Agda.Syntax.Abstract as A import Agda.TypeChecking.Substitute as S -import Agda.TypeChecking.Pretty hiding (empty) +import Agda.TypeChecking.Pretty import Agda.Utils.Except ( Error(noMsg, strMsg) ) import Agda.Utils.Null @@ -165,11 +165,6 @@ consProblem' (Problem ps () tel pr) = Problem (p:ps) () (ExtendTel dom $ Abs x tel) pr -data SplitError - = NothingToSplit - | SplitPanic String - -- ^ __IMPOSSIBLE__, only there to make this instance of 'Error'. - data DotPatternInst = DPI A.Expr Term (I.Dom Type) data AsBinding = AsB Name Term Type @@ -206,10 +201,6 @@ sep [ prettyTCM x <> text "@" <> parens (prettyTCM v) , nest 2 $ text ":" <+> prettyTCM a ] - -instance Error SplitError where - noMsg = NothingToSplit - strMsg = SplitPanic instance Null ProblemRest where null = null . restPats diff --git a/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs b/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + TupleSections #-} module Agda.TypeChecking.Rules.LHS.ProblemRest where diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Split.hs b/src/full/Agda/TypeChecking/Rules/LHS/Split.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Split.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Split.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} module Agda.TypeChecking.Rules.LHS.Split @@ -10,6 +10,7 @@ import Control.Applicative hiding (empty) import Control.Monad.Trans ( lift ) +import Control.Monad.Trans.Maybe import Data.Maybe (fromMaybe) import Data.List hiding (null) @@ -28,7 +29,7 @@ import Agda.Syntax.Abstract.Views (asView) import qualified Agda.Syntax.Info as A -import Agda.TypeChecking.Monad hiding (SplitError) +import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Constraints @@ -38,21 +39,16 @@ import Agda.TypeChecking.Irrelevance import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Patterns.Abstract -import Agda.TypeChecking.Pretty hiding (empty) +import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Rules.LHS.Problem -import Agda.Utils.Except - ( ExceptT - , MonadError(throwError) - , runExceptT - ) - import Agda.Utils.Functor ((<.>)) import Agda.Utils.List +import Agda.Utils.ListT import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null @@ -75,8 +71,9 @@ splitProblem :: Maybe QName -- ^ The definition we are checking at the moment. -> Problem -- ^ The current state of the lhs patterns. - -> TCM (Either SplitError SplitProblem) + -> ListT TCM SplitProblem splitProblem mf (Problem ps (perm, qs) tel pr) = do + lift $ do reportSLn "tc.lhs.split" 20 $ "initiating splitting" ++ maybe "" ((" for definition " ++) . show) mf reportSDoc "tc.lhs.split" 30 $ sep @@ -85,15 +82,17 @@ , nest 2 $ text "perm =" <+> prettyTCM perm , nest 2 $ text "tel =" <+> prettyTCM tel ] - runExceptT $ - splitP ps (permute perm $ zip [0..] $ allHoles qs) tel + splitP ps (permute perm $ zip [0..] $ allHoles qs) tel where -- Result splitting - splitRest :: ProblemRest -> ExceptT SplitError TCM SplitProblem + splitRest :: ProblemRest -> ListT TCM SplitProblem splitRest (ProblemRest (p : ps) b) | Just f <- mf = do - let failure = lift $ typeError $ CannotEliminateWithPattern p $ unArg b - notProjP = lift $ typeError $ NotAProjectionPattern p + let failure = typeError $ CannotEliminateWithPattern p $ unArg b + notProjP = typeError $ NotAProjectionPattern p notRecord = failure -- lift $ typeError $ ShouldBeRecordType $ unArg b + wrongHiding :: MonadTCM tcm => QName -> tcm a + wrongHiding d = typeError . GenericDocError =<< do + liftTCM $ text "Wrong hiding used for projection " <+> prettyTCM d lift $ reportSDoc "tc.lhs.split" 20 $ sep [ text "splitting problem rest" , nest 2 $ text "pattern p =" <+> prettyA p @@ -103,13 +102,15 @@ -- Probably then there were too many arguments. caseMaybe (isProjP p) failure $ \ d -> do -- So it is a projection pattern (d = projection name), is it? - caseMaybeM (lift $ isProjection d) notProjP $ \p -> case p of - Projection{projProper = Nothing} -> __IMPOSSIBLE__ - Projection{projProper = Just d, projFromType = _, projIndex = n} -> do + caseMaybeM (lift $ isProjection d) notProjP $ \ proj -> case proj of + -- Andreas, 2015-05-06 issue 1413 projProper=Nothing is not impossible + Projection{projProper = Nothing} -> notProjP + Projection{projProper = Just d, projIndex = n, projArgInfo = ai} -> do -- If projIndex==0, then the projection is already applied -- to the record value (like in @open R r@), and then it -- is no longer a projection but a record field. unless (n > 0) notProjP + unless (getHiding p == getHiding ai) $ wrongHiding d lift $ reportSLn "tc.lhs.split" 90 "we are a projection pattern" -- If the target is not a record type, that's an error. -- It could be a meta, but since we cannot postpone lhs checking, we crash here. @@ -138,7 +139,7 @@ return $ SplitRest argd $ dType `apply` (vs ++ [self]) _ -> __IMPOSSIBLE__ -- if there are no more patterns left in the problem rest, there is nothing to split: - splitRest _ = throwError $ NothingToSplit + splitRest _ = mzero -- | In @splitP aps iqs tel@, -- @aps@ are the user patterns on which we are splitting (inPats), @@ -148,7 +149,7 @@ splitP :: [A.NamedArg A.Pattern] -> [(Int, OneHolePatterns)] -> Telescope - -> ExceptT SplitError TCM SplitProblem + -> ListT TCM SplitProblem -- the next two cases violate the one-to-one correspondence of qs and tel splitP _ [] (ExtendTel _ _) = __IMPOSSIBLE__ @@ -198,12 +199,13 @@ -- Succeed if the split type is (already) equal to the type of the literal. ifNotM (lift $ tryConversion $ equalType a =<< litType lit) {- then -} keepGoing $ - {- else -} return $ Split + {- else -} return Split { splitLPats = empty , splitAsNames = xs , splitFocus = Arg ai $ LitFocus lit q i a , splitRPats = Abs x $ Problem ps () tel __IMPOSSIBLE__ } + `mplus` keepGoing -- Case: constructor pattern. (xs, p@(A.ConP ci (A.AmbQ cs) args)) -> do @@ -245,9 +247,9 @@ Nothing -> keepGoing Just np -> do let vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es - liftTCM $ traceCall (CheckPattern p EmptyTel a) $ do -- TODO: wrong telescope + traceCall (CheckPattern p EmptyTel a) $ do -- TODO: wrong telescope -- Check that we construct something in the right datatype - c <- do + c <- lift $ do cs' <- mapM canonicalName cs d' <- canonicalName d let cons def = case theDef def of @@ -266,7 +268,7 @@ typeError $ CantResolveOverloadedConstructorsTargetingSameDatatype d cs let (pars, ixs) = genericSplitAt np vs - reportSDoc "tc.lhs.split" 10 $ vcat + lift $ reportSDoc "tc.lhs.split" 10 $ vcat [ sep [ text "splitting on" , nest 2 $ fsep [ prettyA p, text ":", prettyTCM dom ] ] @@ -286,12 +288,12 @@ -- but the extra check here is non-invasive to the existing code. checkParsIfUnambiguous cs d pars - return $ Split + (return Split { splitLPats = empty , splitAsNames = xs , splitFocus = Arg ai $ Focus c (A.patImplicit ci) args (getRange p) q i d pars ixs a , splitRPats = Abs x $ Problem ps () tel __IMPOSSIBLE__ - } + }) `mplus` keepGoing -- Subcase: split type is not a Def. _ -> keepGoing @@ -302,8 +304,8 @@ -- | @checkParsIfUnambiguous [c] d pars@ checks that the data/record type -- behind @c@ is has initial parameters (coming e.g. from a module instantiation) -- that coincide with an prefix of @pars@. -checkParsIfUnambiguous :: [QName] -> QName -> Args -> TCM () -checkParsIfUnambiguous [c] d pars = do +checkParsIfUnambiguous :: MonadTCM tcm => [QName] -> QName -> Args -> tcm () +checkParsIfUnambiguous [c] d pars = liftTCM $ do dc <- getConstructorData c a <- reduce (Def dc []) case ignoreSharing a of diff --git a/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs b/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs --- a/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs +++ b/src/full/Agda/TypeChecking/Rules/LHS/Unify.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} module Agda.TypeChecking.Rules.LHS.Unify where @@ -42,11 +41,11 @@ import Agda.TypeChecking.Monad.Builtin (constructorForm) import Agda.TypeChecking.Conversion -- equalTerm import Agda.TypeChecking.Constraints +import Agda.TypeChecking.Datatypes import Agda.TypeChecking.DropArgs import Agda.TypeChecking.Level (reallyUnLevelView) import Agda.TypeChecking.Reduce -import Agda.TypeChecking.Pretty hiding (empty) -import qualified Agda.TypeChecking.Pretty as P +import Agda.TypeChecking.Pretty import Agda.TypeChecking.Substitute hiding (Substitution) import qualified Agda.TypeChecking.Substitute as S import Agda.TypeChecking.Telescope @@ -63,7 +62,7 @@ ( Error(noMsg, strMsg) , MonadError(catchError, throwError) ) - +import Agda.Utils.Either import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null @@ -72,9 +71,24 @@ #include "undefined.h" import Agda.Utils.Impossible -newtype Unify a = U { unUnify :: ReaderT UnifyEnv (WriterT UnifyOutput (ExceptionT UnifyException (StateT UnifyState TCM))) a } - deriving (Monad, MonadIO, Functor, Applicative, MonadException UnifyException, MonadWriter UnifyOutput) +-- | Result of 'unifyIndices'. +type UnificationResult = UnificationResult' Substitution +data UnificationResult' a + = Unifies a -- ^ Unification succeeded. + | NoUnify TCErr -- ^ Terms are not unifiable. + | DontKnow TCErr -- ^ Some other error happened, unification got stuck. + deriving (Typeable, Show, Functor, Foldable, Traversable) + +-- | Monad for unification. +newtype Unify a = U { unUnify :: + ReaderT UnifyEnv ( + WriterT UnifyOutput ( + ExceptionT UnifyException ( + StateT UnifyState TCM))) a + } deriving ( Monad, MonadIO, Functor, Applicative + , MonadException UnifyException, MonadWriter UnifyOutput) + instance MonadTCM Unify where liftTCM = U . lift . lift . lift . lift @@ -163,8 +177,24 @@ constructorMismatch a u v = throwException $ ConstructorMismatch a u v constructorMismatchHH :: TypeHH -> Term -> Term -> Unify a -constructorMismatchHH aHH = constructorMismatch (leftHH aHH) - -- do not report heterogenity +constructorMismatchHH aHH u v = do + ifM (liftTCM fullyApplied `and2M` canCompare aHH) + {- then -} (constructorMismatch (leftHH aHH) u v) -- do not report heterogenity + {- else -} (throwException (UnclearOccurrence (leftHH aHH) u v)) + where + -- Comparing constructors at different types is incompatible with univalence + canCompare (Het s t) = ifM (liftTCM $ optWithoutK <$> pragmaOptions) + (liftTCM $ tryConversion $ equalType s t) -- no constraints left + (return True) + canCompare Hom{} = return True + -- Issue 1497: only fully applied constructors can mismatch + fullyApplied = case (ignoreSharing u, ignoreSharing v) of + (Con c us, Con d vs) -> do + when (c == d) __IMPOSSIBLE__ + car <- fromLeft length <$> getConstructorArity (conName c) + dar <- fromLeft length <$> getConstructorArity (conName d) + return $ length us == car && length vs == dar + _ -> return True -- could be literals instance Subst Equality where applySubst rho (Equal a s t) = @@ -221,6 +251,13 @@ makeHom :: TypeHH -> TCM (Maybe Type) makeHom aHH = (Just <$> forceHom aHH) `catchError` \ err -> return Nothing +-- | Try to make a possibly heterogeneous term situation homogeneous. +tryHom :: TypeHH -> Term -> Term -> TCM TermHH +tryHom aHH u v = do + a <- forceHom aHH + Hom u <$ checkEquality a u v + `catchError` \ err -> return $ Het u v + addEquality :: Type -> Term -> Term -> Unify () addEquality a = addEqualityHH (Hom a) @@ -348,12 +385,7 @@ -- @inst i u v@ replaces index @i@ in @v@ by @u@, without removing the index. inst :: Nat -> Term -> Term -> Term inst i u v = applySubst us v - where us = [var j | j <- [0..i - 1] ] ++# u :# raiseS (i + 1) - -data UnificationResult - = Unifies Substitution - | NoUnify Type Term Term - | DontKnow TCErr + where us = [ var j | j <- [0..i - 1] ] ++# consS u (raiseS $ i + 1) -- | Are we in a homogeneous (one type) or heterogeneous (two types) situation? data HomHet a @@ -472,7 +504,7 @@ case r of Unifies sub -> return sub DontKnow err -> throwError err - NoUnify a u v -> typeError $ UnequalTerms CmpEq u v a + NoUnify err -> throwError err unifyIndices :: MonadTCM tcm => FlexibleVars -> Type -> Args -> Args -> tcm UnificationResult unifyIndices flex a us vs = liftTCM $ do @@ -493,9 +525,9 @@ recheckEqualities case r of - Left (ConstructorMismatch a u v) -> return $ NoUnify a u v + Left (ConstructorMismatch a u v) -> noUnify a u v -- Andreas 2011-04-14: - Left (StronglyRigidOccurrence a u v) -> return $ NoUnify a u v + Left (StronglyRigidOccurrence a u v) -> noUnify a u v Left (UnclearOccurrence a u v) -> typeError $ UnequalTerms CmpEq u v a Left (WithoutKException a u v) -> typeError $ WithoutKError a u v Left (GenericUnifyException err) -> typeError $ GenericError err @@ -507,6 +539,8 @@ TypeError _ (Closure {clValue = WithoutKError{}}) -> throwError err _ -> return $ DontKnow err where + noUnify a u v = NoUnify <$> do typeError_ $ UnequalTerms CmpEq u v a + flex' = map flexVar flex flexible i = i `elem` flex' findFlexible i = find ((i ==) . flexVar) flex @@ -561,7 +595,7 @@ -- , nest 2 $ parens (prettyTCM tel0) , nest 2 $ prettyList $ map prettyTCM us0 , nest 2 $ prettyList $ map prettyTCM vs0 - , nest 2 $ text "at telescope" <+> prettyTCM bHH <+> text "..." + , nest 2 $ text "at telescope" <+> prettyTCM bHH <+> text ("(" ++ show (getRelevance a) ++ ") ...") ] liftTCM $ reportSDoc "tc.lhs.unify" 25 $ (text $ "tel0 = " ++ show tel0) @@ -571,7 +605,11 @@ -- in case of dependent function type, we cannot postpone -- unification of u and v, otherwise us or vs might be ill-typed -- skip irrelevant parts - uHH <- if isIrrelevant a then return $ Hom u else + uHH <- if getRelevance a == Irrelevant then return $ Hom u else + -- Andreas, 2015-01-19 Forced constructor arguments are not unified. + -- Andreas, 2015-02-26 Restricting this to big forced arguments; + -- this still addresses issue 1406. + if getRelevance a == Forced Big then liftTCM $ tryHom bHH u v else ifClean (unifyHH bHH u v) (return $ Hom u) (return $ Het u v) liftTCM $ reportSDoc "tc.lhs.unify" 25 $ @@ -755,9 +793,9 @@ liftTCM $ reportSDoc "tc.lhs.unify" 15 $ sep [ text "unifyAtom" - , nest 2 $ prettyTCM u <> if flexibleTerm u then text " (flexible)" else P.empty + , nest 2 $ prettyTCM u <> if flexibleTerm u then text " (flexible)" else empty , nest 2 $ text "=?=" - , nest 2 $ prettyTCM v <> if flexibleTerm v then text " (flexible)" else P.empty + , nest 2 $ prettyTCM v <> if flexibleTerm v then text " (flexible)" else empty , nest 2 $ text ":" <+> prettyTCM aHH ] liftTCM $ reportSDoc "tc.lhs.unify" 60 $ @@ -793,18 +831,18 @@ | c == c' -> do r <- liftTCM (dataOrRecordTypeHH' c aHH) case r of - Just (d, bHH) -> do - bHH <- ureduce bHH + Just (d, b, parsIxsHH) -> do + (b, parsIxsHH) <- ureduce (b, parsIxsHH) -- Jesper, 2014-05-03: When --without-K is enabled, we reconstruct -- datatype indices and unify them as well withoutKEnabled <- liftTCM $ optWithoutK <$> pragmaOptions - when withoutKEnabled (do + when withoutKEnabled $ do def <- liftTCM $ getConstInfo d - let parsHH = fmap (\(b, pars, ixs) -> pars) bHH - ixsHH = fmap (\(b, pars, ixs) -> ixs) bHH - dtypeHH = (defType def) `applyHH` parsHH - unifyConstructorArgs dtypeHH (leftHH ixsHH) (rightHH ixsHH)) - let a'HH = fmap (\(b, pars, _) -> b `apply` pars) bHH + let parsHH = fst <$> parsIxsHH + ixsHH = snd <$> parsIxsHH + dtypeHH = defType def `applyHH` parsHH + unifyConstructorArgs dtypeHH (leftHH ixsHH) (rightHH ixsHH) + let a'HH = (b `apply`) . fst <$> parsIxsHH unifyConstructorArgs a'HH us vs Nothing -> checkEqualityHH aHH u v | otherwise -> constructorMismatchHH aHH u v @@ -989,22 +1027,24 @@ dataOrRecordTypeHH' :: ConHead -> TypeHH - -> TCM (Maybe (QName, HomHet (Type, Args, Args))) + -> TCM (Maybe (QName, Type, HomHet (Args, Args))) dataOrRecordTypeHH' c (Hom a) = do r <- dataOrRecordType' c a case r of - Just (d, a', pars, ixs) -> return $ Just (d, Hom (a', pars, ixs)) + Just (d, a', pars, ixs) -> return $ Just (d, a', Hom (pars, ixs)) Nothing -> return $ Nothing dataOrRecordTypeHH' c (Het a1 a2) = do r1 <- dataOrRecordType' c a1 r2 <- dataOrRecordType' c a2 - return $ case (r1, r2) of - -- TODO: We should always have b1 == b2, check/force this in some way? - (Just (d1, b1, pars1, ixs1), Just (d2, b2, pars2, ixs2)) | d1 == d2 -> Just $ + case (r1, r2) of + (Just (d1, b1, pars1, ixs1), Just (d2, b2, pars2, ixs2)) | d1 == d2 -> do + -- Same constructors have same types, of course. + unless (b1 == b2) __IMPOSSIBLE__ + return $ Just $ if null pars1 && null pars2 && null ixs1 && null ixs2 - then (d1, Hom (b1, [], [])) - else (d1, Het (b1, pars1, ixs1) (b2, pars2, ixs2)) - _ -> Nothing + then (d1, b1, Hom ([], [])) + else (d1, b1, Het (pars1, ixs1) (pars2, ixs2)) + _ -> return Nothing -- | Return record type identifier if argument is a record type. diff --git a/src/full/Agda/TypeChecking/Rules/Record.hs b/src/full/Agda/TypeChecking/Rules/Record.hs --- a/src/full/Agda/TypeChecking/Rules/Record.hs +++ b/src/full/Agda/TypeChecking/Rules/Record.hs @@ -62,7 +62,7 @@ -> [A.Field] -- ^ Field signatures. -> TCM () checkRecDef i name ind con ps contel fields = - traceCall (CheckRecDef (getRange i) (qnameName name) ps fields) $ do + traceCall (CheckRecDef (getRange name) (qnameName name) ps fields) $ do reportSDoc "tc.rec" 10 $ vcat [ text "checking record def" <+> prettyTCM name , nest 2 $ text "ps =" <+> prettyList (map prettyAs ps) @@ -169,8 +169,7 @@ addNamedInstance conName name -- Check that the fields fit inside the sort - let dummy = Sort Prop -- We're only interested in the sort here - telePi ftel (El (raise (size ftel) s) dummy) `fitsIn` s + contype `fitsIn` s {- Andreas, 2011-04-27 WRONG because field types are checked again and then non-stricts should not yet be irrelevant @@ -369,8 +368,8 @@ -- (rt) which should be R ptel (ptel,[rt]) = splitAt (size tel - 1) $ telToList tel projArgI = domInfo rt - conp = defaultArg - $ ConP con (Just (False, argFromDom $ fmap snd rt)) + cpi = ConPatternInfo (Just False) (Just $ argFromDom $ fmap snd rt) + conp = defaultArg $ ConP con cpi $ [ Arg info $ unnamed $ VarP "x" | Dom info _ <- telToList ftel ] nobind 0 = id nobind n = Bind . Abs "_" . nobind (n - 1) @@ -379,7 +378,7 @@ $ nobind (size ftel2) $ Body $ bodyMod $ var (size ftel2) cltel = ftel - clause = Clause { clauseRange = getRange info + clause = Clause { clauseRange = getRange info , clauseTel = killRange cltel , clausePerm = idP $ size ftel , namedClausePats = [Named Nothing <$> conp] diff --git a/src/full/Agda/TypeChecking/Rules/Term.hs b/src/full/Agda/TypeChecking/Rules/Term.hs --- a/src/full/Agda/TypeChecking/Rules/Term.hs +++ b/src/full/Agda/TypeChecking/Rules/Term.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.Rules.Term where import Control.Applicative @@ -13,6 +17,7 @@ import Control.Monad.Reader import Data.Maybe +import Data.Monoid (mappend) import Data.List hiding (sort) import qualified Data.Map as Map import Data.Traversable (sequenceA) @@ -93,17 +98,24 @@ -- | Check that an expression is a type without knowing the sort. isType_ :: A.Expr -> TCM Type isType_ e = - traceCall (IsType_ e) $ sharedType <$> + traceCall (IsType_ e) $ sharedType <$> do + let fallback = isType e =<< do workOnTypes $ newSortMeta case unScope e of A.Fun i (Arg info t) b -> do a <- Dom info <$> isType_ t b <- isType_ b - return $ El (sLub (getSort $ unDom a) (getSort b)) (Pi (convColor a) (NoAbs underscore b)) + s <- ptsRule a b + let t' = El s $ Pi (convColor a) $ NoAbs underscore b + noFunctionsIntoSize b t' + return t' + A.Pi _ tel e | null tel -> isType_ e A.Pi _ tel e -> do - checkTelescope_ tel $ \tel -> do + checkPiTelescope tel $ \tel -> do t <- instantiateFull =<< isType_ e tel <- instantiateFull tel - return $ telePi tel t + let t' = telePi tel t + noFunctionsIntoSize t t' + return t' A.Set _ n -> do n <- ifM typeInType (return 0) (return n) return $ sort (mkType n) @@ -119,10 +131,26 @@ applyRelevanceToContext NonStrict $ checkExpr (namedThing l) lvl return $ sort (Type n) - _ -> do - s <- workOnTypes $ newSortMeta - isType e s + _ -> fallback +ptsRule :: (LensSort a, LensSort b) => a -> b -> TCM Sort +ptsRule a b = pts <$> reduce (getSort a) <*> reduce (getSort b) + +-- | Ensure that a (freshly created) function type does not inhabit 'SizeUniv'. +noFunctionsIntoSize :: Type -> Type -> TCM () +noFunctionsIntoSize t tBlame = do + reportSDoc "tc.fun" 20 $ do + let El s (Pi dom b) = ignoreSharing <$> tBlame + sep [ text "created function type " <+> prettyTCM tBlame + , text "with pts rule" <+> prettyTCM (getSort dom, getSort b, s) + ] + s <- reduce $ getSort t + when (s == SizeUniv) $ do + -- Andreas, 2015-02-14 + -- We have constructed a function type in SizeUniv + -- which is illegal to prevent issue 1428. + typeError $ FunctionTypeInSizeUniv $ unEl tBlame + -- | Check that an expression is a type which is equal to a given type. isTypeEqualTo :: A.Expr -> Type -> TCM Type isTypeEqualTo e t = case e of @@ -139,11 +167,11 @@ -- | Force a type to be a Pi. Instantiates if necessary. The 'Hiding' is only -- used when instantiating a meta variable. -forcePi :: Hiding -> String -> Type -> TCM (Type, Constraints) +forcePi :: Hiding -> String -> Type -> TCM Type forcePi h name (El s t) = do t' <- reduce t case t' of - Pi _ _ -> return (El s t', []) + Pi _ _ -> return $ El s t' _ -> do sa <- newSortMeta sb <- newSortMeta @@ -151,33 +179,48 @@ a <- newTypeMeta sa x <- freshName_ name - let arg = Arg h Relevant a + let arg = setHiding h $ defaultDom a b <- addCtx x arg $ newTypeMeta sb let ty = El s' $ Pi arg (Abs (show x) b) - cs <- equalType (El s t') ty + equalType (El s t') ty ty' <- reduce ty - return (ty', cs) + return ty' -} --------------------------------------------------------------------------- -- * Telescopes --------------------------------------------------------------------------- --- | Type check a telescope. Binds the variables defined by the telescope. -checkTelescope_ :: A.Telescope -> (Telescope -> TCM a) -> TCM a -checkTelescope_ [] ret = ret EmptyTel -checkTelescope_ (b : tel) ret = - checkTypedBindings_ b $ \tel1 -> - checkTelescope_ tel $ \tel2 -> - ret $ abstract tel1 tel2 +-- | Type check a (module) telescope. +-- Binds the variables defined by the telescope. +checkTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a +checkTelescope = checkTelescope' LamNotPi --- | Check a typed binding and extends the context with the bound variables. --- The telescope passed to the continuation is valid in the original context. -checkTypedBindings_ :: A.TypedBindings -> (Telescope -> TCM a) -> TCM a -checkTypedBindings_ = checkTypedBindings PiNotLam +-- | Type check the telescope of a dependent function type. +-- Binds the resurrected variables defined by the telescope. +-- The returned telescope is unmodified (not resurrected). +checkPiTelescope :: A.Telescope -> (Telescope -> TCM a) -> TCM a +checkPiTelescope = checkTelescope' PiNotLam -data LamOrPi = LamNotPi | PiNotLam deriving (Eq,Show) +-- | Flag to control resurrection on domains. +data LamOrPi + = LamNotPi -- ^ We are checking a module telescope. + -- We pass into the type world to check the domain type. + -- This resurrects the whole context. + | PiNotLam -- ^ We are checking a telescope in a Pi-type. + -- We stay in the term world, but add resurrected + -- domains to the context to check the remaining + -- domains and codomain of the Pi-type. + deriving (Eq, Show) +-- | Type check a telescope. Binds the variables defined by the telescope. +checkTelescope' :: LamOrPi -> A.Telescope -> (Telescope -> TCM a) -> TCM a +checkTelescope' lamOrPi [] ret = ret EmptyTel +checkTelescope' lamOrPi (b : tel) ret = + checkTypedBindings lamOrPi b $ \tel1 -> + checkTelescope' lamOrPi tel $ \tel2 -> + ret $ abstract tel1 tel2 + -- | Check a typed binding and extends the context with the bound variables. -- The telescope passed to the continuation is valid in the original context. -- @@ -196,7 +239,8 @@ allowed <- optExperimentalIrrelevance <$> pragmaOptions t <- modEnv lamOrPi allowed $ isType_ e let info' = mapRelevance (modRel lamOrPi allowed) info - addCtxs xs (convColor $ Dom info' t) $ ret $ bindsToTel xs (convColor $ Dom info t) + addContext (xs, convColor (Dom info' t) :: I.Dom Type) $ + ret $ bindsWithHidingToTel xs (convColor $ Dom info t) where -- if we are checking a typed lambda, we resurrect before we check the -- types, but do not modify the new context entries @@ -220,7 +264,7 @@ checkLambda (Arg info (A.TBind _ xs typ)) body target = do let numbinds = length xs TelV tel btyp <- telViewUpTo numbinds target - if size tel < size xs || numbinds /= 1 + if size tel < numbinds || numbinds /= 1 then dontUseTargetType else useTargetType tel btyp where @@ -235,23 +279,29 @@ -- body, we first unify (xs : argsT) → ?t₁ with the target type. If this -- is inconclusive we need to block the resulting term so we create a -- fresh problem for the check. - t1 <- addCtxs xs argsT $ workOnTypes newTypeMeta_ - let tel = telFromList $ bindsToTel xs argsT + let tel = telFromList $ bindsWithHidingToTel xs argsT + -- DONT USE tel for addContext, as it loses NameIds. + -- WRONG: t1 <- addContext tel $ workOnTypes newTypeMeta_ + t1 <- addContext (xs, argsT) $ workOnTypes newTypeMeta_ -- Do not coerce hidden lambdas - if (getHiding info /= NotHidden) then do + if notVisible info || any notVisible xs then do pid <- newProblem_ $ leqType (telePi tel t1) target -- Now check body : ?t₁ - v <- addCtxs xs argsT $ checkExpr body t1 + -- WRONG: v <- addContext tel $ checkExpr body t1 + v <- addContext (xs, argsT) $ checkExpr body t1 -- Block on the type comparison blockTermOnProblem target (teleLam tel v) pid else do -- Now check body : ?t₁ - v <- addCtxs xs argsT $ checkExpr body t1 + -- WRONG: v <- addContext tel $ checkExpr body t1 + v <- addContext (xs, argsT) $ checkExpr body t1 -- Block on the type comparison coerce (teleLam tel v) (telePi tel t1) target useTargetType tel@(ExtendTel arg (Abs y EmptyTel)) btyp = do verboseS "tc.term.lambda" 5 $ tick "lambda-with-target-type" + -- merge in the hiding info of the TBind + info <- return $ mapHiding (mappend h) info unless (getHiding arg == getHiding info) $ typeError $ WrongHidingInLambda target -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given let r = getRelevance info @@ -265,11 +315,76 @@ v <- add y (Dom (setRelevance r' info) argT) $ checkExpr body btyp blockTermOnProblem target (Lam info $ Abs (nameToArgName x) v) pid where - [x] = xs + [WithHiding h x] = xs add y dom | isNoName x = addContext (y, dom) | otherwise = addContext (x, dom) useTargetType _ _ = __IMPOSSIBLE__ +-- | Checking a lambda whose domain type has already been checked. +checkPostponedLambda :: I.Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term +checkPostponedLambda args@(Arg _ ([] , _ )) body target = do + checkExpr body target +checkPostponedLambda args@(Arg info (WithHiding h x : xs, mt)) body target = do + let postpone _ t = postponeTypeCheckingProblem_ $ CheckLambda args body t + lamHiding = mappend h $ getHiding info + insertHiddenLambdas lamHiding target postpone $ \ t@(El _ (Pi dom b)) -> do + -- Andreas, 2011-10-01 ignore relevance in lambda if not explicitly given + let r = getRelevance info -- relevance of lambda + r' = getRelevance dom -- relevance of function type + info' = setHiding lamHiding $ setRelevance r' info + when (r == Irrelevant && r' /= r) $ + typeError $ WrongIrrelevanceInLambda target + -- We only need to block the final term on the argument type + -- comparison. The body will be blocked if necessary. We still want to + -- compare the argument types first, so we spawn a new problem for that + -- check. + mpid <- caseMaybe mt (return Nothing) $ \ ascribedType -> Just <$> do + newProblem_ $ leqType (unDom dom) ascribedType + -- We type-check the body with the ascribedType given by the user + -- to get better error messages. + -- Using the type dom from the usage context would be more precise, + -- though. + let add dom | isNoName x = addContext (absName b, dom) + | otherwise = addContext (x, dom) + v <- add (maybe dom (dom $>) mt) $ + checkPostponedLambda (Arg info (xs, mt)) body $ absBody b + let v' = Lam info' $ Abs (nameToArgName x) v + maybe (return v') (blockTermOnProblem t v') mpid + + +-- | Insert hidden lambda until the hiding info of the domain type +-- matches the expected hiding info. +-- Throws 'WrongHidingInLambda' +insertHiddenLambdas + :: Hiding -- ^ Expected hiding. + -> Type -- ^ Expected to be a function type. + -> (MetaId -> Type -> TCM Term) -- ^ Continuation on blocked type. + -> (Type -> TCM Term) -- ^ Continuation when expected hiding found. + -- The continuation may assume that the @Type@ + -- is of the form @(El _ (Pi _ _))@. + -> TCM Term -- ^ Term with hidden lambda inserted. +insertHiddenLambdas h target postpone ret = do + -- If the target type is blocked, we postpone, + -- because we do not know if a hidden lambda needs to be inserted. + ifBlockedType target postpone $ \ t0 -> do + let t = ignoreSharing <$> t0 + case unEl t of + + Pi dom b -> do + let h' = getHiding dom + -- Found expected hiding: return function type. + if h == h' then ret t else do + -- Found a visible argument but expected a hidden one: + -- That's an error, as we cannot insert a visible lambda. + if visible h' then typeError $ WrongHidingInLambda target else do + -- Otherwise, we found a hidden argument that we can insert. + let x = absName b + Lam (domInfo dom) . Abs x <$> do + addContext (x, dom) $ insertHiddenLambdas h (absBody b) postpone ret + + _ -> typeError . GenericDocError =<< do + text "Expected " <+> prettyTCM target <+> text " to be a function type" + -- | @checkAbsurdLambda i h e t@ checks absurd lambda against type @t@. -- Precondition: @e = AbsurdLam i h@ checkAbsurdLambda :: A.ExprInfo -> Hiding -> A.Expr -> Type -> TCM Term @@ -573,13 +688,11 @@ rx = caseMaybe (rStart re) noRange $ \ pos -> posToRange pos pos hiddenLambdaOrHole h e = case e of - A.AbsurdLam _ h' -> h == h' - A.ExtendedLam _ _ _ cls -> any hiddenLHS cls - A.Lam _ (A.DomainFree info' _) _ -> h == getHiding info' - A.Lam _ (A.DomainFull (A.TypedBindings _ (Arg info' _))) _ - -> h == getHiding info' - A.QuestionMark{} -> True - _ -> False + A.AbsurdLam _ h' -> h == h' + A.ExtendedLam _ _ _ cls -> any hiddenLHS cls + A.Lam _ bind _ -> h == getHiding bind + A.QuestionMark{} -> True + _ -> False hiddenLHS (A.Clause (A.LHS _ (A.LHSHead _ (a : _)) _) _ _) = notVisible a hiddenLHS _ = False @@ -651,23 +764,29 @@ A.Lit lit -> checkLiteral lit t A.Let i ds e -> checkLetBindings ds $ checkExpr e t + A.Pi _ tel e | null tel -> checkExpr e t A.Pi _ tel e -> do - t' <- checkTelescope_ tel $ \tel -> do + t' <- checkPiTelescope tel $ \tel -> do t <- instantiateFull =<< isType_ e tel <- instantiateFull tel - return $ telePi tel t + let t' = telePi tel t + noFunctionsIntoSize t t' + return t' let s = getSort t' + v = unEl t' when (s == Inf) $ reportSDoc "tc.term.sort" 20 $ vcat [ text ("reduced to omega:") , nest 2 $ text "t =" <+> prettyTCM t' , nest 2 $ text "cxt =" <+> (prettyTCM =<< getContextTelescope) ] - coerce (unEl t') (sort s) t + coerce v (sort s) t A.Fun _ (Arg info a) b -> do a' <- isType_ a b' <- isType_ b - s <- reduce $ getSort a' `sLub` getSort b' - coerce (Pi (convColor $ Dom info a') (NoAbs underscore b')) (sort s) t + s <- ptsRule a' b' + let v = Pi (convColor $ Dom info a') (NoAbs underscore b') + noFunctionsIntoSize b' $ El s v + coerce v (sort s) t A.Set _ n -> do n <- ifM typeInType (return 0) (return n) coerce (Sort $ mkType n) (sort $ mkType $ n + 1) t @@ -812,7 +931,7 @@ -- by inserting an underscore for the missing type. domainFree :: A.ArgInfo -> A.Name -> A.LamBinding domainFree info x = - A.DomainFull $ A.TypedBindings r $ Arg info $ A.TBind r [x] $ A.Underscore underscoreInfo + A.DomainFull $ A.TypedBindings r $ Arg info $ A.TBind r [pure x] $ A.Underscore underscoreInfo where r = getRange x underscoreInfo = A.MetaInfo @@ -1246,7 +1365,7 @@ -- c) We inserted implicits, but did not find his one. | otherwise = lift $ typeError $ WrongNamedArgument arg - -- (t0', cs) <- forcePi h (name e) t0 + -- t0' <- lift $ forcePi (getHiding info) (maybe "_" rangedThing $ nameOf e) t0' case ignoreSharing $ unEl t0' of Pi (Dom info' a) b | getHiding info == getHiding info' @@ -1352,7 +1471,10 @@ -- @{tel} -> D vs@ for some datatype @D@ then insert the hidden -- arguments. Otherwise, leave the type polymorphic. inferExprForWith :: A.Expr -> TCM (Term, Type) -inferExprForWith e = traceCall (InferExpr e) $ do +inferExprForWith e = do + reportSDoc "tc.with.infer" 20 $ text "inferExprforWith " <+> prettyTCM e + reportSLn "tc.with.infer" 80 $ "inferExprforWith " ++ show e + traceCall (InferExpr e) $ do -- With wants type and term fully instantiated! (v, t) <- instantiateFull =<< inferExpr e v0 <- reduce v @@ -1402,7 +1524,7 @@ , text "t =" <+> prettyTCM t ] ] - checkLeftHandSide (CheckPattern p EmptyTel t) Nothing [p0] t0 $ \ (LHSResult mgamma delta sub xs ps t' perm) -> do + checkLeftHandSide (CheckPattern p EmptyTel t) Nothing [p0] t0 $ \ (LHSResult delta ps _t _perm) -> do -- A single pattern in internal syntax is returned. let p = case ps of [p] -> namedArg p; _ -> __IMPOSSIBLE__ reportSDoc "tc.term.let.pattern" 20 $ nest 2 $ vcat diff --git a/src/full/Agda/TypeChecking/Rules/Term.hs-boot b/src/full/Agda/TypeChecking/Rules/Term.hs-boot --- a/src/full/Agda/TypeChecking/Rules/Term.hs-boot +++ b/src/full/Agda/TypeChecking/Rules/Term.hs-boot @@ -1,9 +1,9 @@ module Agda.TypeChecking.Rules.Term where +import Agda.Syntax.Common (WithHiding) import qualified Agda.Syntax.Abstract as A -import Agda.Syntax.Internal --- import Agda.Syntax.Common hiding (Arg, Dom, NamedArg) +import Agda.Syntax.Internal as I import Agda.Syntax.Position import Agda.TypeChecking.Monad.Base import Agda.Utils.Except ( ExceptT ) @@ -17,3 +17,5 @@ checkArguments' :: ExpandHidden -> ExpandInstances -> Range -> [NamedArg A.Expr] -> Type -> Type -> (Args -> Type -> TCM Term) -> TCM Term + +checkPostponedLambda :: I.Arg ([WithHiding Name], Maybe Type) -> A.Expr -> Type -> TCM Term diff --git a/src/full/Agda/TypeChecking/Serialise.hs b/src/full/Agda/TypeChecking/Serialise.hs --- a/src/full/Agda/TypeChecking/Serialise.hs +++ b/src/full/Agda/TypeChecking/Serialise.hs @@ -1,10 +1,16 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + +#if __GLASGOW_HASKELL__ <= 708 +{-# LANGUAGE OverlappingInstances #-} +#endif + -- Andreas, Makoto, Francesco 2014-10-15 AIM XX: -- -O2 does not have any noticable effect on runtime -- but sabotages cabal repl with -Werror @@ -48,7 +54,7 @@ import qualified Data.Binary.Put as B import qualified Data.List as List import Data.Function -import Data.Typeable +import Data.Typeable ( cast, Typeable, typeOf, TypeRep ) import qualified Codec.Compression.GZip as G import qualified Agda.Compiler.Epic.Interface as Epic @@ -70,7 +76,6 @@ import Agda.Interaction.FindFile import qualified Agda.TypeChecking.Monad.Benchmark as Bench -import Agda.TypeChecking.Monad.Benchmark (billSub, billTo) import Agda.TypeChecking.Monad import Agda.TypeChecking.CompiledClause @@ -110,7 +115,7 @@ -- 32-bit machines). Word64 does not have these problems. currentInterfaceVersion :: Word64 -currentInterfaceVersion = 20141018 * 10 + 0 +currentInterfaceVersion = 20150511 * 10 + 0 -- | Constructor tag (maybe omitted) and argument indices. @@ -269,19 +274,19 @@ liftIO $ H.toList stats modifyStatistics $ Map.union stats -- Encode hashmaps and root, and compress. - bits1 <- billSub [ Bench.Serialization, Bench.BinaryEncode ] $ + bits1 <- Bench.billTo [ Bench.Serialization, Bench.BinaryEncode ] $ returnForcedByteString $ B.encode (root, nL, sL, iL, dL) let compressParams = G.defaultCompressParams { G.compressLevel = G.bestSpeed , G.compressStrategy = G.huffmanOnlyStrategy } - cbits <- billSub [ Bench.Serialization, Bench.Compress ] $ + cbits <- Bench.billTo [ Bench.Serialization, Bench.Compress ] $ returnForcedByteString $ G.compressWith compressParams bits1 let x = B.encode currentInterfaceVersion `L.append` cbits return x where l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h - benchSort = billTo [Bench.Serialization, Bench.Sort] . liftIO + benchSort = Bench.billTo [Bench.Serialization, Bench.Sort] . liftIO statistics :: String -> IORef FreshAndReuse -> TCM () statistics kind ioref = do FreshAndReuse fresh reused <- liftIO $ readIORef ioref @@ -402,7 +407,11 @@ decodeFile :: FilePath -> TCM (Maybe Interface) decodeFile f = decodeInterface =<< liftIO (L.readFile f) +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} EmbPrj String where +#else instance EmbPrj String where +#endif icod_ = icodeString value i = (! i) `fmap` gets stringE @@ -493,9 +502,13 @@ value = vcase valu where valu [a] = valu1 TopLevelModuleName a valu _ = malformed +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} EmbPrj a => EmbPrj [a] where +#else instance EmbPrj a => EmbPrj [a] where +#endif icod_ xs = icodeN =<< mapM icode xs - value = vcase (mapM value) + value = vcase (mapM value) -- icode [] = icode0' -- icode (x : xs) = icode2' x xs -- value = vcase valu where valu [] = valu0 [] @@ -612,13 +625,18 @@ valu [4] = valu0 QuotableName valu _ = malformed +instance EmbPrj Agda.Syntax.Fixity.Associativity where + icod_ LeftAssoc = icode0' + icod_ RightAssoc = icode0 1 + icod_ NonAssoc = icode0 2 + value = vcase valu where valu [] = valu0 LeftAssoc + valu [1] = valu0 RightAssoc + valu [2] = valu0 NonAssoc + valu _ = malformed + instance EmbPrj Agda.Syntax.Fixity.Fixity where - icod_ (LeftAssoc a b) = icode2 0 a b - icod_ (RightAssoc a b) = icode2 1 a b - icod_ (NonAssoc a b) = icode2' a b - value = vcase valu where valu [0, a, b] = valu2 LeftAssoc a b - valu [1, a, b] = valu2 RightAssoc a b - valu [a, b] = valu2 NonAssoc a b + icod_ (Fixity a b c) = icode3' a b c + value = vcase valu where valu [a, b, c] = valu3 Fixity a b c valu _ = malformed instance EmbPrj Agda.Syntax.Fixity.Fixity' where @@ -846,6 +864,11 @@ valu [0, a] = valu1 Proj a valu _ = malformed +instance EmbPrj a => EmbPrj (WithHiding a) where + icod_ (WithHiding a b) = icode2' a b + value = vcase valu where valu [a, b] = valu2 WithHiding a b + valu _ = malformed + instance (EmbPrj a, EmbPrj c) => EmbPrj (Agda.Syntax.Common.Arg c a) where icod_ (Arg i e) = icode2' i e value = vcase valu where valu [i, e] = valu2 Arg i e @@ -875,12 +898,14 @@ instance EmbPrj Agda.Syntax.Common.Relevance where icod_ Relevant = icode0' icod_ Irrelevant = icode0 1 - icod_ Forced = icode0 2 + icod_ (Forced Small) = icode0 2 + icod_ (Forced Big) = icode0 5 icod_ NonStrict = icode0 3 icod_ UnusedArg = icode0 4 value = vcase valu where valu [] = valu0 Relevant valu [1] = valu0 Irrelevant - valu [2] = valu0 Forced + valu [2] = valu0 (Forced Small) + valu [5] = valu0 (Forced Big) valu [3] = valu0 NonStrict valu [4] = valu0 UnusedArg valu _ = malformed @@ -955,21 +980,26 @@ valu _ = malformed instance EmbPrj LevelAtom where - icod_ (NeutralLevel a) = icode1' a + icod_ (NeutralLevel _ a) = icode1' a icod_ (UnreducedLevel a) = icode1 1 a icod_ MetaLevel{} = __IMPOSSIBLE__ icod_ BlockedLevel{} = __IMPOSSIBLE__ - value = vcase valu where valu [a] = valu1 NeutralLevel a - valu [1, a] = valu1 UnreducedLevel a - valu _ = malformed + value = vcase valu where + valu [a] = valu1 UnreducedLevel a -- we forget that we are a NeutralLevel, + -- since we do not want do (de)serialize + -- the reason for neutrality + valu [1, a] = valu1 UnreducedLevel a + valu _ = malformed instance EmbPrj I.Sort where icod_ (Type a ) = icode1' a icod_ Prop = icode1 1 () + icod_ SizeUniv = icode1 3 () icod_ Inf = icode1 4 () icod_ (DLub a b) = __IMPOSSIBLE__ value = vcase valu where valu [a] = valu1 Type a valu [1, _] = valu0 Prop + valu [3, _] = valu0 SizeUniv valu [4, _] = valu0 Inf valu _ = malformed @@ -1022,6 +1052,17 @@ value = vcase valu where valu [rel, a, b, c, d, e, f, g, h, i, j] = valu11 Defn rel a b c d e f g h i j valu _ = malformed +instance EmbPrj NLPat where + icod_ (PVar a) = icode1 0 a + icod_ (PWild) = icode0 1 + icod_ (PDef a b) = icode2 2 a b + icod_ (PTerm a) = icode1 3 a + value = vcase valu where valu [0, a] = valu1 PVar a + valu [1] = valu0 PWild + valu [2, a, b] = valu2 PDef a b + valu [3, a] = valu1 PTerm a + valu _ = malformed + instance EmbPrj RewriteRule where icod_ (RewriteRule a b c d e) = icode5' a b c d e value = vcase valu where valu [a, b, c, d, e] = valu5 RewriteRule a b c d e @@ -1215,6 +1256,11 @@ valu [] = valu0 NotDelayed valu _ = malformed +instance EmbPrj I.ConPatternInfo where + icod_ (ConPatternInfo a b) = icode2' a b + value = vcase valu where valu [a, b] = valu2 ConPatternInfo a b + valu _ = malformed + instance EmbPrj I.Pattern where icod_ (VarP a ) = icode1' a icod_ (ConP a b c) = icode3' a b c @@ -1329,7 +1375,6 @@ valu [8] = valu0 WithArgCtx valu [9] = valu0 DotPatternCtx valu _ = malformed - instance EmbPrj ScopeInfo where icod_ (ScopeInfo a b c d) = icode4' a b c d value = vcase valu where valu [a, b, c, d] = valu4 ScopeInfo a b c d @@ -1414,15 +1459,15 @@ d <- asks dict c <- asks counter liftIO $ do - mi <- H.lookup d key - case mi of - Just i -> do - modifyIORef' c $ over lensReuse (+1) - return i - Nothing -> do - fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) - H.insert d key fresh - return fresh + mi <- H.lookup d key + case mi of + Just i -> do + modifyIORef' c $ over lensReuse (+1) + return i + Nothing -> do + fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) + H.insert d key fresh + return fresh -- Instead of inlining icodeX, we manually specialize it to -- its four uses: Integer, String, Double, Node. @@ -1433,60 +1478,60 @@ d <- asks integerD c <- asks integerC liftIO $ do - mi <- H.lookup d key - case mi of - Just i -> do - modifyIORef' c $ over lensReuse (+1) - return i - Nothing -> do - fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) - H.insert d key fresh - return fresh + mi <- H.lookup d key + case mi of + Just i -> do + modifyIORef' c $ over lensReuse (+1) + return i + Nothing -> do + fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) + H.insert d key fresh + return fresh icodeDouble :: Double -> S Int32 icodeDouble key = do d <- asks doubleD c <- asks doubleC liftIO $ do - mi <- H.lookup d key - case mi of - Just i -> do - modifyIORef' c $ over lensReuse (+1) - return i - Nothing -> do - fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) - H.insert d key fresh - return fresh + mi <- H.lookup d key + case mi of + Just i -> do + modifyIORef' c $ over lensReuse (+1) + return i + Nothing -> do + fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) + H.insert d key fresh + return fresh icodeString :: String -> S Int32 icodeString key = do d <- asks stringD c <- asks stringC liftIO $ do - mi <- H.lookup d key - case mi of - Just i -> do - modifyIORef' c $ over lensReuse (+1) - return i - Nothing -> do - fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) - H.insert d key fresh - return fresh + mi <- H.lookup d key + case mi of + Just i -> do + modifyIORef' c $ over lensReuse (+1) + return i + Nothing -> do + fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) + H.insert d key fresh + return fresh icodeN :: Node -> S Int32 icodeN key = do d <- asks nodeD c <- asks nodeC liftIO $ do - mi <- H.lookup d key - case mi of - Just i -> do - modifyIORef' c $ over lensReuse (+1) - return i - Nothing -> do - fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) - H.insert d key fresh - return fresh + mi <- H.lookup d key + case mi of + Just i -> do + modifyIORef' c $ over lensReuse (+1) + return i + Nothing -> do + fresh <- (^.lensFresh) <$> do readModifyIORef' c $ over lensFresh (+1) + H.insert d key fresh + return fresh -- icodeN :: [Int32] -> S Int32 -- icodeN = icodeX nodeD nodeC diff --git a/src/full/Agda/TypeChecking/SizedTypes.hs b/src/full/Agda/TypeChecking/SizedTypes.hs --- a/src/full/Agda/TypeChecking/SizedTypes.hs +++ b/src/full/Agda/TypeChecking/SizedTypes.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.SizedTypes where +import Prelude hiding (null) + import Data.Function -import Data.List +import Data.List hiding (null) import qualified Data.Map as Map import Agda.Interaction.Options @@ -26,6 +28,7 @@ import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad +import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Tuple @@ -107,13 +110,13 @@ Def inf [] <- ignoreSharing <$> primSizeInf Def suc [] <- ignoreSharing <$> primSizeSuc let loop v = do - v <- reduce v - case ignoreSharing v of - Def x [] | x == inf -> return $ DSizeInf - Def x [Apply u] | x == suc -> sizeViewSuc_ suc <$> loop (unArg u) - Var i [] -> return $ DSizeVar i 0 - MetaV x us -> return $ DSizeMeta x us 0 - _ -> return $ DOtherSize v + v <- reduce v + case ignoreSharing v of + Def x [] | x == inf -> return $ DSizeInf + Def x [Apply u] | x == suc -> sizeViewSuc_ suc <$> loop (unArg u) + Var i [] -> return $ DSizeVar i 0 + MetaV x us -> return $ DSizeMeta x us 0 + _ -> return $ DOtherSize v loop v sizeMaxView :: Term -> TCM SizeMaxView @@ -122,14 +125,14 @@ suc <- getBuiltinDefName builtinSizeSuc max <- getBuiltinDefName builtinSizeMax let loop v = do - v <- reduce v - case v of - Def x [] | Just x == inf -> return $ [DSizeInf] - Def x [Apply u] | Just x == suc -> maxViewSuc_ (fromJust suc) <$> loop (unArg u) - Def x [Apply u1, Apply u2] | Just x == max -> maxViewMax <$> loop (unArg u1) <*> loop (unArg u2) - Var i [] -> return $ [DSizeVar i 0] - MetaV x us -> return $ [DSizeMeta x us 0] - _ -> return $ [DOtherSize v] + v <- reduce v + case v of + Def x [] | Just x == inf -> return $ [DSizeInf] + Def x [Apply u] | Just x == suc -> maxViewSuc_ (fromJust suc) <$> loop (unArg u) + Def x [Apply u1, Apply u2] | Just x == max -> maxViewMax <$> loop (unArg u1) <*> loop (unArg u2) + Var i [] -> return $ [DSizeVar i 0] + MetaV x us -> return $ [DSizeMeta x us 0] + _ -> return $ [DOtherSize v] loop v ------------------------------------------------------------------------ @@ -265,7 +268,7 @@ caseMaybe (test b) no $ \ _ -> do let yes = return $ Just (m, a, tel) if interactionMetas then yes else do - ifM (isJust <$> isInteractionMeta m) no yes + ifM (isJust <$> isInteractionMeta m) no yes _ -> no {- ROLLED BACK @@ -430,51 +433,51 @@ ms <- getSizeMetas True -- get all size metas, also interaction metas when (not (null cs) || not (null ms)) $ do - reportSLn "tc.size.solve" 10 $ "Solving size constraints " ++ show cs + reportSLn "tc.size.solve" 10 $ "Solving size constraints " ++ show cs - cs <- return $ mapMaybe canonicalizeSizeConstraint cs - reportSLn "tc.size.solve" 10 $ "Canonicalized constraints: " ++ show cs + cs <- return $ mapMaybe canonicalizeSizeConstraint cs + reportSLn "tc.size.solve" 10 $ "Canonicalized constraints: " ++ show cs - let -- Error for giving up - cannotSolve = typeError . GenericDocError =<< - vcat (text "Cannot solve size constraints" : map prettyTCM cs0) + let -- Error for giving up + cannotSolve = typeError . GenericDocError =<< + vcat (text "Cannot solve size constraints" : map prettyTCM cs0) - -- Size metas in constraints. - metas0 :: [(MetaId, Int)] -- meta id + arity - metas0 = nub $ map (mapSnd length) $ concatMap flexibleVariables cs + -- Size metas in constraints. + metas0 :: [(MetaId, Int)] -- meta id + arity + metas0 = nub $ map (mapSnd length) $ concatMap flexibleVariables cs - -- Unconstrained size metas that do not occur in constraints. - metas1 :: [(MetaId, Int)] - metas1 = forMaybe ms $ \ (m, _, tel) -> - maybe (Just (m, size tel)) (const Nothing) $ - lookup m metas0 + -- Unconstrained size metas that do not occur in constraints. + metas1 :: [(MetaId, Int)] + metas1 = forMaybe ms $ \ (m, _, tel) -> + maybe (Just (m, size tel)) (const Nothing) $ + lookup m metas0 - -- All size metas - metas = metas0 ++ metas1 + -- All size metas + metas = metas0 ++ metas1 - reportSLn "tc.size.solve" 15 $ "Metas: " ++ show metas0 ++ ", " ++ show metas1 + reportSLn "tc.size.solve" 15 $ "Metas: " ++ show metas0 ++ ", " ++ show metas1 - verboseS "tc.size.solve" 20 $ - -- debug print the type of all size metas - forM_ metas $ \ (m, _) -> - reportSDoc "tc.size.solve" 20 $ prettyTCM =<< mvJudgement <$> lookupMeta m + verboseS "tc.size.solve" 20 $ + -- debug print the type of all size metas + forM_ metas $ \ (m, _) -> + reportSDoc "tc.size.solve" 20 $ prettyTCM =<< mvJudgement <$> lookupMeta m - -- Run the solver. - unlessM (oldSolver metas cs) cannotSolve + -- Run the solver. + unlessM (oldSolver metas cs) cannotSolve - -- Double-checking the solution. + -- Double-checking the solution. - -- Andreas, 2012-09-19 - -- The returned solution might not be consistent with - -- the hypotheses on rigid vars (j : Size< i). - -- Thus, we double check that all size constraints - -- have been solved correctly. - flip catchError (const cannotSolve) $ - noConstraints $ - forM_ cs0 $ \ cl -> enterClosure cl solveConstraint + -- Andreas, 2012-09-19 + -- The returned solution might not be consistent with + -- the hypotheses on rigid vars (j : Size< i). + -- Thus, we double check that all size constraints + -- have been solved correctly. + flip catchError (const cannotSolve) $ + noConstraints $ + forM_ cs0 $ \ cl -> enterClosure cl solveConstraint --- | Old solver for size constraints using 'Agda.Utils.Warshall'. +-- | Old solver for size constraints using "Agda.Utils.Warshall". oldSolver :: [(MetaId, Int)] -- ^ Size metas and their arity. -> [SizeConstraint] -- ^ Size constraints (in preprocessed form). @@ -511,7 +514,7 @@ v = term e reportSDoc "tc.size.solve" 20 $ sep - [ text (show m) <+> text ":=" + [ pretty m <+> text ":=" , nest 2 $ prettyTCM v ] diff --git a/src/full/Agda/TypeChecking/SizedTypes/Solve.hs b/src/full/Agda/TypeChecking/SizedTypes/Solve.hs --- a/src/full/Agda/TypeChecking/SizedTypes/Solve.hs +++ b/src/full/Agda/TypeChecking/SizedTypes/Solve.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | Solving size constraints under hypotheses. -- @@ -92,7 +91,13 @@ import Agda.Utils.Except ( MonadError(catchError) ) import Agda.Utils.Function import Agda.Utils.Functor + +#if MIN_VERSION_base(4,8,0) +import Agda.Utils.List hiding ( uncons ) +#else import Agda.Utils.List +#endif + import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Size diff --git a/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs b/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs --- a/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs +++ b/src/full/Agda/TypeChecking/SizedTypes/Syntax.hs @@ -1,12 +1,11 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- | Syntax of size expressions and constraints. diff --git a/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs b/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs --- a/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs +++ b/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# LANGUAGE FlexibleContexts #-} +#endif + module Agda.TypeChecking.SizedTypes.WarshallSolver where import Prelude hiding (truncate) @@ -834,38 +837,38 @@ -- iterate over all flexible variables xas <- catMaybes <$> do forM xs $ \ x -> do - -- get lower and upper bounds for flexible x - let lx = Set.toList $ Map.findWithDefault Set.empty x lbs - ux = Set.toList $ Map.findWithDefault Set.empty x ubs - traceM ("lower bounds for " ++ show x ++ ": " ++ show lx) - traceM ("upper bounds for " ++ show x ++ ": " ++ show ux) - -- compute maximum of lower bounds - lb <- do - case lx of - [] -> return $ Nothing - (a:as) -> do - case foldM (lub hg) a as of - Nothing -> Left $ "inconsistent lower bound for " ++ show x - Just l -> return $ Just $ truncateOffset l - -- compute minimum of upper bounds - ub <- do - case ux of - [] -> return $ Nothing - (a:as) -> do - case foldM (glb hg) a as of - Nothing -> Left $ "inconsistent upper bound for " ++ show x - Just l | validOffset l -> return $ Just l - | otherwise -> return $ findRigidBelow hg l - case (lb, ub) of - (Just l, Nothing) -> return $ Just (x, l) -- solve x = lower bound - (Nothing, Just u) -> return $ Just (x, u) -- solve x = upper bound - (Just l, Just u) -> do - traceM ("lower bound for " ++ show x ++ ": " ++ show l) - traceM ("upper bound for " ++ show x ++ ": " ++ show u) - case getPolarity pols x of - Least -> return $ Just (x, l) - Greatest -> return $ Just (x, u) - _ -> return Nothing + -- get lower and upper bounds for flexible x + let lx = Set.toList $ Map.findWithDefault Set.empty x lbs + ux = Set.toList $ Map.findWithDefault Set.empty x ubs + traceM ("lower bounds for " ++ show x ++ ": " ++ show lx) + traceM ("upper bounds for " ++ show x ++ ": " ++ show ux) + -- compute maximum of lower bounds + lb <- do + case lx of + [] -> return $ Nothing + (a:as) -> do + case foldM (lub hg) a as of + Nothing -> Left $ "inconsistent lower bound for " ++ show x + Just l -> return $ Just $ truncateOffset l + -- compute minimum of upper bounds + ub <- do + case ux of + [] -> return $ Nothing + (a:as) -> do + case foldM (glb hg) a as of + Nothing -> Left $ "inconsistent upper bound for " ++ show x + Just l | validOffset l -> return $ Just l + | otherwise -> return $ findRigidBelow hg l + case (lb, ub) of + (Just l, Nothing) -> return $ Just (x, l) -- solve x = lower bound + (Nothing, Just u) -> return $ Just (x, u) -- solve x = upper bound + (Just l, Just u) -> do + traceM ("lower bound for " ++ show x ++ ": " ++ show l) + traceM ("upper bound for " ++ show x ++ ": " ++ show u) + case getPolarity pols x of + Least -> return $ Just (x, l) + Greatest -> return $ Just (x, u) + _ -> return Nothing return $ Map.fromList xas -- | Solve a forest of constraint graphs relative to a hypotheses graph. diff --git a/src/full/Agda/TypeChecking/Substitute.hs b/src/full/Agda/TypeChecking/Substitute.hs --- a/src/full/Agda/TypeChecking/Substitute.hs +++ b/src/full/Agda/TypeChecking/Substitute.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +#if __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +#endif module Agda.TypeChecking.Substitute ( module Agda.TypeChecking.Substitute @@ -20,6 +22,7 @@ import Data.List hiding (sort, drop) import qualified Data.List as List import Data.Map (Map) +import Data.Monoid import Data.Typeable (Typeable) import Debug.Trace (trace) @@ -58,6 +61,10 @@ applyE t es = apply t $ map argFromElim es -- precondition: all @es@ are @Apply@s +-- | Apply to a single argument. +apply1 :: Apply t => t -> Term -> t +apply1 t u = apply t [ defaultArg u ] + instance Apply Term where applyE m [] = m applyE m es = @@ -157,10 +164,18 @@ apply (RewriteRule q gamma lhs rhs t) args = RewriteRule q (apply gamma args) lhs rhs t +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} Apply [Base.Occurrence] where +#else instance Apply [Base.Occurrence] where +#endif apply occ args = List.drop (length args) occ +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} Apply [Polarity] where +#else instance Apply [Polarity] where +#endif apply pol args = List.drop (length args) pol instance Apply Projection where @@ -181,20 +196,23 @@ } Function{ funClauses = cs, funCompiled = cc, funInv = inv - , funProjection = Just p} -> - case p `apply` args of + , funProjection = Just p0} -> + case p0 `apply` args of p@Projection{ projIndex = n } | n < 0 -> __IMPOSSIBLE__ -- case: applied only to parameters | n > 0 -> d { funProjection = Just p } - -- case: applied also to record value + -- case: applied also to record value (n == 0) | otherwise -> d { funClauses = apply cs args' , funCompiled = apply cc args' , funInv = apply inv args' - , funProjection = Nothing -- WAS: Just $ p { projIndex = 0 } + , funProjection = if isVar0 then Just p{ projIndex = 0 } else Nothing } - where args' = [last args] -- the record value + where + larg = last args -- the record value + args' = [larg] + isVar0 = case ignoreSharing $ unArg larg of Var 0 [] -> True; _ -> False {- Function{ funClauses = cs, funCompiled = cc, funInv = inv , funProjection = Just p@Projection{ projIndex = n } } @@ -287,10 +305,14 @@ apply (DTerm v) args = DTerm $ apply v args apply (DDot v) args = DDot $ apply v args apply (DCon c vs) args = DCon c $ vs ++ map (fmap DTerm) args - apply (DDef c vs) args = DDef c $ vs ++ map (fmap DTerm) args + apply (DDef c es) args = DDef c $ es ++ map (Apply . fmap DTerm) args apply (DWithApp v ws args') args = DWithApp v ws $ args' ++ args +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} Apply t => Apply [t] where +#else instance Apply t => Apply [t] where +#endif apply ts args = map (`apply` args) ts applyE ts es = map (`applyE` es) ts @@ -374,11 +396,19 @@ abstract tel (RewriteRule q gamma lhs rhs t) = RewriteRule q (abstract tel gamma) lhs rhs t +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} Abstract [Base.Occurrence] where +#else instance Abstract [Base.Occurrence] where +#endif abstract tel [] = [] abstract tel occ = replicate (size tel) Mixed ++ occ -- TODO: check occurrence +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPING #-} Abstract [Polarity] where +#else instance Abstract [Polarity] where +#endif abstract tel [] = [] abstract tel pol = replicate (size tel) Invariant ++ pol -- TODO: check polarity @@ -386,6 +416,8 @@ abstract tel p = p { projIndex = size tel + projIndex p , projDropPars = abstract tel $ projDropPars p + , projArgInfo = if projIndex p > 0 then projArgInfo p else + domInfo $ last $ telToList tel } instance Abstract Defn where @@ -397,8 +429,19 @@ , funCompiled = abstract tel cc , funInv = abstract tel inv } - Function{ funProjection = Just p } -> - d { funProjection = Just $ abstract tel p } + Function{ funClauses = cs, funCompiled = cc, funInv = inv + , funProjection = Just p } -> + -- Andreas, 2015-05-11 if projection was applied to Var 0 + -- then abstract over last element of tel (the others are params). + if projIndex p > 0 then d' else + d' { funClauses = abstract tel1 cs + , funCompiled = abstract tel1 cc + , funInv = abstract tel1 inv + } + where + d' = d { funProjection = Just $ abstract tel p } + tel1 = telFromList $ drop (size tel - 1) $ telToList tel + Datatype{ dataPars = np, dataSmallPars = sps, dataNonLinPars = nlps, dataClause = cl } -> d { dataPars = np + size tel , dataSmallPars = abstract tel sps @@ -456,7 +499,11 @@ abstract EmptyTel b = b abstract (ExtendTel _ tel) b = Bind $ fmap (`abstract` b) tel +#if __GLASGOW_HASKELL__ >= 710 +instance {-# OVERLAPPABLE #-} Abstract t => Abstract [t] where +#else instance Abstract t => Abstract [t] where +#endif abstract tel = map (abstract tel) instance Abstract t => Abstract (Maybe t) where @@ -635,6 +682,7 @@ Type n -> levelSort $ sub n Prop -> Prop Inf -> Inf + SizeUniv -> SizeUniv DLub s1 s2 -> DLub (sub s1) (sub s2) where sub x = applySubst rho x @@ -648,7 +696,7 @@ instance Subst LevelAtom where applySubst rho (MetaLevel m vs) = MetaLevel m $ applySubst rho vs applySubst rho (BlockedLevel m v) = BlockedLevel m $ applySubst rho v - applySubst rho (NeutralLevel v) = UnreducedLevel $ applySubst rho v + applySubst rho (NeutralLevel _ v) = UnreducedLevel $ applySubst rho v applySubst rho (UnreducedLevel v) = UnreducedLevel $ applySubst rho v instance Subst Bool where @@ -657,6 +705,9 @@ instance Subst Name where applySubst rho = id +instance Subst ConPatternInfo where + applySubst rho (ConPatternInfo mr mt) = ConPatternInfo mr $ applySubst rho mt + instance Subst Pattern where applySubst rho p = case p of ConP c mt ps -> ConP c (applySubst rho mt) $ applySubst rho ps @@ -677,7 +728,7 @@ applySubst rho (DTerm v) = DTerm $ applySubst rho v applySubst rho (DDot v) = DDot $ applySubst rho v applySubst rho (DCon c vs) = DCon c $ applySubst rho vs - applySubst rho (DDef c vs) = DDef c $ applySubst rho vs + applySubst rho (DDef c es) = DDef c $ applySubst rho es applySubst rho (DWithApp v vs ws) = uncurry3 DWithApp $ applySubst rho (v, vs, ws) instance Subst a => Subst (Tele a) where @@ -699,9 +750,9 @@ where rf x = applySubst rho x -instance Subst Elim where +instance Subst a => Subst (Elim' a) where applySubst rho e = case e of - Apply v -> Apply (applySubst rho v) + Apply v -> Apply $ applySubst rho v Proj{} -> e instance Subst a => Subst (Abs a) where @@ -781,6 +832,15 @@ bindsToTel :: [Name] -> Dom Type -> ListTel bindsToTel = bindsToTel' nameToArgName +-- | Turn a typed binding @(x1 .. xn : A)@ into a telescope. +bindsWithHidingToTel' :: (Name -> a) -> [WithHiding Name] -> Dom Type -> ListTel' a +bindsWithHidingToTel' f [] t = [] +bindsWithHidingToTel' f (WithHiding h x : xs) t = + fmap (f x,) (mapHiding (mappend h) t) : bindsWithHidingToTel' f xs (raise 1 t) + +bindsWithHidingToTel :: [WithHiding Name] -> Dom Type -> ListTel +bindsWithHidingToTel = bindsWithHidingToTel' nameToArgName + telView' :: Type -> TelView telView' t = case ignoreSharing $ unEl t of Pi a b -> absV a (absName b) $ telView' (absBody b) @@ -803,7 +863,7 @@ telePi (ExtendTel u tel) t = el $ Pi u $ reAbs b where b = (`telePi` t) <$> tel - s1 = getSort $ unDom u + s1 = getSort u s2 = getSort <$> b el = El $ dLub s1 s2 @@ -870,7 +930,7 @@ -- __IMPOSSIBLE__ in the case where the variable shouldn't be used but we -- cannot use 'noabsApp'. Used in Apply. lazyAbsApp :: Subst t => Abs t -> Term -> t -lazyAbsApp (Abs _ v) u = applySubst (u :# IdS) v +lazyAbsApp (Abs _ v) u = applySubst (u :# IdS) v -- Note: do not use consS here! lazyAbsApp (NoAbs _ v) _ = v -- | Instantiate an abstraction that doesn't use its argument. @@ -951,23 +1011,25 @@ -- * Syntactic equality and order --------------------------------------------------------------------------- -deriving instance (Subst a, Eq a) => Eq (Tele a) -deriving instance (Subst a, Ord a) => Ord (Tele a) - deriving instance Eq Substitution deriving instance Ord Substitution deriving instance Eq Sort deriving instance Ord Sort -deriving instance Eq Type -deriving instance Ord Type deriving instance Eq Level deriving instance Ord Level deriving instance Eq PlusLevel deriving instance Ord LevelAtom -deriving instance Eq Elim -deriving instance Ord Elim +deriving instance Eq NotBlocked +deriving instance Ord NotBlocked +deriving instance Eq t => Eq (Blocked t) +deriving instance Ord t => Ord (Blocked t) +deriving instance (Subst a, Eq a) => Eq (Elim' a) +deriving instance (Subst a, Ord a) => Ord (Elim' a) +deriving instance (Subst a, Eq a) => Eq (Tele a) +deriving instance (Subst a, Ord a) => Ord (Tele a) + deriving instance Eq Constraint instance Ord PlusLevel where @@ -980,7 +1042,14 @@ instance Eq LevelAtom where (==) = (==) `on` unLevelAtom --- | Syntactic equality, ignores stuff below @DontCare@. +-- | Syntactic 'Type' equality, ignores sort annotations. +instance Eq a => Eq (Type' a) where + (==) = (==) `on` unEl + +instance Ord a => Ord (Type' a) where + compare = compare `on` unEl + +-- | Syntactic 'Term' equality, ignores stuff below @DontCare@ and sharing. instance Eq Term where Var x vs == Var x' vs' = x == x' && vs == vs' Lam h v == Lam h' v' = h == h' && v == v' @@ -1046,13 +1115,28 @@ -- * Level stuff --------------------------------------------------------------------------- +-- | The ``rule'', if Agda is considered as a functional +-- pure type system (pts). +-- +-- TODO: This needs to be properly implemented, requiring +-- refactoring of Agda's handling of levels. +-- Without impredicativity or 'SizeUniv', Agda's pts rule is +-- just the least upper bound, which is total and commutative. +-- The handling of levels relies on this simplification. +pts :: Sort -> Sort -> Sort +pts = sLub + sLub :: Sort -> Sort -> Sort sLub s Prop = s sLub Prop s = s sLub Inf _ = Inf sLub _ Inf = Inf +sLub SizeUniv s = s -- one can freely quantify over sizes in any Set +sLub _ SizeUniv = SizeUniv -- but everything resulting in a size lives in the SizeUniv sLub (Type (Max as)) (Type (Max bs)) = Type $ levelMax (as ++ bs) -sLub (DLub a b) c = DLub (sLub a c) b +-- sLub (DLub a b) c = DLub (sLub a c) b -- no longer commutative! +sLub (DLub a NoAbs{}) c = __IMPOSSIBLE__ +sLub (DLub a (Abs x b)) c = DLub a $ Abs x $ sLub b $ raise 1 c sLub a (DLub b c) = DLub (sLub a b) c lvlView :: Term -> Level @@ -1081,7 +1165,7 @@ expandAtom l = case l of BlockedLevel _ v -> expandTm v - NeutralLevel v -> expandTm v + NeutralLevel _ v -> expandTm v UnreducedLevel v -> expandTm v MetaLevel{} -> [Plus 0 l] where @@ -1107,17 +1191,18 @@ levelSort :: Level -> Sort levelSort (Max as) - | List.any isInf as = Inf + | List.any (levelIs Inf ) as = Inf + | List.any (levelIs SizeUniv) as = SizeUniv where - isInf ClosedLevel{} = False - isInf (Plus _ l) = infAtom l - infAtom (NeutralLevel a) = infTm a - infAtom (UnreducedLevel a) = infTm a - infAtom MetaLevel{} = False - infAtom BlockedLevel{} = False - infTm (Sort Inf) = True - infTm (Shared p) = infTm $ derefPtr p - infTm _ = False + levelIs s ClosedLevel{} = False + levelIs s (Plus _ l) = atomIs s l + atomIs s (NeutralLevel _ a) = tmIs s a + atomIs s (UnreducedLevel a) = tmIs s a + atomIs s MetaLevel{} = False + atomIs s BlockedLevel{} = False + tmIs s (Sort s') = s == s' + tmIs s (Shared p) = tmIs s $ derefPtr p + tmIs s _ = False levelSort l = case ignoreSharing $ levelTm l of Sort s -> s @@ -1131,26 +1216,6 @@ unLevelAtom :: LevelAtom -> Term unLevelAtom (MetaLevel x es) = MetaV x es -unLevelAtom (NeutralLevel v) = v +unLevelAtom (NeutralLevel _ v) = v unLevelAtom (UnreducedLevel v) = v unLevelAtom (BlockedLevel _ v) = v - ---------------------------------------------------------------------------- --- * Boring instances ---------------------------------------------------------------------------- - -instance Sized Substitution where - size IdS = 1 - size EmptyS = 1 - size (Wk _ rho) = 1 + size rho - size (t :# rho) = 1 + size t + size rho - size (Strengthen _ rho) = 1 + size rho - size (Lift _ rho) = 1 + size rho - -instance KillRange Substitution where - killRange IdS = IdS - killRange EmptyS = EmptyS - killRange (Wk n rho) = killRange1 (Wk n) rho - killRange (t :# rho) = killRange2 (:#) t rho - killRange (Strengthen err rho) = killRange1 (Strengthen err) rho - killRange (Lift n rho) = killRange1 (Lift n) rho diff --git a/src/full/Agda/TypeChecking/SyntacticEquality.hs b/src/full/Agda/TypeChecking/SyntacticEquality.hs --- a/src/full/Agda/TypeChecking/SyntacticEquality.hs +++ b/src/full/Agda/TypeChecking/SyntacticEquality.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} -- | A syntactic equality check that takes meta instantiations into account, -- but does not reduce. It replaces @@ -131,9 +130,10 @@ l <- lift (unBlock =<< instantiate l) case (l, l') of (MetaLevel m vs , MetaLevel m' vs' ) | m == m' -> MetaLevel m <$$> synEq vs vs' - (NeutralLevel v , NeutralLevel v' ) -> NeutralLevel <$$> synEq v v' (UnreducedLevel v, UnreducedLevel v' ) -> UnreducedLevel <$$> synEq v v' - (BlockedLevel m v, BlockedLevel m' v') | m == m' -> BlockedLevel m <$$> synEq v v' + -- The reason for being blocked should not matter for equality. + (NeutralLevel r v, NeutralLevel r' v') -> NeutralLevel r <$$> synEq v v' + (BlockedLevel m v, BlockedLevel m' v') -> BlockedLevel m <$$> synEq v v' _ -> inequal (l, l') where unBlock l = diff --git a/src/full/Agda/TypeChecking/Telescope.hs b/src/full/Agda/TypeChecking/Telescope.hs --- a/src/full/Agda/TypeChecking/Telescope.hs +++ b/src/full/Agda/TypeChecking/Telescope.hs @@ -57,11 +57,11 @@ -- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renaming π) : Term Γ -> Term Δ@ renaming :: Permutation -> Substitution -renaming p = gamma' +renaming p = gammaAux where - n = size p - gamma = safePermute (reverseP $ invertP (-1) $ reverseP p) $ map var [0..] - gamma' = prependS __IMPOSSIBLE__ gamma (raiseS n) + n = size p + gamma = safePermute (reverseP $ invertP (-1) $ reverseP p) $ map var [0..] + gammaAux = prependS __IMPOSSIBLE__ gamma (raiseS n) -- | If @permute π : [a]Γ -> [a]Δ@, then @substs (renamingR π) : Term Δ -> Term Γ@ renamingR :: Permutation -> Substitution @@ -179,15 +179,35 @@ where absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t +-- | Decomposing a function type. + +mustBePi :: MonadTCM tcm => Type -> tcm (Dom Type, Abs Type) +mustBePi t = liftTCM $ do + t <- reduce t + case ignoreSharing $ unEl t of + Pi a b -> return (a, b) + _ -> __IMPOSSIBLE__ + -- | A safe variant of piApply. piApplyM :: Type -> Args -> TCM Type piApplyM t [] = return t piApplyM t (arg : args) = do - t <- reduce t - case ignoreSharing $ unEl t of - Pi _ b -> absApp b (unArg arg) `piApplyM` args - _ -> __IMPOSSIBLE__ + (_, b) <- mustBePi t + absApp b (unArg arg) `piApplyM` args + +piApply1 :: MonadTCM tcm => Type -> Term -> tcm Type +piApply1 t v = do + (_, b) <- mustBePi t + return $ absApp b v + +-- | Given a function type, introduce its domain into +-- the context and continue with its codomain. + +intro1 :: (MonadTCM tcm) => Type -> (Type -> tcm a) -> tcm a +intro1 t cont = do + (a, b) <- mustBePi t + underAbstraction a b cont --------------------------------------------------------------------------- -- * Instance definitions diff --git a/src/full/Agda/TypeChecking/Test/Generators.hs b/src/full/Agda/TypeChecking/Test/Generators.hs --- a/src/full/Agda/TypeChecking/Test/Generators.hs +++ b/src/full/Agda/TypeChecking/Test/Generators.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} module Agda.TypeChecking.Test.Generators where @@ -433,8 +432,8 @@ noShrink = fmap noShrink instance ShrinkC a b => ShrinkC (Blocked a) (Blocked b) where - shrinkC conf (Blocked m x) = Blocked m <$> shrinkC conf x - shrinkC conf (NotBlocked x) = NotBlocked <$> shrinkC conf x + shrinkC conf (Blocked m x) = Blocked m <$> shrinkC conf x + shrinkC conf (NotBlocked r x) = NotBlocked r <$> shrinkC conf x noShrink = fmap noShrink instance ShrinkC a b => ShrinkC (Elim' a) (Elim' b) where @@ -449,6 +448,7 @@ Type n -> [] -- No Level instance yet -- Type <$> shrinkC conf n Prop -> __IMPOSSIBLE__ Inf -> [] + SizeUniv -> [] DLub s1 s2 -> __IMPOSSIBLE__ noShrink = id diff --git a/src/full/Agda/TypeChecking/Unquote.hs b/src/full/Agda/TypeChecking/Unquote.hs --- a/src/full/Agda/TypeChecking/Unquote.hs +++ b/src/full/Agda/TypeChecking/Unquote.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.Unquote where @@ -318,7 +317,7 @@ __IMPOSSIBLE__ Con c [x, y] -> do choice - [ (c `isCon` primAgdaPatCon, flip ConP Nothing <$> unquoteN x <*> (map (fmap unnamed) <$> unquoteN y)) ] + [ (c `isCon` primAgdaPatCon, flip ConP noConPatternInfo <$> unquoteN x <*> (map (fmap unnamed) <$> unquoteN y)) ] __IMPOSSIBLE__ Con c _ -> __IMPOSSIBLE__ _ -> throwException $ NotAConstructor "Pattern" t diff --git a/src/full/Agda/TypeChecking/With.hs b/src/full/Agda/TypeChecking/With.hs --- a/src/full/Agda/TypeChecking/With.hs +++ b/src/full/Agda/TypeChecking/With.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Agda.TypeChecking.With where @@ -8,28 +8,31 @@ import Control.Monad.State import Data.List -import Data.Maybe (fromMaybe) -import qualified Data.Traversable as T (traverse) +import Data.Maybe +import qualified Data.Traversable as Trav (traverse) -import Agda.Syntax.Common +import Agda.Syntax.Common as Common import Agda.Syntax.Internal as I +import Agda.Syntax.Internal.Pattern import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views import Agda.Syntax.Info import Agda.Syntax.Position import Agda.TypeChecking.Monad -import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce -import Agda.TypeChecking.Pretty -import Agda.TypeChecking.Rules.LHS.Implicit -import Agda.TypeChecking.Patterns.Abstract -import Agda.TypeChecking.Abstract import Agda.TypeChecking.Datatypes import Agda.TypeChecking.EtaContract +import Agda.TypeChecking.Patterns.Abstract +import Agda.TypeChecking.Pretty +import Agda.TypeChecking.Records +import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope -import Agda.Utils.Functor ((<.>)) +import Agda.TypeChecking.Abstract +import Agda.TypeChecking.Rules.LHS.Implicit + +import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Monad import Agda.Utils.Permutation @@ -38,8 +41,6 @@ #include "undefined.h" import Agda.Utils.Impossible --- showPat moved to TypeChecking.Pretty as prettyTCM instance - withFunctionType :: Telescope -> [Term] -> [Type] -> Telescope -> Type -> TCM Type withFunctionType delta1 vs as delta2 b = {-dontEtaContractImplicit $-} do (vas, b) <- addCtxTel delta1 $ do @@ -66,29 +67,22 @@ return $ telePi_ delta1 $ foldr (uncurry piAbstractTerm) b vas -- | Compute the clauses for the with-function given the original patterns. -{- OLD -buildWithFunction :: QName -> Telescope -> [I.Arg Pattern] -> Permutation -> - Nat -> Nat -> [A.Clause] -> TCM [A.Clause] -buildWithFunction aux gamma qs perm n1 n cs = mapM buildWithClause cs - where - buildWithClause (A.Clause (A.LHS i (A.LHSProj{}) wps) rhs wh) = - typeError $ NotImplemented "with clauses for definitions by copatterns" - buildWithClause (A.Clause (A.LHS i (A.LHSHead _ ps) wps) rhs wh) = do - let (wps0, wps1) = genericSplitAt n wps - ps0 = map defaultNamedArg wps0 - rhs <- buildRHS rhs - (ps1, ps2) <- genericSplitAt n1 <$> stripWithClausePatterns gamma qs perm ps - let result = A.Clause (A.LHS i (A.LHSHead aux (ps1 ++ ps0 ++ ps2)) wps1) rhs wh --} -buildWithFunction :: QName -> Telescope -> [I.NamedArg Pattern] -> Permutation -> - Nat -> Nat -> [A.SpineClause] -> TCM [A.SpineClause] -buildWithFunction aux gamma qs perm n1 n cs = mapM buildWithClause cs +buildWithFunction + :: QName -- ^ Name of the with-function. + -> Type -- ^ Types of the parent function. + -> [I.NamedArg Pattern] -- ^ Parent patterns. + -> Permutation -- ^ Final permutation. + -> Nat -- ^ Number of needed vars. + -> Nat -- ^ Number of with expressions. + -> [A.SpineClause] -- ^ With-clauses. + -> TCM [A.SpineClause] -- ^ With-clauses flattened wrt. parent patterns. +buildWithFunction aux t qs perm n1 n cs = mapM buildWithClause cs where buildWithClause (A.Clause (A.SpineLHS i _ ps wps) rhs wh) = do let (wps0, wps1) = genericSplitAt n wps ps0 = map defaultNamedArg wps0 rhs <- buildRHS rhs - (ps1, ps2) <- genericSplitAt n1 <$> stripWithClausePatterns gamma qs perm ps + (ps1, ps2) <- genericSplitAt n1 <$> stripWithClausePatterns aux t qs perm ps let result = A.Clause (A.SpineLHS i aux (ps1 ++ ps0 ++ ps2) wps1) rhs wh reportSDoc "tc.with" 20 $ vcat [ text "buildWithClause returns" <+> prettyA result @@ -99,38 +93,83 @@ buildRHS rhs@A.AbsurdRHS = return rhs buildRHS (A.WithRHS q es cs) = A.WithRHS q es <$> mapM (A.spineToLhs <.> buildWithClause . A.lhsToSpine) cs - buildRHS (A.RewriteRHS q eqs rhs wh) = flip (A.RewriteRHS q eqs) wh <$> buildRHS rhs + buildRHS (A.RewriteRHS qes rhs wh) = flip (A.RewriteRHS qes) wh <$> buildRHS rhs -{-| @stripWithClausePatterns Γ qs π ps = ps'@ +{-| @stripWithClausePatterns f t qs π ps = ps'@ - @Δ@ - context bound by lhs of original function (not an argument) + @Δ@ - context bound by lhs of original function (not an argument) - @Γ@ - type of arguments to original function + @f@ - name of with-function - @qs@ - internal patterns for original function + @t@ - type of the original function - @π@ - permutation taking @vars(qs)@ to @support(Δ)@ + @qs@ - internal patterns for original function - @ps@ - patterns in with clause (presumably of type @Γ@) + @π@ - permutation taking @vars(qs)@ to @support(Δ)@ + @ps@ - patterns in with clause (eliminating type @t@) + @ps'@ - patterns for with function (presumably of type @Δ@) + +Example: +@ +record Stream (A : Set) : Set where + coinductive + constructor delay + field force : A × Stream A + +record SEq (s t : Stream A) : Set where + coinductive + field + ~force : let a , as = force s + b , bs = force t + in a ≡ b × SEq as bs + +test : (s : Nat × Stream Nat) (t : Stream Nat) → SEq (delay s) t → SEq t (delay s) +~force (test (a , as) t p) with force t +~force (test (suc n , as) t p) | b , bs = {!!} + +With function: + + f : (t : Stream Nat) (w : Nat × Stream Nat) (a : Nat) (as : Stream Nat) + (p : SEq (delay (a , as)) t) → (fst w ≡ a) × SEq (snd w) as + + Δ = t a as p -- reorder to bring with-relevant (= needed) vars first + π = a as t p → Δ + qs = (a , as) t p ~force + ps = (suc n , as) t p ~force + ps' = (suc n) as t p + +Resulting with-function clause is: + + f t (b , bs) (suc n) as t p + +Note: stripWithClausePatterns factors ps through qs, thus + + ps = qs[ps'] + +where [..] is to be understood as substitution. +The projection patterns have vanished from ps' (as they are already in qs). +@ -} --- TODO: this does not work for varying arity or copatterns. --- Need to do s.th. like in Split.hs with ProblemRest etc. -stripWithClausePatterns :: Telescope -> [I.NamedArg Pattern] -> Permutation -> [A.NamedArg A.Pattern] -> TCM [A.NamedArg A.Pattern] -stripWithClausePatterns gamma qs perm ps = do +stripWithClausePatterns + :: QName -- ^ @f@ + -> Type -- ^ @t@ + -> [I.NamedArg Pattern] -- ^ @qs@ + -> Permutation -- ^ @π@ + -> [A.NamedArg A.Pattern] -- ^ @ps@ + -> TCM [A.NamedArg A.Pattern] -- ^ @ps'@ +stripWithClausePatterns f t qs perm ps = do -- Andreas, 2014-03-05 expand away pattern synoyms (issue 1074) ps <- expandPatternSynonyms ps - psi <- insertImplicitPatterns ExpandLast ps gamma - unless (size psi == size gamma) $ - typeError $ GenericError $ "Wrong number of arguments in with clause: given " ++ show (size psi) ++ ", expected " ++ show (size gamma) + psi <- insertImplicitPatternsT ExpandLast ps t reportSDoc "tc.with.strip" 10 $ vcat [ text "stripping patterns" - , nest 2 $ text "gamma = " <+> prettyTCM gamma + , nest 2 $ text "t = " <+> prettyTCM t , nest 2 $ text "psi = " <+> fsep (punctuate comma $ map prettyA psi) , nest 2 $ text "qs = " <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs) ] - ps' <- strip gamma psi qs + ps' <- strip (Def f []) t psi $ numberPatVars perm qs let psp = permute perm ps' reportSDoc "tc.with.strip" 10 $ vcat [ nest 2 $ text "ps' = " <+> fsep (punctuate comma $ map prettyA ps') @@ -140,42 +179,64 @@ -- In some cases, permute throws away some dot patterns of ps' -- which are then never checked. if True then return psp else do - -- Andreas, 2014-03-05 Disabled the fix for issue 142, the following is dead code: - forM_ (permute (droppedP perm) ps') $ \ p -> traceCall (SetRange $ getRange p) $ do - reportSDoc "tc.with.strip" 10 $ text "warning: dropped pattern " <+> prettyA p - reportSDoc "tc.with.strip" 60 $ text $ show p - case namedArg p of - A.DotP info e -> case unScope e of - A.Underscore{} -> return () - -- Dot patterns without a range are Agda-generated from a user dot pattern - -- so we only complain if there is a range. - e | getRange info /= noRange -> typeError $ GenericError $ - "This inaccessible pattern is never checked, so only _ allowed here" + -- Andreas, 2014-03-05 Disabled the fix for issue 142, the following is dead code: + forM_ (permute (droppedP perm) ps') $ \ p -> setCurrentRange p $ do + reportSDoc "tc.with.strip" 10 $ text "warning: dropped pattern " <+> prettyA p + reportSDoc "tc.with.strip" 60 $ text $ show p + case namedArg p of + A.DotP info e -> case unScope e of + A.Underscore{} -> return () + -- Dot patterns without a range are Agda-generated from a user dot pattern + -- so we only complain if there is a range. + e | getRange info /= noRange -> typeError $ GenericError $ + "This inaccessible pattern is never checked, so only _ allowed here" + _ -> return () _ -> return () - _ -> return () - return psp + return psp where - -- implicit args inserted at top level - -- all three arguments should have the same size - strip :: Telescope -> [A.NamedArg A.Pattern] -> [I.NamedArg Pattern] -> TCM [A.NamedArg A.Pattern] - strip _ [] (_ : _) = __IMPOSSIBLE__ - strip _ (_ : _) [] = __IMPOSSIBLE__ - strip EmptyTel (_ : _) _ = __IMPOSSIBLE__ - strip ExtendTel{} [] _ = __IMPOSSIBLE__ - strip EmptyTel [] [] = return [] - strip tel0@(ExtendTel a tel) ps0@(p0 : ps) qs0@(q : qs) = do + + strip + :: Term -- ^ Self. + -> Type -- ^ The type to be eliminated. + -> [A.NamedArg A.Pattern] -- ^ With-clause patterns. + -> [I.NamedArg DeBruijnPattern] -- ^ Parent-clause patterns with de Bruijn indices relative to Δ. + -> TCM [A.NamedArg A.Pattern] -- ^ With-clause patterns decomposed by parent-clause patterns. + + -- Case: out of with-clause patterns. + strip _ _ [] (_ : _) = + typeError $ GenericError $ "Too few arguments given in with-clause" + + -- Case: out of parent-clause patterns. + -- This is only ok if all remaining with-clause patterns + -- are implicit patterns (we inserted too many). + strip _ _ ps [] = do + let implicit (A.ImplicitP{}) = True + implicit (A.ConP ci _ _) = patImplicit ci + implicit _ = False + unless (all (implicit . namedArg) ps) $ + typeError $ GenericError $ "Too many arguments given in with-clause" + return [] + + -- Case: both parent-clause pattern and with-clause pattern present. + -- Make sure they match, and decompose into subpatterns. + strip self t ps0@(p0 : ps) qs0@(q : qs) = do p <- expandLitPattern p0 reportSDoc "tc.with.strip" 15 $ vcat [ text "strip" , nest 2 $ text "ps0 =" <+> fsep (punctuate comma $ map prettyA ps0) , nest 2 $ text "exp =" <+> prettyA p , nest 2 $ text "qs0 =" <+> fsep (punctuate comma $ map (prettyTCM . namedArg) qs0) - , nest 2 $ text "tel0=" <+> prettyTCM tel0 + , nest 2 $ text "t =" <+> prettyTCM t ] case namedArg q of - ProjP{} -> strip tel0 ps qs - VarP _ -> do - ps <- underAbstraction a tel $ \tel -> strip tel ps qs + ProjP d -> case A.isProjP p of + Just d' | d == d' -> do + t1 <- fromMaybe __IMPOSSIBLE__ <$> projectType t d + strip (self `applyE` [Proj d]) t1 ps qs + _ -> mismatch + + VarP (i, _x) -> do + ps <- intro1 t $ \ t -> strip (self `apply1` var i) t ps qs return $ p : ps DotP v -> case namedArg p of @@ -197,33 +258,26 @@ "also be inaccessible in the with clause, when checking the " ++ "pattern " ++ show d ++ "," where - ok p = (p :) <$> strip (tel `absApp` v) ps qs + ok p = do + t' <- piApply1 t v + (p :) <$> strip (self `apply1` v) t' ps qs ConP c ci qs' -> do reportSDoc "tc.with.strip" 60 $ text "parent pattern is constructor " <+> prettyTCM c + (a, b) <- mustBePi t case namedArg p of -- Andreas, 2013-03-21 if we encounter an implicit pattern in the with-clause -- that has been expanded in the parent clause, we expand it and restart - A.ImplicitP _ | Just (True, _) <- ci -> do - maybe __IMPOSSIBLE__ (\ p -> strip tel0 (p : ps) qs0) =<< + A.ImplicitP _ | Just True <- conPRecord ci -> do + maybe __IMPOSSIBLE__ (\ p -> strip self t (p : ps) qs0) =<< expandImplicitPattern' (unDom a) p A.ConP _ (A.AmbQ cs') ps' -> do -{- OLD - Con c' [] <- ignoreSharing <$> (constructorForm =<< reduce (Con c [])) - c <- return $ c' `withRangeOf` c --} c <- (`withRangeOf` c) <$> do getConForm $ conName c cs' <- mapM getConForm cs' -{- OLD - let getCon (Con c []) = c - getCon (Shared p) = getCon (derefPtr p) - getCon _ = __IMPOSSIBLE__ - cs' <- map getCon <$> (mapM constructorForm =<< mapM (\c' -> reduce $ Con c' []) cs') --} unless (elem c cs') mismatch -- The type is a datatype @@ -231,8 +285,6 @@ let us = fromMaybe __IMPOSSIBLE__ $ allApplyElims es -- Compute the argument telescope for the constructor --- ALREADY normal: --- Con c [] <- ignoreSharing <$> (constructorForm =<< normalise (Con c [])) Defn {defType = ct, theDef = Constructor{conPars = np}} <- getConInfo c let ct' = ct `apply` genericTake np us TelV tel' _ <- telView ct' @@ -245,26 +297,26 @@ , text "us' = " <+> prettyList (map prettyTCM $ genericTake np us) ] - -- Compute the new telescope + -- Compute the new type let v = Con c [ Arg info (var i) | (i, Arg info _) <- zip (downFrom $ size qs') qs' ] --- let v = Con c $ reverse [ Arg h r (var i) | (i, Arg h r _) <- zip [0..] $ reverse qs' ] - tel'' = tel' `abstract` absApp (raise (size tel') tel) v + t' = tel' `abstract` absApp (raise (size tel') b) v reportSDoc "tc.with.strip" 15 $ sep [ text "inserting implicit" , nest 2 $ prettyList $ map prettyA (ps' ++ ps) - , nest 2 $ text ":" <+> prettyTCM tel'' + , nest 2 $ text ":" <+> prettyTCM t' ] -- Insert implicit patterns (just for the constructor arguments) psi' <- insertImplicitPatterns ExpandLast ps' tel' - unless (size psi' == size tel') $ typeError $ WrongNumberOfConstructorArguments (conName c) (size tel') (size psi') + unless (size psi' == size tel') $ typeError $ + WrongNumberOfConstructorArguments (conName c) (size tel') (size psi') -- Do it again for everything (is this necessary?) - psi' <- insertImplicitPatterns ExpandLast (psi' ++ ps) tel'' + psi' <- insertImplicitPatternsT ExpandLast (psi' ++ ps) t' -- Keep going - strip tel'' psi' (qs' ++ qs) + strip (self `apply1` v) t' psi' (qs' ++ qs) p@(A.PatternSynP pi' c' ps') -> do reportSDoc "impossible" 10 $ @@ -277,7 +329,10 @@ mismatch LitP lit -> case namedArg p of - A.LitP lit' | lit == lit' -> strip (tel `absApp` Lit lit) ps qs + A.LitP lit' | lit == lit' -> do + (a, b) <- mustBePi t + let v = Lit lit + strip (self `apply1` v) (b `absApp` v) ps qs p@(A.PatternSynP pi' c' [ps']) -> do reportSDoc "impossible" 10 $ @@ -286,9 +341,8 @@ _ -> mismatch where - mismatch = typeError $ WithClausePatternMismatch (namedArg p0) (namedArg q) - -- UNREACHABLE: - -- strip tel ps qs = error $ "huh? " ++ show (size tel) ++ " " ++ show (size ps) ++ " " ++ show (size qs) + mismatch = typeError $ + WithClausePatternMismatch (namedArg p0) (snd <$> namedArg q) -- | Construct the display form for a with function. It will display -- applications of the with function as applications to the original function. @@ -311,31 +365,32 @@ let arity0 = n + size delta1 + size delta2 -- The currently free variables have to be added to the front. topArgs <- raise arity0 <$> getContextArgs - let top = genericLength topArgs + let top = length topArgs arity = arity0 + top -- Build the rhs of the display form. - x <- freshNoName_ - let wild = Def (qualify (mnameFromList []) x) [] - -- Building the arguments to the with function - (ys0, ys1) = splitAt (size delta1) (permute perm $ map Just [m - 1, m - 2..0]) - ys = reverse $ ys0 ++ genericReplicate n Nothing ++ ys1 - - let tqs = patsToTerms lhsPerm qs - vs = map (fmap DTerm) topArgs ++ applySubst (sub top ys wild) tqs - withArgs = map var $ genericTake n $ downFrom $ size delta2 + n - dt = DWithApp (DDef f vs) (map DTerm withArgs) [] + wild <- freshNoName_ <&> \ x -> Def (qualify_ x) [] + let -- Convert the parent patterns to terms. + tqs0 = patsToElims lhsPerm qs + -- Build a substitution to replace the parent pattern vars + -- by the pattern vars of the with-function. + (ys0, ys1) = splitAt (size delta1) $ permute perm $ downFrom m + ys = reverse $ map Just ys0 ++ replicate n Nothing ++ map Just ys1 + rho = sub top ys wild + tqs = applySubst rho tqs0 + -- Build the arguments to the with function. + es = map (Apply . fmap DTerm) topArgs ++ tqs + withArgs = map var $ take n $ downFrom $ size delta2 + n + dt = DWithApp (DDef f es) (map DTerm withArgs) [] - -- Build the lhs of the display form. + -- Build the lhs of the display form and finish. -- @var 0@ is the pattern variable (hole). - let pats = genericReplicate arity (var 0) + let display = Display arity (replicate arity $ var 0) dt - let display = Display arity pats dt - addFullCtx = addCtxTel delta1 - . flip (foldr addCtxString_) (map ("w" ++) $ map show [1..n]) + -- Debug printing. + let addFullCtx = addCtxTel delta1 + . flip (foldr addContext) (for [1..n] $ \ i -> "w" ++ show i) . addCtxTel delta2 - -- Andreas 2012-09-17: this seems to be the right order of contexts - reportSDoc "tc.with.display" 20 $ vcat [ text "withDisplayForm" , nest 2 $ vcat @@ -350,74 +405,51 @@ , text "dt =" <+> do addFullCtx $ prettyTCM dt , text "ys =" <+> text (show ys) , text "raw =" <+> text (show display) - , text "qsToTm =" <+> prettyTCM tqs -- ctx would be permuted form of delta1 ++ delta2 - , text "sub qs =" <+> prettyTCM (applySubst (sub top ys wild) tqs) + , text "qsToTm =" <+> prettyTCM tqs0 -- ctx would be permuted form of delta1 ++ delta2 + , text "sub qs =" <+> prettyTCM tqs ] ] return display where - -- Note: The upper bound (m - 1) was previously commented out. I - -- restored it in order to make the substitution finite. - -- Andreas, 2013-02-28: Who is "I"? - sub top rho wild = parallelS $ map term [0 .. m - 1] ++ topTerms + -- Ulf, 2014-02-19: We need to rename the module parameters as well! (issue1035) + sub top ys wild = map term [0 .. m - 1] ++# raiseS (length qs) where - -- Ulf, 2014-02-19: We need to rename the module parameters as well! (issue1035) - newVars = genericLength qs - topTerms = [ var (i + newVars) | i <- [0..top - 1] ] - -- thinking required.. but ignored - -- dropping the reverse seems to work better - -- Andreas, 2010-09-09: I DISAGREE. - -- Ulf, 2011-09-02: Thinking done. Neither was correct. - -- We had the wrong permutation and we used it incorrectly. Should work now. - term i = maybe wild var $ findIndex (Just i ==) rho + term i = maybe wild var $ findIndex (Just i ==) ys + -- OLD + -- sub top rho wild = parallelS $ map term [0 .. m - 1] ++ topTerms + -- where + -- -- Ulf, 2014-02-19: We need to rename the module parameters as well! (issue1035) + -- newVars = length qs + -- topTerms = [ var (i + newVars) | i <- [0..top - 1] ] + -- -- thinking required.. but ignored + -- -- dropping the reverse seems to work better + -- -- Andreas, 2010-09-09: I DISAGREE. + -- -- Ulf, 2011-09-02: Thinking done. Neither was correct. + -- -- We had the wrong permutation and we used it incorrectly. Should work now. + -- term i = maybe wild var $ findIndex (Just i ==) rho +-- Andreas, 2014-12-05 refactored using numberPatVars -- Andreas, 2013-02-28 modeled after Coverage/Match/buildMPatterns -- The permutation is the one of the original clause. -patsToTerms :: Permutation -> [I.NamedArg Pattern] -> [I.Arg DisplayTerm] -patsToTerms perm ps = evalState (toTerms ps) xs - where - xs = permute (invertP __IMPOSSIBLE__ perm) $ downFrom (size perm) - tick = do x : xs <- get; put xs; return x - - toTerms :: [I.NamedArg Pattern] -> State [Nat] [I.Arg DisplayTerm] - toTerms ps = mapM (T.traverse $ toTerm . namedThing) ps - - toTerm :: Pattern -> State [Nat] DisplayTerm - toTerm p = case p of - ProjP d -> __IMPOSSIBLE__ -- TODO: convert spine to non-spine ... DDef d . defaultArg - VarP _ -> DTerm . var <$> tick - DotP t -> DDot t <$ tick - ConP c _ ps -> DCon c <$> toTerms ps - LitP l -> return $ DTerm (Lit l) - -{- OLD --- Andreas, 2013-02-28: this translation does not take the permutation --- into account. I replaced it with a new one (see above). --- There are so many similar implementations to translate patterns in Agda, --- opportunity for some refactoring!? - -patsToTerms :: [I.Arg Pattern] -> [I.Arg DisplayTerm] -patsToTerms ps = evalState (toTerms ps) 0 +patsToElims :: Permutation -> [I.NamedArg Pattern] -> [I.Elim' DisplayTerm] +patsToElims perm ps = toElims $ numberPatVars perm ps where - mapMr f xs = reverse <$> mapM f (reverse xs) - - nextVar :: State Nat Nat - nextVar = do - i <- get - put (i + 1) - return i + toElims :: [I.NamedArg DeBruijnPattern] -> [I.Elim' DisplayTerm] + toElims = map $ toElim . fmap namedThing - toTerms :: [I.Arg Pattern] -> State Nat [I.Arg DisplayTerm] - toTerms ps = mapMr toArg ps + toElim :: I.Arg DeBruijnPattern -> I.Elim' DisplayTerm + toElim (Common.Arg ai p) = case p of + ProjP d -> I.Proj d + p -> I.Apply $ Common.Arg ai $ toTerm p - toArg :: I.Arg Pattern -> State Nat (I.Arg DisplayTerm) - toArg = T.mapM toTerm + toTerms :: [I.NamedArg DeBruijnPattern] -> [I.Arg DisplayTerm] + toTerms = map $ fmap $ toTerm . namedThing - toTerm :: Pattern -> State Nat DisplayTerm + toTerm :: DeBruijnPattern -> DisplayTerm toTerm p = case p of - VarP _ -> nextVar >>= \i -> return $ DTerm (var i) - DotP t -> return $ DDot t - ConP c _ ps -> DCon c <$> toTerms ps - LitP l -> return $ DTerm (Lit l) --} + ProjP d -> DDef d [] -- WRONG. TODO: convert spine to non-spine ... DDef d . defaultArg + VarP (i, x) -> DTerm $ var i + DotP t -> DDot $ t + ConP c _ ps -> DCon c $ toTerms ps + LitP l -> DTerm $ Lit l diff --git a/src/full/Agda/Utils/AssocList.hs b/src/full/Agda/Utils/AssocList.hs --- a/src/full/Agda/Utils/AssocList.hs +++ b/src/full/Agda/Utils/AssocList.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} -- | Additional functions for association lists. diff --git a/src/full/Agda/Utils/Bag.hs b/src/full/Agda/Utils/Bag.hs --- a/src/full/Agda/Utils/Bag.hs +++ b/src/full/Agda/Utils/Bag.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} -- | A simple overlay over Data.Map to manage unordered sets with duplicates. @@ -19,7 +19,7 @@ import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set -import qualified Data.Traversable as Trav +import Data.Traversable import Agda.Utils.Functor import Agda.Utils.QuickCheck @@ -128,11 +128,12 @@ ff (a : as) = (b, b : List.map f as) where b = f a ff [] = __IMPOSSIBLE__ -traverse :: forall a b m . (Applicative m, Ord b) => (a -> m b) -> Bag a -> m (Bag b) -traverse f = (Bag . Map.fromListWith (++)) <.> Trav.traverse trav . Map.elems . bag +traverse' :: forall a b m . (Applicative m, Ord b) => + (a -> m b) -> Bag a -> m (Bag b) +traverse' f = (Bag . Map.fromListWith (++)) <.> traverse trav . Map.elems . bag where trav :: [a] -> m (b, [b]) - trav (a : as) = (\ b bs -> (b, b:bs)) <$> f a <*> Trav.traverse f as + trav (a : as) = (\ b bs -> (b, b:bs)) <$> f a <*> traverse f as trav [] = __IMPOSSIBLE__ ------------------------------------------------------------------------ @@ -195,7 +196,7 @@ prop_map_compose f g b = map f (map g b) == map (f . g) b prop_traverse_id :: Ord a => Bag a -> Bool -prop_traverse_id b = traverse Identity b == Identity b +prop_traverse_id b = traverse' Identity b == Identity b ------------------------------------------------------------------------ -- * All tests diff --git a/src/full/Agda/Utils/BiMap.hs b/src/full/Agda/Utils/BiMap.hs --- a/src/full/Agda/Utils/BiMap.hs +++ b/src/full/Agda/Utils/BiMap.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} -- | Finite bijections (implemented as a pair of maps). @@ -20,7 +20,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Tuple -import Data.Typeable +import Data.Typeable ( Typeable ) import Test.QuickCheck import Test.QuickCheck.All diff --git a/src/full/Agda/Utils/Cluster.hs b/src/full/Agda/Utils/Cluster.hs --- a/src/full/Agda/Utils/Cluster.hs +++ b/src/full/Agda/Utils/Cluster.hs @@ -1,6 +1,6 @@ --- {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TemplateHaskell #-} --- {-# LANGUAGE TupleSections #-} +-- {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +-- {-# LANGUAGE TupleSections #-} -- | Create clusters of non-overlapping things. diff --git a/src/full/Agda/Utils/Empty.hs b/src/full/Agda/Utils/Empty.hs --- a/src/full/Agda/Utils/Empty.hs +++ b/src/full/Agda/Utils/Empty.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} -- | An empty type with some useful instances. diff --git a/src/full/Agda/Utils/Except.hs b/src/full/Agda/Utils/Except.hs --- a/src/full/Agda/Utils/Except.hs +++ b/src/full/Agda/Utils/Except.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ -- | Wrapper for Control.Monad.Except from the mtl package diff --git a/src/full/Agda/Utils/Favorites.hs b/src/full/Agda/Utils/Favorites.hs --- a/src/full/Agda/Utils/Favorites.hs +++ b/src/full/Agda/Utils/Favorites.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} +-- GHC 7.4.2 requires this layout for the pragmas. See Issue 1460. +{-# LANGUAGE CPP, + DeriveFoldable, + GeneralizedNewtypeDeriving, + ScopedTypeVariables, + TemplateHaskell #-} -- | Maintaining a list of favorites of some partially ordered type. -- Only the best elements are kept. @@ -15,6 +16,7 @@ module Agda.Utils.Favorites where +import Prelude hiding ( null ) import Control.Monad import Data.Bool @@ -34,8 +36,10 @@ import Text.Show import Test.QuickCheck.All +import Agda.Utils.Null import Agda.Utils.PartialOrd hiding (tests) import Agda.Utils.QuickCheck +import Agda.Utils.Singleton import Agda.Utils.TestHelpers import Agda.Utils.Tuple @@ -44,25 +48,13 @@ -- | A list of incomparable favorites. newtype Favorites a = Favorites { toList :: [a] } - deriving (Foldable, Show, CoArbitrary) + deriving (Foldable, Show, CoArbitrary, Null, Singleton a) -- | Equality checking is a bit expensive, since we need to sort! -- Maybe use a 'Set' of favorites in the first place? instance Ord a => Eq (Favorites a) where as == bs = Set.fromList (toList as) == Set.fromList (toList bs) --- | No favories yet? -null :: Favorites a -> Bool -null = List.null . toList - --- | No favorites yet. Poor me! -empty :: Favorites a -empty = Favorites [] - --- | You are my one and only, darling! -singleton :: a -> Favorites a -singleton a = Favorites [a] - -- | Result of comparing a candidate with the current favorites. data CompareResult a = Dominates { dominated :: [a], notDominated :: [a] } @@ -152,10 +144,10 @@ arbitrary = fromList <$> arbitrary property_null_empty :: Bool -property_null_empty = null empty +property_null_empty = null (empty :: Favorites ()) -property_not_null_singleton :: a -> Bool -property_not_null_singleton = not . null . singleton +property_not_null_singleton :: forall a. a -> Bool +property_not_null_singleton x = not $ null (singleton x :: Favorites a) -- Remember: less is better! diff --git a/src/full/Agda/Utils/FileName.hs b/src/full/Agda/Utils/FileName.hs --- a/src/full/Agda/Utils/FileName.hs +++ b/src/full/Agda/Utils/FileName.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-| Operations on file names. -} @@ -27,6 +27,7 @@ import Data.Function import Data.Typeable (Typeable) +import Agda.Utils.Pretty import Agda.Utils.TestHelpers import Agda.Utils.QuickCheck @@ -51,8 +52,15 @@ filePath :: AbsolutePath -> FilePath filePath = ByteString.unpack . byteStringPath +-- TODO: 'Show' should output Haskell-parseable representations. +-- The following instance is deprecated, and Pretty should be used +-- instead. Later, simply derive Show for this type. + instance Show AbsolutePath where show = filePath + +instance Pretty AbsolutePath where + pretty = text . filePath -- | The paths have to be absolute, valid and normalised, without -- trailing path separators. diff --git a/src/full/Agda/Utils/Functor.hs b/src/full/Agda/Utils/Functor.hs --- a/src/full/Agda/Utils/Functor.hs +++ b/src/full/Agda/Utils/Functor.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} -- | Utilities for functors. @@ -13,12 +13,15 @@ import Data.Functor.Identity import Data.Functor.Compose import Data.Functor.Constant +import Data.Functor.Classes --- ASR (15 October 2014): See issue 1304. -#if !MIN_VERSION_transformers(0,4,1) -instance Eq a => Eq (Identity a) where - Identity x == Identity x' = x == x' -#endif +-- Andreas, 2015-05-06, see issue 1501. +-- This instance can be obtained from transformers-compat. +-- -- ASR (15 October 2014): See issue 1304. +-- #if !MIN_VERSION_transformers(0,4,1) +-- instance Eq a => Eq (Identity a) where +-- Identity x == Identity x' = x == x' +-- #endif infixr 4 $> @@ -65,7 +68,7 @@ dmap :: Decoration t => (a -> b) -> t a -> t b dmap f = runIdentity . traverseF (Identity . f) --- | Any decoration is a lens. @set@ is a special case of @fmap@. +-- | Any decoration is a lens. @set@ is a special case of @dmap@. dget :: Decoration t => t a -> a dget = getConstant . traverseF Constant diff --git a/src/full/Agda/Utils/Graph/AdjacencyMap.hs b/src/full/Agda/Utils/Graph/AdjacencyMap.hs --- a/src/full/Agda/Utils/Graph/AdjacencyMap.hs +++ b/src/full/Agda/Utils/Graph/AdjacencyMap.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} -- | Directed graphs (can of course simulate undirected graphs). -- diff --git a/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs b/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs --- a/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs +++ b/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DoAndIfThenElse #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} -- | Directed graphs (can of course simulate undirected graphs). -- diff --git a/src/full/Agda/Utils/Impossible.hs b/src/full/Agda/Utils/Impossible.hs --- a/src/full/Agda/Utils/Impossible.hs +++ b/src/full/Agda/Utils/Impossible.hs @@ -7,7 +7,7 @@ module Agda.Utils.Impossible where import Control.Exception as E -import Data.Typeable +import Data.Typeable ( Typeable ) -- | \"Impossible\" errors, annotated with a file name and a line -- number corresponding to the source code location of the error. diff --git a/src/full/Agda/Utils/Lens.hs b/src/full/Agda/Utils/Lens.hs --- a/src/full/Agda/Utils/Lens.hs +++ b/src/full/Agda/Utils/Lens.hs @@ -10,6 +10,7 @@ import Control.Monad.State import Control.Monad.Reader +import Control.Monad.Writer import Data.Functor.Constant import Data.Functor.Identity @@ -45,16 +46,29 @@ use :: MonadState o m => Lens' i o -> m i use l = gets (^. l) -infix 4 .= +infix 4 .= -- | Write a part of the state. (.=) :: MonadState o m => Lens' i o -> i -> m () l .= i = modify $ set l i -infix 4 %= +infix 4 %= -- | Modify a part of the state. (%=) :: MonadState o m => Lens' i o -> (i -> i) -> m () l %= f = modify $ over l f +infix 4 %== +-- | Modify a part of the state monadically. +(%==) :: (MonadState o m, Functor m) => Lens' i o -> (i -> m i) -> m () +l %== f = put =<< l f =<< get + +infix 4 %%= +-- | Modify a part of the state monadically, and return some result. +(%%=) :: (MonadState o m, Functor m) => Lens' i o -> (i -> m (i, r)) -> m r +l %%= f = do + o <- get + (o', r) <- runWriterT $ l (WriterT . f) o + put o' + return r -- * Read-only state accessors and modifiers. diff --git a/src/full/Agda/Utils/Lens/Examples.hs b/src/full/Agda/Utils/Lens/Examples.hs --- a/src/full/Agda/Utils/Lens/Examples.hs +++ b/src/full/Agda/Utils/Lens/Examples.hs @@ -1,4 +1,4 @@ --- | Examples how to use 'Agda.Utils.Lens'. +-- | Examples how to use "Agda.Utils.Lens". module Agda.Utils.Lens.Examples where diff --git a/src/full/Agda/Utils/List.hs b/src/full/Agda/Utils/List.hs --- a/src/full/Agda/Utils/List.hs +++ b/src/full/Agda/Utils/List.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE TemplateHaskell #-} {-| Utitlity functions on lists. diff --git a/src/full/Agda/Utils/ListT.hs b/src/full/Agda/Utils/ListT.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/ListT.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} -- Due to limitations of funct.dep. + +-- | @ListT@ done right, +-- see https://www.haskell.org/haskellwiki/ListT_done_right_alternative +-- +-- There is also the @list-t@ package on hackage (Nikita Volkov) +-- but it again depends on other packages we do not use yet, +-- so we rather implement the few bits we need afresh. + +module Agda.Utils.ListT where + +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans + +import Data.Functor +import Data.Monoid + +import Agda.Utils.Maybe +import Agda.Utils.Monad + +-- | Lazy monadic computation of a list of results. +newtype ListT m a = ListT { runListT :: m (Maybe (a, ListT m a)) } + deriving (Functor) + +-- * List operations + +-- | The empty lazy list. +nilListT :: Monad m => ListT m a +nilListT = ListT $ return Nothing + +-- | Consing a value to a lazy list. +consListT :: Monad m => a -> ListT m a -> ListT m a +consListT a l = ListT $ return $ Just (a, l) + +-- | Singleton lazy list. +sgListT :: Monad m => a -> ListT m a +sgListT a = consListT a nilListT + +-- | Case distinction over lazy list. +caseListT :: Monad m => ListT m a -> m b -> (a -> ListT m a -> m b) -> m b +caseListT l nil cons = caseMaybeM (runListT l) nil $ uncurry cons + +-- | Folding a lazy list, effects left-to-right. +foldListT :: Monad m => (a -> m b -> m b) -> m b -> ListT m a -> m b +foldListT cons nil = loop where + loop l = caseListT l nil $ \ a l' -> cons a $ loop l' + +-- | The join operation of the @ListT m@ monad. +concatListT :: Monad m => ListT m (ListT m a) -> ListT m a +concatListT = ListT . foldListT append (return Nothing) + where append l = runListT . mappend l . ListT + +-- * Monadic list operations. + +-- | We can ``run'' a computation of a 'ListT' as it is monadic itself. +runMListT :: Monad m => m (ListT m a) -> ListT m a +runMListT ml = ListT $ runListT =<< ml + +-- | Monadic cons. +consMListT :: Monad m => m a -> ListT m a -> ListT m a +consMListT ma l = runMListT $ liftM (`consListT` l) ma + +-- | Monadic singleton. +sgMListT :: Monad m => m a -> ListT m a +sgMListT ma = consMListT ma nilListT + +-- Instances + +instance Monad m => Monoid (ListT m a) where + mempty = nilListT + mappend l1 l2 = ListT $ foldListT cons (runListT l2) l1 + where cons a = runListT . consListT a . ListT + +instance (Functor m, Applicative m, Monad m) => Alternative (ListT m) where + empty = mempty + (<|>) = mappend + +instance (Functor m, Applicative m, Monad m) => MonadPlus (ListT m) where + mzero = mempty + mplus = mappend + +instance (Functor m, Applicative m, Monad m) => Applicative (ListT m) where + pure = return + (<*>) = ap + + -- Another Applicative, but not the canonical one. + -- l1 <*> l2 = ListT $ loop <$> runListT l1 <*> runListT l2 + -- where + -- loop (Just (f, l1')) (Just (a, l2')) = Just (f a, l1' <*> l2') + -- loop _ _ = Nothing + +instance (Functor m, Applicative m, Monad m) => Monad (ListT m) where + return = sgListT + l >>= k = concatListT $ k <$> l + +instance MonadTrans ListT where + lift = sgMListT + +instance (Applicative m, MonadIO m) => MonadIO (ListT m) where + liftIO = lift . liftIO + +instance (Applicative m, MonadReader r m) => MonadReader r (ListT m) where + ask = lift ask + local f = ListT . local f . runListT + +instance (Applicative m, MonadState s m) => MonadState s (ListT m) where + get = lift get + put = lift . put diff --git a/src/full/Agda/Utils/ListT/Tests.hs b/src/full/Agda/Utils/ListT/Tests.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/ListT/Tests.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Quickcheck properties for 'Agda.Utils.ListT'. + +module Agda.Utils.ListT.Tests (tests) where + +import Control.Applicative + +import Data.Functor +import Data.Functor.Identity + +import Test.QuickCheck +import Test.QuickCheck.All + +import Agda.Utils.Functor +import Agda.Utils.ListT + +-- * Identity monad instance of ListT (simply lists) + +type List = ListT Identity + +foldList :: (a -> b -> b) -> b -> List a -> b +foldList cons nil l = runIdentity $ foldListT c (Identity nil) l + where c a = Identity . cons a . runIdentity + +fromList :: [a] -> List a +fromList = foldr consListT nilListT + +toList :: List a -> [a] +toList = foldList (:) [] + +instance Arbitrary a => Arbitrary (List a) where + arbitrary = fromList <$> arbitrary + +prop_concat xxs = toList (concatListT (fromList (map fromList xxs))) == concat xxs + +prop_idiom fs xs = toList (fromList fs <*> fromList xs) == (fs <*> xs) + +prop_concatMap f xs = toList (fromList . f =<< fromList xs) == (f =<< xs) + +-- Template Haskell hack to make the following $quickCheckAll work +-- under ghc-7.8. +return [] -- KEEP! + +-- | All tests as collected by 'quickCheckAll'. +tests :: IO Bool +tests = do + putStrLn "Agda.Utils.Permutation" + $quickCheckAll diff --git a/src/full/Agda/Utils/Map/Compat.hs b/src/full/Agda/Utils/Map/Compat.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/Map/Compat.hs @@ -0,0 +1,20 @@ +{- We need to keep the dependency on containers below 5.0 in + order to avoid giving rise to unsolvable constraints on + older versions of GHC (7.4.2 at the moment) -} + +{-# LANGUAGE CPP #-} + +module Agda.Utils.Map.Compat where + +import Control.Applicative +import Data.Traversable +import qualified Data.Map as Map +import Data.Map (Map, fromList, toList) + +traverseWithKey :: (Ord k, Applicative t) => (k -> a -> t b) -> Map k a -> t (Map k b) +#if !MIN_VERSION_containers(5,0,0) +traverseWithKey f m = fromList <$> traverse (\ (k, v) -> (,) k <$> f k v) (toList m) +#else +traverseWithKey = Map.traverseWithKey +#endif + diff --git a/src/full/Agda/Utils/Maybe/Strict.hs b/src/full/Agda/Utils/Maybe/Strict.hs --- a/src/full/Agda/Utils/Maybe/Strict.hs +++ b/src/full/Agda/Utils/Maybe/Strict.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} #if __GLASGOW_HASKELL__ >= 706 @@ -6,7 +6,7 @@ #endif {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -39,14 +39,15 @@ import Control.Applicative (pure, (<$>)) import Control.DeepSeq (NFData (..)) import Data.Binary (Binary (..)) -#if MIN_VERSION_base(4,7,0) -import Data.Data (Data (..), Typeable) -#else -import Data.Data (Data (..), Typeable1 (..)) -#endif +import Data.Data (Data (..)) import Data.Monoid (Monoid (..)) import Data.Foldable (Foldable (..)) import Data.Traversable (Traversable (..)) +#if MIN_VERSION_base(4,7,0) +import Data.Typeable (Typeable) +#else +import Data.Typeable (Typeable1) +#endif import Data.Strict.Maybe (Maybe (Nothing, Just), fromJust, fromMaybe, isJust, isNothing, maybe) #if __GLASGOW_HASKELL__ >= 706 diff --git a/src/full/Agda/Utils/Monad.hs b/src/full/Agda/Utils/Monad.hs --- a/src/full/Agda/Utils/Monad.hs +++ b/src/full/Agda/Utils/Monad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} module Agda.Utils.Monad @@ -6,6 +6,9 @@ , module Control.Monad , (<$>), (<*>) , (<$) +#if MIN_VERSION_mtl(2,2,0) + , Control.Monad.State.modify' +#endif ) where @@ -28,6 +31,10 @@ #include "undefined.h" import Agda.Utils.Impossible +-- | Binary bind. +(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c +k ==<< (ma, mb) = ma >>= \ a -> k a =<< mb + -- Conditionals and monads ------------------------------------------------ -- | @when_@ is just @Control.Monad.when@ with a more general type. @@ -133,7 +140,7 @@ finally :: (Error e, MonadError e m) => m a -> m b -> m a first `finally` after = do r <- catchError (liftM Right first) (return . Left) - after + _ <- after case r of Left e -> throwError e Right r -> return r @@ -149,12 +156,19 @@ bracket_ acquire release compute = do resource <- acquire result <- compute - release resource + _ <- release resource return result -- | Restore state after computation. localState :: MonadState s m => m a -> m a localState = bracket_ get put + +#if !MIN_VERSION_mtl(2,2,0) +modify' :: MonadState s m => (s -> s) -> m () +modify' f = do + x <- get + put $! f x +#endif -- Read ------------------------------------------------------------------- diff --git a/src/full/Agda/Utils/Null.hs b/src/full/Agda/Utils/Null.hs --- a/src/full/Agda/Utils/Null.hs +++ b/src/full/Agda/Utils/Null.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DefaultSignatures #-} + -- | Overloaded @null@ and @empty@ for collections and sequences. module Agda.Utils.Null where @@ -10,6 +12,8 @@ import qualified Data.ByteString.Char8 as ByteString import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -28,6 +32,9 @@ null :: a -> Bool -- ^ Satisfying @null empty == True@. + default null :: Eq a => a -> Bool + null = (== empty) + instance Null () where empty = () null _ = True @@ -52,6 +59,10 @@ empty = IntMap.empty null = IntMap.null +instance Null IntSet where + empty = IntSet.empty + null = IntSet.null + instance Null (Map k a) where empty = Map.empty null = Map.null @@ -64,10 +75,11 @@ empty = Set.empty null = Set.null --- instance Null (Maybe a) where --- empty = Nothing --- null Nothing = True --- null (Just a) = False +-- | A 'Maybe' is 'null' when it corresponds to the empty list. +instance Null (Maybe a) where + empty = Nothing + null Nothing = True + null (Just a) = False -- * Testing for null. diff --git a/src/full/Agda/Utils/PartialOrd.hs b/src/full/Agda/Utils/PartialOrd.hs --- a/src/full/Agda/Utils/PartialOrd.hs +++ b/src/full/Agda/Utils/PartialOrd.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} module Agda.Utils.PartialOrd where diff --git a/src/full/Agda/Utils/Permutation.hs b/src/full/Agda/Utils/Permutation.hs --- a/src/full/Agda/Utils/Permutation.hs +++ b/src/full/Agda/Utils/Permutation.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Agda.Utils.Permutation where -import Prelude hiding (drop) +import Prelude hiding (drop, null) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.List hiding (drop) +import Data.List hiding (drop, null) import qualified Data.List as List import Data.Maybe @@ -23,6 +23,7 @@ import Agda.Utils.Functor import Agda.Utils.List ((!!!)) +import Agda.Utils.Null import Agda.Utils.Size #include "undefined.h" @@ -53,6 +54,10 @@ instance Sized Permutation where size (Perm _ xs) = size xs +instance Null Permutation where + empty = Perm 0 [] + null (Perm _ picks) = null picks + -- | @permute [1,2,0] [x0,x1,x2] = [x1,x2,x0]@ -- More precisely, @permute indices list = sublist@, generates @sublist@ -- from @list@ by picking the elements of list as indicated by @indices@. @@ -226,5 +231,5 @@ unDrop m = dropMore (-m) -- allow picking up more than dropped ------------------------------------------------------------------------ --- * Properties, see 'Agda.Utils.Permutation.Tests' +-- * Properties, see "Agda.Utils.Permutation.Tests". ------------------------------------------------------------------------ diff --git a/src/full/Agda/Utils/Permutation/Tests.hs b/src/full/Agda/Utils/Permutation/Tests.hs --- a/src/full/Agda/Utils/Permutation/Tests.hs +++ b/src/full/Agda/Utils/Permutation/Tests.hs @@ -1,11 +1,11 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} module Agda.Utils.Permutation.Tests (tests) where diff --git a/src/full/Agda/Utils/Pointed.hs b/src/full/Agda/Utils/Pointed.hs deleted file mode 100644 --- a/src/full/Agda/Utils/Pointed.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Agda.Utils.Pointed where - -import Data.Set - --- | Pointed class. --- --- We could have used Data.Pointed by Edward Kmett, but it has a --- lot of package dependencies. -class Pointed f where - point :: a -> f a - -instance Pointed [] where - point a = [a] - -instance Pointed Maybe where - point = Just - -instance Pointed Set where - point = singleton diff --git a/src/full/Agda/Utils/Pointer.hs b/src/full/Agda/Utils/Pointer.hs --- a/src/full/Agda/Utils/Pointer.hs +++ b/src/full/Agda/Utils/Pointer.hs @@ -14,7 +14,7 @@ import Data.IORef import Data.Traversable import System.IO.Unsafe -import Data.Typeable +import Data.Typeable ( Typeable ) data Ptr a = Ptr { ptrTag :: !Integer , ptrRef :: !(IORef a) } @@ -73,4 +73,4 @@ instance Hashable (Ptr a) where hashWithSalt salt = (hashWithSalt salt) . ptrTag -instance NFData (Ptr a) where +instance NFData (Ptr a) where rnf x = seq x () diff --git a/src/full/Agda/Utils/Pretty.hs b/src/full/Agda/Utils/Pretty.hs --- a/src/full/Agda/Utils/Pretty.hs +++ b/src/full/Agda/Utils/Pretty.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} {-| Pretty printing functions. -} @@ -10,8 +10,16 @@ import Data.Function import Data.Int ( Int32 ) -import Text.PrettyPrint hiding (TextDetails(Str)) +import Data.Monoid +import Text.PrettyPrint hiding (TextDetails(Str), empty) + +import Agda.Utils.Null + +instance Null Doc where + empty = mempty + null = (== mempty) + -- * Pretty class -- | While 'Show' is for rendering data in Haskell syntax, @@ -22,11 +30,11 @@ -- implement 'pretty' as @pretty a = text $ ... a ...@. class Pretty a where - pretty :: a -> Doc - prettyPrec :: Int -> a -> Doc + pretty :: a -> Doc + prettyPrec :: Int -> a -> Doc - pretty = prettyPrec 0 - prettyPrec = const pretty + pretty = prettyPrec 0 + prettyPrec = const pretty -- | Use instead of 'show' when printing to world. @@ -35,28 +43,26 @@ -- * Pretty instances -instance Pretty Int where - pretty = text . show - -instance Pretty Int32 where - pretty = text . show - -instance Pretty Integer where - pretty = text . show +instance Pretty Bool where pretty = text . show +instance Pretty Int where pretty = text . show +instance Pretty Int32 where pretty = text . show +instance Pretty Integer where pretty = text . show instance Pretty Char where - pretty c = text [c] - -instance Pretty String where - pretty = text + pretty c = text [c] instance Pretty Doc where - pretty = id + pretty = id +instance Pretty String where + pretty = text + -- * 'Doc' utilities +#if !MIN_VERSION_pretty(1,1,2) instance Eq Doc where (==) = (==) `on` render +#endif pwords :: String -> [Doc] pwords = map text . words diff --git a/src/full/Agda/Utils/ReadP.hs b/src/full/Agda/Utils/ReadP.hs --- a/src/full/Agda/Utils/ReadP.hs +++ b/src/full/Agda/Utils/ReadP.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | @@ -261,7 +261,7 @@ string this = do s <- look; scan this s where scan [] _ = do return this - scan (x:xs) (y:ys) | x == y = do get; scan xs ys + scan (x:xs) (y:ys) | x == y = do _ <- get; scan xs ys scan _ _ = do pfail eof :: ReadP tok () @@ -281,7 +281,7 @@ do s <- look scan s where - scan (c:cs) | p c = do get; s <- scan cs; return (c:s) + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) scan _ = do return [] munch1 :: (t -> Bool) -> ReadP t [t] @@ -302,7 +302,7 @@ do s <- look skip s where - skip (c:s) | isSpace c = do get; skip s + skip (c:s) | isSpace c = do _ <- get; skip s skip _ = do return () count :: Int -> ReadP t a -> ReadP t [a] @@ -313,10 +313,11 @@ between :: ReadP t open -> ReadP t close -> ReadP t a -> ReadP t a -- ^ @between open close p@ parses @open@, followed by @p@ and finally -- @close@. Only the value of @p@ is returned. -between open close p = do open - x <- p - close - return x +between open close p = do + _ <- open + x <- p + _ <- close + return x option :: a -> ReadP t a -> ReadP t a -- ^ @option x p@ will either parse @p@ or return @x@ without consuming @@ -356,12 +357,12 @@ endBy :: ReadP t a -> ReadP t sep -> ReadP t [a] -- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended -- by @sep@. -endBy p sep = many (do x <- p ; sep ; return x) +endBy p sep = many (do x <- p ; _ <- sep ; return x) endBy1 :: ReadP t a -> ReadP t sep -> ReadP t [a] -- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended -- by @sep@. -endBy1 p sep = many1 (do x <- p ; sep ; return x) +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) chainr :: ReadP t a -> ReadP t (a -> a -> a) -> a -> ReadP t a -- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. diff --git a/src/full/Agda/Utils/Singleton.hs b/src/full/Agda/Utils/Singleton.hs new file mode 100644 --- /dev/null +++ b/src/full/Agda/Utils/Singleton.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE TypeFamilies #-} + +-- | Constructing singleton collections. + +module Agda.Utils.Singleton where + +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set + +class Singleton el coll | coll -> el where + singleton :: el -> coll + +instance Singleton a (Maybe a) where singleton = Just +instance Singleton a [a] where singleton = (:[]) +instance Singleton a (Seq a) where singleton = Seq.singleton +instance Singleton a (Set a) where singleton = Set.singleton +instance Singleton Int IntSet where singleton = IntSet.singleton + +instance Singleton (k ,a) (Map k a) where singleton = uncurry Map.singleton +instance Singleton (Int,a) (IntMap a) where singleton = uncurry IntMap.singleton + +instance Hashable a => Singleton a (HashSet a) where singleton = HashSet.singleton +instance Hashable k => Singleton (k,a) (HashMap k a) where singleton = uncurry HashMap.singleton + +-- Testing newtype-deriving: + +-- newtype Wrap c = Wrap c +-- deriving (Singleton k) -- Succeeds + +-- Type family version: + +-- class Singleton c where +-- type Elem c +-- singleton :: Elem c -> c + +-- instance Singleton [a] where +-- type Elem [a] = a +-- singleton = (:[]) + +-- instance Singleton (Maybe a) where +-- type Elem (Maybe a) = a +-- singleton = Just + +-- instance Singleton (Set a) where +-- type Elem (Set a) = a +-- singleton = Set.singleton + +-- instance Singleton (Map k a) where +-- type Elem (Map k a) = (k,a) +-- singleton = uncurry Map.singleton + +-- newtype Wrap a = Wrap a +-- deriving (Singleton) -- Fails + diff --git a/src/full/Agda/Utils/Size.hs b/src/full/Agda/Utils/Size.hs --- a/src/full/Agda/Utils/Size.hs +++ b/src/full/Agda/Utils/Size.hs @@ -1,3 +1,7 @@ +-- | Collection size. +-- +-- For 'TermSize' see "Agda.Syntax.Internal". + module Agda.Utils.Size ( Sized(..) , SizedThing(..) @@ -20,10 +24,9 @@ import Agda.Utils.Null --- | The size of an object. +-- | The size of a collection (i.e., its length). -- --- For collections, it returns the length of the collection, --- not the overall size including the elements. +-- Should fit into an @Int@. TODO: change to @Int@. class Sized a where size :: Integral n => a -> n diff --git a/src/full/Agda/Utils/String.hs b/src/full/Agda/Utils/String.hs --- a/src/full/Agda/Utils/String.hs +++ b/src/full/Agda/Utils/String.hs @@ -1,14 +1,10 @@ -module Agda.Utils.String - ( quote - , showIndex - , addFinalNewLine - , indent - , Str(..) - , showThousandSep - ) where +module Agda.Utils.String where +import Data.Char import Data.List + import Numeric + import Agda.Utils.List -- | 'quote' adds double quotes around the string, replaces newline @@ -63,3 +59,15 @@ showThousandSep :: Show a => a -> String showThousandSep = reverse . intercalate "," . chop 3 . reverse . show + +-- | Remove leading whitespace. +ltrim :: String -> String +ltrim = dropWhile isSpace + +-- | Remove trailing whitespace. +rtrim :: String -> String +rtrim = reverse . ltrim . reverse + +-- | Remove leading and trailing whitesapce. +trim :: String -> String +trim = rtrim . ltrim diff --git a/src/full/Agda/Utils/Suffix.hs b/src/full/Agda/Utils/Suffix.hs --- a/src/full/Agda/Utils/Suffix.hs +++ b/src/full/Agda/Utils/Suffix.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Agda.Utils.Suffix where diff --git a/src/full/Agda/Utils/Time.hs b/src/full/Agda/Utils/Time.hs --- a/src/full/Agda/Utils/Time.hs +++ b/src/full/Agda/Utils/Time.hs @@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 +-- To avoid warning on derived Integral instance for CPUTime. {-# OPTIONS_GHC -fno-warn-identities #-} -#endif --- To avoid warning on derived Integral instance for CPUTime - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Time-related utilities. diff --git a/src/full/Agda/Utils/Trie.hs b/src/full/Agda/Utils/Trie.hs --- a/src/full/Agda/Utils/Trie.hs +++ b/src/full/Agda/Utils/Trie.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} --- | Strict tries (based on 'Data.Map.Strict' and 'Agda.Utils.Maybe.Strict'). +-- | Strict tries (based on "Data.Map.Strict" and "Agda.Utils.Maybe.Strict"). module Agda.Utils.Trie ( Trie diff --git a/src/full/Agda/Utils/Tuple.hs b/src/full/Agda/Utils/Tuple.hs --- a/src/full/Agda/Utils/Tuple.hs +++ b/src/full/Agda/Utils/Tuple.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module Agda.Utils.Tuple where diff --git a/src/full/Agda/Utils/Warshall.hs b/src/full/Agda/Utils/Warshall.hs --- a/src/full/Agda/Utils/Warshall.hs +++ b/src/full/Agda/Utils/Warshall.hs @@ -170,9 +170,8 @@ addFlex :: FlexId -> Scope -> GM () addFlex x scope = do modify $ \ st -> st { flexScope = Map.insert x scope (flexScope st) } - addNode (Flex x) + _ <- addNode (Flex x) return () - -- | Lookup identifier of a node. -- If not present, it is added first.