packages feed

Agda 2.6.2.2 → 2.6.3

raw patch · 311 files changed

+23281/−13175 lines, 311 filesdep +STMonadTransdep +dlistdep +time-compatdep −hashtablesdep −template-haskelldep ~Win32dep ~aesondep ~basesetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: STMonadTrans, dlist, time-compat, vector, vector-hashtables

Dependencies removed: hashtables, template-haskell

Dependency ranges changed: Win32, aeson, base, bytestring, containers, deepseq, split, strict, text, transformers

API changes (from Hackage documentation)

- Agda.Auto.CaseSplit: type family UnifiesTo t;
- Agda.Auto.Convert: copatternsNotImplemented :: TCM a
- Agda.Auto.NarrowingSearch: type family Block a;
- Agda.Compiler.Backend: Axiom :: Bool -> Defn
- Agda.Compiler.Backend: Constructor :: Int -> Int -> ConHead -> QName -> IsAbstract -> Induction -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> Defn
- Agda.Compiler.Backend: DataOrRecSig :: Int -> Defn
- Agda.Compiler.Backend: Datatype :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Defn
- Agda.Compiler.Backend: Function :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> IsAbstract -> Delayed -> Maybe Projection -> Set FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Defn
- Agda.Compiler.Backend: Primitive :: IsAbstract -> String -> [Clause] -> FunctionInverse -> Maybe CompiledClauses -> Defn
- Agda.Compiler.Backend: PrimitiveSort :: String -> Sort -> Defn
- Agda.Compiler.Backend: Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> IsAbstract -> CompKit -> Defn
- Agda.Compiler.Backend: [axiomConstTransp] :: Defn -> Bool
- Agda.Compiler.Backend: [callInfoRange] :: CallInfo -> Range
- Agda.Compiler.Backend: [conAbstr] :: Defn -> IsAbstract
- Agda.Compiler.Backend: [conArity] :: Defn -> Int
- Agda.Compiler.Backend: [conComp] :: Defn -> CompKit
- Agda.Compiler.Backend: [conData] :: Defn -> QName
- Agda.Compiler.Backend: [conErased] :: Defn -> Maybe [Bool]
- Agda.Compiler.Backend: [conForced] :: Defn -> [IsForced]
- Agda.Compiler.Backend: [conInd] :: Defn -> Induction
- Agda.Compiler.Backend: [conPars] :: Defn -> Int
- Agda.Compiler.Backend: [conProj] :: Defn -> Maybe [QName]
- Agda.Compiler.Backend: [conSrcCon] :: Defn -> ConHead
- Agda.Compiler.Backend: [dataAbstr] :: Defn -> IsAbstract
- Agda.Compiler.Backend: [dataClause] :: Defn -> Maybe Clause
- Agda.Compiler.Backend: [dataCons] :: Defn -> [QName]
- Agda.Compiler.Backend: [dataIxs] :: Defn -> Nat
- Agda.Compiler.Backend: [dataMutual] :: Defn -> Maybe [QName]
- Agda.Compiler.Backend: [dataPars] :: Defn -> Nat
- Agda.Compiler.Backend: [dataPathCons] :: Defn -> [QName]
- Agda.Compiler.Backend: [dataSort] :: Defn -> Sort
- Agda.Compiler.Backend: [datarecPars] :: Defn -> Int
- Agda.Compiler.Backend: [funAbstr] :: Defn -> IsAbstract
- Agda.Compiler.Backend: [funClauses] :: Defn -> [Clause]
- Agda.Compiler.Backend: [funCompiled] :: Defn -> Maybe CompiledClauses
- Agda.Compiler.Backend: [funCovering] :: Defn -> [Clause]
- Agda.Compiler.Backend: [funDelayed] :: Defn -> Delayed
- Agda.Compiler.Backend: [funExtLam] :: Defn -> Maybe ExtLamInfo
- Agda.Compiler.Backend: [funFlags] :: Defn -> Set FunctionFlag
- Agda.Compiler.Backend: [funInv] :: Defn -> FunctionInverse
- Agda.Compiler.Backend: [funMutual] :: Defn -> Maybe [QName]
- Agda.Compiler.Backend: [funProjection] :: Defn -> Maybe Projection
- Agda.Compiler.Backend: [funSplitTree] :: Defn -> Maybe SplitTree
- Agda.Compiler.Backend: [funTerminates] :: Defn -> Maybe Bool
- Agda.Compiler.Backend: [funTreeless] :: Defn -> Maybe Compiled
- Agda.Compiler.Backend: [funWith] :: Defn -> Maybe QName
- Agda.Compiler.Backend: [primAbstr] :: Defn -> IsAbstract
- Agda.Compiler.Backend: [primClauses] :: Defn -> [Clause]
- Agda.Compiler.Backend: [primCompiled] :: Defn -> Maybe CompiledClauses
- Agda.Compiler.Backend: [primInv] :: Defn -> FunctionInverse
- Agda.Compiler.Backend: [primName] :: Defn -> String
- Agda.Compiler.Backend: [primSort] :: Defn -> Sort
- Agda.Compiler.Backend: [recAbstr] :: Defn -> IsAbstract
- Agda.Compiler.Backend: [recClause] :: Defn -> Maybe Clause
- Agda.Compiler.Backend: [recComp] :: Defn -> CompKit
- Agda.Compiler.Backend: [recConHead] :: Defn -> ConHead
- Agda.Compiler.Backend: [recEtaEquality'] :: Defn -> EtaEquality
- Agda.Compiler.Backend: [recFields] :: Defn -> [Dom QName]
- Agda.Compiler.Backend: [recInduction] :: Defn -> Maybe Induction
- Agda.Compiler.Backend: [recMutual] :: Defn -> Maybe [QName]
- Agda.Compiler.Backend: [recNamedCon] :: Defn -> Bool
- Agda.Compiler.Backend: [recPars] :: Defn -> Nat
- Agda.Compiler.Backend: [recPatternMatching] :: Defn -> PatternOrCopattern
- Agda.Compiler.Backend: [recTel] :: Defn -> Telescope
- Agda.Compiler.Backend: [stPostMetaStore] :: PostScopeState -> !MetaStore
- Agda.Compiler.Backend: getImports :: TCM (Set ModuleName)
- Agda.Compiler.Backend: getMetaModality :: MetaVariable -> Modality
- Agda.Compiler.Backend: getMetaRelevance :: MetaVariable -> Relevance
- Agda.Compiler.Backend: getMetaStore :: ReadTCState m => m MetaStore
- Agda.Compiler.Backend: getMetaVariables :: ReadTCState m => (MetaVariable -> Bool) -> m [MetaId]
- Agda.Compiler.Backend: isImported :: ModuleName -> TCM Bool
- Agda.Compiler.Backend: lookupMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)
- Agda.Compiler.Backend: lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName)
- Agda.Compiler.Backend: modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()
- Agda.Compiler.Backend: parseVerboseKey :: VerboseKey -> [String]
- Agda.Compiler.Backend: primRewrite :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
- Agda.Compiler.Backend: sourceToModule :: TCM SourceToModule
- Agda.Compiler.Backend: stMetaStore :: Lens' MetaStore TCState
- Agda.Compiler.Backend: theDefLens :: Lens' Defn Definition
- Agda.Compiler.Backend: type MetaStore = IntMap MetaVariable
- Agda.Compiler.Backend: type SourceToModule = Map AbsolutePath TopLevelModuleName
- Agda.Compiler.Backend: verbosity :: VerboseKey -> Lens' VerboseLevel TCState
- Agda.Compiler.JS.Compiler: mergeModules :: Map ModuleName Module -> [(GlobalId, Export)]
- Agda.Interaction.Library.Base: OtherError :: String -> LibError'
- Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.ExecutablesFile
- Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.LibPositionInfo
- Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.LibWarning
- Agda.Interaction.Library.Base: instance Data.Data.Data Agda.Interaction.Library.Base.LibWarning'
- Agda.Interaction.Library.Base: instance GHC.Show.Show Agda.Interaction.Library.Base.LibError'
- Agda.Interaction.Options: [optCompletenessCheck] :: PragmaOptions -> Bool
- Agda.Interaction.Options: [optOptimSmashing] :: CommandLineOptions -> Bool
- Agda.Interaction.Options: [optSubtyping] :: PragmaOptions -> WithDefault 'False
- Agda.Interaction.Options: coinfectiveOptions :: [(PragmaOptions -> Bool, String)]
- Agda.Interaction.Options: defaultVerbosity :: Verbosity
- Agda.Interaction.Options: infectiveOptions :: [(PragmaOptions -> Bool, String)]
- Agda.Interaction.Options: restartOptions :: [(PragmaOptions -> RestartCodomain, String)]
- Agda.Interaction.Options: type OptM = Except String
- Agda.Syntax.Abstract: ETel :: Telescope -> Expr
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.BindName
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.DataDefParams
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.Declaration
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.Expr
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.GeneralizeTelescope
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.LHS
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.LamBinding
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.LetBinding
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.ModuleApplication
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.Pragma
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.ProblemEq
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.RHS
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.ScopeCopyInfo
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.SpineLHS
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.TypedBinding
- Agda.Syntax.Abstract: instance Data.Data.Data Agda.Syntax.Abstract.WhereDeclarations
- Agda.Syntax.Abstract: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Abstract.Binder' a)
- Agda.Syntax.Abstract: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Abstract.LHSCore' e)
- Agda.Syntax.Abstract: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Abstract.Pattern' e)
- Agda.Syntax.Abstract: instance Data.Data.Data lhs => Data.Data.Data (Agda.Syntax.Abstract.Clause' lhs)
- Agda.Syntax.Abstract.Name: instance Data.Data.Data Agda.Syntax.Abstract.Name.AmbiguousQName
- Agda.Syntax.Abstract.Name: instance Data.Data.Data Agda.Syntax.Abstract.Name.ModuleName
- Agda.Syntax.Abstract.Name: instance Data.Data.Data Agda.Syntax.Abstract.Name.Name
- Agda.Syntax.Abstract.Name: instance Data.Data.Data Agda.Syntax.Abstract.Name.QName
- Agda.Syntax.Abstract.Name: instance Data.Data.Data Agda.Syntax.Abstract.Name.Suffix
- Agda.Syntax.Abstract.Name: toTopLevelModuleName :: ModuleName -> TopLevelModuleName
- Agda.Syntax.Abstract.Pattern: type family ADotT p;
- Agda.Syntax.Common: BindHole :: Range -> Ranged Int -> GenPart
- Agda.Syntax.Common: NormalHole :: Range -> NamedArg (Ranged Int) -> GenPart
- Agda.Syntax.Common: WildHole :: Ranged Int -> GenPart
- Agda.Syntax.Common: data GenPart
- Agda.Syntax.Common: instance (Data.Data.Data n, Data.Data.Data m) => Data.Data.Data (Agda.Syntax.Common.ImportDirective' n m)
- Agda.Syntax.Common: instance (Data.Data.Data n, Data.Data.Data m) => Data.Data.Data (Agda.Syntax.Common.ImportedName' n m)
- Agda.Syntax.Common: instance (Data.Data.Data n, Data.Data.Data m) => Data.Data.Data (Agda.Syntax.Common.Renaming' n m)
- Agda.Syntax.Common: instance (Data.Data.Data n, Data.Data.Data m) => Data.Data.Data (Agda.Syntax.Common.Using' n m)
- Agda.Syntax.Common: instance (Data.Data.Data name, Data.Data.Data a) => Data.Data.Data (Agda.Syntax.Common.Named name a)
- Agda.Syntax.Common: instance (Data.Data.Data qn, Data.Data.Data nm, Data.Data.Data p, Data.Data.Data e) => Data.Data.Data (Agda.Syntax.Common.RewriteEqn' qn nm p e)
- Agda.Syntax.Common: instance (GHC.Classes.Eq qn, GHC.Classes.Eq e, GHC.Classes.Eq nm, GHC.Classes.Eq p) => GHC.Classes.Eq (Agda.Syntax.Common.RewriteEqn' qn nm p e)
- Agda.Syntax.Common: instance (GHC.Show.Show qn, GHC.Show.Show e, GHC.Show.Show nm, GHC.Show.Show p) => GHC.Show.Show (Agda.Syntax.Common.RewriteEqn' qn nm p e)
- Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance Agda.Syntax.Position.SetRange Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Access
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Annotation
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ArgInfo
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Associativity
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Cohesion
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ConOrigin
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.CoverageCheck
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Delayed
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Erased
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ExpandedEllipsis
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.FileType
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Fixity
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Fixity'
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.FixityLevel
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.FreeVariables
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Hiding
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Induction
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.InteractionId
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.IsAbstract
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.IsInfix
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.IsInstance
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.IsMacro
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Lock
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.MetaId
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Modality
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ModuleNameHash
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.NameId
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Origin
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Overlappable
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.PatternOrCopattern
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.PositionInName
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.PositivityCheck
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ProblemId
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.ProjOrigin
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Q0Origin
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Q1Origin
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Quantity
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.QωOrigin
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.Relevance
- Agda.Syntax.Common: instance Data.Data.Data Agda.Syntax.Common.UniverseCheck
- Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.HasEta' a)
- Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.Ranged a)
- Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.RecordDirectives' a)
- Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.WithHiding a)
- Agda.Syntax.Common: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Common.WithOrigin a)
- Agda.Syntax.Common: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Common.Arg e)
- Agda.Syntax.Common: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Common.MaybePlaceholder e)
- Agda.Syntax.Common: instance Data.Data.Data m => Data.Data.Data (Agda.Syntax.Common.TerminationCheck m)
- Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: instance GHC.Num.Num Agda.Syntax.Common.MetaId
- Agda.Syntax.Common: instance GHC.Real.Integral Agda.Syntax.Common.MetaId
- Agda.Syntax.Common: instance GHC.Real.Real Agda.Syntax.Common.MetaId
- Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.GenPart
- Agda.Syntax.Common: newtype MetaId
- Agda.Syntax.Common: type family NameOf a;
- Agda.Syntax.Concrete: ETel :: Telescope -> Expr
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.BoundName
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.Declaration
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.DoStmt
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.Expr
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.LHS
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.LHSCore
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.LamClause
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.ModuleApplication
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.ModuleAssignment
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.OpenShortHand
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.Pattern
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.Pragma
- Agda.Syntax.Concrete: instance Data.Data.Data Agda.Syntax.Concrete.RecordDirective
- Agda.Syntax.Concrete: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Concrete.AsName' a)
- Agda.Syntax.Concrete: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Concrete.Binder' a)
- Agda.Syntax.Concrete: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Concrete.FieldAssignment' a)
- Agda.Syntax.Concrete: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Concrete.LamBinding' a)
- Agda.Syntax.Concrete: instance Data.Data.Data decls => Data.Data.Data (Agda.Syntax.Concrete.WhereClause' decls)
- Agda.Syntax.Concrete: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Concrete.OpApp e)
- Agda.Syntax.Concrete: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Concrete.RHS' e)
- Agda.Syntax.Concrete: instance Data.Data.Data e => Data.Data.Data (Agda.Syntax.Concrete.TypedBinding' e)
- Agda.Syntax.Concrete: topLevelModuleName :: Module -> TopLevelModuleName
- Agda.Syntax.Concrete.Definitions.Errors: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Errors.DeclarationException'
- Agda.Syntax.Concrete.Definitions.Errors: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Errors.DeclarationWarning'
- Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.Clause
- Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.DataRecOrFun
- Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.KindOfBlock
- Agda.Syntax.Concrete.Definitions.Types: instance Data.Data.Data Agda.Syntax.Concrete.Definitions.Types.NiceDeclaration
- Agda.Syntax.Concrete.Name: TopLevelModuleName :: Range -> List1 String -> TopLevelModuleName
- Agda.Syntax.Concrete.Name: [moduleNameParts] :: TopLevelModuleName -> List1 String
- Agda.Syntax.Concrete.Name: [moduleNameRange] :: TopLevelModuleName -> Range
- Agda.Syntax.Concrete.Name: data TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Agda.Syntax.Position.HasRange Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Agda.Syntax.Position.KillRange Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Agda.Syntax.Position.SetRange Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Agda.Utils.Size.Sized Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Control.DeepSeq.NFData Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance Data.Data.Data Agda.Syntax.Concrete.Name.Name
- Agda.Syntax.Concrete.Name: instance Data.Data.Data Agda.Syntax.Concrete.Name.NameInScope
- Agda.Syntax.Concrete.Name: instance Data.Data.Data Agda.Syntax.Concrete.Name.NamePart
- Agda.Syntax.Concrete.Name: instance Data.Data.Data Agda.Syntax.Concrete.Name.QName
- Agda.Syntax.Concrete.Name: instance Data.Data.Data Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance GHC.Classes.Eq Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance GHC.Classes.Ord Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance GHC.Generics.Generic Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: instance GHC.Show.Show Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.Syntax.Concrete.Name: moduleNameToFileName :: TopLevelModuleName -> String -> FilePath
- Agda.Syntax.Concrete.Name: projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath
- Agda.Syntax.Concrete.Name: toTopLevelModuleName :: QName -> TopLevelModuleName
- Agda.Syntax.Concrete.Pretty: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Common.GenPart
- Agda.Syntax.Fixity: instance Data.Data.Data Agda.Syntax.Fixity.ParenPreference
- Agda.Syntax.Fixity: instance Data.Data.Data Agda.Syntax.Fixity.Precedence
- Agda.Syntax.Fixity: instance Data.Data.Data x => Data.Data.Data (Agda.Syntax.Fixity.ThingWithFixity x)
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.AppInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.ConPatInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.ConPatLazy
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.DeclInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.ExprInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.LHSInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.LetInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.MetaInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.ModuleInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.MutualInfo
- Agda.Syntax.Info: instance Data.Data.Data Agda.Syntax.Info.PatInfo
- Agda.Syntax.Info: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Info.DefInfo' t)
- Agda.Syntax.Internal: EqualityType :: Sort -> QName -> [Arg Term] -> Arg Term -> Arg Term -> Arg Term -> EqualityView
- Agda.Syntax.Internal: [domFinite] :: Dom' t e -> !Bool
- Agda.Syntax.Internal: [eqtLhs] :: EqualityView -> Arg Term
- Agda.Syntax.Internal: [eqtName] :: EqualityView -> QName
- Agda.Syntax.Internal: [eqtParams] :: EqualityView -> [Arg Term]
- Agda.Syntax.Internal: [eqtRhs] :: EqualityView -> Arg Term
- Agda.Syntax.Internal: [eqtSort] :: EqualityView -> Sort
- Agda.Syntax.Internal: [eqtType] :: EqualityView -> Arg Term
- Agda.Syntax.Internal: instance (Data.Data.Data t, Data.Data.Data a) => Data.Data.Data (Agda.Syntax.Internal.Type'' t a)
- Agda.Syntax.Internal: instance (Data.Data.Data t, Data.Data.Data e) => Data.Data.Data (Agda.Syntax.Internal.Dom' t e)
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.BraveTerm
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.Clause
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.ConHead
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.ConPatternInfo
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.DBPatVar
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.DataOrRecord
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.IsFibrant
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.PatOrigin
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.PatternInfo
- Agda.Syntax.Internal: instance Data.Data.Data Agda.Syntax.Internal.Term
- Agda.Syntax.Internal: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Internal.Abs a)
- Agda.Syntax.Internal: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Internal.Tele a)
- Agda.Syntax.Internal: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.Level' t)
- Agda.Syntax.Internal: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.PlusLevel' t)
- Agda.Syntax.Internal: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.Sort' t)
- Agda.Syntax.Internal: instance Data.Data.Data x => Data.Data.Data (Agda.Syntax.Internal.Pattern' x)
- Agda.Syntax.Internal: newtype MetaId
- Agda.Syntax.Internal: type family PatternVarOut a;
- Agda.Syntax.Internal.Blockers: instance (Data.Data.Data t, Data.Data.Data a) => Data.Data.Data (Agda.Syntax.Internal.Blockers.Blocked' t a)
- Agda.Syntax.Internal.Blockers: instance (GHC.Show.Show a, GHC.Show.Show t) => GHC.Show.Show (Agda.Syntax.Internal.Blockers.Blocked' t a)
- Agda.Syntax.Internal.Blockers: instance Data.Data.Data Agda.Syntax.Internal.Blockers.Blocker
- Agda.Syntax.Internal.Blockers: instance Data.Data.Data t => Data.Data.Data (Agda.Syntax.Internal.Blockers.NotBlocked' t)
- Agda.Syntax.Internal.Blockers: instance GHC.Base.Monoid Agda.Syntax.Internal.Blockers.Blocker
- Agda.Syntax.Internal.Blockers: instance GHC.Base.Semigroup Agda.Syntax.Internal.Blockers.Blocker
- Agda.Syntax.Internal.Elim: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Internal.Elim.Elim' a)
- Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike GHC.Integer.Type.Integer
- Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.Generic.TermLike a => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.Dom a)
- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Dom a)
- Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (GHC.Base.NonEmpty a)
- Agda.Syntax.Internal.Pattern: type family PatVar p;
- Agda.Syntax.Literal: instance Data.Data.Data Agda.Syntax.Literal.Literal
- Agda.Syntax.Notation: [_bindHoleName] :: HoleName -> RString
- Agda.Syntax.Notation: isBindingHole :: GenPart -> Bool
- Agda.Syntax.Notation: isNormalHole :: GenPart -> Bool
- Agda.Syntax.Parser.Monad: instance Data.Data.Data Agda.Syntax.Parser.Monad.ParseWarning
- Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange GHC.Integer.Type.Integer
- Agda.Syntax.Position: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Position.Interval' a)
- Agda.Syntax.Position: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Position.Position' a)
- Agda.Syntax.Position: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Position.Range' a)
- Agda.Syntax.Position: instance GHC.Base.Semigroup Agda.Utils.FileName.AbsolutePath
- Agda.Syntax.Position: instance GHC.Base.Semigroup a => GHC.Base.Monoid (Agda.Syntax.Position.Range' a)
- Agda.Syntax.Position: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (Agda.Syntax.Position.Range' a)
- Agda.Syntax.Scope.Base: flattenScope :: [[Name]] -> ScopeInfo -> Map QName [AbstractName]
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.AbstractModule
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.AbstractName
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.BindingSource
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.DataOrRecordModule
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.KindOfName
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.LocalVar
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.NameMapEntry
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.NameMetadata
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.NameOrModule
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.NameSpace
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.NameSpaceId
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.ResolvedName
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.Scope
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.ScopeInfo
- Agda.Syntax.Scope.Base: instance Data.Data.Data Agda.Syntax.Scope.Base.WhyInScope
- Agda.Syntax.Scope.Base: instance Data.Data.Data a => Data.Data.Data (Agda.Syntax.Scope.Base.WithKind a)
- Agda.Syntax.Translation.AbstractToConcrete: type family ConOfAbs a;
- Agda.Syntax.Translation.ConcreteToAbstract: type family AbsOfCon c;
- Agda.Syntax.Translation.InternalToAbstract: type family ReifiesTo i;
- Agda.Syntax.Translation.ReflectedToAbstract: type family AbsOfRef r;
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.ArgUsage
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.CaseInfo
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.CaseType
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.Compiled
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.TAlt
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.TError
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.TPrim
- Agda.Syntax.Treeless: instance Data.Data.Data Agda.Syntax.Treeless.TTerm
- Agda.Termination.Monad: [callInfos] :: CallPath -> [CallInfo]
- Agda.Termination.Monad: type MutualNames = [QName]
- Agda.Termination.Monad: type Target = QName
- Agda.Termination.Semiring: instance Agda.Termination.Semiring.HasZero GHC.Integer.Type.Integer
- Agda.TypeChecking.CompiledClause: instance Data.Data.Data a => Data.Data.Data (Agda.TypeChecking.CompiledClause.CompiledClauses' a)
- Agda.TypeChecking.CompiledClause: instance Data.Data.Data c => Data.Data.Data (Agda.TypeChecking.CompiledClause.Case c)
- Agda.TypeChecking.CompiledClause: instance Data.Data.Data c => Data.Data.Data (Agda.TypeChecking.CompiledClause.WithArity c)
- Agda.TypeChecking.Constraints: solveAwakeConstraints :: MonadConstraint m => m ()
- Agda.TypeChecking.Constraints: solveAwakeConstraints' :: MonadConstraint m => Bool -> m ()
- Agda.TypeChecking.Constraints: wakeConstraints' :: (ProblemConstraint -> WakeUp) -> TCM ()
- Agda.TypeChecking.Conversion: compareCohesion :: Comparison -> Cohesion -> Cohesion -> Bool
- Agda.TypeChecking.Conversion: compareQuantity :: Comparison -> Quantity -> Quantity -> Bool
- Agda.TypeChecking.Conversion: compareRelevance :: Comparison -> Relevance -> Relevance -> Bool
- Agda.TypeChecking.Coverage: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Coverage.SplitClause
- Agda.TypeChecking.Coverage.SplitTree: instance Data.Data.Data Agda.TypeChecking.Coverage.SplitTree.LazySplit
- Agda.TypeChecking.Coverage.SplitTree: instance Data.Data.Data Agda.TypeChecking.Coverage.SplitTree.SplitTag
- Agda.TypeChecking.Coverage.SplitTree: instance Data.Data.Data a => Data.Data.Data (Agda.TypeChecking.Coverage.SplitTree.SplitTree' a)
- Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet () Agda.TypeChecking.Free.SingleFlexRig
- Agda.TypeChecking.Level: levelSucFunction :: TCM (Term -> Term)
- Agda.TypeChecking.MetaVars: etaExpandListeners :: MetaId -> TCM ()
- Agda.TypeChecking.MetaVars: etaExpandMetaSafe :: MonadMetaSolver m => MetaId -> m ()
- Agda.TypeChecking.MetaVars: wakeupListener :: Listener -> TCM ()
- Agda.TypeChecking.Monad.Base: Axiom :: Bool -> Defn
- Agda.TypeChecking.Monad.Base: Constructor :: Int -> Int -> ConHead -> QName -> IsAbstract -> Induction -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> Defn
- Agda.TypeChecking.Monad.Base: DataOrRecSig :: Int -> Defn
- Agda.TypeChecking.Monad.Base: Datatype :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Defn
- Agda.TypeChecking.Monad.Base: Function :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> IsAbstract -> Delayed -> Maybe Projection -> Set FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Defn
- Agda.TypeChecking.Monad.Base: Primitive :: IsAbstract -> String -> [Clause] -> FunctionInverse -> Maybe CompiledClauses -> Defn
- Agda.TypeChecking.Monad.Base: PrimitiveSort :: String -> Sort -> Defn
- Agda.TypeChecking.Monad.Base: Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> IsAbstract -> CompKit -> Defn
- Agda.TypeChecking.Monad.Base: [axiomConstTransp] :: Defn -> Bool
- Agda.TypeChecking.Monad.Base: [callInfoRange] :: CallInfo -> Range
- Agda.TypeChecking.Monad.Base: [conAbstr] :: Defn -> IsAbstract
- Agda.TypeChecking.Monad.Base: [conArity] :: Defn -> Int
- Agda.TypeChecking.Monad.Base: [conComp] :: Defn -> CompKit
- Agda.TypeChecking.Monad.Base: [conData] :: Defn -> QName
- Agda.TypeChecking.Monad.Base: [conErased] :: Defn -> Maybe [Bool]
- Agda.TypeChecking.Monad.Base: [conForced] :: Defn -> [IsForced]
- Agda.TypeChecking.Monad.Base: [conInd] :: Defn -> Induction
- Agda.TypeChecking.Monad.Base: [conPars] :: Defn -> Int
- Agda.TypeChecking.Monad.Base: [conProj] :: Defn -> Maybe [QName]
- Agda.TypeChecking.Monad.Base: [conSrcCon] :: Defn -> ConHead
- Agda.TypeChecking.Monad.Base: [dataAbstr] :: Defn -> IsAbstract
- Agda.TypeChecking.Monad.Base: [dataClause] :: Defn -> Maybe Clause
- Agda.TypeChecking.Monad.Base: [dataCons] :: Defn -> [QName]
- Agda.TypeChecking.Monad.Base: [dataIxs] :: Defn -> Nat
- Agda.TypeChecking.Monad.Base: [dataMutual] :: Defn -> Maybe [QName]
- Agda.TypeChecking.Monad.Base: [dataPars] :: Defn -> Nat
- Agda.TypeChecking.Monad.Base: [dataPathCons] :: Defn -> [QName]
- Agda.TypeChecking.Monad.Base: [dataSort] :: Defn -> Sort
- Agda.TypeChecking.Monad.Base: [datarecPars] :: Defn -> Int
- Agda.TypeChecking.Monad.Base: [funAbstr] :: Defn -> IsAbstract
- Agda.TypeChecking.Monad.Base: [funClauses] :: Defn -> [Clause]
- Agda.TypeChecking.Monad.Base: [funCompiled] :: Defn -> Maybe CompiledClauses
- Agda.TypeChecking.Monad.Base: [funCovering] :: Defn -> [Clause]
- Agda.TypeChecking.Monad.Base: [funDelayed] :: Defn -> Delayed
- Agda.TypeChecking.Monad.Base: [funExtLam] :: Defn -> Maybe ExtLamInfo
- Agda.TypeChecking.Monad.Base: [funFlags] :: Defn -> Set FunctionFlag
- Agda.TypeChecking.Monad.Base: [funInv] :: Defn -> FunctionInverse
- Agda.TypeChecking.Monad.Base: [funMutual] :: Defn -> Maybe [QName]
- Agda.TypeChecking.Monad.Base: [funProjection] :: Defn -> Maybe Projection
- Agda.TypeChecking.Monad.Base: [funSplitTree] :: Defn -> Maybe SplitTree
- Agda.TypeChecking.Monad.Base: [funTerminates] :: Defn -> Maybe Bool
- Agda.TypeChecking.Monad.Base: [funTreeless] :: Defn -> Maybe Compiled
- Agda.TypeChecking.Monad.Base: [funWith] :: Defn -> Maybe QName
- Agda.TypeChecking.Monad.Base: [primAbstr] :: Defn -> IsAbstract
- Agda.TypeChecking.Monad.Base: [primClauses] :: Defn -> [Clause]
- Agda.TypeChecking.Monad.Base: [primCompiled] :: Defn -> Maybe CompiledClauses
- Agda.TypeChecking.Monad.Base: [primInv] :: Defn -> FunctionInverse
- Agda.TypeChecking.Monad.Base: [primName] :: Defn -> String
- Agda.TypeChecking.Monad.Base: [primSort] :: Defn -> Sort
- Agda.TypeChecking.Monad.Base: [recAbstr] :: Defn -> IsAbstract
- Agda.TypeChecking.Monad.Base: [recClause] :: Defn -> Maybe Clause
- Agda.TypeChecking.Monad.Base: [recComp] :: Defn -> CompKit
- Agda.TypeChecking.Monad.Base: [recConHead] :: Defn -> ConHead
- Agda.TypeChecking.Monad.Base: [recEtaEquality'] :: Defn -> EtaEquality
- Agda.TypeChecking.Monad.Base: [recFields] :: Defn -> [Dom QName]
- Agda.TypeChecking.Monad.Base: [recInduction] :: Defn -> Maybe Induction
- Agda.TypeChecking.Monad.Base: [recMutual] :: Defn -> Maybe [QName]
- Agda.TypeChecking.Monad.Base: [recNamedCon] :: Defn -> Bool
- Agda.TypeChecking.Monad.Base: [recPars] :: Defn -> Nat
- Agda.TypeChecking.Monad.Base: [recPatternMatching] :: Defn -> PatternOrCopattern
- Agda.TypeChecking.Monad.Base: [recTel] :: Defn -> Telescope
- Agda.TypeChecking.Monad.Base: [stPostMetaStore] :: PostScopeState -> !MetaStore
- Agda.TypeChecking.Monad.Base: getMetaModality :: MetaVariable -> Modality
- Agda.TypeChecking.Monad.Base: getMetaRelevance :: MetaVariable -> Relevance
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.AbstractMode
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.AllowedReduction
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Call
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Candidate
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CandidateKind
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CheckpointId
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CompKit
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CompareAs
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Comparison
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.CompilerPragma
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Defn
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.DisplayForm
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.DisplayTerm
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.DoGeneralize
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.EtaEquality
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ExpandHidden
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ExtLamInfo
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.FunctionFlag
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.GeneralizedValue
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.HighlightingLevel
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.HighlightingMethod
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.IsForced
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.MutualId
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.NLPSort
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.NLPType
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.NLPat
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.NumGeneralizableArgs
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Overapplied
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Polarity
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ProjLams
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Projection
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.RecordFieldWarning
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.ReduceDefs
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.RewriteRule
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Section
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.Simplification
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.System
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.TermHead
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data Agda.TypeChecking.Monad.Base.UnquoteFlags
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data c => Data.Data.Data (Agda.TypeChecking.Monad.Base.FunctionInverse' c)
- Agda.TypeChecking.Monad.Base: instance Data.Data.Data t => Data.Data.Data (Agda.TypeChecking.Monad.Base.IPBoundary' t)
- Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.MetaInstantiation
- Agda.TypeChecking.Monad.Base: lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName)
- Agda.TypeChecking.Monad.Base: sourceToModule :: TCM SourceToModule
- Agda.TypeChecking.Monad.Base: stMetaStore :: Lens' MetaStore TCState
- Agda.TypeChecking.Monad.Base: theDefLens :: Lens' Defn Definition
- Agda.TypeChecking.Monad.Base: type MetaStore = IntMap MetaVariable
- Agda.TypeChecking.Monad.Base: type SourceToModule = Map AbsolutePath TopLevelModuleName
- Agda.TypeChecking.Monad.Benchmark: type family BenchPhase m
- Agda.TypeChecking.Monad.Builtin: primRewrite :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
- Agda.TypeChecking.Monad.Debug: parseVerboseKey :: VerboseKey -> [String]
- Agda.TypeChecking.Monad.Debug: verbosity :: VerboseKey -> Lens' VerboseLevel TCState
- Agda.TypeChecking.Monad.Imports: getImports :: TCM (Set ModuleName)
- Agda.TypeChecking.Monad.Imports: isImported :: ModuleName -> TCM Bool
- Agda.TypeChecking.Monad.MetaVars: getMetaStore :: ReadTCState m => m MetaStore
- Agda.TypeChecking.Monad.MetaVars: getMetaVariables :: ReadTCState m => (MetaVariable -> Bool) -> m [MetaId]
- Agda.TypeChecking.Monad.MetaVars: lookupMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)
- Agda.TypeChecking.Monad.MetaVars: modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()
- Agda.TypeChecking.Positivity.Occurrence: instance Data.Data.Data Agda.TypeChecking.Positivity.Occurrence.Occurrence
- Agda.TypeChecking.Positivity.Occurrence: instance Data.Data.Data Agda.TypeChecking.Positivity.Occurrence.OccursWhere
- Agda.TypeChecking.Positivity.Occurrence: instance Data.Data.Data Agda.TypeChecking.Positivity.Occurrence.Where
- Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM (Agda.Syntax.Internal.Dom (Agda.Syntax.Abstract.Name.Name, Agda.Syntax.Internal.Type))
- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.FromTerm GHC.Integer.Type.Integer
- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm GHC.Integer.Type.Integer
- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Integer.Type.Integer
- Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.ToTerm GHC.Integer.Type.Integer
- Agda.TypeChecking.Primitive.Cubical: DoHComp :: TranspOrHComp
- Agda.TypeChecking.Primitive.Cubical: DoTransp :: TranspOrHComp
- Agda.TypeChecking.Primitive.Cubical: Eliminated :: TermPosition
- Agda.TypeChecking.Primitive.Cubical: Head :: TermPosition
- Agda.TypeChecking.Primitive.Cubical: IsFam :: a -> FamilyOrNot a
- Agda.TypeChecking.Primitive.Cubical: IsNot :: a -> FamilyOrNot a
- Agda.TypeChecking.Primitive.Cubical: [famThing] :: FamilyOrNot a -> a
- Agda.TypeChecking.Primitive.Cubical: cmdToName :: TranspOrHComp -> String
- Agda.TypeChecking.Primitive.Cubical: compGlue :: PureTCM m => TranspOrHComp -> Arg Term -> Maybe (Arg Term) -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)
- Agda.TypeChecking.Primitive.Cubical: compHCompU :: PureTCM m => TranspOrHComp -> Arg Term -> Maybe (Arg Term) -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)
- Agda.TypeChecking.Primitive.Cubical: data FamilyOrNot a
- Agda.TypeChecking.Primitive.Cubical: data TermPosition
- Agda.TypeChecking.Primitive.Cubical: data TranspOrHComp
- Agda.TypeChecking.Primitive.Cubical: decomposeInterval :: HasBuiltins m => Term -> m [(Map Int Bool, [Term])]
- Agda.TypeChecking.Primitive.Cubical: decomposeInterval' :: HasBuiltins m => Term -> m [(Map Int (Set Bool), [Term])]
- Agda.TypeChecking.Primitive.Cubical: headStop :: PureTCM m => TermPosition -> m Term -> m Bool
- Agda.TypeChecking.Primitive.Cubical: imax :: HasBuiltins m => m Term -> m Term -> m Term
- Agda.TypeChecking.Primitive.Cubical: imin :: HasBuiltins m => m Term -> m Term -> m Term
- Agda.TypeChecking.Primitive.Cubical: instance Agda.TypeChecking.Reduce.Reduce a => Agda.TypeChecking.Reduce.Reduce (Agda.TypeChecking.Primitive.Cubical.FamilyOrNot a)
- Agda.TypeChecking.Primitive.Cubical: instance Data.Foldable.Foldable Agda.TypeChecking.Primitive.Cubical.FamilyOrNot
- Agda.TypeChecking.Primitive.Cubical: instance Data.Traversable.Traversable Agda.TypeChecking.Primitive.Cubical.FamilyOrNot
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Base.Functor Agda.TypeChecking.Primitive.Cubical.FamilyOrNot
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Classes.Eq Agda.TypeChecking.Primitive.Cubical.TermPosition
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Classes.Eq Agda.TypeChecking.Primitive.Cubical.TranspOrHComp
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Primitive.Cubical.FamilyOrNot a)
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.TermPosition
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.TranspOrHComp
- Agda.TypeChecking.Primitive.Cubical: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Primitive.Cubical.FamilyOrNot a)
- Agda.TypeChecking.Primitive.Cubical: mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
- Agda.TypeChecking.Primitive.Cubical: primDepIMin' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primGlue' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIMax' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIMin' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primINeg' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIdElim' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIdFace' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIdJ :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIdPath' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type
- Agda.TypeChecking.Primitive.Cubical: prim_glue' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: prim_glueU' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: prim_unglue' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: prim_unglueU' :: TCM PrimitiveImpl
- Agda.TypeChecking.Primitive.Cubical: requireCubical :: Cubical -> String -> TCM ()
- Agda.TypeChecking.Primitive.Cubical: unglueTranspGlue :: PureTCM m => Arg Term -> Arg Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> m Term
- Agda.TypeChecking.Reduce: appDef :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
- Agda.TypeChecking.Reduce: appDefE :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
- Agda.TypeChecking.Reduce: appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
- Agda.TypeChecking.Reduce: appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
- Agda.TypeChecking.Reduce: blockAll :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)
- Agda.TypeChecking.Reduce: blockAny :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)
- Agda.TypeChecking.Reduce: instantiateFullExceptForDefinitions' :: Interface -> ReduceM Interface
- Agda.TypeChecking.Reduce: isFullyInstantiatedMeta :: MetaId -> TCM Bool
- Agda.TypeChecking.Reduce: maybeFastReduceTerm :: Term -> ReduceM (Blocked Term)
- Agda.TypeChecking.Reduce: normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t)
- Agda.TypeChecking.Reduce: reduceIApply :: ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term)
- Agda.TypeChecking.Reduce: shouldTryFastReduce :: ReduceM Bool
- Agda.TypeChecking.Reduce: simplify' :: (Simplify t, t ~ f a, Traversable f, Simplify a) => t -> ReduceM t
- Agda.TypeChecking.Reduce: unfoldDefinition :: Bool -> (Term -> ReduceM (Blocked Term)) -> Term -> QName -> Args -> ReduceM (Blocked Term)
- Agda.TypeChecking.Reduce: unfoldDefinition' :: Bool -> (Simplification -> Term -> ReduceM (Simplification, Blocked Term)) -> Term -> QName -> Elims -> ReduceM (Simplification, Blocked Term)
- Agda.TypeChecking.Reduce: withReduced :: (Reduce a, IsMeta a, MonadReduce m, MonadBlock m) => a -> (a -> m b) -> m b
- Agda.TypeChecking.Rewriting.NonLinMatch: reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a) => IntSet -> a -> m (Either Blocked_ (Maybe a))
- Agda.TypeChecking.Rules.Data: ClosedType :: Sort -> QName -> CType
- Agda.TypeChecking.Rules.Data: LEl :: Level -> Term -> LType
- Agda.TypeChecking.Rules.Data: LType :: LType -> CType
- Agda.TypeChecking.Rules.Data: data CType
- Agda.TypeChecking.Rules.Data: data LType
- Agda.TypeChecking.Rules.Data: defineTranspOrHCompForFields :: TranspOrHComp -> Maybe Term -> (Term -> QName -> Term) -> QName -> Telescope -> Telescope -> [Arg QName] -> Type -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution))
- Agda.TypeChecking.Rules.Data: fromCType :: CType -> Type
- Agda.TypeChecking.Rules.Data: fromLType :: LType -> Type
- Agda.TypeChecking.Rules.Data: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.Data.CType
- Agda.TypeChecking.Rules.Data: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Rules.Data.LType
- Agda.TypeChecking.Rules.Data: instance GHC.Classes.Eq Agda.TypeChecking.Rules.Data.CType
- Agda.TypeChecking.Rules.Data: instance GHC.Classes.Eq Agda.TypeChecking.Rules.Data.LType
- Agda.TypeChecking.Rules.Data: instance GHC.Show.Show Agda.TypeChecking.Rules.Data.CType
- Agda.TypeChecking.Rules.Data: instance GHC.Show.Show Agda.TypeChecking.Rules.Data.LType
- Agda.TypeChecking.Rules.Data: lTypeLevel :: LType -> Level
- Agda.TypeChecking.Rules.Data: toCType :: MonadReduce m => Type -> m (Maybe CType)
- Agda.TypeChecking.Rules.Data: toLType :: MonadReduce m => Type -> m (Maybe LType)
- Agda.TypeChecking.Rules.LHS.Unify: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Unify.UnifyState
- Agda.TypeChecking.Rules.LHS.Unify: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Unify.UnifyStep
- Agda.TypeChecking.Rules.LHS.Unify: instance Agda.TypeChecking.Reduce.Reduce Agda.TypeChecking.Rules.LHS.Unify.Equality
- Agda.TypeChecking.Rules.LHS.Unify: instance Agda.TypeChecking.Reduce.Reduce Agda.TypeChecking.Rules.LHS.Unify.UnifyState
- Agda.TypeChecking.Rules.LHS.Unify: instance GHC.Base.Monoid Agda.TypeChecking.Rules.LHS.Unify.UnifyOutput
- Agda.TypeChecking.Rules.LHS.Unify: instance GHC.Base.Semigroup Agda.TypeChecking.Rules.LHS.Unify.UnifyOutput
- Agda.TypeChecking.Rules.LHS.Unify: instance GHC.Show.Show Agda.TypeChecking.Rules.LHS.Unify.UnifyState
- Agda.TypeChecking.Rules.LHS.Unify: instance GHC.Show.Show Agda.TypeChecking.Rules.LHS.Unify.UnifyStep
- Agda.TypeChecking.Rules.Record: defineTranspOrHCompR :: TranspOrHComp -> QName -> Telescope -> Telescope -> [Arg QName] -> Type -> TCM (Maybe QName)
- Agda.TypeChecking.Rules.Term: ifPath :: Type -> TCM a -> TCM a -> TCM a
- Agda.TypeChecking.Serialise.Base: [absPathD] :: Dict -> !HashTable AbsolutePath Int32
- Agda.TypeChecking.Serialise.Base: type HashTable k v = BasicHashTable k v
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.GenPart
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Concrete.Name.TopLevelModuleName
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Utils.FileName.AbsolutePath
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Integer.Type.Integer
- Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (GHC.Base.NonEmpty a)
- Agda.TypeChecking.Serialise.Instances.Highlighting: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.RangeMap.PairInt a)
- Agda.TypeChecking.SizedTypes: oldSolveSizeConstraints :: TCM ()
- Agda.TypeChecking.SizedTypes: oldSolver :: [(MetaId, Int)] -> [OldSizeConstraint] -> TCM Bool
- Agda.TypeChecking.SizedTypes.Syntax: type family FlexOf a;
- Agda.TypeChecking.Substitute.Class: compactS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a
- Agda.TypeChecking.Substitute.Class: type family SubstArg a;
- Agda.TypeChecking.Unquote: instance Agda.TypeChecking.Unquote.Unquote GHC.Integer.Type.Integer
- Agda.Utils.Benchmark: type family BenchPhase m;
- Agda.Utils.BiMap: type family Tag a;
- Agda.Utils.Cluster: type C = Int
- Agda.Utils.Empty: instance Data.Data.Data Agda.Utils.Empty.Empty
- Agda.Utils.FileName: instance Data.Data.Data Agda.Utils.FileName.AbsolutePath
- Agda.Utils.List: wordsBy :: (a -> Bool) -> [a] -> [[a]]
- Agda.Utils.List1: pattern (:|) :: () => a -> [a] -> NonEmpty a
- Agda.Utils.List2: instance Data.Data.Data a => Data.Data.Data (Agda.Utils.List2.List2 a)
- Agda.Utils.List2: instance GHC.Exts.IsList (Agda.Utils.List2.List2 a)
- Agda.Utils.Maybe.Strict: Just :: !a -> Maybe a
- Agda.Utils.Maybe.Strict: Nothing :: Maybe a
- Agda.Utils.Maybe.Strict: catMaybes :: [Maybe a] -> [a]
- Agda.Utils.Maybe.Strict: data Maybe a
- Agda.Utils.Maybe.Strict: fromJust :: Maybe a -> a
- Agda.Utils.Maybe.Strict: fromMaybe :: a -> Maybe a -> a
- Agda.Utils.Maybe.Strict: isJust :: Maybe a -> Bool
- Agda.Utils.Maybe.Strict: isNothing :: Maybe a -> Bool
- Agda.Utils.Maybe.Strict: listToMaybe :: [a] -> Maybe a
- Agda.Utils.Maybe.Strict: mapMaybe :: (a -> Maybe b) -> [a] -> [b]
- Agda.Utils.Maybe.Strict: maybe :: b -> (a -> b) -> Maybe a -> b
- Agda.Utils.Maybe.Strict: maybeToList :: Maybe a -> [a]
- Agda.Utils.Maybe.Strict: toLazy :: Maybe a -> Maybe a
- Agda.Utils.Maybe.Strict: toStrict :: Maybe a -> Maybe a
- Agda.Utils.Null: instance (Agda.Utils.Null.Null (m a), GHC.Base.Monad m) => Agda.Utils.Null.Null (Control.Monad.Trans.State.Lazy.StateT r m a)
- Agda.Utils.PartialOrd: instance Agda.Utils.PartialOrd.PartialOrd GHC.Integer.Type.Integer
- Agda.Utils.Permutation: instance Data.Data.Data Agda.Utils.Permutation.Permutation
- Agda.Utils.Permutation: instance Data.Data.Data a => Data.Data.Data (Agda.Utils.Permutation.Drop a)
- Agda.Utils.Permutation: safePermute :: Permutation -> [a] -> [Maybe a]
- Agda.Utils.Pointer: instance Data.Data.Data a => Data.Data.Data (Agda.Utils.Pointer.Ptr a)
- Agda.Utils.Pointer: instance Data.Typeable.Internal.Typeable a => Data.Data.Data (GHC.IORef.IORef a)
- Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty GHC.Integer.Type.Integer
- Agda.Utils.Pretty: instance Data.Data.Data Text.PrettyPrint.HughesPJ.Doc
- Agda.Utils.SmallSet: instance (Data.Data.Data a, GHC.Ix.Ix a) => Data.Data.Data (Agda.Utils.SmallSet.SmallSet a)
- Agda.Utils.SmallSet: mapMemberShip :: SmallSetElement a => (Bool -> Bool) -> SmallSet a -> SmallSet a
- Agda.Utils.SmallSet: zipMemberShipWith :: SmallSetElement a => (Bool -> Bool -> Bool) -> SmallSet a -> SmallSet a -> SmallSet a
- Agda.Utils.Zipper: type family Element z;
+ Agda.Auto.CaseSplit: CSPatProj :: ConstRef o -> CSPatI o
+ Agda.Auto.CaseSplit: type ReplaceWith t u;
+ Agda.Auto.CaseSplit: type UnifiesTo t;
+ Agda.Auto.Convert: lookupLocalMetaAuto :: MetaId -> TCM MetaVariable
+ Agda.Auto.NarrowingSearch: type Block a;
+ Agda.Auto.Syntax: PatProj :: ConstRef o -> Pat o
+ Agda.Compiler.Backend: AxiomData :: Bool -> AxiomData
+ Agda.Compiler.Backend: AxiomDefn :: AxiomData -> Defn
+ Agda.Compiler.Backend: BuiltinRewriteRelations :: Set QName -> Builtin pf
+ Agda.Compiler.Backend: CheckDataSort :: QName -> Sort -> Constraint
+ Agda.Compiler.Backend: CheckIApplyConfluence :: Range -> QName -> Term -> Term -> Term -> Type -> Call
+ Agda.Compiler.Backend: ConstructorData :: Int -> Int -> ConHead -> QName -> IsAbstract -> Induction -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> ConstructorData
+ Agda.Compiler.Backend: ConstructorDefn :: ConstructorData -> Defn
+ Agda.Compiler.Backend: ConstructorType :: WhyCheckModality
+ Agda.Compiler.Backend: DataOrRecSigData :: Int -> DataOrRecSigData
+ Agda.Compiler.Backend: DataOrRecSigDefn :: DataOrRecSigData -> Defn
+ Agda.Compiler.Backend: DatatypeData :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Maybe QName -> Maybe QName -> DatatypeData
+ Agda.Compiler.Backend: DatatypeDefn :: DatatypeData -> Defn
+ Agda.Compiler.Backend: FunctionData :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> IsAbstract -> Delayed -> Either ProjectionLikenessMissing Projection -> Set FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Maybe QName -> FunctionData
+ Agda.Compiler.Backend: FunctionDefn :: FunctionData -> Defn
+ Agda.Compiler.Backend: GeneratedClause :: WhyCheckModality
+ Agda.Compiler.Backend: IndexedClause :: WhyCheckModality
+ Agda.Compiler.Backend: IndexedClauseArg :: Name -> Name -> WhyCheckModality
+ Agda.Compiler.Backend: Instantiation :: [Arg String] -> Term -> Instantiation
+ Agda.Compiler.Backend: LocalMetaStores :: LocalMetaStore -> LocalMetaStore -> LocalMetaStores
+ Agda.Compiler.Backend: MaybeProjection :: ProjectionLikenessMissing
+ Agda.Compiler.Backend: NeverProjection :: ProjectionLikenessMissing
+ Agda.Compiler.Backend: OptionWarning :: OptionWarning -> Warning
+ Agda.Compiler.Backend: PIntervalUniv :: NLPSort
+ Agda.Compiler.Backend: PSSet :: NLPat -> NLPSort
+ Agda.Compiler.Backend: PrimitiveData :: IsAbstract -> String -> [Clause] -> FunctionInverse -> Maybe CompiledClauses -> PrimitiveData
+ Agda.Compiler.Backend: PrimitiveDefn :: PrimitiveData -> Defn
+ Agda.Compiler.Backend: PrimitiveSortData :: String -> Sort -> PrimitiveSortData
+ Agda.Compiler.Backend: PrimitiveSortDefn :: PrimitiveSortData -> Defn
+ Agda.Compiler.Backend: RecordData :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> Maybe Bool -> IsAbstract -> CompKit -> RecordData
+ Agda.Compiler.Backend: RecordDefn :: RecordData -> Defn
+ Agda.Compiler.Backend: RemoteMetaVariable :: Instantiation -> Modality -> Judgement MetaId -> RemoteMetaVariable
+ Agda.Compiler.Backend: UnequalFiniteness :: Comparison -> Term -> Term -> TypeError
+ Agda.Compiler.Backend: UnsupportedIndexedMatch :: Doc -> Warning
+ Agda.Compiler.Backend: [_axiomConstTransp] :: AxiomData -> Bool
+ Agda.Compiler.Backend: [_conAbstr] :: ConstructorData -> IsAbstract
+ Agda.Compiler.Backend: [_conArity] :: ConstructorData -> Int
+ Agda.Compiler.Backend: [_conComp] :: ConstructorData -> CompKit
+ Agda.Compiler.Backend: [_conData] :: ConstructorData -> QName
+ Agda.Compiler.Backend: [_conErased] :: ConstructorData -> Maybe [Bool]
+ Agda.Compiler.Backend: [_conForced] :: ConstructorData -> [IsForced]
+ Agda.Compiler.Backend: [_conInd] :: ConstructorData -> Induction
+ Agda.Compiler.Backend: [_conPars] :: ConstructorData -> Int
+ Agda.Compiler.Backend: [_conProj] :: ConstructorData -> Maybe [QName]
+ Agda.Compiler.Backend: [_conSrcCon] :: ConstructorData -> ConHead
+ Agda.Compiler.Backend: [_dataAbstr] :: DatatypeData -> IsAbstract
+ Agda.Compiler.Backend: [_dataClause] :: DatatypeData -> Maybe Clause
+ Agda.Compiler.Backend: [_dataCons] :: DatatypeData -> [QName]
+ Agda.Compiler.Backend: [_dataIxs] :: DatatypeData -> Nat
+ Agda.Compiler.Backend: [_dataMutual] :: DatatypeData -> Maybe [QName]
+ Agda.Compiler.Backend: [_dataPars] :: DatatypeData -> Nat
+ Agda.Compiler.Backend: [_dataPathCons] :: DatatypeData -> [QName]
+ Agda.Compiler.Backend: [_dataSort] :: DatatypeData -> Sort
+ Agda.Compiler.Backend: [_dataTranspIx] :: DatatypeData -> Maybe QName
+ Agda.Compiler.Backend: [_dataTransp] :: DatatypeData -> Maybe QName
+ Agda.Compiler.Backend: [_datarecPars] :: DataOrRecSigData -> Int
+ Agda.Compiler.Backend: [_funAbstr] :: FunctionData -> IsAbstract
+ Agda.Compiler.Backend: [_funClauses] :: FunctionData -> [Clause]
+ Agda.Compiler.Backend: [_funCompiled] :: FunctionData -> Maybe CompiledClauses
+ Agda.Compiler.Backend: [_funCovering] :: FunctionData -> [Clause]
+ Agda.Compiler.Backend: [_funDelayed] :: FunctionData -> Delayed
+ Agda.Compiler.Backend: [_funExtLam] :: FunctionData -> Maybe ExtLamInfo
+ Agda.Compiler.Backend: [_funFlags] :: FunctionData -> Set FunctionFlag
+ Agda.Compiler.Backend: [_funInv] :: FunctionData -> FunctionInverse
+ Agda.Compiler.Backend: [_funIsKanOp] :: FunctionData -> Maybe QName
+ Agda.Compiler.Backend: [_funMutual] :: FunctionData -> Maybe [QName]
+ Agda.Compiler.Backend: [_funProjection] :: FunctionData -> Either ProjectionLikenessMissing Projection
+ Agda.Compiler.Backend: [_funSplitTree] :: FunctionData -> Maybe SplitTree
+ Agda.Compiler.Backend: [_funTerminates] :: FunctionData -> Maybe Bool
+ Agda.Compiler.Backend: [_funTreeless] :: FunctionData -> Maybe Compiled
+ Agda.Compiler.Backend: [_funWith] :: FunctionData -> Maybe QName
+ Agda.Compiler.Backend: [_primAbstr] :: PrimitiveData -> IsAbstract
+ Agda.Compiler.Backend: [_primClauses] :: PrimitiveData -> [Clause]
+ Agda.Compiler.Backend: [_primCompiled] :: PrimitiveData -> Maybe CompiledClauses
+ Agda.Compiler.Backend: [_primInv] :: PrimitiveData -> FunctionInverse
+ Agda.Compiler.Backend: [_primName] :: PrimitiveData -> String
+ Agda.Compiler.Backend: [_primSortName] :: PrimitiveSortData -> String
+ Agda.Compiler.Backend: [_primSortSort] :: PrimitiveSortData -> Sort
+ Agda.Compiler.Backend: [_recAbstr] :: RecordData -> IsAbstract
+ Agda.Compiler.Backend: [_recClause] :: RecordData -> Maybe Clause
+ Agda.Compiler.Backend: [_recComp] :: RecordData -> CompKit
+ Agda.Compiler.Backend: [_recConHead] :: RecordData -> ConHead
+ Agda.Compiler.Backend: [_recEtaEquality'] :: RecordData -> EtaEquality
+ Agda.Compiler.Backend: [_recFields] :: RecordData -> [Dom QName]
+ Agda.Compiler.Backend: [_recInduction] :: RecordData -> Maybe Induction
+ Agda.Compiler.Backend: [_recMutual] :: RecordData -> Maybe [QName]
+ Agda.Compiler.Backend: [_recNamedCon] :: RecordData -> Bool
+ Agda.Compiler.Backend: [_recPars] :: RecordData -> Nat
+ Agda.Compiler.Backend: [_recPatternMatching] :: RecordData -> PatternOrCopattern
+ Agda.Compiler.Backend: [_recTel] :: RecordData -> Telescope
+ Agda.Compiler.Backend: [_recTerminates] :: RecordData -> Maybe Bool
+ Agda.Compiler.Backend: [envSyntacticEqualityFuel] :: TCEnv -> !Maybe Int
+ Agda.Compiler.Backend: [iMetaBindings] :: Interface -> RemoteMetaStore
+ Agda.Compiler.Backend: [iTopLevelModuleName] :: Interface -> TopLevelModuleName
+ Agda.Compiler.Backend: [instBody] :: Instantiation -> Term
+ Agda.Compiler.Backend: [instTel] :: Instantiation -> [Arg String]
+ Agda.Compiler.Backend: [openMetas] :: LocalMetaStores -> LocalMetaStore
+ Agda.Compiler.Backend: [redPred] :: ReduceEnv -> Maybe (MetaId -> ReduceM Bool)
+ Agda.Compiler.Backend: [rmvInstantiation] :: RemoteMetaVariable -> Instantiation
+ Agda.Compiler.Backend: [rmvJudgement] :: RemoteMetaVariable -> Judgement MetaId
+ Agda.Compiler.Backend: [rmvModality] :: RemoteMetaVariable -> Modality
+ Agda.Compiler.Backend: [solvedMetas] :: LocalMetaStores -> LocalMetaStore
+ Agda.Compiler.Backend: [stPersistentTopLevelModuleNames] :: PersistentTCState -> !BiMap RawTopLevelModuleName ModuleNameHash
+ Agda.Compiler.Backend: [stPostOpenMetaStore] :: PostScopeState -> !LocalMetaStore
+ Agda.Compiler.Backend: [stPostSolvedMetaStore] :: PostScopeState -> !LocalMetaStore
+ Agda.Compiler.Backend: [stPreImportedMetaStore] :: PreScopeState -> !RemoteMetaStore
+ Agda.Compiler.Backend: axiomConstTransp :: Defn -> Bool
+ Agda.Compiler.Backend: bindBuiltinRewriteRelation :: QName -> TCM ()
+ Agda.Compiler.Backend: builtinAgdaErrorPartPatt :: String
+ Agda.Compiler.Backend: builtinAgdaTCMDeclareData :: String
+ Agda.Compiler.Backend: builtinAgdaTCMDefineData :: String
+ Agda.Compiler.Backend: builtinAgdaTCMFormatErrorParts :: String
+ Agda.Compiler.Backend: builtinAgdaTCMGetInstances :: String
+ Agda.Compiler.Backend: builtinIntervalUniv :: String
+ Agda.Compiler.Backend: builtinReflId :: String
+ Agda.Compiler.Backend: class EqualityUnview a
+ Agda.Compiler.Backend: conAbstr :: Defn -> IsAbstract
+ Agda.Compiler.Backend: conArity :: Defn -> Int
+ Agda.Compiler.Backend: conComp :: Defn -> CompKit
+ Agda.Compiler.Backend: conData :: Defn -> QName
+ Agda.Compiler.Backend: conErased :: Defn -> Maybe [Bool]
+ Agda.Compiler.Backend: conForced :: Defn -> [IsForced]
+ Agda.Compiler.Backend: conInd :: Defn -> Induction
+ Agda.Compiler.Backend: conPars :: Defn -> Int
+ Agda.Compiler.Backend: conProj :: Defn -> Maybe [QName]
+ Agda.Compiler.Backend: conSrcCon :: Defn -> ConHead
+ Agda.Compiler.Backend: conidView' :: HasBuiltins m => m (Term -> Term -> Maybe (Arg Term, Arg Term))
+ Agda.Compiler.Backend: cubicalCompatibleOption :: HasOptions m => m Bool
+ Agda.Compiler.Backend: currentTopLevelModule :: (MonadTCEnv m, ReadTCState m) => m (Maybe TopLevelModuleName)
+ Agda.Compiler.Backend: data AxiomData
+ Agda.Compiler.Backend: data ConstructorData
+ Agda.Compiler.Backend: data DataOrRecSigData
+ Agda.Compiler.Backend: data DatatypeData
+ Agda.Compiler.Backend: data FunctionData
+ Agda.Compiler.Backend: data Instantiation
+ Agda.Compiler.Backend: data LocalMetaStores
+ Agda.Compiler.Backend: data PrimitiveData
+ Agda.Compiler.Backend: data PrimitiveSortData
+ Agda.Compiler.Backend: data ProjectionLikenessMissing
+ Agda.Compiler.Backend: data RecordData
+ Agda.Compiler.Backend: data RemoteMetaVariable
+ Agda.Compiler.Backend: data WhyCheckModality
+ Agda.Compiler.Backend: dataAbstr :: Defn -> IsAbstract
+ Agda.Compiler.Backend: dataClause :: Defn -> Maybe Clause
+ Agda.Compiler.Backend: dataCons :: Defn -> [QName]
+ Agda.Compiler.Backend: dataIxs :: Defn -> Nat
+ Agda.Compiler.Backend: dataMutual :: Defn -> Maybe [QName]
+ Agda.Compiler.Backend: dataPars :: Defn -> Nat
+ Agda.Compiler.Backend: dataPathCons :: Defn -> [QName]
+ Agda.Compiler.Backend: dataSort :: Defn -> Sort
+ Agda.Compiler.Backend: dataTransp :: Defn -> Maybe QName
+ Agda.Compiler.Backend: dataTranspIx :: Defn -> Maybe QName
+ Agda.Compiler.Backend: datarecPars :: Defn -> Int
+ Agda.Compiler.Backend: defaultGetProfileOptions :: HasOptions m => m ProfileOptions
+ Agda.Compiler.Backend: emptyFunctionData :: FunctionData
+ Agda.Compiler.Backend: etaExpandListeners :: MonadMetaSolver m => MetaId -> m ()
+ Agda.Compiler.Backend: etaExpandMetaSafe :: MonadMetaSolver m => MetaId -> m ()
+ Agda.Compiler.Backend: funAbstr :: Defn -> IsAbstract
+ Agda.Compiler.Backend: funClauses :: Defn -> [Clause]
+ Agda.Compiler.Backend: funCompiled :: Defn -> Maybe CompiledClauses
+ Agda.Compiler.Backend: funCovering :: Defn -> [Clause]
+ Agda.Compiler.Backend: funDelayed :: Defn -> Delayed
+ Agda.Compiler.Backend: funExtLam :: Defn -> Maybe ExtLamInfo
+ Agda.Compiler.Backend: funFlags :: Defn -> Set FunctionFlag
+ Agda.Compiler.Backend: funInv :: Defn -> FunctionInverse
+ Agda.Compiler.Backend: funIsKanOp :: Defn -> Maybe QName
+ Agda.Compiler.Backend: funMutual :: Defn -> Maybe [QName]
+ Agda.Compiler.Backend: funProjection :: Defn -> Either ProjectionLikenessMissing Projection
+ Agda.Compiler.Backend: funSplitTree :: Defn -> Maybe SplitTree
+ Agda.Compiler.Backend: funTerminates :: Defn -> Maybe Bool
+ Agda.Compiler.Backend: funTreeless :: Defn -> Maybe Compiled
+ Agda.Compiler.Backend: funWith :: Defn -> Maybe QName
+ Agda.Compiler.Backend: getBuiltinRewriteRelations :: HasBuiltins m => m (Maybe (Set QName))
+ Agda.Compiler.Backend: getProfileOptions :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => m ProfileOptions
+ Agda.Compiler.Backend: hasProfileOption :: MonadDebug m => ProfileOption -> m Bool
+ Agda.Compiler.Backend: infallibleSortKit :: HasBuiltins m => m SortKit
+ Agda.Compiler.Backend: initialMetaId :: MetaId
+ Agda.Compiler.Backend: intervalSort :: Sort
+ Agda.Compiler.Backend: isInstanceConstraint :: Constraint -> Bool
+ Agda.Compiler.Backend: isRemoteMeta :: ReadTCState m => m (MetaId -> Bool)
+ Agda.Compiler.Backend: isSortJudgement :: Judgement a -> Bool
+ Agda.Compiler.Backend: lensConstructor :: Lens' ConstructorData Defn
+ Agda.Compiler.Backend: lensFunction :: Lens' FunctionData Defn
+ Agda.Compiler.Backend: lensRecTel :: Lens' Telescope RecordData
+ Agda.Compiler.Backend: lensRecord :: Lens' RecordData Defn
+ Agda.Compiler.Backend: lensTheDef :: Lens' Defn Definition
+ Agda.Compiler.Backend: lookupLocalMeta :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaVariable
+ Agda.Compiler.Backend: lookupLocalMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)
+ Agda.Compiler.Backend: lookupMetaInstantiation :: ReadTCState m => MetaId -> m MetaInstantiation
+ Agda.Compiler.Backend: lookupMetaJudgement :: ReadTCState m => MetaId -> m (Judgement MetaId)
+ Agda.Compiler.Backend: lookupMetaModality :: ReadTCState m => MetaId -> m Modality
+ Agda.Compiler.Backend: modifyTCLens' :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()
+ Agda.Compiler.Backend: nextLocalMeta :: ReadTCState m => m MetaId
+ Agda.Compiler.Backend: pattern Axiom :: Bool -> Defn
+ Agda.Compiler.Backend: pattern Constructor :: Int -> Int -> ConHead -> QName -> IsAbstract -> Induction -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> Defn
+ Agda.Compiler.Backend: pattern DataOrRecSig :: Int -> Defn
+ Agda.Compiler.Backend: pattern Datatype :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Maybe QName -> Maybe QName -> Defn
+ Agda.Compiler.Backend: pattern Function :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> IsAbstract -> Delayed -> Either ProjectionLikenessMissing Projection -> Set FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Maybe QName -> Defn
+ Agda.Compiler.Backend: pattern Primitive :: IsAbstract -> String -> [Clause] -> FunctionInverse -> Maybe CompiledClauses -> Defn
+ Agda.Compiler.Backend: pattern PrimitiveSort :: String -> Sort -> Defn
+ Agda.Compiler.Backend: pattern Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> Maybe Bool -> IsAbstract -> CompKit -> Defn
+ Agda.Compiler.Backend: primAbstr :: Defn -> IsAbstract
+ Agda.Compiler.Backend: primAgdaErrorPartPatt :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.Compiler.Backend: primAgdaTCMDeclareData :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.Compiler.Backend: primAgdaTCMDefineData :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.Compiler.Backend: primAgdaTCMFormatErrorParts :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.Compiler.Backend: primAgdaTCMGetInstances :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.Compiler.Backend: primClauses :: Defn -> [Clause]
+ Agda.Compiler.Backend: primCompiled :: Defn -> Maybe CompiledClauses
+ Agda.Compiler.Backend: primIntervalUniv :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.Compiler.Backend: primInv :: Defn -> FunctionInverse
+ Agda.Compiler.Backend: primName :: Defn -> String
+ Agda.Compiler.Backend: primSortName :: Defn -> String
+ Agda.Compiler.Backend: primSortSort :: Defn -> Sort
+ Agda.Compiler.Backend: recAbstr :: Defn -> IsAbstract
+ Agda.Compiler.Backend: recClause :: Defn -> Maybe Clause
+ Agda.Compiler.Backend: recComp :: Defn -> CompKit
+ Agda.Compiler.Backend: recConHead :: Defn -> ConHead
+ Agda.Compiler.Backend: recEtaEquality' :: Defn -> EtaEquality
+ Agda.Compiler.Backend: recFields :: Defn -> [Dom QName]
+ Agda.Compiler.Backend: recInduction :: Defn -> Maybe Induction
+ Agda.Compiler.Backend: recMutual :: Defn -> Maybe [QName]
+ Agda.Compiler.Backend: recNamedCon :: Defn -> Bool
+ Agda.Compiler.Backend: recPars :: Defn -> Nat
+ Agda.Compiler.Backend: recPatternMatching :: Defn -> PatternOrCopattern
+ Agda.Compiler.Backend: recTel :: Defn -> Telescope
+ Agda.Compiler.Backend: recTerminates :: Defn -> Maybe Bool
+ Agda.Compiler.Backend: setTCLens' :: MonadTCState m => Lens' a TCState -> a -> m ()
+ Agda.Compiler.Backend: shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool
+ Agda.Compiler.Backend: solveAwakeConstraints :: MonadConstraint m => m ()
+ Agda.Compiler.Backend: solveAwakeConstraints' :: MonadConstraint m => Bool -> m ()
+ Agda.Compiler.Backend: stImportedMetaStore :: Lens' RemoteMetaStore TCState
+ Agda.Compiler.Backend: stOpenMetaStore :: Lens' LocalMetaStore TCState
+ Agda.Compiler.Backend: stSolvedMetaStore :: Lens' LocalMetaStore TCState
+ Agda.Compiler.Backend: stTopLevelModuleNames :: Lens' (BiMap RawTopLevelModuleName ModuleNameHash) TCState
+ Agda.Compiler.Backend: topLevelModuleName :: RawTopLevelModuleName -> TCM TopLevelModuleName
+ Agda.Compiler.Backend: type LocalMetaStore = Map MetaId MetaVariable
+ Agda.Compiler.Backend: type RemoteMetaStore = HashMap MetaId RemoteMetaVariable
+ Agda.Compiler.Backend: unionBuiltin :: Builtin a -> Builtin a -> Builtin a
+ Agda.Compiler.Backend: wakeConstraints' :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m ()
+ Agda.Compiler.Backend: wakeupListener :: MonadMetaSolver m => Listener -> m ()
+ Agda.Compiler.Backend: whenProfile :: MonadDebug m => ProfileOption -> m () -> m ()
+ Agda.Compiler.Backend: withFrozenMetas :: (MonadMetaSolver m, MonadTCState m) => m a -> m a
+ Agda.Compiler.JS.Compiler: litmeta :: MetaId -> Exp
+ Agda.Compiler.MAlonzo.Compiler: litmetapat :: MetaId -> Pat
+ Agda.Interaction.Base: Cmd_no_metas :: Interaction' range
+ Agda.Interaction.Base: DataSort :: QName -> b -> OutputConstraint a b
+ Agda.Interaction.Base: [currentFileModule] :: CurrentFile -> TopLevelModuleName
+ Agda.Interaction.Base: instance GHC.Read.Read Agda.Syntax.Position.RangeFile
+ Agda.Interaction.Base: parseIOTCM :: String -> Either String IOTCM
+ Agda.Interaction.BasicOps: instance (Agda.Utils.Pretty.Pretty a, Agda.Utils.Pretty.Pretty b) => Agda.TypeChecking.Pretty.PrettyTCM (Agda.Interaction.Base.OutputForm a b)
+ Agda.Interaction.BasicOps: interactionIdToMetaId :: ReadTCState m => InteractionId -> m MetaId
+ Agda.Interaction.ExitCode: CommandError :: AgdaError
+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Interaction.Highlighting.FromAbstract: instance Agda.Interaction.Highlighting.FromAbstract.Hilite Agda.Syntax.Common.Erased
+ Agda.Interaction.Imports: [srcCohesion] :: Source -> !CohesionAttributes
+ Agda.Interaction.JSONTop: instance Data.Aeson.Types.ToJSON.ToJSON Agda.Syntax.Common.ModuleNameHash
+ Agda.Interaction.Library.Base: BadFieldName :: LineNumber -> String -> LibParseError
+ Agda.Interaction.Library.Base: BadLibraryName :: String -> LibParseError
+ Agda.Interaction.Library.Base: ContentWithoutField :: LineNumber -> LibParseError
+ Agda.Interaction.Library.Base: DuplicateExecutable :: FilePath -> Text -> List2 FilePath -> LibError'
+ Agda.Interaction.Library.Base: DuplicateFields :: List1 String -> LibParseError
+ Agda.Interaction.Library.Base: LibParseError :: LibParseError -> LibError'
+ Agda.Interaction.Library.Base: LibrariesFileNotFound :: FilePath -> LibError'
+ Agda.Interaction.Library.Base: MissingColonForField :: LineNumber -> String -> LibParseError
+ Agda.Interaction.Library.Base: MissingFieldName :: LineNumber -> LibParseError
+ Agda.Interaction.Library.Base: MissingFields :: List1 String -> LibParseError
+ Agda.Interaction.Library.Base: ReadError :: IOException -> String -> LibError'
+ Agda.Interaction.Library.Base: ReadFailure :: FilePath -> IOException -> LibParseError
+ Agda.Interaction.Library.Base: data LibParseError
+ Agda.Interaction.Library.Base: hasLineNumber :: LibParseError -> Maybe LineNumber
+ Agda.Interaction.Library.Base: instance Agda.Utils.Pretty.Pretty Agda.Interaction.Library.Base.LibError'
+ Agda.Interaction.Library.Base: instance Agda.Utils.Pretty.Pretty Agda.Interaction.Library.Base.LibParseError
+ Agda.Interaction.Library.Base: prettyInstalledLibraries :: [AgdaLibFile] -> Doc
+ Agda.Interaction.Library.Base: type LibErrWarns = [Either LibError LibWarning]
+ Agda.Interaction.Options: Coinfective :: InfectiveCoinfective
+ Agda.Interaction.Options: ICOption :: (PragmaOptions -> Bool) -> String -> InfectiveCoinfective -> (PragmaOptions -> PragmaOptions -> Bool) -> (TopLevelModuleName -> Doc) -> InfectiveCoinfectiveOption
+ Agda.Interaction.Options: Infective :: InfectiveCoinfective
+ Agda.Interaction.Options: OptionRenamed :: String -> String -> OptionWarning
+ Agda.Interaction.Options: [icOptionActive] :: InfectiveCoinfectiveOption -> PragmaOptions -> Bool
+ Agda.Interaction.Options: [icOptionDescription] :: InfectiveCoinfectiveOption -> String
+ Agda.Interaction.Options: [icOptionKind] :: InfectiveCoinfectiveOption -> InfectiveCoinfective
+ Agda.Interaction.Options: [icOptionOK] :: InfectiveCoinfectiveOption -> PragmaOptions -> PragmaOptions -> Bool
+ Agda.Interaction.Options: [icOptionWarning] :: InfectiveCoinfectiveOption -> TopLevelModuleName -> Doc
+ Agda.Interaction.Options: [newOptionName] :: OptionWarning -> String
+ Agda.Interaction.Options: [oldOptionName] :: OptionWarning -> String
+ Agda.Interaction.Options: [optCohesion] :: PragmaOptions -> Bool
+ Agda.Interaction.Options: [optCubicalCompatible] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [optEraseRecordParameters] :: PragmaOptions -> Bool
+ Agda.Interaction.Options: [optExitOnError] :: CommandLineOptions -> !Bool
+ Agda.Interaction.Options: [optKeepCoveringClauses] :: PragmaOptions -> Bool
+ Agda.Interaction.Options: [optLoadPrimitives] :: PragmaOptions -> Bool
+ Agda.Interaction.Options: [optProfiling] :: PragmaOptions -> ProfileOptions
+ Agda.Interaction.Options: [optSaveMetas] :: PragmaOptions -> WithDefault 'False
+ Agda.Interaction.Options: [optTransliterate] :: CommandLineOptions -> Bool
+ Agda.Interaction.Options: data InfectiveCoinfective
+ Agda.Interaction.Options: data InfectiveCoinfectiveOption
+ Agda.Interaction.Options: data OptM a
+ Agda.Interaction.Options: data OptionWarning
+ Agda.Interaction.Options: infectiveCoinfectiveOptions :: [InfectiveCoinfectiveOption]
+ Agda.Interaction.Options: optionWarningName :: OptionWarning -> WarningName
+ Agda.Interaction.Options: parseVerboseKey :: VerboseKey -> [VerboseKeyItem]
+ Agda.Interaction.Options: recheckBecausePragmaOptionsChanged :: PragmaOptions -> PragmaOptions -> Bool
+ Agda.Interaction.Options.Warnings: HiddenGeneralize_ :: WarningName
+ Agda.Interaction.Options.Warnings: OptionRenamed_ :: WarningName
+ Agda.Interaction.Options.Warnings: UnsupportedIndexedMatch_ :: WarningName
+ Agda.Main: helpForLocaleError :: TCErr -> IO ()
+ Agda.Syntax.Abstract: AbsurdRHSS :: RHSSpine
+ Agda.Syntax.Abstract: ApplyS :: DeclarationSpine
+ Agda.Syntax.Abstract: AxiomS :: DeclarationSpine
+ Agda.Syntax.Abstract: ClauseS :: RHSSpine -> WhereDeclarationsSpine -> ClauseSpine
+ Agda.Syntax.Abstract: DataDefS :: DeclarationSpine
+ Agda.Syntax.Abstract: DataSigS :: DeclarationSpine
+ Agda.Syntax.Abstract: FieldS :: DeclarationSpine
+ Agda.Syntax.Abstract: FunDefS :: [ClauseSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: GeneralizeS :: DeclarationSpine
+ Agda.Syntax.Abstract: ImportS :: DeclarationSpine
+ Agda.Syntax.Abstract: MutualS :: [DeclarationSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: NotProjectionLikePragma :: QName -> Pragma
+ Agda.Syntax.Abstract: OpenS :: DeclarationSpine
+ Agda.Syntax.Abstract: PatternSynDefS :: DeclarationSpine
+ Agda.Syntax.Abstract: PragmaS :: DeclarationSpine
+ Agda.Syntax.Abstract: PrimitiveS :: DeclarationSpine
+ Agda.Syntax.Abstract: RHSS :: RHSSpine
+ Agda.Syntax.Abstract: RecDefS :: [DeclarationSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: RecSigS :: DeclarationSpine
+ Agda.Syntax.Abstract: RewriteRHSS :: RHSSpine -> WhereDeclarationsSpine -> RHSSpine
+ Agda.Syntax.Abstract: ScopedDeclS :: [DeclarationSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: SectionS :: [DeclarationSpine] -> DeclarationSpine
+ Agda.Syntax.Abstract: TypedBindingInfo :: TacticAttr -> Bool -> TypedBindingInfo
+ Agda.Syntax.Abstract: UnquoteData :: [DefInfo] -> QName -> UniverseCheck -> [DefInfo] -> [QName] -> Expr -> Declaration
+ Agda.Syntax.Abstract: UnquoteDataS :: DeclarationSpine
+ Agda.Syntax.Abstract: UnquoteDeclS :: DeclarationSpine
+ Agda.Syntax.Abstract: UnquoteDefS :: DeclarationSpine
+ Agda.Syntax.Abstract: WhereDeclsS :: Maybe DeclarationSpine -> WhereDeclarationsSpine
+ Agda.Syntax.Abstract: WithRHSS :: [ClauseSpine] -> RHSSpine
+ Agda.Syntax.Abstract: [tbFinite] :: TypedBindingInfo -> Bool
+ Agda.Syntax.Abstract: [tbTacticAttr] :: TypedBindingInfo -> TacticAttr
+ Agda.Syntax.Abstract: [whereAnywhere] :: WhereDeclarations -> Bool
+ Agda.Syntax.Abstract: clauseSpine :: Clause -> ClauseSpine
+ Agda.Syntax.Abstract: data ClauseSpine
+ Agda.Syntax.Abstract: data DeclarationSpine
+ Agda.Syntax.Abstract: data RHSSpine
+ Agda.Syntax.Abstract: data TypedBindingInfo
+ Agda.Syntax.Abstract: data WhereDeclarationsSpine
+ Agda.Syntax.Abstract: declarationSpine :: Declaration -> DeclarationSpine
+ Agda.Syntax.Abstract: defaultTbInfo :: TypedBindingInfo
+ Agda.Syntax.Abstract: instance Agda.Syntax.Position.KillRange Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Syntax.Abstract: instance Control.DeepSeq.NFData Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Syntax.Abstract: instance GHC.Classes.Eq Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Syntax.Abstract: instance GHC.Generics.Generic Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.ClauseSpine
+ Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.DeclarationSpine
+ Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.RHSSpine
+ Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Syntax.Abstract: instance GHC.Show.Show Agda.Syntax.Abstract.WhereDeclarationsSpine
+ Agda.Syntax.Abstract: rhsSpine :: RHS -> RHSSpine
+ Agda.Syntax.Abstract: type Type = Expr
+ Agda.Syntax.Abstract: whereDeclarationsSpine :: WhereDeclarations -> WhereDeclarationsSpine
+ Agda.Syntax.Abstract.Pattern: type ADotT p;
+ Agda.Syntax.Abstract.Views: PiView :: [(ExprInfo, Telescope1)] -> Type -> PiView
+ Agda.Syntax.Abstract.Views: data PiView
+ Agda.Syntax.Abstract.Views: instance Agda.Syntax.Abstract.Views.ExprLike Agda.Syntax.Abstract.TypedBindingInfo
+ Agda.Syntax.Abstract.Views: piView :: Expr -> PiView
+ Agda.Syntax.Abstract.Views: unPiView :: PiView -> Expr
+ Agda.Syntax.Builtin: builtinAgdaErrorPartPatt :: String
+ Agda.Syntax.Builtin: builtinAgdaTCMDeclareData :: String
+ Agda.Syntax.Builtin: builtinAgdaTCMDefineData :: String
+ Agda.Syntax.Builtin: builtinAgdaTCMFormatErrorParts :: String
+ Agda.Syntax.Builtin: builtinAgdaTCMGetInstances :: String
+ Agda.Syntax.Builtin: builtinIntervalUniv :: String
+ Agda.Syntax.Builtin: builtinReflId :: String
+ Agda.Syntax.Common: BoundVariablePosition :: !Int -> !Int -> BoundVariablePosition
+ Agda.Syntax.Common: HolePart :: Range -> NamedArg (Ranged Int) -> NotationPart
+ Agda.Syntax.Common: VarPart :: Range -> Ranged BoundVariablePosition -> NotationPart
+ Agda.Syntax.Common: WildPart :: Ranged BoundVariablePosition -> NotationPart
+ Agda.Syntax.Common: [holeNumber] :: BoundVariablePosition -> !Int
+ Agda.Syntax.Common: [metaModule] :: MetaId -> {-# UNPACK #-} !ModuleNameHash
+ Agda.Syntax.Common: [moduleNameHash] :: ModuleNameHash -> Word64
+ Agda.Syntax.Common: [varNumber] :: BoundVariablePosition -> !Int
+ Agda.Syntax.Common: data BoundVariablePosition
+ Agda.Syntax.Common: data MetaId
+ Agda.Syntax.Common: data NotationPart
+ Agda.Syntax.Common: instance (GHC.Classes.Eq e, GHC.Classes.Eq qn, GHC.Classes.Eq nm, GHC.Classes.Eq p) => GHC.Classes.Eq (Agda.Syntax.Common.RewriteEqn' qn nm p e)
+ Agda.Syntax.Common: instance (GHC.Show.Show e, GHC.Show.Show qn, GHC.Show.Show nm, GHC.Show.Show p) => GHC.Show.Show (Agda.Syntax.Common.RewriteEqn' qn nm p e)
+ Agda.Syntax.Common: instance Agda.Syntax.Position.HasRange Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance Agda.Syntax.Position.KillRange Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance Agda.Syntax.Position.SetRange Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance Agda.Utils.BiMap.HasTag Agda.Syntax.Common.ModuleNameHash
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.BoundVariablePosition
+ Agda.Syntax.Common: instance Control.DeepSeq.NFData Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance Data.Hashable.Class.Hashable Agda.Syntax.Common.ModuleNameHash
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.BoundVariablePosition
+ Agda.Syntax.Common: instance GHC.Classes.Eq Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.BoundVariablePosition
+ Agda.Syntax.Common: instance GHC.Classes.Ord Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.BoundVariablePosition
+ Agda.Syntax.Common: instance GHC.Show.Show Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Common: type NameOf a;
+ Agda.Syntax.Concrete: NotProjectionLikePragma :: Range -> QName -> Pragma
+ Agda.Syntax.Concrete: UnquoteData :: Range -> Name -> [Name] -> Expr -> Declaration
+ Agda.Syntax.Concrete: [bnameIsFinite] :: BoundName -> Bool
+ Agda.Syntax.Concrete.Attribute: type CohesionAttributes = [(String, Range)]
+ Agda.Syntax.Concrete.Definitions: HiddenGeneralize :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions: NiceUnquoteData :: Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [Name] -> Expr -> NiceDeclaration
+ Agda.Syntax.Concrete.Definitions.Errors: HiddenGeneralize :: Range -> DeclarationWarning'
+ Agda.Syntax.Concrete.Definitions.Types: NiceUnquoteData :: Range -> Access -> IsAbstract -> PositivityCheck -> UniverseCheck -> Name -> [Name] -> Expr -> NiceDeclaration
+ Agda.Syntax.Concrete.Pretty: attributesForModality :: Modality -> Doc
+ Agda.Syntax.Concrete.Pretty: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Common.NotationPart
+ Agda.Syntax.Concrete.Pretty: prettyFiniteness :: BoundName -> Doc -> Doc
+ Agda.Syntax.Internal: EqualityTypeData :: Sort -> QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityTypeData
+ Agda.Syntax.Internal: EqualityViewType :: EqualityTypeData -> EqualityView
+ Agda.Syntax.Internal: IntervalUniv :: Sort' t
+ Agda.Syntax.Internal: [_eqtLhs] :: EqualityTypeData -> Arg Term
+ Agda.Syntax.Internal: [_eqtName] :: EqualityTypeData -> QName
+ Agda.Syntax.Internal: [_eqtParams] :: EqualityTypeData -> Args
+ Agda.Syntax.Internal: [_eqtRhs] :: EqualityTypeData -> Arg Term
+ Agda.Syntax.Internal: [_eqtSort] :: EqualityTypeData -> Sort
+ Agda.Syntax.Internal: [_eqtType] :: EqualityTypeData -> Arg Term
+ Agda.Syntax.Internal: [clauseWhereModule] :: Clause -> Maybe ModuleName
+ Agda.Syntax.Internal: [domIsFinite] :: Dom' t e -> Bool
+ Agda.Syntax.Internal: [metaModule] :: MetaId -> {-# UNPACK #-} !ModuleNameHash
+ Agda.Syntax.Internal: data EqualityTypeData
+ Agda.Syntax.Internal: data MetaId
+ Agda.Syntax.Internal: eqtLhs :: EqualityView -> Arg Term
+ Agda.Syntax.Internal: eqtName :: EqualityView -> QName
+ Agda.Syntax.Internal: eqtParams :: EqualityView -> Args
+ Agda.Syntax.Internal: eqtRhs :: EqualityView -> Arg Term
+ Agda.Syntax.Internal: eqtSort :: EqualityView -> Sort
+ Agda.Syntax.Internal: eqtType :: EqualityView -> Arg Term
+ Agda.Syntax.Internal: instance Agda.Utils.Pretty.Pretty a => Agda.Utils.Pretty.Pretty (Agda.Syntax.Internal.Blocked a)
+ Agda.Syntax.Internal: pattern EqualityType :: Sort -> QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView
+ Agda.Syntax.Internal: type PatternVarOut a;
+ Agda.Syntax.Internal.Blockers: UnblockOnDef :: QName -> Blocker
+ Agda.Syntax.Internal.Blockers: allBlockingDefs :: Blocker -> Set QName
+ Agda.Syntax.Internal.Blockers: getBlocker :: Blocked' t a -> Blocker
+ Agda.Syntax.Internal.Blockers: instance (GHC.Show.Show t, GHC.Show.Show a) => GHC.Show.Show (Agda.Syntax.Internal.Blockers.Blocked' t a)
+ Agda.Syntax.Internal.Blockers: unblockDef :: QName -> Blocker -> Blocker
+ Agda.Syntax.Internal.Blockers: unblockOnBoth :: Blocker -> Blocker -> Blocker
+ Agda.Syntax.Internal.Blockers: unblockOnDef :: QName -> Blocker
+ Agda.Syntax.Internal.Blockers: wakeIfBlockedOnDef :: QName -> Blocker -> WakeUp
+ Agda.Syntax.Internal.Defs: instance Agda.Syntax.Internal.Defs.GetDefs Agda.Syntax.Internal.Telescope
+ Agda.Syntax.Internal.Defs: instance Agda.Syntax.Internal.Defs.GetDefs GHC.Base.String
+ Agda.Syntax.Internal.Elim: isProperApplyElim :: Elim' a -> Bool
+ Agda.Syntax.Internal.Generic: instance Agda.Syntax.Internal.Generic.TermLike GHC.Num.Integer.Integer
+ Agda.Syntax.Internal.MetaVars: instance (Agda.Syntax.Internal.MetaVars.AllMetas a, Agda.Syntax.Internal.MetaVars.AllMetas b) => Agda.Syntax.Internal.MetaVars.AllMetas (Agda.Syntax.Internal.Dom' a b)
+ Agda.Syntax.Internal.MetaVars: instance Agda.Syntax.Internal.MetaVars.AllMetas GHC.Base.String
+ Agda.Syntax.Internal.Names: instance (Agda.Syntax.Internal.Names.NamesIn a, Agda.Syntax.Internal.Names.NamesIn b) => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Dom' a b)
+ Agda.Syntax.Internal.Names: instance (Agda.Syntax.Internal.Names.NamesIn a, Agda.Syntax.Internal.Names.NamesIn b) => Agda.Syntax.Internal.Names.NamesIn (Data.HashMap.Internal.HashMap a b)
+ Agda.Syntax.Internal.Names: instance (Agda.Syntax.Internal.Names.NamesIn a, Agda.Syntax.Internal.Names.NamesIn b, Agda.Syntax.Internal.Names.NamesIn c, Agda.Syntax.Internal.Names.NamesIn d, Agda.Syntax.Internal.Names.NamesIn e) => Agda.Syntax.Internal.Names.NamesIn (a, b, c, d, e)
+ Agda.Syntax.Internal.Names: instance (Agda.Syntax.Internal.Names.NamesIn a, Agda.Syntax.Internal.Names.NamesIn b, Agda.Syntax.Internal.Names.NamesIn c, Agda.Syntax.Internal.Names.NamesIn d, Agda.Syntax.Internal.Names.NamesIn e, Agda.Syntax.Internal.Names.NamesIn f) => Agda.Syntax.Internal.Names.NamesIn (a, b, c, d, e, f)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Common.MetaId
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Treeless.CaseInfo
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Treeless.CaseType
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Treeless.Compiled
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Treeless.TAlt
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.Syntax.Treeless.TTerm
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.ExtLamInfo
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.NLPSort
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.NLPType
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.NLPat
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.PrimFun
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.RewriteRule
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.Section
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn Agda.TypeChecking.Monad.Base.System
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn GHC.Types.Bool
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Syntax.Internal.Substitution' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.TypeChecking.Monad.Base.Builtin a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.TypeChecking.Monad.Base.FunctionInverse' a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Agda.Utils.List1.List1 a)
+ Agda.Syntax.Internal.Names: instance Agda.Syntax.Internal.Names.NamesIn a => Agda.Syntax.Internal.Names.NamesIn (Data.Strict.Maybe.Maybe a)
+ Agda.Syntax.Internal.Names: metasIn :: (NamesIn a, Collection MetaId m) => a -> m
+ Agda.Syntax.Internal.Names: metasIn' :: (NamesIn a, Monoid m) => (MetaId -> m) -> a -> m
+ Agda.Syntax.Internal.Names: namesAndMetasIn :: (NamesIn a, Collection QName m1, Collection MetaId m2) => a -> (m1, m2)
+ Agda.Syntax.Internal.Names: namesAndMetasIn' :: (NamesIn a, Monoid m, Foldable f, NamesIn b, f b ~ a) => (Either QName MetaId -> m) -> a -> m
+ Agda.Syntax.Internal.Pattern: hasDefP :: [NamedArg DeBruijnPattern] -> Bool
+ Agda.Syntax.Internal.Pattern: type PatVar p;
+ Agda.Syntax.Internal.Pattern: type PatVarLabel b;
+ Agda.Syntax.Notation: [_bindHoleNames] :: HoleName -> List1 RString
+ Agda.Syntax.Notation: isBinder :: NotationPart -> Bool
+ Agda.Syntax.Notation: isLambdaNotation :: NewNotation -> Bool
+ Agda.Syntax.Parser.Monad: [parseCohesion] :: ParseState -> !CohesionAttributes
+ Agda.Syntax.Parser.Tokens: KwNOT_PROJECTION_LIKE :: Keyword
+ Agda.Syntax.Position: RangeFile :: !AbsolutePath -> !Maybe TopLevelModuleName -> RangeFile
+ Agda.Syntax.Position: [rangeFileName] :: RangeFile -> !Maybe TopLevelModuleName
+ Agda.Syntax.Position: [rangeFilePath] :: RangeFile -> !AbsolutePath
+ Agda.Syntax.Position: data RangeFile
+ Agda.Syntax.Position: instance Agda.Syntax.Position.KillRange GHC.Num.Integer.Integer
+ Agda.Syntax.Position: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance Control.DeepSeq.NFData Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance GHC.Classes.Eq Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance GHC.Classes.Eq a => GHC.Base.Monoid (Agda.Syntax.Position.Range' a)
+ Agda.Syntax.Position: instance GHC.Classes.Eq a => GHC.Base.Semigroup (Agda.Syntax.Position.Range' a)
+ Agda.Syntax.Position: instance GHC.Classes.Ord Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance GHC.Generics.Generic Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: instance GHC.Show.Show Agda.Syntax.Position.RangeFile
+ Agda.Syntax.Position: mkRangeFile :: AbsolutePath -> Maybe TopLevelModuleName -> RangeFile
+ Agda.Syntax.Position: rangeModule :: Range -> Maybe TopLevelModuleName
+ Agda.Syntax.Position: rangeModule' :: Range -> Maybe (Maybe TopLevelModuleName)
+ Agda.Syntax.Scope.Base: AmbiguousDeclName :: List2 AbstractName -> AmbiguousNameReason
+ Agda.Syntax.Scope.Base: AmbiguousLocalVar :: LocalVar -> List1 AbstractName -> AmbiguousNameReason
+ Agda.Syntax.Scope.Base: WhyInScopeData :: QName -> FilePath -> Maybe LocalVar -> [AbstractName] -> [AbstractModule] -> WhyInScopeData
+ Agda.Syntax.Scope.Base: ambiguousNamesInReason :: AmbiguousNameReason -> List2 QName
+ Agda.Syntax.Scope.Base: data AmbiguousNameReason
+ Agda.Syntax.Scope.Base: data WhyInScopeData
+ Agda.Syntax.Scope.Base: findNameInScope :: InScope a => Name -> Scope -> [(a, Access)]
+ Agda.Syntax.Scope.Base: instance Control.DeepSeq.NFData Agda.Syntax.Scope.Base.AmbiguousNameReason
+ Agda.Syntax.Scope.Base: instance GHC.Generics.Generic Agda.Syntax.Scope.Base.AmbiguousNameReason
+ Agda.Syntax.Scope.Base: instance GHC.Show.Show Agda.Syntax.Scope.Base.AmbiguousNameReason
+ Agda.Syntax.Scope.Base: whyInScopeDataFromAmbiguousNameReason :: QName -> AmbiguousNameReason -> WhyInScopeData
+ Agda.Syntax.Scope.Flat: data FlatScope
+ Agda.Syntax.Scope.Flat: flattenScope :: [[Name]] -> ScopeInfo -> FlatScope
+ Agda.Syntax.Scope.Flat: getDefinedNames :: KindsOfNames -> FlatScope -> [[NewNotation]]
+ Agda.Syntax.Scope.Flat: instance Agda.Utils.Pretty.Pretty Agda.Syntax.Scope.Flat.FlatScope
+ Agda.Syntax.Scope.Flat: localNames :: FlatScope -> ScopeM ([QName], [NewNotation])
+ Agda.Syntax.TopLevelModuleName: RawTopLevelModuleName :: Range -> TopLevelModuleNameParts -> RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: TopLevelModuleName :: Range -> {-# UNPACK #-} !ModuleNameHash -> TopLevelModuleNameParts -> TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: [moduleNameId] :: TopLevelModuleName -> {-# UNPACK #-} !ModuleNameHash
+ Agda.Syntax.TopLevelModuleName: [moduleNameParts] :: TopLevelModuleName -> TopLevelModuleNameParts
+ Agda.Syntax.TopLevelModuleName: [moduleNameRange] :: TopLevelModuleName -> Range
+ Agda.Syntax.TopLevelModuleName: [rawModuleNameParts] :: RawTopLevelModuleName -> TopLevelModuleNameParts
+ Agda.Syntax.TopLevelModuleName: [rawModuleNameRange] :: RawTopLevelModuleName -> Range
+ Agda.Syntax.TopLevelModuleName: data RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: data TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: hashRawTopLevelModuleName :: RawTopLevelModuleName -> ModuleNameHash
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Concrete.Name.IsNoName Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Position.HasRange Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Position.HasRange Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Position.KillRange Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Position.KillRange Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Position.SetRange Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Syntax.Position.SetRange Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Utils.BiMap.HasTag Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Utils.Pretty.Pretty Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Utils.Pretty.Pretty Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Utils.Size.Sized Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Agda.Utils.Size.Sized Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Control.DeepSeq.NFData Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Control.DeepSeq.NFData Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance Data.Hashable.Class.Hashable Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Classes.Eq Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Classes.Eq Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Classes.Ord Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Classes.Ord Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Generics.Generic Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Generics.Generic Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Show.Show Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: instance GHC.Show.Show Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: lensTopLevelModuleNameParts :: Lens' TopLevelModuleNameParts TopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: moduleNameToFileName :: TopLevelModuleName -> String -> FilePath
+ Agda.Syntax.TopLevelModuleName: projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath
+ Agda.Syntax.TopLevelModuleName: rawTopLevelModuleName :: TopLevelModuleName -> RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: rawTopLevelModuleNameForModule :: Module -> RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: rawTopLevelModuleNameForModuleName :: ModuleName -> RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: rawTopLevelModuleNameForQName :: QName -> RawTopLevelModuleName
+ Agda.Syntax.TopLevelModuleName: rawTopLevelModuleNameToString :: RawTopLevelModuleName -> String
+ Agda.Syntax.TopLevelModuleName: topLevelModuleNameToQName :: TopLevelModuleName -> QName
+ Agda.Syntax.TopLevelModuleName: type TopLevelModuleNameParts = List1 Text
+ Agda.Syntax.TopLevelModuleName: unsafeTopLevelModuleName :: RawTopLevelModuleName -> ModuleNameHash -> TopLevelModuleName
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Base.MonadFresh Agda.Syntax.Common.NameId Agda.Syntax.Translation.AbstractToConcrete.AbsToCon
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Base.MonadReduce Agda.Syntax.Translation.AbstractToConcrete.AbsToCon
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Context.MonadAddContext Agda.Syntax.Translation.AbstractToConcrete.AbsToCon
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.MetaVars.MonadInteractionPoints Agda.Syntax.Translation.AbstractToConcrete.AbsToCon
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Pure.PureTCM Agda.Syntax.Translation.AbstractToConcrete.AbsToCon
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.TypeChecking.Monad.Signature.HasConstInfo Agda.Syntax.Translation.AbstractToConcrete.AbsToCon
+ Agda.Syntax.Translation.AbstractToConcrete: instance Agda.Utils.Null.Null (Agda.Syntax.Translation.AbstractToConcrete.AbsToCon Text.PrettyPrint.HughesPJ.Doc)
+ Agda.Syntax.Translation.AbstractToConcrete: instance Data.String.IsString (Agda.Syntax.Translation.AbstractToConcrete.AbsToCon Text.PrettyPrint.HughesPJ.Doc)
+ Agda.Syntax.Translation.AbstractToConcrete: instance GHC.Base.Semigroup (Agda.Syntax.Translation.AbstractToConcrete.AbsToCon Text.PrettyPrint.HughesPJ.Doc)
+ Agda.Syntax.Translation.AbstractToConcrete: type ConOfAbs a;
+ Agda.Syntax.Translation.ConcreteToAbstract: checkCohesionAttributes :: CohesionAttributes -> ScopeM ()
+ Agda.Syntax.Translation.ConcreteToAbstract: type AbsOfCon c;
+ Agda.Syntax.Translation.InternalToAbstract: type ReifiesTo i;
+ Agda.Syntax.Translation.ReflectedToAbstract: type AbsOfRef r;
+ Agda.Termination.Monad: TargetDef :: QName -> Target
+ Agda.Termination.Monad: TargetOther :: Target
+ Agda.Termination.Monad: TargetRecord :: Target
+ Agda.Termination.Monad: callInfos :: CallPath -> [CallInfo]
+ Agda.Termination.Monad: class TerSetSizeDepth b
+ Agda.Termination.Monad: data Target
+ Agda.Termination.Monad: instance Agda.Termination.Monad.TerSetSizeDepth Agda.Syntax.Internal.ListTel
+ Agda.Termination.Monad: instance Agda.Termination.Monad.TerSetSizeDepth Agda.Syntax.Internal.Telescope
+ Agda.Termination.Monad: instance GHC.Classes.Eq Agda.Termination.Monad.Target
+ Agda.Termination.Monad: instance GHC.Show.Show Agda.Termination.Monad.Target
+ Agda.Termination.RecCheck: type MutualNames = Set QName
+ Agda.Termination.Semiring: instance Agda.Termination.Semiring.HasZero GHC.Num.Integer.Integer
+ Agda.Termination.TermCheck: instance Agda.Termination.TermCheck.ExtractCalls a => Agda.Termination.TermCheck.ExtractCalls (Agda.Syntax.Internal.Tele a)
+ Agda.TypeChecking.Conversion: compareMetas :: MonadConversion m => Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> m ()
+ Agda.TypeChecking.Coverage: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Coverage.SplitClause.SplitClause
+ Agda.TypeChecking.Coverage.Cubical: covFillTele :: QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]
+ Agda.TypeChecking.Coverage.Cubical: createMissingConIdClause :: QName -> Arg Nat -> BlockingVar -> SplitClause -> IInfo -> TCM (Maybe ((SplitTag, SplitTree), Clause))
+ Agda.TypeChecking.Coverage.Cubical: createMissingHCompClause :: QName -> Arg Nat -> BlockingVar -> SplitClause -> SplitClause -> [Clause] -> TCM ([(SplitTag, CoverResult)], [Clause])
+ Agda.TypeChecking.Coverage.Cubical: createMissingIndexedClauses :: QName -> Arg Nat -> BlockingVar -> SplitClause -> [(SplitTag, (SplitClause, IInfo))] -> [Clause] -> TCM ([(SplitTag, CoverResult)], [Clause])
+ Agda.TypeChecking.Coverage.Cubical: createMissingTrXConClause :: QName -> QName -> Arg Nat -> BlockingVar -> SplitClause -> QName -> UnifyEquiv -> TCM Clause
+ Agda.TypeChecking.Coverage.Cubical: createMissingTrXHCompClause :: QName -> QName -> Arg Nat -> BlockingVar -> SplitClause -> TCM Clause
+ Agda.TypeChecking.Coverage.Cubical: createMissingTrXTrXClause :: QName -> QName -> Arg Nat -> BlockingVar -> SplitClause -> TCM Clause
+ Agda.TypeChecking.Coverage.Match: fromSplitPattern :: NamedArg SplitPattern -> NamedArg DeBruijnPattern
+ Agda.TypeChecking.Coverage.SplitClause: CoverResult :: SplitTree -> IntSet -> [(Telescope, [NamedArg DeBruijnPattern])] -> [Clause] -> IntSet -> CoverResult
+ Agda.TypeChecking.Coverage.SplitClause: Covering :: Arg Nat -> [(SplitTag, (SplitClause, IInfo))] -> Covering
+ Agda.TypeChecking.Coverage.SplitClause: NoInfo :: IInfo
+ Agda.TypeChecking.Coverage.SplitClause: SClause :: Telescope -> [NamedArg SplitPattern] -> Substitution' SplitPattern -> Map CheckpointId Substitution -> Maybe (Dom Type) -> SplitClause
+ Agda.TypeChecking.Coverage.SplitClause: TheInfo :: UnifyEquiv -> IInfo
+ Agda.TypeChecking.Coverage.SplitClause: UE :: Telescope -> Telescope -> Telescope -> [Term] -> [Term] -> PatternSubstitution -> Substitution -> Substitution -> UnifyEquiv
+ Agda.TypeChecking.Coverage.SplitClause: [covSplitArg] :: Covering -> Arg Nat
+ Agda.TypeChecking.Coverage.SplitClause: [covSplitClauses] :: Covering -> [(SplitTag, (SplitClause, IInfo))]
+ Agda.TypeChecking.Coverage.SplitClause: [coverMissingClauses] :: CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])]
+ Agda.TypeChecking.Coverage.SplitClause: [coverNoExactClauses] :: CoverResult -> IntSet
+ Agda.TypeChecking.Coverage.SplitClause: [coverPatterns] :: CoverResult -> [Clause]
+ Agda.TypeChecking.Coverage.SplitClause: [coverSplitTree] :: CoverResult -> SplitTree
+ Agda.TypeChecking.Coverage.SplitClause: [coverUsedClauses] :: CoverResult -> IntSet
+ Agda.TypeChecking.Coverage.SplitClause: [infoEqLHS] :: UnifyEquiv -> [Term]
+ Agda.TypeChecking.Coverage.SplitClause: [infoEqRHS] :: UnifyEquiv -> [Term]
+ Agda.TypeChecking.Coverage.SplitClause: [infoEqTel] :: UnifyEquiv -> Telescope
+ Agda.TypeChecking.Coverage.SplitClause: [infoLeftInv] :: UnifyEquiv -> Substitution
+ Agda.TypeChecking.Coverage.SplitClause: [infoRho] :: UnifyEquiv -> PatternSubstitution
+ Agda.TypeChecking.Coverage.SplitClause: [infoTau] :: UnifyEquiv -> Substitution
+ Agda.TypeChecking.Coverage.SplitClause: [infoTel0] :: UnifyEquiv -> Telescope
+ Agda.TypeChecking.Coverage.SplitClause: [infoTel] :: UnifyEquiv -> Telescope
+ Agda.TypeChecking.Coverage.SplitClause: [scCheckpoints] :: SplitClause -> Map CheckpointId Substitution
+ Agda.TypeChecking.Coverage.SplitClause: [scPats] :: SplitClause -> [NamedArg SplitPattern]
+ Agda.TypeChecking.Coverage.SplitClause: [scSubst] :: SplitClause -> Substitution' SplitPattern
+ Agda.TypeChecking.Coverage.SplitClause: [scTarget] :: SplitClause -> Maybe (Dom Type)
+ Agda.TypeChecking.Coverage.SplitClause: [scTel] :: SplitClause -> Telescope
+ Agda.TypeChecking.Coverage.SplitClause: clauseToSplitClause :: Clause -> SplitClause
+ Agda.TypeChecking.Coverage.SplitClause: data CoverResult
+ Agda.TypeChecking.Coverage.SplitClause: data Covering
+ Agda.TypeChecking.Coverage.SplitClause: data IInfo
+ Agda.TypeChecking.Coverage.SplitClause: data SplitClause
+ Agda.TypeChecking.Coverage.SplitClause: data UnifyEquiv
+ Agda.TypeChecking.Coverage.SplitClause: instance GHC.Show.Show Agda.TypeChecking.Coverage.SplitClause.IInfo
+ Agda.TypeChecking.Coverage.SplitClause: instance GHC.Show.Show Agda.TypeChecking.Coverage.SplitClause.UnifyEquiv
+ Agda.TypeChecking.Coverage.SplitClause: splitClauses :: Covering -> [SplitClause]
+ Agda.TypeChecking.Datatypes: getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo)
+ Agda.TypeChecking.Datatypes: getDatatypeArgs :: HasConstInfo m => Type -> m (Maybe (QName, Args, Args))
+ Agda.TypeChecking.Datatypes: isConstructor :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Datatypes: isPathCons :: HasConstInfo m => QName -> m Bool
+ Agda.TypeChecking.Errors: class Verbalize a
+ Agda.TypeChecking.Errors: explainWhyInScope :: forall m. MonadPretty m => WhyInScopeData -> m Doc
+ Agda.TypeChecking.Errors: instance Agda.TypeChecking.Errors.Verbalize Agda.Syntax.Common.Modality
+ Agda.TypeChecking.Errors: verbalize :: Verbalize a => a -> String
+ Agda.TypeChecking.Free: instance Agda.TypeChecking.Free.Lazy.IsVarSet Agda.TypeChecking.Free.Lazy.MetaSet Agda.TypeChecking.Free.SingleFlexRig
+ Agda.TypeChecking.Free: metaSetToBlocker :: MetaSet -> Blocker
+ Agda.TypeChecking.Free.Lazy: metaSetToBlocker :: MetaSet -> Blocker
+ Agda.TypeChecking.Free.Reduce: reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a) => IntSet -> a -> m (Either Blocked_ (Maybe a))
+ Agda.TypeChecking.Injectivity: isUnstableDef :: PureTCM m => QName -> m Bool
+ Agda.TypeChecking.InstanceArguments: getInstanceCandidates :: MetaId -> TCM (Either Blocker [Candidate])
+ Agda.TypeChecking.Irrelevance: usableAtModality' :: MonadConstraint TCM => Maybe Sort -> WhyCheckModality -> Modality -> Term -> TCM ()
+ Agda.TypeChecking.Level: levelType' :: HasBuiltins m => m Type
+ Agda.TypeChecking.Monad.Base: AxiomData :: Bool -> AxiomData
+ Agda.TypeChecking.Monad.Base: AxiomDefn :: AxiomData -> Defn
+ Agda.TypeChecking.Monad.Base: BuiltinRewriteRelations :: Set QName -> Builtin pf
+ Agda.TypeChecking.Monad.Base: CheckDataSort :: QName -> Sort -> Constraint
+ Agda.TypeChecking.Monad.Base: CheckIApplyConfluence :: Range -> QName -> Term -> Term -> Term -> Type -> Call
+ Agda.TypeChecking.Monad.Base: ConstructorData :: Int -> Int -> ConHead -> QName -> IsAbstract -> Induction -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> ConstructorData
+ Agda.TypeChecking.Monad.Base: ConstructorDefn :: ConstructorData -> Defn
+ Agda.TypeChecking.Monad.Base: ConstructorType :: WhyCheckModality
+ Agda.TypeChecking.Monad.Base: DataOrRecSigData :: Int -> DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: DataOrRecSigDefn :: DataOrRecSigData -> Defn
+ Agda.TypeChecking.Monad.Base: DatatypeData :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Maybe QName -> Maybe QName -> DatatypeData
+ Agda.TypeChecking.Monad.Base: DatatypeDefn :: DatatypeData -> Defn
+ Agda.TypeChecking.Monad.Base: FunctionData :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> IsAbstract -> Delayed -> Either ProjectionLikenessMissing Projection -> Set FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Maybe QName -> FunctionData
+ Agda.TypeChecking.Monad.Base: FunctionDefn :: FunctionData -> Defn
+ Agda.TypeChecking.Monad.Base: GeneratedClause :: WhyCheckModality
+ Agda.TypeChecking.Monad.Base: IndexedClause :: WhyCheckModality
+ Agda.TypeChecking.Monad.Base: IndexedClauseArg :: Name -> Name -> WhyCheckModality
+ Agda.TypeChecking.Monad.Base: Instantiation :: [Arg String] -> Term -> Instantiation
+ Agda.TypeChecking.Monad.Base: MaybeProjection :: ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: NeverProjection :: ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: OptionWarning :: OptionWarning -> Warning
+ Agda.TypeChecking.Monad.Base: PIntervalUniv :: NLPSort
+ Agda.TypeChecking.Monad.Base: PSSet :: NLPat -> NLPSort
+ Agda.TypeChecking.Monad.Base: PrimitiveData :: IsAbstract -> String -> [Clause] -> FunctionInverse -> Maybe CompiledClauses -> PrimitiveData
+ Agda.TypeChecking.Monad.Base: PrimitiveDefn :: PrimitiveData -> Defn
+ Agda.TypeChecking.Monad.Base: PrimitiveSortData :: String -> Sort -> PrimitiveSortData
+ Agda.TypeChecking.Monad.Base: PrimitiveSortDefn :: PrimitiveSortData -> Defn
+ Agda.TypeChecking.Monad.Base: RecordData :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> Maybe Bool -> IsAbstract -> CompKit -> RecordData
+ Agda.TypeChecking.Monad.Base: RecordDefn :: RecordData -> Defn
+ Agda.TypeChecking.Monad.Base: RemoteMetaVariable :: Instantiation -> Modality -> Judgement MetaId -> RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: UnequalFiniteness :: Comparison -> Term -> Term -> TypeError
+ Agda.TypeChecking.Monad.Base: UnsupportedIndexedMatch :: Doc -> Warning
+ Agda.TypeChecking.Monad.Base: [_axiomConstTransp] :: AxiomData -> Bool
+ Agda.TypeChecking.Monad.Base: [_conAbstr] :: ConstructorData -> IsAbstract
+ Agda.TypeChecking.Monad.Base: [_conArity] :: ConstructorData -> Int
+ Agda.TypeChecking.Monad.Base: [_conComp] :: ConstructorData -> CompKit
+ Agda.TypeChecking.Monad.Base: [_conData] :: ConstructorData -> QName
+ Agda.TypeChecking.Monad.Base: [_conErased] :: ConstructorData -> Maybe [Bool]
+ Agda.TypeChecking.Monad.Base: [_conForced] :: ConstructorData -> [IsForced]
+ Agda.TypeChecking.Monad.Base: [_conInd] :: ConstructorData -> Induction
+ Agda.TypeChecking.Monad.Base: [_conPars] :: ConstructorData -> Int
+ Agda.TypeChecking.Monad.Base: [_conProj] :: ConstructorData -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: [_conSrcCon] :: ConstructorData -> ConHead
+ Agda.TypeChecking.Monad.Base: [_dataAbstr] :: DatatypeData -> IsAbstract
+ Agda.TypeChecking.Monad.Base: [_dataClause] :: DatatypeData -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: [_dataCons] :: DatatypeData -> [QName]
+ Agda.TypeChecking.Monad.Base: [_dataIxs] :: DatatypeData -> Nat
+ Agda.TypeChecking.Monad.Base: [_dataMutual] :: DatatypeData -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: [_dataPars] :: DatatypeData -> Nat
+ Agda.TypeChecking.Monad.Base: [_dataPathCons] :: DatatypeData -> [QName]
+ Agda.TypeChecking.Monad.Base: [_dataSort] :: DatatypeData -> Sort
+ Agda.TypeChecking.Monad.Base: [_dataTranspIx] :: DatatypeData -> Maybe QName
+ Agda.TypeChecking.Monad.Base: [_dataTransp] :: DatatypeData -> Maybe QName
+ Agda.TypeChecking.Monad.Base: [_datarecPars] :: DataOrRecSigData -> Int
+ Agda.TypeChecking.Monad.Base: [_funAbstr] :: FunctionData -> IsAbstract
+ Agda.TypeChecking.Monad.Base: [_funClauses] :: FunctionData -> [Clause]
+ Agda.TypeChecking.Monad.Base: [_funCompiled] :: FunctionData -> Maybe CompiledClauses
+ Agda.TypeChecking.Monad.Base: [_funCovering] :: FunctionData -> [Clause]
+ Agda.TypeChecking.Monad.Base: [_funDelayed] :: FunctionData -> Delayed
+ Agda.TypeChecking.Monad.Base: [_funExtLam] :: FunctionData -> Maybe ExtLamInfo
+ Agda.TypeChecking.Monad.Base: [_funFlags] :: FunctionData -> Set FunctionFlag
+ Agda.TypeChecking.Monad.Base: [_funInv] :: FunctionData -> FunctionInverse
+ Agda.TypeChecking.Monad.Base: [_funIsKanOp] :: FunctionData -> Maybe QName
+ Agda.TypeChecking.Monad.Base: [_funMutual] :: FunctionData -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: [_funProjection] :: FunctionData -> Either ProjectionLikenessMissing Projection
+ Agda.TypeChecking.Monad.Base: [_funSplitTree] :: FunctionData -> Maybe SplitTree
+ Agda.TypeChecking.Monad.Base: [_funTerminates] :: FunctionData -> Maybe Bool
+ Agda.TypeChecking.Monad.Base: [_funTreeless] :: FunctionData -> Maybe Compiled
+ Agda.TypeChecking.Monad.Base: [_funWith] :: FunctionData -> Maybe QName
+ Agda.TypeChecking.Monad.Base: [_primAbstr] :: PrimitiveData -> IsAbstract
+ Agda.TypeChecking.Monad.Base: [_primClauses] :: PrimitiveData -> [Clause]
+ Agda.TypeChecking.Monad.Base: [_primCompiled] :: PrimitiveData -> Maybe CompiledClauses
+ Agda.TypeChecking.Monad.Base: [_primInv] :: PrimitiveData -> FunctionInverse
+ Agda.TypeChecking.Monad.Base: [_primName] :: PrimitiveData -> String
+ Agda.TypeChecking.Monad.Base: [_primSortName] :: PrimitiveSortData -> String
+ Agda.TypeChecking.Monad.Base: [_primSortSort] :: PrimitiveSortData -> Sort
+ Agda.TypeChecking.Monad.Base: [_recAbstr] :: RecordData -> IsAbstract
+ Agda.TypeChecking.Monad.Base: [_recClause] :: RecordData -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: [_recComp] :: RecordData -> CompKit
+ Agda.TypeChecking.Monad.Base: [_recConHead] :: RecordData -> ConHead
+ Agda.TypeChecking.Monad.Base: [_recEtaEquality'] :: RecordData -> EtaEquality
+ Agda.TypeChecking.Monad.Base: [_recFields] :: RecordData -> [Dom QName]
+ Agda.TypeChecking.Monad.Base: [_recInduction] :: RecordData -> Maybe Induction
+ Agda.TypeChecking.Monad.Base: [_recMutual] :: RecordData -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: [_recNamedCon] :: RecordData -> Bool
+ Agda.TypeChecking.Monad.Base: [_recPars] :: RecordData -> Nat
+ Agda.TypeChecking.Monad.Base: [_recPatternMatching] :: RecordData -> PatternOrCopattern
+ Agda.TypeChecking.Monad.Base: [_recTel] :: RecordData -> Telescope
+ Agda.TypeChecking.Monad.Base: [_recTerminates] :: RecordData -> Maybe Bool
+ Agda.TypeChecking.Monad.Base: [envSyntacticEqualityFuel] :: TCEnv -> !Maybe Int
+ Agda.TypeChecking.Monad.Base: [iMetaBindings] :: Interface -> RemoteMetaStore
+ Agda.TypeChecking.Monad.Base: [iTopLevelModuleName] :: Interface -> TopLevelModuleName
+ Agda.TypeChecking.Monad.Base: [instBody] :: Instantiation -> Term
+ Agda.TypeChecking.Monad.Base: [instTel] :: Instantiation -> [Arg String]
+ Agda.TypeChecking.Monad.Base: [redPred] :: ReduceEnv -> Maybe (MetaId -> ReduceM Bool)
+ Agda.TypeChecking.Monad.Base: [rmvInstantiation] :: RemoteMetaVariable -> Instantiation
+ Agda.TypeChecking.Monad.Base: [rmvJudgement] :: RemoteMetaVariable -> Judgement MetaId
+ Agda.TypeChecking.Monad.Base: [rmvModality] :: RemoteMetaVariable -> Modality
+ Agda.TypeChecking.Monad.Base: [stPersistentTopLevelModuleNames] :: PersistentTCState -> !BiMap RawTopLevelModuleName ModuleNameHash
+ Agda.TypeChecking.Monad.Base: [stPostOpenMetaStore] :: PostScopeState -> !LocalMetaStore
+ Agda.TypeChecking.Monad.Base: [stPostSolvedMetaStore] :: PostScopeState -> !LocalMetaStore
+ Agda.TypeChecking.Monad.Base: [stPreImportedMetaStore] :: PreScopeState -> !RemoteMetaStore
+ Agda.TypeChecking.Monad.Base: axiomConstTransp :: Defn -> Bool
+ Agda.TypeChecking.Monad.Base: conAbstr :: Defn -> IsAbstract
+ Agda.TypeChecking.Monad.Base: conArity :: Defn -> Int
+ Agda.TypeChecking.Monad.Base: conComp :: Defn -> CompKit
+ Agda.TypeChecking.Monad.Base: conData :: Defn -> QName
+ Agda.TypeChecking.Monad.Base: conErased :: Defn -> Maybe [Bool]
+ Agda.TypeChecking.Monad.Base: conForced :: Defn -> [IsForced]
+ Agda.TypeChecking.Monad.Base: conInd :: Defn -> Induction
+ Agda.TypeChecking.Monad.Base: conPars :: Defn -> Int
+ Agda.TypeChecking.Monad.Base: conProj :: Defn -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: conSrcCon :: Defn -> ConHead
+ Agda.TypeChecking.Monad.Base: cubicalCompatibleOption :: HasOptions m => m Bool
+ Agda.TypeChecking.Monad.Base: data AxiomData
+ Agda.TypeChecking.Monad.Base: data ConstructorData
+ Agda.TypeChecking.Monad.Base: data DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: data DatatypeData
+ Agda.TypeChecking.Monad.Base: data FunctionData
+ Agda.TypeChecking.Monad.Base: data Instantiation
+ Agda.TypeChecking.Monad.Base: data PrimitiveData
+ Agda.TypeChecking.Monad.Base: data PrimitiveSortData
+ Agda.TypeChecking.Monad.Base: data ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: data RecordData
+ Agda.TypeChecking.Monad.Base: data RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: data WhyCheckModality
+ Agda.TypeChecking.Monad.Base: dataAbstr :: Defn -> IsAbstract
+ Agda.TypeChecking.Monad.Base: dataClause :: Defn -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: dataCons :: Defn -> [QName]
+ Agda.TypeChecking.Monad.Base: dataIxs :: Defn -> Nat
+ Agda.TypeChecking.Monad.Base: dataMutual :: Defn -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: dataPars :: Defn -> Nat
+ Agda.TypeChecking.Monad.Base: dataPathCons :: Defn -> [QName]
+ Agda.TypeChecking.Monad.Base: dataSort :: Defn -> Sort
+ Agda.TypeChecking.Monad.Base: dataTransp :: Defn -> Maybe QName
+ Agda.TypeChecking.Monad.Base: dataTranspIx :: Defn -> Maybe QName
+ Agda.TypeChecking.Monad.Base: datarecPars :: Defn -> Int
+ Agda.TypeChecking.Monad.Base: emptyFunctionData :: FunctionData
+ Agda.TypeChecking.Monad.Base: funAbstr :: Defn -> IsAbstract
+ Agda.TypeChecking.Monad.Base: funClauses :: Defn -> [Clause]
+ Agda.TypeChecking.Monad.Base: funCompiled :: Defn -> Maybe CompiledClauses
+ Agda.TypeChecking.Monad.Base: funCovering :: Defn -> [Clause]
+ Agda.TypeChecking.Monad.Base: funDelayed :: Defn -> Delayed
+ Agda.TypeChecking.Monad.Base: funExtLam :: Defn -> Maybe ExtLamInfo
+ Agda.TypeChecking.Monad.Base: funFlags :: Defn -> Set FunctionFlag
+ Agda.TypeChecking.Monad.Base: funInv :: Defn -> FunctionInverse
+ Agda.TypeChecking.Monad.Base: funIsKanOp :: Defn -> Maybe QName
+ Agda.TypeChecking.Monad.Base: funMutual :: Defn -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: funProjection :: Defn -> Either ProjectionLikenessMissing Projection
+ Agda.TypeChecking.Monad.Base: funSplitTree :: Defn -> Maybe SplitTree
+ Agda.TypeChecking.Monad.Base: funTerminates :: Defn -> Maybe Bool
+ Agda.TypeChecking.Monad.Base: funTreeless :: Defn -> Maybe Compiled
+ Agda.TypeChecking.Monad.Base: funWith :: Defn -> Maybe QName
+ Agda.TypeChecking.Monad.Base: initialMetaId :: MetaId
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensModality Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensQuantity Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Monad.Base.MetaInfo
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Monad.Base.MetaVariable
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Common.LensRelevance Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.TypeChecking.Monad.Base.NLPSort
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.TypeChecking.Monad.Base.NLPType
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.Generic.TermLike Agda.TypeChecking.Monad.Base.NLPat
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.TypeChecking.Monad.Base.NLPSort
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.TypeChecking.Monad.Base.NLPType
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Internal.MetaVars.AllMetas Agda.TypeChecking.Monad.Base.NLPat
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.HasRange Agda.TypeChecking.Monad.Base.CallInfo
+ Agda.TypeChecking.Monad.Base: instance Agda.Syntax.Position.KillRange Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.CompareAs
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.ConstructorData
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.DatatypeData
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.FunctionData
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.MetaInstantiation
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.PrimitiveData
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.PrimitiveSortData
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Monad.Base.RecordData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData (Agda.Utils.BiMap.BiMap Agda.Syntax.TopLevelModuleName.RawTopLevelModuleName Agda.Syntax.Common.ModuleNameHash)
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.AxiomData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ConstructorData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.DatatypeData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.FunctionData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.Instantiation
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PrimitiveData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.PrimitiveSortData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.RecordData
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: instance Control.DeepSeq.NFData Agda.TypeChecking.Monad.Base.WhyCheckModality
+ Agda.TypeChecking.Monad.Base: instance Control.Monad.Fix.MonadFix m => Control.Monad.Fix.MonadFix (Agda.TypeChecking.Monad.Base.TCMT m)
+ Agda.TypeChecking.Monad.Base: instance GHC.Enum.Bounded Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance GHC.Enum.Enum Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.AxiomData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ConstructorData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.DatatypeData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.FunctionData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.Instantiation
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PrimitiveData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.PrimitiveSortData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.RecordData
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: instance GHC.Generics.Generic Agda.TypeChecking.Monad.Base.WhyCheckModality
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.AxiomData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.ConstructorData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.DataOrRecSigData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.DatatypeData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.FunctionData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.Instantiation
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.PrimitiveData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.PrimitiveSortData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.RecordData
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show Agda.TypeChecking.Monad.Base.WhyCheckModality
+ Agda.TypeChecking.Monad.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Monad.Base.Judgement a)
+ Agda.TypeChecking.Monad.Base: lensConstructor :: Lens' ConstructorData Defn
+ Agda.TypeChecking.Monad.Base: lensFunction :: Lens' FunctionData Defn
+ Agda.TypeChecking.Monad.Base: lensRecTel :: Lens' Telescope RecordData
+ Agda.TypeChecking.Monad.Base: lensRecord :: Lens' RecordData Defn
+ Agda.TypeChecking.Monad.Base: lensTheDef :: Lens' Defn Definition
+ Agda.TypeChecking.Monad.Base: modifyTCLens' :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()
+ Agda.TypeChecking.Monad.Base: pattern Axiom :: Bool -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Constructor :: Int -> Int -> ConHead -> QName -> IsAbstract -> Induction -> CompKit -> Maybe [QName] -> [IsForced] -> Maybe [Bool] -> Defn
+ Agda.TypeChecking.Monad.Base: pattern DataOrRecSig :: Int -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Datatype :: Nat -> Nat -> Maybe Clause -> [QName] -> Sort -> Maybe [QName] -> IsAbstract -> [QName] -> Maybe QName -> Maybe QName -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Function :: [Clause] -> Maybe CompiledClauses -> Maybe SplitTree -> Maybe Compiled -> [Clause] -> FunctionInverse -> Maybe [QName] -> IsAbstract -> Delayed -> Either ProjectionLikenessMissing Projection -> Set FunctionFlag -> Maybe Bool -> Maybe ExtLamInfo -> Maybe QName -> Maybe QName -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Primitive :: IsAbstract -> String -> [Clause] -> FunctionInverse -> Maybe CompiledClauses -> Defn
+ Agda.TypeChecking.Monad.Base: pattern PrimitiveSort :: String -> Sort -> Defn
+ Agda.TypeChecking.Monad.Base: pattern Record :: Nat -> Maybe Clause -> ConHead -> Bool -> [Dom QName] -> Telescope -> Maybe [QName] -> EtaEquality -> PatternOrCopattern -> Maybe Induction -> Maybe Bool -> IsAbstract -> CompKit -> Defn
+ Agda.TypeChecking.Monad.Base: primAbstr :: Defn -> IsAbstract
+ Agda.TypeChecking.Monad.Base: primClauses :: Defn -> [Clause]
+ Agda.TypeChecking.Monad.Base: primCompiled :: Defn -> Maybe CompiledClauses
+ Agda.TypeChecking.Monad.Base: primInv :: Defn -> FunctionInverse
+ Agda.TypeChecking.Monad.Base: primName :: Defn -> String
+ Agda.TypeChecking.Monad.Base: primSortName :: Defn -> String
+ Agda.TypeChecking.Monad.Base: primSortSort :: Defn -> Sort
+ Agda.TypeChecking.Monad.Base: recAbstr :: Defn -> IsAbstract
+ Agda.TypeChecking.Monad.Base: recClause :: Defn -> Maybe Clause
+ Agda.TypeChecking.Monad.Base: recComp :: Defn -> CompKit
+ Agda.TypeChecking.Monad.Base: recConHead :: Defn -> ConHead
+ Agda.TypeChecking.Monad.Base: recEtaEquality' :: Defn -> EtaEquality
+ Agda.TypeChecking.Monad.Base: recFields :: Defn -> [Dom QName]
+ Agda.TypeChecking.Monad.Base: recInduction :: Defn -> Maybe Induction
+ Agda.TypeChecking.Monad.Base: recMutual :: Defn -> Maybe [QName]
+ Agda.TypeChecking.Monad.Base: recNamedCon :: Defn -> Bool
+ Agda.TypeChecking.Monad.Base: recPars :: Defn -> Nat
+ Agda.TypeChecking.Monad.Base: recPatternMatching :: Defn -> PatternOrCopattern
+ Agda.TypeChecking.Monad.Base: recTel :: Defn -> Telescope
+ Agda.TypeChecking.Monad.Base: recTerminates :: Defn -> Maybe Bool
+ Agda.TypeChecking.Monad.Base: setTCLens' :: MonadTCState m => Lens' a TCState -> a -> m ()
+ Agda.TypeChecking.Monad.Base: stImportedMetaStore :: Lens' RemoteMetaStore TCState
+ Agda.TypeChecking.Monad.Base: stOpenMetaStore :: Lens' LocalMetaStore TCState
+ Agda.TypeChecking.Monad.Base: stSolvedMetaStore :: Lens' LocalMetaStore TCState
+ Agda.TypeChecking.Monad.Base: stTopLevelModuleNames :: Lens' (BiMap RawTopLevelModuleName ModuleNameHash) TCState
+ Agda.TypeChecking.Monad.Base: type LocalMetaStore = Map MetaId MetaVariable
+ Agda.TypeChecking.Monad.Base: type RemoteMetaStore = HashMap MetaId RemoteMetaVariable
+ Agda.TypeChecking.Monad.Base: unionBuiltin :: Builtin a -> Builtin a -> Builtin a
+ Agda.TypeChecking.Monad.Benchmark: type BenchPhase m
+ Agda.TypeChecking.Monad.Builtin: bindBuiltinRewriteRelation :: QName -> TCM ()
+ Agda.TypeChecking.Monad.Builtin: class EqualityUnview a
+ Agda.TypeChecking.Monad.Builtin: conidView' :: HasBuiltins m => m (Term -> Term -> Maybe (Arg Term, Arg Term))
+ Agda.TypeChecking.Monad.Builtin: getBuiltinRewriteRelations :: HasBuiltins m => m (Maybe (Set QName))
+ Agda.TypeChecking.Monad.Builtin: infallibleSortKit :: HasBuiltins m => m SortKit
+ Agda.TypeChecking.Monad.Builtin: instance Agda.TypeChecking.Monad.Builtin.EqualityUnview Agda.Syntax.Internal.EqualityTypeData
+ Agda.TypeChecking.Monad.Builtin: instance Agda.TypeChecking.Monad.Builtin.EqualityUnview Agda.Syntax.Internal.EqualityView
+ Agda.TypeChecking.Monad.Builtin: intervalSort :: Sort
+ Agda.TypeChecking.Monad.Builtin: primAgdaErrorPartPatt :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMDeclareData :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMDefineData :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMFormatErrorParts :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Builtin: primAgdaTCMGetInstances :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Builtin: primIntervalUniv :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term
+ Agda.TypeChecking.Monad.Constraints: isInstanceConstraint :: Constraint -> Bool
+ Agda.TypeChecking.Monad.Constraints: shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool
+ Agda.TypeChecking.Monad.Constraints: wakeConstraints' :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m ()
+ Agda.TypeChecking.Monad.Context: instance Agda.TypeChecking.Monad.Context.AddContext (Data.Text.Internal.Text, Agda.Syntax.Internal.Dom Agda.Syntax.Internal.Type)
+ Agda.TypeChecking.Monad.Debug: defaultGetProfileOptions :: HasOptions m => m ProfileOptions
+ Agda.TypeChecking.Monad.Debug: getProfileOptions :: (MonadDebug m, MonadTrans t, MonadDebug n, m ~ t n) => m ProfileOptions
+ Agda.TypeChecking.Monad.Debug: hasProfileOption :: MonadDebug m => ProfileOption -> m Bool
+ Agda.TypeChecking.Monad.Debug: whenProfile :: MonadDebug m => ProfileOption -> m () -> m ()
+ Agda.TypeChecking.Monad.MetaVars: LocalMetaStores :: LocalMetaStore -> LocalMetaStore -> LocalMetaStores
+ Agda.TypeChecking.Monad.MetaVars: [openMetas] :: LocalMetaStores -> LocalMetaStore
+ Agda.TypeChecking.Monad.MetaVars: [solvedMetas] :: LocalMetaStores -> LocalMetaStore
+ Agda.TypeChecking.Monad.MetaVars: data LocalMetaStores
+ Agda.TypeChecking.Monad.MetaVars: etaExpandListeners :: MonadMetaSolver m => MetaId -> m ()
+ Agda.TypeChecking.Monad.MetaVars: etaExpandMetaSafe :: MonadMetaSolver m => MetaId -> m ()
+ Agda.TypeChecking.Monad.MetaVars: instance Agda.TypeChecking.Monad.MetaVars.MonadMetaSolver m => Agda.TypeChecking.Monad.MetaVars.MonadMetaSolver (Control.Monad.Trans.Reader.ReaderT r m)
+ Agda.TypeChecking.Monad.MetaVars: isRemoteMeta :: ReadTCState m => m (MetaId -> Bool)
+ Agda.TypeChecking.Monad.MetaVars: isSortJudgement :: Judgement a -> Bool
+ Agda.TypeChecking.Monad.MetaVars: lookupLocalMeta :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaVariable
+ Agda.TypeChecking.Monad.MetaVars: lookupLocalMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)
+ Agda.TypeChecking.Monad.MetaVars: lookupMetaInstantiation :: ReadTCState m => MetaId -> m MetaInstantiation
+ Agda.TypeChecking.Monad.MetaVars: lookupMetaJudgement :: ReadTCState m => MetaId -> m (Judgement MetaId)
+ Agda.TypeChecking.Monad.MetaVars: lookupMetaModality :: ReadTCState m => MetaId -> m Modality
+ Agda.TypeChecking.Monad.MetaVars: nextLocalMeta :: ReadTCState m => m MetaId
+ Agda.TypeChecking.Monad.MetaVars: solveAwakeConstraints :: MonadConstraint m => m ()
+ Agda.TypeChecking.Monad.MetaVars: solveAwakeConstraints' :: MonadConstraint m => Bool -> m ()
+ Agda.TypeChecking.Monad.MetaVars: wakeupListener :: MonadMetaSolver m => Listener -> m ()
+ Agda.TypeChecking.Monad.MetaVars: withFrozenMetas :: (MonadMetaSolver m, MonadTCState m) => m a -> m a
+ Agda.TypeChecking.Monad.State: currentTopLevelModule :: (MonadTCEnv m, ReadTCState m) => m (Maybe TopLevelModuleName)
+ Agda.TypeChecking.Monad.State: topLevelModuleName :: RawTopLevelModuleName -> TCM TopLevelModuleName
+ Agda.TypeChecking.Names: AbsN :: [ArgName] -> a -> AbsN a
+ Agda.TypeChecking.Names: [absNName] :: AbsN a -> [ArgName]
+ Agda.TypeChecking.Names: [unAbsN] :: AbsN a -> a
+ Agda.TypeChecking.Names: absAppN :: Subst a => AbsN a -> [SubstArg a] -> a
+ Agda.TypeChecking.Names: abstractN :: (MonadFail m, Abstract a) => NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
+ Agda.TypeChecking.Names: abstractT :: (MonadFail m, Abstract a) => String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
+ Agda.TypeChecking.Names: appTel :: Monad m => NamesT m [Term] -> NamesT m Term -> NamesT m [Term]
+ Agda.TypeChecking.Names: applyN :: (Monad m, Subst a) => NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
+ Agda.TypeChecking.Names: applyN' :: (Monad m, Subst a) => NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a
+ Agda.TypeChecking.Names: bindN :: MonadFail m => [ArgName] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
+ Agda.TypeChecking.Names: bindNArg :: MonadFail m => [Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
+ Agda.TypeChecking.Names: data AbsN a
+ Agda.TypeChecking.Names: instance Agda.TypeChecking.Substitute.Class.Subst a => Agda.TypeChecking.Substitute.Class.Subst (Agda.TypeChecking.Names.AbsN a)
+ Agda.TypeChecking.Names: instance Data.Foldable.Foldable Agda.TypeChecking.Names.AbsN
+ Agda.TypeChecking.Names: instance Data.Traversable.Traversable Agda.TypeChecking.Names.AbsN
+ Agda.TypeChecking.Names: instance GHC.Base.Functor Agda.TypeChecking.Names.AbsN
+ Agda.TypeChecking.Names: lamTel :: Monad m => NamesT m (Abs [Term]) -> NamesT m [Term]
+ Agda.TypeChecking.Names: toAbsN :: Abs (AbsN a) -> AbsN a
+ Agda.TypeChecking.Names: type Var m = forall b. (Subst b, DeBruijn b) => NamesT m b
+ Agda.TypeChecking.Names: type Vars m = (forall b. (Subst b, DeBruijn b) => [NamesT m b])
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.Abstract.Pattern
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.ContextEntry
+ Agda.TypeChecking.Pretty: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Monad.Base.NamedMeta
+ Agda.TypeChecking.Pretty.Constraint: prettyRangeConstraint :: (MonadPretty m, Foldable f, Null (f ProblemId)) => Range -> f ProblemId -> Blocker -> Doc -> m Doc
+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.FromTerm GHC.Num.Integer.Integer
+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimTerm GHC.Num.Integer.Integer
+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.PrimType GHC.Num.Integer.Integer
+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.ToTerm (Agda.Syntax.Internal.Dom Agda.Syntax.Internal.Type)
+ Agda.TypeChecking.Primitive: instance Agda.TypeChecking.Primitive.ToTerm GHC.Num.Integer.Integer
+ Agda.TypeChecking.Primitive: metaToNat :: MetaId -> Nat
+ Agda.TypeChecking.Primitive.Base: getQNameFromTerm :: MonadReduce m => Term -> MaybeT m QName
+ Agda.TypeChecking.Primitive.Base: toFinitePi :: Type -> Type
+ Agda.TypeChecking.Primitive.Cubical: CannotTransp :: Closure (Abs Type) -> TranspError
+ Agda.TypeChecking.Primitive.Cubical: ClosedType :: Sort -> QName -> CType
+ Agda.TypeChecking.Primitive.Cubical: LEl :: Level -> Term -> LType
+ Agda.TypeChecking.Primitive.Cubical: LType :: LType -> CType
+ Agda.TypeChecking.Primitive.Cubical: [errorType] :: TranspError -> Closure (Abs Type)
+ Agda.TypeChecking.Primitive.Cubical: data CType
+ Agda.TypeChecking.Primitive.Cubical: data LType
+ Agda.TypeChecking.Primitive.Cubical: data TranspError
+ Agda.TypeChecking.Primitive.Cubical: debugClause :: String -> Clause -> TCM ()
+ Agda.TypeChecking.Primitive.Cubical: doPathPKanOp :: KanOperation -> FamilyOrNot (Arg Term) -> FamilyOrNot (Arg Term, Arg Term, Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
+ Agda.TypeChecking.Primitive.Cubical: doPiKanOp :: KanOperation -> ArgName -> FamilyOrNot (Dom Type, Abs Type) -> ReduceM (Maybe Term)
+ Agda.TypeChecking.Primitive.Cubical: expS :: Nat -> Substitution
+ Agda.TypeChecking.Primitive.Cubical: expTelescope :: Type -> Telescope -> Telescope
+ Agda.TypeChecking.Primitive.Cubical: fromCType :: CType -> Type
+ Agda.TypeChecking.Primitive.Cubical: fromLType :: LType -> Type
+ Agda.TypeChecking.Primitive.Cubical: hcomp :: (HasBuiltins m, MonadError TCErr m, MonadReduce m, MonadPretty m) => NamesT m Type -> [(NamesT m Term, NamesT m Term)] -> NamesT m Term -> NamesT m Term
+ Agda.TypeChecking.Primitive.Cubical: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Primitive.Cubical.CType
+ Agda.TypeChecking.Primitive.Cubical: instance Agda.TypeChecking.Substitute.Class.Subst Agda.TypeChecking.Primitive.Cubical.LType
+ Agda.TypeChecking.Primitive.Cubical: instance Agda.Utils.Pretty.Pretty Agda.TypeChecking.Primitive.Cubical.CType
+ Agda.TypeChecking.Primitive.Cubical: instance GHC.Classes.Eq Agda.TypeChecking.Primitive.Cubical.CType
+ Agda.TypeChecking.Primitive.Cubical: instance GHC.Classes.Eq Agda.TypeChecking.Primitive.Cubical.LType
+ Agda.TypeChecking.Primitive.Cubical: instance GHC.Exception.Type.Exception Agda.TypeChecking.Primitive.Cubical.TranspError
+ Agda.TypeChecking.Primitive.Cubical: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.CType
+ Agda.TypeChecking.Primitive.Cubical: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.LType
+ Agda.TypeChecking.Primitive.Cubical: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.TranspError
+ Agda.TypeChecking.Primitive.Cubical: lTypeLevel :: LType -> Level
+ Agda.TypeChecking.Primitive.Cubical: mkComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
+ Agda.TypeChecking.Primitive.Cubical: mkCompLazy :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
+ Agda.TypeChecking.Primitive.Cubical: pathTelescope :: forall m. (PureTCM m, MonadError TCErr m) => Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
+ Agda.TypeChecking.Primitive.Cubical: pathTelescope' :: forall m. (PureTCM m, MonadError (Closure Type) m) => Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
+ Agda.TypeChecking.Primitive.Cubical: redReturnNoSimpl :: a -> ReduceM (Reduced a' a)
+ Agda.TypeChecking.Primitive.Cubical: toCType :: MonadReduce m => Type -> m (Maybe CType)
+ Agda.TypeChecking.Primitive.Cubical: toLType :: MonadReduce m => Type -> m (Maybe LType)
+ Agda.TypeChecking.Primitive.Cubical: trFillPathPTel' :: NamesT TCM (Abs (Abs Telescope)) -> [NamesT TCM Term] -> [NamesT TCM Term] -> NamesT TCM Term -> [NamesT TCM Term] -> NamesT TCM Term -> NamesT TCM [Arg Term]
+ Agda.TypeChecking.Primitive.Cubical: trFillPathTel' :: NamesT TCM (Abs Telescope) -> [NamesT TCM Term] -> [NamesT TCM Term] -> NamesT TCM Term -> [NamesT TCM Term] -> NamesT TCM Term -> NamesT TCM [Arg Term]
+ Agda.TypeChecking.Primitive.Cubical: trFillTel' :: (PureTCM m, MonadError TCErr m) => Bool -> Abs Telescope -> Term -> Args -> Term -> ExceptT (Closure (Abs Type)) m Args
+ Agda.TypeChecking.Primitive.Cubical: transpPathPTel' :: NamesT TCM (Abs (Abs Telescope)) -> [NamesT TCM Term] -> [NamesT TCM Term] -> NamesT TCM Term -> [NamesT TCM Term] -> NamesT TCM [Arg Term]
+ Agda.TypeChecking.Primitive.Cubical: transpPathTel' :: NamesT TCM (Abs Telescope) -> [NamesT TCM Term] -> [NamesT TCM Term] -> NamesT TCM Term -> [NamesT TCM Term] -> NamesT TCM [Arg Term]
+ Agda.TypeChecking.Primitive.Cubical: transpSys :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) => NamesT m (Abs Type) -> [(NamesT m Term, NamesT m Term)] -> NamesT m Term -> NamesT m Term -> NamesT m Term
+ Agda.TypeChecking.Primitive.Cubical: transpSysTel' :: forall m. (PureTCM m, MonadError TCErr m) => Bool -> Abs Telescope -> [(Term, Abs [Term])] -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args
+ Agda.TypeChecking.Primitive.Cubical: transpTel' :: (PureTCM m, MonadError TCErr m) => Bool -> Abs Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args
+ Agda.TypeChecking.Primitive.Cubical: tryTranspError :: TCM a -> TCM (Either (Closure (Abs Type)) a)
+ Agda.TypeChecking.Primitive.Cubical: type LM m a = NamesT (ExceptT (Closure (Abs Type)) m) a
+ Agda.TypeChecking.Primitive.Cubical.Base: DoHComp :: Command
+ Agda.TypeChecking.Primitive.Cubical.Base: DoTransp :: Command
+ Agda.TypeChecking.Primitive.Cubical.Base: Eliminated :: TermPosition
+ Agda.TypeChecking.Primitive.Cubical.Base: HCompOp :: Blocked (Arg Term) -> Arg Term -> Arg Term -> KanOperation
+ Agda.TypeChecking.Primitive.Cubical.Base: Head :: TermPosition
+ Agda.TypeChecking.Primitive.Cubical.Base: IsFam :: a -> FamilyOrNot a
+ Agda.TypeChecking.Primitive.Cubical.Base: IsNot :: a -> FamilyOrNot a
+ Agda.TypeChecking.Primitive.Cubical.Base: TranspOp :: Blocked (Arg Term) -> Arg Term -> KanOperation
+ Agda.TypeChecking.Primitive.Cubical.Base: [famThing] :: FamilyOrNot a -> a
+ Agda.TypeChecking.Primitive.Cubical.Base: [kanOpBase] :: KanOperation -> Arg Term
+ Agda.TypeChecking.Primitive.Cubical.Base: [kanOpCofib] :: KanOperation -> Blocked (Arg Term)
+ Agda.TypeChecking.Primitive.Cubical.Base: [kanOpSides] :: KanOperation -> Arg Term
+ Agda.TypeChecking.Primitive.Cubical.Base: combineSys :: HasBuiltins m => NamesT m Term -> NamesT m Term -> [(NamesT m Term, NamesT m Term)] -> NamesT m Term
+ Agda.TypeChecking.Primitive.Cubical.Base: combineSys' :: forall m. HasBuiltins m => NamesT m Term -> NamesT m Term -> [(NamesT m Term, NamesT m Term)] -> NamesT m (Term, Term)
+ Agda.TypeChecking.Primitive.Cubical.Base: data Command
+ Agda.TypeChecking.Primitive.Cubical.Base: data FamilyOrNot a
+ Agda.TypeChecking.Primitive.Cubical.Base: data KanOperation
+ Agda.TypeChecking.Primitive.Cubical.Base: data TermPosition
+ Agda.TypeChecking.Primitive.Cubical.Base: decomposeInterval :: HasBuiltins m => Term -> m [(IntMap Bool, [Term])]
+ Agda.TypeChecking.Primitive.Cubical.Base: decomposeInterval' :: HasBuiltins m => Term -> m [(IntMap BoolSet, [Term])]
+ Agda.TypeChecking.Primitive.Cubical.Base: familyOrNot :: IsString p => FamilyOrNot a -> p
+ Agda.TypeChecking.Primitive.Cubical.Base: fiber :: (HasBuiltins m, HasConstInfo m) => NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
+ Agda.TypeChecking.Primitive.Cubical.Base: headStop :: PureTCM m => TermPosition -> m Term -> m Bool
+ Agda.TypeChecking.Primitive.Cubical.Base: hfill :: (HasBuiltins m, HasConstInfo m) => NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
+ Agda.TypeChecking.Primitive.Cubical.Base: imax :: HasBuiltins m => m Term -> m Term -> m Term
+ Agda.TypeChecking.Primitive.Cubical.Base: imin :: HasBuiltins m => m Term -> m Term -> m Term
+ Agda.TypeChecking.Primitive.Cubical.Base: ineg :: HasBuiltins m => m Term -> m Term
+ Agda.TypeChecking.Primitive.Cubical.Base: instance Agda.TypeChecking.Reduce.Reduce a => Agda.TypeChecking.Reduce.Reduce (Agda.TypeChecking.Primitive.Cubical.Base.FamilyOrNot a)
+ Agda.TypeChecking.Primitive.Cubical.Base: instance Data.Foldable.Foldable Agda.TypeChecking.Primitive.Cubical.Base.FamilyOrNot
+ Agda.TypeChecking.Primitive.Cubical.Base: instance Data.Traversable.Traversable Agda.TypeChecking.Primitive.Cubical.Base.FamilyOrNot
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Base.Functor Agda.TypeChecking.Primitive.Cubical.Base.FamilyOrNot
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Classes.Eq Agda.TypeChecking.Primitive.Cubical.Base.Command
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Classes.Eq Agda.TypeChecking.Primitive.Cubical.Base.TermPosition
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Classes.Eq a => GHC.Classes.Eq (Agda.TypeChecking.Primitive.Cubical.Base.FamilyOrNot a)
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.Base.Command
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Show.Show Agda.TypeChecking.Primitive.Cubical.Base.TermPosition
+ Agda.TypeChecking.Primitive.Cubical.Base: instance GHC.Show.Show a => GHC.Show.Show (Agda.TypeChecking.Primitive.Cubical.Base.FamilyOrNot a)
+ Agda.TypeChecking.Primitive.Cubical.Base: isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term))
+ Agda.TypeChecking.Primitive.Cubical.Base: kanOpName :: KanOperation -> String
+ Agda.TypeChecking.Primitive.Cubical.Base: primDepIMin' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Base: primIMax' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Base: primIMin' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Base: primINeg' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Base: primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type
+ Agda.TypeChecking.Primitive.Cubical.Base: reduce2Lam :: Term -> ReduceM (Blocked Term)
+ Agda.TypeChecking.Primitive.Cubical.Base: requireCubical :: Cubical -> String -> TCM ()
+ Agda.TypeChecking.Primitive.Cubical.Glue: doGlueKanOp :: PureTCM m => KanOperation -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)
+ Agda.TypeChecking.Primitive.Cubical.Glue: mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
+ Agda.TypeChecking.Primitive.Cubical.Glue: primGlue' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Glue: prim_glue' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Glue: prim_unglue' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.HCompU: doHCompUKanOp :: PureTCM m => KanOperation -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term) -> TermPosition -> m (Maybe Term)
+ Agda.TypeChecking.Primitive.Cubical.HCompU: prim_glueU' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.HCompU: prim_unglueU' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Id: doIdKanOp :: KanOperation -> FamilyOrNot (Arg Term) -> FamilyOrNot (Arg Term, Arg Term, Arg Term) -> ReduceM (Maybe (Reduced t Term))
+ Agda.TypeChecking.Primitive.Cubical.Id: primConId' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Id: primIdElim' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Id: primIdFace' :: TCM PrimitiveImpl
+ Agda.TypeChecking.Primitive.Cubical.Id: primIdPath' :: TCM PrimitiveImpl
+ Agda.TypeChecking.ReconstructParameters: extractParameters :: QName -> Type -> TCM Args
+ Agda.TypeChecking.ReconstructParameters: reconstruct :: Type -> Term -> TCM Term
+ Agda.TypeChecking.ReconstructParameters: reconstructAction :: Action TCM
+ Agda.TypeChecking.ReconstructParameters: reconstructAction' :: Action TCM -> Action TCM
+ Agda.TypeChecking.Records: updateEtaForRecord :: QName -> TCM ()
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull (Agda.TypeChecking.Monad.Base.Judgement Agda.Syntax.Common.MetaId)
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.Instantiation
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.InstantiateFull Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Reduce: instance Agda.TypeChecking.Reduce.Reduce t => Agda.TypeChecking.Reduce.Reduce (GHC.Maybe.Maybe t)
+ Agda.TypeChecking.Reduce: instantiateWhen :: (InstantiateFull a, MonadReduce m) => (MetaId -> ReduceM Bool) -> a -> m a
+ Agda.TypeChecking.Rewriting: rewriteRelationDom :: QName -> TCM (ListTel, Dom Type)
+ Agda.TypeChecking.Rewriting.NonLinPattern: assertConOf :: ConHead -> Type -> TCM Type
+ Agda.TypeChecking.Rewriting.NonLinPattern: assertPath :: Type -> TCM (Sort, QName, Arg Term, Arg Term, Arg Term, Arg Term)
+ Agda.TypeChecking.Rewriting.NonLinPattern: assertPi :: Type -> TCM (Dom Type, Abs Type)
+ Agda.TypeChecking.Rewriting.NonLinPattern: assertProjOf :: QName -> Type -> TCM (Dom Type, Abs Type)
+ Agda.TypeChecking.Rewriting.NonLinPattern: blockOnMetasIn :: (MonadBlock m, AllMetas t) => t -> m ()
+ Agda.TypeChecking.Rewriting.NonLinPattern: errNotConOf :: ConHead -> Type -> TCM a
+ Agda.TypeChecking.Rewriting.NonLinPattern: errNotPath :: Type -> TCM a
+ Agda.TypeChecking.Rewriting.NonLinPattern: errNotPi :: Type -> TCM a
+ Agda.TypeChecking.Rewriting.NonLinPattern: errNotProjOf :: QName -> Type -> TCM a
+ Agda.TypeChecking.Rules.Data: checkDataSort :: QName -> Sort -> TCM ()
+ Agda.TypeChecking.Rules.Data: defineConClause :: QName -> Bool -> Maybe QName -> Nat -> Nat -> Telescope -> Telescope -> Substitution -> Type -> [QName] -> TCM [Clause]
+ Agda.TypeChecking.Rules.Data: defineKanOperationForFields :: Command -> Maybe Term -> (Term -> QName -> Term) -> QName -> Telescope -> Telescope -> [Arg QName] -> Type -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution))
+ Agda.TypeChecking.Rules.Data: defineTranspFun :: QName -> Maybe QName -> [QName] -> [QName] -> TCM (Maybe QName)
+ Agda.TypeChecking.Rules.Data: defineTranspIx :: QName -> TCM (Maybe QName)
+ Agda.TypeChecking.Rules.Decl: checkSig :: KindOfName -> DefInfo -> QName -> GeneralizeTelescope -> Expr -> TCM ()
+ Agda.TypeChecking.Rules.LHS: [lhsIndexedSplit] :: LHSResult -> Bool
+ Agda.TypeChecking.Rules.LHS.Problem: [_lhsIndexedSplit] :: LHSState a -> !Bool
+ Agda.TypeChecking.Rules.LHS.Unify: Illegal :: UnifyStep -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: NoCubical :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: SplitOnFlat :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: SplitOnStrict :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: UnsupportedCxt :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: UnsupportedYet :: UnifyStep -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: WithKEnabled :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: [badStep] :: NoLeftInv -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify: data NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify: unifyIndices' :: (PureTCM m, MonadError TCErr m) => Maybe NoLeftInv -> Telescope -> FlexibleVars -> Type -> Args -> Args -> m FullUnificationResult
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: Illegal :: UnifyStep -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: NoCubical :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: SplitOnFlat :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: SplitOnStrict :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: UnsupportedCxt :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: UnsupportedYet :: UnifyStep -> NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: WithKEnabled :: NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: [badStep] :: NoLeftInv -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: buildEquiv :: forall tcm. (PureTCM tcm, MonadError TCErr tcm) => UnifyLogEntry -> UnifyState -> tcm (Either NoLeftInv (Retract, Term))
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: buildLeftInverse :: (PureTCM tcm, MonadError TCErr tcm) => UnifyState -> UnifyLog -> tcm (Either NoLeftInv (Substitution, Substitution))
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: composeRetract :: (PureTCM tcm, MonadError TCErr tcm, MonadDebug tcm, HasBuiltins tcm, MonadAddContext tcm) => Retract -> Term -> Retract -> tcm Retract
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: data NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: explainStep :: MonadPretty m => UnifyStep -> m Doc
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Unify.LeftInverse.NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: instance GHC.Show.Show Agda.TypeChecking.Rules.LHS.Unify.LeftInverse.NoLeftInv
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: termsS :: DeBruijn a => Impossible -> [a] -> Substitution' a
+ Agda.TypeChecking.Rules.LHS.Unify.LeftInverse: type Retract = (Telescope, Substitution, Substitution, Substitution)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: Conflict :: Int -> Type -> QName -> Args -> Term -> Term -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: Cycle :: Int -> Type -> QName -> Args -> Int -> Term -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: Deletion :: Int -> Type -> Term -> Term -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: Equal :: Dom Type -> Term -> Term -> Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: EtaExpandEquation :: Int -> QName -> Args -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: EtaExpandVar :: FlexibleVar Int -> QName -> Args -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: Injectivity :: Int -> Type -> QName -> Args -> Args -> ConHead -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: LitConflict :: Int -> Type -> Literal -> Literal -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: SkipIrrelevantEquation :: Int -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: Solution :: Int -> Dom Type -> FlexibleVar Int -> Term -> Either () () -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: StripSizeSuc :: Int -> Term -> Term -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: TypeConInjectivity :: Int -> QName -> Args -> Args -> UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: UState :: Telescope -> FlexibleVars -> Telescope -> [Arg Term] -> [Arg Term] -> UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: UnificationStep :: UnifyState -> UnifyStep -> UnifyOutput -> UnifyLogEntry
+ Agda.TypeChecking.Rules.LHS.Unify.Types: UnifyOutput :: PatternSubstitution -> PatternSubstitution -> UnifyOutput
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [_eqLeft] :: Equality -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [_eqRight] :: Equality -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [_eqType] :: Equality -> Dom Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [conflictAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [conflictDatatype] :: UnifyStep -> QName
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [conflictLeft] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [conflictParameters] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [conflictRight] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [conflictType] :: UnifyStep -> Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [cycleAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [cycleDatatype] :: UnifyStep -> QName
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [cycleOccursIn] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [cycleParameters] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [cycleType] :: UnifyStep -> Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [cycleVar] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [deleteAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [deleteLeft] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [deleteRight] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [deleteType] :: UnifyStep -> Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [eqLHS] :: UnifyState -> [Arg Term]
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [eqRHS] :: UnifyState -> [Arg Term]
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [eqTel] :: UnifyState -> Telescope
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [expandAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [expandParameters] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [expandRecordType] :: UnifyStep -> QName
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [expandVarParameters] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [expandVarRecordType] :: UnifyStep -> QName
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [expandVar] :: UnifyStep -> FlexibleVar Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [flexVars] :: UnifyState -> FlexibleVars
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [injectAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [injectConstructor] :: UnifyStep -> ConHead
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [injectDatatype] :: UnifyStep -> QName
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [injectIndices] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [injectParameters] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [injectType] :: UnifyStep -> Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [litConflictAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [litConflictLeft] :: UnifyStep -> Literal
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [litConflictRight] :: UnifyStep -> Literal
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [litType] :: UnifyStep -> Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [skipIrrelevantAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [solutionAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [solutionSide] :: UnifyStep -> Either () ()
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [solutionTerm] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [solutionType] :: UnifyStep -> Dom Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [solutionVar] :: UnifyStep -> FlexibleVar Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [stripArgLeft] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [stripArgRight] :: UnifyStep -> Term
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [stripAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [typeConArgsLeft] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [typeConArgsRight] :: UnifyStep -> Args
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [typeConInjectAt] :: UnifyStep -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [typeConstructor] :: UnifyStep -> QName
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [unifyProof] :: UnifyOutput -> PatternSubstitution
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [unifySubst] :: UnifyOutput -> PatternSubstitution
+ Agda.TypeChecking.Rules.LHS.Unify.Types: [varTel] :: UnifyState -> Telescope
+ Agda.TypeChecking.Rules.LHS.Unify.Types: applyUnder :: Int -> Telescope -> Term -> Telescope
+ Agda.TypeChecking.Rules.LHS.Unify.Types: data Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: data UnifyLogEntry
+ Agda.TypeChecking.Rules.LHS.Unify.Types: data UnifyOutput
+ Agda.TypeChecking.Rules.LHS.Unify.Types: data UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: data UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: dropAt :: Int -> [a] -> [a]
+ Agda.TypeChecking.Rules.LHS.Unify.Types: eqConstructorForm :: HasBuiltins m => Equality -> m Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: eqCount :: UnifyState -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: eqUnLevel :: HasBuiltins m => Equality -> m Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: getEquality :: Int -> UnifyState -> Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: getEqualityUnraised :: Int -> UnifyState -> Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: getReducedEquality :: (MonadReduce m, MonadAddContext m) => Int -> UnifyState -> m Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: getReducedEqualityUnraised :: (MonadReduce m, MonadAddContext m) => Int -> UnifyState -> m Equality
+ Agda.TypeChecking.Rules.LHS.Unify.Types: getVarType :: Int -> UnifyState -> Dom Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: getVarTypeUnraised :: Int -> UnifyState -> Dom Type
+ Agda.TypeChecking.Rules.LHS.Unify.Types: initUnifyState :: PureTCM m => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance Agda.TypeChecking.Reduce.Reduce Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance GHC.Base.Monoid Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyOutput
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance GHC.Base.Semigroup Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyOutput
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance GHC.Show.Show Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: instance GHC.Show.Show Agda.TypeChecking.Rules.LHS.Unify.Types.UnifyStep
+ Agda.TypeChecking.Rules.LHS.Unify.Types: isUnifyStateSolved :: UnifyState -> Bool
+ Agda.TypeChecking.Rules.LHS.Unify.Types: lensEqTel :: Lens' Telescope UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: lensVarTel :: Lens' Telescope UnifyState
+ Agda.TypeChecking.Rules.LHS.Unify.Types: runUnifyLogT :: Functor m => UnifyLogT m a -> m (a, UnifyLog)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: solveVar :: Int -> DeBruijnPattern -> UnifyState -> Maybe (UnifyState, PatternSubstitution)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()
+ Agda.TypeChecking.Rules.LHS.Unify.Types: tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()
+ Agda.TypeChecking.Rules.LHS.Unify.Types: type UnifyLog = [(UnifyLogEntry, UnifyState)]
+ Agda.TypeChecking.Rules.LHS.Unify.Types: type UnifyLog' = DList (UnifyLogEntry, UnifyState)
+ Agda.TypeChecking.Rules.LHS.Unify.Types: type UnifyLogT m a = WriterT UnifyLog' m a
+ Agda.TypeChecking.Rules.LHS.Unify.Types: type UnifyStepT m a = WriterT UnifyOutput m a
+ Agda.TypeChecking.Rules.LHS.Unify.Types: varCount :: UnifyState -> Int
+ Agda.TypeChecking.Rules.LHS.Unify.Types: writeUnifyLog :: MonadWriter UnifyLog' m => (UnifyLogEntry, UnifyState) -> m ()
+ Agda.TypeChecking.Rules.Record: defineKanOperationR :: Command -> QName -> Telescope -> Telescope -> [Arg QName] -> Type -> TCM (Maybe QName)
+ Agda.TypeChecking.Serialise: instance Data.Binary.Class.Binary a => Data.Binary.Class.Binary (Agda.TypeChecking.Serialise.ListLike a)
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.BoundVariablePosition
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Common.NotationPart
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.Position.RangeFile
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Syntax.TopLevelModuleName.TopLevelModuleName
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj GHC.Num.Integer.Integer
+ Agda.TypeChecking.Serialise.Instances.Common: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.Utils.List1.List1 a)
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.Base.InfectiveCoinfective
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Interaction.Options.Base.OptionWarning
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Utils.ProfileOptions.ProfileOption
+ Agda.TypeChecking.Serialise.Instances.Errors: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.Utils.ProfileOptions.ProfileOptions
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.Comparison
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.Instantiation
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.ProjectionLikenessMissing
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj Agda.TypeChecking.Monad.Base.RemoteMetaVariable
+ Agda.TypeChecking.Serialise.Instances.Internal: instance Agda.TypeChecking.Serialise.Base.EmbPrj a => Agda.TypeChecking.Serialise.Base.EmbPrj (Agda.TypeChecking.Monad.Base.Judgement a)
+ Agda.TypeChecking.SizedTypes.Syntax: instance Agda.TypeChecking.Pretty.PrettyTCM Agda.TypeChecking.SizedTypes.Syntax.Flex
+ Agda.TypeChecking.SizedTypes.Syntax: type Error = TCM Doc
+ Agda.TypeChecking.SizedTypes.Syntax: type FlexOf a;
+ Agda.TypeChecking.SizedTypes.Syntax: type RigidOf a;
+ Agda.TypeChecking.Substitute: LargeSort :: IsFibrant -> Integer -> SizeOfSort
+ Agda.TypeChecking.Substitute: SmallSort :: IsFibrant -> SizeOfSort
+ Agda.TypeChecking.Substitute: absV :: Dom a -> ArgName -> TelV a -> TelV a
+ Agda.TypeChecking.Substitute: data SizeOfSort
+ Agda.TypeChecking.Substitute: instance Agda.TypeChecking.Substitute.Class.Subst Agda.Syntax.Internal.EqualityTypeData
+ Agda.TypeChecking.Substitute: sizeOfSort :: Sort -> Either Blocker SizeOfSort
+ Agda.TypeChecking.Substitute.Class: strengthenS' :: Impossible -> Int -> Substitution' a -> Substitution' a
+ Agda.TypeChecking.Substitute.Class: type SubstArg a;
+ Agda.TypeChecking.Substitute.DeBruijn: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn a => Agda.TypeChecking.Substitute.DeBruijn.DeBruijn (Agda.Syntax.Common.Named_ a)
+ Agda.TypeChecking.SyntacticEquality: checkSyntacticEquality' :: (Instantiate a, SynEq a, MonadReduce m) => a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
+ Agda.TypeChecking.SyntacticEquality: syntacticEqualityFuelRemains :: MonadReduce m => m Bool
+ Agda.TypeChecking.Telescope: unflattenTel' :: Int -> [ArgName] -> [Dom Type] -> Telescope
+ Agda.TypeChecking.Telescope.Path: class IApplyVars p
+ Agda.TypeChecking.Telescope.Path: instance Agda.TypeChecking.Substitute.DeBruijn.DeBruijn a => Agda.TypeChecking.Telescope.Path.IApplyVars (Agda.Syntax.Internal.Pattern' a)
+ Agda.TypeChecking.Telescope.Path: instance Agda.TypeChecking.Telescope.Path.IApplyVars p => Agda.TypeChecking.Telescope.Path.IApplyVars (Agda.Syntax.Common.NamedArg p)
+ Agda.TypeChecking.Telescope.Path: instance Agda.TypeChecking.Telescope.Path.IApplyVars p => Agda.TypeChecking.Telescope.Path.IApplyVars [p]
+ Agda.TypeChecking.Unquote: PattPart :: Pattern -> ErrorPart
+ Agda.TypeChecking.Unquote: instance Agda.TypeChecking.Unquote.Unquote GHC.Num.Integer.Integer
+ Agda.Utils.Benchmark: type BenchPhase m;
+ Agda.Utils.BiMap: source :: Ord k => k -> BiMap k v -> Bool
+ Agda.Utils.BiMap: target :: Ord (Tag v) => Tag v -> BiMap k v -> Bool
+ Agda.Utils.BiMap: type Tag a;
+ Agda.Utils.BoolSet: (\\) :: BoolSet -> BoolSet -> BoolSet
+ Agda.Utils.BoolSet: complement :: BoolSet -> BoolSet
+ Agda.Utils.BoolSet: data BoolSet
+ Agda.Utils.BoolSet: delete :: Bool -> BoolSet -> BoolSet
+ Agda.Utils.BoolSet: difference :: BoolSet -> BoolSet -> BoolSet
+ Agda.Utils.BoolSet: elems :: BoolSet -> [Bool]
+ Agda.Utils.BoolSet: empty :: BoolSet
+ Agda.Utils.BoolSet: fromAscList :: [Bool] -> BoolSet
+ Agda.Utils.BoolSet: fromDistinctAscList :: [Bool] -> BoolSet
+ Agda.Utils.BoolSet: fromList :: [Bool] -> BoolSet
+ Agda.Utils.BoolSet: insert :: Bool -> BoolSet -> BoolSet
+ Agda.Utils.BoolSet: instance GHC.Classes.Eq Agda.Utils.BoolSet.BoolSet
+ Agda.Utils.BoolSet: instance GHC.Classes.Ord Agda.Utils.BoolSet.BoolSet
+ Agda.Utils.BoolSet: instance GHC.Enum.Bounded Agda.Utils.BoolSet.BoolSet
+ Agda.Utils.BoolSet: instance GHC.Enum.Enum Agda.Utils.BoolSet.BoolSet
+ Agda.Utils.BoolSet: instance GHC.Show.Show Agda.Utils.BoolSet.BoolSet
+ Agda.Utils.BoolSet: intersection :: BoolSet -> BoolSet -> BoolSet
+ Agda.Utils.BoolSet: isSubsetOf :: BoolSet -> BoolSet -> Bool
+ Agda.Utils.BoolSet: lookupMin :: BoolSet -> Maybe Bool
+ Agda.Utils.BoolSet: member :: Bool -> BoolSet -> Bool
+ Agda.Utils.BoolSet: notMember :: Bool -> BoolSet -> Bool
+ Agda.Utils.BoolSet: null :: BoolSet -> Bool
+ Agda.Utils.BoolSet: singleton :: Bool -> BoolSet
+ Agda.Utils.BoolSet: size :: BoolSet -> Int
+ Agda.Utils.BoolSet: toAscList :: BoolSet -> [Bool]
+ Agda.Utils.BoolSet: toList :: BoolSet -> [Bool]
+ Agda.Utils.BoolSet: toSingleton :: BoolSet -> Maybe Bool
+ Agda.Utils.BoolSet: total :: BoolSet
+ Agda.Utils.BoolSet: union :: BoolSet -> BoolSet -> BoolSet
+ Agda.Utils.FileName: relativizeAbsolutePath :: AbsolutePath -> AbsolutePath -> Maybe FilePath
+ Agda.Utils.HashTable: data HashTable k v
+ Agda.Utils.HashTable: empty :: IO (HashTable k v)
+ Agda.Utils.HashTable: insert :: (Eq k, Hashable k) => HashTable k v -> k -> v -> IO ()
+ Agda.Utils.HashTable: lookup :: (Eq k, Hashable k) => HashTable k v -> k -> IO (Maybe v)
+ Agda.Utils.HashTable: toList :: (Eq k, Hashable k) => HashTable k v -> IO [(k, v)]
+ Agda.Utils.IO.UTF8: data ReadException
+ Agda.Utils.IO.UTF8: instance GHC.Exception.Type.Exception Agda.Utils.IO.UTF8.ReadException
+ Agda.Utils.IO.UTF8: instance GHC.Show.Show Agda.Utils.IO.UTF8.ReadException
+ Agda.Utils.List: (!!) :: HasCallStack => [a] -> Int -> a
+ Agda.Utils.List: nubFavouriteOn :: forall a b c. (Ord b, Eq c, Hashable c) => (a -> b) -> (a -> c) -> [a] -> [a]
+ Agda.Utils.List: suffixesSatisfying :: (a -> Bool) -> [a] -> [Bool]
+ Agda.Utils.List1: (:|) :: a -> [a] -> NonEmpty a
+ Agda.Utils.List1: -- structure <tt>l</tt>.
+ Agda.Utils.List1: -- | The <a>Item</a> type function returns the type of items of the
+ Agda.Utils.List1: append :: NonEmpty a -> NonEmpty a -> NonEmpty a
+ Agda.Utils.List1: class () => IsList l where {
+ Agda.Utils.List1: data () => NonEmpty a
+ Agda.Utils.List1: foldr :: (a -> b -> b) -> (a -> b) -> List1 a -> b
+ Agda.Utils.List1: fromListN :: IsList l => Int -> [Item l] -> l
+ Agda.Utils.List1: fromListSafe :: List1 a -> [a] -> List1 a
+ Agda.Utils.List1: type String1 = List1 Char
+ Agda.Utils.List1: type family Item l
+ Agda.Utils.List1: wordsBy :: (a -> Bool) -> [a] -> [List1 a]
+ Agda.Utils.List1: }
+ Agda.Utils.List2: append :: List1 a -> List1 a -> List2 a
+ Agda.Utils.List2: appendList :: List2 a -> [a] -> List2 a
+ Agda.Utils.List2: cons :: a -> List1 a -> List2 a
+ Agda.Utils.List2: fromList1Either :: List1 a -> Either a (List2 a)
+ Agda.Utils.List2: instance GHC.IsList.IsList (Agda.Utils.List2.List2 a)
+ Agda.Utils.List2: toList1Either :: Either a (List2 a) -> List1 a
+ Agda.Utils.Monad: embedWriter :: (Monoid w, Monad m) => Writer w a -> WriterT w m a
+ Agda.Utils.Monad: tell1 :: (Monoid ws, Singleton w ws, MonadWriter ws m) => w -> m ()
+ Agda.Utils.Null: instance (Agda.Utils.Null.Null (m a), GHC.Base.Monad m) => Agda.Utils.Null.Null (Control.Monad.Trans.Except.ExceptT e m a)
+ Agda.Utils.Null: instance (Agda.Utils.Null.Null (m a), GHC.Base.Monad m) => Agda.Utils.Null.Null (Control.Monad.Trans.State.Lazy.StateT s m a)
+ Agda.Utils.Null: instance (Agda.Utils.Null.Null (m a), GHC.Base.Monad m, GHC.Base.Monoid w) => Agda.Utils.Null.Null (Control.Monad.Trans.Writer.Lazy.WriterT w m a)
+ Agda.Utils.Null: instance Agda.Utils.Null.Null a => Agda.Utils.Null.Null (Data.Functor.Identity.Identity a)
+ Agda.Utils.Null: instance Agda.Utils.Null.Null a => Agda.Utils.Null.Null (GHC.Types.IO a)
+ Agda.Utils.PartialOrd: instance Agda.Utils.PartialOrd.PartialOrd GHC.Num.Integer.Integer
+ Agda.Utils.Pretty: instance Agda.Utils.Pretty.Pretty GHC.Num.Integer.Integer
+ Agda.Utils.ProfileOptions: Constraints :: ProfileOption
+ Agda.Utils.ProfileOptions: Conversion :: ProfileOption
+ Agda.Utils.ProfileOptions: Definitions :: ProfileOption
+ Agda.Utils.ProfileOptions: Interactive :: ProfileOption
+ Agda.Utils.ProfileOptions: Internal :: ProfileOption
+ Agda.Utils.ProfileOptions: Metas :: ProfileOption
+ Agda.Utils.ProfileOptions: Modules :: ProfileOption
+ Agda.Utils.ProfileOptions: Serialize :: ProfileOption
+ Agda.Utils.ProfileOptions: Sharing :: ProfileOption
+ Agda.Utils.ProfileOptions: addProfileOption :: String -> ProfileOptions -> Either String ProfileOptions
+ Agda.Utils.ProfileOptions: containsProfileOption :: ProfileOption -> ProfileOptions -> Bool
+ Agda.Utils.ProfileOptions: data ProfileOption
+ Agda.Utils.ProfileOptions: data ProfileOptions
+ Agda.Utils.ProfileOptions: instance Control.DeepSeq.NFData Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance Control.DeepSeq.NFData Agda.Utils.ProfileOptions.ProfileOptions
+ Agda.Utils.ProfileOptions: instance GHC.Classes.Eq Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance GHC.Classes.Eq Agda.Utils.ProfileOptions.ProfileOptions
+ Agda.Utils.ProfileOptions: instance GHC.Classes.Ord Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance GHC.Enum.Bounded Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance GHC.Enum.Enum Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance GHC.Generics.Generic Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance GHC.Show.Show Agda.Utils.ProfileOptions.ProfileOption
+ Agda.Utils.ProfileOptions: instance GHC.Show.Show Agda.Utils.ProfileOptions.ProfileOptions
+ Agda.Utils.ProfileOptions: noProfileOptions :: ProfileOptions
+ Agda.Utils.ProfileOptions: profileOptionsFromList :: [ProfileOption] -> ProfileOptions
+ Agda.Utils.ProfileOptions: profileOptionsToList :: ProfileOptions -> [ProfileOption]
+ Agda.Utils.ProfileOptions: validProfileOptionStrings :: [String]
+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Collection a (Data.DList.Internal.DList a)
+ Agda.Utils.Singleton: instance Agda.Utils.Singleton.Singleton a (Data.DList.Internal.DList a)
+ Agda.Utils.SmallSet: mapMembership :: SmallSetElement a => (Bool -> Bool) -> SmallSet a -> SmallSet a
+ Agda.Utils.SmallSet: zipMembershipWith :: SmallSetElement a => (Bool -> Bool -> Bool) -> SmallSet a -> SmallSet a -> SmallSet a
+ Agda.Utils.Zipper: type Carrier z;
+ Agda.Utils.Zipper: type Element z;
+ Agda.Version: docsUrl :: String -> String
- Agda.Compiler.Backend: AmbiguousName :: QName -> List1 QName -> TypeError
+ Agda.Compiler.Backend: AmbiguousName :: QName -> AmbiguousNameReason -> TypeError
- Agda.Compiler.Backend: Backend' :: String -> Maybe String -> opts -> [OptDescr (Flag opts)] -> (opts -> Bool) -> (opts -> TCM env) -> (env -> IsMain -> Map ModuleName mod -> TCM ()) -> (env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)) -> (env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod) -> (env -> menv -> IsMain -> Definition -> TCM def) -> Bool -> (QName -> TCM Bool) -> Backend' opts env menv mod def
+ Agda.Compiler.Backend: Backend' :: String -> Maybe String -> opts -> [OptDescr (Flag opts)] -> (opts -> Bool) -> (opts -> TCM env) -> (env -> IsMain -> Map TopLevelModuleName mod -> TCM ()) -> (env -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile menv mod)) -> (env -> menv -> IsMain -> TopLevelModuleName -> [def] -> TCM mod) -> (env -> menv -> IsMain -> Definition -> TCM def) -> Bool -> (QName -> TCM Bool) -> Backend' opts env menv mod def
- Agda.Compiler.Backend: CallInfo :: QName -> Range -> Closure Term -> CallInfo
+ Agda.Compiler.Backend: CallInfo :: QName -> Closure Term -> CallInfo
- Agda.Compiler.Backend: CoInfectiveImport :: String -> ModuleName -> Warning
+ Agda.Compiler.Backend: CoInfectiveImport :: Doc -> Warning
- Agda.Compiler.Backend: InfectiveImport :: String -> ModuleName -> Warning
+ Agda.Compiler.Backend: InfectiveImport :: Doc -> Warning
- Agda.Compiler.Backend: InstV :: [Arg String] -> Term -> MetaInstantiation
+ Agda.Compiler.Backend: InstV :: Instantiation -> MetaInstantiation
- Agda.Compiler.Backend: Interface :: Hash -> Text -> FileType -> [(ModuleName, Hash)] -> ModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> DisplayForms -> Map QName Text -> Maybe Text -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface
+ Agda.Compiler.Backend: Interface :: Hash -> Text -> FileType -> [(TopLevelModuleName, Hash)] -> ModuleName -> TopLevelModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> RemoteMetaStore -> DisplayForms -> Map QName Text -> Maybe Text -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface
- Agda.Compiler.Backend: PersistentTCSt :: !DecodedModules -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState
+ Agda.Compiler.Backend: PersistentTCSt :: !DecodedModules -> !BiMap RawTopLevelModuleName ModuleNameHash -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState
- Agda.Compiler.Backend: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !MetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe ModuleName -> !TempInstanceTable -> !ConcreteNames -> !Map RawName [RawName] -> !Map Name [RawName] -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState
+ Agda.Compiler.Backend: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !LocalMetaStore -> !LocalMetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe (ModuleName, TopLevelModuleName) -> !TempInstanceTable -> !ConcreteNames -> !Map RawName (DList RawName) -> !Map Name (DList RawName) -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState
- Agda.Compiler.Backend: PreScopeState :: !HighlightingInfo -> !Signature -> !Set ModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName Text -> !Map QName Text -> !Maybe Text -> !Set QName -> !Map FilePath ProjectConfig -> !Map FilePath AgdaLibFile -> PreScopeState
+ Agda.Compiler.Backend: PreScopeState :: !HighlightingInfo -> !Signature -> !HashSet TopLevelModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName Text -> !Map QName Text -> !Maybe Text -> !Set QName -> !Map FilePath ProjectConfig -> !Map FilePath AgdaLibFile -> !RemoteMetaStore -> PreScopeState
- Agda.Compiler.Backend: ReduceEnv :: TCEnv -> TCState -> ReduceEnv
+ Agda.Compiler.Backend: ReduceEnv :: TCEnv -> TCState -> Maybe (MetaId -> ReduceM Bool) -> ReduceEnv
- Agda.Compiler.Backend: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> ReduceDefs -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Maybe BackendName -> Bool -> Bool -> TCEnv
+ Agda.Compiler.Backend: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> ReduceDefs -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Maybe BackendName -> Bool -> Bool -> !Maybe Int -> TCEnv
- Agda.Compiler.Backend: UsableAtModality :: Modality -> Term -> Constraint
+ Agda.Compiler.Backend: UsableAtModality :: WhyCheckModality -> Maybe Sort -> Modality -> Term -> Constraint
- Agda.Compiler.Backend: [iImportedModules] :: Interface -> [(ModuleName, Hash)]
+ Agda.Compiler.Backend: [iImportedModules] :: Interface -> [(TopLevelModuleName, Hash)]
- Agda.Compiler.Backend: [postCompile] :: Backend' opts env menv mod def -> env -> IsMain -> Map ModuleName mod -> TCM ()
+ Agda.Compiler.Backend: [postCompile] :: Backend' opts env menv mod def -> env -> IsMain -> Map TopLevelModuleName mod -> TCM ()
- Agda.Compiler.Backend: [postModule] :: Backend' opts env menv mod def -> env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod
+ Agda.Compiler.Backend: [postModule] :: Backend' opts env menv mod def -> env -> menv -> IsMain -> TopLevelModuleName -> [def] -> TCM mod
- Agda.Compiler.Backend: [preModule] :: Backend' opts env menv mod def -> env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)
+ Agda.Compiler.Backend: [preModule] :: Backend' opts env menv mod def -> env -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile menv mod)
- Agda.Compiler.Backend: [stPostCurrentModule] :: PostScopeState -> !Maybe ModuleName
+ Agda.Compiler.Backend: [stPostCurrentModule] :: PostScopeState -> !Maybe (ModuleName, TopLevelModuleName)
- Agda.Compiler.Backend: [stPostShadowingNames] :: PostScopeState -> !Map Name [RawName]
+ Agda.Compiler.Backend: [stPostShadowingNames] :: PostScopeState -> !Map Name (DList RawName)
- Agda.Compiler.Backend: [stPostUsedNames] :: PostScopeState -> !Map RawName [RawName]
+ Agda.Compiler.Backend: [stPostUsedNames] :: PostScopeState -> !Map RawName (DList RawName)
- Agda.Compiler.Backend: [stPreImportedModules] :: PreScopeState -> !Set ModuleName
+ Agda.Compiler.Backend: [stPreImportedModules] :: PreScopeState -> !HashSet TopLevelModuleName
- Agda.Compiler.Backend: addClauses :: QName -> [Clause] -> TCM ()
+ Agda.Compiler.Backend: addClauses :: (MonadConstraint m, MonadTCState m) => QName -> [Clause] -> m ()
- Agda.Compiler.Backend: addImport :: ModuleName -> TCM ()
+ Agda.Compiler.Backend: addImport :: TopLevelModuleName -> TCM ()
- Agda.Compiler.Backend: equalityUnview :: EqualityView -> Type
+ Agda.Compiler.Backend: equalityUnview :: EqualityUnview a => a -> Type
- Agda.Compiler.Backend: freezeMetas :: MetaStore -> TCM IntSet
+ Agda.Compiler.Backend: freezeMetas :: MonadTCState m => LocalMetaStore -> m (Set MetaId)
- Agda.Compiler.Backend: getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]
+ Agda.Compiler.Backend: getAgdaLibFiles :: AbsolutePath -> TopLevelModuleName -> TCM [AgdaLibFile]
- Agda.Compiler.Backend: getBuiltin :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => String -> m Term
+ Agda.Compiler.Backend: getBuiltin :: (HasBuiltins m, MonadTCError m) => String -> m Term
- Agda.Compiler.Backend: getContext :: MonadTCEnv m => m [Dom (Name, Type)]
+ Agda.Compiler.Backend: getContext :: MonadTCEnv m => m Context
- Agda.Compiler.Backend: getInteractionScope :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => InteractionId -> m ScopeInfo
+ Agda.Compiler.Backend: getInteractionScope :: (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => InteractionId -> m ScopeInfo
- Agda.Compiler.Backend: getLibraryOptions :: FilePath -> TCM [OptionsPragma]
+ Agda.Compiler.Backend: getLibraryOptions :: AbsolutePath -> TopLevelModuleName -> TCM [OptionsPragma]
- Agda.Compiler.Backend: getMetaListeners :: (MonadFail m, ReadTCState m) => MetaId -> m [Listener]
+ Agda.Compiler.Backend: getMetaListeners :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m [Listener]
- Agda.Compiler.Backend: getMetaNameSuggestion :: (MonadFail m, ReadTCState m) => MetaId -> m MetaNameSuggestion
+ Agda.Compiler.Backend: getMetaNameSuggestion :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaNameSuggestion
- Agda.Compiler.Backend: getMetaPriority :: (MonadFail m, ReadTCState m) => MetaId -> m MetaPriority
+ Agda.Compiler.Backend: getMetaPriority :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaPriority
- Agda.Compiler.Backend: getMetaRange :: (MonadFail m, ReadTCState m) => MetaId -> m Range
+ Agda.Compiler.Backend: getMetaRange :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Range
- Agda.Compiler.Backend: getMetaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type
+ Agda.Compiler.Backend: getMetaType :: ReadTCState m => MetaId -> m Type
- Agda.Compiler.Backend: getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m) => MetaId -> m Type
+ Agda.Compiler.Backend: getMetaTypeInContext :: (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m, MonadTCEnv m, ReadTCState m) => MetaId -> m Type
- Agda.Compiler.Backend: getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]
+ Agda.Compiler.Backend: getUniqueMetasRanges :: (HasCallStack, MonadDebug m, ReadTCState m) => [MetaId] -> m [Range]
- Agda.Compiler.Backend: getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]
+ Agda.Compiler.Backend: getUnsolvedInteractionMetas :: (HasCallStack, MonadDebug m, ReadTCState m) => m [Range]
- Agda.Compiler.Backend: getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]
+ Agda.Compiler.Backend: getUnsolvedMetas :: (HasCallStack, MonadDebug m, ReadTCState m) => m [Range]
- Agda.Compiler.Backend: isFrozen :: (MonadFail m, ReadTCState m) => MetaId -> m Bool
+ Agda.Compiler.Backend: isFrozen :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Bool
- Agda.Compiler.Backend: isGeneralizableMeta :: (ReadTCState m, MonadFail m) => MetaId -> m DoGeneralize
+ Agda.Compiler.Backend: isGeneralizableMeta :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m DoGeneralize
- Agda.Compiler.Backend: isSortMeta :: (MonadFail m, ReadTCState m) => MetaId -> m Bool
+ Agda.Compiler.Backend: isSortMeta :: ReadTCState m => MetaId -> m Bool
- Agda.Compiler.Backend: lookupBV' :: MonadTCEnv m => Nat -> m (Maybe (Dom (Name, Type)))
+ Agda.Compiler.Backend: lookupBV' :: MonadTCEnv m => Nat -> m (Maybe ContextEntry)
- Agda.Compiler.Backend: lookupMeta :: (MonadFail m, ReadTCState m) => MetaId -> m MetaVariable
+ Agda.Compiler.Backend: lookupMeta :: ReadTCState m => MetaId -> m (Maybe (Either RemoteMetaVariable MetaVariable))
- Agda.Compiler.Backend: lookupMutualBlock :: MutualId -> TCM MutualBlock
+ Agda.Compiler.Backend: lookupMutualBlock :: ReadTCState tcm => MutualId -> tcm MutualBlock
- Agda.Compiler.Backend: metaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type
+ Agda.Compiler.Backend: metaType :: ReadTCState m => MetaId -> m Type
- Agda.Compiler.Backend: metasCreatedBy :: ReadTCState m => m a -> m (a, MetaStore)
+ Agda.Compiler.Backend: metasCreatedBy :: forall m a. ReadTCState m => m a -> m (a, LocalMetaStores)
- Agda.Compiler.Backend: printStatistics :: (MonadDebug m, MonadTCEnv m, HasOptions m) => Int -> Maybe TopLevelModuleName -> Statistics -> m ()
+ Agda.Compiler.Backend: printStatistics :: (MonadDebug m, MonadTCEnv m, HasOptions m) => Maybe TopLevelModuleName -> Statistics -> m ()
- Agda.Compiler.Backend: setTerminates :: QName -> Bool -> TCM ()
+ Agda.Compiler.Backend: setTerminates :: MonadTCState m => QName -> Bool -> m ()
- Agda.Compiler.Backend: setTopLevelModule :: QName -> TCM ()
+ Agda.Compiler.Backend: setTopLevelModule :: TopLevelModuleName -> TCM ()
- Agda.Compiler.Backend: sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => NonEmpty Term -> m Term
+ Agda.Compiler.Backend: sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => List1 Term -> m Term
- Agda.Compiler.Backend: sortKit :: HasBuiltins m => m SortKit
+ Agda.Compiler.Backend: sortKit :: (HasBuiltins m, MonadTCError m, HasOptions m) => m SortKit
- Agda.Compiler.Backend: stCurrentModule :: Lens' (Maybe ModuleName) TCState
+ Agda.Compiler.Backend: stCurrentModule :: Lens' (Maybe (ModuleName, TopLevelModuleName)) TCState
- Agda.Compiler.Backend: stImportedModules :: Lens' (Set ModuleName) TCState
+ Agda.Compiler.Backend: stImportedModules :: Lens' (HashSet TopLevelModuleName) TCState
- Agda.Compiler.Backend: stShadowingNames :: Lens' (Map Name [RawName]) TCState
+ Agda.Compiler.Backend: stShadowingNames :: Lens' (Map Name (DList RawName)) TCState
- Agda.Compiler.Backend: stUsedNames :: Lens' (Map RawName [RawName]) TCState
+ Agda.Compiler.Backend: stUsedNames :: Lens' (Map RawName (DList RawName)) TCState
- Agda.Compiler.Backend: type SizeMaxView = NonEmpty DeepSizeView
+ Agda.Compiler.Backend: type SizeMaxView = List1 DeepSizeView
- Agda.Compiler.Backend: type Verbosity = Trie VerboseKey VerboseLevel
+ Agda.Compiler.Backend: type Verbosity = Maybe (Trie VerboseKeyItem VerboseLevel)
- Agda.Compiler.Backend: updateMetaVarTCM :: MetaId -> (MetaVariable -> MetaVariable) -> TCM ()
+ Agda.Compiler.Backend: updateMetaVarTCM :: HasCallStack => MetaId -> (MetaVariable -> MetaVariable) -> TCM ()
- Agda.Compiler.Backend: withInteractionId :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m) => InteractionId -> m a -> m a
+ Agda.Compiler.Backend: withInteractionId :: (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m) => InteractionId -> m a -> m a
- Agda.Compiler.Backend: withMetaId :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaId -> m a -> m a
+ Agda.Compiler.Backend: withMetaId :: (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m, ReadTCState m) => MetaId -> m a -> m a
- Agda.Compiler.Backend: withTopLevelModule :: QName -> TCM a -> TCM a
+ Agda.Compiler.Backend: withTopLevelModule :: TopLevelModuleName -> TCM a -> TCM a
- Agda.Compiler.CallCompiler: callCompiler :: Bool -> FilePath -> [String] -> Maybe TextEncoding -> TCM ()
+ Agda.Compiler.CallCompiler: callCompiler :: Bool -> FilePath -> [String] -> Maybe FilePath -> Maybe TextEncoding -> TCM ()
- Agda.Compiler.CallCompiler: callCompiler' :: FilePath -> [String] -> Maybe TextEncoding -> TCM (Maybe String)
+ Agda.Compiler.CallCompiler: callCompiler' :: FilePath -> [String] -> Maybe FilePath -> Maybe TextEncoding -> TCM (Maybe String)
- Agda.Compiler.Common: curMName :: ReadTCState m => m ModuleName
+ Agda.Compiler.Common: curMName :: ReadTCState m => m TopLevelModuleName
- Agda.Compiler.Common: topLevelModuleName :: ReadTCState m => ModuleName -> m ModuleName
+ Agda.Compiler.Common: topLevelModuleName :: ReadTCState m => ModuleName -> m TopLevelModuleName
- Agda.Compiler.JS.Compiler: jsMod :: ModuleName -> GlobalId
+ Agda.Compiler.JS.Compiler: jsMod :: TopLevelModuleName -> GlobalId
- Agda.Compiler.JS.Compiler: jsPostCompile :: JSOptions -> IsMain -> Map ModuleName Module -> TCM ()
+ Agda.Compiler.JS.Compiler: jsPostCompile :: JSOptions -> IsMain -> Map TopLevelModuleName Module -> TCM ()
- Agda.Compiler.JS.Compiler: jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM Module
+ Agda.Compiler.JS.Compiler: jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> TopLevelModuleName -> [Maybe Export] -> TCM Module
- Agda.Compiler.JS.Compiler: jsPreModule :: JSOptions -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module)
+ Agda.Compiler.JS.Compiler: jsPreModule :: JSOptions -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module)
- Agda.Compiler.MAlonzo.Compiler: GHCDefinition :: UsesFloat -> [Decl] -> Definition -> Maybe MainFunctionDef -> Set ModuleName -> GHCDefinition
+ Agda.Compiler.MAlonzo.Compiler: GHCDefinition :: UsesFloat -> [Decl] -> Definition -> Maybe MainFunctionDef -> Set TopLevelModuleName -> GHCDefinition
- Agda.Compiler.MAlonzo.Compiler: [ghcDefImports] :: GHCDefinition -> Set ModuleName
+ Agda.Compiler.MAlonzo.Compiler: [ghcDefImports] :: GHCDefinition -> Set TopLevelModuleName
- Agda.Compiler.MAlonzo.Compiler: ghcPostCompile :: GHCEnv -> IsMain -> Map ModuleName GHCModule -> TCM ()
+ Agda.Compiler.MAlonzo.Compiler: ghcPostCompile :: GHCEnv -> IsMain -> Map TopLevelModuleName GHCModule -> TCM ()
- Agda.Compiler.MAlonzo.Compiler: ghcPostModule :: GHCEnv -> GHCModuleEnv -> IsMain -> ModuleName -> [GHCDefinition] -> TCM GHCModule
+ Agda.Compiler.MAlonzo.Compiler: ghcPostModule :: GHCEnv -> GHCModuleEnv -> IsMain -> TopLevelModuleName -> [GHCDefinition] -> TCM GHCModule
- Agda.Compiler.MAlonzo.Compiler: ghcPreModule :: GHCEnv -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile GHCModuleEnv GHCModule)
+ Agda.Compiler.MAlonzo.Compiler: ghcPreModule :: GHCEnv -> IsMain -> TopLevelModuleName -> Maybe FilePath -> TCM (Recompile GHCModuleEnv GHCModule)
- Agda.Compiler.MAlonzo.Compiler: imports :: BuiltinThings PrimFun -> Set ModuleName -> [Definition] -> [ImportDecl]
+ Agda.Compiler.MAlonzo.Compiler: imports :: BuiltinThings PrimFun -> Set TopLevelModuleName -> [Definition] -> [ImportDecl]
- Agda.Compiler.MAlonzo.Misc: HsCompileState :: Set ModuleName -> HsCompileState
+ Agda.Compiler.MAlonzo.Misc: HsCompileState :: Set TopLevelModuleName -> HsCompileState
- Agda.Compiler.MAlonzo.Misc: HsModuleEnv :: ModuleName -> Bool -> HsModuleEnv
+ Agda.Compiler.MAlonzo.Misc: HsModuleEnv :: TopLevelModuleName -> Bool -> HsModuleEnv
- Agda.Compiler.MAlonzo.Misc: [mazAccumlatedImports] :: HsCompileState -> Set ModuleName
+ Agda.Compiler.MAlonzo.Misc: [mazAccumlatedImports] :: HsCompileState -> Set TopLevelModuleName
- Agda.Compiler.MAlonzo.Misc: [mazModuleName] :: HsModuleEnv -> ModuleName
+ Agda.Compiler.MAlonzo.Misc: [mazModuleName] :: HsModuleEnv -> TopLevelModuleName
- Agda.Compiler.MAlonzo.Misc: curAgdaMod :: ReadGHCModuleEnv m => m ModuleName
+ Agda.Compiler.MAlonzo.Misc: curAgdaMod :: ReadGHCModuleEnv m => m TopLevelModuleName
- Agda.Compiler.MAlonzo.Misc: mazMod :: ModuleName -> ModuleName
+ Agda.Compiler.MAlonzo.Misc: mazMod :: TopLevelModuleName -> ModuleName
- Agda.Interaction.Base: CurrentFile :: AbsolutePath -> [String] -> ClockTime -> CurrentFile
+ Agda.Interaction.Base: CurrentFile :: AbsolutePath -> TopLevelModuleName -> [String] -> ClockTime -> CurrentFile
- Agda.Interaction.Base: type IOTCM = IOTCM' Range
+ Agda.Interaction.Base: type IOTCM = Maybe TopLevelModuleName -> IOTCM' Range
- Agda.Interaction.BasicOps: whyInScope :: String -> TCM (Maybe LocalVar, [AbstractName], [AbstractModule])
+ Agda.Interaction.BasicOps: whyInScope :: FilePath -> String -> TCM WhyInScopeData
- Agda.Interaction.EmacsTop: explainWhyInScope :: FilePath -> String -> Maybe LocalVar -> [AbstractName] -> [AbstractModule] -> TCM Doc
+ Agda.Interaction.EmacsTop: explainWhyInScope :: forall m. MonadPretty m => WhyInScopeData -> m Doc
- Agda.Interaction.ExitCode: exitAgdaWith :: AgdaError -> IO ()
+ Agda.Interaction.ExitCode: exitAgdaWith :: AgdaError -> IO a
- Agda.Interaction.Highlighting.FromAbstract: runHighlighter :: Hilite a => SourceToModule -> AbsolutePath -> NameKinds -> a -> HighlightingInfoBuilder
+ Agda.Interaction.Highlighting.FromAbstract: runHighlighter :: Hilite a => TopLevelModuleName -> NameKinds -> a -> HighlightingInfoBuilder
- Agda.Interaction.Highlighting.Generate: generateTokenInfoFromSource :: AbsolutePath -> String -> TCM HighlightingInfo
+ Agda.Interaction.Highlighting.Generate: generateTokenInfoFromSource :: RangeFile -> String -> TCM HighlightingInfo
- Agda.Interaction.Imports: Source :: Text -> FileType -> SourceFile -> Module -> TopLevelModuleName -> [AgdaLibFile] -> Source
+ Agda.Interaction.Imports: Source :: Text -> FileType -> SourceFile -> Module -> TopLevelModuleName -> [AgdaLibFile] -> !CohesionAttributes -> Source
- Agda.Interaction.Imports: scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)
+ Agda.Interaction.Imports: scopeCheckImport :: TopLevelModuleName -> ModuleName -> TCM (ModuleName, Map ModuleName Scope)
- Agda.Interaction.JSON: class FromJSON a
+ Agda.Interaction.JSON: class () => FromJSON a
- Agda.Interaction.JSON: class FromJSON1 (f :: Type -> Type)
+ Agda.Interaction.JSON: class () => FromJSON1 (f :: Type -> Type)
- Agda.Interaction.JSON: class FromJSON2 (f :: Type -> Type -> Type)
+ Agda.Interaction.JSON: class () => FromJSON2 (f :: Type -> Type -> Type)
- Agda.Interaction.JSON: class FromJSONKey a
+ Agda.Interaction.JSON: class () => FromJSONKey a
- Agda.Interaction.JSON: class GFromJSON arity (f :: Type -> Type)
+ Agda.Interaction.JSON: class () => GFromJSON arity (f :: Type -> Type)
- Agda.Interaction.JSON: class GToJSON' enc arity (f :: Type -> Type)
+ Agda.Interaction.JSON: class () => GToJSON' enc arity (f :: Type -> Type)
- Agda.Interaction.JSON: class KeyValue kv
+ Agda.Interaction.JSON: class () => KeyValue kv
- Agda.Interaction.JSON: class ToJSON a
+ Agda.Interaction.JSON: class () => ToJSON a
- Agda.Interaction.JSON: class ToJSON1 (f :: Type -> Type)
+ Agda.Interaction.JSON: class () => ToJSON1 (f :: Type -> Type)
- Agda.Interaction.JSON: class ToJSON2 (f :: Type -> Type -> Type)
+ Agda.Interaction.JSON: class () => ToJSON2 (f :: Type -> Type -> Type)
- Agda.Interaction.JSON: class ToJSONKey a
+ Agda.Interaction.JSON: class () => ToJSONKey a
- Agda.Interaction.JSON: data FromArgs arity a
+ Agda.Interaction.JSON: data () => FromArgs arity a
- Agda.Interaction.JSON: data FromJSONKeyFunction a
+ Agda.Interaction.JSON: data () => FromJSONKeyFunction a
- Agda.Interaction.JSON: data JSONKeyOptions
+ Agda.Interaction.JSON: data () => JSONKeyOptions
- Agda.Interaction.JSON: data Key
+ Agda.Interaction.JSON: data () => Key
- Agda.Interaction.JSON: data One
+ Agda.Interaction.JSON: data () => One
- Agda.Interaction.JSON: data Options
+ Agda.Interaction.JSON: data () => Options
- Agda.Interaction.JSON: data Series
+ Agda.Interaction.JSON: data () => Series
- Agda.Interaction.JSON: data SumEncoding
+ Agda.Interaction.JSON: data () => SumEncoding
- Agda.Interaction.JSON: data ToArgs res arity a
+ Agda.Interaction.JSON: data () => ToArgs res arity a
- Agda.Interaction.JSON: data ToJSONKeyFunction a
+ Agda.Interaction.JSON: data () => ToJSONKeyFunction a
- Agda.Interaction.JSON: data Value
+ Agda.Interaction.JSON: data () => Value
- Agda.Interaction.JSON: data Zero
+ Agda.Interaction.JSON: data () => Zero
- Agda.Interaction.JSON: infixr 1 >=>
+ Agda.Interaction.JSON: infixr 1 <=<
- Agda.Interaction.JSON: newtype DotNetTime
+ Agda.Interaction.JSON: newtype () => DotNetTime
- Agda.Interaction.Library.Base: formatLibPositionInfo :: LibPositionInfo -> String -> Doc
+ Agda.Interaction.Library.Base: formatLibPositionInfo :: LibPositionInfo -> LibParseError -> Doc
- Agda.Interaction.Library.Base: raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m ()
+ Agda.Interaction.Library.Base: raiseErrors :: MonadWriter LibErrWarns m => List1 LibError -> m ()
- Agda.Interaction.Library.Base: raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m ()
+ Agda.Interaction.Library.Base: raiseErrors' :: MonadWriter LibErrWarns m => List1 LibError' -> m ()
- Agda.Interaction.Library.Base: type LibErrorIO = WriterT [Either LibError LibWarning] (StateT LibState IO)
+ Agda.Interaction.Library.Base: type LibErrorIO = WriterT LibErrWarns (StateT LibState IO)
- Agda.Interaction.Library.Base: warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m ()
+ Agda.Interaction.Library.Base: warnings :: MonadWriter LibErrWarns m => List1 LibWarning -> m ()
- Agda.Interaction.Library.Base: warnings' :: MonadWriter [Either LibError LibWarning] m => [LibWarning'] -> m ()
+ Agda.Interaction.Library.Base: warnings' :: MonadWriter LibErrWarns m => List1 LibWarning' -> m ()
- Agda.Interaction.Library.Parse: runP :: P a -> (Either String a, [LibWarning'])
+ Agda.Interaction.Library.Parse: runP :: P a -> (Either LibParseError a, [LibWarning'])
- Agda.Interaction.Options: Options :: String -> Maybe FilePath -> [FilePath] -> [AbsolutePath] -> [LibName] -> Maybe FilePath -> Bool -> Bool -> Map ExeName FilePath -> Bool -> Bool -> Maybe Help -> Bool -> Bool -> Bool -> Bool -> Maybe FilePath -> Bool -> Bool -> Bool -> Bool -> PragmaOptions -> Bool -> CommandLineOptions
+ Agda.Interaction.Options: Options :: String -> Maybe FilePath -> [FilePath] -> [AbsolutePath] -> [LibName] -> Maybe FilePath -> Bool -> Bool -> Map ExeName FilePath -> Bool -> Bool -> Maybe Help -> Bool -> Bool -> Bool -> !Bool -> Maybe FilePath -> Bool -> Bool -> Bool -> Bool -> PragmaOptions -> Bool -> Bool -> CommandLineOptions
- Agda.Interaction.Options: PragmaOptions :: Bool -> Bool -> UnicodeOrAscii -> Verbosity -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> CutOff -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> WithDefault 'False -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe Cubical -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Int -> Bool -> Bool -> Bool -> WarningMode -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe ConfluenceCheck -> Bool -> Bool -> Bool -> Bool -> PragmaOptions
+ Agda.Interaction.Options: PragmaOptions :: Bool -> Bool -> UnicodeOrAscii -> !Verbosity -> ProfileOptions -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> CutOff -> Bool -> Bool -> Bool -> WithDefault 'False -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> WithDefault 'False -> WithDefault 'False -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe Cubical -> Bool -> Bool -> Bool -> Bool -> Int -> Bool -> Bool -> Int -> Bool -> Bool -> !Maybe Int -> WarningMode -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe ConfluenceCheck -> Bool -> WithDefault 'False -> Bool -> Bool -> Bool -> WithDefault 'False -> Bool -> Bool -> PragmaOptions
- Agda.Interaction.Options: [optFlatSplit] :: PragmaOptions -> Bool
+ Agda.Interaction.Options: [optFlatSplit] :: PragmaOptions -> WithDefault 'False
- Agda.Interaction.Options: [optSyntacticEquality] :: PragmaOptions -> Bool
+ Agda.Interaction.Options: [optSyntacticEquality] :: PragmaOptions -> !Maybe Int
- Agda.Interaction.Options: [optVerbose] :: PragmaOptions -> Verbosity
+ Agda.Interaction.Options: [optVerbose] :: PragmaOptions -> !Verbosity
- Agda.Interaction.Options: checkOpts :: Flag CommandLineOptions
+ Agda.Interaction.Options: checkOpts :: MonadError OptionError m => CommandLineOptions -> m ()
- Agda.Interaction.Options: data ArgDescr a
+ Agda.Interaction.Options: data () => ArgDescr a
- Agda.Interaction.Options: data OptDescr a
+ Agda.Interaction.Options: data () => OptDescr a
- Agda.Interaction.Options: runOptM :: Monad m => OptM opts -> m (Either String opts)
+ Agda.Interaction.Options: runOptM :: OptM opts -> (Either OptionError opts, OptionWarnings)
- Agda.Interaction.Options: type Verbosity = Trie VerboseKey VerboseLevel
+ Agda.Interaction.Options: type Verbosity = Maybe (Trie VerboseKeyItem VerboseLevel)
- Agda.Interaction.Options: unsafePragmaOptions :: CommandLineOptions -> PragmaOptions -> [String]
+ Agda.Interaction.Options: unsafePragmaOptions :: PragmaOptions -> [String]
- Agda.Interaction.Response: Info_WhyInScope :: String -> FilePath -> Maybe LocalVar -> [AbstractName] -> [AbstractModule] -> DisplayInfo
+ Agda.Interaction.Response: Info_WhyInScope :: WhyInScopeData -> DisplayInfo
- Agda.Syntax.Abstract: Axiom :: KindOfName -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Expr -> Declaration
+ Agda.Syntax.Abstract: Axiom :: KindOfName -> DefInfo -> ArgInfo -> Maybe [Occurrence] -> QName -> Type -> Declaration
- Agda.Syntax.Abstract: DataSig :: DefInfo -> QName -> GeneralizeTelescope -> Expr -> Declaration
+ Agda.Syntax.Abstract: DataSig :: DefInfo -> QName -> GeneralizeTelescope -> Type -> Declaration
- Agda.Syntax.Abstract: Field :: DefInfo -> QName -> Arg Expr -> Declaration
+ Agda.Syntax.Abstract: Field :: DefInfo -> QName -> Arg Type -> Declaration
- Agda.Syntax.Abstract: Fun :: ExprInfo -> Arg Expr -> Expr -> Expr
+ Agda.Syntax.Abstract: Fun :: ExprInfo -> Arg Type -> Type -> Expr
- Agda.Syntax.Abstract: Generalize :: Set QName -> DefInfo -> ArgInfo -> QName -> Expr -> Declaration
+ Agda.Syntax.Abstract: Generalize :: Set QName -> DefInfo -> ArgInfo -> QName -> Type -> Declaration
- Agda.Syntax.Abstract: Generalized :: Set QName -> Expr -> Expr
+ Agda.Syntax.Abstract: Generalized :: Set QName -> Type -> Expr
- Agda.Syntax.Abstract: LetBind :: LetInfo -> ArgInfo -> BindName -> Expr -> Expr -> LetBinding
+ Agda.Syntax.Abstract: LetBind :: LetInfo -> ArgInfo -> BindName -> Type -> Expr -> LetBinding
- Agda.Syntax.Abstract: Pi :: ExprInfo -> Telescope1 -> Expr -> Expr
+ Agda.Syntax.Abstract: Pi :: ExprInfo -> Telescope1 -> Type -> Expr
- Agda.Syntax.Abstract: Primitive :: DefInfo -> QName -> Arg Expr -> Declaration
+ Agda.Syntax.Abstract: Primitive :: DefInfo -> QName -> Arg Type -> Declaration
- Agda.Syntax.Abstract: RecDef :: DefInfo -> QName -> UniverseCheck -> RecordDirectives -> DataDefParams -> Expr -> [Declaration] -> Declaration
+ Agda.Syntax.Abstract: RecDef :: DefInfo -> QName -> UniverseCheck -> RecordDirectives -> DataDefParams -> Type -> [Declaration] -> Declaration
- Agda.Syntax.Abstract: RecSig :: DefInfo -> QName -> GeneralizeTelescope -> Expr -> Declaration
+ Agda.Syntax.Abstract: RecSig :: DefInfo -> QName -> GeneralizeTelescope -> Type -> Declaration
- Agda.Syntax.Abstract: TBind :: Range -> TacticAttr -> List1 (NamedArg Binder) -> Expr -> TypedBinding
+ Agda.Syntax.Abstract: TBind :: Range -> TypedBindingInfo -> List1 (NamedArg Binder) -> Type -> TypedBinding
- Agda.Syntax.Abstract: WhereDecls :: Maybe ModuleName -> Maybe Declaration -> WhereDeclarations
+ Agda.Syntax.Abstract: WhereDecls :: Maybe ModuleName -> Bool -> Maybe Declaration -> WhereDeclarations
- Agda.Syntax.Abstract: generalized :: Set QName -> Expr -> Expr
+ Agda.Syntax.Abstract: generalized :: Set QName -> Type -> Type
- Agda.Syntax.Abstract: mkPi :: ExprInfo -> Telescope -> Expr -> Expr
+ Agda.Syntax.Abstract: mkPi :: ExprInfo -> Telescope -> Type -> Type
- Agda.Syntax.Abstract: mkTBind :: Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding
+ Agda.Syntax.Abstract: mkTBind :: Range -> List1 (NamedArg Binder) -> Type -> TypedBinding
- Agda.Syntax.Common: IdPart :: RString -> GenPart
+ Agda.Syntax.Common: IdPart :: RString -> NotationPart
- Agda.Syntax.Common: MetaId :: Nat -> MetaId
+ Agda.Syntax.Common: MetaId :: {-# UNPACK #-} !Word64 -> {-# UNPACK #-} !ModuleNameHash -> MetaId
- Agda.Syntax.Common: [metaId] :: MetaId -> Nat
+ Agda.Syntax.Common: [metaId] :: MetaId -> {-# UNPACK #-} !Word64
- Agda.Syntax.Common: type Notation = [GenPart]
+ Agda.Syntax.Common: type Notation = [NotationPart]
- Agda.Syntax.Concrete: BName :: Name -> Fixity' -> TacticAttribute -> BoundName
+ Agda.Syntax.Concrete: BName :: Name -> Fixity' -> TacticAttribute -> Bool -> BoundName
- Agda.Syntax.Concrete.Definitions.Monad: type LoneSigs = Map Name LoneSig " We retain the 'Name' also in the codomain since 'Name' as a key is up to @Eq Name@ which ignores the range. However, without range names are not unique in case the user gives a second definition of the same name. This causes then problems in 'replaceSigs' which might replace the wrong signature. Another reason is that we want to distinguish different occurrences of 'NoName' in a mutual block (issue #4157). The 'NoName' in the codomain will have a unique 'NameId'."
+ Agda.Syntax.Concrete.Definitions.Monad: type LoneSigs = -- | We retain the 'Name' also in the codomain since -- 'Name' as a key is up to @Eq Name@ which ignores the range. -- However, without range names are not unique in case the -- user gives a second definition of the same name. -- This causes then problems in 'replaceSigs' which might -- replace the wrong signature. -- -- Another reason is that we want to distinguish different -- occurrences of 'NoName' in a mutual block (issue #4157). -- The 'NoName' in the codomain will have a unique 'NameId'. Map Name LoneSig
- Agda.Syntax.Concrete.Definitions.Monad: type NiceWarnings = [DeclarationWarning] " Stack of warnings. Head is last warning."
+ Agda.Syntax.Concrete.Definitions.Monad: type NiceWarnings = -- | Stack of warnings. Head is last warning. [DeclarationWarning]
- Agda.Syntax.Internal: Clause :: Range -> Range -> Telescope -> NAPs -> Maybe Term -> Maybe (Arg Type) -> Bool -> Maybe Bool -> Maybe Bool -> Maybe Bool -> ExpandedEllipsis -> Clause
+ Agda.Syntax.Internal: Clause :: Range -> Range -> Telescope -> NAPs -> Maybe Term -> Maybe (Arg Type) -> Bool -> Maybe Bool -> Maybe Bool -> Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause
- Agda.Syntax.Internal: DBPatVar :: PatVarName -> Int -> DBPatVar
+ Agda.Syntax.Internal: DBPatVar :: PatVarName -> !Int -> DBPatVar
- Agda.Syntax.Internal: Dom :: ArgInfo -> !Bool -> Maybe NamedName -> Maybe t -> e -> Dom' t e
+ Agda.Syntax.Internal: Dom :: ArgInfo -> Maybe NamedName -> Bool -> Maybe t -> e -> Dom' t e
- Agda.Syntax.Internal: Inf :: IsFibrant -> Integer -> Sort' t
+ Agda.Syntax.Internal: Inf :: IsFibrant -> !Integer -> Sort' t
- Agda.Syntax.Internal: Max :: Integer -> [PlusLevel' t] -> Level' t
+ Agda.Syntax.Internal: Max :: !Integer -> [PlusLevel' t] -> Level' t
- Agda.Syntax.Internal: MetaId :: Nat -> MetaId
+ Agda.Syntax.Internal: MetaId :: {-# UNPACK #-} !Word64 -> {-# UNPACK #-} !ModuleNameHash -> MetaId
- Agda.Syntax.Internal: Plus :: Integer -> t -> PlusLevel' t
+ Agda.Syntax.Internal: Plus :: !Integer -> t -> PlusLevel' t
- Agda.Syntax.Internal: Strengthen :: Impossible -> Substitution' a -> Substitution' a
+ Agda.Syntax.Internal: Strengthen :: Impossible -> !Int -> Substitution' a -> Substitution' a
- Agda.Syntax.Internal: [dbPatVarIndex] :: DBPatVar -> Int
+ Agda.Syntax.Internal: [dbPatVarIndex] :: DBPatVar -> !Int
- Agda.Syntax.Internal: [metaId] :: MetaId -> Nat
+ Agda.Syntax.Internal: [metaId] :: MetaId -> {-# UNPACK #-} !Word64
- Agda.Syntax.Internal: type Elims = [Elim] " eliminations ordered left-to-right."
+ Agda.Syntax.Internal: type Elims = -- | eliminations ordered left-to-right. [Elim]
- Agda.Syntax.Internal: type Pattern = Pattern' PatVarName " The @PatVarName@ is a name suggestion."
+ Agda.Syntax.Internal: type Pattern = -- | The @PatVarName@ is a name suggestion. Pattern' PatVarName
- Agda.Syntax.Internal.Blockers: MissingClauses :: NotBlocked' t
+ Agda.Syntax.Internal.Blockers: MissingClauses :: QName -> NotBlocked' t
- Agda.Syntax.Internal.Names: namesIn' :: (NamesIn a, Monoid m, Foldable f, NamesIn b, f b ~ a) => (QName -> m) -> a -> m
+ Agda.Syntax.Internal.Names: namesIn' :: (NamesIn a, Monoid m) => (QName -> m) -> a -> m
- Agda.Syntax.Literal: LitMeta :: AbsolutePath -> MetaId -> Literal
+ Agda.Syntax.Literal: LitMeta :: !TopLevelModuleName -> !MetaId -> Literal
- Agda.Syntax.Notation: LambdaHole :: RString -> RString -> HoleName
+ Agda.Syntax.Notation: LambdaHole :: List1 RString -> RString -> HoleName
- Agda.Syntax.Notation: holeTarget :: GenPart -> Maybe Int
+ Agda.Syntax.Notation: holeTarget :: NotationPart -> Maybe Int
- Agda.Syntax.Notation: isAHole :: GenPart -> Bool
+ Agda.Syntax.Notation: isAHole :: NotationPart -> Bool
- Agda.Syntax.Parser: InvalidExtensionError :: !AbsolutePath -> [String] -> ParseError
+ Agda.Syntax.Parser: InvalidExtensionError :: !RangeFile -> [String] -> ParseError
- Agda.Syntax.Parser: ReadFileError :: !AbsolutePath -> IOError -> ParseError
+ Agda.Syntax.Parser: ReadFileError :: !RangeFile -> IOError -> ParseError
- Agda.Syntax.Parser: [errPath] :: ParseError -> !AbsolutePath
+ Agda.Syntax.Parser: [errPath] :: ParseError -> !RangeFile
- Agda.Syntax.Parser: parse :: Parser a -> String -> PM a
+ Agda.Syntax.Parser: parse :: Parser a -> String -> PM (a, CohesionAttributes)
- Agda.Syntax.Parser: parseFile :: Show a => Parser a -> AbsolutePath -> String -> PM (a, FileType)
+ Agda.Syntax.Parser: parseFile :: Show a => Parser a -> RangeFile -> String -> PM ((a, CohesionAttributes), FileType)
- Agda.Syntax.Parser: parsePosString :: Parser a -> Position -> String -> PM a
+ Agda.Syntax.Parser: parsePosString :: Parser a -> Position -> String -> PM (a, CohesionAttributes)
- Agda.Syntax.Parser: readFilePM :: AbsolutePath -> PM Text
+ Agda.Syntax.Parser: readFilePM :: RangeFile -> PM Text
- Agda.Syntax.Parser.Monad: InvalidExtensionError :: !AbsolutePath -> [String] -> ParseError
+ Agda.Syntax.Parser.Monad: InvalidExtensionError :: !RangeFile -> [String] -> ParseError
- Agda.Syntax.Parser.Monad: PState :: !SrcFile -> !PositionWithoutFile -> !PositionWithoutFile -> String -> !Char -> String -> LayoutContext -> LayoutStatus -> Keyword -> [LexState] -> ParseFlags -> ![ParseWarning] -> ParseState
+ Agda.Syntax.Parser.Monad: PState :: !SrcFile -> !PositionWithoutFile -> !PositionWithoutFile -> String -> !Char -> String -> LayoutContext -> LayoutStatus -> Keyword -> [LexState] -> ParseFlags -> ![ParseWarning] -> !CohesionAttributes -> ParseState
- Agda.Syntax.Parser.Monad: ReadFileError :: !AbsolutePath -> IOError -> ParseError
+ Agda.Syntax.Parser.Monad: ReadFileError :: !RangeFile -> IOError -> ParseError
- Agda.Syntax.Parser.Monad: [errPath] :: ParseError -> !AbsolutePath
+ Agda.Syntax.Parser.Monad: [errPath] :: ParseError -> !RangeFile
- Agda.Syntax.Parser.Monad: initState :: Maybe AbsolutePath -> ParseFlags -> String -> [LexState] -> ParseState
+ Agda.Syntax.Parser.Monad: initState :: Maybe RangeFile -> ParseFlags -> String -> [LexState] -> ParseState
- Agda.Syntax.Position: movePosByString :: Position' a -> String -> Position' a
+ Agda.Syntax.Position: movePosByString :: Foldable t => Position' a -> t Char -> Position' a
- Agda.Syntax.Position: startPos :: Maybe AbsolutePath -> Position
+ Agda.Syntax.Position: startPos :: Maybe RangeFile -> Position
- Agda.Syntax.Position: type SrcFile = Maybe AbsolutePath
+ Agda.Syntax.Position: type SrcFile = Maybe RangeFile
- Agda.Syntax.Scope.Monad: tryResolveName :: (ReadTCState m, HasBuiltins m, MonadError (List1 QName) m) => KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName
+ Agda.Syntax.Scope.Monad: tryResolveName :: forall m. (ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m) => KindsOfNames -> Maybe (Set Name) -> QName -> m ResolvedName
- Agda.Syntax.Translation.AbstractToConcrete: type MonadAbsToCon m = (MonadTCEnv m, ReadTCState m, MonadStConcreteNames m, HasOptions m, HasBuiltins m, MonadDebug m)
+ Agda.Syntax.Translation.AbstractToConcrete: type MonadAbsToCon m = (MonadFresh NameId m, MonadInteractionPoints m, MonadStConcreteNames m, HasOptions m, PureTCM m, IsString (m Doc), Null (m Doc), Semigroup (m Doc))
- Agda.Termination.Monad: CallPath :: [CallInfo] -> CallPath
+ Agda.Termination.Monad: CallPath :: DList CallInfo -> CallPath
- Agda.Termination.Monad: TerEnv :: Bool -> Maybe QName -> Maybe QName -> CutOff -> QName -> MutualNames -> [QName] -> Bool -> Maybe Target -> Delayed -> [Bool] -> Bool -> Int -> MaskedDeBruijnPatterns -> !Int -> !Guarded -> Bool -> VarSet -> TerEnv
+ Agda.Termination.Monad: TerEnv :: Bool -> Maybe QName -> Maybe QName -> CutOff -> QName -> MutualNames -> Set QName -> Bool -> Target -> Delayed -> [Bool] -> Bool -> Int -> MaskedDeBruijnPatterns -> !Int -> !Guarded -> Bool -> VarSet -> TerEnv
- Agda.Termination.Monad: [terTarget] :: TerEnv -> Maybe Target
+ Agda.Termination.Monad: [terTarget] :: TerEnv -> Target
- Agda.Termination.Monad: [terUserNames] :: TerEnv -> [QName]
+ Agda.Termination.Monad: [terUserNames] :: TerEnv -> Set QName
- Agda.Termination.Monad: terGetTarget :: TerM (Maybe Target)
+ Agda.Termination.Monad: terGetTarget :: TerM Target
- Agda.Termination.Monad: terGetUserNames :: TerM [QName]
+ Agda.Termination.Monad: terGetUserNames :: TerM (Set QName)
- Agda.Termination.Monad: terSetSizeDepth :: Telescope -> TerM a -> TerM a
+ Agda.Termination.Monad: terSetSizeDepth :: TerSetSizeDepth b => b -> TerM a -> TerM a
- Agda.Termination.Monad: terSetTarget :: Maybe Target -> TerM a -> TerM a
+ Agda.Termination.Monad: terSetTarget :: Target -> TerM a -> TerM a
- Agda.Termination.RecCheck: recursive :: [QName] -> TCM [[QName]]
+ Agda.Termination.RecCheck: recursive :: Set QName -> TCM [MutualNames]
- Agda.TypeChecking.Constraints: wakeupConstraints :: MetaId -> TCM ()
+ Agda.TypeChecking.Constraints: wakeupConstraints :: MonadMetaSolver m => MetaId -> m ()
- Agda.TypeChecking.Conversion: compareDom :: (MonadConversion m, Free c) => Comparison -> Dom Type -> Dom Type -> Abs b -> Abs c -> m () -> m () -> m () -> m () -> m () -> m ()
+ Agda.TypeChecking.Conversion: compareDom :: (MonadConversion m, Free c) => Comparison -> Dom Type -> Dom Type -> Abs b -> Abs c -> m () -> m () -> m () -> m () -> m () -> m () -> m ()
- Agda.TypeChecking.Conversion: compareTermOnFace' :: MonadConversion m => (Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m ()
+ Agda.TypeChecking.Conversion: compareTermOnFace' :: MonadConversion m => (Substitution -> Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m ()
- Agda.TypeChecking.Conversion: forallFaceMaps :: MonadConversion m => Term -> (Map Int Bool -> Blocker -> Term -> m a) -> (Substitution -> m a) -> m [a]
+ Agda.TypeChecking.Conversion: forallFaceMaps :: MonadConversion m => Term -> (IntMap Bool -> Blocker -> Term -> m a) -> (IntMap Bool -> Substitution -> m a) -> m [a]
- Agda.TypeChecking.Conversion: type Conj = (Map Int (Set Bool), [Term])
+ Agda.TypeChecking.Conversion: type Conj = (IntMap BoolSet, [Term])
- Agda.TypeChecking.Coverage: Covering :: Arg Nat -> [(SplitTag, SplitClause)] -> Covering
+ Agda.TypeChecking.Coverage: Covering :: Arg Nat -> [(SplitTag, (SplitClause, IInfo))] -> Covering
- Agda.TypeChecking.Coverage: [covSplitClauses] :: Covering -> [(SplitTag, SplitClause)]
+ Agda.TypeChecking.Coverage: [covSplitClauses] :: Covering -> [(SplitTag, (SplitClause, IInfo))]
- Agda.TypeChecking.DeadCode: eliminateDeadCode :: DisplayForms -> Signature -> TCM (DisplayForms, Signature)
+ Agda.TypeChecking.DeadCode: eliminateDeadCode :: BuiltinThings PrimFun -> DisplayForms -> Signature -> LocalMetaStore -> TCM (DisplayForms, Signature, RemoteMetaStore)
- Agda.TypeChecking.Free: flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe (FlexRig' ())
+ Agda.TypeChecking.Free: flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig
- Agda.TypeChecking.Free.Lazy: MetaSet :: IntSet -> MetaSet
+ Agda.TypeChecking.Free.Lazy: MetaSet :: HashSet MetaId -> MetaSet
- Agda.TypeChecking.Free.Lazy: [theMetaSet] :: MetaSet -> IntSet
+ Agda.TypeChecking.Free.Lazy: [theMetaSet] :: MetaSet -> HashSet MetaId
- Agda.TypeChecking.Irrelevance: usableAtModality :: MonadConstraint TCM => Modality -> Term -> TCM ()
+ Agda.TypeChecking.Irrelevance: usableAtModality :: MonadConstraint TCM => WhyCheckModality -> Modality -> Term -> TCM ()
- Agda.TypeChecking.Level: levelMaxView :: Level' t -> NonEmpty (SingleLevel' t)
+ Agda.TypeChecking.Level: levelMaxView :: Level' t -> List1 (SingleLevel' t)
- Agda.TypeChecking.Level: levelType :: HasBuiltins m => m Type
+ Agda.TypeChecking.Level: levelType :: (HasBuiltins m, MonadTCError m) => m Type
- Agda.TypeChecking.Level: requireLevels :: HasBuiltins m => m LevelKit
+ Agda.TypeChecking.Level: requireLevels :: (HasBuiltins m, MonadTCError m) => m LevelKit
- Agda.TypeChecking.Level.Solve: defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => MetaStore -> m ()
+ Agda.TypeChecking.Level.Solve: defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => LocalMetaStore -> m ()
- Agda.TypeChecking.MetaVars: type SubstCand = [(Int, Term)] " a possibly non-deterministic substitution"
+ Agda.TypeChecking.MetaVars: type SubstCand = -- | a possibly non-deterministic substitution [(Int, Term)]
- Agda.TypeChecking.Monad.Base: AmbiguousName :: QName -> List1 QName -> TypeError
+ Agda.TypeChecking.Monad.Base: AmbiguousName :: QName -> AmbiguousNameReason -> TypeError
- Agda.TypeChecking.Monad.Base: CallInfo :: QName -> Range -> Closure Term -> CallInfo
+ Agda.TypeChecking.Monad.Base: CallInfo :: QName -> Closure Term -> CallInfo
- Agda.TypeChecking.Monad.Base: CoInfectiveImport :: String -> ModuleName -> Warning
+ Agda.TypeChecking.Monad.Base: CoInfectiveImport :: Doc -> Warning
- Agda.TypeChecking.Monad.Base: InfectiveImport :: String -> ModuleName -> Warning
+ Agda.TypeChecking.Monad.Base: InfectiveImport :: Doc -> Warning
- Agda.TypeChecking.Monad.Base: InstV :: [Arg String] -> Term -> MetaInstantiation
+ Agda.TypeChecking.Monad.Base: InstV :: Instantiation -> MetaInstantiation
- Agda.TypeChecking.Monad.Base: Interface :: Hash -> Text -> FileType -> [(ModuleName, Hash)] -> ModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> DisplayForms -> Map QName Text -> Maybe Text -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface
+ Agda.TypeChecking.Monad.Base: Interface :: Hash -> Text -> FileType -> [(TopLevelModuleName, Hash)] -> ModuleName -> TopLevelModuleName -> Map ModuleName Scope -> ScopeInfo -> Signature -> RemoteMetaStore -> DisplayForms -> Map QName Text -> Maybe Text -> BuiltinThings (String, QName) -> Map BackendName [ForeignCode] -> HighlightingInfo -> [OptionsPragma] -> [OptionsPragma] -> PragmaOptions -> PatternSynDefns -> [TCWarning] -> Set QName -> Interface
- Agda.TypeChecking.Monad.Base: PersistentTCSt :: !DecodedModules -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState
+ Agda.TypeChecking.Monad.Base: PersistentTCSt :: !DecodedModules -> !BiMap RawTopLevelModuleName ModuleNameHash -> CommandLineOptions -> InteractionOutputCallback -> !Benchmark -> !Statistics -> !Maybe LoadedFileCache -> [Backend] -> PersistentTCState
- Agda.TypeChecking.Monad.Base: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !MetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe ModuleName -> !TempInstanceTable -> !ConcreteNames -> !Map RawName [RawName] -> !Map Name [RawName] -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState
+ Agda.TypeChecking.Monad.Base: PostScopeState :: !HighlightingInfo -> !DisambiguatedNames -> !LocalMetaStore -> !LocalMetaStore -> !InteractionPoints -> !Constraints -> !Constraints -> !Bool -> !Set QName -> !Signature -> !Map ModuleName CheckpointId -> !DisplayForms -> !Maybe (ModuleName, TopLevelModuleName) -> !TempInstanceTable -> !ConcreteNames -> !Map RawName (DList RawName) -> !Map Name (DList RawName) -> !Statistics -> ![TCWarning] -> !Map MutualId MutualBlock -> !BuiltinThings PrimFun -> !MetaId -> !MutualId -> !ProblemId -> !CheckpointId -> !Int -> !NameId -> !Bool -> !Bool -> !Bool -> !Bool -> !Set QName -> PostScopeState
- Agda.TypeChecking.Monad.Base: PreScopeState :: !HighlightingInfo -> !Signature -> !Set ModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName Text -> !Map QName Text -> !Maybe Text -> !Set QName -> !Map FilePath ProjectConfig -> !Map FilePath AgdaLibFile -> PreScopeState
+ Agda.TypeChecking.Monad.Base: PreScopeState :: !HighlightingInfo -> !Signature -> !HashSet TopLevelModuleName -> !ModuleToSource -> !VisitedModules -> !ScopeInfo -> !PatternSynDefns -> !PatternSynDefns -> !Maybe (Set QName) -> !PragmaOptions -> !BuiltinThings PrimFun -> !DisplayForms -> !InstanceTable -> !Map BackendName [ForeignCode] -> !InteractionId -> !Map QName Text -> !Map QName Text -> !Maybe Text -> !Set QName -> !Map FilePath ProjectConfig -> !Map FilePath AgdaLibFile -> !RemoteMetaStore -> PreScopeState
- Agda.TypeChecking.Monad.Base: ReduceEnv :: TCEnv -> TCState -> ReduceEnv
+ Agda.TypeChecking.Monad.Base: ReduceEnv :: TCEnv -> TCState -> Maybe (MetaId -> ReduceM Bool) -> ReduceEnv
- Agda.TypeChecking.Monad.Base: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> ReduceDefs -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Maybe BackendName -> Bool -> Bool -> TCEnv
+ Agda.TypeChecking.Monad.Base: TCEnv :: Context -> LetBindings -> ModuleName -> Maybe AbsolutePath -> [(ModuleName, Nat)] -> [TopLevelModuleName] -> Maybe MutualId -> TerminationCheck () -> CoverageCheck -> Bool -> Bool -> Bool -> Bool -> Bool -> Set ProblemId -> AbstractMode -> Modality -> Bool -> Bool -> Range -> Range -> IPClause -> Maybe (Closure Call) -> HighlightingLevel -> HighlightingMethod -> ExpandHidden -> Maybe QName -> Simplification -> AllowedReductions -> ReduceDefs -> Bool -> Int -> Bool -> Bool -> Bool -> Bool -> UnquoteFlags -> !Int -> Bool -> [QName] -> Bool -> CheckpointId -> Map CheckpointId Substitution -> DoGeneralize -> Map QName GeneralizedValue -> Maybe BackendName -> Bool -> Bool -> !Maybe Int -> TCEnv
- Agda.TypeChecking.Monad.Base: UsableAtModality :: Modality -> Term -> Constraint
+ Agda.TypeChecking.Monad.Base: UsableAtModality :: WhyCheckModality -> Maybe Sort -> Modality -> Term -> Constraint
- Agda.TypeChecking.Monad.Base: [iImportedModules] :: Interface -> [(ModuleName, Hash)]
+ Agda.TypeChecking.Monad.Base: [iImportedModules] :: Interface -> [(TopLevelModuleName, Hash)]
- Agda.TypeChecking.Monad.Base: [stPostCurrentModule] :: PostScopeState -> !Maybe ModuleName
+ Agda.TypeChecking.Monad.Base: [stPostCurrentModule] :: PostScopeState -> !Maybe (ModuleName, TopLevelModuleName)
- Agda.TypeChecking.Monad.Base: [stPostShadowingNames] :: PostScopeState -> !Map Name [RawName]
+ Agda.TypeChecking.Monad.Base: [stPostShadowingNames] :: PostScopeState -> !Map Name (DList RawName)
- Agda.TypeChecking.Monad.Base: [stPostUsedNames] :: PostScopeState -> !Map RawName [RawName]
+ Agda.TypeChecking.Monad.Base: [stPostUsedNames] :: PostScopeState -> !Map RawName (DList RawName)
- Agda.TypeChecking.Monad.Base: [stPreImportedModules] :: PreScopeState -> !Set ModuleName
+ Agda.TypeChecking.Monad.Base: [stPreImportedModules] :: PreScopeState -> !HashSet TopLevelModuleName
- Agda.TypeChecking.Monad.Base: stCurrentModule :: Lens' (Maybe ModuleName) TCState
+ Agda.TypeChecking.Monad.Base: stCurrentModule :: Lens' (Maybe (ModuleName, TopLevelModuleName)) TCState
- Agda.TypeChecking.Monad.Base: stImportedModules :: Lens' (Set ModuleName) TCState
+ Agda.TypeChecking.Monad.Base: stImportedModules :: Lens' (HashSet TopLevelModuleName) TCState
- Agda.TypeChecking.Monad.Base: stShadowingNames :: Lens' (Map Name [RawName]) TCState
+ Agda.TypeChecking.Monad.Base: stShadowingNames :: Lens' (Map Name (DList RawName)) TCState
- Agda.TypeChecking.Monad.Base: stUsedNames :: Lens' (Map RawName [RawName]) TCState
+ Agda.TypeChecking.Monad.Base: stUsedNames :: Lens' (Map RawName (DList RawName)) TCState
- Agda.TypeChecking.Monad.Builtin: equalityUnview :: EqualityView -> Type
+ Agda.TypeChecking.Monad.Builtin: equalityUnview :: EqualityUnview a => a -> Type
- Agda.TypeChecking.Monad.Builtin: getBuiltin :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => String -> m Term
+ Agda.TypeChecking.Monad.Builtin: getBuiltin :: (HasBuiltins m, MonadTCError m) => String -> m Term
- Agda.TypeChecking.Monad.Builtin: sortKit :: HasBuiltins m => m SortKit
+ Agda.TypeChecking.Monad.Builtin: sortKit :: (HasBuiltins m, MonadTCError m, HasOptions m) => m SortKit
- Agda.TypeChecking.Monad.Context: getContext :: MonadTCEnv m => m [Dom (Name, Type)]
+ Agda.TypeChecking.Monad.Context: getContext :: MonadTCEnv m => m Context
- Agda.TypeChecking.Monad.Context: lookupBV' :: MonadTCEnv m => Nat -> m (Maybe (Dom (Name, Type)))
+ Agda.TypeChecking.Monad.Context: lookupBV' :: MonadTCEnv m => Nat -> m (Maybe ContextEntry)
- Agda.TypeChecking.Monad.Debug: type Verbosity = Trie VerboseKey VerboseLevel
+ Agda.TypeChecking.Monad.Debug: type Verbosity = Maybe (Trie VerboseKeyItem VerboseLevel)
- Agda.TypeChecking.Monad.Imports: addImport :: ModuleName -> TCM ()
+ Agda.TypeChecking.Monad.Imports: addImport :: TopLevelModuleName -> TCM ()
- Agda.TypeChecking.Monad.MetaVars: freezeMetas :: MetaStore -> TCM IntSet
+ Agda.TypeChecking.Monad.MetaVars: freezeMetas :: MonadTCState m => LocalMetaStore -> m (Set MetaId)
- Agda.TypeChecking.Monad.MetaVars: getInteractionScope :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => InteractionId -> m ScopeInfo
+ Agda.TypeChecking.Monad.MetaVars: getInteractionScope :: (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => InteractionId -> m ScopeInfo
- Agda.TypeChecking.Monad.MetaVars: getMetaListeners :: (MonadFail m, ReadTCState m) => MetaId -> m [Listener]
+ Agda.TypeChecking.Monad.MetaVars: getMetaListeners :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m [Listener]
- Agda.TypeChecking.Monad.MetaVars: getMetaNameSuggestion :: (MonadFail m, ReadTCState m) => MetaId -> m MetaNameSuggestion
+ Agda.TypeChecking.Monad.MetaVars: getMetaNameSuggestion :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaNameSuggestion
- Agda.TypeChecking.Monad.MetaVars: getMetaPriority :: (MonadFail m, ReadTCState m) => MetaId -> m MetaPriority
+ Agda.TypeChecking.Monad.MetaVars: getMetaPriority :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m MetaPriority
- Agda.TypeChecking.Monad.MetaVars: getMetaRange :: (MonadFail m, ReadTCState m) => MetaId -> m Range
+ Agda.TypeChecking.Monad.MetaVars: getMetaRange :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Range
- Agda.TypeChecking.Monad.MetaVars: getMetaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type
+ Agda.TypeChecking.Monad.MetaVars: getMetaType :: ReadTCState m => MetaId -> m Type
- Agda.TypeChecking.Monad.MetaVars: getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m) => MetaId -> m Type
+ Agda.TypeChecking.Monad.MetaVars: getMetaTypeInContext :: (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m, MonadTCEnv m, ReadTCState m) => MetaId -> m Type
- Agda.TypeChecking.Monad.MetaVars: getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]
+ Agda.TypeChecking.Monad.MetaVars: getUniqueMetasRanges :: (HasCallStack, MonadDebug m, ReadTCState m) => [MetaId] -> m [Range]
- Agda.TypeChecking.Monad.MetaVars: getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]
+ Agda.TypeChecking.Monad.MetaVars: getUnsolvedInteractionMetas :: (HasCallStack, MonadDebug m, ReadTCState m) => m [Range]
- Agda.TypeChecking.Monad.MetaVars: getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]
+ Agda.TypeChecking.Monad.MetaVars: getUnsolvedMetas :: (HasCallStack, MonadDebug m, ReadTCState m) => m [Range]
- Agda.TypeChecking.Monad.MetaVars: isFrozen :: (MonadFail m, ReadTCState m) => MetaId -> m Bool
+ Agda.TypeChecking.Monad.MetaVars: isFrozen :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Bool
- Agda.TypeChecking.Monad.MetaVars: isGeneralizableMeta :: (ReadTCState m, MonadFail m) => MetaId -> m DoGeneralize
+ Agda.TypeChecking.Monad.MetaVars: isGeneralizableMeta :: (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m DoGeneralize
- Agda.TypeChecking.Monad.MetaVars: isSortMeta :: (MonadFail m, ReadTCState m) => MetaId -> m Bool
+ Agda.TypeChecking.Monad.MetaVars: isSortMeta :: ReadTCState m => MetaId -> m Bool
- Agda.TypeChecking.Monad.MetaVars: lookupMeta :: (MonadFail m, ReadTCState m) => MetaId -> m MetaVariable
+ Agda.TypeChecking.Monad.MetaVars: lookupMeta :: ReadTCState m => MetaId -> m (Maybe (Either RemoteMetaVariable MetaVariable))
- Agda.TypeChecking.Monad.MetaVars: metaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type
+ Agda.TypeChecking.Monad.MetaVars: metaType :: ReadTCState m => MetaId -> m Type
- Agda.TypeChecking.Monad.MetaVars: metasCreatedBy :: ReadTCState m => m a -> m (a, MetaStore)
+ Agda.TypeChecking.Monad.MetaVars: metasCreatedBy :: forall m a. ReadTCState m => m a -> m (a, LocalMetaStores)
- Agda.TypeChecking.Monad.MetaVars: updateMetaVarTCM :: MetaId -> (MetaVariable -> MetaVariable) -> TCM ()
+ Agda.TypeChecking.Monad.MetaVars: updateMetaVarTCM :: HasCallStack => MetaId -> (MetaVariable -> MetaVariable) -> TCM ()
- Agda.TypeChecking.Monad.MetaVars: withInteractionId :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m) => InteractionId -> m a -> m a
+ Agda.TypeChecking.Monad.MetaVars: withInteractionId :: (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m) => InteractionId -> m a -> m a
- Agda.TypeChecking.Monad.MetaVars: withMetaId :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaId -> m a -> m a
+ Agda.TypeChecking.Monad.MetaVars: withMetaId :: (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m, ReadTCState m) => MetaId -> m a -> m a
- Agda.TypeChecking.Monad.Mutual: lookupMutualBlock :: MutualId -> TCM MutualBlock
+ Agda.TypeChecking.Monad.Mutual: lookupMutualBlock :: ReadTCState tcm => MutualId -> tcm MutualBlock
- Agda.TypeChecking.Monad.Options: getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]
+ Agda.TypeChecking.Monad.Options: getAgdaLibFiles :: AbsolutePath -> TopLevelModuleName -> TCM [AgdaLibFile]
- Agda.TypeChecking.Monad.Options: getLibraryOptions :: FilePath -> TCM [OptionsPragma]
+ Agda.TypeChecking.Monad.Options: getLibraryOptions :: AbsolutePath -> TopLevelModuleName -> TCM [OptionsPragma]
- Agda.TypeChecking.Monad.Signature: addClauses :: QName -> [Clause] -> TCM ()
+ Agda.TypeChecking.Monad.Signature: addClauses :: (MonadConstraint m, MonadTCState m) => QName -> [Clause] -> m ()
- Agda.TypeChecking.Monad.Signature: setTerminates :: QName -> Bool -> TCM ()
+ Agda.TypeChecking.Monad.Signature: setTerminates :: MonadTCState m => QName -> Bool -> m ()
- Agda.TypeChecking.Monad.SizedTypes: sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => NonEmpty Term -> m Term
+ Agda.TypeChecking.Monad.SizedTypes: sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => List1 Term -> m Term
- Agda.TypeChecking.Monad.SizedTypes: type SizeMaxView = NonEmpty DeepSizeView
+ Agda.TypeChecking.Monad.SizedTypes: type SizeMaxView = List1 DeepSizeView
- Agda.TypeChecking.Monad.State: setTopLevelModule :: QName -> TCM ()
+ Agda.TypeChecking.Monad.State: setTopLevelModule :: TopLevelModuleName -> TCM ()
- Agda.TypeChecking.Monad.State: withTopLevelModule :: QName -> TCM a -> TCM a
+ Agda.TypeChecking.Monad.State: withTopLevelModule :: TopLevelModuleName -> TCM a -> TCM a
- Agda.TypeChecking.Monad.Statistics: printStatistics :: (MonadDebug m, MonadTCEnv m, HasOptions m) => Int -> Maybe TopLevelModuleName -> Statistics -> m ()
+ Agda.TypeChecking.Monad.Statistics: printStatistics :: (MonadDebug m, MonadTCEnv m, HasOptions m) => Maybe TopLevelModuleName -> Statistics -> m ()
- Agda.TypeChecking.Names: bind :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
+ Agda.TypeChecking.Names: bind :: MonadFail m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m (Abs a)
- Agda.TypeChecking.Names: bind' :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a
+ Agda.TypeChecking.Names: bind' :: MonadFail m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m a
- Agda.TypeChecking.Pretty: class Semigroup a
+ Agda.TypeChecking.Pretty: class () => Semigroup a
- Agda.TypeChecking.Pretty: type MonadAbsToCon m = (MonadTCEnv m, ReadTCState m, MonadStConcreteNames m, HasOptions m, HasBuiltins m, MonadDebug m)
+ Agda.TypeChecking.Pretty: type MonadAbsToCon m = (MonadFresh NameId m, MonadInteractionPoints m, MonadStConcreteNames m, HasOptions m, PureTCM m, IsString (m Doc), Null (m Doc), Semigroup (m Doc))
- Agda.TypeChecking.Pretty: type MonadPretty m = (MonadReify m, MonadAbsToCon m, IsString (m Doc), Null (m Doc), Semigroup (m Doc))
+ Agda.TypeChecking.Pretty: type MonadPretty m = MonadAbsToCon m
- Agda.TypeChecking.Primitive.Cubical: primTransHComp :: TranspOrHComp -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
+ Agda.TypeChecking.Primitive.Cubical: primTransHComp :: Command -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
- Agda.TypeChecking.Quote: quoteMeta :: AbsolutePath -> MetaId -> Term
+ Agda.TypeChecking.Quote: quoteMeta :: TopLevelModuleName -> MetaId -> Term
- Agda.TypeChecking.Records: expandRecordVar :: Int -> Telescope -> TCM (Maybe (Telescope, Substitution, Substitution, Telescope))
+ Agda.TypeChecking.Records: expandRecordVar :: PureTCM m => Int -> Telescope -> m (Maybe (Telescope, Substitution, Substitution, Telescope))
- Agda.TypeChecking.Records: isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m) => Bool -> QName -> Args -> m (Maybe Term)
+ Agda.TypeChecking.Records: isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m) => Bool -> QName -> Args -> Set QName -> m (Maybe Term)
- Agda.TypeChecking.Records: isSingletonType' :: (PureTCM m, MonadBlock m) => Bool -> Type -> m (Maybe Term)
+ Agda.TypeChecking.Records: isSingletonType' :: forall m. (PureTCM m, MonadBlock m) => Bool -> Type -> Set QName -> m (Maybe Term)
- Agda.TypeChecking.Reduce: appDef' :: Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
+ Agda.TypeChecking.Reduce: appDef' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
- Agda.TypeChecking.Reduce: appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
+ Agda.TypeChecking.Reduce: appDefE' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
- Agda.TypeChecking.Reduce: instantiate' :: (Instantiate t, t ~ f a, Traversable f, Instantiate a) => t -> ReduceM t
+ Agda.TypeChecking.Reduce: instantiate' :: Instantiate t => t -> ReduceM t
- Agda.TypeChecking.Reduce: instantiateFull' :: (InstantiateFull t, t ~ f a, Traversable f, InstantiateFull a) => t -> ReduceM t
+ Agda.TypeChecking.Reduce: instantiateFull' :: InstantiateFull t => t -> ReduceM t
- Agda.TypeChecking.Reduce: normalise' :: (Normalise t, t ~ f a, Traversable f, Normalise a) => t -> ReduceM t
+ Agda.TypeChecking.Reduce: normalise' :: Normalise t => t -> ReduceM t
- Agda.TypeChecking.Rewriting.NonLinMatch: makeSubstitution :: Telescope -> Sub -> Substitution
+ Agda.TypeChecking.Rewriting.NonLinMatch: makeSubstitution :: Telescope -> Sub -> Maybe Substitution
- Agda.TypeChecking.Rules.LHS: LHSResult :: Nat -> Telescope -> [NamedArg DeBruijnPattern] -> Bool -> Arg Type -> Substitution -> [AsBinding] -> IntSet -> LHSResult
+ Agda.TypeChecking.Rules.LHS: LHSResult :: Nat -> Telescope -> [NamedArg DeBruijnPattern] -> Bool -> Arg Type -> Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult
- Agda.TypeChecking.Rules.LHS.Problem: LHSState :: Telescope -> [NamedArg DeBruijnPattern] -> Problem a -> Arg Type -> ![Maybe Int] -> LHSState a
+ Agda.TypeChecking.Rules.LHS.Problem: LHSState :: Telescope -> [NamedArg DeBruijnPattern] -> Problem a -> Arg Type -> ![Maybe Int] -> !Bool -> LHSState a
- Agda.TypeChecking.Rules.LHS.Unify: unifyIndices :: (PureTCM m, MonadBench m, BenchPhase m ~ Phase) => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnificationResult
+ Agda.TypeChecking.Rules.LHS.Unify: unifyIndices :: (PureTCM m, MonadBench m, BenchPhase m ~ Phase, MonadError TCErr m) => Maybe NoLeftInv -> Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnificationResult
- Agda.TypeChecking.Serialise.Base: Dict :: !HashTable Node Int32 -> !HashTable String Int32 -> !HashTable Text Int32 -> !HashTable Text Int32 -> !HashTable Integer Int32 -> !HashTable Double Int32 -> !HashTable (Ptr Term) Int32 -> !HashTable NameId Int32 -> !HashTable QNameId Int32 -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !HashTable String Int -> Bool -> !HashTable AbsolutePath Int32 -> Dict
+ Agda.TypeChecking.Serialise.Base: Dict :: !HashTable Node Int32 -> !HashTable String Int32 -> !HashTable Text Int32 -> !HashTable Text Int32 -> !HashTable Integer Int32 -> !HashTable Double Int32 -> !HashTable (Ptr Term) Int32 -> !HashTable NameId Int32 -> !HashTable QNameId Int32 -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !IORef FreshAndReuse -> !HashTable String Int -> Bool -> Dict
- Agda.TypeChecking.Serialise.Base: type Memo = HashTable (Int32, TypeRep) U
+ Agda.TypeChecking.Serialise.Base: type Memo = IOArray Int32 (HashMap TypeRep U)
- Agda.TypeChecking.Serialise.Base: valueArgs :: (VALU t b, b ~ IsBase t) => All EmbPrj (CoDomain t : Domains t) => Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
+ Agda.TypeChecking.Serialise.Base: valueArgs :: (VALU t b, b ~ IsBase t) => All EmbPrj (CoDomain t ': Domains t) => Proxy t -> Node -> Maybe (Products (Constant Int32 (Domains t)))
- Agda.TypeChecking.Serialise.Base: valueN :: forall t. VALU t (IsBase t) => All EmbPrj (CoDomain t : Domains t) => t -> Int32 -> R (CoDomain t)
+ Agda.TypeChecking.Serialise.Base: valueN :: forall t. VALU t (IsBase t) => All EmbPrj (CoDomain t ': Domains t) => t -> Int32 -> R (CoDomain t)
- Agda.TypeChecking.SizedTypes.Syntax: type CTrans r f = Constraint' r f -> Either String [Constraint' r f]
+ Agda.TypeChecking.SizedTypes.Syntax: type CTrans r f = Constraint' r f -> Either Error [Constraint' r f]
- Agda.TypeChecking.SizedTypes.WarshallSolver: constraintGraph :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either String (ConGraph r f)
+ Agda.TypeChecking.SizedTypes.WarshallSolver: constraintGraph :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either Error (ConGraph r f)
- Agda.TypeChecking.SizedTypes.WarshallSolver: constraintGraphs :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either String ([f], ConGraphs r f)
+ Agda.TypeChecking.SizedTypes.WarshallSolver: constraintGraphs :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either Error ([f], ConGraphs r f)
- Agda.TypeChecking.SizedTypes.WarshallSolver: hypGraph :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => Set rigid -> [Hyp' rigid flex] -> Either String (HypGraph rigid flex)
+ Agda.TypeChecking.SizedTypes.WarshallSolver: hypGraph :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => Set rigid -> [Hyp' rigid flex] -> Either Error (HypGraph rigid flex)
- Agda.TypeChecking.SizedTypes.WarshallSolver: iterateSolver :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) => Polarities f -> HypGraph r f -> [Constraint' r f] -> Solution r f -> Either String (Solution r f)
+ Agda.TypeChecking.SizedTypes.WarshallSolver: iterateSolver :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) => Polarities f -> HypGraph r f -> [Constraint' r f] -> Solution r f -> Either Error (Solution r f)
- Agda.TypeChecking.SizedTypes.WarshallSolver: simplifyWithHypotheses :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => HypGraph rigid flex -> [Constraint' rigid flex] -> Either String [Constraint' rigid flex]
+ Agda.TypeChecking.SizedTypes.WarshallSolver: simplifyWithHypotheses :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) => HypGraph rigid flex -> [Constraint' rigid flex] -> Either Error [Constraint' rigid flex]
- Agda.TypeChecking.SizedTypes.WarshallSolver: solveGraph :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraph r f -> Either String (Solution r f)
+ Agda.TypeChecking.SizedTypes.WarshallSolver: solveGraph :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraph r f -> Either Error (Solution r f)
- Agda.TypeChecking.SizedTypes.WarshallSolver: solveGraphs :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraphs r f -> Either String (Solution r f)
+ Agda.TypeChecking.SizedTypes.WarshallSolver: solveGraphs :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) => Polarities f -> HypGraph r f -> ConGraphs r f -> Either Error (Solution r f)
- Agda.TypeChecking.SizedTypes.WarshallSolver: verifySolution :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) => HypGraph r f -> [Constraint' r f] -> Solution r f -> Either String ()
+ Agda.TypeChecking.SizedTypes.WarshallSolver: verifySolution :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f) => HypGraph r f -> [Constraint' r f] -> Solution r f -> Either Error ()
- Agda.TypeChecking.Substitute: Strengthen :: Impossible -> Substitution' a -> Substitution' a
+ Agda.TypeChecking.Substitute: Strengthen :: Impossible -> !Int -> Substitution' a -> Substitution' a
- Agda.TypeChecking.Substitute: funSort' :: Sort -> Sort -> Maybe Sort
+ Agda.TypeChecking.Substitute: funSort' :: Sort -> Sort -> Either Blocker Sort
- Agda.TypeChecking.Substitute: isSmallSort :: Sort -> Maybe (Bool, IsFibrant)
+ Agda.TypeChecking.Substitute: isSmallSort :: Sort -> Bool
- Agda.TypeChecking.Substitute: piSort' :: Dom Term -> Sort -> Abs Sort -> Maybe Sort
+ Agda.TypeChecking.Substitute: piSort' :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort
- Agda.TypeChecking.Substitute: univSort' :: Sort -> Maybe Sort
+ Agda.TypeChecking.Substitute: univSort' :: Sort -> Either Blocker Sort
- Agda.TypeChecking.SyntacticEquality: checkSyntacticEquality :: (Instantiate a, SynEq a, MonadReduce m) => a -> a -> m ((a, a), Bool)
+ Agda.TypeChecking.SyntacticEquality: checkSyntacticEquality :: (Instantiate a, SynEq a, MonadReduce m) => a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
- Agda.TypeChecking.Telescope: teleNamedArgs :: DeBruijn a => Telescope -> [NamedArg a]
+ Agda.TypeChecking.Telescope: teleNamedArgs :: DeBruijn a => Tele (Dom t) -> [NamedArg a]
- Agda.TypeChecking.Telescope.Path: iApplyVars :: DeBruijn a => [NamedArg (Pattern' a)] -> [Int]
+ Agda.TypeChecking.Telescope.Path: iApplyVars :: IApplyVars p => p -> [Int]
- Agda.Utils.BiMap: BiMap :: Map k v -> Map (Tag v) k -> BiMap k v
+ Agda.Utils.BiMap: BiMap :: !Map k v -> !Map (Tag v) k -> BiMap k v
- Agda.Utils.BiMap: [biMapBack] :: BiMap k v -> Map (Tag v) k
+ Agda.Utils.BiMap: [biMapBack] :: BiMap k v -> !Map (Tag v) k
- Agda.Utils.BiMap: [biMapThere] :: BiMap k v -> Map k v
+ Agda.Utils.BiMap: [biMapThere] :: BiMap k v -> !Map k v
- Agda.Utils.CallStack: data CallStack
+ Agda.Utils.CallStack: data () => CallStack
- Agda.Utils.CallStack: data SrcLoc
+ Agda.Utils.CallStack: data () => SrcLoc
- Agda.Utils.Cluster: cluster :: (a -> NonEmpty C) -> [a] -> [NonEmpty a]
+ Agda.Utils.Cluster: cluster :: Ord c => (a -> NonEmpty c) -> [a] -> [NonEmpty a]
- Agda.Utils.Cluster: cluster' :: [(a, NonEmpty C)] -> [NonEmpty a]
+ Agda.Utils.Cluster: cluster' :: Ord c => [(a, NonEmpty c)] -> [NonEmpty a]
- Agda.Utils.Float: doubleToWord64 :: Double -> Word64
+ Agda.Utils.Float: doubleToWord64 :: Double -> Maybe Word64
- Agda.Utils.Graph.TopSort: topSort :: Ord n => [n] -> [(n, n)] -> Maybe [n]
+ Agda.Utils.Graph.TopSort: topSort :: Ord n => Set n -> [(n, n)] -> Maybe [n]
- Agda.Utils.IndexedList: [Cons] :: p x -> All p xs -> All p (x : xs)
+ Agda.Utils.IndexedList: [Cons] :: p x -> All p xs -> All p (x ': xs)
- Agda.Utils.IndexedList: [Suc] :: Index xs x -> Index (y : xs) x
+ Agda.Utils.IndexedList: [Suc] :: Index xs x -> Index (y ': xs) x
- Agda.Utils.IndexedList: [Zero] :: Index (x : xs) x
+ Agda.Utils.IndexedList: [Zero] :: Index (x ': xs) x
- Agda.Utils.List: type Prefix a = [a] " The list before the split point."
+ Agda.Utils.List: type Prefix a = -- | The list before the split point. [a]
- Agda.Utils.List: type Suffix a = [a] " The list after the split point."
+ Agda.Utils.List: type Suffix a = -- | The list after the split point. [a]
- Agda.Utils.List1: (!!) :: NonEmpty a -> Int -> a
+ Agda.Utils.List1: (!!) :: HasCallStack => NonEmpty a -> Int -> a
- Agda.Utils.List1: appendList :: List1 a -> [a] -> List1 a
+ Agda.Utils.List1: appendList :: NonEmpty a -> [a] -> NonEmpty a
- Agda.Utils.List1: fromList :: [a] -> NonEmpty a
+ Agda.Utils.List1: fromList :: IsList l => [Item l] -> l
- Agda.Utils.List1: infixr 5 :|
+ Agda.Utils.List1: infixr 5 <|
- Agda.Utils.List1: prependList :: [a] -> List1 a -> List1 a
+ Agda.Utils.List1: prependList :: [a] -> NonEmpty a -> NonEmpty a
- Agda.Utils.List1: singleton :: a -> List1 a
+ Agda.Utils.List1: singleton :: a -> NonEmpty a
- Agda.Utils.List1: toList :: NonEmpty a -> [a]
+ Agda.Utils.List1: toList :: IsList l => l -> [Item l]
- Agda.Utils.Monad: allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+ Agda.Utils.Monad: allM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
- Agda.Utils.Monad: anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+ Agda.Utils.Monad: anyM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
- Agda.Utils.Pretty: data Doc
+ Agda.Utils.Pretty: data () => Doc
- Agda.Utils.Pretty: data Mode
+ Agda.Utils.Pretty: data () => Mode
- Agda.Utils.Pretty: data Style
+ Agda.Utils.Pretty: data () => Style
- Agda.Utils.Pretty: infixl 5 $$
+ Agda.Utils.Pretty: infixl 5 $+$
- Agda.Utils.Semigroup: class Semigroup a
+ Agda.Utils.Semigroup: class () => Semigroup a

Files

Agda.cabal view
@@ -1,10 +1,10 @@ name:            Agda-version:         2.6.2.2-cabal-version:   >= 1.10+version:         2.6.3+cabal-version:   1.24 build-type:      Custom license:         OtherLicense license-file:    LICENSE-copyright:       (c) 2005-2022 The Agda Team.+copyright:       (c) 2005-2023 The Agda Team. author:          Ulf Norell and The Agda Team, see https://agda.readthedocs.io/en/latest/team.html maintainer:      The Agda Team homepage:        http://wiki.portal.chalmers.se/agda/@@ -40,13 +40,14 @@                     GHC == 8.6.5                     GHC == 8.8.4                     GHC == 8.10.7-                    GHC == 9.0.1                     GHC == 9.0.2-                    GHC == 9.2.1-                    GHC == 9.2.2+                    GHC == 9.2.5+                    GHC == 9.4.4  extra-source-files: CHANGELOG.md                     README.md+                    doc/user-manual/agda.svg+                    doc/release-notes/2.6.2.2.md                     doc/release-notes/2.6.2.1.md                     doc/release-notes/2.6.2.md                     doc/release-notes/2.6.1.3.md@@ -82,18 +83,15 @@                     doc/release-notes/2.2.2.md                     doc/release-notes/2.2.4.md                     doc/release-notes/2.2.0.md--- Liang-Ting (2019-11-26): See Issues #4216---                    doc/user-manual.pdf                     stack-8.0.2.yaml                     stack-8.2.2.yaml                     stack-8.4.4.yaml                     stack-8.6.5.yaml                     stack-8.8.4.yaml                     stack-8.10.7.yaml-                    stack-9.0.1.yaml                     stack-9.0.2.yaml-                    stack-9.2.1.yaml-                    stack-9.2.2.yaml+                    stack-9.2.5.yaml+                    stack-9.4.4.yaml  data-dir:           src/data data-files:         emacs-mode/*.el@@ -148,7 +146,7 @@ source-repository this   type:     git   location: https://github.com/agda/agda.git-  tag:      v2.6.2.2+  tag:      v2.6.3  flag cpphs   default:     False@@ -173,8 +171,8 @@     Enable some expensive optimisations when compiling Agda.  custom-setup-  setup-depends:  base >= 4.9.0.0 && < 4.17-                , Cabal >= 1.24.0.0 && < 3.7+  setup-depends:  base >= 4.9.0.0 && < 4.18+                , Cabal >= 1.24.0.0 && < 3.9                 , directory >= 1.2.6.2 && < 1.4                 , filepath >= 1.4.1.0 && < 1.5                 , process >= 1.4.2.0 && < 1.7@@ -209,10 +207,10 @@   if os(windows) && impl(ghc == 8.6.3)     buildable: False -  build-depends:  aeson >= 1.1.2.0 && < 2.1+  build-depends:  aeson >= 1.1.2.0 && < 2.2                 , array >= 0.5.1.1 && < 0.6                 , async >= 2.2 && < 2.3-                , base >= 4.9.0.0 && < 4.17+                , base >= 4.9.0.0 && < 4.18                 , binary >= 0.8.3.0 && < 0.9                 , blaze-html >= 0.8 && < 0.10                 , boxes >= 0.1.3 && < 0.2@@ -223,6 +221,7 @@                 , data-hash >= 0.2.0.0 && < 0.3                 , deepseq >= 1.4.2.0 && < 1.5                 , directory >= 1.2.6.2 && < 1.4+                , dlist >= 0.8 && < 1.1                 , edit-distance >= 0.2.1.2 && < 0.3                 , equivalence >= 0.3.2 && < 0.5                 -- exceptions-0.8 instead of 0.10 because of stack@@ -233,12 +232,6 @@                 -- slower. The issue was fixed in hashable 1.2.1.0.                 -- https://github.com/tibbe/hashable/issues/57.                 , hashable >= 1.2.1.0 && < 1.5-                -- There is a "serious bug"-                -- (https://hackage.haskell.org/package/hashtables-1.2.0.2/changelog)-                -- in hashtables 1.2.0.0/1.2.0.1. This bug seems to-                -- have made Agda much slower (infinitely slower?) in-                -- some cases.-                , hashtables >= 1.2.0.2 && < 1.4                 , haskeline >= 0.7.2.3 && < 0.9                 -- monad-control-1.0.1.0 is the first to contain liftThrough                 , monad-control >= 1.0.1.0 && < 1.1@@ -252,21 +245,19 @@                 , regex-tdfa >= 1.3.1.0 && < 1.4                 , split >= 0.2.0.0 && < 0.2.4                 , stm >= 2.4.4 && < 2.6-                , strict >= 0.3.2 && < 0.5-                , template-haskell >= 2.11.0.0 && < 2.19+                , STMonadTrans >= 0.4.3 && < 0.5+                , strict >= 0.4.0.1 && < 0.5                 , text >= 1.2.3.0 && < 2.1                 , time >= 1.6.0.1 && < 1.13+                , time-compat >= 1.9.2 && < 1.10+                    -- time-compat adds needed functionality missing in time < 1.9                 , transformers >= 0.5 && < 0.7                 , unordered-containers >= 0.2.5.0 && < 0.3                 , uri-encode >= 1.5.0.4 && < 1.6+                , vector >= 0.12 && < 0.14+                , vector-hashtables == 0.1.*                 , zlib == 0.6.* -  -- Andreas, 2022-02-02, issue #5659:-  -- Build failure with transformers-0.6.0.{0,1,2} and GHC 8.6.-  -- Transformers-0.6.0.3 might restored GHC 8.6 buildability.-  if impl(ghc == 8.6.*)-    build-depends: transformers < 0.6 || >= 0.6.0.3-   -- Andreas, 2021-03-10:   -- All packages we depend upon should be mentioned in an unconditional   -- build-depends field, but additional restrictions on their@@ -422,7 +413,9 @@                     Agda.Syntax.Position                     Agda.Syntax.Reflected                     Agda.Syntax.Scope.Base+                    Agda.Syntax.Scope.Flat                     Agda.Syntax.Scope.Monad+                    Agda.Syntax.TopLevelModuleName                     Agda.Syntax.Translation.AbstractToConcrete                     Agda.Syntax.Translation.ConcreteToAbstract                     Agda.Syntax.Translation.InternalToAbstract@@ -450,6 +443,8 @@                     Agda.TypeChecking.Coverage                     Agda.TypeChecking.Coverage.Match                     Agda.TypeChecking.Coverage.SplitTree+                    Agda.TypeChecking.Coverage.SplitClause+                    Agda.TypeChecking.Coverage.Cubical                     Agda.TypeChecking.Datatypes                     Agda.TypeChecking.DeadCode                     Agda.TypeChecking.DisplayForm@@ -513,6 +508,10 @@                     Agda.TypeChecking.Primitive                     Agda.TypeChecking.Primitive.Base                     Agda.TypeChecking.Primitive.Cubical+                    Agda.TypeChecking.Primitive.Cubical.Id+                    Agda.TypeChecking.Primitive.Cubical.Glue+                    Agda.TypeChecking.Primitive.Cubical.Base+                    Agda.TypeChecking.Primitive.Cubical.HCompU                     Agda.TypeChecking.ProjectionLike                     Agda.TypeChecking.Quote                     Agda.TypeChecking.ReconstructParameters@@ -538,6 +537,8 @@                     Agda.TypeChecking.Rules.LHS.Problem                     Agda.TypeChecking.Rules.LHS.ProblemRest                     Agda.TypeChecking.Rules.LHS.Unify+                    Agda.TypeChecking.Rules.LHS.Unify.Types+                    Agda.TypeChecking.Rules.LHS.Unify.LeftInverse                     Agda.TypeChecking.Rules.Record                     Agda.TypeChecking.Rules.Term                     Agda.TypeChecking.Serialise@@ -570,6 +571,7 @@                     Agda.Utils.Bag                     Agda.Utils.Benchmark                     Agda.Utils.BiMap+                    Agda.Utils.BoolSet                     Agda.Utils.CallStack                     Agda.Utils.Char                     Agda.Utils.Cluster@@ -585,6 +587,7 @@                     Agda.Utils.Graph.AdjacencyMap.Unidirectional                     Agda.Utils.Graph.TopSort                     Agda.Utils.Hash+                    Agda.Utils.HashTable                     Agda.Utils.Haskell.Syntax                     Agda.Utils.Impossible                     Agda.Utils.IndexedList@@ -614,6 +617,7 @@                     Agda.Utils.Pointer                     Agda.Utils.POMonoid                     Agda.Utils.Pretty+                    Agda.Utils.ProfileOptions                     Agda.Utils.RangeMap                     Agda.Utils.SemiRing                     Agda.Utils.Semigroup@@ -652,12 +656,10 @@     ghc-options: -fexpose-all-unfoldings                  -fspecialise-aggressively -  -- NOTE: If adding flags, also add to `.ghci-8.0`   if impl(ghc <= 8.0.2)     ghc-options: -fprint-potential-instances                  -- Initially, we disable all the warnings.                  -w-                 -Wwarn                  -- This option must be the first one after disabling the                  -- warnings. See Issue #2094.                  -Wunrecognised-warning-flags@@ -669,7 +671,9 @@                  -Wduplicate-exports                  -Wempty-enumerations                  -Widentities-                 -Wincomplete-patterns+                 -- #6137: GHC 8.0 has no COMPLETE pragma, so we have to turn off the completeness checker+                 -- -Wincomplete-patterns+                 -- -Wincomplete-record-updates                  -Winline-rule-shadowing                  -Wmissing-fields                  -Wmissing-methods@@ -678,7 +682,8 @@                  -Wnoncanonical-monad-instances                  -Wnoncanonical-monoid-instances                  -Woverflowed-literals-                 -Woverlapping-patterns+                 -- #6137: GHC 8.0 has no COMPLETE pragma, so we have to turn off the completeness checker+                 -- -Woverlapping-patterns                  -Wsemigroup                  -Wtabs                  -Wtyped-holes@@ -690,73 +695,77 @@                  -Wwrong-do-bind   else     ghc-options: -fprint-potential-instances-                 -Wwarn=unrecognised-warning-flags-                 -Wwarn=deprecated-flags-                 -Wwarn=deriving-typeable-                 -Wwarn=dodgy-exports-                 -Wwarn=dodgy-foreign-imports-                 -Wwarn=dodgy-imports-                 -Wwarn=duplicate-exports-                 -Wwarn=empty-enumerations-                 -Wwarn=identities-                 -Wwarn=incomplete-patterns-                 -Wwarn=inline-rule-shadowing-                 -Wwarn=missing-fields-                 -Wwarn=missing-methods-                 -Wwarn=missing-pattern-synonym-signatures-                 -Wwarn=missing-signatures-                 -Wwarn=noncanonical-monad-instances-                 -Wwarn=noncanonical-monoid-instances-                 -Wwarn=overflowed-literals-                 -Wwarn=overlapping-patterns-                 -Wwarn=semigroup-                 -Wwarn=tabs-                 -Wwarn=typed-holes-                 -Wwarn=unrecognised-pragmas-                 -Wwarn=unticked-promoted-constructors-                 -Wwarn=unused-do-bind-                 -Wwarn=unused-foralls-                 -Wwarn=warnings-deprecations-                 -Wwarn=wrong-do-bind+                 -- ASR (2022-05-31). Workaround to Issue #5932.+                 -Werror=unrecognised-warning-flags+                 -Werror=deprecated-flags+                 -Werror=deriving-typeable+                 -Werror=dodgy-exports+                 -Werror=dodgy-foreign-imports+                 -Werror=dodgy-imports+                 -Werror=duplicate-exports+                 -Werror=empty-enumerations+                 -Werror=identities+                 -Werror=inline-rule-shadowing+                 -Werror=missing-fields+                 -Werror=missing-methods+                 -Werror=missing-pattern-synonym-signatures+                 -Werror=missing-signatures+                 -Werror=noncanonical-monad-instances+                 -Werror=noncanonical-monoid-instances+                 -Werror=overflowed-literals+                 -Werror=overlapping-patterns+                 -Werror=semigroup+                 -Werror=tabs+                 -Werror=typed-holes+                 -Werror=unrecognised-pragmas+                 -Werror=unticked-promoted-constructors+                 -Werror=unused-do-bind+                 -Werror=unused-foralls+                 -Werror=warnings-deprecations+                 -Werror=wrong-do-bind -  -- NOTE: If adding or removing flags, also change `.ghci-8.2`   if impl(ghc >= 8.2)-    ghc-options: -Wcpp-undef-                 -- ASR TODO (2017-07-23): `make haddock` fails when-                 -- this flag is on.-                 -- -Wmissing-home-modules-                 -Wwarn=simplifiable-class-constraints-                 -Wwarn=unbanged-strict-patterns+    ghc-options: -Werror=cpp-undef+                 -Werror=missing-home-modules+                 -Werror=simplifiable-class-constraints+                 -Werror=unbanged-strict-patterns -  -- NOTE: If adding or removing flags, also change `.ghci-8.6`   if impl(ghc >= 8.6)-    ghc-options: -Wwarn=inaccessible-code-                 -Wwarn=star-binder-                 -Wwarn=star-is-type+    ghc-options: -Werror=inaccessible-code+                 -Werror=star-binder+                 -Werror=star-is-type    -- The following warning is an error in GHC >= 8.10.   if impl(ghc >= 8.6) && impl(ghc < 8.10)-    ghc-options: -Wwarn=implicit-kind-vars+    ghc-options: -Werror=implicit-kind-vars -  -- NOTE: If adding or removing flags, also change `.ghci-8.8`   if impl(ghc >= 8.8)-    ghc-options: -Wwarn=missed-extra-shared-lib+    ghc-options: -Werror=missed-extra-shared-lib -  -- NOTE: If adding or removing flags, also change `.ghci-8.10`   if impl(ghc >= 8.10)-    ghc-options: -Wwarn=deriving-defaults-                 -Wwarn=redundant-record-wildcards-                 -Wwarn=unused-packages-                 -Wwarn=unused-record-wildcards+    ghc-options: -Werror=deriving-defaults+                 -Werror=redundant-record-wildcards+                 -Werror=unused-packages+                 -Werror=unused-record-wildcards -  -- NOTE: If adding or removing flags, also change `.ghci-9.0`   if impl(ghc >= 9.0)-    ghc-options: -Wwarn=invalid-haddock+    ghc-options: -Werror=invalid-haddock+                 -- #6137: coverage checker works only sufficiently well from GHC 9.0+                 -Werror=incomplete-patterns+                 -Werror=incomplete-record-updates +  -- ASR (2022-04-27). This warning was added in GHC 9.0.2, removed+  -- from 9.2.1 and added back in 9.2.2.+  if impl(ghc == 9.0.2)+    ghc-options: -Werror=unicode-bidirectional-format-characters++  if impl(ghc >= 9.2.2)+    ghc-options: -Werror=redundant-bang-patterns+                 -Werror=unicode-bidirectional-format-characters+   default-language: Haskell2010    -- NOTE: If adding or removing default extensions, also change:-  --         .ghci-8.0   --         .hlint.yaml   -- This should also use the same extensions as the `test-suite` target below.   default-extensions: BangPatterns@@ -766,7 +775,6 @@                     -- slightly shorter, see PR #3920.                     --, DataKinds                     , DefaultSignatures-                    , DeriveDataTypeable                     , DeriveFoldable                     , DeriveFunctor                     , DeriveGeneric@@ -789,6 +797,7 @@                     , StandaloneDeriving                     , TupleSections                     , TypeFamilies+                    , TypeOperators                     , TypeSynonymInstances  executable agda@@ -821,7 +830,7 @@   hs-source-dirs:   src/agda-mode   main-is:          Main.hs   other-modules:    Paths_Agda-  build-depends:    base >= 4.9.0.0 && < 4.17+  build-depends:    base >= 4.9.0.0 && < 4.18                   , directory >= 1.2.6.2 && < 1.4                   , filepath >= 1.4.1.0 && < 1.5                   , process >= 1.4.2.0 && < 1.7
CHANGELOG.md view
@@ -1,54 +1,202 @@-Release notes for Agda version 2.6.2.2-======================================+Release notes for Agda version 2.6.3+====================================  Highlights ---------- -* Agda 2.6.2.2 catches up to changes in the Haskell ecosystem-  (`bytestring-0.11.2.0`, `mtl-2.3-rc3/4`, `text-icu-0.8.0.1`,-  stackage `lts-19.0` and `nightly`).--* Fixes inconsistency [#5838](https://github.com/agda/agda/issues/5838)-  in `--cubical`.--* Fixes some regressions introduced in 2.6.1:+* Added support for [Erased Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#cubical-agda-with-erased-glue),+  a variant of Cubical Agda that is supported by the GHC backend,+  under the flag `--erased-cubical`. -  - [#5809](https://github.com/agda/agda/issues/5809):-    internal error with `--irrelevant-projections`.+* Added a new flag `--cubical-compatible` to turn on generation of+  Cubical Agda-specific support code (previously this behaviour was+  part of `--without-K`). -* Fixes some regressions introduced in 2.6.2:+  Since `--cubical-compatible` mode implies that functions should work+  with the preliminary support for [indexed inductive types in Cubical+  Agda](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#indexed-inductive-types),+  many pattern matching functions will now emit an+  `UnsupportedIndexedMatch` warning, indicating that the function will+  not compute when applied to transports (from `--cubical` code). -  - [#5705](https://github.com/agda/agda/issues/5705) and-    [#5706](https://github.com/agda/agda/issues/5706):-    inconsistency from universe level `Int` overflow.+  This warning can be disabled with `-WnoUnsupportedIndexedMatch`, which+  can be used either in an `OPTIONS` pragma or in your `agda-lib` file.+  The latter is recommended if your project is only+  `--cubical-compatible`, or if it is already making extensive use of+  indexed types. -  - [#5784](https://github.com/agda/agda/issues/5784):-    `primEraseEquality` does not compute.+  Note that code that uses (only) `--without-K` can no longer be+  imported from code that uses `--cubical`. Thus it may make sense to+  replace `--without-K` with `--cubical-compatible` in library code,+  if possible. -  - [#5805](https://github.com/agda/agda/issues/5805):-    internal error involving holes and `with`.+  Note also that Agda tends to be quite a bit faster if `--without-K`+  is used instead of `--cubical-compatible`. -  - [#5819](https://github.com/agda/agda/issues/5819):-    internal error when reducing in termination checker.+* Agda 2.6.3 seems to type-check one variant of the standard library+  about [30%+  faster](https://github.com/agda/agda/issues/6049#issuecomment-1329163727)+  than Agda 2.6.2.2 (on one system; the library was changed in a small+  way between the tests to accommodate changes to Agda). In that test+  the standard library did not use the new flag+  `--cubical-compatible`. With that flag enabled in all the files that+  used to use `--without-K` (and the warning `UnsupportedIndexedMatch`+  turned off) Agda 2.6.3 was still about 10% faster. -* Other-  [fixes](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.2+is%3Aclosed)-  and improvements (see below).+* New primitives `declareData`, `defineData`, and `unquoteDecl data`+  for generating new data types have been added to the [reflection+  API](https://agda.readthedocs.io/en/v2.6.3/language/reflection.html#metaprogramming).  Installation and infrastructure ------------------------------- -Agda supports GHC versions 8.0.2 to 9.2.2.+Agda supports GHC versions 8.0.2 to 9.4.4. -* UTF-8 encoding is now used for the `libraries` and `executables`-  configuration files (issue-  [#5741](https://github.com/agda/agda/issues/5741)).+Erasure+------- -Language---------+* The new option `--erased-cubical` turns on a variant of Cubical Agda+  (see [#4701](https://github.com/agda/agda/issues/4701)). -* `macro` definitions can now be used even when they are declared as erased-  (PR [#5744](https://github.com/agda/agda/pull/5744)).+  When this variant of Cubical Agda is used glue (and some related+  builtins) may only be used in erased settings. One can import+  regular Cubical Agda code from this variant of Cubical Agda, but+  names defined using Cubical Agda are (mostly) treated as if they had+  been marked as erased. See the [reference+  manual](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#cubical-agda-with-erased-glue-and-erased-higher-constructors)+  for more details.++  The GHC backend can compile code that uses `--erased-cubical` if the+  top-level module uses this flag.++  This feature is experimental.++* Added an option `--erase-record-parameters` that marks parameters to+  record fields and definitions in a record module as erased (see+  [#4786](https://github.com/agda/agda/issues/4786) and+  [#5770](https://github.com/agda/agda/issues/5770)). For example:++  ```agda+  {-# OPTIONS --erase-record-parameters #-}++  record R (A : Set) : Set where+    field+      f : A++  test : {@0 A : Set} → R A → A+  test = R.f+  ```++Cubical Agda+------------++* [**Breaking**] The generation of Cubical Agda-specific support code was removed+  from `--without-K` and transferred to its own flag,+  `--cubical-compatible` (see+  [#5843](https://github.com/agda/agda/issues/5843) and+  [#6049](https://github.com/agda/agda/issues/6049) for the+  rationale).++* Cubical Agda now has experimental support for indexed inductive types+  ([#3733](https://github.com/agda/agda/issues/3733)).+  See the [user guide](https://agda.readthedocs.io/en/v2.6.3/language/cubical.html#indexed-inductive-types)+  for caveats.++* The cubical interval `I` now belongs to its own sort, `IUniv`, rather+  than `SSet`. For `J : IUniv` and `A : J → Set l`, we have+  `(j : J) → A j : Set l`, that is, the type of functions from a type in `IUniv`+  to a fibrant type is fibrant.++* The option `--experimental-irrelevance` is now perhaps incompatible+  with Cubical Agda and perhaps also postulated univalence (see+  [#5611](https://github.com/agda/agda/issues/5611) and+  [#5861](https://github.com/agda/agda/pull/5861)).++  This is not meant to imply that the option was not already+  incompatible with those things. Note that+  `--experimental-irrelevance` cannot be used together with `--safe`.++* A new built-in constructor `REFLID` was added to the cubical identity+  types. This is definitionally equal to the reflexivity identification+  built with `conid`, with the difference being that matching on+  `REFLID` is allowed.++  ```agda+  symId : ∀ {a} {A : Set a} {x y : A} → Id x y → Id y x+  symId reflId = reflId+  ```++* Definitions which pattern match on higher-inductive types are no+  longer considered for injectivity analysis.+  ([#6219](https://github.com/agda/agda/pull/6219))++* [**Breaking**] Higher constructors are no longer considered as guarding in the productivity check.+  ([#6108](https://github.com/agda/agda/issues/6108))++* Rewrite rules with interval arguments are now supported.+  ([#4384](https://github.com/agda/agda/issues/4384))++The flat modality+-----------------++* [**Breaking**] The `@flat`/`@♭` modality is now by default disabled (see+  [#4927](https://github.com/agda/agda/issues/4927)).++  It can be enabled using the infective flag `--cohesion`.++* [**Breaking**] Matching on `@flat` arguments is now disabled by default, the flag+  `--no-flat-split` has been removed, and the flag `--flat-split` is+  now infective (see [#6238](https://github.com/agda/agda/issues/6238)+  and [#6263](https://github.com/agda/agda/issues/6263)).++  Matching can be enabled using the `--flat-split` flag. Note that in+  Cubical Agda functions that match on an argument marked with `@flat`+  trigger the `UnsupportedIndexedMatch` warning, and the code might+  not compute properly.++Reflection+----------++* Two new reflection primitives++  ```agda+  declareData      : Name → Nat → Type → TC ⊤+  defineData       : Name → List (Σ Name (λ _ → Type)) → TC ⊤+  ```++  are added for declaring and defining datatypes, similar to+  `declareDef` and `defineDef`.++* The construct `unquoteDecl` is extended with the ability of bringing+  a datatype `d` and its constructors `c₁ ... cₙ` given by a `TC`+  computation `m` into scope by the following syntax:++  ```agda+  unquoteDecl data x constructor c₁ .. cₙ = m+  ```++* A new reflection primitive `getInstances : Meta → TC (List Term)`+  was added to `Agda.Builtin.Reflection`. This operation returns the+  list of all possibly valid instance candidates for a given+  metavariable. For example, the following macro instantiates the goal+  with the first instance candidate, even if there are several:+  ```agda+  macro+    pickWhatever : Term → TC ⊤+    pickWhatever hole@(meta m _) = do+      (cand ∷ _) ← getInstances m+        where [] -> typeError (strErr "No candidates!" ∷ [])+      unify hole cand+    pickWhatever _ = typeError (strErr "Already solved!" ∷ [])+  ```++* [**Breaking**] The reflection primitives `getContext` and `inContext` use a nominal context+  `List (Σ String λ _ → Arg Type)` instead of  `List (Arg Type)` for printing+  type information better. Similarly, `extendContext` takes an extra argument+  of type `String`.++* `macro` definitions can now be used even when they are declared as erased.   For example, this is now accepted:   ```agda   macro@@ -59,51 +207,316 @@   test = trivial   ``` -* Fixed inconsistent `--cubical` reductions for `transp`:-  issue [#5838](https://github.com/agda/agda/issues/5838).+* A new reflection primitive `formatErrorParts : List ErrorPart → TC String`+  is added. It takes a list of `ErrorPart` and return its formatted string. -* Fixed issues with reflection:+* [**Breaking**] A new constructor `pattErr : Pattern → ErrorPart` of `ErrorPart` for reflection+  is added. -  - [#5762](https://github.com/agda/agda/issues/5762):-    do not eagerly check existence of commands in `executables` file.+* [**Breaking**] The reflection primitives `getType` and+  `getDefinition` respect the module context they are invoked from+  instead of returning information that would be expected in the top+  context. -  - [#5695](https://github.com/agda/agda/issues/5695):-    fix `elaborate-and-give` interaction command.+* [**Breaking**] The reflection primitive `inContext` cannot step+  outside of the context that the `TC` computation is invoked from+  anymore. The telescope is now relative to that context instead. -  - [#5700](https://github.com/agda/agda/issues/5700):-    scope of metas created during macro expansion.+Syntax+------ -  - [#5712](https://github.com/agda/agda/issues/5712):-    internal error with tactics on record fields of function type.+* It is now OK to put lambda-bound variables anywhere in the+  right-hand side of a syntax declaration. However, there must always+  be at least one "identifier" between any two regular "holes". For+  instance, the following syntax declaration is accepted because `-`+  is between the holes `B` and `D`. -* Fixed issues with instance search:+  ```agda+  postulate+    F : (Set → Set) → (Set → Set) → Set -  - [#5583](https://github.com/agda/agda/issues/5583):-    constructor instances from parameterized modules.+  syntax F (λ A → B) (λ C → D) = B A C - D+  ``` -  - [#5787](https://github.com/agda/agda/issues/5787):-    erased instance arguments.+* Syntax can now use lambdas with multiple arguments+  ([#394](https://github.com/agda/agda/issues/394)). -* Fixed issue [#5683](https://github.com/agda/agda/issues/5683) with-  generalization in `let`.+  Example: +  ```agda+  postulate+    Σ₂ : (A : Set) → (A → A → Set) → Set++  syntax Σ₂ A (λ x₁ x₂ → P) = [ x₁ x₂ ⦂ A ] × P+  ```++Builtins+--------++* [**Breaking**] Change `primFloatToWord64` to return `Maybe Word64`.+  (See [#6093](https://github.com/agda/agda/issues/6093).)++  The new type is+  ```agda+    primFloatToWord64 : Float → Maybe Word64+  ```+  and it returns `nothing` for `NaN`.++* [**Breaking**] The type expected by the builtin `EQUIVPROOF` has been changed to+  properly encode the condition that `EQUVIFUN` is an equivalence.+  ([#5661](https://github.com/agda/agda/issues/5661),+  [#6032](https://github.com/agda/agda/pull/6032))++* [**Breaking**] The primitive `primIdJ` has been removed+  ([#6032](https://github.com/agda/agda/pull/6032)) in favour of+  matching on the cubical identity type.++* [**Breaking**] The builtin `SUBIN` is now exported from `Agda.Builtin.Cubical.Sub` as+  **`inS`** rather than `inc`. Similarly, the internal modules refer to+  `primSubOut` as `outS`. ([#6032](https://github.com/agda/agda/pull/6032))++Pragmas and options+-------------------++* It is now possible to declare several `BUILTIN REWRITE` relations.+  Example:+  ```agda+  {-# OPTIONS --rewriting #-}++  open import Agda.Builtin.Equality+  open import Agda.Builtin.Equality.Rewrite  -- 1st rewrite relation++  postulate+    R : (A : Set) → A → A → Set+    A : Set+    a b c : A+    foo : R A a b  -- using 2nd rewrite relation+    bar : b ≡ c    -- using 1st rewrite relation++  {-# BUILTIN REWRITE R #-}  -- 2nd rewrite relation+  {-# REWRITE foo bar #-}++  test : a ≡ c+  test = refl+  ```++* [**Breaking**] The option `--experimental-lossy-unification` that+  makes Agda sometimes use first-order unification has been renamed to+  `--lossy-unification`+  ([#1625](https://github.com/agda/agda/issues/1625)).++  Note that use of this option is associated with some potential+  [drawbacks](https://agda.readthedocs.io/en/v2.6.3/language/lossy-unification.html#drawbacks).++* The new option `--no-load-primitives` complements `--no-import-sorts`+  by foregoing loading of the primitive modules altogether. This option+  leaves Agda in a very fragile state, as the built-in sorts are used+  extensively throughout the implementation. It is intended to be used+  by Literate Agda projects which want to bind `BUILTIN TYPE` (and+  other primitives) in their own literate files.++* If `--interaction-exit-on-error` is used, then Agda exits with a+  non-zero exit code if `--interaction` or `--interaction-json` are+  used and a type error is encountered. The option also makes Agda+  exit with exit code 113 if Agda fails to parse a command.++  This option might for instance be used if Agda is controlled from a+  script.++* Add a `NOT_PROJECTION_LIKE` pragma, which marks a function as not+  suitable for projection-likeness. Projection-like functions have some of+  their arguments erased, which can cause confusing behaviour when they+  are printed instantiated (see [#6203](https://github.com/agda/agda/issues/6203)).++* [**Breaking**] The options `--subtyping` and `--no-subtyping` have been removed+  (see [#5427](https://github.com/agda/agda/issues/5427)).++Profiling and performance+-------------------------++* New verbosity `-v debug.time:100` adds time stamps to debugging output.++* [**Breaking**] Profiling options are now turned on with a new `--profile` flag+  instead of abusing the debug verbosity option. (See+  [#5781](https://github.com/agda/agda/issues/5781).)++* The new profiling option `--profile=conversion` collects statistics+  on how often various steps of the conversion algorithm are used+  (reduction, eta-expansion, syntactic equality, etc).++* Meta-variables can now be saved in `.agdai` files, instead+  of being expanded. This can affect performance. (See+  [#5731](https://github.com/agda/agda/issues/5731).)++  Meta-variables are saved if the pragma option `--save-metas` is+  used. This option can be overridden by `--no-save-metas`.++* The new option `--syntactic-equality[=FUEL]` can be used to limit+  how many times the syntactic equality shortcut is allowed to fail+  (see [#5801](https://github.com/agda/agda/issues/5801)).++  If `FUEL` is omitted, then the syntactic equality shortcut is+  enabled without any restrictions.++  If `FUEL` is given, then the syntactic equality shortcut is given+  `FUEL` units of fuel. The exact meaning of this is+  implementation-dependent, but successful uses of the shortcut do not+  affect the amount of fuel. Currently the fuel is decreased in the+  failure continuations of the implementation of the syntactic+  equality shortcut. When a failure continuation completes the fuel is+  restored to its previous amount.++  The idea for this option comes from András Kovács'+  [smalltt](https://github.com/AndrasKovacs/smalltt/blob/989b020309686e04374f1ab7844f468386d2eb2f/README.md#approximate-conversion-checking).++  Note that this option is experimental and subject to change.++Library management+------------------++* Library files below the "project root" are now ignored+  (see [#5644](https://github.com/agda/agda/issues/5644)).++  For instance, if you have a module called `A.B.C` in the directory+  `Root/A/B`, then `.agda-lib` files in `Root/A` or `Root/A/B` do not+  affect what options are used to type-check `A.B.C`: `.agda-lib`+  files for `A.B.C` have to reside in `Root`, or further up the+  directory hierarchy.++Interaction+-----------++* Agsy ([automatic proof search](https://agda.readthedocs.io/en/v2.6.3/tools/auto.html)) can+  now be invoked in the right-hand-sides of copattern matching clauses.+  ([#5827](https://github.com/agda/agda/pull/5827))+ Compiler backends ----------------- -* `.hs` files generated by the GHC backend now switch off the-  `warn-overlapping-patterns` warning (issue-  [#5758](https://github.com/agda/agda/issues/5758)).+* [**Breaking**] Both the GHC and JS backends now refuse to compile code that uses+  `--cubical`. -* The GHC backend now calls `ghc` with environment setting-  `GHC_CHARENC=UTF-8` (issue-  [#5742](https://github.com/agda/agda/issues/5742)).+  Note that support for compiling code that uses `--erased-cubical`+  has been added to the GHC backend (see above). -Performance+* If the GHC backend is invoked when `--interaction` or+  `--interaction-json` is active (for instance when the Emacs mode is+  used), then GHC is now invoked from the directory containing the+  `MAlonzo` directory (see+  [#6194](https://github.com/agda/agda/issues/6194)).++  Before GHC was invoked from the Agda process's current working+  directory, and that is still the case if `--interaction` and+  `--interaction-json` are not used.++DOT backend ----------- -* Better caching of interfaces-  (issue [#2767](https://github.com/agda/agda/issues/2767)).+* The new option `--dependency-graph-include=LIBRARY` can be used to+  restrict the dependency graph to modules from one or more libraries+  (see [#5634](https://github.com/agda/agda/issues/5634)). -* Various performance improvements concerning meta-variables:-  issue [#5388](https://github.com/agda/agda/issues/5388)-  and PR [#5733](https://github.com/agda/agda/pull/5733).+  Note that the module given on the command line might not be+  included.++* The generated graphs no longer contain "redundant" edges: if a+  module is imported both directly and indirectly, then the edge+  corresponding to the direct import is omitted.++JSON API+--------++* [**Breaking**] The JSON API now represents meta-variables differently, using+  objects containing two keys, `id` and `module`, both with values+  that are (natural) numbers. See+  [#5731](https://github.com/agda/agda/issues/5731).+++Other issues closed+--------------------++For 2.6.3, the following issues were also closed (see [bug+tracker](https://github.com/agda/agda/issues)):++  - [#3660](https://github.com/agda/agda/issues/3660): Wrong variable name in constraints for higher constructor+  - [#3986](https://github.com/agda/agda/issues/3986): Subtyping `.A -> B <= A -> B` leads to wrong `ArgInfo`+  - [#4103](https://github.com/agda/agda/issues/4103): Rewrite rule rejected because of projection likeness+  - [#4506](https://github.com/agda/agda/issues/4506): Lack of unicode support in locale may result in uncaught `IOException`+  - [#4725](https://github.com/agda/agda/issues/4725): Cubical Agda: Program rejected by termination checker due to moved dot pattern+  - [#4755](https://github.com/agda/agda/issues/4755): Rewrite rule on constructor uses wrong type for matching+  - [#4763](https://github.com/agda/agda/issues/4763): Cubical Agda: Unquote anonymous copattern involving path+  - [#5191](https://github.com/agda/agda/issues/5191): Unifier can use erased variables in non-erased data parameters+  - [#5257](https://github.com/agda/agda/issues/5257): Internal error when matching on user syntax with binding+  - [#5378](https://github.com/agda/agda/issues/5378): Internal error with tactic on record field+  - [#5448](https://github.com/agda/agda/issues/5448): Should the predicate be erasable in the subst rule (without-K)+  - [#5462](https://github.com/agda/agda/issues/5462): Internal error caused by a REWRITE on a projection-like function+  - [#5468](https://github.com/agda/agda/issues/5468): Disallow certain forms of pattern matching when an index is erased+  - [#5525](https://github.com/agda/agda/issues/5525): Duplicate entries in `executables` file lead to undefined behavior+  - [#5548](https://github.com/agda/agda/issues/5548): Agda infers an incorrect type with subtyping on+  - [#5551](https://github.com/agda/agda/issues/5551): Panic when showing module contents with pattern synonym+  - [#5563](https://github.com/agda/agda/issues/5563): Allow erased names in the type signatures of let-bound definitions+  - [#5577](https://github.com/agda/agda/issues/5577): The "Could not generate equivalence" warning is not always emitted+  - [#5581](https://github.com/agda/agda/issues/5581): Lexical error with tab character in literate Agda text+  - [#5589](https://github.com/agda/agda/issues/5589): Internal error with REWRITE of function from path+  - [#5681](https://github.com/agda/agda/issues/5681): Panic on record declaration with unknown sort+  - [#5702](https://github.com/agda/agda/issues/5702): Can't case split an `HitInt` with some already existing cases+  - [#5715](https://github.com/agda/agda/issues/5715): Reflection: Use `Telescope` for `getContext`, `inContext`, and `extendContext`+  - [#5727](https://github.com/agda/agda/issues/5727): Reducing universe levels before checking is not sufficient+  - [#5728](https://github.com/agda/agda/issues/5728): Internal error when pattern matching on `...` in with statement without providing a pattern match+  - [#5734](https://github.com/agda/agda/issues/5734): Relevance check in reflection+  - [#5751](https://github.com/agda/agda/issues/5751): json interaction produces Haskell output for `SolveAll`+  - [#5754](https://github.com/agda/agda/issues/5754): Internal error when compiling program with quoted metavariable+  - [#5760](https://github.com/agda/agda/issues/5760): Some code related to Cubical Agda runs also when the K rule is on+  - [#5763](https://github.com/agda/agda/issues/5763): Internal parser error using syntax rules+  - [#5765](https://github.com/agda/agda/issues/5765): Erasure check failure when pattern matching on refl in erased definition+  - [#5775](https://github.com/agda/agda/issues/5775): JSON interaction produces fully qualified terms+  - [#5794](https://github.com/agda/agda/issues/5794): Agsy/Auto crashes with `Prelude.!!: index too large`+  - [#5823](https://github.com/agda/agda/issues/5823): Singleton check loops on recursive eta record+  - [#5828](https://github.com/agda/agda/issues/5828): Agsy/Auto panics with `-r` in the presence of a pattern synonym+  - [#5845](https://github.com/agda/agda/issues/5845): Internal error caused by abstracting `variables`+  - [#5848](https://github.com/agda/agda/issues/5848): Internal error with `--confluence-check`+  - [#5850](https://github.com/agda/agda/issues/5850): Warn about useless hiding in `variable` declaration+  - [#5856](https://github.com/agda/agda/issues/5856): Lambda with irrefutable pattern is not rejected when used on Path+  - [#5868](https://github.com/agda/agda/issues/5868): Document `--two-level`+  - [#5875](https://github.com/agda/agda/issues/5875): Instance Search breaks Termination Highlighting+  - [#5891](https://github.com/agda/agda/issues/5891): `SizeUniv : SizeUniv` is inconsistent+  - [#5901](https://github.com/agda/agda/issues/5901): Use `emacs --batch` mode in `agda-mode` setup+  - [#5920](https://github.com/agda/agda/issues/5920): Erased constructors skipped in modality check+  - [#5922](https://github.com/agda/agda/issues/5922): Failure of termination checking for reflection-generated code due to data projections+  - [#5923](https://github.com/agda/agda/issues/5923): Internal error in rewriting+  - [#5944](https://github.com/agda/agda/issues/5944): Internal error in rewriting with `--two-level`+  - [#5953](https://github.com/agda/agda/issues/5953): Recursor of inductive-inductive type does not pass termination check in Cubical Agda+  - [#5955](https://github.com/agda/agda/issues/5955): Composition of Glue Type Causes Infinite Loop+  - [#5956](https://github.com/agda/agda/issues/5956): Cubical Agda crashes when printing empty system+  - [#5966](https://github.com/agda/agda/issues/5966): Improved performance by switching to `vector-hashtables`+  - [#5989](https://github.com/agda/agda/issues/5989): Dead-code elimination crashes function with private tactic argument+  - [#6003](https://github.com/agda/agda/issues/6003): de Bruijn index out of scope when rewriting+  - [#6006](https://github.com/agda/agda/issues/6006): Internal error rewriting with holes+  - [#6015](https://github.com/agda/agda/issues/6015): Pi types and Partial types should not be considered inter-convertible+  - [#6022](https://github.com/agda/agda/issues/6022): Private bindings in imported modules defeat check for binding of primIdFace/primIdPath+  - [#6042](https://github.com/agda/agda/issues/6042): De Bruijn index out of scope when rewriting without-K+  - [#6043](https://github.com/agda/agda/issues/6043): de Bruijn error on unexpected implicit argument+  - [#6059](https://github.com/agda/agda/issues/6059): Non-terminating function over tuples passed with `--termination-depth=2`+  - [#6066](https://github.com/agda/agda/issues/6066): Document the meaning of `pattern` without `no-eta-equality`+  - [#6067](https://github.com/agda/agda/issues/6067): Another de Bruijn error in rewriting+  - [#6073](https://github.com/agda/agda/issues/6073): Constraint solving does not honour singleton types+  - [#6074](https://github.com/agda/agda/issues/6074): `piSort`/`funSort` of `IUniv` should be blocked on the codomain+  - [#6076](https://github.com/agda/agda/issues/6076): Agda input mode (emacs): Minibuffer display for `\;` is strange+  - [#6080](https://github.com/agda/agda/issues/6080): A space leak due to `absName`+  - [#6082](https://github.com/agda/agda/issues/6082): Elaborate-and-give does not respect `--postfix-projections`+  - [#6095](https://github.com/agda/agda/issues/6095): Ambiguous pattern synonyms broken with anonymous module+  - [#6112](https://github.com/agda/agda/issues/6112): Internal error: non-confluent rewriting to singletons+  - [#6200](https://github.com/agda/agda/issues/6200): The reflection machinery does not treat the module telescope consistently+  - [#6203](https://github.com/agda/agda/issues/6203): Projection-likeness and instance arguments+  - [#6205](https://github.com/agda/agda/issues/6205): Internal error with `withReconstructed`+  - [#6244](https://github.com/agda/agda/issues/6244): Make `--no-load-primitives` not `--safe`+  - [#6250](https://github.com/agda/agda/issues/6250): Documentation says `--sized-types` is the default when it isn't+  - [#6257](https://github.com/agda/agda/issues/6257): Document options `--prop`, `--guarded`, and `--two-level`.+  - [#6265](https://github.com/agda/agda/issues/6265): Some options should be listed in `restartOptions`+  - [#6273](https://github.com/agda/agda/issues/6273): Missing highlighting when interleaved mutual is used+  - [#6276](https://github.com/agda/agda/issues/6276): LaTeX/HTML generation doesn't properly render parameters of pre-declared records+  - [#6281](https://github.com/agda/agda/issues/6281): Special treatment of attribute followed by underscore in pretty-printer+  - [#6337](https://github.com/agda/agda/issues/6337): `--lossy-unification` in Agda 2.6.3+  - [#6338](https://github.com/agda/agda/issues/6338): internal error in Agda, perhaps related to `--rewriting`+  - [#6377](https://github.com/agda/agda/issues/6377): Fix installation docs concerning icu libraries+  - [#6379](https://github.com/agda/agda/issues/6379): Weird warning for instance declarations of bad type
LICENSE view
@@ -1,12 +1,12 @@-Copyright (c) 2005-2022 remains with the authors.+Copyright (c) 2005-2023 remains with the authors. Agda 2 was originally written by Ulf Norell, partially based on code from Agda 1 by Catarina Coquand and Makoto Takeyama, and from Agdalight by Ulf Norell and Andreas Abel.  Agda 2 is currently actively developed mainly by Andreas Abel,-Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt, Nils-Anders Danielsson, Ulf Norell, Andrés Sicard-Ramírez, and Andrea-Vezzosi.+Guillaume Allais, Liang-Ting Chen, Jesper Cockx, Matthew Daggitt,+Nils Anders Danielsson, Amélia Liao, Ulf Norell, Andrés Sicard-Ramírez,+and Andrea Vezzosi.  Further, Agda 2 has received contributions by, amongst others, Stevan Andjelkovic, Marcin Benke, Jean-Philippe Bernardy, Guillaume Brunerie,
Setup.hs view
@@ -16,10 +16,11 @@ import System.Environment (getEnvironment) import System.Process import System.Exit+import System.IO import System.IO.Error (isDoesNotExistError) -import Control.Monad (when, forM_, unless)-import Control.Exception (catch, throwIO)+import Control.Monad (forM_, unless)+import Control.Exception (bracket, catch, throwIO)  main :: IO () main = defaultMainWithHooks userhooks@@ -96,25 +97,47 @@   -- current directory root of the package.    putStrLn "Generating Agda library interface files..."-  forM_ (dataFiles pd) $ \fp -> when (takeExtension fp == ".agda") $ do-    let fullpath  = ddir </> fp-    let fullpathi = toIFile fullpath -    -- remove existing interface file-    let handleExists e | isDoesNotExistError e = return ()+  -- The Agda.Primitive* and Agda.Builtin* modules.+  let builtins = filter ((== ".agda") . takeExtension) (dataFiles pd)++  -- Remove all existing .agdai files.+  forM_ builtins $ \fp -> do+    let fullpathi = toIFile (ddir </> fp)++        handleExists e | isDoesNotExistError e = return ()                        | otherwise             = throwIO e      removeFile fullpathi `catch` handleExists -    putStrLn $ "... " ++ fullpath-    ok <- rawSystem' ddir agda [ "--no-libraries", "--local-interfaces"-                               , "--ignore-all-interfaces"-                               , "-Werror"-                               , fullpath, "-v0"-                               ]-    case ok of-      ExitSuccess   -> return ()-      ExitFailure _ -> die $ "Error: Failed to typecheck " ++ fullpath ++ "!"+  -- Type-check all builtin modules (in a single Agda session to take+  -- advantage of caching).+  let loadBuiltinCmds = concat+        [ [ cmd ("Cmd_load " ++ f ++ " []")+          , cmd "Cmd_no_metas"+            -- Fail if any meta-variable is unsolved.+          ]+        | b <- builtins+        , let f     = show (ddir </> b)+              cmd c = "IOTCM " ++ f ++ " None Indirect (" ++ c ++ ")"+        ]+  env <- getEnvironment+  _output <- readCreateProcess+      (proc agda+          [ "--interaction"+          , "--interaction-exit-on-error"+          , "--no-libraries"+          , "--local-interfaces"+          , "-Werror"+          , "-v0"+          ])+        { delegate_ctlc = True+                          -- Make Agda look for data files in a+                          -- certain place.+        , env           = Just (("Agda_datadir", ddir) : env)+        }+      (unlines loadBuiltinCmds)+  return ()  agdaExeExtension :: String #if MIN_VERSION_Cabal(2,3,0)@@ -122,12 +145,3 @@ #else agdaExeExtension = exeExtension #endif--rawSystem' :: FilePath -> String -> [String] -> IO ExitCode-rawSystem' agda_datadir cmd args = do-  -- modify environment with Agda_datadir, so agda-executable will look-  -- for data-files in the right place-  e <- getEnvironment-  let e' = ("Agda_datadir", agda_datadir) : e-  (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True, env = Just e' }-  waitForProcess p
+ doc/release-notes/2.6.2.2.md view
@@ -0,0 +1,109 @@+Release notes for Agda version 2.6.2.2+======================================++Highlights+----------++* Agda 2.6.2.2 catches up to changes in the Haskell ecosystem+  (`bytestring-0.11.2.0`, `mtl-2.3-rc3/4`, `text-icu-0.8.0.1`,+  stackage `lts-19.0` and `nightly`).++* Fixes inconsistency [#5838](https://github.com/agda/agda/issues/5838)+  in `--cubical`.++* Fixes some regressions introduced in 2.6.1:++  - [#5809](https://github.com/agda/agda/issues/5809):+    internal error with `--irrelevant-projections`.++* Fixes some regressions introduced in 2.6.2:++  - [#5705](https://github.com/agda/agda/issues/5705) and+    [#5706](https://github.com/agda/agda/issues/5706):+    inconsistency from universe level `Int` overflow.++  - [#5784](https://github.com/agda/agda/issues/5784):+    `primEraseEquality` does not compute.++  - [#5805](https://github.com/agda/agda/issues/5805):+    internal error involving holes and `with`.++  - [#5819](https://github.com/agda/agda/issues/5819):+    internal error when reducing in termination checker.++* Other+  [fixes](https://github.com/agda/agda/issues?q=is%3Aissue+milestone%3A2.6.2.2+is%3Aclosed)+  and improvements (see below).++Installation and infrastructure+-------------------------------++Agda supports GHC versions 8.0.2 to 9.2.2.++* UTF-8 encoding is now used for the `libraries` and `executables`+  configuration files (issue+  [#5741](https://github.com/agda/agda/issues/5741)).++Language+--------++* `macro` definitions can now be used even when they are declared as erased+  (PR [#5744](https://github.com/agda/agda/pull/5744)).+  For example, this is now accepted:+  ```agda+  macro+    @0 trivial : Term → TC ⊤+    trivial = unify (con (quote refl) [])++  test : 42 ≡ 42+  test = trivial+  ```++* Fixed inconsistent `--cubical` reductions for `transp`:+  issue [#5838](https://github.com/agda/agda/issues/5838).++* Fixed issues with reflection:++  - [#5762](https://github.com/agda/agda/issues/5762):+    do not eagerly check existence of commands in `executables` file.++  - [#5695](https://github.com/agda/agda/issues/5695):+    fix `elaborate-and-give` interaction command.++  - [#5700](https://github.com/agda/agda/issues/5700):+    scope of metas created during macro expansion.++  - [#5712](https://github.com/agda/agda/issues/5712):+    internal error with tactics on record fields of function type.++* Fixed issues with instance search:++  - [#5583](https://github.com/agda/agda/issues/5583):+    constructor instances from parameterized modules.++  - [#5787](https://github.com/agda/agda/issues/5787):+    erased instance arguments.++* Fixed issue [#5683](https://github.com/agda/agda/issues/5683) with+  generalization in `let`.++Compiler backends+-----------------++* `.hs` files generated by the GHC backend now switch off the+  `warn-overlapping-patterns` warning (issue+  [#5758](https://github.com/agda/agda/issues/5758)).++* The GHC backend now calls `ghc` with environment setting+  `GHC_CHARENC=UTF-8` (issue+  [#5742](https://github.com/agda/agda/issues/5742)).++Performance+-----------++* Better caching of interfaces+  (issue [#2767](https://github.com/agda/agda/issues/2767)).++* Various performance improvements concerning meta-variables:+  issue [#5388](https://github.com/agda/agda/issues/5388)+  and PR [#5733](https://github.com/agda/agda/pull/5733).
+ doc/user-manual/agda.svg view
@@ -0,0 +1,43 @@+<?xml version="1.0" encoding="UTF-8"?>+<svg width="5217px" height="1707px" viewBox="0 0 5217 1707" version="1.1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">+    <!-- Generator: Sketch 52.6 (67491) - http://www.bohemiancoding.com/sketch -->+    <title>logotype</title>+    <desc>Created with Sketch.</desc>+    <g id="Page-1" stroke="none" stroke-width="1" fill="none" fill-rule="evenodd">+        <g id="Group" transform="translate(-4781.000000, -4784.000000)">+            <rect id="white-background" fill="#FFFFFF" x="0" y="0" width="45624" height="78038"></rect>+            <g id="black-logotypes" transform="translate(4781.000000, 4784.000000)">+                <g id="logotype" transform="translate(219.000000, 219.000000)">+                    <g id="logo">+                        <circle id="left-eye" fill="#000000" cx="240" cy="270" r="27"></circle>+                        <circle id="right-eye" fill="#000000" cx="340" cy="270" r="27"></circle>+                        <path d="M1000,0 L600,400" id="wing" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M1200,100 L1000,300" id="tail-middle" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M1200,0 L1000,200" id="tail-top" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M500,0 L300,200" id="head-middle" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M600,0 L400,200" id="head-right" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                        <path d="M400,-2.84217094e-13 L0,400 L200,400 L200,600 C200,820 380,1000 600,1000 C820,1000 1000,820 1000,600 L1000,400 L1200,200" id="body" stroke="#000000" stroke-width="36" stroke-linecap="round" stroke-linejoin="round"></path>+                    </g>+                    <g id="type" transform="translate(1200.000000, 0.000000)" stroke="#000000" stroke-width="36">+                        <g id="A">+                            <polyline id="A-body" stroke-linecap="round" stroke-linejoin="round" points="0 1000 1002 -2.27373675e-13 1002 1000"></polyline>+                            <path d="M360,640.5 L1000.5,640.5" id="A-stroke"></path>+                        </g>+                        <g id="g" transform="translate(1140.000000, 280.000000)">+                            <circle id="g-body" cx="360" cy="360" r="360"></circle>+                            <path d="M720,0 L720,630 C720,830 560,990 360,990 C225.742948,990 109.510851,917.900176 47.6033734,810.000189" id="g-stroke" stroke-linecap="round" stroke-linejoin="round"></path>+                        </g>+                        <g id="d" transform="translate(2000.000000, 0.000000)">+                            <circle id="d-body" cx="360" cy="640" r="360"></circle>+                            <path d="M720.5,5.68434189e-14 L720.5,1000" id="d-stroke" stroke-linecap="round" stroke-linejoin="round"></path>+                        </g>+                        <g id="a" transform="translate(2860.000000, 280.000000)">+                            <circle id="a-body" cx="360" cy="360" r="360"></circle>+                            <path d="M720,0 L720,720" id="a-stroke" stroke-linecap="round" stroke-linejoin="round"></path>+                        </g>+                    </g>+                </g>+            </g>+        </g>+    </g>+</svg>
src/agda-mode/Main.hs view
@@ -122,7 +122,7 @@ -- | Tries to find the user's .emacs file by querying Emacs.  findDotEmacs :: IO FilePath-findDotEmacs = askEmacs "(insert (expand-file-name user-init-file))"+findDotEmacs = askEmacs "(expand-file-name user-init-file)"  -- | Has the Agda mode already been set up? @@ -167,14 +167,24 @@           (removeFile . fst) $ \(file, h) -> do     hClose h     exit <- rawSystemWithDiagnostics "emacs"-                      [ "--no-desktop", "-nw", "--no-splash"-                          -- Andreas, 2014-01-11: ^ try a leaner startup of emacs-                          -- Andreas, 2018-09-08: -nw instead of --no-window-system as some emacses do not support the long version-                      , "--eval"-                      , "(with-temp-file " ++ escape file ++ " "-                                           ++ query ++ ")"-                      , "--kill"-                      ]+      [ "--batch"+          -- Andreas, 2022-10-15, issue #5901, suggested by Spencer Baugh (catern):+          -- Use Emacs batch mode so that it can run without a terminal.+      , "--user", ""+          -- The flag --user is necessary with --batch so that user-init-file is defined.+          -- The empty user is the default user.+          -- (Option --batch includes --no-init-file, this is reverted by supplying --user.)+      -- Andreas, 2022-05-25, issue #5901 reloaded:+      -- Loading the init file without loading the site fails for some users:+      -- , "--quick"+      --     -- Option --quick includes --no-site-file.+      , "--eval"+      , apply [ "with-temp-file", escape file, apply [ "insert", query ] ]+          -- Short cutting the temp file via just [ "princ", query ]+          -- does not work if the loading of the user-init-file prints extra stuff.+          -- Going via the temp file we can let this stuff go to stdout without+          -- affecting the output we care about.+      ]     unless (exit == ExitSuccess) $ do       informLn "Unable to query Emacs."       exitFailure@@ -249,16 +259,16 @@   where   compile dataDir f = do     exit <- rawSystemWithDiagnostics "emacs" $-                      [ "--no-init-file", "--no-site-file"-                      , "--directory", dataDir-                      , "--batch"-                      , "--eval"-                      , "(progn \-                           \(setq byte-compile-error-on-warn t) \-                           \(byte-compile-disable-warning 'cl-functions) \-                           \(batch-byte-compile))"-                      , f-                      ]+      [ "--quick"                -- 'quick' implies 'no-site-file'+      , "--directory", dataDir+      , "--batch"                -- 'batch' implies 'no-init-file' but not 'no-site-file'.+      , "--eval"+      , "(progn \+           \(setq byte-compile-error-on-warn t) \+           \(byte-compile-disable-warning 'cl-functions) \+           \(batch-byte-compile))"+      , f+      ]     return $ if exit == ExitSuccess then Nothing else Just f  ------------------------------------------------------------------------@@ -269,3 +279,10 @@  inform   = hPutStr   stderr informLn = hPutStrLn stderr++parens :: String -> String+parens s = concat [ "(", s, ")" ]++-- LISP application+apply :: [String] -> String+apply = parens . unwords
src/data/JS/agda-rts.js view
@@ -185,7 +185,6 @@   // These WORD64 values were obtained via `castDoubleToWord64` in Haskell:-const WORD64_NAN      = 18444492273895866368n; const WORD64_POS_INF  = 9218868437227405312n; const WORD64_NEG_INF  = 18442240474082181120n; const WORD64_POS_ZERO = 0n;@@ -193,7 +192,7 @@  exports.primFloatToWord64 = function(x) {     if (exports.primFloatIsNaN(x)) {-        return WORD64_NAN;+        return null;     }     else if (x < 0.0 && exports.primFloatIsInfinite(x)) {         return WORD64_NEG_INF;@@ -350,9 +349,9 @@ exports.primFaceForall = f => f(true) == true && f(false) == false; exports.primDepIMin =     i => f => i ? f({ "tt" : a => a["tt"]() }) : false;+exports.primConId = _ => _ => _ => _ => i => p => { return { "i" : i, "p" : p } }; exports.primIdFace = _ => _ => _ => _ => x => x["i"]; exports.primIdPath = _ => _ => _ => _ => x => x["p"];-exports.primIdJ = _ => _ => _ => _ => _ => x => _ => _ => x; exports.primIdElim =     _ => _ => _ => _ => _ => f => x => y => f(y["i"])(x)(y["p"]); @@ -375,3 +374,21 @@  // primQNameFixity : Name -> Fixity exports.primQNameFixity = x => x['fixity'];++// Meta++// primShowMeta : Meta -> String+//   Should be kept in sync with version in `primitiveFunctions` in+//   Agda.TypeChecking.Primitive+exports.primShowMeta = x => "_" + x['id'] + "@" + x['module'];++// primMetaToNat : Meta -> Nat+//   Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive+exports.primMetaToNat = x => x['module'] * 2^64 + x['id'];++// primMetaEquality : Meta -> Meta -> Bool+exports.primMetaEquality = x => y => x['id'] === y['id'] && x['module'] === y['module'];++// primMetaLess : Meta -> Meta -> Bool+exports.primMetaLess = x => y => x['id'] === y['id'] ? x['module'] < y['module'] : x['id'] < y['id'];+
src/data/MAlonzo/src/MAlonzo/RTE/Float.hs view
@@ -174,8 +174,10 @@   | isNaN x   = nan   | otherwise = x -doubleToWord64 :: Double -> Word64-doubleToWord64 = castDoubleToWord64 . normaliseNaN+doubleToWord64 :: Double -> Maybe Word64+doubleToWord64 x+  | isNaN x   = Nothing+  | otherwise = Just (castDoubleToWord64 x)  -- |Denotational equality for floating point numbers, checks bitwise equality. --
src/data/emacs-mode/agda-input.el view
@@ -184,11 +184,12 @@    ;; Equality and similar symbols. -  ("eq"  . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕"))+  ("eq"  . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕＝"))   ("eqn" . ,(agda-input-to-string-list "≠≁ ≉     ≄  ≇≆  ≢                 ≭    "))                      ("=n"  . ("≠"))-  ("~"    . ("∼"))  ("~n"  . ("≁"))+  ("~"    . ,(agda-input-to-string-list "∼～"))+                    ("~n"  . ("≁"))   ("~~"   . ("≈"))  ("~~n" . ("≉"))   ("~~~"  . ("≋"))   (":~"   . ("∻"))@@ -198,6 +199,7 @@   ("~~-"  . ("≊"))   ("=="   . ("≡"))  ("==n" . ("≢"))   ("==="  . ("≣"))+  ("="    . ("＝"))   (".="   . ("≐"))  (".=." . ("≑"))   (":="   . ("≔"))  ("=:"  . ("≕"))   ("=o"   . ("≗"))@@ -211,9 +213,9 @@    ;; Inequality and similar symbols. -  ("leq"  . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞"))+  ("leq"  . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞＜"))   ("leqn" . ,(agda-input-to-string-list "≮  ≰≨≴⋦≸⊀ ⋨⊄⊈⊊  ⋢⋤ ⋪⋬   ⋠"))-  ("geq"  . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟"))+  ("geq"  . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟＞"))   ("geqn" . ,(agda-input-to-string-list "≯  ≱≩≵⋧≹⊁ ⋩⊅⊉⊋  ⋣⋥ ⋫⋭   ⋡"))    ("<="   . ("≤"))  (">="   . ("≥"))@@ -293,23 +295,25 @@   ("x"         . ("×"))   ("o"         . ("∘"))   ("comp"      . ("∘"))-  ("."         . ("∙"))+  ("."         . ,(agda-input-to-string-list "∙．"))   ("*"         . ("⋆"))   (".+"        . ("∔"))   (".-"        . ("∸"))   (":"         . ,(agda-input-to-string-list "∶⦂ː꞉˸፥፦：﹕︓"))   (","         . ,(agda-input-to-string-list "ʻ،⸲⸴⹁⹉、︐︑﹐﹑，､"))-  (";"         . ,(agda-input-to-string-list "؛⁏፤꛶；︔﹔⍮⸵;"))+  (";"         . ,(agda-input-to-string-list "⨾⨟⁏፤꛶；︔﹔⍮⸵;"))   ("::"        . ("∷"))   ("::-"       . ("∺"))   ("-:"        . ("∹"))   ("+ "        . ("⊹"))+  ("+"         . ("＋"))+  ("sqrt"      . ("√"))   ("surd3"     . ("∛"))   ("surd4"     . ("∜"))   ("increment" . ("∆"))   ("inf"       . ("∞"))   ("&"         . ("⅋"))-  ("z;"        . ("⨟"))+  ("z;"        . ,(agda-input-to-string-list "⨟⨾"))   ("z:"        . ("⦂"))    ;; Circled operators.@@ -344,10 +348,10 @@    ;; Arrows. -  ("l"  . ,(agda-input-to-string-list "←⇐⇚⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹     ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲                                     "))-  ("r"  . ,(agda-input-to-string-list "→⇒⇛⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴    ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸"))-  ("u"  . ,(agda-input-to-string-list "↑⇑⟰⇈⇅↥⇧↟↿↾⇡⇞          ↰↱➦ ⇪⇫⇬⇭⇮⇯                                           "))-  ("d"  . ,(agda-input-to-string-list "↓⇓⟱⇊⇵↧⇩↡⇃⇂⇣⇟         ↵↲↳➥ ↯                                                "))+  ("l"  . ,(agda-input-to-string-list "←⇐⇚⭅⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹     ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲                                     "))+  ("r"  . ,(agda-input-to-string-list "→⇒⇛⭆⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴    ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾⊸"))+  ("u"  . ,(agda-input-to-string-list "↑⇑⤊⟰⇈⇅↥⇧↟↿↾⇡⇞          ↰↱➦ ⇪⇫⇬⇭⇮⇯                                           "))+  ("d"  . ,(agda-input-to-string-list "↓⇓⤋⟱⇊⇵↧⇩↡⇃⇂⇣⇟         ↵↲↳➥ ↯                                                "))   ("ud" . ,(agda-input-to-string-list "↕⇕   ↨⇳                                                                    "))   ("lr" . ,(agda-input-to-string-list "↔⇔         ⇼↭⇿⟷⟺↮⇎⇹                                                        "))   ("ul" . ,(agda-input-to-string-list "↖⇖                        ⇱↸                                               "))@@ -536,6 +540,112 @@   ("b8"   . ("𝟠"))   ("b9"   . ("𝟡")) +  ;; Mathematical bold letters.++  ("BA"   . ("𝐀"))+  ("BB"   . ("𝐁"))+  ("BC"   . ("𝐂"))+  ("BD"   . ("𝐃"))+  ("BE"   . ("𝐄"))+  ("BF"   . ("𝐅"))+  ("BG"   . ("𝐆"))+  ("BH"   . ("𝐇"))+  ("BI"   . ("𝐈"))+  ("BJ"   . ("𝐉"))+  ("BK"   . ("𝐊"))+  ("BL"   . ("𝐋"))+  ("BM"   . ("𝐌"))+  ("BN"   . ("𝐍"))+  ("BO"   . ("𝐎"))+  ("BP"   . ("𝐏"))+  ("BQ"   . ("𝐐"))+  ("BR"   . ("𝐑"))+  ("BS"   . ("𝐒"))+  ("BT"   . ("𝐓"))+  ("BU"   . ("𝐔"))+  ("BV"   . ("𝐕"))+  ("BW"   . ("𝐖"))+  ("BX"   . ("𝐗"))+  ("BY"   . ("𝐘"))+  ("BZ"   . ("𝐙"))+  ("Ba"   . ("𝐚"))+  ("Bb"   . ("𝐛"))+  ("Bc"   . ("𝐜"))+  ("Bd"   . ("𝐝"))+  ("Be"   . ("𝐞"))+  ("Bf"   . ("𝐟"))+  ("Bg"   . ("𝐠"))+  ("Bh"   . ("𝐡"))+  ("Bi"   . ("𝐢"))+  ("Bj"   . ("𝐣"))+  ("Bk"   . ("𝐤"))+  ("Bl"   . ("𝐥"))+  ("Bm"   . ("𝐦"))+  ("Bn"   . ("𝐧"))+  ("Bo"   . ("𝐨"))+  ("Bp"   . ("𝐩"))+  ("Bq"   . ("𝐪"))+  ("Br"   . ("𝐫"))+  ("Bs"   . ("𝐬"))+  ("Bt"   . ("𝐭"))+  ("Bu"   . ("𝐮"))+  ("Bv"   . ("𝐯"))+  ("Bw"   . ("𝐰"))+  ("Bx"   . ("𝐱"))+  ("By"   . ("𝐲"))+  ("Bz"   . ("𝐳"))++  ;; Mathematical bold Greek letters.++  ("BGA"  . ("𝚨"))+  ("BGB"  . ("𝚩"))+  ("BGC"  . ("𝚾"))+  ("BGD"  . ("𝚫"))+  ("BGE"  . ("𝚬"))+  ("BGG"  . ("𝚪"))+  ("BGH"  . ("𝚮"))+  ("BGI"  . ("𝚰"))+  ("BGK"  . ("𝚱"))+  ("BGL"  . ("𝚲"))+  ("BGM"  . ("𝚳"))+  ("BGN"  . ("𝚴"))+  ("BGO"  . ("𝛀"))+  ("BOmicron" . ("𝚶"))+  ("BGF"  . ("𝚽"))+  ("BPi"  . ("𝚷"))+  ("BGP"  . ("𝚿"))+  ("BGR"  . ("𝚸"))+  ("BGS"  . ("𝚺"))+  ("BGT"  . ("𝚻"))+  ("BGTH" . ("𝚯"))+  ("BGU"  . ("𝚼"))+  ("BGX"  . ("𝚵"))+  ("BGZ"  . ("𝚭"))+  ("BGa"  . ("𝛂"))+  ("BGb"  . ("𝛃"))+  ("BGc"  . ("𝛘"))+  ("BGd"  . ("𝛅"))+  ("BGe"  . ("𝛆"))+  ("BGg"  . ("𝛄"))+  ("BGh"  . ("𝛈"))+  ("BGi"  . ("𝛊"))+  ("BGk"  . ("𝛋"))+  ("BGl"  . ("𝛌"))+  ("BGm"  . ("𝛍"))+  ("BGn"  . ("𝛎"))+  ("BGo"  . ("𝛚"))+  ("Bomicron" . ("𝛐"))+  ("BGf"  . ("𝛗"))+  ("Bpi"  . ("𝛑"))+  ("BGp"  . ("𝛙"))+  ("BGr"  . ("𝛒"))+  ("BGs"  . ("𝛔"))+  ("BGt"  . ("𝛕"))+  ("BGth" . ("𝛉"))+  ("BGu"  . ("𝛖"))+  ("BGx"  . ("𝛏"))+  ("BGz"  . ("𝛇"))+   ;; Mathematical bold digits.    ("B0"   . ("𝟎"))@@ -549,6 +659,74 @@   ("B8"   . ("𝟖"))   ("B9"   . ("𝟗")) +  ;; Fullwidth letters++  ("FA"   . ("Ａ"))+  ("FB"   . ("Ｂ"))+  ("FC"   . ("Ｃ"))+  ("FD"   . ("Ｄ"))+  ("FE"   . ("Ｅ"))+  ("FF"   . ("Ｆ"))+  ("FG"   . ("Ｇ"))+  ("FH"   . ("Ｈ"))+  ("FI"   . ("Ｉ"))+  ("FJ"   . ("Ｊ"))+  ("FK"   . ("Ｋ"))+  ("FL"   . ("Ｌ"))+  ("FM"   . ("Ｍ"))+  ("FN"   . ("Ｎ"))+  ("FO"   . ("Ｏ"))+  ("FP"   . ("Ｐ"))+  ("FQ"   . ("Ｑ"))+  ("FR"   . ("Ｒ"))+  ("FS"   . ("Ｓ"))+  ("FT"   . ("Ｔ"))+  ("FU"   . ("Ｕ"))+  ("FV"   . ("Ｖ"))+  ("FW"   . ("Ｗ"))+  ("FX"   . ("Ｘ"))+  ("FY"   . ("Ｙ"))+  ("FZ"   . ("Ｚ"))+  ("Fa"   . ("ａ"))+  ("Fb"   . ("ｂ"))+  ("Fc"   . ("ｃ"))+  ("Fd"   . ("ｄ"))+  ("Fe"   . ("ｅ"))+  ("Ff"   . ("ｆ"))+  ("Fg"   . ("ｇ"))+  ("Fh"   . ("ｈ"))+  ("Fi"   . ("ｉ"))+  ("Fj"   . ("ｊ"))+  ("Fk"   . ("ｋ"))+  ("Fl"   . ("ｌ"))+  ("Fm"   . ("ｍ"))+  ("Fn"   . ("ｎ"))+  ("Fo"   . ("ｏ"))+  ("Fp"   . ("ｐ"))+  ("Fq"   . ("ｑ"))+  ("Fr"   . ("ｒ"))+  ("Fs"   . ("ｓ"))+  ("Ft"   . ("ｔ"))+  ("Fu"   . ("ｕ"))+  ("Fv"   . ("ｖ"))+  ("Fw"   . ("ｗ"))+  ("Fx"   . ("ｘ"))+  ("Fy"   . ("ｙ"))+  ("Fz"   . ("ｚ"))++  ;; Fullwidth digits++  ("F0"   . ("０"))+  ("F1"   . ("１"))+  ("F2"   . ("２"))+  ("F3"   . ("３"))+  ("F4"   . ("４"))+  ("F5"   . ("５"))+  ("F6"   . ("６"))+  ("F7"   . ("７"))+  ("F8"   . ("８"))+  ("F9"   . ("９"))+   ;; Parentheses.    ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟅⟦⟨⟪⦃〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢❪❬❰❲❴⟮⦅⦗⧼⸨❮⦇⦉"))@@ -556,8 +734,8 @@    ("[[" . ("⟦"))   ("]]" . ("⟧"))-  ("<"  . ("⟨"))-  (">"  . ("⟩"))+  ("<"  . ,(agda-input-to-string-list "⟨<≪⋘≺⊂⋐⊏⊰⊲⋖＜"))+  (">"  . ,(agda-input-to-string-list "⟩>≫⋙≻⊃⋑⊐⊱⊳⋗＞"))   ("<<" . ("⟪"))   (">>" . ("⟫"))   ("{{" . ("⦃"))@@ -575,13 +753,13 @@   ("(|" . ("⦇"))  ;; Idiom brackets   ("|)" . ("⦈")) -  ("((" . ("⦅"))  ;; Banana brackets-  ("))" . ("⦆"))+  ("((" . ,(agda-input-to-string-list "⦅｟"))  ;; Banana brackets+  ("))" . ,(agda-input-to-string-list "⦆｠"))    ;; Primes. -  ("'" . ,(agda-input-to-string-list "′″‴⁗"))-  ("`" . ,(agda-input-to-string-list "‵‶‷"))+  ("'" . ,(agda-input-to-string-list "′″‴⁗＇"))+  ("`" . ,(agda-input-to-string-list "‵‶‷｀"))    ;; Fractions. @@ -605,12 +783,14 @@   ("\\"         . ("\\"))   ("en"         . ("–"))   ("em"         . ("—"))+  ("!"          . ("！"))   ("!!"         . ("‼"))+  ("?"          . ("？"))   ("??"         . ("⁇"))   ("?!"         . ("‽" "⁈"))   ("!?"         . ("⁉"))   ("die"        . ,(agda-input-to-string-list "⚀⚁⚂⚃⚄⚅"))-  ("asterisk"   . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋"))+  ("asterisk"   . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋＊"))   ("8<"         . ("✂" "✄"))   ("tie"        . ("⁀"))   ("undertie"   . ("‿"))@@ -618,6 +798,14 @@                                                ⍉⍊⍋⍌⍍⍎⍏⍐⍑⍒⍓⍔⍕⍖⍗⍘⍙⍚⍛                                                ⍜⍝⍞⍟⍠⍡⍢⍣⍤⍥⍦⍧⍨⍩⍪⍫⍬⍭⍮                                                ⍯⍰⍱⍲⍳⍴⍵⍶⍷⍸⍹⍺⎕"))+  ("#"          . ("＃"))+  ("%"          . ("％"))+  ("&"          . ("＆"))+  ("*"          . ("＊"))+  ("/"          . ,(agda-input-to-string-list "／＼"))+  ("@"          . ("＠"))+  ("__"         . ("＿"))+  ("\""         . ("＂"))    ;; Some combining characters.   ;;
src/data/emacs-mode/agda2-mode-pkg.el view
@@ -1,3 +1,3 @@-(define-package "agda2-mode" "2.6.2.2"+(define-package "agda2-mode" "2.6.3"   "interactive development for Agda, a dependently typed functional programming language"   '((emacs "24.3") (annotation "1.0") (eri "1.0")))
src/data/emacs-mode/agda2-mode.el view
@@ -28,7 +28,7 @@  ;;; Code: -(defvar agda2-version "2.6.2.2"+(defvar agda2-version "2.6.3"   "The version of the Agda mode. Note that the same version of the Agda executable must be used.") @@ -108,10 +108,6 @@   :type 'string   :group 'agda2) -(defcustom agda2-toplevel-module "Agda.Interaction.GhciTop"-  "The name of the Agda toplevel module."-  :type 'string :group 'agda2)- (defcustom agda2-information-window-max-height   0.35   "The maximum height of the information window.@@ -1306,7 +1302,8 @@  (agda2-maybe-normalised  agda2-elaborate-give- "Elaborate check the given expression against the hole's type and fill in hole with the elaborated term"+ "Elaborate check the given expression against the hole's type and fill in the+ hole with the elaborated term"  "Cmd_elaborate_give"  "expression to elaborate and give") @@ -1324,7 +1321,8 @@  (agda2-maybe-normalised  agda2-goal-and-context-and-checked- "Shows the context, the goal and check the given expression's against the hole's type"+ "Shows the context, the goal and check the given expression's against+ the hole's type"  "Cmd_goal_type_context_check"  "expression to type") @@ -1976,7 +1974,10 @@ This command assumes that the agda and agda-mode executables for Agda version VERSION are called agda-VERSION and agda-mode-VERSION, and that they are located on the PATH. (If-VERSION is empty, then agda and agda-mode are used instead.)"+VERSION is empty, then agda and agda-mode are used instead.)++An attempt is made to preserve the default value of+`agda2-mode-hook'."   (interactive    (list (completing-read "Version: " (agda2-get-agda-program-versions)))) @@ -1988,6 +1989,8 @@                       (list buf))))                 (buffer-list))) +       (default-hook (default-value 'agda2-mode-hook))+        (version-suffix (if (or (equal version "")                                (equal version nil))                            ""@@ -2041,6 +2044,10 @@     (load-file agda-mode-path)     (require 'agda2-mode)     (setq agda2-program-name (concat "agda" version-suffix))++    ;; Restore the Agda mode's default hook (if any).+    (when default-hook+      (set-default 'agda2-mode-hook default-hook))      ;; Restart the Agda mode in all former Agda mode buffers.     (mapc (lambda (buf)
src/data/latex/agda.sty view
@@ -6,7 +6,7 @@ % !!! NOTE: when you make changes to this file, bump the date. !!! % !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! \ProvidesPackage{agda}-  [2021/07/14 version 2.6.2.2 Formatting LaTeX generated by Agda]+  [2021/07/14 version 2.6.3 Formatting LaTeX generated by Agda]  \RequirePackage{ifxetex, ifluatex, xifthen, xcolor, polytable, etoolbox,                 calc, environ, xparse, xkeyval}
src/data/lib/prim/Agda/Builtin/Bool.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness  --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness #-}  module Agda.Builtin.Bool where
src/data/lib/prim/Agda/Builtin/Char.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness #-}  module Agda.Builtin.Char where
src/data/lib/prim/Agda/Builtin/Char/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Char.Properties where
src/data/lib/prim/Agda/Builtin/Coinduction.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --universe-polymorphism --no-sized-types-            --guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --universe-polymorphism --no-sized-types+            --guardedness #-}  module Agda.Builtin.Coinduction where
src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Glue where @@ -9,7 +8,7 @@                                              primHComp to hcomp; primTransp to transp; primComp to comp;                                              itIsOne to 1=1) open import Agda.Builtin.Cubical.Path-open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to ouc)+open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]) import Agda.Builtin.Cubical.HCompU as HCompU  module Helpers = HCompU.Helpers@@ -41,8 +40,9 @@ -- case. This makes the computational behavior better, in particular -- for transp in Glue. equivProof : ∀ {la lt} (T : Set la) (A : Set lt) → (w : T ≃ A) → (a : A)-           → ∀ ψ → (Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a-equivProof A B w a ψ fb = contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb+           → ∀ ψ (f : Partial ψ (fiber (w .fst) a)) → fiber (w .fst) a [ ψ ↦ f ]+equivProof A B w a ψ fb =+  inS (contr' {A = fiber (w .fst) a} (w .snd .equiv-proof a) ψ fb)   where     contr' : ∀ {ℓ} {A : Set ℓ} → isContr A → (φ : I) → (u : Partial φ A) → A     contr' {A = A} (c , p) φ u = hcomp (λ i → λ { (φ = i1) → p (u 1=1) i@@ -97,11 +97,11 @@           sys x i (j = i1) = u (~ i) x         ω0 = comp ~E (sys x0) ((β0 (~ j)))         ω1 = comp ~E (sys x1) ((β1 (~ j)))-        θ0 = fill ~E (sys x0) (inc (β0 (~ j)))-        θ1 = fill ~E (sys x1) (inc (β1 (~ j)))+        θ0 = fill ~E (sys x0) (inS (β0 (~ j)))+        θ1 = fill ~E (sys x1) (inS (β1 (~ j)))       sys = λ {j (k = i0) → ω0 j ; j (k = i1) → ω1 j}       ω = hcomp sys (g y)-      θ = hfill sys (inc (g y))+      θ = hfill sys (inS (g y))       δ = λ (j : I) → comp E             (λ i → λ { (j = i0) → v i y ; (k = i0) → θ0 j (~ i)                      ; (j = i1) → u i ω ; (k = i1) → θ1 j (~ i) })
src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.HCompU where @@ -9,7 +8,7 @@                                              primHComp to hcomp; primTransp to transp; primComp to comp;                                              itIsOne to 1=1) open import Agda.Builtin.Cubical.Path-open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS; inc to inS)+open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS)  module Helpers where     -- Homogeneous filling
src/data/lib/prim/Agda/Builtin/Cubical/Id.agda view
@@ -1,19 +1,22 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Id where    open import Agda.Primitive.Cubical   open import Agda.Builtin.Cubical.Path-  open import Agda.Builtin.Cubical.Sub renaming (primSubOut to ouc; Sub to _[_↦_])--  postulate-    Id : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ+  open import Agda.Builtin.Cubical.Sub renaming (primSubOut to outS; Sub to _[_↦_])    {-# BUILTIN ID           Id       #-}-  {-# BUILTIN CONID        conid    #-}+  {-# BUILTIN REFLID       reflId   #-} -  -- Id x y is treated as a pair of I and x ≡ y, using "i" for the+  private+    module ConId where+      primitive+        primConId : ∀ {ℓ} {A : Set ℓ} {x y : A} → I → x ≡ y → Id x y++  open ConId public renaming (primConId to conid)++  -- Id x y is treated as a pair of I and x ≡ y, using "i" for the   -- first component and "p" for the second.   {-# COMPILE JS conid =       _ => _ => _ => _ => i => p => { return { "i" : i, "p" : p } }@@ -25,14 +28,22 @@     primIdPath : ∀ {ℓ} {A : Set ℓ} {x y : A} → Id x y → x ≡ y    primitive-    primIdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') →-                P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p---  primitive     primIdElim : ∀ {a c} {A : Set a} {x : A}                    (C : (y : A) → Id x y → Set c) →                    ((φ : I) (y : A [ φ ↦ (λ _ → x) ])-                    (w : (x ≡ ouc y) [ φ ↦ (λ { (φ = i1) → \ _ → x}) ]) →-                    C (ouc y) (conid φ (ouc w))) →+                    (w : (x ≡ outS y) [ φ ↦ (λ { (φ = i1) → \ _ → x}) ]) →+                    C (outS y) (conid φ (outS w))) →                    {y : A} (p : Id x y) → C y p++  -- IdJ can be defined in terms of pattern matching on the reflId+  -- constructor. This equality is definitional; For non-reflId+  -- identifications, it computes in terms of primIdElim and primComp.+  IdJ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ') →+      P x (conid i1 (λ i → x)) → ∀ {y} (p : Id x y) → P y p+  IdJ {x = x} P prefl reflId = prefl++  -- Test computational behaviour of IdJ:+  _ : ∀ {ℓ ℓ'} {A : Set ℓ} {x : A} (P : ∀ y → Id x y → Set ℓ')+    → (a : P x (conid i1 (λ i → x)))+    → IdJ P a (conid i1 (λ i → x)) ≡ a+  _ = λ P a i → a
src/data/lib/prim/Agda/Builtin/Cubical/Path.agda view
@@ -1,14 +1,9 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Path where -  open import Agda.Primitive.Cubical--  postulate-    PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ+  open import Agda.Primitive.Cubical using (PathP) public -  {-# BUILTIN PATHP        PathP     #-}    infix 4 _≡_
src/data/lib/prim/Agda/Builtin/Cubical/Sub.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Cubical.Sub where @@ -8,12 +7,12 @@   {-# BUILTIN SUB Sub #-}    postulate-    inc : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x)+    inS : ∀ {ℓ} {A : Set ℓ} {φ} (x : A) → Sub A φ (λ _ → x) -  {-# BUILTIN SUBIN inc #-}+  {-# BUILTIN SUBIN inS #-} -  -- Sub A φ u is treated as A.-  {-# COMPILE JS inc = _ => _ => _ => x => x #-}+  -- Sub A φ u is treated as A.+  {-# COMPILE JS inS = _ => _ => _ => x => x #-}    primitive     primSubOut : ∀ {ℓ} {A : Set ℓ} {φ : I} {u : Partial φ A} → Sub _ φ u → A
src/data/lib/prim/Agda/Builtin/Equality.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Equality where
src/data/lib/prim/Agda/Builtin/Equality/Erase.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --with-K --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Equality.Erase where
src/data/lib/prim/Agda/Builtin/Equality/Rewrite.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --rewriting --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --rewriting --no-sized-types --no-guardedness #-}  module Agda.Builtin.Equality.Rewrite where
src/data/lib/prim/Agda/Builtin/Float.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Float where @@ -24,7 +23,7 @@   primFloatIsNegativeZero    : Float → Bool   primFloatIsSafeInteger     : Float → Bool   -- Conversions-  primFloatToWord64          : Float → Word64+  primFloatToWord64          : Float → Maybe Word64   primNatToFloat             : Nat → Float   primIntToFloat             : Int → Float   primFloatRound             : Float → Maybe Int
src/data/lib/prim/Agda/Builtin/Float/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Float.Properties where
src/data/lib/prim/Agda/Builtin/FromNat.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.FromNat where
src/data/lib/prim/Agda/Builtin/FromNeg.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.FromNeg where
src/data/lib/prim/Agda/Builtin/FromString.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.FromString where
src/data/lib/prim/Agda/Builtin/IO.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.IO where
src/data/lib/prim/Agda/Builtin/Int.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Int where
src/data/lib/prim/Agda/Builtin/List.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.List where
src/data/lib/prim/Agda/Builtin/Maybe.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Maybe where
src/data/lib/prim/Agda/Builtin/Nat.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness #-}  module Agda.Builtin.Nat where
src/data/lib/prim/Agda/Builtin/Reflection.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Reflection where @@ -165,6 +164,7 @@ data Pattern : Set data Clause  : Set Type = Term+Telescope = List (Σ String λ _ → Arg Type)  data Term where   var       : (x : Nat) (args : List (Arg Term)) → Term@@ -195,8 +195,8 @@   absurd : (x : Nat)     → Pattern  -- absurd patterns counts as variables  data Clause where-  clause        : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) (t : Term) → Clause-  absurd-clause : (tel : List (Σ String λ _ → Arg Type)) (ps : List (Arg Pattern)) → Clause+  clause        : (tel : Telescope) (ps : List (Arg Pattern)) (t : Term) → Clause+  absurd-clause : (tel : Telescope) (ps : List (Arg Pattern)) → Clause  {-# BUILTIN AGDATERM      Term    #-} {-# BUILTIN AGDASORT      Sort    #-}@@ -254,11 +254,13 @@ data ErrorPart : Set where   strErr  : String → ErrorPart   termErr : Term → ErrorPart+  pattErr : Pattern → ErrorPart   nameErr : Name → ErrorPart  {-# BUILTIN AGDAERRORPART       ErrorPart #-} {-# BUILTIN AGDAERRORPARTSTRING strErr    #-} {-# BUILTIN AGDAERRORPARTTERM   termErr   #-}+{-# BUILTIN AGDAERRORPARTPATT   pattErr   #-} {-# BUILTIN AGDAERRORPARTNAME   nameErr   #-}  -- TC monad --@@ -277,12 +279,14 @@   quoteTC          : ∀ {a} {A : Set a} → A → TC Term   unquoteTC        : ∀ {a} {A : Set a} → Term → TC A   quoteωTC         : ∀ {A : Setω} → A → TC Term-  getContext       : TC (List (Arg Type))-  extendContext    : ∀ {a} {A : Set a} → Arg Type → TC A → TC A-  inContext        : ∀ {a} {A : Set a} → List (Arg Type) → TC A → TC A+  getContext       : TC Telescope+  extendContext    : ∀ {a} {A : Set a} → String → Arg Type → TC A → TC A+  inContext        : ∀ {a} {A : Set a} → Telescope → TC A → TC A   freshName        : String → TC Name   declareDef       : Arg Name → Type → TC ⊤   declarePostulate : Arg Name → Type → TC ⊤+  declareData      : Name → Nat → Type → TC ⊤+  defineData       : Name → List (Σ Name (λ _ → Type)) → TC ⊤   defineFun        : Name → List Clause → TC ⊤   getType          : Name → TC Type   getDefinition    : Name → TC Definition@@ -298,6 +302,7 @@   -- getDefinition, normalise, reduce, inferType, checkType and getContext   withReconstructed : ∀ {a} {A : Set a} → TC A → TC A +  formatErrorParts : List ErrorPart → TC String   -- Prints the third argument if the corresponding verbosity level is turned   -- on (with the -v flag to Agda).   debugPrint : String → Nat → List ErrorPart → TC ⊤@@ -317,6 +322,10 @@   -- new TC state if it is 'true'.   runSpeculative : ∀ {a} {A : Set a} → TC (Σ A λ _ → Bool) → TC A +  -- Get a list of all possible instance candidates for the given meta+  -- variable (it does not have to be an instance meta).+  getInstances : Meta → TC (List Term)+ {-# BUILTIN AGDATCM                           TC                         #-} {-# BUILTIN AGDATCMRETURN                     returnTC                   #-} {-# BUILTIN AGDATCMBIND                       bindTC                     #-}@@ -336,6 +345,8 @@ {-# BUILTIN AGDATCMFRESHNAME                  freshName                  #-} {-# BUILTIN AGDATCMDECLAREDEF                 declareDef                 #-} {-# BUILTIN AGDATCMDECLAREPOSTULATE           declarePostulate           #-}+{-# BUILTIN AGDATCMDECLAREDATA                declareData                #-}+{-# BUILTIN AGDATCMDEFINEDATA                 defineData                 #-} {-# BUILTIN AGDATCMDEFINEFUN                  defineFun                  #-} {-# BUILTIN AGDATCMGETTYPE                    getType                    #-} {-# BUILTIN AGDATCMGETDEFINITION              getDefinition              #-}@@ -343,12 +354,14 @@ {-# BUILTIN AGDATCMCOMMIT                     commitTC                   #-} {-# BUILTIN AGDATCMISMACRO                    isMacro                    #-} {-# BUILTIN AGDATCMWITHNORMALISATION          withNormalisation          #-}+{-# BUILTIN AGDATCMFORMATERRORPARTS           formatErrorParts           #-} {-# BUILTIN AGDATCMDEBUGPRINT                 debugPrint                 #-} {-# BUILTIN AGDATCMONLYREDUCEDEFS             onlyReduceDefs             #-} {-# BUILTIN AGDATCMDONTREDUCEDEFS             dontReduceDefs             #-} {-# BUILTIN AGDATCMWITHRECONSPARAMS           withReconstructed          #-} {-# BUILTIN AGDATCMNOCONSTRAINTS              noConstraints              #-} {-# BUILTIN AGDATCMRUNSPECULATIVE             runSpeculative             #-}+{-# BUILTIN AGDATCMGETINSTANCES               getInstances               #-}  -- All the TC primitives are compiled to functions that return -- undefined, rather than just undefined, in an attempt to make sure@@ -367,11 +380,13 @@ {-# COMPILE JS unquoteTC         = _ => _ => _ =>      undefined #-} {-# COMPILE JS quoteωTC          = _ => _ =>           undefined #-} {-# COMPILE JS getContext        =                     undefined #-}-{-# COMPILE JS extendContext     = _ => _ => _ => _ => undefined #-}+{-# COMPILE JS extendContext     = _ => _ => _ => _ => _ => undefined #-} {-# COMPILE JS inContext         = _ => _ => _ => _ => undefined #-} {-# COMPILE JS freshName         = _ =>                undefined #-} {-# COMPILE JS declareDef        = _ => _ =>           undefined #-} {-# COMPILE JS declarePostulate  = _ => _ =>           undefined #-}+{-# COMPILE JS declareData       = _ => _ => _ =>      undefined #-}+{-# COMPILE JS defineData        = _ => _ =>           undefined #-} {-# COMPILE JS defineFun         = _ => _ =>           undefined #-} {-# COMPILE JS getType           = _ =>                undefined #-} {-# COMPILE JS getDefinition     = _ =>                undefined #-}@@ -385,3 +400,4 @@ {-# COMPILE JS dontReduceDefs    = _ => _ => _ => _ => undefined #-} {-# COMPILE JS noConstraints     = _ => _ => _ =>      undefined #-} {-# COMPILE JS runSpeculative    = _ => _ => _ =>      undefined #-}+{-# COMPILE JS getInstances      = _ =>                undefined #-}
src/data/lib/prim/Agda/Builtin/Reflection/External.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Reflection.External where
src/data/lib/prim/Agda/Builtin/Reflection/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Reflection.Properties where
src/data/lib/prim/Agda/Builtin/Sigma.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Sigma where
src/data/lib/prim/Agda/Builtin/Size.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --no-universe-polymorphism --sized-types-            --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --no-universe-polymorphism --sized-types+            --no-guardedness #-}  module Agda.Builtin.Size where
src/data/lib/prim/Agda/Builtin/Strict.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Strict where
src/data/lib/prim/Agda/Builtin/String.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.String where
src/data/lib/prim/Agda/Builtin/String/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.String.Properties where
src/data/lib/prim/Agda/Builtin/TrustMe.agda view
@@ -1,4 +1,4 @@-{-# OPTIONS --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --no-sized-types --no-guardedness #-}  module Agda.Builtin.TrustMe where
src/data/lib/prim/Agda/Builtin/Unit.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness #-}  module Agda.Builtin.Unit where
src/data/lib/prim/Agda/Builtin/Word.agda view
@@ -1,5 +1,5 @@-{-# OPTIONS --without-K --safe --no-universe-polymorphism-            --no-sized-types --no-guardedness --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-universe-polymorphism+            --no-sized-types --no-guardedness #-}  module Agda.Builtin.Word where
src/data/lib/prim/Agda/Builtin/Word/Properties.agda view
@@ -1,5 +1,4 @@-{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness-            --no-subtyping #-}+{-# OPTIONS --cubical-compatible --safe --no-sized-types --no-guardedness #-}  module Agda.Builtin.Word.Properties where
src/data/lib/prim/Agda/Primitive.agda view
@@ -1,6 +1,6 @@ -- The Agda primitives (preloaded). -{-# OPTIONS --without-K --no-subtyping --no-import-sorts #-}+{-# OPTIONS --cubical-compatible --no-import-sorts #-}  module Agda.Primitive where
src/data/lib/prim/Agda/Primitive/Cubical.agda view
@@ -1,8 +1,9 @@-{-# OPTIONS --erased-cubical --no-subtyping #-}+{-# OPTIONS --erased-cubical #-}  module Agda.Primitive.Cubical where -{-# BUILTIN INTERVAL I  #-}  -- I : Setω+{-# BUILTIN CUBEINTERVALUNIV IUniv #-}  -- IUniv : SSet₁+{-# BUILTIN INTERVAL I  #-}  -- I : IUniv  {-# BUILTIN IZERO    i0 #-} {-# BUILTIN IONE     i1 #-}@@ -69,3 +70,9 @@ primitive   primTransp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (a : A i0) → A i1   primHComp  : ∀ {ℓ} {A : Set ℓ} {φ : I} (u : ∀ i → Partial φ A) (a : A) → A+++postulate+  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ++{-# BUILTIN PATHP        PathP     #-}
src/full/Agda/Auto/Auto.hs view
@@ -5,7 +5,7 @@       , AutoProgress(..)       ) where -import Prelude hiding (null)+import Prelude hiding ((!!), null)  import Control.Monad          ( filterM, forM, guard, join, when ) import Control.Monad.Except@@ -54,6 +54,7 @@ import Agda.Utils.Functor import Agda.Utils.Impossible import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Null import Agda.Utils.Pretty ( prettyShow )@@ -196,7 +197,7 @@         let getsols :: [I.Term] -> TCM [(MetaId, A.Expr)]             getsols sol = do              exprs <- forM (zip (Map.keys tccons) sol) $ \ (mi, e) -> do-               mv   <- lookupMeta mi+               mv   <- lookupLocalMetaAuto mi                e    <- etaContract e                expr <- modifyAbstractExpr <$> do withMetaInfo (getMetaInfo mv) $ reify e                return (mi, expr)@@ -234,7 +235,7 @@                  else do                   aexprss <- mapM getsols rsols                   cexprss <- forM aexprss $ mapM $ \(mi, e) -> do-                    mv <- lookupMeta mi+                    mv <- lookupLocalMetaAuto mi                     withMetaInfo (getMetaInfo mv) $ do                       (mi,) <$> abstractToConcrete_ e                   let ss = dropWhile (== ' ') . dropWhile (/= ' ') . prettyShow@@ -290,7 +291,7 @@               -- cexprss <- mapM (mapM (\(mi, e) -> lookupMeta mi >>= \mv -> withMetaInfo (getMetaInfo mv) $ abstractToConcrete_ e >>= \e' -> return (mi, e'))) aexprss               cexprss <- forM aexprss $ do                 mapM $ \ (mi, e) -> do-                  mv <- lookupMeta mi+                  mv <- lookupLocalMetaAuto mi                   withMetaInfo (getMetaInfo mv) $ do                     e' <- abstractToConcrete_ e                     return (mi, e')@@ -337,7 +338,7 @@                            -- (const retry)                            -- (\_ -> return (Nothing, Just ("Failed to give expr for side solution of " ++ show mi)))                          Just ii' -> do ae <- give WithoutForce ii' Nothing expr-                                        mv <- lookupMeta mi+                                        mv <- lookupLocalMetaAuto mi                                         let scope = getMetaScope mv                                         ce <- abstractToConcreteScope scope ae                                         let cmnt = if ii' == ii then agsyinfo ticks else ""@@ -381,12 +382,12 @@             case cls' of              Left{} -> stopWithMsg "No solution found"              Right cls' -> do-              cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall exact recursive reachable ell) -> do+              cls'' <- forM cls' $ \ (I.Clause _ _ tel ps body t catchall exact recursive reachable ell wm) -> do                 withCurrentModule (AN.qnameModule def) $ do                  -- Normalise the dot patterns                  ps <- addContext tel $ normalise ps                  body <- etaContract body-                 fmap modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange noRange tel ps body t catchall exact recursive reachable ell+                 fmap modifyAbstractClause $ inTopContext $ reify $ AN.QNamed def $ I.Clause noRange noRange tel ps body t catchall exact recursive reachable ell wm               moduleTel <- lookupSection (AN.qnameModule def)               pcs <- withInteractionId ii $ inTopContext $ addContext moduleTel $ mapM prettyA cls''               ticks <- liftIO $ readIORef ticks@@ -400,7 +401,7 @@        _ -> stopWithMsg "Metavariable is not at top level of clause RHS"       MRefine listmode -> do-      mv <- lookupMeta mi+      mv <- lookupLocalMetaAuto mi       let tt = jMetaType $ mvJudgement mv           minfo = getMetaInfo mv       targettyp <- withMetaInfo minfo $ do@@ -421,13 +422,14 @@             cn <- withMetaInfo minfo $ runAbsToCon $ toConcrete n             if C.isInScope cn == C.NotInScope then               return Nothing-            else do-              c <- getConstInfo n-              ctyp <- normalise $ defType c-              cdfv <- withMetaInfo minfo $ getDefFreeVars n-              return $ case matchType cdfv tctx ctyp targettyp of-               Nothing -> Nothing-               Just score -> Just (prettyShow cn, score)+            else getConstInfo' n >>= \case+              Left{} -> return Nothing+              Right c -> do+                ctyp <- normalise $ defType c+                cdfv <- withMetaInfo minfo $ getDefFreeVars n+                return $ case matchType cdfv tctx ctyp targettyp of+                  Nothing -> Nothing+                  Just score -> Just (prettyShow cn, score)          ) alldefs        else do         let scopeinfo = clScope (getMetaInfo mv)@@ -437,13 +439,14 @@             modnames = case thisdefinfo of                         Just (def, _, _) -> filter (\(_, n) -> n /= def) qnames                         Nothing -> qnames-        catMaybes <$> mapM (\(cn, n) -> do-          c <- getConstInfo n-          ctyp <- normalise $ defType c-          cdfv <- withMetaInfo minfo $ getDefFreeVars n-          return $ case matchType cdfv tctx ctyp targettyp of-           Nothing -> Nothing-           Just score -> Just (prettyShow cn, score)+        catMaybes <$> mapM (\(cn, n) -> getConstInfo' n >>= \case+          Left{} -> return Nothing+          Right c -> do+            ctyp <- normalise $ defType c+            cdfv <- withMetaInfo minfo $ getDefFreeVars n+            return $ case matchType cdfv tctx ctyp targettyp of+              Nothing -> Nothing+              Just score -> Just (prettyShow cn, score)          ) modnames        let sorthits = List.sortBy (\(_, (pa1, pb1)) (_, (pa2, pb2)) -> case compare pa2 pa1 of {EQ -> compare pb1 pb2; o -> o}) hits@@ -466,14 +469,14 @@ -- Get the functions and axioms defined in the same module as @def@. autohints :: AutoHintMode -> I.MetaId -> Maybe AN.QName -> TCM [Hint] autohints AHMModule mi (Just def) = do-  scope <- clScope . getMetaInfo <$> lookupMeta mi+  scope <- clScope . getMetaInfo <$> lookupLocalMetaAuto mi   let names     = Scope.nsNames $ Scope.everythingInScope scope       qnames    = map (Scope.anameName . head) $ Map.elems names       modnames  = filter (\n -> AN.qnameModule n == AN.qnameModule def && n /= def) qnames   map (Hint False) <$> do-    (`filterM` modnames) $ \ n -> do-      c <- getConstInfo n-      case theDef c of+    (`filterM` modnames) $ \ n -> getConstInfo' n >>= \case+      Left{} -> return False+      Right c -> case theDef c of         Axiom{}    -> return True         AbstractDefn{} -> return True         Function{} -> return True
src/full/Agda/Auto/CaseSplit.hs view
@@ -1,12 +1,14 @@  module Agda.Auto.CaseSplit where +import Prelude hiding ((!!))+ import Control.Monad.State as St hiding (lift) import Control.Monad.Reader as Rd hiding (lift) import qualified Control.Monad.State as St import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Function+import Data.Function (on) import Data.IORef import Data.Tuple (swap) import Data.List (elemIndex)@@ -24,7 +26,7 @@  import Agda.Utils.Impossible import Agda.Utils.Monad (or2M)-import Agda.Utils.List (last1)+import Agda.Utils.List ((!!), last1)  abspatvarname :: String abspatvarname = "\0absurdPattern"@@ -45,6 +47,7 @@ type CSCtx o = [HI (MId, MExp o)]  data CSPatI o = CSPatConApp (ConstRef o) [CSPat o]+              | CSPatProj (ConstRef o)               | CSPatVar Nat               | CSPatExp (MExp o)               | CSWith (MExp o) -- always an App
src/full/Agda/Auto/Convert.hs view
@@ -1,6 +1,8 @@  module Agda.Auto.Convert where +import Prelude hiding ((!!))+ import Control.Monad          ( when ) import Control.Monad.Except import Control.Monad.IO.Class ( MonadIO(..) )@@ -27,7 +29,8 @@ import Agda.TypeChecking.Monad.Signature (getConstInfo, getDefFreeVars, ignoreAbstractMode) import Agda.TypeChecking.Level (reallyUnLevelView) import Agda.TypeChecking.Monad.Base (mvJudgement, mvPermutation, getMetaInfo, envContext, clEnv)-import Agda.TypeChecking.Monad.MetaVars (lookupMeta, withMetaInfo, lookupInteractionPoint)+import Agda.TypeChecking.Monad.MetaVars+  (lookupMeta, withMetaInfo, lookupInteractionPoint) import Agda.TypeChecking.Monad.Context (getContextArgs) import Agda.TypeChecking.Monad.Constraints (getAllConstraints) import Agda.TypeChecking.Substitute (applySubst, renamingR)@@ -47,6 +50,7 @@  import Agda.Utils.Either import Agda.Utils.Lens+import Agda.Utils.List import Agda.Utils.Monad       ( forMaybeMM ) import Agda.Utils.Permutation ( Permutation(Perm), permute, takeP, compactP ) import Agda.Utils.Pretty      ( prettyShow )@@ -162,7 +166,7 @@           when (Map.notMember eqi eqsm) $ do            modify $ \s -> s {sEqs = (Map.insert eqi Nothing eqsm, eqi : eqsl)}         ) (zip eqs [0..])-       mv <- lift $ lookupMeta mi+       mv <- lift $ lookupLocalMetaAuto mi        msol <- case MB.mvInstantiation mv of                      MB.InstV{} ->                       lift $ withMetaInfo (getMetaInfo mv) $ do@@ -264,9 +268,23 @@  getdfv :: I.MetaId -> A.QName -> MB.TCM Cm.Nat getdfv mainm name = do- mv <- lookupMeta mainm+ mv <- lookupLocalMetaAuto mainm  withMetaInfo (getMetaInfo mv) $ getDefFreeVars name +-- | A variant of 'lookupLocalMeta' that, if applied to a remote+-- meta-variable, raises a special error message noting that remote+-- meta-variables are not handled by the auto command.++lookupLocalMetaAuto :: I.MetaId -> MB.TCM MB.MetaVariable+lookupLocalMetaAuto m = do+  mv <- lookupMeta m+  case mv of+    Just (Right mv) -> return mv+    Nothing         -> __IMPOSSIBLE__+    Just Left{}     -> MB.typeError $ MB.GenericError $+      "The auto command does not support remote meta-variables," +++      "consider using --no-save-metas"+ getMeta :: I.MetaId -> TOM (Metavar (Exp O) (RefInfo O)) getMeta name = do  mmap <- gets (fst . sMetas)@@ -288,10 +306,6 @@       return $ Just (tomyIneq ineq, ee, ei)     _ -> return Nothing -copatternsNotImplemented :: MB.TCM a-copatternsNotImplemented = MB.typeError $ MB.NotImplemented $-  "The Agda synthesizer (Agsy) does not support copatterns yet"- literalsNotImplemented :: MB.TCM a literalsNotImplemented = MB.typeError $ MB.NotImplemented $   "The Agda synthesizer (Agsy) does not support literals yet"@@ -336,9 +350,9 @@       cc    <- lift $ liftIO $ readIORef c       let Just (npar,_) = fst $ cdorigin cc       return $ PatConApp c (replicate npar PatExp ++ pats')+    I.ProjP _ q -> PatProj <$> getConst True q TMAll      -- UNSUPPORTED CASES-    I.ProjP{}   -> lift copatternsNotImplemented     I.LitP{}    -> lift literalsNotImplemented     I.DefP{}    -> lift hitsNotImplemented @@ -581,7 +595,10 @@        I.DotP _ t -> do         (t2, _) <- runStateT (convert t) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm})         return (ns, HI hid (CSPatExp t2))-       I.ProjP{} -> copatternsNotImplemented+       I.ProjP po c -> do+        (c2, _) <- runStateT (getConst True c TMAll) (S {sConsts = (cmap, []), sMetas = initMapS, sEqs = initMapS, sCurMeta = Nothing, sMainMeta = mainm})+        cc <- liftIO $ readIORef c2+        return (ns, HI hid (CSPatProj c2))        I.LitP{} -> literalsNotImplemented        I.DefP{} -> hitsNotImplemented @@ -651,18 +668,19 @@           Nothing -> return $ Nothing           Just e -> Just <$> convert e  let cperm =  Perm nv perm- return $ I.Clause+ return I.Clause    { I.clauseLHSRange  = SP.noRange    , I.clauseFullRange = SP.noRange    , I.clauseTel       = tel    , I.namedClausePats = IP.numberPatVars __IMPOSSIBLE__ cperm $ applySubst (renamingR $ compactP cperm) ps-   , I.clauseBody  = body-   , I.clauseType  = Nothing -- TODO: compute clause type-   , I.clauseCatchall = False+   , I.clauseBody      = body+   , I.clauseType      = Nothing -- TODO: compute clause type+   , I.clauseCatchall    = False    , I.clauseExact       = Nothing -- TODO    , I.clauseRecursive   = Nothing -- TODO: Don't know here whether recursive or not !?    , I.clauseUnreachable = Nothing -- TODO: Don't know here whether reachable or not !?-   , I.clauseEllipsis = Cm.NoEllipsis+   , I.clauseEllipsis    = Cm.NoEllipsis+   , I.clauseWhereModule = Nothing    }  contains_constructor :: [CSPat O] -> Bool
src/full/Agda/Auto/Syntax.hs view
@@ -112,10 +112,8 @@   | PatVar String   | PatExp     -- ^ Dot pattern.-{- TODO: projection patterns.   | PatProj (ConstRef o)     -- ^ Projection pattern.--}  type ConstRef o = IORef (ConstDef o)
src/full/Agda/Auto/Typecheck.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE NondecreasingIndentation #-}  module Agda.Auto.Typecheck where +import Prelude hiding ((!!))+ import Data.IORef  import Agda.Syntax.Common (Hiding (..))@@ -9,6 +12,8 @@ import Agda.Auto.SearchControl  import Agda.Utils.Impossible+import Agda.Utils.List+import Agda.Utils.Maybe  -- --------------------------------- @@ -16,20 +21,23 @@ tcExp :: Bool -> Ctx o -> CExp o -> MExp o -> EE (MyPB o) tcExp isdep ctx typ@(TrBr typtrs ityp@(Clos _ itypexp)) trm =   mbpcase prioTypeUnknown Nothing (hnn_checkstep ityp) $ \(hntyp, iotastepdone) ->-  mmpcase (True, prioTypecheck isdep, Just (RIMainInfo (length ctx) hntyp iotastepdone)) trm $ \trm -> case trm of+  mmpcase (True, prioTypecheck isdep, Just (RIMainInfo (length ctx) hntyp iotastepdone)) trm $ \case    App _ okh elr args -> case rawValue hntyp of     HNPi{} | isdep -> mpret $ Error "tcExp, dep terms should be eta-long"     _ -> do-     (ityp, sc) <- case elr of-              Var v -> -- assuming within scope-               return (weak (v + 1) (snd $ ctx !! v), id)+     res <- case elr of+              Var v ->+                case ctx !!! v of+                  Nothing     -> return Nothing+                  Just (_, a) -> return $ Just (weak (v+1) a, id)               Const c -> do                cdef <- readIORef c-               return (closify (cdtype cdef), \x -> mpret $ And (Just [Term args]) (noiotastep_term c args) x)+               return $ Just (closify (cdtype cdef), mpret . And (Just [Term args]) (noiotastep_term c args))+     caseMaybe res (mpret $ Error "tcExp, variable not in scope") $ \ (ityp, sc) -> do       ndfv <- case elr of               Var{} -> return 0-              Const c -> readIORef c >>= \cd -> return (cddeffreevars cd)+              Const c -> cddeffreevars <$> readIORef c        isconstructor <- case elr of@@ -408,6 +416,25 @@       mbfailed "dopat: wrong amount of args"     else      mbret $ Left (Left aa)+ dopat (PatProj cs) a =+  case a of+   PENo a ->+    if smartcheck then+     mbcase (meta_not_constructor a) $ \notcon -> if notcon then mbret $ Left $ Right noblks else qq -- to know more often if iota step is possible+    else+     qq+    where+     qq =+      mbcase (hnn_blks a) $ \(hna, blks) -> case rawValue hna of+       HNApp (Const c') as ->+        do+         cd <- readIORef c'+         case cdcont cd of+          Constructor{} -> mbcase (getAllArgs as) $ \as' ->+           mbret $ Left (Left (PEConApp a c' (map PENo as')))+          _ -> mbret $ Left (Right (addblk hna blks))+       _ -> mbret $ Left (Right (addblk hna blks))+   aa@(PEConApp a c' as) -> mbret $ Left (Left aa)  dopat PatVar{} a@(PENo a') = mbret $ Right (a, [a'])  dopat PatVar{} a@(PEConApp a' _ _) = mbret $ Right (a, [a'])  dopat PatExp a = mbret $ Right (a, [])
src/full/Agda/Benchmarking.hs view
@@ -13,9 +13,9 @@  import System.IO.Unsafe -import Agda.Syntax.Concrete.Name (TopLevelModuleName) import Agda.Syntax.Concrete.Pretty () --instance only import Agda.Syntax.Abstract.Name+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.Benchmark (MonadBench(..)) import qualified Agda.Utils.Benchmark as B import Agda.Utils.Null
src/full/Agda/Compiler/Backend.hs view
@@ -36,6 +36,7 @@  import System.Console.GetOpt +import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Treeless import Agda.TypeChecking.Errors (getAllWarnings) -- Agda.TypeChecking.Monad.Base imports us, relying on the .hs-boot file to@@ -83,15 +84,18 @@       --   vanilla Agda behaviour.   , preCompile       :: opts -> TCM env       -- ^ Called after type checking completes, but before compilation starts.-  , postCompile      :: env -> IsMain -> Map ModuleName mod -> TCM ()+  , postCompile      :: env -> IsMain -> Map TopLevelModuleName mod ->+                        TCM ()       -- ^ Called after module compilation has completed. The @IsMain@ argument       --   is @NotMain@ if the @--no-main@ flag is present.-  , preModule        :: env -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile menv mod)+  , preModule        :: env -> IsMain -> TopLevelModuleName ->+                        Maybe FilePath -> TCM (Recompile menv mod)       -- ^ Called before compilation of each module. Gets the path to the       --   @.agdai@ file to allow up-to-date checking of previously written       --   compilation results. Should return @Skip m@ if compilation is not       --   required. Will be @Nothing@ if only scope checking.-  , postModule       :: env -> menv -> IsMain -> ModuleName -> [def] -> TCM mod+  , postModule       :: env -> menv -> IsMain -> TopLevelModuleName ->+                        [def] -> TCM mod       -- ^ Called after all definitions of a module have been compiled.   , compileDef       :: env -> menv -> IsMain -> Definition -> TCM def       -- ^ Compile a single definition.@@ -202,7 +206,7 @@       (backends, opts) <- getOptSimple (stripRTS argv)                                        (agdaFlags ++ backendFlags) (embedFlag lSnd . inputFlag)                                        (bs, opts0)-      opts <- checkOpts opts+      () <- checkOpts opts       return (forgetAll forgetOpts backends, opts)  backendInteraction :: AbsolutePath -> [Backend] -> TCM () -> (AbsolutePath -> TCM CheckResult) -> TCM ()@@ -254,7 +258,9 @@     mods <- doCompile         -- This inner function is called for both `Agda.Primitive` and the module in question,         -- and all (distinct) imported modules. So avoid shadowing "isMain" or "i".-        (\ifaceIsMain iface -> Map.singleton (iModuleName iface) <$> compileModule backend env ifaceIsMain iface)+        (\ifaceIsMain iface ->+          Map.singleton (iTopLevelModuleName iface) <$>+          compileModule backend env ifaceIsMain iface)         isMain i     -- Note that `doCompile` calls `setInterface` for each distinct module in the graph prior to calling into     -- `compileModule`. This last one is just to ensure it's reset to _this_ module.@@ -263,19 +269,19 @@  compileModule :: Backend' opts env menv mod def -> env -> IsMain -> Interface -> TCM mod compileModule backend env isMain i = do-  mName <- toTopLevelModuleName <$> curMName+  mName <- curMName   -- The interface file will only exist if performing af full type-check, vs scoping.   -- FIXME: Expecting backends to read the timestamp of the output path of the interface   --        file for dirtiness checking is very roundabout and heavily couples backend   --        implementations to the filesystem as the source of cache state.   mifile <- (Just . filePath . intFilePath =<<) <$> findInterfaceFile mName-  r      <- preModule backend env isMain (iModuleName i) mifile+  r      <- preModule backend env isMain (iTopLevelModuleName i) mifile   case r of     Skip m         -> return m     Recompile menv -> do       defs <- map snd . sortDefs <$> curDefs       res  <- mapM (compileDef' backend env menv isMain <=< instantiateFull) defs-      postModule backend env menv isMain (iModuleName i) res+      postModule backend env menv isMain (iTopLevelModuleName i) res  compileDef' :: Backend' opts env menv mod def -> env -> menv -> IsMain -> Definition -> TCM def compileDef' backend env menv isMain def =
src/full/Agda/Compiler/CallCompiler.hs view
@@ -32,13 +32,16 @@      -- ^ The path to the compiler   -> [String]      -- ^ Command-line arguments.+  -> Maybe FilePath+     -- ^ The working directory that should be used when the compiler+     -- is invoked. The default is the current working directory.   -> Maybe TextEncoding      -- ^ Use the given text encoding, if any, when reading the output      -- from the process (stdout and stderr).   -> TCM ()-callCompiler doCall cmd args enc =+callCompiler doCall cmd args cwd enc =   if doCall then do-    merrors <- callCompiler' cmd args enc+    merrors <- callCompiler' cmd args cwd enc     case merrors of       Nothing     -> return ()       Just errors -> typeError (CompilationError errors)@@ -52,16 +55,20 @@      -- ^ The path to the compiler   -> [String]      -- ^ Command-line arguments.+  -> Maybe FilePath+     -- ^ The working directory that should be used when the compiler+     -- is invoked. The default is the current working directory.   -> Maybe TextEncoding      -- ^ Use the given text encoding, if any, when reading the output      -- from the process (stdout and stderr).   -> TCM (Maybe String)-callCompiler' cmd args enc = do+callCompiler' cmd args cwd enc = do   reportSLn "compile.cmd" 1 $ "Calling: " ++ unwords (cmd : args)   (_, out, err, p) <-     liftIO $ createProcess                (proc cmd args) { std_err = CreatePipe                                , std_out = CreatePipe+                               , cwd     = cwd                                }    -- In -v0 mode we throw away any progress information printed to
src/full/Agda/Compiler/Common.hs view
@@ -2,13 +2,16 @@  module Agda.Compiler.Common where -import Data.List as List+import Prelude hiding ((!!))++import Data.List (sortBy, isPrefixOf) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap+import qualified Data.HashSet as HSet import Data.Char-import Data.Function+import Data.Function (on) #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif@@ -19,16 +22,20 @@ import Agda.Syntax.Common import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Internal as I+import Agda.Syntax.TopLevelModuleName  import Agda.Interaction.FindFile ( srcFilePath ) import Agda.Interaction.Options-import Agda.Interaction.Imports ( CheckResult, crInterface, crSource, Source(..) )+import Agda.Interaction.Imports  ( CheckResult, crInterface, crSource, Source(..) ) -import Agda.TypeChecking.Monad+import Agda.TypeChecking.Monad as TCM  import Agda.Utils.FileName import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.List1          ( pattern (:|) ) import Agda.Utils.Maybe+import Agda.Utils.Monad          ( ifNotM ) import Agda.Utils.Pretty  import Agda.Utils.Impossible@@ -48,13 +55,24 @@  doCompile :: Monoid r => (IsMain -> Interface -> TCM r) -> IsMain -> Interface -> TCM r doCompile f isMain i = do-  -- The Agda.Primitive module is implicitly assumed to be always imported,-  -- even though it not necesseraly occurs in iImportedModules.-  -- TODO: there should be a better way to get hold of Agda.Primitive?-  [agdaPrimInter] <- filter (("Agda.Primitive"==) . prettyShow . iModuleName)-    . map miInterface . Map.elems-      <$> getVisitedModules-  flip evalStateT Set.empty $ mappend <$> doCompile' f NotMain agdaPrimInter <*> doCompile' f isMain i+  flip evalStateT Set.empty $ compilePrim $ doCompile' f isMain i+  where+  -- The Agda.Primitive module is only loaded if the --no-load-primitives flag was not given,+  -- thus, only try to compile it if we have visited it.+  compilePrim cont = do+    agdaPrim <- lift $ do+      agdaPrim <- TCM.topLevelModuleName agdaPrim+      Map.lookup agdaPrim <$> getVisitedModules+    case agdaPrim of+      Nothing   -> cont+      Just prim ->+        mappend <$> doCompile' f NotMain (miInterface prim) <*> cont+    where+    agdaPrim = RawTopLevelModuleName+      { rawModuleNameRange = mempty+      , rawModuleNameParts = "Agda" :| "Primitive" : []+      }+      -- N.B. The Range in TopLevelModuleName is ignored for Ord, so we can set it to mempty.  -- This helper function is called for both `Agda.Primitive` and the module in question. -- It's also called for each imported module, recursively. (Avoiding duplicates).@@ -66,7 +84,7 @@   if alreadyDone then return mempty else do     imps <- lift $       map miInterface . catMaybes <$>-        mapM (getVisitedModule . toTopLevelModuleName . fst) (iImportedModules i)+        mapM (getVisitedModule . fst) (iImportedModules i)     ri <- mconcat <$> mapM (doCompile' f NotMain) imps     lift $ setInterface i     r <- lift $ f isMain i@@ -78,16 +96,21 @@   opts <- getsTC (stPersistentOptions . stPersistentState)   setCommandLineOptions opts   mapM_ setOptionsFromPragma (iDefaultPragmaOptions i ++ iFilePragmaOptions i)-  stImportedModules `setTCLens` Set.fromList (map fst $ iImportedModules i)-  stCurrentModule   `setTCLens` Just (iModuleName i)+  -- One could perhaps make the following command lazy. Note, however,+  -- that it doesn't suffice to replace setTCLens' with setTCLens,+  -- because the stPreImportedModules field is strict.+  stImportedModules `setTCLens'`+    HSet.fromList (map fst (iImportedModules i))+  stCurrentModule `setTCLens'`+    Just (iModuleName i, iTopLevelModuleName i)  curIF :: ReadTCState m => m Interface curIF = do   name <- curMName-  maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule (toTopLevelModuleName name)+  maybe __IMPOSSIBLE__ miInterface <$> getVisitedModule name -curMName :: ReadTCState m => m ModuleName-curMName = fromMaybe __IMPOSSIBLE__ <$> useTC stCurrentModule+curMName :: ReadTCState m => m TopLevelModuleName+curMName = maybe __IMPOSSIBLE__ snd <$> useTC stCurrentModule  curDefs :: ReadTCState m => m Definitions curDefs = HMap.filter (not . defNoCompilation) . (^. sigDefinitions) . iSignature <$> curIF@@ -97,7 +120,7 @@   -- The list is sorted to ensure that the order of the generated   -- definitions does not depend on things like the number of bits   -- in an Int (see Issue 1900).-  List.sortBy (compare `on` fst) $+  sortBy (compare `on` fst) $   HMap.toList defs  compileDir :: HasOptions m => m FilePath@@ -135,9 +158,9 @@           Just dir -> dir           Nothing  ->             -- The default output directory is the project root.-            let tm = toTopLevelModuleName $ iModuleName mainI+            let tm = iTopLevelModuleName mainI                 f  = srcFilePath $ srcOrigin checkedSource-            in filePath $ C.projectRoot f tm+            in filePath $ projectRoot f tm     setCommandLineOptions $       opts { optCompileDir = Just compileDir } @@ -163,16 +186,18 @@   stTCWarnings `setTCLens` newWarnings   return a -topLevelModuleName :: ReadTCState m => ModuleName -> m ModuleName+topLevelModuleName ::+  ReadTCState m => ModuleName -> m TopLevelModuleName topLevelModuleName m = do-  -- get the names of the visited modules-  visited <- List.map (iModuleName . miInterface) . Map.elems <$>-    getVisitedModules+  -- Interfaces of visited modules.+  visited <- map miInterface . Map.elems <$> getVisitedModules   -- find the module with the longest matching prefix to m-  let ms = sortBy (compare `on` (length . mnameToList)) $-       List.filter (\ m' -> mnameToList m' `isPrefixOf` mnameToList m) visited-  case ms of-    (m' : _) -> return m'+  let is = sortBy (compare `on` (length . mnameToList . iModuleName)) $+           filter (\i -> mnameToList (iModuleName i) `isPrefixOf`+                         mnameToList m)+             visited+  case is of+    (i : _) -> return (iTopLevelModuleName i)     -- if we did not get anything, it may be because m is a section     -- (a module _ ), see e.g. #1866     []       -> curMName
src/full/Agda/Compiler/JS/Compiler.hs view
@@ -9,7 +9,7 @@  import Data.Char     ( isSpace ) import Data.Foldable ( forM_ )-import Data.List     ( dropWhileEnd, findIndex, intercalate, partition )+import Data.List     ( dropWhileEnd, elemIndex, intercalate, partition ) import Data.Set      ( Set )  import qualified Data.Set as Set@@ -30,12 +30,13 @@ import Agda.Syntax.Common import Agda.Syntax.Concrete.Name ( isNoName ) import Agda.Syntax.Abstract.Name-  ( ModuleName, QName,+  ( QName,     mnameToList, qnameName, qnameModule, nameId ) import Agda.Syntax.Internal   ( Name, Type   , nameFixity, unDom, telToList ) import Agda.Syntax.Literal       ( Literal(..) )+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName(..)) import Agda.Syntax.Treeless      ( ArgUsage(..), filterUsed ) import qualified Agda.Syntax.Treeless as T @@ -58,8 +59,9 @@ import Agda.Utils.IO.Directory import Agda.Utils.IO.UTF8 ( writeFile ) import Agda.Utils.Singleton ( singleton )+import Agda.Utils.Size (size) -import Agda.Compiler.Common+import Agda.Compiler.Common as CC import Agda.Compiler.ToTreeless import Agda.Compiler.Treeless.EliminateDefaults import Agda.Compiler.Treeless.EliminateLiteralPatterns@@ -154,14 +156,15 @@           "Compilation of code that uses " ++ s ++ " is not supported."   case cubical of     Nothing      -> return ()-    Just CErased -> return ()+    Just CErased -> notSupported "--erased-cubical"     Just CFull   -> notSupported "--cubical"    return opts  -- | After all modules have been compiled, copy RTE modules and verify compiled modules. -jsPostCompile :: JSOptions -> IsMain -> Map.Map ModuleName Module -> TCM ()+jsPostCompile ::+  JSOptions -> IsMain -> Map.Map TopLevelModuleName Module -> TCM () jsPostCompile opts _ ms = do    -- Copy RTE modules.@@ -193,14 +196,6 @@         reportSLn "compile.js.verify" 20 $ unwords [ "calling:", cmd ]         liftIO $ callCommand cmd --mergeModules :: Map.Map ModuleName Module -> [(GlobalId, Export)]-mergeModules ms-    = [ (jsMod n, e)-      | (n, Module _ _ es _) <- Map.toList ms-      , e <- es-      ]- --- Module compilation ---  data JSModuleEnv = JSModuleEnv@@ -209,7 +204,9 @@     -- ^ Should this module be compiled?   } -jsPreModule :: JSOptions -> IsMain -> ModuleName -> Maybe FilePath -> TCM (Recompile JSModuleEnv Module)+jsPreModule ::+  JSOptions -> IsMain -> TopLevelModuleName -> Maybe FilePath ->+  TCM (Recompile JSModuleEnv Module) jsPreModule _opts _ m mifile = do   cubical <- optCubical <$> pragmaOptions   let compile = case cubical of@@ -241,10 +238,12 @@         , jsCompile        = compile         } -jsPostModule :: JSOptions -> JSModuleEnv -> IsMain -> ModuleName -> [Maybe Export] -> TCM Module+jsPostModule ::+  JSOptions -> JSModuleEnv -> IsMain -> TopLevelModuleName ->+  [Maybe Export] -> TCM Module jsPostModule opts _ isMain _ defs = do-  m             <- jsMod <$> curMName-  is            <- map (jsMod . fst) . iImportedModules <$> curIF+  m  <- jsMod <$> curMName+  is <- map (jsMod . fst) . iImportedModules <$> curIF   let mod = Module m is (reorder es) callMain   writeModule (optJSMinify opts) mod   return mod@@ -269,8 +268,9 @@ prefix :: [Char] prefix = "jAgda" -jsMod :: ModuleName -> GlobalId-jsMod m = GlobalId (prefix : map prettyShow (mnameToList m))+jsMod :: TopLevelModuleName -> GlobalId+jsMod m =+  GlobalId (prefix : map T.unpack (List1.toList (moduleNameParts m)))  jsFileName :: GlobalId -> String jsFileName (GlobalId ms) = intercalate "." ms ++ ".js"@@ -285,17 +285,17 @@  global' :: QName -> TCM (Exp, JSQName) global' q = do-  i <- iModuleName <$> curIF-  modNm <- topLevelModuleName (qnameModule q)+  i   <- iTopLevelModuleName <$> curIF+  top <- CC.topLevelModuleName (qnameModule q)   let     -- Global module prefix     qms = mnameToList $ qnameModule q     -- File-local module prefix-    localms = drop (length $ mnameToList modNm) qms+    localms = drop (size top) qms     nm = fmap jsMember $ List1.snoc localms $ qnameName q-  if modNm == i+  if top == i     then return (Self, nm)-    else return (Global (jsMod modNm), nm)+    else return (Global (jsMod top), nm)  global :: QName -> TCM (Exp, JSQName) global q = do@@ -494,7 +494,7 @@               , optJSOptimize (fst kit) = do                   q  <- canonicalName q                   cs <- mapM canonicalName $ defConstructors dt-                  case findIndex (q ==) cs of+                  case q `elemIndex` cs of                     Just i  -> return $ MemberIndex i (mkComment l)                     Nothing -> __IMPOSSIBLE_VERBOSE__ $ unwords [ "Constructor", prettyShow q, "not found in", prettyShow cs ]               | otherwise = return l@@ -668,7 +668,7 @@   (LitString x) -> String  x   (LitChar   x) -> Char    x   (LitQName  x) -> litqname x-  LitMeta{}     -> __IMPOSSIBLE__+  (LitMeta _ m) -> litmeta m  litqname :: QName -> Exp litqname q =@@ -695,6 +695,13 @@     litPrec Unrelated   = String "unrelated"     litPrec (Related l) = Double l +litmeta :: MetaId -> Exp+litmeta (MetaId m h) =+  Object $ Map.fromListWith __IMPOSSIBLE__+    [ (MemberId "id", Integer $ fromIntegral m)+    , (MemberId "module", Integer $ fromIntegral $ moduleNameHash h) ]++ -------------------------------------------------- -- Writing out an ECMAScript module --------------------------------------------------@@ -832,10 +839,10 @@   , "primQNameFixity"   -- , "primQNameToWord64s"          -- missing   -- , "primQNameToWord64sInjective" -- missing-  -- , "primMetaEquality"            -- missing-  -- , "primMetaLess"                -- missing-  -- , "primShowMeta"                -- missing-  -- , "primMetaToNat"               -- missing+  , "primMetaEquality"+  , "primMetaLess"+  , "primShowMeta"+  , "primMetaToNat"   -- , "primMetaToNatInjective"      -- missing   , builtinIMin   , builtinIMax@@ -853,8 +860,8 @@   , "primDepIMin"   , "primIdFace"   , "primIdPath"-  , "primIdJ"   , builtinIdElim+  , builtinConId   -- , builtinGlue                   -- missing   -- , builtin_glue                  -- missing   -- , builtin_unglue                -- missing
src/full/Agda/Compiler/MAlonzo/Compiler.hs view
@@ -54,6 +54,7 @@ import Agda.Syntax.Internal.Names (namesIn) import qualified Agda.Syntax.Treeless as T import Agda.Syntax.Literal+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Primitive (getBuiltinName)@@ -70,6 +71,7 @@ import Agda.Utils.IO.Directory import Agda.Utils.Lens import Agda.Utils.List+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty (prettyShow, render)@@ -192,7 +194,7 @@   , ghcDefDecls      :: [HS.Decl]   , ghcDefDefinition :: Definition   , ghcDefMainDef    :: Maybe MainFunctionDef-  , ghcDefImports    :: Set ModuleName+  , ghcDefImports    :: Set TopLevelModuleName   }  --- Top-level compilation ---@@ -245,7 +247,7 @@   msub        <- getBuiltinName builtinSub   msubin      <- getBuiltinName builtinSubIn   mid         <- getBuiltinName builtinId-  mconid      <- getBuiltinName builtinConId+  mconid      <- getPrimitiveName' builtinConId    istcbuiltin <- do     builtins <- mapM getBuiltinName@@ -267,6 +269,8 @@       , builtinAgdaTCMFreshName       , builtinAgdaTCMDeclareDef       , builtinAgdaTCMDeclarePostulate+      , builtinAgdaTCMDeclareData+      , builtinAgdaTCMDefineData       , builtinAgdaTCMDefineFun       , builtinAgdaTCMGetType       , builtinAgdaTCMGetDefinition@@ -275,12 +279,14 @@       , builtinAgdaTCMIsMacro       , builtinAgdaTCMWithNormalisation       , builtinAgdaTCMWithReconsParams+      , builtinAgdaTCMFormatErrorParts       , builtinAgdaTCMDebugPrint       , builtinAgdaTCMOnlyReduceDefs       , builtinAgdaTCMDontReduceDefs       , builtinAgdaTCMNoConstraints       , builtinAgdaTCMRunSpeculative       , builtinAgdaTCMExec+      , builtinAgdaTCMGetInstances       ]     return $       flip HashSet.member $@@ -320,7 +326,8 @@     , ghcEnvIsTCBuiltin = istcbuiltin     } -ghcPostCompile :: GHCEnv -> IsMain -> Map ModuleName GHCModule -> TCM ()+ghcPostCompile ::+  GHCEnv -> IsMain -> Map TopLevelModuleName GHCModule -> TCM () ghcPostCompile _cenv _isMain mods = do   -- FIXME: @curMName@ and @curIF@ are evil TCM state, but there does not appear to be   --------- another way to retrieve the compilation root ("main" module or interaction focused).@@ -336,7 +343,7 @@ ghcPreModule   :: GHCEnv   -> IsMain      -- ^ Are we looking at the main module?-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath    -- ^ Path to the @.agdai@ file.   -> TCM (Recompile GHCModuleEnv GHCModule)                  -- ^ Could we confirm the existence of a main function?@@ -356,7 +363,8 @@     ifileDesc = fromMaybe "(memory)" mifile      noComp = do-      reportSLn "compile.ghc" 2 . (++ " : no compilation is needed.") . prettyShow . A.mnameToConcrete =<< curMName+      reportSLn "compile.ghc" 2 .+        (++ " : no compilation is needed.") . prettyShow =<< curMName       menv <- ask       mainDefs <- ifM curIsMainModule                          (mainFunctionDefs <$> curIF)@@ -364,7 +372,7 @@       return . Skip $ GHCModule menv mainDefs      yesComp = do-      m   <- prettyShow . A.mnameToConcrete <$> curMName+      m   <- prettyShow <$> curMName       out <- curOutFile       reportSLn "compile.ghc" 1 $ repl [m, ifileDesc, out] "Compiling <<0>> in <<1>> to <<2>>"       asks Recompile@@ -373,7 +381,7 @@   :: GHCEnv   -> GHCModuleEnv   -> IsMain        -- ^ Are we looking at the main module?-  -> ModuleName+  -> TopLevelModuleName   -> [GHCDefinition]   -- ^ Compiled module content.   -> TCM GHCModule ghcPostModule _cenv menv _isMain _moduleName ghcDefs = do@@ -421,7 +429,9 @@  -- Compilation ------------------------------------------------------------ -imports :: BuiltinThings PrimFun -> Set ModuleName -> [Definition] -> [HS.ImportDecl]+imports ::+  BuiltinThings PrimFun -> Set TopLevelModuleName -> [Definition] ->+  [HS.ImportDecl] imports builtinThings usedModules defs = hsImps ++ imps where   hsImps :: [HS.ImportDecl]   hsImps = [unqualRTE, decl mazRTE]@@ -442,7 +452,7 @@   decl :: HS.ModuleName -> HS.ImportDecl   decl m = HS.ImportDecl m True Nothing -  mnames :: [ModuleName]+  mnames :: [TopLevelModuleName]   mnames = Set.elems usedModules    uniq :: [HS.ModuleName] -> [HS.ModuleName]@@ -657,13 +667,14 @@        -- Id x y is compiled as a pair of a boolean and whatever       -- Path x y is compiled to.-      Axiom{} | is ghcEnvId -> do+      Datatype{} | is ghcEnvId -> do         _        <- sequence_ [primInterval]         Just int <- getBuiltinName builtinInterval         int      <- xhqn TypeK int+        -- re  #3733: implement reflId         retDecls $           [ HS.TypeDecl (unqhname TypeK q)-              [HS.UnkindedVar (ihname A i) | i <- [0..3]]+              [] -- [HS.UnkindedVar (ihname A i) | i <- [0..3]]               (HS.TyApp (HS.FakeType "(,) Bool")                  (HS.TyFun (HS.TyCon int) mazAnyType))           , HS.FunBind@@ -673,7 +684,7 @@           ]        -- conid.-      Axiom{} | is ghcEnvConId -> do+      Primitive{} | is ghcEnvConId -> do         strict <- optGhcStrictData <$> askGhcOpts         let var = (if strict then HS.PBangPat else id) . HS.PVar         retDecls $@@ -705,7 +716,7 @@                    fb axiomErr       Primitive{ primName = s } -> (mempty,) . fb <$> (liftTCM . primBody) s -      PrimitiveSort{ primName = s } -> retDecls []+      PrimitiveSort{} -> retDecls []        Function{} -> function pragma $ functionViaTreeless q @@ -787,7 +798,7 @@       def <- getConstInfo q       (argTypes0, resType) <- hsTelApproximation $ defType def       let pars = case theDef def of-                   Function{ funProjection = Just Projection{ projIndex = i } } | i > 0 -> i - 1+                   Function{ funProjection = Right Projection{ projIndex = i } } | i > 0 -> i - 1                    _ -> 0           argTypes  = drop pars argTypes0           argTypesS = filterUsed used argTypes@@ -1040,6 +1051,7 @@                       (HS.GuardedRhss [HS.GuardedRhs [HS.Qualifier g] b])                       emptyBinds     T.TALit { T.aLit = LitQName q } -> mkAlt (litqnamepat q)+    T.TALit { T.aLit = LitMeta _ m } -> mkAlt (litmetapat m)     T.TALit { T.aLit = l@LitFloat{}, T.aBody = b } -> do       tell YesFloat       l <- literal l@@ -1071,6 +1083,10 @@   LitFloat  x   -> floatExp x "Double"   LitQName  x   -> return $ litqname x   LitString s   -> return $ litString s+  LitMeta _ m   ->+    return $ HS.FakeExp "(,)" `HS.App`+             hsTypedInt (metaId m) `HS.App`+             (hsTypedInt (moduleNameHash $ metaModule m))   _             -> return $ l'   where     l'    = HS.Lit $ hslit l@@ -1135,6 +1151,12 @@   where     NameId n (ModuleNameHash m) = nameId $ qnameName x +litmetapat :: MetaId -> HS.Pat+litmetapat (MetaId m h) =+  HS.PApp (hsName "(,)")+          [ HS.PLit (HS.Int $ fromIntegral m)+          , HS.PLit (HS.Int $ fromIntegral $ moduleNameHash h) ]+ condecl :: QName -> Induction -> HsCompileM HS.ConDecl condecl q _ind = do   opts <- askGhcOpts@@ -1270,10 +1292,11 @@  callGHC :: ReaderT GHCModule TCM () callGHC = do-  opts    <- askGhcOpts-  hsmod   <- prettyPrint <$> curHsMod-  agdaMod <- curAgdaMod-  let outputName = lastWithDefault __IMPOSSIBLE__ $ mnameToList agdaMod+  opts     <- askGhcOpts+  agdaOpts <- lift commandLineOptions+  hsmod    <- prettyPrint <$> curHsMod+  agdaMod  <- curAgdaMod+  let outputName = Text.unpack $ List1.last $ moduleNameParts agdaMod   (mdir, fp) <- curOutFileAndDir   let ghcopts = optGhcFlags opts @@ -1288,7 +1311,7 @@    let overridableArgs =         [ "-O"] ++-        (if isMain then ["-o", mdir </> prettyShow (nameConcrete outputName)] else []) +++        (if isMain then ["-o", mdir </> outputName] else []) ++         [ "-Werror"]       otherArgs       =         [ "-i" ++ mdir] ++@@ -1307,4 +1330,8 @@   -- those versions of GHC we don't print any progress information   -- unless an error is encountered.   let doCall = optGhcCallGhc opts-  liftTCM $ callCompiler doCall ghcBin args (Just utf8)+      cwd    = if optGHCiInteraction agdaOpts ||+                  optJSONInteraction agdaOpts+               then Just mdir+               else Nothing+  liftTCM $ callCompiler doCall ghcBin args cwd (Just utf8)
src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs view
@@ -8,8 +8,9 @@   , hsTelApproximation, hsTelApproximation'   ) where -import Control.Monad (zipWithM)-import Control.Monad.Except+import Control.Monad         ( zipWithM )+import Control.Monad.Except  ( ExceptT(ExceptT), runExceptT, mapExceptT, catchError, throwError )+import Control.Monad.Trans   ( lift ) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) import Data.Maybe (fromMaybe)
src/full/Agda/Compiler/MAlonzo/Misc.hs view
@@ -23,10 +23,11 @@  import qualified Agda.Utils.Haskell.Syntax as HS -import Agda.Compiler.Common+import Agda.Compiler.Common as CC  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad @@ -39,7 +40,7 @@ --------------------------------------------------  data HsModuleEnv = HsModuleEnv-  { mazModuleName :: ModuleName+  { mazModuleName :: TopLevelModuleName     -- ^ The name of the Agda module   , mazIsMainModule :: Bool   -- ^ Whether this is the compilation root and therefore should have the `main` function.@@ -133,7 +134,7 @@ instance ReadGHCModuleEnv m => ReadGHCModuleEnv (StateT s m)  newtype HsCompileState = HsCompileState-  { mazAccumlatedImports :: Set ModuleName+  { mazAccumlatedImports :: Set TopLevelModuleName   } deriving (Eq, Semigroup, Monoid)  -- | Transformer adding read-only module info and a writable set of imported modules@@ -161,7 +162,7 @@ -- | This is the same value as @curMName@, but does not rely on the TCM's state. --   (@curMName@ and co. should be removed, but the current @Backend@ interface --   is not sufficient yet to allow that)-curAgdaMod :: ReadGHCModuleEnv m => m ModuleName+curAgdaMod :: ReadGHCModuleEnv m => m TopLevelModuleName curAgdaMod = mazModuleName <$> askHsModuleEnv  -- | Get the Haskell module name of the currently-focused Agda module@@ -237,14 +238,14 @@  -- the toplevel module containing the given one tlmodOf :: ReadTCState m => ModuleName -> m HS.ModuleName-tlmodOf = fmap mazMod . topLevelModuleName+tlmodOf = fmap mazMod . CC.topLevelModuleName   -- qualify HS.Name n by the module of QName q, if necessary; -- accumulates the used module in stImportedModules at the same time. xqual :: QName -> HS.Name -> HsCompileM HS.QName xqual q n = do-  m1 <- topLevelModuleName (qnameModule q)+  m1 <- CC.topLevelModuleName (qnameModule q)   m2 <- curAgdaMod   if m1 == m2     then return (HS.UnQual n)@@ -331,7 +332,7 @@ mazMod' :: String -> HS.ModuleName mazMod' s = HS.ModuleName $ mazstr ++ "." ++ s -mazMod :: ModuleName -> HS.ModuleName+mazMod :: TopLevelModuleName -> HS.ModuleName mazMod = mazMod' . prettyShow  mazCoerceName :: String
src/full/Agda/Compiler/MAlonzo/Primitives.hs view
@@ -26,6 +26,8 @@  import Agda.Utils.Either import Agda.Utils.Lens+import Agda.Utils.List   (hasElem)+import Agda.Utils.Maybe import Agda.Utils.Pretty (prettyShow) import qualified Agda.Utils.Haskell.Syntax as HS @@ -42,17 +44,17 @@ -- TODO: Also only consider top-level definition (not buried inside a module). asMainFunctionDef :: Definition -> Maybe MainFunctionDef asMainFunctionDef d = case (theDef d) of-    Axiom{}                             -> perhaps-    Function{ funProjection = Nothing } -> perhaps-    Function{ funProjection = Just{}  } -> no-    AbstractDefn{}                      -> no-    GeneralizableVar{}                  -> no-    DataOrRecSig{}                      -> no-    Datatype{}                          -> no-    Record{}                            -> no-    Constructor{}                       -> no-    Primitive{}                         -> no-    PrimitiveSort{}                     -> no+    Axiom{}                              -> perhaps+    Function{ funProjection = Left _ }   -> perhaps+    Function{ funProjection = Right{}  } -> no+    AbstractDefn{}                       -> no+    GeneralizableVar{}                   -> no+    DataOrRecSig{}                       -> no+    Datatype{}                           -> no+    Record{}                             -> no+    Constructor{}                        -> no+    Primitive{}                          -> no+    PrimitiveSort{}                      -> no   where   isNamedMain = "main" == prettyShow (nameConcrete . qnameName . defName $ d)  -- ignores the qualification!?   perhaps | isNamedMain = Just $ MainFunctionDef d@@ -156,12 +158,14 @@ xForPrim table builtinThings defs = catMaybes     [ Map.lookup s table     | (s, def) <- Map.toList builtinThings-    , getName def `Set.member` qs+    , maybe False elemDefs $ getName def     ]   where-  qs = Set.fromList $ map defName defs-  getName (Builtin t)            = getPrimName t-  getName (Prim (PrimFun q _ _)) = q+  elemDefs = hasElem $ map defName defs+  getName = \case+    Builtin t                 -> Just $ getPrimName t+    Prim (PrimFun q _ _)      -> Just q+    BuiltinRewriteRelations _ -> Nothing   -- | Definition bodies for primitive functions@@ -282,10 +286,13 @@   , "primQNameFixity"     |-> return "MAlonzo.RTE.qnameFixity"   , "primQNameToWord64s"  |-> return "\\ qn -> (MAlonzo.RTE.nameId qn, MAlonzo.RTE.moduleId qn)"   , "primQNameToWord64sInjective" |-> return mazErasedName-  , "primMetaEquality"    |-> rel "(==)" "Integer"-  , "primMetaLess"        |-> rel "(<)" "Integer"-  , "primShowMeta"        |-> return "\\ x -> Data.Text.pack (\"_\" ++ show (x :: Integer))"-  , "primMetaToNat"       |-> return "(id :: Integer -> Integer)"+  , "primMetaEquality"    |-> rel "(==)" "(Integer, Integer)"+  , "primMetaLess"        |-> rel "(<)" "(Integer, Integer)"+  -- Should be kept in sync with version in `primitiveFunctions` in+  -- Agda.TypeChecking.Primitive+  , "primShowMeta"        |-> return "\\ (m, h) -> Data.Text.pack (\"_\" ++ show (m :: Integer) ++ \"@\" ++ show (h :: Integer))"+  -- Should be kept in sync with `metaToNat` in Agda.TypeChecking.Primitive+  , "primMetaToNat"       |-> return "\\ (m, h) -> (h :: Integer) * 2^64 + (m :: Integer)"   , "primMetaToNatInjective" |-> return mazErasedName    -- Seq@@ -313,7 +320,6 @@   , "primDepIMin"     |-> return "\\i f -> if i then f () else False"   , "primIdFace"      |-> return "\\_ _ _ _ -> fst"   , "primIdPath"      |-> return "\\_ _ _ _ -> snd"-  , "primIdJ"         |-> return "\\_ _ _ _ _ x _ _ -> x"   , builtinIdElim     |-> return                             "\\_ _ _ _ _ f x y -> f (fst y) x (snd y)"   ]
src/full/Agda/Compiler/ToTreeless.hs view
@@ -4,6 +4,8 @@   , closedTermToTreeless   ) where +import Prelude hiding ((!!))+ import Control.Arrow        ( first ) import Control.Monad        ( filterM, foldM, forM, zipWithM ) import Control.Monad.Reader ( MonadReader(..), asks, ReaderT, runReaderT )@@ -22,6 +24,7 @@  import Agda.TypeChecking.CompiledClause as CC import qualified Agda.TypeChecking.CompiledClause.Compile as CC+import Agda.TypeChecking.Datatypes import Agda.TypeChecking.EtaContract (binAppView, BinAppView(..)) import Agda.TypeChecking.Monad as TCM import Agda.TypeChecking.Pretty@@ -57,7 +60,7 @@ getCompiledClauses q = do   def <- getConstInfo q   let cs = defClauses def-      isProj | Function{ funProjection = proj } <- theDef def = isJust (projProper =<< proj)+      isProj | Function{ funProjection = Right x } <- theDef def = isJust (projProper x)              | otherwise = False       translate | isProj    = CC.DontRunRecordPatternTranslation                 | otherwise = CC.RunRecordPatternTranslation@@ -253,6 +256,8 @@     CC.Case (Arg _ n) (CC.Branches True conBrs _ _ Nothing _ _) -> lambdasUpTo n $ do       mkRecord =<< traverse casetree (CC.content <$> conBrs)     CC.Case (Arg i n) (CC.Branches False conBrs etaBr litBrs catchAll _ lazy) -> lambdasUpTo (n + 1) $ do+      -- re #3733 TODO: revise when compiling --cubical+      conBrs <- fmap Map.fromList $ filterM (isConstructor . fst) (Map.toList conBrs)                     -- We can treat eta-matches as regular matches here.       let conBrs' = caseMaybe etaBr conBrs $ \ (c, br) -> Map.insertWith (\ new old -> old) (conName c) br conBrs       if Map.null conBrs' && Map.null litBrs then do
src/full/Agda/Compiler/Treeless/Erase.hs view
@@ -277,7 +277,7 @@ typeWithoutParams q = do   def <- getConstInfo q   let d = case I.theDef def of-        Function{ funProjection = Just Projection{ projIndex = i } } -> i - 1+        Function{ funProjection = Right Projection{ projIndex = i } } -> i - 1         Constructor{ conPars = n } -> n         _                          -> 0   first (drop d) <$> telListView (defType def)@@ -306,6 +306,7 @@   typeInfo :: QName -> E TypeInfo   typeInfo q = ifM (erasureForbidden q) (return NotErasable) $ {-else-} do     memoRec (typeMap . key q) Erasable $ do  -- assume recursive occurrences are erasable+      mId    <- lift $ getName' builtinId       msizes <- lift $ mapM getBuiltinName                          [builtinSize, builtinSizeLt]       def    <- lift $ getConstInfo q@@ -314,6 +315,7 @@                   I.Record{ recConHead = c }  -> Just [conName c]                   _                           -> Nothing       case mcs of+        _ | Just q == mId        -> return NotErasable         _ | Just q `elem` msizes -> return Erasable         Just [c] -> do           (ts, _) <- lift $ typeWithoutParams c
src/full/Agda/Compiler/Treeless/Identity.hs view
@@ -6,13 +6,13 @@  import Control.Applicative ( Alternative((<|>), empty) ) import Data.Semigroup-import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List as List  import Agda.Syntax.Treeless import Agda.TypeChecking.Monad  import Agda.Utils.List+import Agda.Utils.List1 (pattern (:|))  import Agda.Utils.Impossible
src/full/Agda/Interaction/AgdaTop.hs view
@@ -12,6 +12,7 @@ import System.IO  import Agda.Interaction.Base+import Agda.Interaction.ExitCode import Agda.Interaction.Response as R import Agda.Interaction.InteractionTop import Agda.Interaction.Options@@ -52,8 +53,14 @@       r <- maybeAbort runInteraction       case r of         Done      -> return True -- Done.-        Error s   -> liftIO (putStrLn s) >> return False         Command _ -> return False+        Error s   -> do+          exit <- optExitOnError <$> commandLineOptions+          if exit+            then liftIO (exitAgdaWith CommandError)+            else do+              liftIO (putStrLn s)+              return False      lift Bench.print     unless done interact'@@ -71,7 +78,6 @@       case dropWhile isSpace r of         ""          -> readCommand         ('-':'-':_) -> readCommand-        _           -> case listToMaybe $ reads r of-          Just (x, "")  -> return $ Command x-          Just (_, rem) -> return $ Error $ "not consumed: " ++ rem-          _             -> return $ Error $ "cannot read: " ++ r+        _           -> case parseIOTCM r of+          Right cmd -> return $ Command cmd+          Left err  -> return $ Error err
src/full/Agda/Interaction/Base.hs view
@@ -24,6 +24,7 @@ import           Agda.Syntax.Internal         (ProblemId, Blocker) import           Agda.Syntax.Position import           Agda.Syntax.Scope.Base       (ScopeInfo)+import           Agda.Syntax.TopLevelModuleName  import           Agda.Interaction.Options     (CommandLineOptions,                                                defaultOptions)@@ -85,6 +86,8 @@ data CurrentFile = CurrentFile   { currentFilePath  :: AbsolutePath       -- ^ The file currently loaded into interaction.+  , currentFileModule :: TopLevelModuleName+      -- ^ The top-level module name of the currently loaded file.   , currentFileArgs  :: [String]       -- ^ The arguments to Agda used for loading the file.   , currentFileStamp :: ClockTime@@ -109,6 +112,15 @@  type Command = Command' IOTCM +-- | IOTCM commands.+--+-- The commands are obtained by applying the functions to the current+-- top-level module name, if any. Note that the top-level module name+-- is not used by independent commands. For other commands the+-- top-level module name should be known.++type IOTCM = Maybe TopLevelModuleName -> IOTCM' Range+ -- | Command queues.  data CommandQueue = CommandQueue@@ -143,6 +155,11 @@     -- show those instead.   | Cmd_metas Rewrite +    -- | A command that fails if there are any unsolved+    -- meta-variables. By default no output is generated if the+    -- command is successful.+  | Cmd_no_metas+     -- | Shows all the top-level names in the given module, along with     -- their types. Uses the top-level scope.   | Cmd_show_module_contents_toplevel@@ -293,7 +310,6 @@     -- ^ Exit the program.         deriving (Show, Read, Functor, Foldable, Traversable) -type IOTCM = IOTCM' Range data IOTCM' range     = IOTCM         FilePath@@ -319,7 +335,19 @@ --------------------------------------------------------- -- Read instances +-- | An 'IOTCM' parser.+--+-- If the parse fails, then an error message is returned. +parseIOTCM ::+  String -> Either String IOTCM+parseIOTCM s = case listToMaybe $ reads s of+  Just (x, "")  -> Right $ \top -> case x of+    IOTCM f l m i -> IOTCM f l m $+      (fmap . fmap . fmap) (\rf -> mkRangeFile (rangeFilePath rf) top) i+  Just (_, rem) -> Left $ "not consumed: " ++ rem+  _             -> Left $ "cannot read: " ++ s+ -- | The 'Parse' monad. --   'StateT' state holds the remaining input. @@ -384,6 +412,14 @@         exact "mkAbsolute"         fmap mkAbsolute readParse +-- | This instance fills in the 'TopLevelModuleName's using 'Nothing'.+-- Note that these occurrences of 'Nothing' are \"overwritten\" by+-- 'parseIOTCM'.++instance Read RangeFile where+    readsPrec = parseToReadsPrec $+      fmap (flip mkRangeFile Nothing) readParse+ instance Read a => Read (Position' a) where     readsPrec = parseToReadsPrec $ do         exact "Pn"@@ -443,6 +479,7 @@       | PTSInstance b b       | PostponedCheckFunDef QName a TCErr       | CheckLock b b+      | DataSort QName b       | UsableAtMod Modality b   deriving (Functor)
src/full/Agda/Interaction/BasicOps.hs view
@@ -13,8 +13,8 @@ import Control.Monad.State import Control.Monad.Identity -import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.List as List import Data.Maybe@@ -46,9 +46,10 @@ import Agda.Syntax.Parser  import Agda.TheTypeChecker+import Agda.TypeChecking.ReconstructParameters import Agda.TypeChecking.Constraints import Agda.TypeChecking.Conversion-import Agda.TypeChecking.Errors ( getAllWarnings, stringTCErr )+import Agda.TypeChecking.Errors ( getAllWarnings, stringTCErr, Verbalize(..) ) import Agda.TypeChecking.Monad as M hiding (MetaInfo) import Agda.TypeChecking.MetaVars import Agda.TypeChecking.MetaVars.Mention@@ -61,6 +62,7 @@ import Agda.TypeChecking.Records import Agda.TypeChecking.Irrelevance (wakeIrrelevantVars) import Agda.TypeChecking.Pretty ( PrettyTCM, prettyTCM )+import Agda.TypeChecking.Pretty.Constraint (prettyRangeConstraint) import Agda.TypeChecking.IApplyConfluence import Agda.TypeChecking.Primitive import Agda.TypeChecking.Names@@ -80,6 +82,7 @@ import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe+import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty as P@@ -88,12 +91,16 @@ import Agda.Utils.String  import Agda.Utils.Impossible+import qualified Agda.Utils.SmallSet as SmallSet+import Agda.TypeChecking.ProjectionLike (reduceProjectionLike)  -- | Parses an expression.  parseExpr :: Range -> String -> TCM C.Expr parseExpr rng s = do-  C.ExprWhere e wh <- runPM $ parsePosString exprWhereParser pos s+  (C.ExprWhere e wh, coh) <-+    runPM $ parsePosString exprWhereParser pos s+  checkCohesionAttributes coh   unless (null wh) $ typeError $ GenericError $     "where clauses are not supported in holes"   return e@@ -103,7 +110,7 @@ parseExprIn ii rng s = do     mId <- lookupInteractionId ii     updateMetaVarRange mId rng-    mi  <- getMetaInfo <$> lookupMeta mId+    mi  <- getMetaInfo <$> lookupLocalMeta mId     e   <- parseExpr rng s     -- Andreas, 2019-08-19, issue #4007     -- We need to be in the TCEnv of the meta variable@@ -117,7 +124,7 @@ -- Precondition: we are in the context where the given meta was created. giveExpr :: UseForce -> Maybe InteractionId -> MetaId -> Expr -> TCM Term giveExpr force mii mi e = do-    mv <- lookupMeta mi+    mv <- lookupLocalMeta mi     let t = case mvJudgement mv of               IsSort{}    -> __IMPOSSIBLE__               HasType _ _ t -> t@@ -140,6 +147,7 @@       -- when not in a mutual block.       v <- locallyTC eMutualBlock (const Nothing) $         checkExpr e t'+      reportSDoc "interaction.give" 40 $ "give: checked expression:" TP.<+> pure (pretty v)       case mvInstantiation mv of          InstV{} -> unlessM ((Irrelevant ==) <$> asksTC getRelevance) $ do@@ -236,7 +244,11 @@       PatternErr{} -> typeError . GenericDocError =<< do         withInteractionId ii $ "Failed to give" TP.<+> prettyTCM e       err -> throwError err-  nv <- normalForm norm v+  mv <- lookupLocalMeta mi+  -- Reduce projection-likes before quoting, otherwise instance+  -- selection may fail on reload (see #6203).+  nv <- reduceProjectionLike =<< normalForm norm v+  reportSDoc "interaction.give" 40 $ "nv = " TP.<+> pure (pretty v)   locallyTC ePrintMetasBare (const True) $ reify nv  -- | Try to refine hole by expression @e@.@@ -251,7 +263,7 @@   -> TCM Expr       -- ^ The successfully given expression. refine force ii mr e = do   mi <- lookupInteractionId ii-  mv <- lookupMeta mi+  mv <- lookupLocalMeta mi   let range = fromMaybe (getRange mv) mr       scope = M.getMetaScope mv   reportSDoc "interaction.refine" 10 $@@ -334,7 +346,7 @@ evalInMeta :: InteractionId -> ComputeMode -> Expr -> TCM Expr evalInMeta ii cmode e =    do   m <- lookupInteractionId ii-        mi <- getMetaInfo <$> lookupMeta m+        mi <- getMetaInfo <$> lookupLocalMeta m         withMetaInfo mi $             evalInCurrent cmode e @@ -395,6 +407,7 @@       FindInstanceOF _ _ _        -> __IMPOSSIBLE__       PTSInstance i _            -> i       PostponedCheckFunDef{}     -> __IMPOSSIBLE__+      DataSort _ i               -> i       CheckLock i _              -> i       UsableAtMod _ i            -> i @@ -434,7 +447,7 @@         tac <- A.App defaultAppInfo_ (A.Unquote exprNoRange) . defaultNamedArg <$> reify tac         OfType tac <$> reify goal     reify (UnBlock m) = do-        mi <- mvInstantiation <$> lookupMeta m+        mi <- lookupMetaInstantiation m         m' <- reify (MetaV m [])         case mi of           BlockedConst t -> do@@ -476,13 +489,18 @@     reify (HasPTSRule a b) = do       (a,(x,b)) <- reify (unDom a,b)       return $ PTSInstance a b+    reify (CheckDataSort q s) = DataSort q <$> reify s     reify (CheckLockedVars t _ lk _) = CheckLock <$> reify t <*> reify (unArg lk)     reify (CheckMetaInst m) = do-      t <- jMetaType . mvJudgement <$> lookupMeta m+      t <- jMetaType . mvJudgement <$> lookupLocalMeta m       OfType <$> reify (MetaV m []) <*> reify t     reify (CheckType t) = JustType <$> reify t-    reify (UsableAtModality mod t) = UsableAtMod mod <$> reify t+    reify (UsableAtModality _ _ mod t) = UsableAtMod mod <$> reify t +instance (Pretty a, Pretty b) => PrettyTCM (OutputForm a b) where+  prettyTCM (OutputForm r pids unblock c) =+    prettyRangeConstraint r pids unblock (pretty c)+ instance (Pretty a, Pretty b) => Pretty (OutputForm a b) where   pretty (OutputForm r pids unblock c) =     pretty c <?>@@ -530,8 +548,9 @@       PostponedCheckFunDef q a _err ->         vcat [ "Check definition of" <+> pretty q <+> ":" <+> pretty a ]              -- , nest 2 "stuck because" <?> pretty err ] -- We don't have Pretty for TCErr+      DataSort q s         -> "Sort" <+> pretty s <+> "allows data/record definitions"       CheckLock t lk       -> "Check lock" <+> pretty lk <+> "allows" <+> pretty t-      UsableAtMod mod t    -> "Is usable at" <+> pretty mod <+> pretty t+      UsableAtMod mod t    -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> pretty t     where       bin a op b = sep [a, nest 2 $ op <+> b]       pcmp cmp a b = bin (pretty a) (pretty cmp) (pretty b)@@ -571,6 +590,7 @@       FindInstanceOF <$> toConcrete s <*> toConcrete t                      <*> mapM (\(q,tm,ty) -> (,,) <$> toConcrete q <*> toConcrete tm <*> toConcrete ty) cs     toConcrete (PTSInstance a b) = PTSInstance <$> toConcrete a <*> toConcrete b+    toConcrete (DataSort a b)  = DataSort a <$> toConcrete b     toConcrete (CheckLock a b) = CheckLock <$> toConcrete a <*> toConcrete b     toConcrete (PostponedCheckFunDef q a err) = PostponedCheckFunDef q <$> toConcrete a <*> pure err     toConcrete (UsableAtMod a b) = UsableAtMod a <$> toConcrete b@@ -644,15 +664,20 @@         HasBiggerSort a            -> Nothing         HasPTSRule a b             -> Nothing         UnquoteTactic{}            -> Nothing+        CheckDataSort _ s          -> isMetaS s         CheckMetaInst{}            -> Nothing         CheckType t                -> isMeta (unEl t)         CheckLockedVars t _ _ _    -> isMeta t-        UsableAtModality _ t       -> isMeta t+        UsableAtModality _ ms _ t  -> caseMaybe ms (isMeta t) $ \ s -> isMetaS s `mplus` isMeta t      isMeta (MetaV m' es_m)       | m == m' = Just es_m     isMeta _  = Nothing +    isMetaS (MetaS m' es_m)+      | m == m' = Just es_m+    isMetaS _  = Nothing+     getConstrs g f = liftTCM $ do       cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints)       reportSDoc "constr.ment" 20 $ "getConstraintsMentioning"@@ -676,6 +701,16 @@     interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs     stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c +-- | Converts an 'InteractionId' to a 'MetaId'.++interactionIdToMetaId :: ReadTCState m => InteractionId -> m MetaId+interactionIdToMetaId i = do+  h <- currentModuleNameHash+  return MetaId+    { metaId     = fromIntegral i+    , metaModule = h+    }+ getConstraints' :: (ProblemConstraint -> TCM ProblemConstraint) -> (ProblemConstraint -> Bool) -> TCM [OutputForm C.Expr C.Expr] getConstraints' g f = liftTCM $ do     cs <- stripConstraintPids . filter f <$> (mapM g =<< M.getAllConstraints)@@ -686,9 +721,10 @@     return $ ss ++ cs   where     toOutputForm (ii, mi, e) = do-      mv <- getMetaInfo <$> lookupMeta mi+      mv <- getMetaInfo <$> lookupLocalMeta mi       withMetaInfo mv $ do-        let m = QuestionMark emptyMetaInfo{ metaNumber = Just $ fromIntegral ii } ii+        mi <- interactionIdToMetaId ii+        let m = QuestionMark emptyMetaInfo{ metaNumber = Just mi } ii         abstractToConcrete_ $ OutputForm noRange [] alwaysUnblock $ Assign m e  @@ -759,7 +795,7 @@   mapM solution =<< getInteractionIdsAndMetas   where     solution (i, m) = do-      mv <- lookupMeta m+      mv <- lookupLocalMeta m       withMetaInfo (getMetaInfo mv) $ do         args  <- getContextArgs         scope <- getScope@@ -780,7 +816,7 @@  typeOfMetaMI :: Rewrite -> MetaId -> TCM (OutputConstraint Expr NamedMeta) typeOfMetaMI norm mi =-     do mv <- lookupMeta mi+     do mv <- lookupLocalMeta mi         withMetaInfo (getMetaInfo mv) $           rewriteJudg mv (mvJudgement mv)    where@@ -825,13 +861,13 @@ typesOfHiddenMetas :: Rewrite -> TCM [OutputConstraint Expr NamedMeta] typesOfHiddenMetas norm = liftTCM $ do   is    <- getInteractionMetas-  store <- IntMap.filterWithKey (openAndImplicit is . MetaId) <$> getMetaStore-  mapM (typeOfMetaMI norm . MetaId) $ IntMap.keys store+  store <- MapS.filterWithKey (implicit is) <$> useR stOpenMetaStore+  mapM (typeOfMetaMI norm) $ MapS.keys store   where-  openAndImplicit is x m | isJust (mvTwin m) = False-  openAndImplicit is x m =+  implicit is x m | isJust (mvTwin m) = False+  implicit is x m =     case mvInstantiation m of-      M.InstV{} -> False+      M.InstV{} -> __IMPOSSIBLE__       M.Open    -> x `notElem` is       M.OpenInstance -> x `notElem` is  -- OR: True !?       M.BlockedConst{} -> False@@ -928,8 +964,8 @@     -- renameVars = onNames (stringToArgName <.> renameVar . argNameToString)     renameVars = onNames renameVar -    -- onNames :: Applicative m => (ArgName -> m ArgName) -> Type -> m Type-    onNames :: Applicative m => (String -> m String) -> Type -> m Type+    -- onNames :: Applicative m => (ArgName -> m ArgName) -> I.Type -> m I.Type+    onNames :: Applicative m => (String -> m String) -> I.Type -> m I.Type     onNames f (El s v) = El s <$> onNamesTm f v      -- onNamesTel :: Applicative f => (ArgName -> f ArgName) -> I.Telescope -> f I.Telescope@@ -978,7 +1014,7 @@  contextOfMeta :: InteractionId -> Rewrite -> TCM [ResponseContextEntry] contextOfMeta ii norm = withInteractionId ii $ do-  info <- getMetaInfo <$> (lookupMeta =<< lookupInteractionId ii)+  info <- getMetaInfo <$> (lookupLocalMeta =<< lookupInteractionId ii)   withMetaInfo info $ do     -- List of local variables.     cxt <- getContext@@ -990,7 +1026,7 @@          <*> forMaybeM letVars mkLet    where-    mkVar :: Dom (Name, Type) -> TCM (Maybe ResponseContextEntry)+    mkVar :: ContextEntry -> TCM (Maybe ResponseContextEntry)     mkVar Dom{ domInfo = ai, unDom = (name, t) } = do       if shouldHide ai name then return Nothing else Just <$> do         let n = nameConcrete name@@ -999,7 +1035,7 @@         ty <- reifyUnblocked =<< normalForm norm t         return $ ResponseContextEntry n x (Arg ai ty) Nothing s -    mkLet :: (Name, Open (Term, Dom Type)) -> TCM (Maybe ResponseContextEntry)+    mkLet :: (Name, Open (Term, Dom I.Type)) -> TCM (Maybe ResponseContextEntry)     mkLet (name, lb) = do       (tm, !dom) <- getOpen lb       if shouldHide (domInfo dom) name then return Nothing else Just <$> do@@ -1027,7 +1063,7 @@ typeInMeta :: InteractionId -> Rewrite -> Expr -> TCM Expr typeInMeta ii norm e =    do   m <- lookupInteractionId ii-        mi <- getMetaInfo <$> lookupMeta m+        mi <- getMetaInfo <$> lookupLocalMeta m         withMetaInfo mi $             typeInCurrent norm e @@ -1040,7 +1076,7 @@ introTactic :: Bool -> InteractionId -> TCM [String] introTactic pmLambda ii = do   mi <- lookupInteractionId ii-  mv <- lookupMeta mi+  mv <- lookupLocalMeta mi   withMetaInfo (getMetaInfo mv) $ case mvJudgement mv of     HasType _ _ t -> do         t <- reduce =<< piApplyM t =<< getContextArgs@@ -1139,8 +1175,8 @@ atTopLevel :: TCM a -> TCM a atTopLevel m = inConcreteMode $ do   let err = typeError $ GenericError "The file has not been loaded yet."-  caseMaybeM (useTC stCurrentModule) err $ \ current -> do-    caseMaybeM (getVisitedModule $ toTopLevelModuleName current) __IMPOSSIBLE__ $ \ mi -> do+  caseMaybeM (useTC stCurrentModule) err $ \(current, topCurrent) -> do+    caseMaybeM (getVisitedModule topCurrent) __IMPOSSIBLE__ $ \ mi -> do       let scope = iInsideScope $ miInterface mi       tel <- lookupSection current       -- Get the names of the local variables from @scope@@@ -1212,7 +1248,7 @@      -- ^ The range of the next argument.   -> String      -- ^ The module name.-  -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])      -- ^ Module names,      --   context extension needed to print types,      --   names paired up with corresponding types.@@ -1235,7 +1271,7 @@ getRecordContents   :: Rewrite  -- ^ Amount of normalization in types.   -> C.Expr   -- ^ Expression presumably of record type.-  -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])               -- ^ Module names,               --   context extension,               --   names paired up with corresponding types.@@ -1269,7 +1305,7 @@        -- ^ Amount of normalization in types.   -> Maybe C.QName        -- ^ Module name, @Nothing@ if top-level module.-  -> TCM ([C.Name], I.Telescope, [(C.Name, Type)])+  -> TCM ([C.Name], I.Telescope, [(C.Name, I.Type)])        -- ^ Module names,        --   context extension,        --   names paired up with corresponding types.@@ -1282,17 +1318,22 @@       names :: ThingsInScope AbstractName       names = exportedNamesInScope modScope       xns = [ (x,n) | (x, ns) <- Map.toList names, n <- ns ]-  types <- forM xns $ \(x, n) -> do-    d <- getConstInfo $ anameName n-    t <- normalForm norm =<< (defType <$> instantiateDef d)-    return (x, t)+  types <- forMaybeM xns $ \(x, n) -> do+    getConstInfo' (anameName n) >>= \case+      Right d -> do+        t <- normalForm norm =<< (defType <$> instantiateDef d)+        return $ Just (x, t)+      Left{} -> return Nothing   return (Map.keys modules, EmptyTel, types)  -whyInScope :: String -> TCM (Maybe LocalVar, [AbstractName], [AbstractModule])-whyInScope s = do+whyInScope :: FilePath -> String -> TCM WhyInScopeData+whyInScope cwd s = do   x     <- parseName noRange s   scope <- getScope-  return ( lookup x $ map (first C.QName) $ scope ^. scopeLocals-         , scopeLookup x scope-         , scopeLookup x scope )+  return $ WhyInScopeData+    x+    cwd+    (lookup x $ map (first C.QName) $ scope ^. scopeLocals)+    (scopeLookup x scope)+    (scopeLookup x scope)
src/full/Agda/Interaction/CommandLine.hs view
@@ -233,11 +233,12 @@ metaParseExpr ::  InteractionId -> String -> TCM A.Expr metaParseExpr ii s =     do  m <- lookupInteractionId ii-        scope <- getMetaScope <$> lookupMeta m-        r <- getRange <$> lookupMeta m+        scope <- getMetaScope <$> lookupLocalMeta m+        r <- getRange <$> lookupLocalMeta m         -- liftIO $ putStrLn $ prettyShow scope         let pos = fromMaybe __IMPOSSIBLE__ (rStart r)-        e <- runPM $ parsePosString exprParser pos s+        (e, coh) <- runPM $ parsePosString exprParser pos s+        checkCohesionAttributes coh         concreteToAbstract scope e  actOnMeta :: [String] -> (InteractionId -> A.Expr -> TCM a) -> TCM a@@ -277,7 +278,8 @@  parseExpr :: String -> TCM A.Expr parseExpr s = do-    e <- runPM $ parse exprParser s+    (e, coh) <- runPM $ parse exprParser s+    checkCohesionAttributes coh     localToAbstract e return  evalTerm :: String -> TCM (ExitCode a)@@ -306,7 +308,7 @@ showContext :: [String] -> TCM () showContext (meta:args) = do     i <- InteractionId <$> readM meta-    mi <- lookupMeta =<< lookupInteractionId i+    mi <- lookupLocalMeta =<< lookupInteractionId i     withMetaInfo (getMetaInfo mi) $ do       ctx <- List.map I.unDom . telToList <$> getContextTelescope       zipWithM_ display ctx $ reverse $ zipWith const [1..] ctx
src/full/Agda/Interaction/EmacsTop.hs view
@@ -21,7 +21,7 @@ import Agda.Syntax.Abstract as A import Agda.Syntax.Concrete as C -import Agda.TypeChecking.Errors (prettyError, getAllWarningsOfTCErr)+import Agda.TypeChecking.Errors ( explainWhyInScope, getAllWarningsOfTCErr, prettyError ) import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Pretty (prettyTCM) import Agda.TypeChecking.Pretty.Warning (prettyTCWarnings, prettyTCWarnings')@@ -124,7 +124,9 @@       -- abusing the goals field since we ignore the title         (body, _) = formatWarningsAndErrors msg warnings errors       format body "*Compilation result*"-    Info_Constraints s -> format (show $ vcat $ map pretty s) "*Constraints*"+    Info_Constraints s -> do+      doc <- TCP.vcat $ map prettyTCM s+      format (render doc) "*Constraints*"     Info_AllGoalsWarnings ms ws -> do       goals <- showGoals ms       warnings <- prettyTCWarnings (tcWarnings ws)@@ -179,8 +181,8 @@       let doc = "Definitions about" <+>                 text (List.intercalate ", " $ words names) $$ nest 2 (align 10 hitDocs)       format (render doc) "*Search About*"-    Info_WhyInScope s cwd v xs ms -> do-      doc <- explainWhyInScope s cwd v xs ms+    Info_WhyInScope why -> do+      doc <- explainWhyInScope why       format (render doc) "*Scope Info*"     Info_Context ii ctx -> do       doc <- localTCState (prettyResponseContext ii False ctx)@@ -227,18 +229,19 @@             | otherwise  = [ text $ delimiter "Boundary"                            , vcat $ map pretty bndry                            ]-      let constraintsDoc = if (null constraints)-            then  []-            else  [ text $ delimiter "Constraints"-                  , vcat $ map pretty constraints-                  ]-      let doc = vcat $-            [ "Goal:" <+> goalDoc-            , auxDoc-            , vcat boundaryDoc-            , text (replicate 60 '\x2014')-            , ctxDoc-            ] ++ constraintsDoc+      let constraintsDoc+            | null constraints = []+            | otherwise        =+              [ TCP.text $ delimiter "Constraints"+              , TCP.vcat $ map prettyTCM constraints+              ]+      doc <- TCP.vcat $+        [ "Goal:" TCP.<+> return goalDoc+        , return auxDoc+        , return (vcat boundaryDoc)+        , TCP.text (replicate 60 '\x2014')+        , return ctxDoc+        ] ++ constraintsDoc       format (render doc) "*Goal type etc.*"     Goal_CurrentGoal norm -> do       doc <- prettyTypeOfMeta norm ii@@ -314,87 +317,6 @@   return $ "Highlighting failed to parse expression in " ++ show ii showInfoError (Info_HighlightingScopeCheckError ii) =   return $ "Highlighting failed to scope check expression in " ++ show ii--explainWhyInScope :: FilePath-                  -> String-                  -> (Maybe LocalVar)-                  -> [AbstractName]-                  -> [AbstractModule]-                  -> TCM Doc-explainWhyInScope s _ Nothing [] [] = TCP.text (s ++ " is not in scope.")-explainWhyInScope s _ v xs ms = TCP.vcat-  [ TCP.text (s ++ " is in scope as")-  , TCP.nest 2 $ TCP.vcat [variable v xs, modules ms]-  ]-  where-    -- variable :: Maybe _ -> [_] -> TCM Doc-    variable Nothing vs = names vs-    variable (Just x) vs-      | null vs   = asVar-      | otherwise = TCP.vcat-         [ TCP.sep [ asVar, TCP.nest 2 $ shadowing x]-         , TCP.nest 2 $ names vs-         ]-      where-        asVar :: TCM Doc-        asVar = do-          "* a variable bound at" TCP.<+> TCP.prettyTCM (nameBindingSite $ localVar x)-        shadowing :: LocalVar -> TCM Doc-        shadowing (LocalVar _ _ [])    = "shadowing"-        shadowing _ = "in conflict with"-    names   = TCP.vcat . map pName-    modules = TCP.vcat . map pMod--    pKind = \case-      ConName                  -> "constructor"-      CoConName                -> "coinductive constructor"-      FldName                  -> "record field"-      PatternSynName           -> "pattern synonym"-      GeneralizeName           -> "generalizable variable"-      DisallowedGeneralizeName -> "generalizable variable from let open"-      MacroName                -> "macro name"-      QuotableName             -> "quotable name"-      -- previously DefName:-      DataName                 -> "data type"-      RecName                  -> "record type"-      AxiomName                -> "postulate"-      PrimName                 -> "primitive function"-      FunName                  -> "defined name"-      OtherDefName             -> "defined name"--    pName :: AbstractName -> TCM Doc-    pName a = TCP.sep-      [ "* a"-        TCP.<+> pKind (anameKind a)-        TCP.<+> TCP.text (prettyShow $ anameName a)-      , TCP.nest 2 $ "brought into scope by"-      ] TCP.$$-      TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))-    pMod :: AbstractModule -> TCM Doc-    pMod  a = TCP.sep-      [ "* a module" TCP.<+> TCP.text (prettyShow $ amodName a)-      , TCP.nest 2 $ "brought into scope by"-      ] TCP.$$-      TCP.nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))--    pWhy :: Range -> WhyInScope -> TCM Doc-    pWhy r Defined = "- its definition at" TCP.<+> TCP.prettyTCM r-    pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w-    pWhy r (Opened m w) =-      "- the opening of"-      TCP.<+> TCP.prettyTCM m-      TCP.<+> "at"-      TCP.<+> TCP.prettyTCM (getRange m)-      TCP.$$-      pWhy r w-    pWhy r (Applied m w) =-      "- the application of"-      TCP.<+> TCP.prettyTCM m-      TCP.<+> "at"-      TCP.<+> TCP.prettyTCM (getRange m)-      TCP.$$-      pWhy r w-  -- | Pretty-prints the context of the given meta-variable.
src/full/Agda/Interaction/ExitCode.hs view
@@ -12,6 +12,7 @@ data AgdaError = UnknownError      -- ^ 1                | TCMError          -- ^ 42                | OptionError       -- ^ 71+               | CommandError      -- ^ 113                | ImpossibleError   -- ^ 154                deriving (Show, Eq, Enum, Bounded) @@ -19,6 +20,7 @@ agdaErrorToInt UnknownError    = 1 agdaErrorToInt TCMError        = 42 agdaErrorToInt OptionError     = 71+agdaErrorToInt CommandError    = 113 agdaErrorToInt ImpossibleError = 154  -- ^ Return the error corresponding to an exit code from the@@ -30,5 +32,5 @@                                | error  <- [minBound..maxBound]                                ] -exitAgdaWith :: AgdaError -> IO ()+exitAgdaWith :: AgdaError -> IO a exitAgdaWith = exitWith . ExitFailure . agdaErrorToInt
src/full/Agda/Interaction/FindFile.hs view
@@ -25,6 +25,7 @@ import Control.Monad.Trans import Data.Maybe (catMaybes) import qualified Data.Map as Map+import qualified Data.Text as T import System.FilePath  import Agda.Interaction.Library ( findProjectRoot )@@ -33,6 +34,7 @@ import Agda.Syntax.Parser import Agda.Syntax.Parser.Literate (literateExtsShortList) import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName  import Agda.Interaction.Options ( optLocalInterfaces ) @@ -41,6 +43,7 @@ import qualified Agda.TypeChecking.Monad.Benchmark as Bench import {-# SOURCE #-} Agda.TypeChecking.Monad.Options   (getIncludeDirs, libToTCM)+import Agda.TypeChecking.Monad.State (topLevelModuleName) import Agda.TypeChecking.Warnings (runPM)  import Agda.Version ( version )@@ -248,10 +251,12 @@   -> Module      -- ^ The parsed module.   -> TCM TopLevelModuleName-moduleName file parsedModule = billTo [Bench.ModuleName] $-  case moduleNameParts name of-    "_" :| [] -> do-      m <- runPM (parse moduleNameParser defaultName)+moduleName file parsedModule = billTo [Bench.ModuleName] $ do+  let defaultName = rootNameModule file+      raw         = rawTopLevelModuleNameForModule parsedModule+  topLevelModuleName =<< if isNoName raw+    then do+      m <- runPM (fst <$> parse moduleNameParser defaultName)              `catchError` \_ ->            typeError $ GenericError $              "The file name " ++ prettyShow file ++@@ -262,11 +267,11 @@             "The file name " ++ prettyShow file ++ " is invalid because " ++             defaultName ++ " is not an unqualified module name."         QName {} ->-          return $ TopLevelModuleName (getRange m) $ singleton defaultName-    _ -> return name-  where-  name        = topLevelModuleName parsedModule-  defaultName = rootNameModule file+          return $ RawTopLevelModuleName+            { rawModuleNameRange = getRange m+            , rawModuleNameParts = singleton (T.pack defaultName)+            }+    else return raw  parseFileExtsShortList :: [String] parseFileExtsShortList = ".agda" : literateExtsShortList
src/full/Agda/Interaction/Highlighting/Dot/Backend.hs view
@@ -3,11 +3,7 @@   ( dotBackend   ) where -import Agda.Interaction.Highlighting.Dot.Base-  ( dottify-  , renderDotToFile-  , Env(Env, deConnections, deLabel)-  )+import Agda.Interaction.Highlighting.Dot.Base (renderDotToFile)  import Control.Monad.Except   ( ExceptT@@ -19,8 +15,10 @@   ) import Control.DeepSeq -import Data.Map ( Map )-import Data.Set ( Set )+import Data.HashSet (HashSet)+import Data.Map (Map)+import Data.Set (Set)+import qualified Data.HashSet as HashSet import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe@@ -31,27 +29,38 @@ import Agda.Compiler.Backend (Backend(..), Backend'(..), Definition, Recompile(..)) import Agda.Compiler.Common (curIF, IsMain) +import Agda.Interaction.FindFile (findFile, srcFilePath)+import Agda.Interaction.Library import Agda.Interaction.Options   ( ArgDescr(ReqArg)   , Flag   , OptDescr(..)   ) -import Agda.Syntax.Abstract ( ModuleName )+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)  import Agda.TypeChecking.Monad   ( Interface(iImportedModules, iModuleName)   , MonadTCError   , ReadTCState+  , MonadTCM(..)   , genericError+  , reportSDoc+  , getAgdaLibFiles   )+import Agda.TypeChecking.Pretty +import Agda.Utils.Graph.AdjacencyMap.Unidirectional+  (Graph, WithUniqueInt)+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph import Agda.Utils.Pretty ( prettyShow )  -- ------------------------------------------------------------------------  data DotFlags = DotFlags   { dotFlagDestination :: Maybe FilePath+  , dotFlagLibraries   :: Maybe (HashSet String)+    -- ^ Only include modules from the given libraries.   } deriving (Eq, Generic)  instance NFData DotFlags@@ -59,27 +68,43 @@ defaultDotFlags :: DotFlags defaultDotFlags = DotFlags   { dotFlagDestination = Nothing+  , dotFlagLibraries   = Nothing   }  dotFlagsDescriptions :: [OptDescr (Flag DotFlags)] dotFlagsDescriptions =   [ Option [] ["dependency-graph"] (ReqArg dependencyGraphFlag "FILE")               "generate a Dot file with a module dependency graph"+  , Option [] ["dependency-graph-include"]+      (ReqArg includeFlag "LIBRARY")+      "include modules from the given library (default: all modules)"   ]  dependencyGraphFlag :: FilePath -> Flag DotFlags dependencyGraphFlag f o = return $ o { dotFlagDestination = Just f } +includeFlag :: String -> Flag DotFlags+includeFlag l o = return $+  o { dotFlagLibraries =+        case dotFlagLibraries o of+          Nothing -> Just (HashSet.singleton l)+          Just s  -> Just (HashSet.insert l s)+    }+ data DotCompileEnv = DotCompileEnv-  { _dotCompileEnvDestination :: FilePath+  { dotCompileEnvDestination :: FilePath+  , dotCompileEnvLibraries   :: Maybe (HashSet String)+    -- ^ Only include modules from the given libraries.   }  -- Currently unused data DotModuleEnv = DotModuleEnv  data DotModule = DotModule-  { _dotModuleName :: ModuleName-  , dotModuleImportedNames :: Set ModuleName+  { dotModuleName          :: TopLevelModuleName+  , dotModuleImportedNames :: Set TopLevelModuleName+  , dotModuleInclude       :: Bool+    -- ^ Include the module in the graph?   }  -- | Currently unused@@ -112,14 +137,19 @@   :: MonadError String m   => DotFlags   -> m DotCompileEnv-preCompileDot (DotFlags (Just dest)) = return $ DotCompileEnv dest-preCompileDot (DotFlags Nothing)     = throwError "The Dot backend was invoked without being enabled!"+preCompileDot d = case dotFlagDestination d of+  Just dest -> return $ DotCompileEnv+    { dotCompileEnvDestination = dest+    , dotCompileEnvLibraries   = dotFlagLibraries d+    }+  Nothing ->+    throwError "The Dot backend was invoked without being enabled!"  preModuleDot   :: Applicative m   => DotCompileEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath   -> m (Recompile DotModuleEnv DotModule) preModuleDot _cenv _main _moduleName _ifacePath = pure $ Recompile DotModuleEnv@@ -134,28 +164,83 @@ compileDefDot _cenv _menv _main _def = pure DotDef  postModuleDot-  :: (MonadIO m, ReadTCState m)+  :: (MonadTCM m, ReadTCState m)   => DotCompileEnv   -> DotModuleEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> [DotDef]   -> m DotModule-postModuleDot _cenv DotModuleEnv _main moduleName _defs = do+postModuleDot cenv DotModuleEnv _main m _defs = do   i <- curIF   let importedModuleNames = Set.fromList $ fst <$> (iImportedModules i)-  return $ DotModule moduleName importedModuleNames+  include <- case dotCompileEnvLibraries cenv of+    Nothing -> return True+    Just ls -> liftTCM $ do+      f    <- findFile m+      libs <- getAgdaLibFiles (srcFilePath f) m +      let incLibs = filter (\l -> _libName l `HashSet.member` ls) libs+          inLib   = not (null incLibs)++      reportSDoc "dot.include" 10 $ do+        let name = pretty m+            list = nest 2 . vcat . map (text . _libName)+        if inLib then+          fsep+            ([ "Including"+             , name+             ] +++             pwords "because it is in the following libraries:") $$+          list incLibs+        else+          fsep+            (pwords "Not including" +++             [name <> ","] +++             pwords "which is in the following libraries:") $$+          list libs++      return inLib++  return $ DotModule+    { dotModuleName          = m+    , dotModuleImportedNames = importedModuleNames+    , dotModuleInclude       = include+    }+ postCompileDot   :: (MonadIO m, ReadTCState m)   => DotCompileEnv   -> IsMain-  -> Map ModuleName DotModule+  -> Map TopLevelModuleName DotModule   -> m ()-postCompileDot (DotCompileEnv fp) _main modulesByName = do-  let env = Env-        { deConnections = (maybe [] (Set.toList . dotModuleImportedNames) . (flip Map.lookup modulesByName))-        , deLabel       = L.pack . prettyShow-        }-  dot <- dottify env . iModuleName <$> curIF-  renderDotToFile dot fp+postCompileDot cenv _main modulesByName =+  renderDotToFile moduleGraph (dotCompileEnvDestination cenv)+  where+  -- Only the keys of this map are used.+  modulesToInclude =+    Map.filter dotModuleInclude modulesByName++  moduleGraph :: Graph (WithUniqueInt L.Text) ()+  moduleGraph =+    Graph.renameNodesMonotonic (fmap (L.pack . prettyShow)) $+    Graph.transitiveReduction $+    Graph.filterNodesKeepingEdges+      (\n -> Graph.otherValue n `Map.member` modulesToInclude) $+    -- The following use of transitive reduction should not affect the+    -- semantics. It tends to make the graph smaller, so it might+    -- improve the overall performance of the code, but I did not+    -- verify this.+    Graph.transitiveReduction $+    Graph.addUniqueInts $+    Graph.fromEdges $+    concatMap+       (\ (name, m) ->+          [ Graph.Edge+              { source = name+              , target = target+              , label  = ()+              }+          | target <- Set.toList $ dotModuleImportedNames m+          ]) $+    Map.toList modulesByName
src/full/Agda/Interaction/Highlighting/Dot/Base.hs view
@@ -2,129 +2,45 @@ -- | Generate an import dependency graph for a given module.  module Agda.Interaction.Highlighting.Dot.Base-  ( dottify-  , renderDotToFile+  ( renderDotToFile   , renderDot-  , DotGraph (..)-  , Env(..)+  , DotGraph   ) where -import Control.Monad          (liftM2, when)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Reader   (ReaderT, runReaderT, ask)-import Control.Monad.State    (State, execState, get, modify, put)--import qualified Data.Map as M-import Data.Map(Map)+import Control.Monad.IO.Class +import qualified Data.Map.Strict as M import qualified Data.Set as S-import Data.Set (Set)  import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Encoding as E import qualified Data.ByteString.Lazy as BS --- | Internal module identifiers for construction of dependency graph.-type NodeId = L.Text+import Agda.Utils.Graph.AdjacencyMap.Unidirectional+  (Graph, WithUniqueInt)+import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph  -- | Graph structure-data DotGraph = DotGraph-  { dgNodeLabels :: Map NodeId L.Text-  , dgEdges      :: Set (NodeId, NodeId)-  }---- * Graph construction monad---- Read-only environment when constructing the graph.-data Env n where-  Env :: Ord n =>-    { deConnections :: n -> [n]-    -- ^ Names connected to an entity-    , deLabel       :: n -> L.Text-    -- ^ Rendering that entity's name to a label-    } -> Env n--data DotState n = DotState-  { dsNodeIds      :: Map n NodeId-    -- ^ Records already processed entities-    --   and maps them to an internal identifier.-  , dsNodeIdSupply :: [NodeId]-    -- ^ Supply of internal identifiers.-  , dsGraph        :: DotGraph-  }--initialDotState :: DotState n-initialDotState = DotState-  { dsNodeIds      = M.empty-  , dsNodeIdSupply = map (L.pack . ('m':) . show) [0..]-  , dsGraph        = DotGraph mempty mempty-  }--type DotM n a = ReaderT (Env n) (State (DotState n)) a--runDotM :: Env n -> DotM n x -> DotGraph-runDotM env@Env{} = dsGraph . flip execState initialDotState . flip runReaderT env--getLabel :: n -> DotM n L.Text-getLabel = liftM2 deLabel ask . pure--getConnections :: n -> DotM n [n]-getConnections = liftM2 deConnections ask . pure---- | Translate an entity name into an internal 'NodeId'.---   Returns @True@ if the 'ModuleName' is new, i.e., has not been---   encountered before and is thus added to the map of processed modules.-addEntity :: Ord n => n -> DotM n (NodeId, Bool)-addEntity name = do-    s@(DotState nodeIds nodeIdSupply graph) <- get-    case M.lookup name nodeIds of-        Just nodeId  -> return (nodeId, False)-        Nothing -> do-            let newNodeId:remainingNodeIdSupply = nodeIdSupply-            label <- getLabel name-            put s-              { dsNodeIds      = M.insert name newNodeId nodeIds-              , dsNodeIdSupply = remainingNodeIdSupply-              , dsGraph        = graph-                { dgNodeLabels = M.insert newNodeId label . dgNodeLabels $ graph-                }-              }-            return (newNodeId, True)---- | Add an arc from importer to imported.-addConnection :: NodeId -> NodeId -> DotM n ()-addConnection m1 m2 = modify $ \s -> s-  { dsGraph = (dsGraph s)-    { dgEdges = S.insert (m1, m2) . dgEdges . dsGraph $ s-    }-  }--dottify :: Ord n => Env n -> n -> DotGraph-dottify env root = runDotM env (dottify' root)--dottify' :: Ord n => n -> DotM n NodeId-dottify' entity = do-  (nodeId, continue) <- addEntity entity-  -- If we have not visited this interface yet,-  -- process its imports recursively and-  -- add them as connections to the graph.-  when continue $ do-    connectedEntities <- getConnections entity-    connectedNodeIds <- mapM dottify' connectedEntities-    mapM_ (addConnection nodeId) connectedNodeIds-  return nodeId+type DotGraph = Graph (WithUniqueInt L.Text) ()  -- * Graph rendering  renderDot :: DotGraph -> L.Text renderDot g = L.unlines $ concat   [ [ "digraph dependencies {" ]-  , [ L.concat ["   ", nodeId, "[label=\"", label, "\"];"]-    | (nodeId, label) <- M.toList (dgNodeLabels g) ]-  , [ L.concat ["   ", r1, " -> ", r2, ";"]-    | (r1 , r2) <- S.toList (dgEdges g) ]+  , [ L.concat ["   ", show' nodeId, "[label=\"", label, "\"];"]+    | Graph.WithUniqueInt nodeId label <- S.toList $ Graph.nodes g+    ]+  , [ L.concat ["   ", show' r1, " -> ", show' r2, ";"]+    | Graph.Edge+        { source = Graph.WithUniqueInt r1 _+        , target = Graph.WithUniqueInt r2 _+        } <- Graph.edges g+    ]   , ["}"]   ]+  where+  show' = L.pack . ("m" ++) . show  renderDotToFile :: MonadIO m => DotGraph -> FilePath -> m () renderDotToFile dot fp = liftIO $ BS.writeFile fp $ E.encodeUtf8 $ renderDot dot
src/full/Agda/Interaction/Highlighting/FromAbstract.hs view
@@ -35,6 +35,7 @@ import qualified Agda.Syntax.Position      as P import           Agda.Syntax.Position                ( Range, HasRange, getRange, noRange ) import           Agda.Syntax.Scope.Base              ( AbstractName(..), ResolvedName(..), exactConName )+import           Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad   hiding (ModuleInfo, MetaInfo, Primitive, Constructor, Record, Function, Datatype)@@ -49,29 +50,29 @@ import qualified Agda.Utils.Maybe.Strict   as Strict import           Agda.Utils.Pretty import           Agda.Utils.Singleton+import           Agda.Utils.Size  -- Entry point: -- | Create highlighting info for some piece of syntax.-runHighlighter ::-  Hilite a =>-  SourceToModule -> AbsolutePath -> NameKinds -> a ->-  HighlightingInfoBuilder-runHighlighter modMap fileName kinds x =+runHighlighter+  :: Hilite a+  => TopLevelModuleName+     -- ^ The current top-level module's name.+  -> NameKinds -> a -> HighlightingInfoBuilder+runHighlighter top kinds x =   runReader (hilite x) $   HiliteEnv-    { hleNameKinds = kinds-    , hleModMap    = modMap-    , hleFileName  = fileName+    { hleNameKinds         = kinds+    , hleCurrentModuleName = top     }  -- | Environment of the highlighter. data HiliteEnv = HiliteEnv   { hleNameKinds :: NameKinds       -- ^ Function mapping qualified names to their kind.-  , hleModMap    :: SourceToModule-      -- ^ Maps source file paths to module names.-  , hleFileName  :: AbsolutePath-      -- ^ The file name of the current module. Used for consistency checking.+  , hleCurrentModuleName :: TopLevelModuleName+      -- ^ The current top-level module's name. Used for consistency+      -- checking.   }  -- | A function mapping names to the kind of name they stand for.@@ -214,6 +215,7 @@       A.PatternSynDef x xs p                 -> hl x <> hl xs <> hl p       A.UnquoteDecl _mi _di xs e             -> hl xs <> hl e       A.UnquoteDef _di xs e                  -> hl xs <> hl e+      A.UnquoteData _i xs _uc _j cs e        -> hl xs <> hl cs <> hl e       A.ScopedDecl s ds                      -> hl ds       A.Pragma _r pragma                     -> hl pragma     where@@ -230,6 +232,7 @@     A.StaticPragma x             -> hilite x     A.EtaPragma x                -> hilite x     A.InjectivePragma x          -> hilite x+    A.NotProjectionLikePragma x  -> hilite x     A.InlinePragma _inline x     -> hilite x     A.DisplayPragma x ps e       -> hilite x <> hilite ps <> hilite e @@ -250,12 +253,11 @@       A.WithApp _r e es             -> hl e <> hl es       A.Lam _r bs e                 -> hl bs <> hl e       A.AbsurdLam _r _h             -> mempty-      A.ExtendedLam _r _di _e _q cs -> hl cs -- No hilighting of generated extended lambda name!+      A.ExtendedLam _r _di er _q cs -> hl er <> hl cs -- No hilighting of generated extended lambda name!       A.Pi _r tel b                 -> hl tel <> hl b       A.Generalized _qs e           -> hl e       A.Fun _r a b                  -> hl a <> hl b       A.Let _r bs e                 -> hl bs <> hl e-      A.ETel _tel                   -> mempty  -- Printing only construct       A.Rec _r ass                  -> hl ass       A.RecUpdate _r e ass          -> hl e <> hl ass       A.ScopedExpr _ e              -> hl e@@ -333,7 +335,7 @@   hilite (A.ProblemEq p _t _dom) = hilite p  instance Hilite A.WhereDeclarations where-  hilite (A.WhereDecls m ds) = hilite m <> hilite ds+  hilite (A.WhereDecls m _ ds) = hilite m <> hilite ds  instance Hilite A.GeneralizeTelescope where   hilite (A.GeneralizeTel _gen tel) = hilite tel@@ -356,6 +358,9 @@     where     hl x = hilite x +instance Hilite A.TypedBindingInfo where+  hilite (A.TypedBindingInfo x _) = hilite x+ instance Hilite A.TypedBinding where   hilite = \case     A.TBind _r tac binds e -> hilite tac <> hilite binds <> hilite e@@ -394,6 +399,10 @@ instance Hilite Quantity where   hilite = singleAspect Symbol +-- | Erasure attributes are highlighted as symbols.+instance Hilite Erased where+  hilite = singleAspect Symbol+ instance Hilite ModuleInfo where   hilite (ModuleInfo _r rAsTo asName _open _impDir)     =  singleAspect Symbol rAsTo            -- TODO: 'to' already covered by A.ImportDirective@@ -450,17 +459,14 @@   hilite = hiliteAmbiguousQName Nothing  instance Hilite A.ModuleName where-  hilite m@(A.MName xs) = do-    modMap <- asks hleModMap-    hiliteModule (isTopLevelModule modMap, m)+  hilite m@(A.MName xs) = hiliteModule (isTopLevelModule, m)     where-    isTopLevelModule modMap =-      case mapMaybe-          ((Strict.toLazy . P.srcFile) <=< (P.rStart . A.nameBindingSite)) xs of-        f : _ ->-          Map.lookup f modMap-            == Just (C.toTopLevelModuleName $ A.mnameToConcrete m)-        [] -> False+    isTopLevelModule =+      case mapMaybe (P.rangeModule . A.nameBindingSite) xs of+        []      -> False+        top : _ ->+          rawTopLevelModuleName top ==+          rawTopLevelModuleNameForModuleName m    -- Andreas, 2020-09-29, issue #4952. -- The target of a @renaming@ clause needs to be highlighted in a special way.@@ -563,36 +569,34 @@      --   The argument is 'True' iff the name is an operator.   -> Hiliter hiliteCName xs x fr mR asp = do-  HiliteEnv _ modMap fileName <- ask+  env <- ask   -- We don't care if we get any funny ranges.-  if all (== Strict.Just fileName) fileNames then pure $-    frFile modMap <>-    H.singleton (rToR rs)-                (aspects { definitionSite = mFilePos modMap })-   else-    mempty+  if all (== Just (hleCurrentModuleName env)) moduleNames+  then pure $+    frFile <>+    H.singleton (rToR rs) (aspects { definitionSite = mFilePos })+  else mempty   where-  aspects       = asp $ C.isOperator x-  fileNames     = mapMaybe (fmap P.srcFile . P.rStart . getRange) (x : xs)-  frFile modMap = H.singleton (rToR fr) (aspects { definitionSite = notHere <$> mFilePos modMap })-  rs            = getRange (x : xs)+  aspects     = asp $ C.isOperator x+  moduleNames = mapMaybe (P.rangeModule' . getRange) (x : xs)+  frFile      = H.singleton (rToR fr) $+                aspects { definitionSite = notHere <$> mFilePos }+  rs          = getRange (x : xs)    -- The fixity declaration should not get a symbolic anchor.   notHere d = d { defSiteHere = False } -  mFilePos-    :: SourceToModule  -- Maps source file paths to module names.-    -> Maybe DefinitionSite-  mFilePos modMap = do+  mFilePos :: Maybe DefinitionSite+  mFilePos = do     r <- mR     P.Pn { P.srcFile = Strict.Just f, P.posPos = p } <- P.rStart r-    mod <- Map.lookup f modMap+    mod <- P.rangeFileName f     -- Andreas, 2017-06-16, Issue #2604: Symbolic anchors.     -- We drop the file name part from the qualifiers, since     -- this is contained in the html file name already.     -- We want to get anchors of the form:     -- @<a name="TopLevelModule.html#LocalModule.NestedModule.identifier">@-    let qualifiers = drop (length $ C.moduleNameParts mod) xs+    let qualifiers = drop (size mod) xs     -- For bound variables, we do not create symbolic anchors.         local = maybe True isLocalAspect $ aspect aspects     return $ DefinitionSite@@ -640,13 +644,13 @@      -- ^ The argument is 'True' iff the name is an operator.   -> Hiliter hiliteAName x include asp = do-  fileName <- asks hleFileName+  currentModule <- asks hleCurrentModuleName   hiliteCName (concreteQualifier x)               (concreteBase x)-              (rangeOfFixityDeclaration fileName)+              (rangeOfFixityDeclaration currentModule)               (if include then Just $ bindingSite x else Nothing)               asp-    <> (notationFile fileName)+    <> notationFile currentModule   where   -- TODO: Currently we highlight fixity and syntax declarations by   -- producing highlighting something like once per occurrence of the@@ -654,14 +658,14 @@   -- avoid doing this for other files). Perhaps it would be better to   -- only produce this highlighting once. -  rangeOfFixityDeclaration fileName =-    if P.rangeFile r == Strict.Just fileName+  rangeOfFixityDeclaration currentModule =+    if P.rangeModule r == Just currentModule     then r else noRange     where     r = theNameRange $ A.nameFixity $ A.qnameName x -  notationFile fileName = pure $-    if P.rangeFile (getRange notation) == Strict.Just fileName+  notationFile currentModule = pure $+    if P.rangeModule (getRange notation) == Just currentModule     then mconcat $ map genPartFile notation     else mempty     where@@ -669,10 +673,10 @@      boundAspect = nameAsp Bound False -    genPartFile (BindHole r i)   = several [rToR r, rToR $ getRange i] boundAspect-    genPartFile (NormalHole r i) = several [rToR r, rToR $ getRange i] boundAspect-    genPartFile WildHole{}       = mempty-    genPartFile (IdPart x)       = H.singleton (rToR $ getRange x) (asp False)+    genPartFile (VarPart r i)  = several [rToR r, rToR $ getRange i] boundAspect+    genPartFile (HolePart r i) = several [rToR r, rToR $ getRange i] boundAspect+    genPartFile WildPart{}     = mempty+    genPartFile (IdPart x)     = H.singleton (rToR $ getRange x) (asp False)  -- * Short auxiliary functions. ---------------------------------------------------------------------------
src/full/Agda/Interaction/Highlighting/Generate.hs view
@@ -64,7 +64,9 @@ import qualified Agda.Syntax.Parser as Pa import qualified Agda.Syntax.Parser.Tokens as T import qualified Agda.Syntax.Position as P-import Agda.Syntax.Position (Range, HasRange, getRange, noRange)+import Agda.Syntax.Position+  (RangeFile, Range, HasRange, getRange, noRange)+import Agda.Syntax.TopLevelModuleName  import Agda.Syntax.Scope.Base     ( WithKind(..) ) import Agda.Syntax.Abstract.Views ( KName, declaredNames )@@ -127,19 +129,19 @@   -> TCM () generateAndPrintSyntaxInfo decl _ _ | null $ getRange decl = return () generateAndPrintSyntaxInfo decl hlLevel updateState = do-  file <- getCurrentPath+  top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule -  reportSLn "import.iface.create" 15 $ concat-    [ "Generating syntax info for "-    , filePath file-    , case hlLevel of-        Full   {} -> " (final)."-        Partial{} -> " (first approximation)."-    ]+  reportSDoc "import.iface.create" 15 $+    TCM.fwords+      ("Generating syntax info for the following declaration " +++       case hlLevel of+         Full   {} -> "(final):"+         Partial{} -> "(first approximation):")+      TCM.$$+    TCM.prettyA decl    ignoreAbstractMode $ do-    modMap <- sourceToModule-    kinds  <- nameKinds hlLevel decl+    kinds <- nameKinds hlLevel decl      -- After the code has been type checked more information may be     -- available for overloaded constructors, and@@ -147,11 +149,11 @@     -- Note, however, that highlighting for overloaded constructors is     -- included also in @nameInfo@.     constructorInfo <- case hlLevel of-      Full{} -> generateConstructorInfo modMap file kinds decl+      Full{} -> generateConstructorInfo top kinds decl       _      -> return mempty      -- Main source of scope-checker generated highlighting:-    let nameInfo = runHighlighter modMap file kinds decl+    let nameInfo = runHighlighter top kinds decl      reportSDoc "highlighting.warning" 60 $ TCM.hcat       [ "current path = "@@ -184,21 +186,31 @@  generateTokenInfo :: AbsolutePath -> TCM HighlightingInfo generateTokenInfo file =-  generateTokenInfoFromSource file . Text.unpack =<<-    runPM (Pa.readFilePM file)+  generateTokenInfoFromSource rf . Text.unpack =<<+    runPM (Pa.readFilePM rf)+  where+  -- Note the use of Nothing here. The file might not even parse, but+  -- it should still be possible to obtain token-based highlighting+  -- information. The top-level module names seem to be *mostly*+  -- unused, but one cannot use __IMPOSSIBLE__ instead of Nothing,+  -- because the top-level module names are used by interleaveRanges,+  -- which is used by parseLiterateWithComments, which is used by+  -- generateTokenInfoFromSource.+  rf = P.mkRangeFile file Nothing  -- | Generate and return the syntax highlighting information for the -- tokens in the given file.  generateTokenInfoFromSource-  :: AbsolutePath+  :: RangeFile      -- ^ The module to highlight.   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.   -> TCM HighlightingInfo generateTokenInfoFromSource file input =-  runPM $ tokenHighlighting . fst <$> Pa.parseFile Pa.tokensParser file input+  runPM $ tokenHighlighting . fst . fst <$>+          Pa.parseFile Pa.tokensParser file input  -- | Generate and return the syntax highlighting information for the -- tokens in the given string, which is assumed to correspond to the@@ -207,7 +219,8 @@ generateTokenInfoFromString :: Range -> String -> TCM HighlightingInfo generateTokenInfoFromString r _ | r == noRange = return mempty generateTokenInfoFromString r s = do-  runPM $ tokenHighlighting <$> Pa.parsePosString Pa.tokensParser p s+  runPM $ tokenHighlighting . fst <$>+          Pa.parsePosString Pa.tokensParser p s   where     Just p = P.rStart r @@ -323,12 +336,12 @@ -- the type checker.  generateConstructorInfo-  :: SourceToModule  -- ^ Maps source file paths to module names.-  -> AbsolutePath    -- ^ The module to highlight.+  :: TopLevelModuleName+     -- ^ The module to highlight.   -> NameKinds   -> A.Declaration   -> TCM HighlightingInfoBuilder-generateConstructorInfo modMap file kinds decl = do+generateConstructorInfo top kinds decl = do    -- Get boundaries of current declaration.   -- @noRange@ should be impossible, but in case of @noRange@@@ -345,7 +358,7 @@         constrs = IntMap.elems m2      -- Return suitable syntax highlighting information.-    return $ foldMap (runHighlighter modMap file kinds) constrs+    return $ foldMap (runHighlighter top kinds) constrs  printSyntaxInfo :: Range -> TCM () printSyntaxInfo r = do@@ -460,9 +473,11 @@   RewriteMissingRule{}       -> confluenceErrorHighlighting w   PragmaCompileErased{}      -> deadcodeHighlighting w   NotInScopeW{}              -> deadcodeHighlighting w+  UnsupportedIndexedMatch{}  -> mempty   AsPatternShadowsConstructorOrPatternSynonym{}                              -> deadcodeHighlighting w   RecordFieldWarning w       -> recordFieldWarningHighlighting w+  OptionWarning w            -> mempty   ParseWarning w             -> case w of     Pa.UnsupportedAttribute{}     -> deadcodeHighlighting w     Pa.MultipleAttributes{}       -> deadcodeHighlighting w@@ -482,6 +497,12 @@     EmptyPrivate{}                   -> deadcodeHighlighting w     EmptyGeneralize{}                -> deadcodeHighlighting w     EmptyField{}                     -> deadcodeHighlighting w+    HiddenGeneralize{}               -> mempty+      -- Andreas, 2022-03-25, issue #5850+      -- We would like @deadcodeHighlighting w@ for the braces in+      -- @variable {x} : A@, but these have no range, so we cannot highlight them.+      -- Highlighting the variable instead might be misleading,+      -- suggesting that it is not generalized over.     UselessAbstract{}                -> deadcodeHighlighting w     UselessInstance{}                -> deadcodeHighlighting w     UselessPrivate{}                 -> deadcodeHighlighting w@@ -530,7 +551,7 @@     functionDefs = foldMap (\x -> H.singleton (rToR $ bindingSite x) m) $                    concatMap termErrFunctions termErrs     callSites    = foldMap (\r -> H.singleton (rToR r) m) $-                   concatMap (map callInfoRange . termErrCalls) termErrs+                   concatMap (map getRange . termErrCalls) termErrs     bindingSite  = A.nameBindingSite . A.qnameName  -- | Generate syntax highlighting for not-strictly-positive inductive
src/full/Agda/Interaction/Highlighting/HTML/Backend.hs view
@@ -25,7 +25,7 @@ import Agda.Compiler.Backend (Backend(..), Backend'(..), Recompile(..)) import Agda.Compiler.Common (IsMain(..), curIF) -import Agda.Syntax.Abstract (ModuleName, toTopLevelModuleName)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)  import Agda.TypeChecking.Monad   ( MonadDebug@@ -52,7 +52,7 @@  data HtmlModuleEnv = HtmlModuleEnv   { htmlModEnvCompileEnv :: HtmlCompileEnv-  , htmlModEnvName       :: ModuleName+  , htmlModEnvName       :: TopLevelModuleName   }  data HtmlModule = HtmlModule@@ -164,7 +164,7 @@   :: Applicative m   => HtmlCompileEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath   -> m (Recompile HtmlModuleEnv HtmlModule) preModuleHtml cenv _isMain modName _ifacePath = pure $ Recompile (HtmlModuleEnv cenv modName)@@ -183,12 +183,12 @@   => HtmlCompileEnv   -> HtmlModuleEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> [HtmlDef]   -> m HtmlModule postModuleHtml _env menv _isMain _modName _defs = do   let generatePage = defaultPageGen . htmlCompileEnvOpts . htmlModEnvCompileEnv $ menv-  htmlSrc <- srcFileOfInterface (toTopLevelModuleName . htmlModEnvName $ menv) <$> curIF+  htmlSrc <- srcFileOfInterface (htmlModEnvName menv) <$> curIF   runLogHtmlWithMonadDebug $ generatePage htmlSrc   return HtmlModule @@ -196,6 +196,6 @@   :: Applicative m   => HtmlCompileEnv   -> IsMain-  -> Map ModuleName HtmlModule+  -> Map TopLevelModuleName HtmlModule   -> m () postCompileHtml _cenv _isMain _modulesByName = pure ()
src/full/Agda/Interaction/Highlighting/HTML/Base.hs view
@@ -54,8 +54,8 @@  import Agda.Interaction.Highlighting.Precise hiding (toList) -import qualified Agda.Syntax.Concrete as C import Agda.Syntax.Common+import Agda.Syntax.TopLevelModuleName  import qualified Agda.TypeChecking.Monad as TCM   ( Interface(..)@@ -137,7 +137,7 @@ -- | Internal type bundling the information related to a module source file  data HtmlInputSourceFile = HtmlInputSourceFile-  { _srcFileModuleName :: C.TopLevelModuleName+  { _srcFileModuleName :: TopLevelModuleName   , _srcFileType :: FileType   -- ^ Source file type   , _srcFileText :: Text@@ -148,7 +148,8 @@  -- | Bundle up the highlighting info for a source file -srcFileOfInterface :: C.TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile+srcFileOfInterface ::+  TopLevelModuleName -> TCM.Interface -> HtmlInputSourceFile srcFileOfInterface m i = HtmlInputSourceFile m (TCM.iFileType i) (TCM.iSource i) (TCM.iHighlighting i)  -- | Logging during HTML generation@@ -213,7 +214,7 @@  -- | Converts module names to the corresponding HTML file names. -modToFile :: C.TopLevelModuleName -> String -> FilePath+modToFile :: TopLevelModuleName -> String -> FilePath modToFile m ext = Network.URI.Encode.encode $ render (pretty m) <.> ext  -- | Generates a highlighted, hyperlinked version of the given module.@@ -236,7 +237,7 @@ page :: FilePath              -- ^ URL to the CSS file.      -> Bool                  -- ^ Highlight occurrences      -> Bool                  -- ^ Whether to reserve literate-     -> C.TopLevelModuleName  -- ^ Module to be highlighted.+     -> TopLevelModuleName    -- ^ Module to be highlighted.      -> Html      -> Text page css
src/full/Agda/Interaction/Highlighting/LaTeX/Backend.hs view
@@ -35,8 +35,8 @@   , OptDescr(..)   ) -import Agda.Syntax.Abstract.Name (ModuleName, toTopLevelModuleName)-import Agda.Syntax.Concrete.Name (TopLevelModuleName, projectRoot)+import Agda.Syntax.Position (mkRangeFile, rangeFilePath)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName, projectRoot)  import Agda.TypeChecking.Monad   ( HasOptions(commandLineOptions)@@ -122,14 +122,18 @@   options <- commandLineOptions   modFiles <- useTC stModuleToSource   let-    mSrcFileName = (mkAbsolute . filePath) <$> Map.lookup moduleName modFiles+    mSrcFileName =+      (\f -> mkRangeFile (mkAbsolute (filePath f)) (Just moduleName)) <$>+      Map.lookup moduleName modFiles     countClusters = optCountClusters . optPragmaOptions $ options     latexDir = latexFlagOutDir flags     -- FIXME: This reliance on emacs-mode to decide whether to interpret the output location as project-relative or     -- cwd-relative is gross. Also it currently behaves differently for JSON mode :-/     -- And it prevents us from doing a real "one-time" setup.     outDir = case (mSrcFileName, optGHCiInteraction options) of-      (Just sourceFile, True) -> filePath (projectRoot sourceFile moduleName) </> latexDir+      (Just sourceFile, True) ->+        filePath (projectRoot (rangeFilePath sourceFile) moduleName) </>+        latexDir       _ -> latexDir   return LaTeXOptions     { latexOptOutDir         = outDir@@ -147,11 +151,11 @@   :: (HasOptions m, ReadTCState m)   => LaTeXCompileEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> Maybe FilePath   -> m (Recompile LaTeXModuleEnv LaTeXModule) preModuleLaTeX (LaTeXCompileEnv flags) isMain moduleName _ifacePath = case isMain of-  IsMain  -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags (toTopLevelModuleName moduleName)+  IsMain  -> Recompile . LaTeXModuleEnv <$> resolveLaTeXOptions flags moduleName   NotMain -> return $ Skip LaTeXModule  compileDefLaTeX@@ -168,7 +172,7 @@   => LaTeXCompileEnv   -> LaTeXModuleEnv   -> IsMain-  -> ModuleName+  -> TopLevelModuleName   -> [LaTeXDef]   -> m LaTeXModule postModuleLaTeX _cenv (LaTeXModuleEnv latexOpts) _main _moduleName _defs = do@@ -186,6 +190,6 @@   :: Applicative m   => LaTeXCompileEnv   -> IsMain-  -> Map ModuleName LaTeXModule+  -> Map TopLevelModuleName LaTeXModule   -> m () postCompileLaTeX _cenv _main _modulesByName = pure ()
src/full/Agda/Interaction/Highlighting/LaTeX/Base.hs view
@@ -20,12 +20,14 @@ import Data.Bifunctor (second) import Data.Char import Data.Maybe-import Data.Function+import Data.Function (on) import Data.Foldable (toList) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup (Semigroup(..)) #endif+import qualified Data.Text as T +import Control.Exception.Base (IOException, try) import Control.Monad (forM_, mapM_, unless, when) import Control.Monad.Trans.Reader as R ( ReaderT(runReaderT)) import Control.Monad.RWS.Strict@@ -59,22 +61,22 @@  import Paths_Agda -import Agda.Syntax.Abstract (toTopLevelModuleName) import Agda.Syntax.Common-import Agda.Syntax.Concrete (TopLevelModuleName, moduleNameParts) import Agda.Syntax.Parser.Literate (literateTeX, LayerRole, atomizeLayers) import qualified Agda.Syntax.Parser.Literate as L-import Agda.Syntax.Position (startPos)+import Agda.Syntax.Position (RangeFile, startPos)+import Agda.Syntax.TopLevelModuleName+  (TopLevelModuleName, moduleNameParts)  import Agda.Interaction.Highlighting.Precise hiding (toList) -import Agda.TypeChecking.Monad (Interface(..))+import Agda.TypeChecking.Monad (Interface(..)) --, reportSLn) -import Agda.Utils.FileName (AbsolutePath) import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor  ((<&>)) import Agda.Utils.List     (last1, updateHead, updateLast) import Agda.Utils.Maybe    (whenJust)+import Agda.Utils.Monad import qualified Agda.Utils.List1 as List1  import Agda.Utils.Impossible@@ -695,7 +697,7 @@  data LaTeXOptions = LaTeXOptions   { latexOptOutDir         :: FilePath-  , latexOptSourceFileName :: Maybe AbsolutePath+  , latexOptSourceFileName :: Maybe RangeFile     -- ^ The parser uses a @Position@ which includes a source filename for     -- error reporting and such. We don't actually get the source filename     -- with an @Interface@, and it isn't necessary to look it up.@@ -718,28 +720,45 @@ -- | Create the common base output directory and check for/install the style file. prepareCommonAssets :: (MonadLogLaTeX m, MonadIO m) => FilePath -> m () prepareCommonAssets dir = do-  liftIO $ createDirectoryIfMissing True dir-  (code, _, _) <--    liftIO $-      readProcessWithExitCode+  -- Make sure @dir@ will exist.+  dirExisted <- liftIO $ doesDirectoryExist dir+  unless dirExisted $+    -- Create directory @dir@ and parent directories.+    liftIO $ createDirectoryIfMissing True dir++  -- Check whether TeX will find @agda.sty@.+  texFindsSty <- liftIO $ try $+      readProcess         "kpsewhich"-        ["--path=" ++ dir, defaultStyFile]+        (applyWhen dirExisted (("--path=" ++ dir) :) [defaultStyFile])         ""-  when (code /= ExitSuccess) $ do-    logLaTeX $ LogMessage FileSystem-      (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir])-      []-    liftIO $ do-      styFile <- getDataFileName $-        latexDataDir </> defaultStyFile-      copyFile styFile (dir </> defaultStyFile)+  case texFindsSty of+    Right _ -> return ()+    Left (e :: IOException) -> do+     -- -- we are lacking MonadDebug here, so no debug printing via reportSLn+     -- reportSLn "compile.latex.sty" 70 $ unlines+     --   [ unwords [ "Searching for", defaultStyFile, "in", dir, "returns:" ]+     --   , show e+     --   ]+     let agdaSty = dir </> defaultStyFile+     unlessM (pure dirExisted `and2M` liftIO (doesFileExist agdaSty)) $ do+       -- It is safe now to create the default style file in @dir@ without overwriting+       -- a possibly user-edited copy there.+       logLaTeX $ LogMessage FileSystem+         (T.pack $ unwords [defaultStyFile, "was not found. Copying a default version of", defaultStyFile, "into", dir])+         []+       liftIO $ do+         styFile <- getDataFileName $+           latexDataDir </> defaultStyFile+         copyFile styFile agdaSty  -- | Generates a LaTeX file for the given interface. generateLaTeXIO :: (MonadLogLaTeX m, MonadIO m) => LaTeXOptions -> Interface -> m () generateLaTeXIO opts i = do   let textWidthEstimator = getTextWidthEstimator (latexOptCountClusters opts)   let baseDir = latexOptOutDir opts-  let outPath = baseDir </> (latexOutRelativeFilePath $ toTopLevelModuleName $ iModuleName i)+  let outPath = baseDir </>+                latexOutRelativeFilePath (iTopLevelModuleName i)   latex <- E.encodeUtf8 <$> toLaTeX               (emptyEnv textWidthEstimator)               (latexOptSourceFileName opts)@@ -750,7 +769,10 @@     BS.writeFile outPath latex  latexOutRelativeFilePath :: TopLevelModuleName -> FilePath-latexOutRelativeFilePath m = List.intercalate [pathSeparator] (List1.toList $ moduleNameParts m) <.> "tex"+latexOutRelativeFilePath m =+  List.intercalate [pathSeparator]+    (map T.unpack $ List1.toList $ moduleNameParts m) <.>+  "tex"  groupByFst :: forall a b. Eq a => [(a,b)] -> [(a,[b])] groupByFst =@@ -765,7 +787,7 @@ toLaTeX   :: MonadLogLaTeX m   => Env-  -> Maybe AbsolutePath+  -> Maybe RangeFile   -> L.Text   -> HighlightingInfo   -> m L.Text
src/full/Agda/Interaction/Highlighting/Precise.hs view
@@ -33,7 +33,7 @@ import Control.DeepSeq import Control.Monad -import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Semigroup@@ -51,7 +51,7 @@  import qualified Agda.Syntax.Position as P import qualified Agda.Syntax.Common   as Common-import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.TopLevelModuleName import Agda.Syntax.Scope.Base                   ( KindOfName(..) )  import Agda.Interaction.Highlighting.Range@@ -162,7 +162,7 @@   deriving (Show, Generic)  data DefinitionSite = DefinitionSite-  { defSiteModule :: C.TopLevelModuleName+  { defSiteModule :: TopLevelModuleName       -- ^ The defining module.   , defSitePos    :: Int       -- ^ The file position in that module. File positions are
src/full/Agda/Interaction/Imports.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE RecursiveDo #-}  {-| This module deals with finding imported modules and loading their     interface files.@@ -35,14 +37,15 @@ import Control.Monad.Fail (MonadFail) #endif -import Data.Either (lefts)-import qualified Data.Map as Map+import Data.Either import qualified Data.List as List-import Data.Set (Set)-import qualified Data.Set as Set import Data.Maybe import Data.Map (Map)+import qualified Data.Map as Map import qualified Data.HashMap.Strict as HMap+import qualified Data.HashSet as HSet+import Data.Set (Set)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.Lazy as TL @@ -53,12 +56,14 @@  import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Abstract.Name import Agda.Syntax.Common import Agda.Syntax.Parser import Agda.Syntax.Position import Agda.Syntax.Scope.Base-import Agda.Syntax.Translation.ConcreteToAbstract+import Agda.Syntax.TopLevelModuleName+import Agda.Syntax.Translation.ConcreteToAbstract as CToA  import Agda.TypeChecking.Errors import Agda.TypeChecking.Warnings hiding (warnings)@@ -94,8 +99,10 @@ import Agda.Utils.Null import Agda.Utils.IO.Binary import Agda.Utils.Pretty hiding (Mode)+import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Hash import qualified Agda.Utils.Trie as Trie+import Agda.Utils.WithDefault  import Agda.Utils.Impossible @@ -116,19 +123,27 @@   , srcFileType    :: FileType              -- ^ Source file type   , srcOrigin      :: SourceFile            -- ^ Source location at the time of its parsing   , srcModule      :: C.Module              -- ^ The parsed module.-  , srcModuleName  :: C.TopLevelModuleName  -- ^ The top-level module name.+  , srcModuleName  :: TopLevelModuleName    -- ^ The top-level module name.   , srcProjectLibs :: [AgdaLibFile]         -- ^ The .agda-lib file(s) of the project this file belongs to.+  , srcCohesion    :: !CohesionAttributes+    -- ^ Every encountered occurrence of a cohesion attribute.   }  -- | Parses a source file and prepares the 'Source' record.  parseSource :: SourceFile -> TCM Source parseSource sourceFile@(SourceFile f) = Bench.billTo [Bench.Parsing] $ do-  source                <- runPM $ readFilePM f-  (parsedMod, fileType) <- runPM $-                           parseFile moduleParser f $ TL.unpack source-  parsedModName         <- moduleName f parsedMod-  libs <- getAgdaLibFiles $ takeDirectory $ filePath f+  (source, fileType, parsedMod, coh, parsedModName) <- mdo+    -- This piece of code uses mdo because the top-level module name+    -- (parsedModName) is obtained from the parser's result, but it is+    -- also used by the parser.+    let rf = mkRangeFile f (Just parsedModName)+    source                       <- runPM $ readFilePM rf+    ((parsedMod, coh), fileType) <- runPM $ parseFile moduleParser rf $+                                    TL.unpack source+    parsedModName                <- moduleName f parsedMod+    return (source, fileType, parsedMod, coh, parsedModName)+  libs <- getAgdaLibFiles f parsedModName   return Source     { srcText        = source     , srcFileType    = fileType@@ -136,6 +151,7 @@     , srcModule      = parsedMod     , srcModuleName  = parsedModName     , srcProjectLibs = libs+    , srcCohesion    = coh     }  srcDefaultPragmas :: Source -> [OptionsPragma]@@ -196,10 +212,12 @@ mergeInterface i = do     let sig     = iSignature i         builtin = Map.toAscList $ iBuiltin i-        prim    = [ x | (_,Prim x) <- builtin ]-        bi      = Map.fromDistinctAscList [ (x, Builtin t) | (x, Builtin t) <- builtin ]-                    -- Andreas, 2021-08-19: this seeming identity filters out the @Prim@s-                    -- and converts the type.+        primOrBi = \case+          (_, Prim x)                     -> Left x+          (x, Builtin t)                  -> Right (x, Builtin t)+          (x, BuiltinRewriteRelations xs) -> Right (x, BuiltinRewriteRelations xs)+        (prim, bi') = partitionEithers $ map primOrBi builtin+        bi      = Map.fromDistinctAscList bi'         warns   = iWarnings i     bs <- getsTC stBuiltinThings     reportSLn "import.iface.merge" 10 "Merging interface"@@ -209,9 +227,13 @@     let check b (Builtin x) (Builtin y)               | x == y    = return ()               | otherwise = typeError $ DuplicateBuiltinBinding b x y+        check _ (BuiltinRewriteRelations xs) (BuiltinRewriteRelations ys) = return ()         check _ _ _ = __IMPOSSIBLE__     sequence_ $ Map.intersectionWithKey check bs bi-    addImportedThings sig bi+    addImportedThings+      sig+      (iMetaBindings i)+      bi       (iPatternSyns i)       (iDisplayForms i)       (iUserWarnings i)@@ -230,6 +252,7 @@  addImportedThings   :: Signature+  -> RemoteMetaStore   -> BuiltinThings PrimFun   -> A.PatternSynDefns   -> DisplayForms@@ -237,8 +260,10 @@   -> Set QName             -- ^ Name of imported definitions which are partial   -> [TCWarning]   -> TCM ()-addImportedThings isig ibuiltin patsyns display userwarn partialdefs warnings = do+addImportedThings isig metas ibuiltin patsyns display userwarn+                  partialdefs warnings = do   stImports              `modifyTCLens` \ imp -> unionSignatures [imp, isig]+  stImportedMetaStore    `modifyTCLens` HMap.union metas   stImportedBuiltins     `modifyTCLens` \ imp -> Map.union imp ibuiltin   stImportedUserWarnings `modifyTCLens` \ imp -> Map.union imp userwarn   stImportedPartialDefs  `modifyTCLens` \ imp -> Set.union imp partialdefs@@ -250,16 +275,18 @@ -- | Scope checks the given module. A proper version of the module -- name (with correct definition sites) is returned. -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)-scopeCheckImport x = do+scopeCheckImport ::+  TopLevelModuleName -> ModuleName ->+  TCM (ModuleName, Map ModuleName Scope)+scopeCheckImport top x = do     reportSLn "import.scope" 5 $ "Scope checking " ++ prettyShow x     verboseS "import.scope" 10 $ do       visited <- prettyShow <$> getPrettyVisitedModules       reportSLn "import.scope" 10 $ "  visited: " ++ visited     -- Since scopeCheckImport is called from the scope checker,     -- we need to reimburse her account.-    i <- Bench.billTo [] $ getNonMainInterface (toTopLevelModuleName x) Nothing-    addImport x+    i <- Bench.billTo [] $ getNonMainInterface top Nothing+    addImport top      -- If that interface was supposed to raise a warning on import, do so.     whenJust (iImportWarning i) $ warning . UserWarning@@ -273,7 +300,7 @@ -- used to find the interface and the computed interface is stored for -- potential later use. -alreadyVisited :: C.TopLevelModuleName ->+alreadyVisited :: TopLevelModuleName ->                   MainInterface ->                   PragmaOptions ->                   TCM ModuleInfo ->@@ -331,7 +358,7 @@       _                             -> storeDecodedModule mi      reportS "warning.import" 10-      [ "module: " ++ show (C.moduleNameParts x)+      [ "module: " ++ show (moduleNameParts x)       , "WarningOnImport: " ++ show (iImportWarning (miInterface mi))       ] @@ -383,33 +410,42 @@ typeCheckMain mode src = do   -- liftIO $ putStrLn $ "This is typeCheckMain " ++ prettyShow f   -- liftIO . putStrLn . show =<< getVerbosity-  reportSLn "import.main" 10 "Importing the primitive modules."-  libdirPrim <- liftIO getPrimitiveLibDir-  reportSLn "import.main" 20 $ "Library primitive dir = " ++ show libdirPrim-  -- Turn off import-chasing messages.-  -- We have to modify the persistent verbosity setting, since-  -- getInterface resets the current verbosity settings to the persistent ones.-  bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do-    Lens.modifyPersistentVerbosity (Trie.delete [])  -- set root verbosity to 0 -    -- We don't want to generate highlighting information for Agda.Primitive.-    withHighlightingLevel None $-      forM_ (Set.map (libdirPrim </>) Lens.primitiveModules) $ \f -> do-        primSource <- parseSource (SourceFile $ mkAbsolute f)-        checkModuleName' (srcModuleName primSource) (srcOrigin primSource)-        void $ getNonMainInterface (srcModuleName primSource) (Just primSource)+  -- For the main interface, we also remember the pragmas from the file+  setOptionsFromSourcePragmas src+  loadPrims <- optLoadPrimitives <$> pragmaOptions -  reportSLn "import.main" 10 $ "Done importing the primitive modules."+  when loadPrims $ do+    reportSLn "import.main" 10 "Importing the primitive modules."+    libdirPrim <- liftIO getPrimitiveLibDir+    reportSLn "import.main" 20 $ "Library primitive dir = " ++ show libdirPrim+    -- Turn off import-chasing messages.+    -- We have to modify the persistent verbosity setting, since+    -- getInterface resets the current verbosity settings to the persistent ones. +    bracket_ (getsTC Lens.getPersistentVerbosity) Lens.putPersistentVerbosity $ do+      Lens.modifyPersistentVerbosity+        (Strict.Just . Trie.insert [] 0 . Strict.fromMaybe Trie.empty)+        -- set root verbosity to 0++      -- We don't want to generate highlighting information for Agda.Primitive.+      withHighlightingLevel None $+        forM_ (Set.map (libdirPrim </>) Lens.primitiveModules) $ \f -> do+          primSource <- parseSource (SourceFile $ mkAbsolute f)+          checkModuleName' (srcModuleName primSource) (srcOrigin primSource)+          void $ getNonMainInterface (srcModuleName primSource) (Just primSource)++    reportSLn "import.main" 10 $ "Done importing the primitive modules."+   -- Now do the type checking via getInterface.   checkModuleName' (srcModuleName src) (srcOrigin src) -  -- For the main interface, we also remember the pragmas from the file-  setOptionsFromSourcePragmas src-   mi <- getInterface (srcModuleName src) (MainInterface mode) (Just src) -  stCurrentModule `setTCLens` Just (iModuleName (miInterface mi))+  stCurrentModule `setTCLens'`+    Just ( iModuleName (miInterface mi)+         , iTopLevelModuleName (miInterface mi)+         )    return $ CheckResult' mi src   where@@ -428,7 +464,7 @@ --   Do not use this for the main file, use 'typeCheckMain' instead.  getNonMainInterface-  :: C.TopLevelModuleName+  :: TopLevelModuleName   -> Maybe Source      -- ^ Optional: the source code and some information about the source code.   -> TCM Interface@@ -445,7 +481,7 @@ -- errors.  getInterface-  :: C.TopLevelModuleName+  :: TopLevelModuleName   -> MainInterface   -> Maybe Source      -- ^ Optional: the source code and some information about the source code.@@ -503,25 +539,25 @@ -- | Check if the options used for checking an imported module are --   compatible with the current options. Raises Non-fatal errors if --   not.-checkOptionsCompatible :: PragmaOptions -> PragmaOptions -> ModuleName -> TCM Bool+checkOptionsCompatible ::+  PragmaOptions -> PragmaOptions -> TopLevelModuleName -> TCM Bool checkOptionsCompatible current imported importedModule = flip execStateT True $ do   reportSDoc "import.iface.options" 5 $ P.nest 2 $ "current options  =" P.<+> showOptions current   reportSDoc "import.iface.options" 5 $ P.nest 2 $ "imported options =" P.<+> showOptions imported-  forM_ coinfectiveOptions $ \ (opt, optName) -> do-    unless (opt current `implies` opt imported) $ do-      put False-      warning (CoInfectiveImport optName importedModule)-  forM_ infectiveOptions $ \ (opt, optName) -> do-    unless (opt imported `implies` opt current) $ do+  forM_ infectiveCoinfectiveOptions $ \opt -> do+    unless (icOptionOK opt current imported) $ do       put False-      warning (InfectiveImport optName importedModule)+      warning $+        (case icOptionKind opt of+           Infective   -> InfectiveImport+           Coinfective -> CoInfectiveImport)+        (icOptionWarning opt importedModule)   where-    implies :: Bool -> Bool -> Bool-    p `implies` q = p <= q--    showOptions opts = P.prettyList (map (\ (o, n) -> (P.text n <> ": ") P.<+> P.pretty (o opts))-                                 (coinfectiveOptions ++ infectiveOptions))-+  showOptions opts =+    P.prettyList $+    map (\opt -> (P.text (icOptionDescription opt) <> ": ") P.<+>+                 P.pretty (icOptionActive opt opts))+      infectiveCoinfectiveOptions  -- | Compare options and return collected warnings. -- | Returns `Nothing` if warning collection was skipped.@@ -532,14 +568,15 @@   -- They weren't logged before, but they're nice for documenting the early returns.   when isPrim $     throwError "Options consistency checking disabled for always-available primitive module"-  whenM (lift $ checkOptionsCompatible currentOptions (iOptionsUsed i) (iModuleName i)) $+  whenM (lift $ checkOptionsCompatible currentOptions (iOptionsUsed i)+                  (iTopLevelModuleName i)) $     throwError "No warnings to collect because options were compatible"   lift $ getAllWarnings' isMain ErrorWarnings  -- | Try to get the interface from interface file or cache.  getStoredInterface-  :: C.TopLevelModuleName+  :: TopLevelModuleName      -- ^ Module name of file we process.   -> SourceFile      -- ^ File we process.@@ -634,7 +671,7 @@           readInterface ifile          -- Ensure that the given module name matches the one in the file.-        let topLevelName = toTopLevelModuleName $ iModuleName i+        let topLevelName = iTopLevelModuleName i         unless (topLevelName == x) $           -- Andreas, 2014-03-27 This check is now done in the scope checker.           -- checkModuleName topLevelName file@@ -644,7 +681,9 @@          lift $ chaseMsg "Loading " x $ Just ifp         -- print imported warnings-        let ws = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (iWarnings i)+        let ws = filter ((Strict.Just (Just x) ==) .+                         fmap rangeFileName . tcWarningOrigin) $+                 iWarnings i         unless (null ws) $ reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> ws          loadDecodedModule file $ ModuleInfo@@ -673,23 +712,16 @@   -- want the pragmas to apply to interactive commands in the UI.   -- Jesper, 2021-04-18: Check for changed options in library files!   -- (see #5250)-  libOptions <- lift $ getLibraryOptions $ takeDirectory fp+  libOptions <- lift $ getLibraryOptions+    (srcFilePath file)+    (iTopLevelModuleName i)   lift $ mapM_ setOptionsFromPragma (libOptions ++ iFilePragmaOptions i)    -- Check that options that matter haven't changed compared to   -- current options (issue #2487)   unlessM (lift $ Lens.isBuiltinModule fp) $ do-    currentOptions <- useTC stPragmaOptions-    let disagreements =-          [ optName | (opt, optName) <- restartOptions,-                      opt currentOptions /= opt (iOptionsUsed i) ]-    unless (null disagreements) $ do-      reportSLn "import.iface.options" 4 $ concat-        [ "  Changes in the following options in "-        , prettyShow fp-        , ", re-typechecking: "-        , prettyShow disagreements-        ]+    current <- useTC stPragmaOptions+    when (recheckBecausePragmaOptionsChanged (iOptionsUsed i) current) $       throwError "options changed"    -- If any of the imports are newer we need to retype check@@ -721,7 +753,7 @@ --   in order to forget some state changes after successful type checking.  createInterfaceIsolated-  :: C.TopLevelModuleName+  :: TopLevelModuleName      -- ^ Module name of file we process.   -> SourceFile      -- ^ File we process.@@ -739,6 +771,7 @@       ds          <- getDecodedModules       opts        <- stPersistentOptions . stPersistentState <$> getTC       isig        <- useTC stImports+      metas       <- useTC stImportedMetaStore       ibuiltin    <- useTC stImportedBuiltins       display     <- useTC stImportsDisplayForms       userwarn    <- useTC stImportedUserWarnings@@ -768,7 +801,8 @@                setInteractionOutputCallback ho                stModuleToSource `setTCLens` mf                setVisitedModules vs-               addImportedThings isig ibuiltin ipatsyns display userwarn partialdefs []+               addImportedThings isig metas ibuiltin ipatsyns display+                 userwarn partialdefs []                 r  <- createInterface x file NotMainInterface msrc                mf' <- useTC stModuleToSource@@ -800,7 +834,7 @@  chaseMsg   :: String               -- ^ The prefix, like @Checking@, @Finished@, @Loading @.-  -> C.TopLevelModuleName -- ^ The module name.+  -> TopLevelModuleName   -- ^ The module name.   -> Maybe String         -- ^ Optionally: the file name.   -> TCM () chaseMsg kind x file = do@@ -897,7 +931,7 @@ -- information.  createInterface-  :: C.TopLevelModuleName  -- ^ The expected module name.+  :: TopLevelModuleName    -- ^ The expected module name.   -> SourceFile            -- ^ The file to type check.   -> MainInterface         -- ^ Are we dealing with the main module?   -> Maybe Source      -- ^ Optional information about the source code.@@ -912,7 +946,9 @@        (chaseMsg checkMsg x $ Just fp)        (const $ do ws <- getAllWarnings AllWarnings                    let classified = classifyWarnings ws-                   let wa' = filter ((Strict.Just (srcFilePath file) ==) . tcWarningOrigin) (tcWarnings classified)+                   let wa' = filter ((Strict.Just (Just mname) ==) .+                                     fmap rangeFileName . tcWarningOrigin) $+                             tcWarnings classified                    unless (null wa') $                      reportSDoc "warning" 1 $ P.vcat $ P.prettyTCM <$> wa'                    when (null (nonFatalErrors classified)) $ chaseMsg "Finished" x Nothing)@@ -934,10 +970,16 @@     let srcPath = srcFilePath $ srcOrigin src      fileTokenInfo <- Bench.billTo [Bench.Highlighting] $-      generateTokenInfoFromSource srcPath (TL.unpack $ srcText src)+      generateTokenInfoFromSource+        (let !top = srcModuleName src in+         mkRangeFile srcPath (Just top))+        (TL.unpack $ srcText src)     stTokens `modifyTCLens` (fileTokenInfo <>)      setOptionsFromSourcePragmas src+    checkCohesionAttributes (srcCohesion src)+    syntactic <- optSyntacticEquality <$> pragmaOptions+    localTC (\env -> env { envSyntacticEqualityFuel = syntactic }) $ do      verboseS "import.iface.create" 15 $ do       nestingLevel      <- asksTC (pred . length . envImportPath)@@ -1006,9 +1048,9 @@     unfreezeMetas      -- Profiling: Count number of metas.-    verboseS "profile.metas" 10 $ do-      MetaId n <- fresh-      tickN "metas" (fromIntegral n)+    whenProfile Profile.Metas $ do+      m <- fresh+      tickN "metas" (fromIntegral (metaId m))      -- Highlighting from type checker.     reportSLn "import.iface.create" 7 "Starting highlighting from type info."@@ -1112,13 +1154,13 @@     -- stMetaStore `setTCLens` savedMetaStore      -- Profiling: Print statistics.-    printStatistics 30 (Just mname) =<< getStatistics+    printStatistics (Just mname) =<< getStatistics      -- Get the statistics of the current module     -- and add it to the accumulated statistics.     localStatistics <- getStatistics     lensAccumStatistics `modifyTCLens` Map.unionWith (+) localStatistics-    verboseS "profile" 1 $ reportSLn "import.iface" 5 "Accumulated statistics."+    reportSLn "import.iface" 5 "Accumulated statistics."      isPrimitiveModule <- Lens.isPrimitiveModule (filePath srcPath) @@ -1158,7 +1200,7 @@   -> TCM Interface buildInterface src topLevel = do     reportSLn "import.iface" 5 "Building interface..."-    let mname = topLevelModuleName topLevel+    let mname = CToA.topLevelModuleName topLevel         source   = srcText src         fileType = srcFileType src         defPragmas = srcDefaultPragmas src@@ -1174,20 +1216,23 @@     -- faster and interface file sizes a bit smaller, at least for the     -- standard library).     builtin     <- useTC stLocalBuiltins-    ms          <- getImports-    mhs         <- mapM (\ m -> (m,) <$> moduleHash m) $ Set.toList ms+    mhs         <- mapM (\top -> (top,) <$> moduleHash top) .+                   HSet.toList =<<+                   useR stImportedModules     foreignCode <- useTC stForeignCode     -- Ulf, 2016-04-12:     -- Non-closed display forms are not applicable outside the module anyway,     -- and should be dead-code eliminated (#1928).     origDisplayForms <- HMap.filter (not . null) . HMap.map (filter isClosed) <$> useTC stImportsDisplayForms     -- TODO: Kill some ranges?-    (display, sig) <- eliminateDeadCode origDisplayForms =<< getSignature-    userwarns      <- useTC stLocalUserWarnings-    importwarn     <- useTC stWarningOnImport-    syntaxInfo     <- useTC stSyntaxInfo-    optionsUsed    <- useTC stPragmaOptions-    partialDefs    <- useTC stLocalPartialDefs+    (display, sig, solvedMetas) <-+      eliminateDeadCode builtin origDisplayForms ==<<+        (getSignature, useR stSolvedMetaStore)+    userwarns   <- useTC stLocalUserWarnings+    importwarn  <- useTC stWarningOnImport+    syntaxInfo  <- useTC stSyntaxInfo+    optionsUsed <- useTC stPragmaOptions+    partialDefs <- useTC stLocalPartialDefs      -- Andreas, 2015-02-09 kill ranges in pattern synonyms before     -- serialization to avoid error locations pointing to external files@@ -1195,31 +1240,39 @@     patsyns <- killRange <$> getPatternSyns     let builtin' = Map.mapWithKey (\ x b -> (x,) . primFunName <$> b) builtin     warnings <- getAllWarnings AllWarnings-    reportSLn "import.iface" 7 "  instantiating all meta variables"-    -- Note that the meta-variables in the definitions in "sig" have-    -- already been instantiated (by eliminateDeadCode).-    i <- instantiateFullExceptForDefinitions Interface-      { iSourceHash      = hashText source-      , iSource          = source-      , iFileType        = fileType-      , iImportedModules = mhs-      , iModuleName      = mname-      , iScope           = empty -- publicModules scope-      , iInsideScope     = topLevelScope topLevel-      , iSignature       = sig-      , iDisplayForms    = display-      , iUserWarnings    = userwarns-      , iImportWarning   = importwarn-      , iBuiltin         = builtin'-      , iForeignCode     = foreignCode-      , iHighlighting    = syntaxInfo-      , iDefaultPragmaOptions = defPragmas-      , iFilePragmaOptions    = filePragmas-      , iOptionsUsed     = optionsUsed-      , iPatternSyns     = patsyns-      , iWarnings        = warnings-      , iPartialDefs     = partialDefs-      }+    let i = Interface+          { iSourceHash      = hashText source+          , iSource          = source+          , iFileType        = fileType+          , iImportedModules = mhs+          , iModuleName      = mname+          , iTopLevelModuleName = srcModuleName src+          , iScope           = empty -- publicModules scope+          , iInsideScope     = topLevelScope topLevel+          , iSignature       = sig+          , iMetaBindings    = solvedMetas+          , iDisplayForms    = display+          , iUserWarnings    = userwarns+          , iImportWarning   = importwarn+          , iBuiltin         = builtin'+          , iForeignCode     = foreignCode+          , iHighlighting    = syntaxInfo+          , iDefaultPragmaOptions = defPragmas+          , iFilePragmaOptions    = filePragmas+          , iOptionsUsed     = optionsUsed+          , iPatternSyns     = patsyns+          , iWarnings        = warnings+          , iPartialDefs     = partialDefs+          }+    i <-+      ifM (collapseDefault . optSaveMetas <$> pragmaOptions)+        (return i)+        (do reportSLn "import.iface" 7+              "  instantiating all meta variables"+            -- Note that the meta-variables in the definitions in+            -- "sig" have already been instantiated (by+            -- eliminateDeadCode).+            instantiateFullExceptForDefinitions i)     reportSLn "import.iface" 7 "  interface complete"     return i @@ -1234,5 +1287,5 @@   maybe 0 (uncurry (+)) hs `seq` close   return hs -moduleHash :: ModuleName -> TCM Hash-moduleHash m = iFullHash <$> getNonMainInterface (toTopLevelModuleName m) Nothing+moduleHash :: TopLevelModuleName -> TCM Hash+moduleHash m = iFullHash <$> getNonMainInterface m Nothing
src/full/Agda/Interaction/Imports.hs-boot view
@@ -5,6 +5,9 @@  import Agda.Syntax.Abstract.Name    ( ModuleName ) import Agda.Syntax.Scope.Base       ( Scope )+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.TypeChecking.Monad.Base ( TCM ) -scopeCheckImport :: ModuleName -> TCM (ModuleName, Map ModuleName Scope)+scopeCheckImport ::+  TopLevelModuleName -> ModuleName ->+  TCM (ModuleName, Map ModuleName Scope)
src/full/Agda/Interaction/InteractionTop.hs view
@@ -25,7 +25,7 @@ import Control.Monad.Trans          ( lift )  import qualified Data.Char as Char-import Data.Function+import Data.Function (on) import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe@@ -39,7 +39,7 @@ import qualified Agda.TypeChecking.Pretty as TCP import Agda.TypeChecking.Rules.Term (checkExpr, isType_) import Agda.TypeChecking.Errors-import Agda.TypeChecking.Warnings (runPM)+import Agda.TypeChecking.Warnings (runPM, warning)  import Agda.Syntax.Fixity import Agda.Syntax.Position@@ -53,8 +53,10 @@ import Agda.Syntax.Translation.ConcreteToAbstract import Agda.Syntax.Translation.AbstractToConcrete hiding (withScope) import Agda.Syntax.Scope.Base+import Agda.Syntax.TopLevelModuleName  import Agda.Interaction.Base+import Agda.Interaction.ExitCode import Agda.Interaction.FindFile import Agda.Interaction.Options import Agda.Interaction.Options.Lenses as Lenses@@ -81,6 +83,7 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty hiding (Mode)+import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.String import Agda.Utils.Time@@ -233,7 +236,7 @@       let handle e =             Right <$>               toIO (handleErr (Just Direct) $-                        Exception noRange $ text $ show e)+                        Exception noRange $ text $ E.displayException e)            asyncHandler e@AsyncCancelled = return (Left e) @@ -263,7 +266,8 @@          showImpl <- lift $ optShowImplicit <$> useTC stPragmaOptions         showIrr <- lift $ optShowIrrelevant <$> useTC stPragmaOptions-        unless noError $ mapM_ putResponse $+        unless noError $ do+          mapM_ putResponse $             [ Resp_DisplayInfo $ Info_Error $ Info_GenericError e ] ++             tellEmacsToJumpToError (getRange e) ++             [ Resp_HighlightingInfo info KeepHighlighting@@ -272,6 +276,8 @@                                    , sShowImplicitArguments = showImpl                                    , sShowIrrelevantArguments = showIrr                                    } ]+          whenM (optExitOnError <$> commandLineOptions) $+            liftIO $ exitAgdaWith TCMError  -- | Run an 'IOTCM' value, catch the exceptions, emit output --@@ -280,15 +286,17 @@ --   loaded interfaces for example).  runInteraction :: IOTCM -> CommandM ()-runInteraction (IOTCM current highlighting highlightingMethod cmd) =+runInteraction iotcm =   handleCommand inEmacs onFail $ do     currentAbs <- liftIO $ absolute current-    -- Raises an error if the given file is not the one currently-    -- loaded.-    cf <- gets theCurrentFile-    when (not (independent cmd) && Just currentAbs /= (currentFilePath <$> cf)) $ do+    cf  <- gets theCurrentFile+    cmd <- if independent cmd then return cmd else do+      when (Just currentAbs /= (currentFilePath <$> cf)) $ do         let mode = TypeCheck         cmd_load' current [] True mode $ \_ -> return ()+      cf <- fromMaybe __IMPOSSIBLE__ <$> gets theCurrentFile+      return $ case iotcm (Just (currentFileModule cf)) of+        IOTCM _ _ _ cmd -> cmd      withCurrentFile $ interpret cmd @@ -299,6 +307,10 @@         putResponse . Resp_InteractionPoints =<< gets theInteractionPoints    where+    -- The ranges in cmd might be incorrect because of the use of+    -- Nothing here. That is taken care of above.+    IOTCM current highlighting highlightingMethod cmd = iotcm Nothing+     inEmacs :: forall a. CommandM a -> CommandM a     inEmacs = liftCommandMT $ withEnv $ initEnv             { envHighlightingLevel  = highlighting@@ -337,13 +349,14 @@       tcState <- getTC       tcEnv   <- askTC       result  <- liftIO $ race-                   (runTCM tcEnv tcState $ runStateT (m c) commandState)+                   (runTCM tcEnv tcState $+                    runStateT (m c) commandState)                    (waitForAbort n q)       case result of         Left ((x, commandState'), tcState') -> do           putTC tcState'           put commandState'-          case c of+          case c Nothing of             IOTCM _ _ _ Cmd_exit -> do               putResponse Resp_DoneExiting               return Done@@ -420,7 +433,7 @@       readCommands n = do         c <- next         case c of-          Command (IOTCM _ _ _ Cmd_abort) -> do+          Command c | IOTCM _ _ _ Cmd_abort <- c Nothing -> do             atomically $ writeTVar abort (Just n)             readCommands n           _ -> do@@ -455,6 +468,7 @@ updateInteractionPointsAfter Cmd_compile{}                       = True updateInteractionPointsAfter Cmd_constraints{}                   = False updateInteractionPointsAfter Cmd_metas{}                         = False+updateInteractionPointsAfter Cmd_no_metas{}                      = False updateInteractionPointsAfter Cmd_show_module_contents_toplevel{} = False updateInteractionPointsAfter Cmd_search_about_toplevel{}         = False updateInteractionPointsAfter Cmd_solveAll{}                      = True@@ -524,6 +538,11 @@   ms <- lift $ B.getGoals' norm (max Simplified norm)   display_info . Info_AllGoalsWarnings ms =<< lift B.getWarningsAndNonFatalErrors +interpret Cmd_no_metas = do+  metas <- getOpenMetas+  unless (null metas) $+    typeError $ GenericError "Unsolved meta-variables"+ interpret (Cmd_show_module_contents_toplevel norm s) =   atTopLevel $ showModuleContents norm noRange s @@ -846,7 +865,7 @@   putResponse $ Resp_SolveAll out   where       prt (i, m, e) = do-        mi <- getMetaInfo <$> lookupMeta m+        mi <- getMetaInfo <$> lookupLocalMeta m         e' <- withMetaInfo mi $ abstractToConcreteCtx TopCtx e         return (i, e') @@ -907,9 +926,10 @@     -- choice of whether or not to display implicit arguments.     opts0 <- gets optionsOnReload     backends <- useTC stBackends-    z <- runOptM $ parseBackendOptions backends argv opts0+    let (z, warns) = runOptM $ parseBackendOptions backends argv opts0+    mapM_ (lift . warning . OptionWarning) warns     case z of-      Left err   -> lift $ typeError $ GenericError err+      Left err -> lift $ typeError $ GenericError err       Right (_, opts) -> do         opts <- lift $ addTrustedExecutables opts         let update o = o { optAllowUnsolved = unsolvedOK && optAllowUnsolved o}@@ -928,7 +948,12 @@     when (t == t') $ do       is <- lift $ sortInteractionPoints =<< getInteractionPoints       modify $ \st -> st { theInteractionPoints = is-                         , theCurrentFile       = Just $ CurrentFile fp argv t+                         , theCurrentFile       = Just $ CurrentFile+                             { currentFilePath   = fp+                             , currentFileModule = Imp.srcModuleName src+                             , currentFileArgs   = argv+                             , currentFileStamp  = t+                             }                          }      cmd ok@@ -1091,10 +1116,10 @@  whyInScope :: String -> CommandM () whyInScope s = do-  Just (CurrentFile file _ _) <- gets theCurrentFile-  let cwd = takeDirectory (filePath file)-  (v, xs, ms) <- liftLocalState (B.whyInScope s)-  display_info $ Info_WhyInScope s cwd v xs ms+  Just file <- gets theCurrentFile+  let cwd = takeDirectory (filePath $ currentFilePath file)+  why <- liftLocalState $ B.whyInScope cwd s+  display_info $ Info_WhyInScope why  -- | Sets the command line options and updates the status information. @@ -1118,16 +1143,13 @@   -- changed since. Note: This code does not check if any dependencies   -- have changed, and uses a time stamp to check for changes.   checked  <- lift $ case cf of-    Nothing     -> return False-    Just (CurrentFile f _ t) -> do-      t' <- liftIO $ getModificationTime $ filePath f-      if t == t'+    Nothing -> return False+    Just f  -> do+      t <- liftIO $ getModificationTime $ filePath (currentFilePath f)+      if currentFileStamp f == t         then-          do-            mm <- lookupModuleFromSource f-            case mm of-              Nothing -> return False -- work-around for Issue1007-              Just m  -> maybe False (null . miWarnings) <$> getVisitedModule m+          maybe False (null . miWarnings) <$>+          getVisitedModule (currentFileModule f)         else             return False @@ -1164,13 +1186,14 @@   -> CommandM (Maybe CPUTime, a) parseAndDoAtToplevel cmd s = do   localStateCommandM $ do-    e <- lift $ runPM $ parse exprParser s+    (e, coh) <- lift $ runPM $ parse exprParser s+    lift $ checkCohesionAttributes coh     maybeTimed $ atTopLevel $ lift $       cmd =<< concreteToAbstract_ e  maybeTimed :: CommandM a -> CommandM (Maybe CPUTime, a) maybeTimed work = do-  doTime <- lift $ hasVerbosity "profile.interactive" 10+  doTime <- lift $ hasProfileOption Profile.Interactive   if not doTime     then (Nothing,) <$> work     else do@@ -1194,4 +1217,4 @@     Nothing                                           -> []     Just (Pn { srcFile = Strict.Nothing })            -> []     Just (Pn { srcFile = Strict.Just f, posPos = p }) ->-       [ Resp_JumpToError (filePath f) p ]+       [ Resp_JumpToError (filePath (rangeFilePath f)) p ]
src/full/Agda/Interaction/JSONTop.hs view
@@ -2,8 +2,10 @@     ( jsonREPL     ) where -import Control.Monad          ( (<=<), forM )-import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad+         ( (<=<), forM )+import Control.Monad.IO.Class+         ( MonadIO(..) )  import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Char8 as BS@@ -12,31 +14,48 @@  import Agda.Interaction.AgdaTop import Agda.Interaction.Base-  (CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..))+         ( CommandState(..), CurrentFile(..), ComputeMode(..), Rewrite(..), OutputForm(..), OutputConstraint(..) ) import qualified Agda.Interaction.BasicOps as B import Agda.Interaction.EmacsTop import Agda.Interaction.JSON import Agda.Interaction.Response as R import Agda.Interaction.Highlighting.JSON-import Agda.Syntax.Abstract.Pretty (prettyATop)++import Agda.Syntax.Abstract.Pretty+         ( prettyATop ) import Agda.Syntax.Common import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Name (NameInScope(..), Name)-import Agda.Syntax.Internal (telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock)-import Agda.Syntax.Position (Range, rangeIntervals, Interval'(..), Position'(..), noRange)-import Agda.VersionCommit+import Agda.Syntax.Concrete.Name+         ( NameInScope(..), Name )+import Agda.Syntax.Internal+         ( telToList, Dom'(..), Dom, MetaId(..), ProblemId(..), Blocker(..), alwaysUnblock )+import Agda.Syntax.Position+         ( Range, rangeIntervals, Interval'(..), Position'(..), noRange )+import Agda.Syntax.Scope.Base+         ( WhyInScopeData(..) ) -import Agda.TypeChecking.Errors (getAllWarningsOfTCErr)-import Agda.TypeChecking.Monad (Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..), withInteractionId)-import Agda.TypeChecking.Monad.MetaVars (getInteractionRange, getMetaRange, withMetaId)-import Agda.TypeChecking.Pretty (PrettyTCM(..), prettyTCM)+import Agda.TypeChecking.Errors+         ( getAllWarningsOfTCErr )+import Agda.TypeChecking.Monad+         ( Comparison(..), inTopContext, TCM, TCErr, TCWarning, NamedMeta(..), withInteractionId )+import Agda.TypeChecking.Monad.MetaVars+         ( getInteractionRange, getMetaRange, withMetaId )+import Agda.TypeChecking.Pretty+         ( PrettyTCM(..), prettyTCM ) -- borrowed from EmacsTop, for temporarily serialising stuff-import Agda.TypeChecking.Pretty.Warning (filterTCWarnings)-import Agda.TypeChecking.Warnings (WarningsAndNonFatalErrors(..))-import Agda.Utils.Pretty (Pretty(..))+import Agda.TypeChecking.Pretty.Warning+         ( filterTCWarnings )+import Agda.TypeChecking.Warnings+         ( WarningsAndNonFatalErrors(..) )+ import qualified Agda.Utils.Pretty as P-import Agda.Utils.Time (CPUTime(..))+import Agda.Utils.Pretty+         ( Pretty(..), prettyShow )+import Agda.Utils.Time+         ( CPUTime(..) ) +import Agda.VersionCommit+ --------------------------------------------------------------------------------  -- | 'jsonREPL' is a interpreter like 'mimicGHCi', but outputs JSON-encoded strings.@@ -70,7 +89,7 @@  instance EncodeTCM CurrentFile where instance ToJSON CurrentFile where-  toJSON (CurrentFile path _ time) = toJSON (path, time)  -- backwards compat.+  toJSON (CurrentFile path _ _ time) = toJSON (path, time)  -- backwards compat.  instance EncodeTCM ResponseContextEntry where   encodeTCM entry = obj@@ -97,8 +116,16 @@ instance EncodeTCM MetaId    where  instance ToJSON ProblemId where toJSON (ProblemId i) = toJSON i-instance ToJSON MetaId    where toJSON (MetaId    i) = toJSON i +instance ToJSON ModuleNameHash where+  toJSON (ModuleNameHash h) = toJSON h++instance ToJSON MetaId where+  toJSON m = object+    [ "id"     .= toJSON (metaId m)+    , "module" .= toJSON (metaModule m)+    ]+ instance EncodeTCM InteractionId where   encodeTCM ii@(InteractionId i) = obj     [ "id"    @= toJSON i@@ -223,6 +250,10 @@   , "type"           #= encPrettyTCM a   , "error"          #= encodeTCM err   ]+ DataSort q s -> kind "DataSort"+  [ "name"           @= encodePretty q+  , "sort"           #= f s+  ]  CheckLock t lk -> kind "CheckLock"   [ "head"           #= f t   , "lock"           #= f lk@@ -249,6 +280,7 @@ instance EncodeTCM Blocker where   encodeTCM (UnblockOnMeta x)    = kind "UnblockOnMeta" [ "meta" @= x ]   encodeTCM (UnblockOnProblem p) = kind "UnblockOnProblem" [ "id" @= p ]+  encodeTCM (UnblockOnDef q)     = kind "UnblockOnDef" [ "name" @= encodePretty q ]   encodeTCM (UnblockOnAll us)    = kind "UnblockOnAll" [ "blockers" @= Set.toList us ]   encodeTCM (UnblockOnAny us)    = kind "UnblockOnAny" [ "blockers" @= Set.toList us ] @@ -288,7 +320,7 @@       encodeDomType dom = obj         [ "dom"       #= encodePrettyTCM (unDom dom)         , "name"      @= fmap encodePretty (bareNameOf dom)-        , "finite"    @= toJSON (domFinite dom)+        , "finite"    @= toJSON (domIsFinite dom)         , "cohesion"  @= encodeShow (modCohesion . argInfoModality $ domInfo dom)         , "relevance" @= encodeShow (modRelevance . argInfoModality $ domInfo dom)         , "hiding"    @= case argInfoHiding $ domInfo dom of@@ -299,11 +331,11 @@     [ "results"           #= forM results encodeNamedPretty     , "search"            @= toJSON search     ]-  encodeTCM (Info_WhyInScope thing path v xs ms) = kind "WhyInScope"-    [ "thing"             @= thing+  encodeTCM (Info_WhyInScope why@(WhyInScopeData y path _ _ _)) = kind "WhyInScope"+    [ "thing"             @= prettyShow y     , "filepath"          @= toJSON path     -- use Emacs message first-    , "message"           #= explainWhyInScope thing path v xs ms+    , "message"           #= explainWhyInScope why     ]   encodeTCM (Info_NormalForm commandState computeMode time expr) = kind "NormalForm"     [ "commandState"      @= commandState@@ -425,7 +457,7 @@     where       encodeSolution (i, expr) = object         [ "interactionPoint"  .= i-        , "expression"        .= show expr+        , "expression"        .= P.prettyShow expr         ]  -- | Convert Response to an JSON value for interactive editor frontends.
src/full/Agda/Interaction/Library.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedLists #-}+ -- | Library management. -- --   Sample use:@@ -39,16 +41,16 @@   ) where  import Control.Arrow          ( first , second )+import qualified Control.Exception as E import Control.Monad          ( filterM, forM ) import Control.Monad.Except import Control.Monad.State-import Control.Monad.Writer+import Control.Monad.Writer   ( Writer, runWriter, WriterT(WriterT), runWriterT, tell ) import Control.Monad.IO.Class ( MonadIO(..) )  import Data.Char-import Data.Data ( Data ) import Data.Either-import Data.Function+import Data.Function (on) import Data.Map ( Map ) import qualified Data.Map as Map import Data.Maybe ( catMaybes, fromMaybe )@@ -58,6 +60,7 @@ import System.Directory import System.FilePath import System.Environment+import Text.Printf  import Agda.Interaction.Library.Base import Agda.Interaction.Library.Parse@@ -69,11 +72,14 @@ import Agda.Utils.IO ( catchIO ) import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.List-import Agda.Utils.List1 ( List1 )-import qualified Agda.Utils.List1 as List1+import Agda.Utils.List1             ( List1, pattern (:|) )+import Agda.Utils.List2             ( List2 )+import qualified Agda.Utils.List1   as List1+import qualified Agda.Utils.List2   as List2 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty+import Agda.Utils.Singleton import Agda.Utils.String ( trim )  import Agda.Version@@ -140,13 +146,13 @@ -- | The @~/.agda/libraries@ file lists the libraries Agda should know about. --   The content of @libraries@ is a list of paths to @.agda-lib@ files. -----   Agda honors also version specific @libraries@ files, e.g. @libraries-2.6.0@.+--   Agda honors also version-specific @libraries@ files, e.g. @libraries-2.6.0@. -- --   @defaultLibraryFiles@ gives a list of all @libraries@ files Agda should process---   by default.+--   by default.  The first file in this list that exists is actually used. -- defaultLibraryFiles :: List1 FilePath-defaultLibraryFiles = List1.fromList ["libraries-" ++ version, "libraries"]+defaultLibraryFiles = ("libraries-" ++ version) :| "libraries" : []  -- | The @defaultsFile@ contains a list of library names relevant for each Agda project. --@@ -156,13 +162,13 @@ -- | The @~/.agda/executables@ file lists the executables Agda should know about. --   The content of @executables@ is a list of paths to executables. -----   Agda honors also version specific @executables@ files, e.g. @executables-2.6.0@.+--   Agda honors also version-specific @executables@ files, e.g. @executables-2.6.0@. -- --   @defaultExecutablesFiles@ gives a list of all @executables@ Agda should process---   by default.+--   by default.  The first file in this list that exists is actually used. -- defaultExecutableFiles :: List1 FilePath-defaultExecutableFiles = List1.fromList ["executables-" ++ version, "executables"]+defaultExecutableFiles = ("executables-" ++ version) :| "executables" : []  ------------------------------------------------------------------------ -- * Get the libraries for the current project@@ -263,7 +269,7 @@       ls <- liftIO $ map snd . stripCommentLines <$> UTF8.readFile file       return $ concatMap splitCommas ls   `catchIO` \ e -> do-    raiseErrors' [ OtherError $ unlines ["Failed to read defaults file.", show e] ]+    raiseErrors' [ ReadError e "Failed to read defaults file." ]     return []  ------------------------------------------------------------------------@@ -274,15 +280,17 @@ -- --   Note: file may not exist. --+--   If the user specified an alternative @libraries@ file which does not exist,+--   an exception is thrown containing the name of this file. getLibrariesFile-  :: (MonadIO m, MonadError String m)+  :: (MonadIO m, MonadError FilePath m)   => Maybe FilePath -- ^ Override the default @libraries@ file?   -> m LibrariesFile getLibrariesFile (Just overrideLibFile) = do   -- A user-specified override file must exist.   ifM (liftIO $ doesFileExist overrideLibFile)     {-then-} (return $ LibrariesFile overrideLibFile True)-    {-else-} (throwError $ "Libraries file not found: " ++ overrideLibFile)+    {-else-} (throwError overrideLibFile) getLibrariesFile Nothing = do   agdaDir <- liftIO $ getAgdaAppDir   let defaults = List1.map (agdaDir </>) defaultLibraryFiles -- NB: very short list@@ -301,14 +309,16 @@ getInstalledLibraries overrideLibFile = mkLibM [] $ do     filem <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile     case filem of-      Left err -> raiseErrors' [OtherError err] >> return []+      Left theOverrideLibFile -> do+        raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ]+        return []       Right file -> do         if not (lfExists file) then return [] else do           ls    <- liftIO $ stripCommentLines <$> UTF8.readFile (lfPath file)           files <- liftIO $ sequence [ (i, ) <$> expandEnvironmentVariables s | (i, s) <- ls ]           parseLibFiles (Just file) $ nubOn snd files   `catchIO` \ e -> do-    raiseErrors' [ OtherError $ unlines ["Failed to read installed libraries.", show e] ]+    raiseErrors' [ ReadError e "Failed to read installed libraries." ]     return []  -- | Parse the given library files.@@ -336,9 +346,9 @@   let (xs, warns) = unzip anns       (errs, als) = partitionEithers xs -  unless (null warns) $ warnings $ concat warns-  unless (null errs)  $-    raiseErrors $ map (\(mc,s) -> LibError mc $ OtherError s) errs+  List1.unlessNull (concat warns) warnings+  List1.unlessNull errs $ \ errs1 ->+    raiseErrors $ fmap (\ (mc, err) -> LibError mc $ LibParseError err) errs1    return $ nubOn _libFile als @@ -378,7 +388,7 @@       tmp   <- parseExecutablesFile file $ nubOn snd files       return tmp   `catchIO` \ e -> do-    raiseErrors' [ OtherError $ unlines ["Failed to read trusted executables.", show e] ]+    raiseErrors' [ ReadError e "Failed to read trusted executables." ]     return Map.empty  -- | Parse the @executables@ file.@@ -387,16 +397,29 @@   :: ExecutablesFile   -> [(LineNumber, FilePath)]   -> LibErrorIO (Map ExeName FilePath)-parseExecutablesFile ef files =-  fmap (Map.fromList . catMaybes) . forM files $ \(ln, fp) -> do-+parseExecutablesFile ef files = do+  executables <- forM files $ \(ln, fp) -> do     -- Compute canonical executable name and absolute filepath.     let strExeName  = takeFileName fp     let strExeName' = fromMaybe strExeName $ stripExtension exeExtension strExeName     let txtExeName  = T.pack strExeName'     exePath <- liftIO $ makeAbsolute fp-    return $ Just (txtExeName, exePath)+    return (txtExeName, exePath) +  -- Create a map from executable names to their location(s).+  let exeMap1 :: Map ExeName (List1 FilePath)+      exeMap1 = Map.fromListWith (<>) $ map (second singleton) executables++  -- Separate non-ambiguous from ambiguous mappings.+  let (exeMap, duplicates) = Map.mapEither List2.fromList1Either exeMap1++  -- Report ambiguous mappings.+  List1.unlessNull (Map.toList duplicates) $ \ duplicates1 ->+    raiseErrors' $ fmap (uncurry $ DuplicateExecutable $ efPath ef) duplicates1++  -- Return non-ambiguous mappings.+  return exeMap+ ------------------------------------------------------------------------ -- * Resolving library names to include pathes ------------------------------------------------------------------------@@ -407,11 +430,13 @@   -> [AgdaLibFile]   -- ^ Libraries Agda knows about.   -> [LibName]       -- ^ (Non-empty) library names to be resolved to (lists of) pathes.   -> LibM [FilePath] -- ^ Resolved pathes (no duplicates).  Contains "." if @[LibName]@ does.-libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ WriterT $ do+libraryIncludePaths overrideLibFile libs xs0 = mkLibM libs $ do     efile <- liftIO $ runExceptT $ getLibrariesFile overrideLibFile     case efile of-      Left err -> return ([], [Left $ LibError Nothing $ OtherError err])-      Right file -> return $ runWriter $ (dot ++) . incs <$> find file [] xs+      Left theOverrideLibFile -> do+        raiseErrors' [ LibrariesFileNotFound theOverrideLibFile ]+        return []+      Right file -> embedWriter $ (dot ++) . incs <$> find file [] xs   where     (dots, xs) = List.partition (== libNameForCurrentDir) $ map trim xs0     incs       = nubOn id . concatMap _libIncludes@@ -422,7 +447,7 @@       :: LibrariesFile  -- Only for error reporting.       -> [LibName]      -- Already resolved libraries.       -> [LibName]      -- Work list: libraries left to be resolved.-      -> Writer [Either LibError LibWarning] [AgdaLibFile]+      -> Writer LibErrWarns [AgdaLibFile]     find _ _ [] = pure []     find file visited (x : xs)       | x `elem` visited = find file visited xs
src/full/Agda/Interaction/Library/Base.hs view
@@ -2,21 +2,24 @@  module Agda.Interaction.Library.Base where -import Control.Arrow ( first , second )+import Prelude hiding (null)+ import Control.DeepSeq+import qualified Control.Exception as E+ import Control.Monad.Except import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Writer        ( WriterT, MonadWriter, tell )+import Control.Monad.IO.Class      ( MonadIO(..) ) -import Data.Char ( isDigit )-import Data.Data ( Data )-import qualified Data.List as List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Text ( Text )+import Data.Bifunctor              ( first , second )+import Data.Char                   ( isDigit )+import qualified Data.List         as List+import Data.Map                    ( Map )+import qualified Data.Map          as Map+import Data.Text                   ( Text, unpack ) -import GHC.Generics (Generic)+import GHC.Generics                ( Generic )  import System.Directory import System.FilePath@@ -25,6 +28,9 @@  import Agda.Utils.FileName import Agda.Utils.Lens+import Agda.Utils.List1            ( List1, toList )+import Agda.Utils.List2            ( List2, toList )+import Agda.Utils.Null import Agda.Utils.Pretty  -- | A symbolic library name.@@ -49,7 +55,7 @@   , efExists :: Bool        -- ^ The executables file might not exist,        --   but we may print its assumed location in error messages.-  } deriving (Show, Data, Generic)+  } deriving (Show, Generic)  -- | The special name @\".\"@ is used to indicated that the current directory --   should count as a project root.@@ -110,70 +116,123 @@ -- * Library warnings and errors ------------------------------------------------------------------------ +-- ** Position information+ type LineNumber = Int +-- | Information about which @.agda-lib@ file we are reading+--   and from where in the @libraries@ file it came from.+ data LibPositionInfo = LibPositionInfo-  { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file+  { libFilePos :: Maybe FilePath -- ^ Name of @libraries@ file.   , lineNumPos :: LineNumber     -- ^ Line number in @libraries@ file.-  , filePos    :: FilePath       -- ^ Library file+  , filePos    :: FilePath       -- ^ Library file.   }-  deriving (Show, Data, Generic)+  deriving (Show, Generic) +-- ** Warnings+ data LibWarning = LibWarning (Maybe LibPositionInfo) LibWarning'-  deriving (Show, Data, Generic)+  deriving (Show, Generic)  -- | Library Warnings. data LibWarning'   = UnknownField String-  deriving (Show, Data, Generic)--data LibError = LibError (Maybe LibPositionInfo) LibError'+  deriving (Show, Generic)  libraryWarningName :: LibWarning -> WarningName libraryWarningName (LibWarning c (UnknownField{})) = LibUnknownField_ +-- * Errors++data LibError = LibError (Maybe LibPositionInfo) LibError'+ -- | Collected errors while processing library files. -- data LibError'-  = LibNotFound LibrariesFile LibName+  = LibrariesFileNotFound FilePath+      -- ^ The user specified replacement for the default @libraries@ file does not exist.+  | LibNotFound LibrariesFile LibName       -- ^ Raised when a library name could not successfully be resolved       --   to an @.agda-lib@ file.       --   | AmbiguousLib LibName [AgdaLibFile]       -- ^ Raised when a library name is defined in several @.agda-lib files@.-  | OtherError String-      -- ^ Generic error.-  deriving (Show)+  | LibParseError LibParseError+      -- ^ The @.agda-lib@ file could not be parsed.+  | ReadError+      -- ^ An I/O Error occurred when reading a file.+      E.IOException+        -- ^ The caught exception+      String+        -- ^ Explanation when this error occurred.+  | DuplicateExecutable+      -- ^ The @executables@ file contains duplicate entries.+      FilePath+        -- ^ Name of the @executables@ file.+      Text+        -- ^ Name of the executable that is defined twice.+      (List2 FilePath)+        -- ^ The resolutions of the executable.+  -- deriving (Show) --- | Cache locations of project configurations and parsed .agda-lib files-type LibState =-  ( Map FilePath ProjectConfig-  , Map FilePath AgdaLibFile-  )+-- | Exceptions thrown by the @.agda-lib@ parser.+--+data LibParseError+  = BadLibraryName String+      -- ^ An invalid library name, e.g., containing spaces.+  | ReadFailure FilePath E.IOException+      -- ^ I/O error while reading file.+  | MissingFields (List1 String)+      -- ^ Missing these mandatory fields.+  | DuplicateFields (List1 String)+      -- ^ These fields occur each more than once.+  | MissingFieldName LineNumber+      -- ^ At the given line number, a field name is missing before the @:@.+  | BadFieldName LineNumber String+      -- ^ At the given line number, an invalid field name is encountered before the @:@.+      --   (E.g., containing spaces.)+  | MissingColonForField LineNumber String+      -- ^ At the given line number, the given field is not followed by @:@.+  | ContentWithoutField LineNumber+      -- ^ At the given line number, indented text (content) is not preceded by a field. --- | Collects 'LibError's and 'LibWarning's.+-- ** Raising warnings and errors++-- | Collection of 'LibError's and 'LibWarning's. ---type LibErrorIO = WriterT [Either LibError LibWarning] (StateT LibState IO)+type LibErrWarns = [Either LibError LibWarning] --- | Throws 'Doc' exceptions, still collects 'LibWarning's.-type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO))+warnings :: MonadWriter LibErrWarns m => List1 LibWarning -> m ()+warnings = tell . map Right . toList -warnings :: MonadWriter [Either LibError LibWarning] m => [LibWarning] -> m ()-warnings = tell . map Right+warnings' :: MonadWriter LibErrWarns m => List1 LibWarning' -> m ()+warnings' = tell . map (Right . LibWarning Nothing) . toList -warnings' :: MonadWriter [Either LibError LibWarning] m => [LibWarning'] -> m ()-warnings' = tell . map (Right . LibWarning Nothing)+raiseErrors' :: MonadWriter LibErrWarns m => List1 LibError' -> m ()+raiseErrors' = tell . map (Left . (LibError Nothing)) . toList --- UNUSED Liang-Ting Chen 2019-07-16---warning :: MonadWriter [Either LibError LibWarning] m => LibWarning -> m ()---warning = warnings . pure+raiseErrors :: MonadWriter LibErrWarns m => List1 LibError -> m ()+raiseErrors = tell . map Left . toList -raiseErrors' :: MonadWriter [Either LibError LibWarning] m => [LibError'] -> m ()-raiseErrors' = tell . map (Left . (LibError Nothing)) -raiseErrors :: MonadWriter [Either LibError LibWarning] m => [LibError] -> m ()-raiseErrors = tell . map Left+------------------------------------------------------------------------+-- * Library Monad+------------------------------------------------------------------------ +-- | Collects 'LibError's and 'LibWarning's.+--+type LibErrorIO = WriterT LibErrWarns (StateT LibState IO)++-- | Throws 'Doc' exceptions, still collects 'LibWarning's.+type LibM = ExceptT Doc (WriterT [LibWarning] (StateT LibState IO))++-- | Cache locations of project configurations and parsed @.agda-lib@ files.+type LibState =+  ( Map FilePath ProjectConfig+  , Map FilePath AgdaLibFile+  )+ getCachedProjectConfig   :: (MonadState LibState m, MonadIO m)   => FilePath -> m (Maybe ProjectConfig)@@ -207,35 +266,89 @@ -- * Prettyprinting errors and warnings ------------------------------------------------------------------------ -formatLibPositionInfo :: LibPositionInfo -> String -> Doc-formatLibPositionInfo (LibPositionInfo libFile lineNum file) err = text $-  let loc | Just lf <- libFile = lf ++ ":" ++ show lineNum ++ ": "-          | otherwise = ""-  in if "Failed to read" `List.isPrefixOf` err-     then loc-     else file ++ ":" ++ (if all isDigit (take 1 err) then "" else " ")- -- | Pretty-print 'LibError'. formatLibError :: [AgdaLibFile] -> LibError -> Doc-formatLibError installed (LibError mc e) = prefix <+> body where-  prefix = case mc of-    Nothing                      -> ""-    Just c | OtherError err <- e -> formatLibPositionInfo c err-    _                            -> ""+formatLibError installed (LibError mc e) =+  case (mc, e) of+    (Just c, LibParseError err) -> sep  [ formatLibPositionInfo c err, pretty e ]+    (_     , LibNotFound{}    ) -> vcat [ pretty e, prettyInstalledLibraries installed ]+    _ -> pretty e -  body = case e of+-- | Does a parse error contain a line number?+hasLineNumber :: LibParseError -> Maybe LineNumber+hasLineNumber = \case+  BadLibraryName       _   -> Nothing+  ReadFailure          _ _ -> Nothing+  MissingFields        _   -> Nothing+  DuplicateFields      _   -> Nothing+  MissingFieldName     l   -> Just l+  BadFieldName         l _ -> Just l+  MissingColonForField l _ -> Just l+  ContentWithoutField  l   -> Just l++-- UNUSED:+-- -- | Does a parse error contain the name of the parsed file?+-- hasFilePath :: LibParseError -> Maybe FilePath+-- hasFilePath = \case+--   BadLibraryName       _   -> Nothing+--   ReadFailure          f _ -> Just f+--   MissingFields        _   -> Nothing+--   DuplicateFields      _   -> Nothing+--   MissingFieldName     _   -> Nothing+--   BadFieldName         _ _ -> Nothing+--   MissingColonForField _ _ -> Nothing+--   ContentWithoutField  _   -> Nothing++-- | Compute a position position prefix.+--+--   Depending on the error to be printed, it will+--+--   - either give the name of the @libraries@ file and a line inside it,+--+--   - or give the name of the @.agda-lib@ file.+--+formatLibPositionInfo :: LibPositionInfo -> LibParseError -> Doc+formatLibPositionInfo (LibPositionInfo libFile lineNum file) = \case++  -- If we couldn't even read the @.agda-lib@ file, report error in the @libraries@ file.+  ReadFailure _ _+    | Just lf <- libFile+      -> hcat [ text lf, ":", pretty lineNum, ":" ]+    | otherwise+      -> empty++  -- If the parse error comes with a line number, print it here.+  e | Just l <- hasLineNumber e+      -> hcat [ text file, ":", pretty l, ":" ]+    | otherwise+      -> hcat [ text file, ":" ]++prettyInstalledLibraries :: [AgdaLibFile] -> Doc+prettyInstalledLibraries installed =+  vcat $ ("Installed libraries:" :) $+    map (nest 2) $+    if null installed then ["(none)"]+    else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ]+         | l <- installed+         ]++-- | Pretty-print library management error without position info.++instance Pretty LibError' where+  pretty = \case++    LibrariesFileNotFound path -> sep+      [ text "Libraries file not found:"+      , text path+      ]+     LibNotFound file lib -> vcat $       [ text $ "Library '" ++ lib ++ "' not found."       , sep [ "Add the path to its .agda-lib file to"             , nest 2 $ text $ "'" ++ lfPath file ++ "'"             , "to install."             ]-      , "Installed libraries:"-      ] ++-      map (nest 2)-         (if null installed then ["(none)"]-          else [ sep [ text $ _libName l, nest 2 $ parens $ text $ _libFile l ]-               | l <- installed ])+      ]      AmbiguousLib lib tgts -> vcat $       sep [ text $ "Ambiguous library '" ++ lib ++ "'."@@ -243,16 +356,51 @@           ]         : [ nest 2 $ text (_libName l) <+> parens (text $ _libFile l) | l <- tgts ] +    LibParseError err -> pretty err -    OtherError err -> text err+    ReadError e msg -> vcat+      [ text $ msg+      , text $ E.displayException e+      ] -instance Pretty LibWarning where-  pretty (LibWarning mc w) = prefix <+> pretty w+    DuplicateExecutable exeFile exe paths -> vcat $+      hcat [ "Duplicate entries for executable '", (text . unpack) exe, "' in ", text exeFile, ":" ] :+      map (nest 2 . ("-" <+>) . text) (toList paths)++-- | Print library file parse error without position info.+--+instance Pretty LibParseError where+  pretty = \case++    BadLibraryName s -> sep+      [ "Bad library name:", quotes (text s) ]+    ReadFailure file e -> vcat+      [ hsep [ "Failed to read library file", text file <> "." ]+      , "Reason:" <+> text (E.displayException e)+      ]++    MissingFields   xs -> "Missing"   <+> listFields xs+    DuplicateFields xs -> "Duplicate" <+> listFields xs++    MissingFieldName     l   -> atLine l $ "Missing field name"+    BadFieldName         l s -> atLine l $ "Bad field name" <+> text (show s)+    MissingColonForField l s -> atLine l $ "Missing ':' for field " <+> text (show s)+    ContentWithoutField  l   -> atLine l $ "Missing field"+     where-      prefix = case mc of-        Nothing -> ""-        Just c  -> formatLibPositionInfo c ""+    listFields xs = hsep $ fieldS xs : list xs+    fieldS xs     = singPlural xs "field:" "fields:"+    list          = punctuate comma . map (quotes . text) . toList+    atLine l      = id+    -- The line number will be printed by 'formatLibPositionInfo'!+    -- atLine l doc  = hsep [ text (show l) <> ":", doc ] ++instance Pretty LibWarning where+  pretty (LibWarning mc w) =+    case mc of+      Nothing -> pretty w+      Just (LibPositionInfo _ _ file) -> hcat [ text file, ":"] <+> pretty w  instance Pretty LibWarning' where   pretty (UnknownField s) = text $ "Unknown field '" ++ s ++ "'"
src/full/Agda/Interaction/Library/Parse.hs view
@@ -29,28 +29,30 @@   , runP   ) where +import qualified Control.Exception as E import Control.Monad import Control.Monad.Except import Control.Monad.Writer import Data.Char-import Data.Data import qualified Data.List as List import System.FilePath  import Agda.Interaction.Library.Base  import Agda.Utils.Applicative-import Agda.Utils.IO ( catchIO )+import Agda.Utils.IO                ( catchIO ) import qualified Agda.Utils.IO.UTF8 as UTF8 import Agda.Utils.Lens-import Agda.Utils.List   ( duplicates )-import Agda.Utils.String ( ltrim )+import Agda.Utils.List              ( duplicates )+import Agda.Utils.List1             ( List1, toList )+import qualified Agda.Utils.List1   as List1+import Agda.Utils.String            ( ltrim ) --- | Parser monad: Can throw @String@ error messages, and collects+-- | Parser monad: Can throw @LibParseError@s, and collects -- @LibWarning'@s library warnings.-type P = ExceptT String (Writer [LibWarning'])+type P = ExceptT LibParseError (Writer [LibWarning']) -runP :: P a -> (Either String a, [LibWarning'])+runP :: P a -> (Either LibParseError a, [LibWarning']) runP = runWriter . runExceptT  warningP :: LibWarning' -> P ()@@ -89,7 +91,7 @@   where     parseName :: [String] -> P LibName     parseName [s] | [name] <- words s = pure name-    parseName ls = throwError $ "Bad library name: '" ++ unwords ls ++ "'"+    parseName ls = throwError $ BadLibraryName $ unwords ls      parsePaths :: String -> [FilePath]     parsePaths = go id where@@ -111,10 +113,7 @@ parseLibFile :: FilePath -> IO (P AgdaLibFile) parseLibFile file =   (fmap setPath . parseLib <$> UTF8.readFile file) `catchIO` \e ->-    return $ throwError $ unlines-      [ "Failed to read library file " ++ file ++ "."-      , "Reason: " ++ show e-      ]+    return $ throwError $ ReadFailure file e   where     setPath      lib = unrelativise (takeDirectory file) (set libFile file lib)     unrelativise dir = over libIncludes (map (dir </>))@@ -150,16 +149,15 @@ -- | Ensure that there are no duplicate fields and no mandatory fields are missing. checkFields :: [Field] -> [String] -> P () checkFields fields fs = do-  let mandatory = [ fName f | f <- fields, not $ fOptional f ]-      -- Missing fields.-      missing   = mandatory List.\\ fs-      -- Duplicate fields.-      dup       = duplicates fs-      -- Plural s for error message.-      s xs      = if length xs > 1 then "s" else ""-      list xs   = List.intercalate ", " [ "'" ++ f ++ "'" | f <- xs ]-  unless (null missing) $ throwError $ "Missing field" ++ s missing ++ " " ++ list missing-  unless (null dup)     $ throwError $ "Duplicate field" ++ s dup ++ " " ++ list dup+  -- Report missing mandatory fields.+  () <- List1.unlessNull missing $ throwError . MissingFields+  -- Report duplicate fields.+  List1.unlessNull (duplicates fs) $ throwError . DuplicateFields+  where+  mandatory :: [String]+  mandatory = [ fName f | f <- fields, not $ fOptional f ]+  missing   :: [String]+  missing   = mandatory List.\\ fs  -- | Find 'Field' with given 'fName', throw error if unknown. findField :: String -> [Field] -> P (Maybe Field)@@ -227,17 +225,17 @@       (h, ':' : r) ->         case words h of           [h] -> pure $ Header l h : [Content l r' | let r' = ltrim r, not (null r')]-          []  -> throwError $ show l ++ ": Missing field name"-          hs  -> throwError $ show l ++ ": Bad field name " ++ show h-      _ -> throwError $ show l ++ ": Missing ':' for field " ++ show (ltrim s)+          []  -> throwError $ MissingFieldName l+          hs  -> throwError $ BadFieldName l h+      _ -> throwError $ MissingColonForField l (ltrim s)  -- | Collect 'Header' and subsequent 'Content's into 'GenericEntry'. -----   Tailing 'Content's?  That's an error.+--   Leading 'Content's?  That's an error. -- groupLines :: [GenericLine] -> P GenericFile groupLines [] = pure []-groupLines (Content l c : _) = throwError $ show l ++ ": Missing field"+groupLines (Content l c : _) = throwError $ ContentWithoutField l groupLines (Header _ h : ls) = (GenericEntry h [ c | Content _ c <- cs ] :) <$> groupLines ls1   where     (cs, ls1) = span isContent ls@@ -250,7 +248,7 @@  -- | Break a comma-separated string.  Result strings are @trim@med. splitCommas :: String -> [String]-splitCommas s = words $ map (\c -> if c == ',' then ' ' else c) s+splitCommas = words . map (\c -> if c == ',' then ' ' else c)  -- | ...and trailing, but not leading, whitespace. stripComments :: String -> String
src/full/Agda/Interaction/MakeCase.hs view
@@ -2,12 +2,12 @@  module Agda.Interaction.MakeCase where -import Prelude hiding (null)+import Prelude hiding ((!!), null)  import Control.Monad  import Data.Either-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Monoid@@ -76,7 +76,7 @@   -- Get into the context of the meta.   mId <- lookupInteractionId ii   updateMetaVarRange mId rng-  mi  <- getMetaInfo <$> lookupMeta mId+  mi  <- getMetaInfo <$> lookupLocalMeta mId   enterClosure mi $ \ r -> do    reportSDoc "interaction.case" 20 $ do@@ -223,18 +223,19 @@  recheckAbstractClause :: Type -> Maybe Substitution -> A.SpineClause -> TCM (Clause, Context, [AsBinding]) recheckAbstractClause t sub acl = checkClauseLHS t sub acl $ \ lhs -> do-  let cl = Clause{ clauseLHSRange    = getRange acl-                 , clauseFullRange   = getRange acl-                 , clauseTel         = lhsVarTele lhs-                 , namedClausePats   = lhsPatterns lhs-                 , clauseBody        = Nothing -- We don't need the body for make case-                 , clauseType        = Just (lhsBodyType lhs)-                 , clauseCatchall    = False-                 , clauseExact       = Nothing-                 , clauseRecursive   = Nothing-                 , clauseUnreachable = Nothing-                 , clauseEllipsis    = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl-                 }+  let cl = Clause { clauseLHSRange    = getRange acl+                  , clauseFullRange   = getRange acl+                  , clauseTel         = lhsVarTele lhs+                  , namedClausePats   = lhsPatterns lhs+                  , clauseBody        = Nothing -- We don't need the body for make case+                  , clauseType        = Just (lhsBodyType lhs)+                  , clauseCatchall    = False+                  , clauseExact       = Nothing+                  , clauseRecursive   = Nothing+                  , clauseUnreachable = Nothing+                  , clauseEllipsis    = lhsEllipsis $ A.spLhsInfo $ A.clauseLHS acl+                  , clauseWhereModule = A.whereModule $ A.clauseWhereDecls acl+                  }   cxt <- getContext   let asb = lhsAsBindings lhs   return (cl, cxt, asb)@@ -501,15 +502,25 @@       , "ell     =" <+> text (show ell)       ]     ]-  withCurrentModule (qnameModule f) $ do+  withCurrentModule (qnameModule f) $     -- Andreas, 2015-05-29 Issue 635     -- Contract implicit record patterns before printing.     -- c <- translateRecordPatterns $ Clause noRange tel perm ps NoBody t False     -- Jesper, 2015-09-19 Don't contract, since we do on-demand splitting-    let c = Clause noRange noRange tel ps Nothing (argFromDom <$> t) False Nothing Nothing Nothing ell-    let ps = namedClausePats c-    inTopContext $ reify $ QNamed f $ c { namedClausePats = ps }-+    inTopContext $ reify $ QNamed f $ Clause+      { clauseLHSRange  = noRange+      , clauseFullRange = noRange+      , clauseTel       = tel+      , namedClausePats = ps+      , clauseBody      = Nothing+      , clauseType      = argFromDom <$> t+      , clauseCatchall    = False+      , clauseExact       = Nothing+      , clauseRecursive   = Nothing+      , clauseUnreachable = Nothing+      , clauseEllipsis    = ell+      , clauseWhereModule = Nothing+      }  -- | Make a clause with a question mark as rhs.
src/full/Agda/Interaction/Options/Base.hs view
@@ -5,6 +5,7 @@     ( CommandLineOptions(..)     , PragmaOptions(..)     , OptionsPragma+    , OptionWarning(..), optionWarningName     , Flag, OptM, runOptM, OptDescr(..), ArgDescr(..)     , Verbosity, VerboseKey, VerboseLevel     , WarningMode(..)@@ -13,17 +14,18 @@     , checkOpts     , parsePragmaOptions     , parsePluginOptions+    , parseVerboseKey     , stripRTS     , defaultOptions     , defaultInteractionOptions-    , defaultVerbosity     , defaultCutOff     , defaultPragmaOptions     , standardOptions_     , unsafePragmaOptions-    , restartOptions-    , infectiveOptions-    , coinfectiveOptions+    , recheckBecausePragmaOptionsChanged+    , InfectiveCoinfective(..)+    , InfectiveCoinfectiveOption(..)+    , infectiveCoinfectiveOptions     , safeFlag     , mapFlag     , usage@@ -33,9 +35,12 @@     , getOptSimple     ) where +import Prelude hiding ( null )+ import Control.DeepSeq import Control.Monad ( when, void )-import Control.Monad.Except ( Except, MonadError(throwError), runExcept )+import Control.Monad.Except ( ExceptT, MonadError(throwError), runExceptT )+import Control.Monad.Writer ( Writer, runWriter, MonadWriter(..) )  import qualified System.IO.Unsafe as UNSAFE (unsafePerformIO) import Data.Maybe@@ -64,24 +69,41 @@ import Agda.Interaction.Options.Warnings import Agda.Syntax.Concrete.Glyph ( unsafeSetUnicodeOrAscii, UnicodeOrAscii(..) ) import Agda.Syntax.Common (Cubical(..))+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)  import Agda.Utils.FileName      ( AbsolutePath ) import Agda.Utils.Functor       ( (<&>) ) import Agda.Utils.Lens          ( Lens', over )-import Agda.Utils.List          ( groupOn, initLast1, wordsBy )-import Agda.Utils.Pretty        ( singPlural )+import Agda.Utils.List          ( groupOn, initLast1 )+import Agda.Utils.List1         ( String1, toList )+import qualified Agda.Utils.List1        as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad         ( tell1 )+import Agda.Utils.Null+import Agda.Utils.Pretty+import Agda.Utils.ProfileOptions import Agda.Utils.Trie          ( Trie ) import qualified Agda.Utils.Trie as Trie import Agda.Utils.WithDefault +import Agda.Utils.Impossible+ import Agda.Version  -- OptDescr is a Functor -------------------------------------------------- -type VerboseKey   = String-type VerboseLevel = Int-type Verbosity    = Trie VerboseKey VerboseLevel+type VerboseKey     = String+type VerboseKeyItem = String1+type VerboseLevel   = Int+-- | 'Strict.Nothing' is used if no verbosity options have been given,+-- thus making it possible to handle the default case relatively+-- quickly. Note that 'Strict.Nothing' corresponds to a trie with+-- verbosity level 1 for the empty path.+type Verbosity = Strict.Maybe (Trie VerboseKeyItem VerboseLevel) +parseVerboseKey :: VerboseKey -> [VerboseKeyItem]+parseVerboseKey = List1.wordsBy (`elem` ['.', ':'])+ -- Don't forget to update --   doc/user-manual/tools/command-line-options.rst -- if you make changes to the command-line options!@@ -99,7 +121,7 @@   -- ^ Use ~/.agda/defaults   , optUseLibs               :: Bool   -- ^ look for .agda-lib files-  , optTrustedExecutables             :: Map ExeName FilePath+  , optTrustedExecutables    :: Map ExeName FilePath   -- ^ Map names of trusted executables to absolute paths   , optPrintAgdaDir          :: Bool   , optPrintVersion          :: Bool@@ -108,7 +130,8 @@       -- ^ Agda REPL (-I).   , optGHCiInteraction       :: Bool   , optJSONInteraction       :: Bool-  , optOptimSmashing         :: Bool+  , optExitOnError           :: !Bool+    -- ^ Exit if an interactive command fails.   , optCompileDir            :: Maybe FilePath   -- ^ In the absence of a path the project root is used.   , optGenerateVimFile       :: Bool@@ -119,6 +142,8 @@   , optOnlyScopeChecking     :: Bool     -- ^ Should the top-level module only be scope-checked, and not     --   type-checked?+  , optTransliterate         :: Bool+    -- ^ Should code points that are not supported by the locale be transliterated?   }   deriving (Show, Generic) @@ -130,7 +155,8 @@   { optShowImplicit              :: Bool   , optShowIrrelevant            :: Bool   , optUseUnicode                :: UnicodeOrAscii-  , optVerbose                   :: Verbosity+  , optVerbose                   :: !Verbosity+  , optProfiling                 :: ProfileOptions   , optProp                      :: Bool   , optTwoLevel                  :: WithDefault 'False   , optAllowUnsolved             :: Bool@@ -139,10 +165,8 @@   , optTerminationCheck          :: Bool   , optTerminationDepth          :: CutOff     -- ^ Cut off structural order comparison at some depth in termination checker?-  , optCompletenessCheck         :: Bool   , optUniverseCheck             :: Bool   , optOmegaInOmega              :: Bool-  , optSubtyping                 :: WithDefault 'False   , optCumulativity              :: Bool   , optSizedTypes                :: WithDefault 'False   , optGuardedness               :: WithDefault 'False@@ -151,12 +175,14 @@   , optIrrelevantProjections     :: Bool   , optExperimentalIrrelevance   :: Bool  -- ^ irrelevant levels, irrelevant data matching   , optWithoutK                  :: WithDefault 'False+  , optCubicalCompatible         :: WithDefault 'False   , optCopatterns                :: Bool  -- ^ Allow definitions by copattern matching?   , optPatternMatching           :: Bool  -- ^ Is pattern matching allowed in the current file?   , optExactSplit                :: Bool   , optEta                       :: Bool   , optForcing                   :: Bool  -- ^ Perform the forcing analysis on data constructors?   , optProjectionLike            :: Bool  -- ^ Perform the projection-likeness analysis on functions?+  , optEraseRecordParameters     :: Bool  -- ^ Mark parameters of record modules as erased?   , optRewriting                 :: Bool  -- ^ Can rewrite rules be added and used?   , optCubical                   :: Maybe Cubical   , optGuarded                   :: Bool@@ -173,7 +199,14 @@   , optInversionMaxDepth         :: Int   , optSafe                      :: Bool   , optDoubleCheck               :: Bool-  , optSyntacticEquality         :: Bool  -- ^ Should conversion checker use syntactic equality shortcut?+  , optSyntacticEquality         :: !(Strict.Maybe Int)+    -- ^ Should the conversion checker use the syntactic equality+    -- shortcut? 'Nothing' means that it should. @'Just' n@, for a+    -- non-negative number @n@, means that syntactic equality checking+    -- gets @n@ units of fuel. If the fuel becomes zero, then+    -- syntactic equality checking is turned off. The fuel counter is+    -- decreased in the failure continuation of+    -- 'Agda.TypeChecking.SyntacticEquality.checkSyntacticEquality'.   , optWarningMode               :: WarningMode   , optCompileNoMain             :: Bool   , optCaching                   :: Bool@@ -190,15 +223,25 @@     -- ^ Use call-by-name instead of call-by-need   , optConfluenceCheck           :: Maybe ConfluenceCheck     -- ^ Check confluence of rewrite rules?-  , optFlatSplit                 :: Bool+  , optCohesion                  :: Bool+     -- ^ Are the cohesion modalities available?+  , optFlatSplit                 :: WithDefault 'False      -- ^ Can we split on a (@flat x : A) argument?   , optImportSorts               :: Bool      -- ^ Should every top-level module start with an implicit statement      --   @open import Agda.Primitive using (Set; Prop)@?+  , optLoadPrimitives            :: Bool+    -- ^ Should we load the primitive modules at all? This is a stronger+    -- form of 'optImportSorts'.   , optAllowExec                 :: Bool+  , optSaveMetas                 :: WithDefault 'False+    -- ^ Save meta-variables.   , optShowIdentitySubstitutions :: Bool     -- ^ Show identity substitutions when pretty-printing terms     --   (i.e. always show all arguments of a metavariable)+  , optKeepCoveringClauses       :: Bool+    -- ^ Do not discard clauses constructed by the coverage checker+    --   (needed for some external backends)   }   deriving (Show, Eq, Generic) @@ -223,9 +266,6 @@ mapFlag :: (String -> String) -> OptDescr a -> OptDescr a mapFlag f (Option _ long arg descr) = Option [] (map f long) arg descr -defaultVerbosity :: Verbosity-defaultVerbosity = Trie.singleton [] 1- defaultInteractionOptions :: PragmaOptions defaultInteractionOptions = defaultPragmaOptions @@ -246,7 +286,7 @@   , optInteractive           = False   , optGHCiInteraction       = False   , optJSONInteraction       = False-  , optOptimSmashing         = True+  , optExitOnError           = False   , optCompileDir            = Nothing   , optGenerateVimFile       = False   , optIgnoreInterfaces      = False@@ -254,6 +294,7 @@   , optLocalInterfaces       = False   , optPragmaOptions         = defaultPragmaOptions   , optOnlyScopeChecking     = False+  , optTransliterate         = False   }  defaultPragmaOptions :: PragmaOptions@@ -261,7 +302,8 @@   { optShowImplicit              = False   , optShowIrrelevant            = False   , optUseUnicode                = UnicodeOk-  , optVerbose                   = defaultVerbosity+  , optVerbose                   = Strict.Nothing+  , optProfiling                 = noProfileOptions   , optProp                      = False   , optTwoLevel                  = Default   , optExperimentalIrrelevance   = False@@ -271,22 +313,22 @@   , optDisablePositivity         = False   , optTerminationCheck          = True   , optTerminationDepth          = defaultCutOff-  , optCompletenessCheck         = True   , optUniverseCheck             = True   , optOmegaInOmega              = False-  , optSubtyping                 = Default   , optCumulativity              = False   , optSizedTypes                = Default   , optGuardedness               = Default   , optInjectiveTypeConstructors = False   , optUniversePolymorphism      = True   , optWithoutK                  = Default+  , optCubicalCompatible         = Default   , optCopatterns                = True   , optPatternMatching           = True   , optExactSplit                = False   , optEta                       = True   , optForcing                   = True   , optProjectionLike            = True+  , optEraseRecordParameters     = False   , optRewriting                 = False   , optCubical                   = Nothing   , optGuarded                   = False@@ -299,7 +341,7 @@   , optInversionMaxDepth         = 50   , optSafe                      = False   , optDoubleCheck               = False-  , optSyntacticEquality         = True+  , optSyntacticEquality         = Strict.Nothing   , optWarningMode               = defaultWarningMode   , optCompileNoMain             = False   , optCaching                   = True@@ -309,26 +351,55 @@   , optFastReduce                = True   , optCallByName                = False   , optConfluenceCheck           = Nothing-  , optFlatSplit                 = True+  , optCohesion                  = False+  , optFlatSplit                 = Default   , optImportSorts               = True   , optAllowExec                 = False+  , optSaveMetas                 = Default   , optShowIdentitySubstitutions = False+  , optLoadPrimitives            = True+  , optKeepCoveringClauses       = False   } -type OptM = Except String+-- | The options parse monad 'OptM' collects warnings that are not discarded+--   when a fatal error occurrs+newtype OptM a = OptM { unOptM :: ExceptT OptionError (Writer OptionWarnings) a }+  deriving (Functor, Applicative, Monad, MonadError OptionError, MonadWriter OptionWarnings) -runOptM :: Monad m => OptM opts -> m (Either String opts)-runOptM = pure . runExcept+type OptionError = String+type OptionWarnings = [OptionWarning] +runOptM :: OptM opts -> (Either OptionError opts, OptionWarnings)+runOptM = runWriter . runExceptT . unOptM+ {- | @f :: Flag opts@  is an action on the option record that results from      parsing an option.  @f opts@ produces either an error message or an      updated options record -} type Flag opts = opts -> OptM opts +-- | Warnings when parsing options.++data OptionWarning+  = OptionRenamed { oldOptionName :: String, newOptionName :: String }+  deriving (Show, Generic)++instance NFData OptionWarning++instance Pretty OptionWarning where+  pretty = \case+    OptionRenamed old new -> hsep+      [ "Option", name old, "is deprecated, please use", name new, "instead" ]+    where+    name = text . ("--" ++)++optionWarningName :: OptionWarning -> WarningName+optionWarningName = \case+  OptionRenamed{} -> OptionRenamed_+ -- | Checks that the given options are consistent. -checkOpts :: Flag CommandLineOptions+checkOpts :: MonadError OptionError m => CommandLineOptions -> m () checkOpts opts = do   -- NOTE: This is a temporary hold-out until --vim can be converted into a backend or plugin,   -- whose options compatibility currently is checked in `Agda.Compiler.Backend`.@@ -344,12 +415,11 @@   --     to the rest of the type-checking system.   when (optGenerateVimFile opts && optOnlyScopeChecking opts) $     throwError $ "The --only-scope-checking flag cannot be combined with --vim."-  return opts  -- | Check for unsafe pragmas. Gives a list of used unsafe flags. -unsafePragmaOptions :: CommandLineOptions -> PragmaOptions -> [String]-unsafePragmaOptions clo opts =+unsafePragmaOptions :: PragmaOptions -> [String]+unsafePragmaOptions opts =   [ "--allow-unsolved-metas"                     | optAllowUnsolved opts             ] ++   [ "--allow-incomplete-matches"                 | optAllowIncompleteMatch opts      ] ++   [ "--no-positivity-check"                      | optDisablePositivity opts         ] ++@@ -361,96 +431,155 @@   [ "--irrelevant-projections"                   | optIrrelevantProjections opts     ] ++   [ "--experimental-irrelevance"                 | optExperimentalIrrelevance opts   ] ++   [ "--rewriting"                                | optRewriting opts                 ] ++-  [ "--cubical and --with-K"                     | optCubical opts == Just CFull-                                                 , not (collapseDefault $ optWithoutK opts) ] ++-  [ "--erased-cubical and --with-K"              | optCubical opts == Just CErased+  [ "--cubical-compatible and --with-K"          | collapseDefault (optCubicalCompatible opts)                                                  , not (collapseDefault $ optWithoutK opts) ] +++  [ "--without-K and --flat-split"               | collapseDefault (optWithoutK opts)+                                                 , collapseDefault (optFlatSplit opts) ] ++   [ "--cumulativity"                             | optCumulativity opts              ] ++   [ "--allow-exec"                               | optAllowExec opts                 ] +++  [ "--no-load-primitives"                       | not $ optLoadPrimitives opts      ] ++   [] --- | If any these options have changed, then the file will be---   rechecked. Boolean options are negated to mention non-default---   options, where possible.+-- | This function returns 'True' if the file should be rechecked. -restartOptions :: [(PragmaOptions -> RestartCodomain, String)]-restartOptions =-  [ (C . optTerminationDepth, "--termination-depth")-  , (B . (/= UnicodeOk) . optUseUnicode, "--no-unicode")-  , (B . optAllowUnsolved, "--allow-unsolved-metas")-  , (B . optAllowIncompleteMatch, "--allow-incomplete-matches")-  , (B . optDisablePositivity, "--no-positivity-check")-  , (B . optTerminationCheck,  "--no-termination-check")-  , (B . not . optUniverseCheck, "--type-in-type")-  , (B . optOmegaInOmega, "--omega-in-omega")-  , (B . collapseDefault . optSubtyping, "--subtyping")-  , (B . optCumulativity, "--cumulativity")-  , (B . collapseDefault . optSizedTypes, "--no-sized-types")-  , (B . collapseDefault . optGuardedness, "--no-guardedness")-  , (B . optInjectiveTypeConstructors, "--injective-type-constructors")-  , (B . optProp, "--prop")-  , (B . collapseDefault . optTwoLevel, "--two-level")-  , (B . not . optUniversePolymorphism, "--no-universe-polymorphism")-  , (B . optIrrelevantProjections, "--irrelevant-projections")-  , (B . optExperimentalIrrelevance, "--experimental-irrelevance")-  , (B . collapseDefault . optWithoutK, "--without-K")-  , (B . optExactSplit, "--exact-split")-  , (B . not . optEta, "--no-eta-equality")-  , (B . optRewriting, "--rewriting")-  , (B . (== Just CFull) . optCubical, "--cubical")-  , (B . (== Just CErased) . optCubical, "--erased-cubical")-  , (B . optGuarded, "--guarded")-  , (B . optOverlappingInstances, "--overlapping-instances")-  , (B . optQualifiedInstances, "--qualified-instances")-  , (B . not . optQualifiedInstances, "--no-qualified-instances")-  , (B . optSafe, "--safe")-  , (B . optDoubleCheck, "--double-check")-  , (B . not . optSyntacticEquality, "--no-syntactic-equality")-  , (B . not . optAutoInline, "--no-auto-inline")-  , (B . not . optFastReduce, "--no-fast-reduce")-  , (B . optCallByName, "--call-by-name")-  , (I . optInstanceSearchDepth, "--instance-search-depth")-  , (I . optInversionMaxDepth, "--inversion-max-depth")-  , (W . optWarningMode, "--warning")-  , (B . (== Just LocalConfluenceCheck) . optConfluenceCheck, "--local-confluence-check")-  , (B . (== Just GlobalConfluenceCheck) . optConfluenceCheck, "--confluence-check")-  , (B . not . optImportSorts, "--no-import-sorts")-  , (B . optAllowExec, "--allow-exec")-  ]+recheckBecausePragmaOptionsChanged+  :: PragmaOptions+     -- ^ The options that were used to check the file.+  -> PragmaOptions+     -- ^ The options that are currently in effect.+  -> Bool+recheckBecausePragmaOptionsChanged used current =+  blankOut used /= blankOut current+  where+  -- "Blank out" irrelevant options.+  blankOut opts = opts+    { optShowImplicit              = False+    , optShowIrrelevant            = False+    , optVerbose                   = empty+    , optProfiling                 = noProfileOptions+    , optPostfixProjections        = False+    , optCompileNoMain             = False+    , optCaching                   = False+    , optCountClusters             = False+    , optPrintPatternSynonyms      = False+    , optShowIdentitySubstitutions = False+    } --- to make all restart options have the same type-data RestartCodomain = C CutOff | B Bool | I Int | W WarningMode-  deriving Eq+-- | Infective or coinfective? --- | An infective option is an option that if used in one module, must---   be used in all modules that depend on this module.+data InfectiveCoinfective+  = Infective+  | Coinfective+    deriving (Eq, Show, Generic)++instance NFData InfectiveCoinfective++-- | Descriptions of infective and coinfective options.++data InfectiveCoinfectiveOption = ICOption+  { icOptionActive :: PragmaOptions -> Bool+    -- ^ Is the option active?+  , icOptionDescription :: String+    -- ^ A description of the option (typically a flag that activates+    -- the option).+  , icOptionKind :: InfectiveCoinfective+    -- ^ Is the option (roughly speaking) infective or coinfective?+  , icOptionOK :: PragmaOptions -> PragmaOptions -> Bool+    -- ^ This function returns 'True' exactly when, from the+    -- perspective of the option in question, the options in the+    -- current module (the first argument) are compatible with the+    -- options in a given imported module (the second argument).+  , icOptionWarning :: TopLevelModuleName -> Doc+    -- ^ A warning message that should be used if this option is not+    -- used correctly. The given module name is the name of an+    -- imported module for which 'icOptionOK' failed.+  }++-- | A standard infective option: If the option is active in an+-- imported module, then it must be active in the current module.++infectiveOption+  :: (PragmaOptions -> Bool)+     -- ^ Is the option active?+  -> String+    -- ^ A description of the option.+  -> InfectiveCoinfectiveOption+infectiveOption opt s = ICOption+  { icOptionActive      = opt+  , icOptionDescription = s+  , icOptionKind        = Infective+  , icOptionOK          = \current imported ->+                           opt imported <= opt current+  , icOptionWarning     = \m -> fsep $+      pwords "Importing module" ++ [pretty m] ++ pwords "using the" +++      [text s] ++ pwords "flag from a module which does not."+  }++-- | A standard coinfective option: If the option is active in the+-- current module, then it must be active in all imported modules.++coinfectiveOption+  :: (PragmaOptions -> Bool)+     -- ^ Is the option active?+  -> String+    -- ^ A description of the option.+  -> InfectiveCoinfectiveOption+coinfectiveOption opt s = ICOption+  { icOptionActive      = opt+  , icOptionDescription = s+  , icOptionKind        = Coinfective+  , icOptionOK          = \current imported ->+                           opt current <= opt imported+  , icOptionWarning     = \m -> fsep $+      pwords "Importing module" ++ [pretty m] +++      pwords "not using the" ++ [text s] +++      pwords "flag from a module which does."+  }++-- | Infective and coinfective options. -- -- Note that @--cubical@ and @--erased-cubical@ are \"jointly -- infective\": if one of them is used in one module, then one or the -- other must be used in all modules that depend on this module. -infectiveOptions :: [(PragmaOptions -> Bool, String)]-infectiveOptions =-  [ (isJust . optCubical, "--cubical/--erased-cubical")-  , (optGuarded, "--guarded")-  , (optProp, "--prop")-  , (collapseDefault . optTwoLevel, "--two-level")-  , (optRewriting, "--rewriting")-  , (collapseDefault . optSizedTypes, "--sized-types")-  , (collapseDefault . optGuardedness, "--guardedness")-  ]---- | A coinfective option is an option that if used in one module, must---   be used in all modules that this module depends on.--coinfectiveOptions :: [(PragmaOptions -> Bool, String)]-coinfectiveOptions =-  [ (optSafe, "--safe")-  , (collapseDefault . optWithoutK, "--without-K")-  , (not . optUniversePolymorphism, "--no-universe-polymorphism")-  , (not . collapseDefault . optSubtyping, "--no-subtyping")-  , (not . optCumulativity, "--no-cumulativity")+infectiveCoinfectiveOptions :: [InfectiveCoinfectiveOption]+infectiveCoinfectiveOptions =+  [ coinfectiveOption optSafe "--safe"+  , coinfectiveOption (collapseDefault . optWithoutK) "--without-K"+  , cubicalCompatible+  , coinfectiveOption (not . optUniversePolymorphism)+                      "--no-universe-polymorphism"+  , coinfectiveOption (not . optCumulativity) "--no-cumulativity"+  , infectiveOption (isJust . optCubical) "--cubical/--erased-cubical"+  , infectiveOption optGuarded "--guarded"+  , infectiveOption optProp "--prop"+  , infectiveOption (collapseDefault . optTwoLevel) "--two-level"+  , infectiveOption optRewriting "--rewriting"+  , infectiveOption (collapseDefault . optSizedTypes) "--sized-types"+  , infectiveOption (collapseDefault . optGuardedness) "--guardedness"+  , infectiveOption (collapseDefault . optFlatSplit) "--flat-split"+  , infectiveOption optCohesion "--cohesion"   ]+  where+  cubicalCompatible =+    (coinfectiveOption+       (collapseDefault . optCubicalCompatible)+       "--cubical-compatible")+      { icOptionOK = \current imported ->+        -- One must use --cubical-compatible in the imported module if+        -- it is used in the current module, except if the current+        -- module also uses --with-K and not --safe, and the imported+        -- module uses --with-K.+        if collapseDefault (optCubicalCompatible current)+        then collapseDefault (optCubicalCompatible imported)+               ||+             not (collapseDefault (optWithoutK imported))+               &&+             not (collapseDefault (optWithoutK current))+               &&+             not (optSafe current)+        else True+      }  inputFlag :: FilePath -> Flag CommandLineOptions inputFlag f o =@@ -478,24 +607,29 @@              , optSizedTypes  = setDefault False sizedTypes              } -flatSplitFlag :: Flag PragmaOptions-flatSplitFlag o = return $ o { optFlatSplit = True }+cohesionFlag :: Flag PragmaOptions+cohesionFlag o = return $ o { optCohesion = True } -noFlatSplitFlag :: Flag PragmaOptions-noFlatSplitFlag o = return $ o { optFlatSplit = False }+flatSplitFlag :: Flag PragmaOptions+flatSplitFlag o = return $ o+  { optFlatSplit = Value True+  , optCohesion  = True+  }  doubleCheckFlag :: Bool -> Flag PragmaOptions doubleCheckFlag b o = return $ o { optDoubleCheck = b } -noSyntacticEqualityFlag :: Flag PragmaOptions-noSyntacticEqualityFlag o = return $ o { optSyntacticEquality = False }--noSortComparisonFlag :: Flag PragmaOptions-noSortComparisonFlag o = return o--sharingFlag :: Bool -> Flag CommandLineOptions-sharingFlag _ _ = throwError $-  "Feature --sharing has been removed (in favor of the Agda abstract machine)."+syntacticEqualityFlag :: Maybe String -> Flag PragmaOptions+syntacticEqualityFlag s o =+  case fuel of+    Left err   -> throwError err+    Right fuel -> return $ o { optSyntacticEquality = fuel }+  where+  fuel = case s of+    Nothing -> Right Strict.Nothing+    Just s  -> case readMaybe s of+      Just n | n >= 0 -> Right (Strict.Just n)+      _               -> Left $ "Not a natural number: " ++ s  cachingFlag :: Bool -> Flag PragmaOptions cachingFlag b o = return $ o { optCaching = b }@@ -527,6 +661,12 @@ localInterfacesFlag :: Flag CommandLineOptions localInterfacesFlag o = return $ o { optLocalInterfaces = True } +noLoadPrimitivesFlag :: Flag PragmaOptions+noLoadPrimitivesFlag o = return $ o+  { optLoadPrimitives = False+  , optImportSorts = False+  }+ allowUnsolvedFlag :: Flag PragmaOptions allowUnsolvedFlag o = do   let upd = over warningSet (Set.\\ unsolvedWarnings)@@ -561,12 +701,18 @@ jsonInteractionFlag :: Flag CommandLineOptions jsonInteractionFlag o = return $ o { optJSONInteraction = True } +interactionExitFlag :: Flag CommandLineOptions+interactionExitFlag o = return $ o { optExitOnError = True }+ vimFlag :: Flag CommandLineOptions vimFlag o = return $ o { optGenerateVimFile = True }  onlyScopeCheckingFlag :: Flag CommandLineOptions onlyScopeCheckingFlag o = return $ o { optOnlyScopeChecking = True } +transliterateFlag :: Flag CommandLineOptions+transliterateFlag o = return $ o { optTransliterate = True }+ countClustersFlag :: Flag PragmaOptions countClustersFlag o = #ifdef COUNT_CLUSTERS@@ -605,28 +751,14 @@              , optWarningMode   = upd (optWarningMode o)              } --- The option was removed. See Issue 1918.-dontCompletenessCheckFlag :: Flag PragmaOptions-dontCompletenessCheckFlag _ =-  throwError "The --no-coverage-check option has been removed."- dontUniverseCheckFlag :: Flag PragmaOptions dontUniverseCheckFlag o = return $ o { optUniverseCheck = False }  omegaInOmegaFlag :: Flag PragmaOptions omegaInOmegaFlag o = return $ o { optOmegaInOmega = True } -subtypingFlag :: Flag PragmaOptions-subtypingFlag o = return $ o { optSubtyping = Value True }--noSubtypingFlag :: Flag PragmaOptions-noSubtypingFlag o = return $ o { optSubtyping = Value False }- cumulativityFlag :: Flag PragmaOptions-cumulativityFlag o =-  return $ o { optCumulativity = True-             , optSubtyping    = setDefault True $ optSubtyping o-             }+cumulativityFlag o = return $ o { optCumulativity = True }  noCumulativityFlag :: Flag PragmaOptions noCumulativityFlag o = return $ o { optCumulativity = False }@@ -639,10 +771,7 @@ noEtaFlag o = return $ o { optEta = False }  sizedTypes :: Flag PragmaOptions-sizedTypes o =-  return $ o { optSizedTypes = Value True-             --, optSubtyping  = setDefault True $ optSubtyping o-             }+sizedTypes o = return $ o { optSizedTypes = Value True }  noSizedTypes :: Flag PragmaOptions noSizedTypes o = return $ o { optSizedTypes = Value False }@@ -656,10 +785,6 @@ injectiveTypeConstructorFlag :: Flag PragmaOptions injectiveTypeConstructorFlag o = return $ o { optInjectiveTypeConstructors = True } -guardingTypeConstructorFlag :: Flag PragmaOptions-guardingTypeConstructorFlag _ = throwError $-  "Experimental feature --guardedness-preserving-type-constructors has been removed."- universePolymorphismFlag :: Flag PragmaOptions universePolymorphismFlag o = return $ o { optUniversePolymorphism = True } @@ -676,7 +801,10 @@ withKFlag o = return $ o { optWithoutK = Value False }  withoutKFlag :: Flag PragmaOptions-withoutKFlag o = return $ o { optWithoutK = Value True }+withoutKFlag o = return $ o+  { optWithoutK = Value True+  , optFlatSplit = setDefault False (optFlatSplit o)+  }  copatternsFlag :: Flag PragmaOptions copatternsFlag o = return $ o { optCopatterns = True }@@ -707,14 +835,22 @@ firstOrderFlag :: Flag PragmaOptions firstOrderFlag o = return $ o { optFirstOrder = True } +cubicalCompatibleFlag :: Flag PragmaOptions+cubicalCompatibleFlag o =+  return $ o { optCubicalCompatible = Value True+             , optWithoutK = setDefault True $ optWithoutK o+             , optFlatSplit = setDefault False (optFlatSplit o)+             }+ cubicalFlag   :: Cubical  -- ^ Which variant of Cubical Agda?   -> Flag PragmaOptions-cubicalFlag variant o = do-  let withoutK = optWithoutK o+cubicalFlag variant o =   return $ o { optCubical  = Just variant-             , optWithoutK = setDefault True withoutK+             , optCubicalCompatible = setDefault True $ optCubicalCompatible o+             , optWithoutK = setDefault True $ optWithoutK o              , optTwoLevel = setDefault True $ optTwoLevel o+             , optFlatSplit = setDefault False (optFlatSplit o)              }  guardedFlag :: Flag PragmaOptions@@ -780,17 +916,30 @@ verboseFlag :: String -> Flag PragmaOptions verboseFlag s o =     do  (k,n) <- parseVerbose s-        return $ o { optVerbose = Trie.insert k n $ optVerbose o }+        return $+          o { optVerbose =+                Strict.Just $ Trie.insert k n $+                case optVerbose o of+                  Strict.Nothing -> Trie.singleton [] 1+                  Strict.Just v  -> v+            }   where-    parseVerbose :: String -> OptM ([VerboseKey], VerboseLevel)-    parseVerbose s = case wordsBy (`elem` (":." :: String)) s of+    parseVerbose :: String -> OptM ([VerboseKeyItem], VerboseLevel)+    parseVerbose s = case parseVerboseKey s of       []  -> usage       s0:ss0 -> do         let (ss, s) = initLast1 s0 ss0-        n <- maybe usage return $ readMaybe s+        -- The last entry must be a number.+        n <- maybe usage return $ readMaybe $ toList s         return (ss, n)     usage = throwError "argument to verbose should be on the form x.y.z:N or N" +profileFlag :: String -> Flag PragmaOptions+profileFlag s o =+  case addProfileOption s (optProfiling o) of+    Left err   -> throwError err+    Right prof -> pure o{ optProfiling = prof }+ warningModeFlag :: String -> Flag PragmaOptions warningModeFlag s o = case warningModeUpdate s of   Right upd -> return $ o { optWarningMode = upd (optWarningMode o) }@@ -815,11 +964,24 @@ allowExec :: Flag PragmaOptions allowExec o = return $ o { optAllowExec = True } +saveMetas :: Bool -> Flag PragmaOptions+saveMetas save o = return $ o { optSaveMetas = Value save }++eraseRecordParametersFlag :: Flag PragmaOptions+eraseRecordParametersFlag o = return $ o { optEraseRecordParameters = True }++noEraseRecordParametersFlag :: Flag PragmaOptions+noEraseRecordParametersFlag o = return $ o { optEraseRecordParameters = False }+ integerArgument :: String -> String -> OptM Int integerArgument flag s = maybe usage return $ readMaybe s   where   usage = throwError $ "option '" ++ flag ++ "' requires an integer argument" +keepCoveringClausesFlag :: Flag PragmaOptions+keepCoveringClausesFlag o = return $ o { optKeepCoveringClauses = True }++ standardOptions :: [OptDescr (Flag CommandLineOptions)] standardOptions =     [ Option ['V']  ["version"] (NoArg versionFlag)@@ -841,6 +1003,9 @@                     "for use with the Emacs mode"     , Option []     ["interaction-json"] (NoArg jsonInteractionFlag)                     "for use with other editors such as Atom"+    , Option []     ["interaction-exit-on-error"]+                    (NoArg interactionExitFlag)+                    "exit if a type error is encountered"      , Option []     ["compile-dir"] (ReqArg compileDirFlag "DIR")                     ("directory for compiler output (default: the project root)")@@ -863,6 +1028,8 @@                     "don't use default libraries"     , Option []     ["only-scope-checking"] (NoArg onlyScopeCheckingFlag)                     "only scope-check the top-level module, do not type-check it"+    , Option []     ["transliterate"] (NoArg transliterateFlag)+                    "transliterate unsupported code points when printing to stdout/stderr"     ] ++ map (fmap lensPragmaOptions) pragmaOptions  -- | Defined locally here since module ''Agda.Interaction.Options.Lenses''@@ -874,13 +1041,13 @@ --   Should not be listed in the usage info, put parsed by GetOpt for good error messaging. deadStandardOptions :: [OptDescr (Flag CommandLineOptions)] deadStandardOptions =-    [ Option []     ["sharing"] (NoArg $ sharingFlag True)-                    "DEPRECATED: does nothing"-    , Option []     ["no-sharing"] (NoArg $ sharingFlag False)-                    "DEPRECATED: does nothing"+    [ removedOption "sharing"    msgSharing+    , removedOption "no-sharing" msgSharing     , Option []     ["ignore-all-interfaces"] (NoArg ignoreAllInterfacesFlag) -- not deprecated! Just hidden                     "ignore all interface files (re-type check everything, including builtin files)"     ] ++ map (fmap lensPragmaOptions) deadPragmaOptions+  where+    msgSharing = "(in favor of the Agda abstract machine)"  pragmaOptions :: [OptDescr (Flag PragmaOptions)] pragmaOptions =@@ -894,6 +1061,8 @@                     "don't use unicode characters when printing terms"     , Option ['v']  ["verbose"] (ReqArg verboseFlag "N")                     "set verbosity level to N"+    , Option []     ["profile"] (ReqArg profileFlag "TYPE")+                    ("turn on profiling for TYPE (where TYPE=" ++ intercalate "|" validProfileOptionStrings ++ ")")     , Option []     ["allow-unsolved-metas"] (NoArg allowUnsolvedFlag)                     "succeed and create interface file regardless of unsolved meta variables"     , Option []     ["allow-incomplete-matches"] (NoArg allowIncompleteMatchFlag)@@ -908,12 +1077,8 @@                     "ignore universe levels (this makes Agda inconsistent)"     , Option []     ["omega-in-omega"] (NoArg omegaInOmegaFlag)                     "enable typing rule Setω : Setω (this makes Agda inconsistent)"-    , Option []     ["subtyping"] (NoArg subtypingFlag)-                    "enable subtyping rules in general (e.g. for irrelevance and erasure)"-    , Option []     ["no-subtyping"] (NoArg noSubtypingFlag)-                    "disable subtyping rules in general (e.g. for irrelevance and erasure) (default)"     , Option []     ["cumulativity"] (NoArg cumulativityFlag)-                    "enable subtyping of universes (e.g. Set =< Set₁) (implies --subtyping)"+                    "enable subtyping of universes (e.g. Set =< Set₁)"     , Option []     ["no-cumulativity"] (NoArg noCumulativityFlag)                     "disable subtyping of universes (default)"     , Option []     ["prop"] (NoArg propFlag)@@ -923,17 +1088,17 @@     , Option []     ["two-level"] (NoArg twoLevelFlag)                     "enable the use of SSet* universes"     , Option []     ["sized-types"] (NoArg sizedTypes)-                    "enable sized types (default, inconsistent with --guardedness, implies --subtyping)"+                    "enable sized types (inconsistent with --guardedness)"     , Option []     ["no-sized-types"] (NoArg noSizedTypes)-                    "disable sized types"+                    "disable sized types (default)"+    , Option []     ["cohesion"] (NoArg cohesionFlag)+                    "enable the cohesion modalities (in particular @flat)"     , Option []     ["flat-split"] (NoArg flatSplitFlag)-                    "allow split on (@flat x : A) arguments (default)"-    , Option []     ["no-flat-split"] (NoArg noFlatSplitFlag)-                    "disable split on (@flat x : A) arguments"+                    "allow split on (@flat x : A) arguments (implies --cohesion)"     , Option []     ["guardedness"] (NoArg guardedness)-                    "enable constructor-based guarded corecursion (default, inconsistent with --sized-types)"+                    "enable constructor-based guarded corecursion (inconsistent with --sized-types)"     , Option []     ["no-guardedness"] (NoArg noGuardedness)-                    "disable constructor-based guarded corecursion"+                    "disable constructor-based guarded corecursion (default)"     , Option []     ["injective-type-constructors"] (NoArg injectiveTypeConstructorFlag)                     "enable injective type constructors (makes Agda anti-classical and possibly inconsistent)"     , Option []     ["no-universe-polymorphism"] (NoArg noUniversePolymorphismFlag)@@ -948,8 +1113,10 @@                     "enable potentially unsound irrelevance features (irrelevant levels, irrelevant data matching)"     , Option []     ["with-K"] (NoArg withKFlag)                     "enable the K rule in pattern matching (default)"+    , Option []     ["cubical-compatible"] (NoArg cubicalCompatibleFlag)+                    "turn on generation of auxiliary code required for --cubical, implies --without-K"     , Option []     ["without-K"] (NoArg withoutKFlag)-                    "disable the K rule in pattern matching"+                    "turn on checks to make code compatible with HoTT (e.g. disabling the K rule). Implies --no-flat-split."     , Option []     ["copatterns"] (NoArg copatternsFlag)                     "enable definitions by copattern matching (default)"     , Option []     ["no-copatterns"] (NoArg noCopatternsFlag)@@ -966,6 +1133,10 @@                     "disable the forcing analysis for data constructors (optimisation)"     , Option []     ["no-projection-like"] (NoArg noProjectionLikeFlag)                     "disable the analysis whether function signatures liken those of projections (optimisation)"+    , Option []     ["erase-record-parameters"] (NoArg eraseRecordParametersFlag)+                    "mark all parameters of record modules as erased"+    , Option []     ["no-erase-record-parameters"] (NoArg noEraseRecordParametersFlag)+                    "do mark all parameters of record modules as erased (default)"     , Option []     ["rewriting"] (NoArg rewritingFlag)                     "enable declaration and use of REWRITE rules"     , Option []     ["local-confluence-check"] (NoArg $ confluenceCheckFlag LocalConfluenceCheck)@@ -975,13 +1146,12 @@     , Option []     ["no-confluence-check"] (NoArg noConfluenceCheckFlag)                     "disable confluence checking of REWRITE rules (default)"     , Option []     ["cubical"] (NoArg $ cubicalFlag CFull)-                    "enable cubical features (e.g. overloads lambdas for paths), implies --without-K"+                    "enable cubical features (e.g. overloads lambdas for paths), implies --cubical-compatible"     , Option []     ["erased-cubical"] (NoArg $ cubicalFlag CErased)-                    "enable cubical features (some only in erased settings), implies --without-K"+                    "enable cubical features (some only in erased settings), implies --cubical-compatible"     , Option []     ["guarded"] (NoArg guardedFlag)                     "enable @lock/@tick attributes"-    , Option []     ["experimental-lossy-unification"] (NoArg firstOrderFlag)-                    "enable heuristically unifying `f es = f es'` by unifying `es = es'`, even when it could lose solutions."+    , lossyUnificationOption     , Option []     ["postfix-projections"] (NoArg postfixProjectionsFlag)                     "make postfix projection notation the default"     , Option []     ["keep-pattern-variables"] (NoArg keepPatternVariablesFlag)@@ -1004,8 +1174,10 @@                     "enable double-checking of all terms using the internal typechecker"     , Option []     ["no-double-check"] (NoArg (doubleCheckFlag False))                     "disable double-checking of terms (default)"-    , Option []     ["no-syntactic-equality"] (NoArg noSyntacticEqualityFlag)+    , Option []     ["no-syntactic-equality"] (NoArg $ syntacticEqualityFlag (Just "0"))                     "disable the syntactic equality shortcut in the conversion checker"+    , Option []     ["syntactic-equality"] (OptArg syntacticEqualityFlag "FUEL")+                    "give the syntactic equality shortcut FUEL units of fuel (default: unlimited)"     , Option ['W']  ["warning"] (ReqArg warningModeFlag "FLAG")                     ("set warning flags. See --help=warning.")     , Option []     ["no-main"] (NoArg compileFlagNoMain)@@ -1036,22 +1208,75 @@                     "use call-by-name evaluation instead of call-by-need"     , Option []     ["no-import-sorts"] (NoArg noImportSorts)                     "disable the implicit import of Agda.Primitive using (Set; Prop) at the start of each top-level module"+    , Option []     ["no-load-primitives"] (NoArg noLoadPrimitivesFlag)+                    "disable loading of primitive modules at all (implies --no-import-sorts)"     , Option []     ["allow-exec"] (NoArg allowExec)                     "allow system calls to trusted executables with primExec"+    , Option []     ["save-metas"] (NoArg $ saveMetas True)+                    "save meta-variables"+    , Option []     ["no-save-metas"] (NoArg $ saveMetas False)+                    "do not save meta-variables (the default)"+    , Option []     ["keep-covering-clauses"] (NoArg keepCoveringClausesFlag)+                    "do not discard covering clauses (required for some external backends)"     ] +lossyUnificationOption :: OptDescr (Flag PragmaOptions)+lossyUnificationOption =+      Option []     ["lossy-unification"] (NoArg firstOrderFlag)+                    "enable heuristically unifying `f es = f es'` by unifying `es = es'`, even when it could lose solutions"+ -- | Pragma options of previous versions of Agda. --   Should not be listed in the usage info, put parsed by GetOpt for good error messaging. deadPragmaOptions :: [OptDescr (Flag PragmaOptions)]-deadPragmaOptions =-    [ Option []     ["guardedness-preserving-type-constructors"] (NoArg guardingTypeConstructorFlag)-                    "treat type constructors as inductive constructors when checking productivity"-    , Option []     ["no-coverage-check"] (NoArg dontCompletenessCheckFlag)-                    "the option has been removed"-    , Option []     ["no-sort-comparison"] (NoArg noSortComparisonFlag)-                    "disable the comparison of sorts when checking conversion of types"+deadPragmaOptions = concat+  [ map (uncurry removedOption)+    [ ("guardedness-preserving-type-constructors"+      , "")+    , ("no-coverage-check"+      , inVersion "2.5.1") -- see issue #1918+    , ("no-sort-comparison"+      , "")+    , ("subtyping"+      , inVersion "2.6.3") -- see issue #5427+    , ("no-subtyping"+      , inVersion "2.6.3") -- see issue #5427+    , ("no-flat-split", inVersion "2.6.3")  -- See issue #6263.     ]+  , map (uncurry renamedNoArgOption)+    [ ( "experimental-lossy-unification"+      , lossyUnificationOption+      )+    ]+  ]+  where+    inVersion = ("in version " ++) +-- | Generate a dead options that just error out saying this option has been removed.+removedOption ::+     String+       -- ^ The name of the removed option.+  -> String+       -- ^ Optional: additional remark, like in which version the option was removed.+  -> OptDescr (Flag a)+removedOption name remark = Option [] [name] (NoArg $ const $ throwError msg) msg+  where+  msg = unwords ["Option", "--" ++ name, "has been removed", remark]++-- | Generate a deprecated option that resolves to another option.+renamedNoArgOption ::+     String+       -- ^ The deprecated long option name.+  -> OptDescr (Flag a)+       -- ^ The new option.+  -> OptDescr (Flag a)+       -- ^ The old option which additionally emits a 'RenamedOption' warning.+renamedNoArgOption old = \case+  Option _ [new] (NoArg flag) description ->+    Option [] [old] (NoArg flag') $ concat [description, " (DEPRECATED, use --", new, ")"]+    where+    flag' o = tell1 (OptionRenamed old new) >> flag o+  _ -> __IMPOSSIBLE__+ -- | Used for printing usage info. --   Does not include the dead options. standardOptions_ :: [OptDescr ()]@@ -1105,17 +1330,6 @@       sugs [a] = a       sugs as  = "any of " ++ unwords as -{- No longer used in favour of parseBackendOptions in Agda.Compiler.Backend--- | Parse the standard options.-parseStandardOptions :: [String] -> OptM CommandLineOptions-parseStandardOptions argv = parseStandardOptions' argv defaultOptions--parseStandardOptions' :: [String] -> Flag CommandLineOptions-parseStandardOptions' argv opts = do-  opts <- getOptSimple (stripRTS argv) (deadStandardOptions ++ standardOptions) inputFlag opts-  checkOpts opts--}- -- | Parse options from an options pragma. parsePragmaOptions   :: [String]@@ -1127,7 +1341,7 @@   ps <- getOptSimple argv (deadPragmaOptions ++ pragmaOptions)           (\s _ -> throwError $ "Bad option in pragma: " ++ s)           (optPragmaOptions opts)-  _ <- checkOpts (opts { optPragmaOptions = ps })+  () <- checkOpts (opts { optPragmaOptions = ps })   return ps  -- | Parse options for a plugin.
src/full/Agda/Interaction/Options/Warnings.hs view
@@ -30,6 +30,7 @@ import Text.Read ( readMaybe ) import Data.Set (Set) import qualified Data.Set as Set+import qualified Data.HashMap.Strict as HMap import Data.List ( stripPrefix, intercalate )  import GHC.Generics (Generic)@@ -166,9 +167,10 @@ -- to existing warnings in the codebase.  data WarningName-  =+  -- Option Warnings+  = OptionRenamed_   -- Parser Warnings-    OverlappingTokensWarning_+  | OverlappingTokensWarning_   | UnsupportedAttribute_   | MultipleAttributes_   -- Library Warnings@@ -186,6 +188,7 @@   | EmptyPrivate_   | EmptyRewritePragma_   | EmptyWhere_+  | HiddenGeneralize_   | InvalidCatchallPragma_   | InvalidConstructor_   | InvalidConstructorBlock_@@ -231,6 +234,7 @@   | NoGuardednessFlag_   | NotInScope_   | NotStrictlyPositive_+  | UnsupportedIndexedMatch_   | OldBuiltin_   | PragmaCompileErased_   | RewriteMaybeNonConfluent_@@ -273,9 +277,9 @@ -- | The flag corresponding to a warning is precisely the name of the constructor -- minus the trailing underscore. --- sorry string2WarningName :: String -> Maybe WarningName-string2WarningName = readMaybe . (++ "_")+string2WarningName = (`HMap.lookup` warnings) where+  warnings = HMap.fromList $ map (\x -> (warningName2String x, x)) [minBound..maxBound]  warningName2String :: WarningName -> String warningName2String = initWithDefault __IMPOSSIBLE__ . show@@ -321,6 +325,8 @@  warningNameDescription :: WarningName -> String warningNameDescription = \case+  -- Option Warnings+  OptionRenamed_                   -> "Renamed options."   -- Parser Warnings   OverlappingTokensWarning_        -> "Multi-line comments spanning one or more literate text blocks."   UnsupportedAttribute_            -> "Unsupported attributes."@@ -340,6 +346,7 @@   EmptyPrivate_                    -> "Empty `private' blocks."   EmptyRewritePragma_              -> "Empty `REWRITE' pragmas."   EmptyWhere_                      -> "Empty `where' blocks."+  HiddenGeneralize_                -> "Hidden identifiers in variable blocks."   InvalidCatchallPragma_           -> "`CATCHALL' pragmas before a non-function clause."   InvalidConstructor_              -> "`constructor' blocks may only contain type signatures for constructors."   InvalidConstructorBlock_         -> "No `constructor' blocks outside of `interleaved mutual' blocks."@@ -389,6 +396,7 @@   FixityInRenamingModule_          -> "Found fixity annotation in renaming directive for module."   NotInScope_                      -> "Out of scope name."   NotStrictlyPositive_             -> "Failed strict positivity checks."+  UnsupportedIndexedMatch_         -> "Failed to compute full equivalence when splitting on indexed family."   OldBuiltin_                      -> "Deprecated `BUILTIN' pragmas."   PragmaCompileErased_             -> "`COMPILE' pragma targeting an erased symbol."   RewriteMaybeNonConfluent_        -> "Failed local confluence check while computing overlap."@@ -413,7 +421,7 @@   UnsolvedMetaVariables_           -> "Unsolved meta variables."   UserWarning_                     -> "User-defined warning added using one of the 'WARNING_ON_*' pragmas."   WithoutKFlagPrimEraseEquality_   -> "`primEraseEquality' usages with the without-K flags."-  WrongInstanceDeclaration_        -> "Terms marked as eligible for instance search should end with a name."+  WrongInstanceDeclaration_        -> "Instances that do not adhere to the required format."   -- Checking consistency of options   CoInfectiveImport_               -> "Importing a file not using e.g. `--safe'  from one which does."   InfectiveImport_                 -> "Importing a file using e.g. `--cubical' into one which doesn't."
src/full/Agda/Interaction/Response.hs view
@@ -30,10 +30,10 @@   ) import Agda.Interaction.Highlighting.Precise import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Common   (InteractionId(..), Arg)-import Agda.Syntax.Concrete (Expr, Name)-import Agda.Syntax.Concrete.Name (NameInScope)-import Agda.Syntax.Scope.Base (AbstractModule, AbstractName, LocalVar)+import Agda.Syntax.Common         (InteractionId(..), Arg)+import Agda.Syntax.Concrete       (Expr)+import Agda.Syntax.Concrete.Name  (Name, QName, NameInScope)+import Agda.Syntax.Scope.Base     (AbstractModule, AbstractName, LocalVar, WhyInScopeData) import qualified Agda.Syntax.Internal as I import {-# SOURCE #-} Agda.TypeChecking.Monad.Base   (TCM, TCErr, TCWarning, HighlightingMethod, ModuleToSource, NamedMeta, TCWarning, IPBoundary')@@ -108,7 +108,7 @@         --   TODO: split these into separate constructors     | Info_ModuleContents [Name] I.Telescope [(Name, I.Type)]     | Info_SearchAbout [(Name, I.Type)] String-    | Info_WhyInScope String FilePath (Maybe LocalVar) [AbstractName] [AbstractModule]+    | Info_WhyInScope WhyInScopeData     | Info_NormalForm CommandState ComputeMode (Maybe CPUTime) A.Expr     | Info_InferredType CommandState (Maybe CPUTime) A.Expr     | Info_Context InteractionId [ResponseContextEntry]
src/full/Agda/Main.hs view
@@ -5,6 +5,7 @@  import Prelude hiding (null) +import qualified Control.Exception as E import Control.Monad          ( void ) import Control.Monad.Except   ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) )@@ -13,7 +14,9 @@ import Data.Maybe  import System.Environment+import System.Exit import System.Console.GetOpt+import qualified System.IO as IO  import Paths_Agda            ( getDataDir ) @@ -51,26 +54,45 @@  -- | The main function without importing built-in backends runAgda' :: [Backend] -> IO ()-runAgda' backends = do-  progName <- getProgName-  argv     <- getArgs-  conf     <- runExceptT $ do-    (bs, opts) <- ExceptT $ runOptM $ parseBackendOptions backends argv defaultOptions+runAgda' backends = runTCMPrettyErrors $ do+  progName <- liftIO getProgName+  argv     <- liftIO getArgs+  let (z, warns) = runOptM $ parseBackendOptions backends argv defaultOptions+  mapM_ (warning . OptionWarning) warns+  conf     <- liftIO $ runExceptT $ do+    (bs, opts) <- ExceptT $ pure z     -- The absolute path of the input file, if provided     inputFile <- liftIO $ mapM absolute $ optInputFile opts     mode      <- getMainMode bs inputFile opts     return (bs, opts, mode)    case conf of-    Left err -> optionError err-    Right (bs, opts, mode) -> case mode of-      MainModePrintHelp hp   -> printUsage bs hp-      MainModePrintVersion   -> printVersion bs-      MainModePrintAgdaDir   -> printAgdaDir-      MainModeRun interactor -> runTCMPrettyErrors $ do-        setTCLens stBackends bs-        runAgdaWithOptions interactor progName opts+    Left err -> liftIO $ optionError err+    Right (bs, opts, mode) -> do +      when (optTransliterate opts) $ liftIO $ do+        -- When --interaction or --interaction-json is used, then we+        -- use UTF-8 when writing to stdout (and when reading from+        -- stdin).+        if optGHCiInteraction opts || optJSONInteraction opts+        then optionError $+               "The option --transliterate must not be combined with " +++               "--interaction or --interaction-json"+        else do+          -- Transliterate unsupported code points.+          enc <- IO.mkTextEncoding+                   (show IO.localeEncoding ++ "//TRANSLIT")+          IO.hSetEncoding IO.stdout enc+          IO.hSetEncoding IO.stderr enc++      case mode of+        MainModePrintHelp hp   -> liftIO $ printUsage bs hp+        MainModePrintVersion   -> liftIO $ printVersion bs+        MainModePrintAgdaDir   -> liftIO $ printAgdaDir+        MainModeRun interactor -> do+          setTCLens stBackends bs+          runAgdaWithOptions interactor progName opts+ -- | Main execution mode data MainMode   = MainModeRun (Interactor ())@@ -182,7 +204,7 @@             Bench.print              -- Print accumulated statistics.-            printStatistics 1 Nothing =<< useTC lensAccumStatistics+            printStatistics Nothing =<< useTC lensAccumStatistics   where     -- Options are fleshed out here so that (most) errors like     -- "bad library path" are validated within the interactor,@@ -253,17 +275,84 @@   exitAgdaWith OptionError  -- | Run a TCM action in IO; catch and pretty print errors.++-- If some error message cannot be printed due to locale issues, then+-- one may get the "Error when handling error" error message. There is+-- currently no test case for this error, but on some systems one can+-- (at the time of writing) trigger it by running @LC_CTYPE=C agda+-- --no-libraries Bug.agda@, where @Bug.agda@ contains the following+-- code (if there is some other file in the same directory, for+-- instance @Bug.lagda@, then the error message may be different):+--+-- @+-- _ : Set+-- _ = Set+-- @+ runTCMPrettyErrors :: TCM () -> IO () runTCMPrettyErrors tcm = do-    r <- runTCMTop $ tcm `catchError` \err -> do-      s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err-      s1  <- prettyError err-      let ss = filter (not . null) $ s2s ++ [s1]-      unless (null s1) (liftIO $ putStr $ unlines ss)-      throwError err-    case r of-      Right _ -> exitSuccess-      Left _  -> exitAgdaWith TCMError-  `catchImpossible` \e -> do-    putStr $ show e-    exitAgdaWith ImpossibleError+  r <- runTCMTop+    ( ( (Nothing <$ tcm)+          `catchError` \err -> do+            s2s <- prettyTCWarnings' =<< getAllWarningsOfTCErr err+            s1  <- prettyError err+            let ss = filter (not . null) $ s2s ++ [s1]+            unless (null s1) (liftIO $ putStr $ unlines ss)+            liftIO $ helpForLocaleError err+            return (Just TCMError)+      ) `catchImpossible` \e -> do+          liftIO $ putStr $ E.displayException e+          return (Just ImpossibleError)+    ) `E.catches`+        -- Catch all exceptions except for those of type ExitCode+        -- (which are thrown by exitWith) and asynchronous exceptions+        -- (which are for instance raised when Ctrl-C is used, or if+        -- the program runs out of heap or stack space).+        [ E.Handler $ \(e :: ExitCode)         -> E.throw e+        , E.Handler $ \(e :: E.AsyncException) -> E.throw e+        , E.Handler $ \(e :: E.SomeException)  -> do+            liftIO $ putStr $ E.displayException e+            return $ Right (Just UnknownError)+        ]+  case r of+    Right Nothing       -> exitSuccess+    Right (Just reason) -> exitAgdaWith reason+    Left err            -> do+      liftIO $ do+        putStrLn "\n\nError when handling error:"+        putStrLn $ tcErrString err+        helpForLocaleError err+      exitAgdaWith UnknownError++-- | If the error is an IO error, and the error message suggests that+-- the problem is related to locales or code pages, print out some+-- extra information.++helpForLocaleError :: TCErr -> IO ()+helpForLocaleError e = case e of+  (IOException _ _ e)+    | "invalid argument" `List.isInfixOf` show e -> msg+  _                                              -> return ()+  where+  msg = putStr $ unlines+    [ ""+    , "This error may be due to the use of a locale or code page that does not"+    , "support some character used in the program being type-checked."+    , ""+    , "If it is, then one option is to use the option --transliterate, in which"+    , "case unsupported characters are (hopefully) replaced with something else,"+    , "perhaps question marks. However, that could make the output harder to"+    , "read."+    , ""+    , "If you want to fix the problem \"properly\", then you could try one of the"+    , "following suggestions:"+    , ""+    , "* If you are using Windows, try switching to a different code page (for"+    , "  instance by running the command 'CHCP 65001')."+    , ""+    , "* If you are using a Unix-like system, try using a different locale. The"+    , "  installed locales are perhaps printed by the command 'locale -a'. If"+    , "  you have a UTF-8 locale installed (for instance sv_SE.UTF-8), then you"+    , "  can perhaps make Agda use this locale by running something like"+    , "  'LC_ALL=sv_SE.UTF-8 agda <...>'."+    ]
src/full/Agda/Syntax/Abstract.hs view
@@ -23,7 +23,6 @@ import qualified Data.Set as Set import Data.Set (Set) import Data.Void-import Data.Data (Data)  import GHC.Generics (Generic) @@ -56,7 +55,7 @@ -- e.g. in @{_ : A} -> ..@ vs. @{r : A} -> ..@.  newtype BindName = BindName { unBind :: Name }-  deriving (Show, Data, HasRange, KillRange, SetRange, NFData)+  deriving (Show, HasRange, KillRange, SetRange, NFData)  mkBindName :: Name -> BindName mkBindName x = BindName x@@ -73,6 +72,10 @@  type Args = [NamedArg Expr] +-- | Types are just expressions.+-- Use this type synonym for hinting that an expression should be a type.+type Type = Expr+ -- | Expressions after scope checking (operators parsed, names resolved). data Expr   = Var  Name                          -- ^ Bound variable.@@ -98,12 +101,11 @@   | Lam  ExprInfo LamBinding Expr      -- ^ @λ bs → e@.   | AbsurdLam ExprInfo Hiding          -- ^ @λ()@ or @λ{}@.   | ExtendedLam ExprInfo DefInfo Erased QName (List1 Clause)-  | Pi   ExprInfo Telescope1 Expr      -- ^ Dependent function space @Γ → A@.-  | Generalized (Set QName) Expr       -- ^ Like a Pi, but the ordering is not known-  | Fun  ExprInfo (Arg Expr) Expr      -- ^ Non-dependent function space.+  | Pi   ExprInfo Telescope1 Type      -- ^ Dependent function space @Γ → A@.+  | Generalized (Set QName) Type       -- ^ Like a Pi, but the ordering is not known+  | Fun  ExprInfo (Arg Type) Type      -- ^ Non-dependent function space.   | Let  ExprInfo (List1 LetBinding) Expr                                        -- ^ @let bs in e@.-  | ETel Telescope                     -- ^ Only used when printing telescopes.   | Rec  ExprInfo RecordAssigns        -- ^ Record construction.   | RecUpdate ExprInfo Expr Assigns    -- ^ Record update.   | ScopedExpr ScopeInfo Expr          -- ^ Scope annotation.@@ -111,14 +113,14 @@   | QuoteTerm ExprInfo                 -- ^ Quote a term.   | Unquote ExprInfo                   -- ^ The splicing construct: unquote ...   | DontCare Expr                      -- ^ For printing @DontCare@ from @Syntax.Internal@.-  deriving (Data, Show, Generic)+  deriving (Show, Generic) --- | Pattern synonym for regular Def+-- | Pattern synonym for regular 'Def'. pattern Def :: QName -> Expr pattern Def x = Def' x NoSuffix --- | Smart constructor for Generalized-generalized :: Set QName -> Expr -> Expr+-- | Smart constructor for 'Generalized'.+generalized :: Set QName -> Type -> Type generalized s e     | null s    = e     | otherwise = Generalized s e@@ -135,7 +137,7 @@ data ScopeCopyInfo = ScopeCopyInfo   { renModules :: Ren ModuleName   , renNames   :: Ren QName }-  deriving (Eq, Show, Data, Generic)+  deriving (Eq, Show, Generic)  initCopyInfo :: ScopeCopyInfo initCopyInfo = ScopeCopyInfo@@ -155,15 +157,15 @@ type RecordDirectives = RecordDirectives' QName  data Declaration-  = Axiom      KindOfName DefInfo ArgInfo (Maybe [Occurrence]) QName Expr+  = Axiom      KindOfName DefInfo ArgInfo (Maybe [Occurrence]) QName Type     -- ^ Type signature (can be irrelevant, but not hidden).     --     -- The fourth argument contains an optional assignment of     -- polarities to arguments.-  | Generalize (Set QName) DefInfo ArgInfo QName Expr+  | Generalize (Set QName) DefInfo ArgInfo QName Type     -- ^ First argument is set of generalizable variables used in the type.-  | Field      DefInfo QName (Arg Expr)              -- ^ record field-  | Primitive  DefInfo QName (Arg Expr)              -- ^ primitive function+  | Field      DefInfo QName (Arg Type)              -- ^ record field+  | Primitive  DefInfo QName (Arg Type)              -- ^ primitive function   | Mutual     MutualInfo [Declaration]              -- ^ a bunch of mutually recursive definitions   | Section    Range ModuleName GeneralizeTelescope [Declaration]   | Apply      ModuleInfo ModuleName ModuleApplication ScopeCopyInfo ImportDirective@@ -174,19 +176,20 @@   | Open       ModuleInfo ModuleName ImportDirective     -- ^ only retained for highlighting purposes   | FunDef     DefInfo QName Delayed [Clause] -- ^ sequence of function clauses-  | DataSig    DefInfo QName GeneralizeTelescope Expr -- ^ lone data signature+  | DataSig    DefInfo QName GeneralizeTelescope Type -- ^ lone data signature   | DataDef    DefInfo QName UniverseCheck DataDefParams [Constructor]-  | RecSig     DefInfo QName GeneralizeTelescope Expr -- ^ lone record signature-  | RecDef     DefInfo QName UniverseCheck RecordDirectives DataDefParams Expr [Declaration]-      -- ^ The 'Expr' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,+  | RecSig     DefInfo QName GeneralizeTelescope Type -- ^ lone record signature+  | RecDef     DefInfo QName UniverseCheck RecordDirectives DataDefParams Type [Declaration]+      -- ^ The 'Type' gives the constructor type telescope, @(x1 : A1)..(xn : An) -> Prop@,       --   and the optional name is the constructor's name.       --   The optional 'Range' is for the @pattern@ attribute.   | PatternSynDef QName [Arg BindName] (Pattern' Void)       -- ^ Only for highlighting purposes   | UnquoteDecl MutualInfo [DefInfo] [QName] Expr   | UnquoteDef  [DefInfo] [QName] Expr+  | UnquoteData [DefInfo] QName UniverseCheck [DefInfo] [QName] Expr   | ScopedDecl ScopeInfo [Declaration]  -- ^ scope annotation-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  type DefInfo = DefInfo' Expr @@ -199,7 +202,7 @@       -- ^ @tel. M args@:  applies @M@ to @args@ and abstracts @tel@.     | RecordModuleInstance ModuleName       -- ^ @M {{...}}@-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  data Pragma   = OptionsPragma [String]@@ -218,12 +221,14 @@     --   @eta-equality@ definition (as it is might make Agda loop).   | InjectivePragma QName   | InlinePragma Bool QName -- INLINE or NOINLINE+  | NotProjectionLikePragma QName+    -- Mark the definition as not being projection-like   | DisplayPragma QName [NamedArg Pattern] Expr-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Bindings that are valid in a @let@. data LetBinding-  = LetBind LetInfo ArgInfo BindName Expr Expr+  = LetBind LetInfo ArgInfo BindName Type Expr     -- ^ @LetBind info rel name type defn@   | LetPatBind LetInfo Pattern Expr     -- ^ Irrefutable pattern binding.@@ -235,8 +240,7 @@   | LetDeclaredVariable BindName     -- ^ Only used for highlighting. Refers to the first occurrence of     -- @x@ in @let x : A; x = e@.---  | LetGeneralize DefInfo ArgInfo Expr-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Only 'Axiom's. type TypeSignature  = Declaration@@ -249,7 +253,7 @@ data Binder' a = Binder   { binderPattern :: Maybe Pattern   , binderName    :: a-  } deriving (Data, Show, Eq, Functor, Foldable, Traversable, Generic)+  } deriving (Show, Eq, Functor, Foldable, Traversable, Generic)  type Binder = Binder' BindName @@ -268,11 +272,31 @@     -- ^ . @x@ or @{x}@ or @.x@ or @{x = y}@ or @x\@p@ or @(p)@   | DomainFull TypedBinding     -- ^ . @(xs:e)@ or @{xs:e}@ or @(let Ds)@-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  mkDomainFree :: NamedArg Binder -> LamBinding mkDomainFree = DomainFree Nothing +-- | Extra information that is attached to a typed binding, that plays a+-- role during type checking but strictly speaking is not part of the+-- @name : type@" relation which a makes up a binding.+data TypedBindingInfo+  = TypedBindingInfo+    { tbTacticAttr :: TacticAttr+      -- ^ Does this binding have a tactic annotation?+    , tbFinite     :: Bool+      -- ^ Does this binding correspond to a Partial binder, rather than+      -- to a Pi binder? Must be present here to be reflected into+      -- abstract syntax later (and to be printed to the user later).+    }+  deriving (Show, Eq, Generic)++defaultTbInfo :: TypedBindingInfo+defaultTbInfo = TypedBindingInfo+  { tbTacticAttr = Nothing+  , tbFinite = False+  }+ -- | A typed binding.  Appears in dependent function spaces, typed lambdas, and --   telescopes.  It might be tempting to simplify this to only bind a single --   name at a time, and translate, say, @(x y : A)@ to @(x : A)(y : A)@@@ -288,14 +312,14 @@ --   that the metas of the copy are aliases of the metas of the original.  data TypedBinding-  = TBind Range TacticAttr (List1 (NamedArg Binder)) Expr+  = TBind Range TypedBindingInfo (List1 (NamedArg Binder)) Type     -- ^ As in telescope @(x y z : A)@ or type @(x y z : A) -> B@.   | TLet Range (List1 LetBinding)     -- ^ E.g. @(let x = e)@ or @(let open M)@.-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic) -mkTBind :: Range -> List1 (NamedArg Binder) -> Expr -> TypedBinding-mkTBind r = TBind r Nothing+mkTBind :: Range -> List1 (NamedArg Binder) -> Type -> TypedBinding+mkTBind r = TBind r defaultTbInfo  mkTLet :: Range -> [LetBinding] -> Maybe TypedBinding mkTLet _ []     = Nothing@@ -304,7 +328,7 @@ type Telescope1 = List1 TypedBinding type Telescope  = [TypedBinding] -mkPi :: ExprInfo -> Telescope -> Expr -> Expr+mkPi :: ExprInfo -> Telescope -> Type -> Type mkPi i []     e = e mkPi i (x:xs) e = Pi i (x :| xs) e @@ -313,7 +337,7 @@     -- ^ Maps generalize variables to the corresponding bound variable (to be     --   introduced by the generalisation).   , generalizeTel     :: Telescope }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  data DataDefParams = DataDefParams   { dataDefGeneralizedParams :: Set Name@@ -321,7 +345,7 @@     --   sig, so we keep these in a set on the side.   , dataDefParams :: [LamBinding]   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  noDataDefParams :: DataDefParams noDataDefParams = DataDefParams Set.empty []@@ -343,7 +367,7 @@   { problemInPat :: Pattern   , problemInst  :: I.Term   , problemType  :: I.Dom I.Type-  } deriving (Data, Show, Generic)+  } deriving (Show, Generic)  -- These are not relevant for caching purposes instance Eq ProblemEq where _ == _ = True@@ -359,18 +383,20 @@   , clauseRHS        :: RHS   , clauseWhereDecls :: WhereDeclarations   , clauseCatchall   :: Bool-  } deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)+  } deriving (Show, Functor, Foldable, Traversable, Eq, Generic)  data WhereDeclarations = WhereDecls   { whereModule :: Maybe ModuleName       -- #2897: we need to restrict named where modules in refined contexts,       --        so remember whether it was named here-  , whereDecls  :: Maybe Declaration+  , whereAnywhere :: Bool+      -- ^ is it an ordinary unnamed @where@?+  , whereDecls :: Maybe Declaration       -- ^ The declaration is a 'Section'.-  } deriving (Data, Show, Eq, Generic)+  } deriving (Show, Eq, Generic)  instance Null WhereDeclarations where-  empty = WhereDecls empty empty+  empty = WhereDecls empty False empty  noWhereDecls :: WhereDeclarations noWhereDecls = empty@@ -405,7 +431,7 @@       -- ^ The where clauses are attached to the @RewriteRHS@ by       ---  the scope checker (instead of to the clause).     }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | Ignore 'rhsConcrete' when comparing 'RHS's. instance Eq RHS where@@ -423,7 +449,7 @@   , spLhsDefName  :: QName               -- ^ Name of function we are defining.   , spLhsPats     :: [NamedArg Pattern]  -- ^ Elimination by pattern, projections, with-patterns.   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Ignore 'Range' when comparing 'LHS's. instance Eq LHS where@@ -435,7 +461,7 @@   { lhsInfo     :: LHSInfo               -- ^ Range.   , lhsCore     :: LHSCore               -- ^ Copatterns.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | The lhs in projection-application and with-pattern view. --   Parameterised over the type @e@ of dot patterns.@@ -463,7 +489,7 @@              , lhsPats         :: [NamedArg (Pattern' e)]                  -- ^ Further applied to patterns.              }-  deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)+  deriving (Show, Functor, Foldable, Traversable, Eq, Generic)  type LHSCore = LHSCore' Expr @@ -494,7 +520,7 @@   | EqualP PatInfo [(e, e)]   | WithP PatInfo (Pattern' e)  -- ^ @| p@, for with-patterns.   | AnnP PatInfo e (Pattern' e) -- ^ Pattern with type annotation-  deriving (Data, Show, Functor, Foldable, Traversable, Eq, Generic)+  deriving (Show, Functor, Foldable, Traversable, Eq, Generic)  type NAPs e   = [NamedArg (Pattern' e)] type NAPs1 e  = List1 (NamedArg (Pattern' e))@@ -549,7 +575,6 @@   Generalized a1 b1          == Generalized a2 b2          = (a1, b1) == (a2, b2)   Fun a1 b1 c1               == Fun a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)   Let a1 b1 c1               == Let a2 b2 c2               = (a1, b1, c1) == (a2, b2, c2)-  ETel a1                    == ETel a2                    = a1 == a2   Rec a1 b1                  == Rec a2 b2                  = (a1, b1) == (a2, b2)   RecUpdate a1 b1 c1         == RecUpdate a2 b2 c2         = (a1, b1, c1) == (a2, b2, c2)   Quote a1                   == Quote a2                   = a1 == a2@@ -632,7 +657,6 @@     getRange (Let i _ _)             = getRange i     getRange (Rec i _)               = getRange i     getRange (RecUpdate i _ _)       = getRange i-    getRange (ETel tel)              = getRange tel     getRange (ScopedExpr _ e)        = getRange e     getRange (Quote i)               = getRange i     getRange (QuoteTerm i)           = getRange i@@ -661,6 +685,7 @@     getRange (PatternSynDef x _ _   ) = getRange x     getRange (UnquoteDecl _ i _ _)    = getRange i     getRange (UnquoteDef i _ _)       = getRange i+    getRange (UnquoteData i _ _ j _ _) = getRange (i, j)  instance HasRange (Pattern' e) where     getRange (VarP x)           = getRange x@@ -699,7 +724,7 @@     getRange (RewriteRHS xes _ rhs wh) = getRange (xes, rhs, wh)  instance HasRange WhereDeclarations where-  getRange (WhereDecls _ ds) = getRange ds+  getRange (WhereDecls _ _ ds) = getRange ds  instance HasRange LetBinding where     getRange (LetBind i _ _ _ _     ) = getRange i@@ -738,6 +763,9 @@ instance KillRange DataDefParams where   killRange (DataDefParams s tel) = DataDefParams s (killRange tel) +instance KillRange TypedBindingInfo where+  killRange (TypedBindingInfo a b) = killRange2 TypedBindingInfo a b+ instance KillRange TypedBinding where   killRange (TBind r t xs e) = killRange4 TBind r t xs e   killRange (TLet r lbs)     = killRange2 TLet r lbs@@ -762,7 +790,6 @@   killRange (Let i ds e)             = killRange3 Let i ds e   killRange (Rec i fs)               = killRange2 Rec i fs   killRange (RecUpdate i e fs)       = killRange3 RecUpdate i e fs-  killRange (ETel tel)               = killRange1 ETel tel   killRange (ScopedExpr s e)         = killRange1 (ScopedExpr s) e   killRange (Quote i)                = killRange1 Quote i   killRange (QuoteTerm i)            = killRange1 QuoteTerm i@@ -794,6 +821,7 @@   killRange (PatternSynDef x xs p     ) = killRange3 PatternSynDef x xs p   killRange (UnquoteDecl mi i x e     ) = killRange4 UnquoteDecl mi i x e   killRange (UnquoteDef i x e         ) = killRange3 UnquoteDef i x e+  killRange (UnquoteData i xs uc j cs e) = killRange6 UnquoteData i xs uc j cs e  instance KillRange ModuleApplication where   killRange (SectionApp a b c  ) = killRange3 SectionApp a b c@@ -842,7 +870,7 @@   killRange (RewriteRHS xes spats rhs wh) = killRange4 RewriteRHS xes spats rhs wh  instance KillRange WhereDeclarations where-  killRange (WhereDecls a b) = killRange2 WhereDecls a b+  killRange (WhereDecls a b c) = killRange3 WhereDecls a b c  instance KillRange LetBinding where   killRange (LetBind   i info a b c) = killRange5 LetBind i info a b c@@ -860,6 +888,7 @@ instance NFData a => NFData (Binder' a) instance NFData LamBinding instance NFData TypedBinding+instance NFData TypedBindingInfo instance NFData GeneralizeTelescope instance NFData DataDefParams instance NFData ProblemEq@@ -1042,7 +1071,6 @@     Generalized{}   -> __IMPOSSIBLE__     Fun{}           -> __IMPOSSIBLE__     Let{}           -> __IMPOSSIBLE__-    ETel{}          -> __IMPOSSIBLE__     RecUpdate{}     -> __IMPOSSIBLE__     Quote{}         -> __IMPOSSIBLE__     QuoteTerm{}     -> __IMPOSSIBLE__@@ -1076,3 +1104,99 @@     matchArgs r (n:ns) as = do       (p, as) <- matchNextArg r n as       first ((unArg n, p) :) <$> matchArgs (getRange p) ns as++------------------------------------------------------------------------+-- Declaration spines+------------------------------------------------------------------------++-- | Declaration spines. Used in debugging to make it easy to see+-- where constructors such as 'ScopedDecl' and 'Mutual' are placed.++data DeclarationSpine+  = AxiomS+  | GeneralizeS+  | FieldS+  | PrimitiveS+  | MutualS [DeclarationSpine]+  | SectionS [DeclarationSpine]+  | ApplyS+  | ImportS+  | PragmaS+  | OpenS+  | FunDefS [ClauseSpine]+  | DataSigS+  | DataDefS+  | RecSigS+  | RecDefS [DeclarationSpine]+  | PatternSynDefS+  | UnquoteDeclS+  | UnquoteDefS+  | UnquoteDataS+  | ScopedDeclS [DeclarationSpine]+  deriving Show++-- | Clause spines.++data ClauseSpine = ClauseS RHSSpine WhereDeclarationsSpine+  deriving Show++-- | Right-hand side spines.++data RHSSpine+  = RHSS+  | AbsurdRHSS+  | WithRHSS [ClauseSpine]+  | RewriteRHSS RHSSpine WhereDeclarationsSpine+  deriving Show++-- | Spines corresponding to 'WhereDeclarations' values.++data WhereDeclarationsSpine = WhereDeclsS (Maybe DeclarationSpine)+  deriving Show++-- | The declaration spine corresponding to a declaration.++declarationSpine :: Declaration -> DeclarationSpine+declarationSpine = \case+  Axiom _ _ _ _ _ _       -> AxiomS+  Generalize _ _ _ _ _    -> GeneralizeS+  Field _ _ _             -> FieldS+  Primitive _ _ _         -> PrimitiveS+  Mutual _ ds             -> MutualS (map declarationSpine ds)+  Section _ _ _ ds        -> SectionS (map declarationSpine ds)+  Apply _ _ _ _ _         -> ApplyS+  Import _ _ _            -> ImportS+  Pragma _ _              -> PragmaS+  Open _ _ _              -> OpenS+  FunDef _ _ _ cs         -> FunDefS (map clauseSpine cs)+  DataSig _ _ _ _         -> DataSigS+  DataDef _ _ _ _ _       -> DataDefS+  RecSig _ _ _ _          -> RecSigS+  RecDef _ _ _ _ _ _ ds   -> RecDefS (map declarationSpine ds)+  PatternSynDef _ _ _     -> PatternSynDefS+  UnquoteDecl _ _ _ _     -> UnquoteDeclS+  UnquoteDef _ _ _        -> UnquoteDefS+  UnquoteData _ _ _ _ _ _ -> UnquoteDataS+  ScopedDecl _ ds         -> ScopedDeclS (map declarationSpine ds)++-- | The clause spine corresponding to a clause.++clauseSpine :: Clause -> ClauseSpine+clauseSpine (Clause _ _ rhs ws _) =+  ClauseS (rhsSpine rhs) (whereDeclarationsSpine ws)++-- | The right-hand side spine corresponding to a right-hand side.++rhsSpine :: RHS -> RHSSpine+rhsSpine = \case+  RHS _ _               -> RHSS+  AbsurdRHS             -> AbsurdRHSS+  WithRHS _ _ cs        -> WithRHSS (map clauseSpine cs)+  RewriteRHS _ _ rhs ws ->+    RewriteRHSS (rhsSpine rhs) (whereDeclarationsSpine ws)++-- | The spine corresponding to a 'WhereDeclarations' value.++whereDeclarationsSpine :: WhereDeclarations -> WhereDeclarationsSpine+whereDeclarationsSpine (WhereDecls _ _ md) =+  WhereDeclsS (fmap declarationSpine md)
src/full/Agda/Syntax/Abstract/Name.hs view
@@ -11,9 +11,8 @@  import Control.DeepSeq -import Data.Data (Data) import Data.Foldable (length)-import Data.Function+import Data.Function (on) import Data.Hashable (Hashable(..)) import qualified Data.List as List import Data.Maybe@@ -46,7 +45,7 @@   , nameIsRecordName :: Bool       -- ^ Is this the name of the invisible record variable `self`?       --   Should not be printed or displayed in the context, see issue #3584.-  } deriving Data+  }  -- | Useful for debugging scoping problems uglyShowName :: Name -> String@@ -61,7 +60,6 @@ data QName = QName { qnameModule :: ModuleName                    , qnameName   :: Name                    }-    deriving Data  -- | Something preceeded by a qualified name. data QNamed a = QNamed@@ -75,14 +73,14 @@ -- The 'SetRange' instance for module names sets all individual ranges -- to the given one. newtype ModuleName = MName { mnameToList :: [Name] }-  deriving (Eq, Ord, Data)+  deriving (Eq, Ord)  -- | Ambiguous qualified names. Used for overloaded constructors. -- -- Invariant: All the names in the list must have the same concrete, -- unqualified name.  (This implies that they all have the same 'Range'). newtype AmbiguousQName = AmbQ { unAmbQ :: List1 QName }-  deriving (Eq, Ord, Data, NFData)+  deriving (Eq, Ord, NFData)  -- | A singleton "ambiguous" name. unambiguous :: QName -> AmbiguousQName@@ -105,7 +103,7 @@ data Suffix   = NoSuffix   | Suffix !Integer-  deriving (Data, Show, Eq, Ord)+  deriving (Show, Eq, Ord)  instance NFData Suffix where   rnf NoSuffix   = ()@@ -224,16 +222,6 @@ mnameToConcrete (MName (x:xs)) = foldr C.Qual (C.QName $ List1.last cs) $ List1.init cs   where     cs = fmap nameConcrete (x :| xs)---- | Computes the 'TopLevelModuleName' corresponding to the given--- module name, which is assumed to represent a top-level module name.------ Precondition: The module name must be well-formed.--toTopLevelModuleName :: ModuleName -> C.TopLevelModuleName-toTopLevelModuleName (MName []) = __IMPOSSIBLE__-toTopLevelModuleName (MName ms) = List1.ifNull ms __IMPOSSIBLE__ {-else-} $ \ ms1 ->-  C.TopLevelModuleName (getRange ms1) $ fmap (C.nameToRawName . nameConcrete) ms1  qualifyM :: ModuleName -> ModuleName -> ModuleName qualifyM m1 m2 = mnameFromList $ mnameToList m1 ++ mnameToList m2
src/full/Agda/Syntax/Abstract/Views.hs view
@@ -8,6 +8,7 @@ import Control.Monad.Identity  import Data.Foldable (foldMap)+import qualified Data.DList as DL import Data.Semigroup ((<>)) import Data.Void @@ -37,18 +38,20 @@ appView = fmap snd . appView'  appView' :: Expr -> AppView' (AppInfo, Expr)-appView' e =-  case e of+appView' e = f (DL.toList es)+  where+  (f, es) = appView'' e++  appView'' e = case e of     App i e1 e2       | Dot _ e2' <- unScope $ namedArg e2       , Just f <- maybeProjTurnPostfix e2'       , getHiding e2 == NotHidden -- Jesper, 2018-12-13: postfix projections shouldn't be hidden-                   -> Application f [defaultNamedArg (i, e1)]-    App i e1 arg-      | Application hd es <- appView' e1-                   -> Application hd $ es ++ [(fmap . fmap) (i,) arg]-    ScopedExpr _ e -> appView' e-    _              -> Application e []+      -> (Application f, singleton (defaultNamedArg (i, e1)))+    App i e1 arg | (f, es) <- appView'' e1 ->+      (f, es `DL.snoc` (fmap . fmap) (i,) arg)+    ScopedExpr _ e -> appView'' e+    _              -> (Application e, mempty)  maybeProjTurnPostfix :: Expr -> Maybe Expr maybeProjTurnPostfix e =@@ -70,6 +73,18 @@ lamView (ScopedExpr _ e) = lamView e lamView e = LamView [] e +-- | Collect @A.Pi@s.+data PiView = PiView [(ExprInfo, Telescope1)] Type++piView :: Expr -> PiView+piView = \case+   Pi i tel b -> cons $ piView b+     where cons (PiView tels t) = PiView ((i,tel) : tels) t+   e -> PiView [] e++unPiView :: PiView -> Expr+unPiView (PiView tels t) = foldr (uncurry Pi) t tels+ -- | Gather top-level 'AsP'atterns and 'AnnP'atterns to expose underlying pattern. asView :: A.Pattern -> ([Name], [A.Expr], A.Pattern) asView (A.AsP _ x p)  = (\(asb, ann, p) -> (unBind x : asb, ann, p)) $ asView p@@ -157,7 +172,6 @@       Generalized  s e           -> Generalized s <$> recurse e       Fun ei arg e               -> Fun ei <$> recurse arg <*> recurse e       Let ei bs e                -> Let ei <$> recurse bs <*> recurse e-      ETel tel                   -> ETel <$> recurse tel       Rec ei bs                  -> Rec ei <$> recurse bs       RecUpdate ei e bs          -> RecUpdate ei <$> recurse e <*> recurse bs       ScopedExpr sc e            -> ScopedExpr sc <$> recurse e@@ -190,7 +204,6 @@       Generalized _ e        -> m `mappend` fold e       Fun _ e e'             -> m `mappend` fold e `mappend` fold e'       Let _ bs e             -> m `mappend` fold bs `mappend` fold e-      ETel tel               -> m `mappend` fold tel       Rec _ as               -> m `mappend` fold as       RecUpdate _ e as       -> m `mappend` fold e `mappend` fold as       ScopedExpr _ e         -> m `mappend` fold e@@ -226,7 +239,6 @@       Generalized s e            -> f =<< Generalized s <$> trav e       Fun ei arg e               -> f =<< Fun ei <$> trav arg <*> trav e       Let ei bs e                -> f =<< Let ei <$> trav bs <*> trav e-      ETel tel                   -> f =<< ETel <$> trav tel       Rec ei bs                  -> f =<< Rec ei <$> trav bs       RecUpdate ei e bs          -> f =<< RecUpdate ei <$> trav e <*> trav bs       ScopedExpr sc e            -> f =<< ScopedExpr sc <$> trav e@@ -289,6 +301,11 @@   foldExpr     f (DataDefParams s tel) = foldExpr f tel   traverseExpr f (DataDefParams s tel) = DataDefParams s <$> traverseExpr f tel +instance ExprLike TypedBindingInfo where+  recurseExpr f (TypedBindingInfo s t)  = TypedBindingInfo <$> recurseExpr f s <*> pure t+  foldExpr f (TypedBindingInfo s t)     = foldExpr f s+  traverseExpr f (TypedBindingInfo s t) = TypedBindingInfo <$> traverseExpr f s <*> pure t+ instance ExprLike TypedBinding where   recurseExpr f e =     case e of@@ -367,7 +384,7 @@     Invert qn pes -> Invert <$> recurseExpr f qn <*> recurseExpr f pes  instance ExprLike WhereDeclarations where-  recurseExpr f (WhereDecls a b) = WhereDecls a <$> recurseExpr f b+  recurseExpr f (WhereDecls a b c) = WhereDecls a b <$> recurseExpr f c  instance ExprLike ModuleApplication where   recurseExpr :: forall m. RecurseExprFn m ModuleApplication@@ -392,6 +409,7 @@       InjectivePragma{}           -> pure p       InlinePragma{}              -> pure p       EtaPragma{}                 -> pure p+      NotProjectionLikePragma{}   -> pure p       DisplayPragma f xs e        -> DisplayPragma f <$> rec xs <*> rec e     where       rec :: RecurseExprRecFn m@@ -428,6 +446,7 @@       PatternSynDef f xs p      -> PatternSynDef f xs <$> rec p       UnquoteDecl i is xs e     -> UnquoteDecl i is xs <$> rec e       UnquoteDef i xs e         -> UnquoteDef i xs <$> rec e+      UnquoteData i xs uc j cs e -> UnquoteData i xs uc j cs <$> rec e       ScopedDecl s ds           -> ScopedDecl s <$> rec ds     where       rec :: RecurseExprRecFn m@@ -490,6 +509,7 @@       PatternSynDef q _ _          -> singleton (WithKind PatternSynName q)       UnquoteDecl _ _ qs _         -> fromList $ map (WithKind OtherDefName) qs  -- could be Fun or Axiom       UnquoteDef _ qs _            -> fromList $ map (WithKind FunName) qs       -- cannot be Axiom+      UnquoteData _ d _ _ cs _     -> singleton (WithKind DataName d) <> (fromList $ map (WithKind ConName) cs) -- singleton _ <> map (WithKind ConName) cs       FunDef _ q _ cls             -> singleton (WithKind FunName q) <> declaredNames cls       ScopedDecl _ decls           -> declaredNames decls       Section _ _ _ decls          -> declaredNames decls@@ -505,21 +525,22 @@ instance DeclaredNames Pragma where   declaredNames = \case     BuiltinNoDefPragma _b kind x -> singleton $ WithKind kind x-    BuiltinPragma{}         -> mempty-    CompilePragma{}         -> mempty-    RewritePragma{}         -> mempty-    StaticPragma{}          -> mempty-    EtaPragma{}             -> mempty-    InjectivePragma{}       -> mempty-    InlinePragma{}          -> mempty-    DisplayPragma{}         -> mempty-    OptionsPragma{}         -> mempty+    BuiltinPragma{}           -> mempty+    CompilePragma{}           -> mempty+    RewritePragma{}           -> mempty+    StaticPragma{}            -> mempty+    EtaPragma{}               -> mempty+    InjectivePragma{}         -> mempty+    InlinePragma{}            -> mempty+    NotProjectionLikePragma{} -> mempty+    DisplayPragma{}           -> mempty+    OptionsPragma{}           -> mempty  instance DeclaredNames Clause where   declaredNames (Clause _ _ rhs decls _) = declaredNames rhs <> declaredNames decls  instance DeclaredNames WhereDeclarations where-  declaredNames (WhereDecls _ ds) = declaredNames ds+  declaredNames (WhereDecls _ _ ds) = declaredNames ds  instance DeclaredNames RHS where   declaredNames = \case@@ -575,7 +596,6 @@ --     Set{}                 -> mempty --     Prop{}                -> mempty --     Let _ lbs e           -> declaredNames lbs <> declaredNames e---     ETel{}                -> __IMPOSSIBLE__ --     Rec _ fields          -> declaredNames fields --     RecUpdate _ e fs      -> declaredNames e <> declaredNames fs --     ScopedExpr _ e        -> declaredNames e
src/full/Agda/Syntax/Builtin.hs view
@@ -23,7 +23,7 @@   builtinGlue, builtin_glue, builtin_unglue,   builtin_glueU, builtin_unglueU,   builtinFaceForall,-  builtinId, builtinConId, builtinIdElim,+  builtinId, builtinReflId, builtinConId, builtinIdElim,   builtinSizeUniv, builtinSize, builtinSizeLt,   builtinSizeSuc, builtinSizeInf, builtinSizeMax,   builtinInf, builtinSharp, builtinFlat,@@ -31,6 +31,7 @@   builtinLevel, builtinLevelZero, builtinLevelSuc,   builtinSet, builtinProp, builtinSetOmega, builtinStrictSet, builtinSSetOmega,   builtinLockUniv,+  builtinIntervalUniv,   builtinFromNat, builtinFromNeg, builtinFromString,   builtinQName, builtinAgdaSort, builtinAgdaSortSet, builtinAgdaSortLit,   builtinAgdaSortProp, builtinAgdaSortPropLit, builtinAgdaSortInf,@@ -48,7 +49,7 @@   builtinAgdaTermVar, builtinAgdaTermLam, builtinAgdaTermExtLam,   builtinAgdaTermDef, builtinAgdaTermCon, builtinAgdaTermPi,   builtinAgdaTermSort, builtinAgdaTermLit, builtinAgdaTermUnsupported, builtinAgdaTermMeta,-  builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName,+  builtinAgdaErrorPart, builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartPatt, builtinAgdaErrorPartName,   builtinAgdaLiteral, builtinAgdaLitNat, builtinAgdaLitWord64, builtinAgdaLitFloat,   builtinAgdaLitChar, builtinAgdaLitString, builtinAgdaLitQName, builtinAgdaLitMeta,   builtinAgdaClause, builtinAgdaClauseClause, builtinAgdaClauseAbsurd, builtinAgdaPattern,@@ -64,15 +65,17 @@   builtinAgdaTCMCheckType, builtinAgdaTCMNormalise, builtinAgdaTCMReduce,   builtinAgdaTCMCatchError,   builtinAgdaTCMGetContext, builtinAgdaTCMExtendContext, builtinAgdaTCMInContext,-  builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDefineFun,+  builtinAgdaTCMFreshName, builtinAgdaTCMDeclareDef, builtinAgdaTCMDeclarePostulate, builtinAgdaTCMDeclareData, builtinAgdaTCMDefineData, builtinAgdaTCMDefineFun,   builtinAgdaTCMGetType, builtinAgdaTCMGetDefinition,   builtinAgdaTCMQuoteTerm, builtinAgdaTCMUnquoteTerm, builtinAgdaTCMQuoteOmegaTerm,   builtinAgdaTCMBlockOnMeta, builtinAgdaTCMCommit, builtinAgdaTCMIsMacro,-  builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconsParams, builtinAgdaTCMDebugPrint,+  builtinAgdaTCMFormatErrorParts, builtinAgdaTCMDebugPrint,+  builtinAgdaTCMWithNormalisation, builtinAgdaTCMWithReconsParams,   builtinAgdaTCMOnlyReduceDefs, builtinAgdaTCMDontReduceDefs,   builtinAgdaTCMNoConstraints,   builtinAgdaTCMRunSpeculative,-  builtinAgdaTCMExec+  builtinAgdaTCMExec,+  builtinAgdaTCMGetInstances   :: String  builtinNat                               = "NATURAL"@@ -106,10 +109,12 @@ builtinJust                              = "JUST" builtinIO                                = "IO" builtinId                                = "ID"-builtinConId                             = "CONID"+builtinReflId                            = "REFLID"+builtinConId                             = "primConId" builtinIdElim                            = "primIdElim" builtinPath                              = "PATH" builtinPathP                             = "PATHP"+builtinIntervalUniv                      = "CUBEINTERVALUNIV" builtinInterval                          = "INTERVAL" builtinIMin                              = "primIMin" builtinIMax                              = "primIMax"@@ -214,6 +219,7 @@ builtinAgdaErrorPart                     = "AGDAERRORPART" builtinAgdaErrorPartString               = "AGDAERRORPARTSTRING" builtinAgdaErrorPartTerm                 = "AGDAERRORPARTTERM"+builtinAgdaErrorPartPatt                 = "AGDAERRORPARTPATT" builtinAgdaErrorPartName                 = "AGDAERRORPARTNAME" builtinAgdaLiteral                       = "AGDALITERAL" builtinAgdaLitNat                        = "AGDALITNAT"@@ -257,6 +263,8 @@ builtinAgdaTCMFreshName                  = "AGDATCMFRESHNAME" builtinAgdaTCMDeclareDef                 = "AGDATCMDECLAREDEF" builtinAgdaTCMDeclarePostulate           = "AGDATCMDECLAREPOSTULATE"+builtinAgdaTCMDeclareData                = "AGDATCMDECLAREDATA"+builtinAgdaTCMDefineData                 = "AGDATCMDEFINEDATA" builtinAgdaTCMDefineFun                  = "AGDATCMDEFINEFUN" builtinAgdaTCMGetType                    = "AGDATCMGETTYPE" builtinAgdaTCMGetDefinition              = "AGDATCMGETDEFINITION"@@ -268,12 +276,14 @@ builtinAgdaTCMIsMacro                    = "AGDATCMISMACRO" builtinAgdaTCMWithNormalisation          = "AGDATCMWITHNORMALISATION" builtinAgdaTCMWithReconsParams           = "AGDATCMWITHRECONSPARAMS"+builtinAgdaTCMFormatErrorParts           = "AGDATCMFORMATERRORPARTS" builtinAgdaTCMDebugPrint                 = "AGDATCMDEBUGPRINT" builtinAgdaTCMOnlyReduceDefs             = "AGDATCMONLYREDUCEDEFS" builtinAgdaTCMDontReduceDefs             = "AGDATCMDONTREDUCEDEFS" builtinAgdaTCMNoConstraints              = "AGDATCMNOCONSTRAINTS" builtinAgdaTCMRunSpeculative             = "AGDATCMRUNSPECULATIVE" builtinAgdaTCMExec                       = "AGDATCMEXEC"+builtinAgdaTCMGetInstances               = "AGDATCMGETINSTANCES"  -- | Builtins that come without a definition in Agda syntax. --   These are giving names to Agda internal concepts which@@ -293,6 +303,9 @@ builtinsNoDef =   sizeBuiltins ++   [ builtinConId+  , builtinIntervalUniv+  , builtinId+  , builtinReflId   , builtinInterval   , builtinPartial   , builtinPartialP
src/full/Agda/Syntax/Common.hs view
@@ -17,10 +17,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as ByteString import qualified Data.Foldable as Fold-import Data.Function+import Data.Function (on) import Data.Hashable (Hashable(..)) import qualified Data.Strict.Maybe as Strict-import Data.Data (Data) import Data.Word import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet@@ -29,6 +28,7 @@  import Agda.Syntax.Position +import Agda.Utils.BiMap (HasTag(..)) import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List1  ( List1, pattern (:|), (<|) )@@ -50,7 +50,7 @@  -- | Used to specify whether something should be delayed. data Delayed = Delayed | NotDelayed-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  instance KillRange Delayed where   killRange = id@@ -62,7 +62,7 @@ ---------------------------------------------------------------------------  data FileType = AgdaFileType | MdFileType | RstFileType | TexFileType | OrgFileType-  deriving (Data, Eq, Ord, Show, Generic)+  deriving (Eq, Ord, Show, Generic)  instance Pretty FileType where   pretty = \case@@ -109,7 +109,7 @@   , recHasEta      :: Maybe HasEta0   , recPattern     :: Maybe Range   , recConstructor :: Maybe a-  } deriving (Functor, Data, Show, Eq)+  } deriving (Functor, Show, Eq)  emptyRecordDirectives :: RecordDirectives' a emptyRecordDirectives = RecordDirectives empty empty empty empty@@ -131,7 +131,7 @@ data HasEta' a   = YesEta   | NoEta a-  deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)  instance HasRange a => HasRange (HasEta' a) where   getRange = foldMap getRange@@ -158,7 +158,7 @@       -- ^ Can match on the record constructor.   | CopatternMatching       -- ^ Can copattern match using the projections. (Default.)-  deriving (Data, Show, Eq, Ord, Enum, Bounded)+  deriving (Show, Eq, Ord, Enum, Bounded)  instance NFData PatternOrCopattern where   rnf PatternMatching   = ()@@ -201,7 +201,7 @@  -- | @Inductive < Coinductive@ data Induction = Inductive | CoInductive  -- Keep in this order!-  deriving (Data, Eq, Ord, Show)+  deriving (Eq, Ord, Show)  instance Pretty Induction where   pretty Inductive   = "inductive"@@ -225,10 +225,10 @@ ---------------------------------------------------------------------------  data Overlappable = YesOverlap | NoOverlap-  deriving (Data, Show, Eq, Ord)+  deriving (Show, Eq, Ord)  data Hiding  = Hidden | Instance Overlappable | NotHidden-  deriving (Data, Show, Eq, Ord)+  deriving (Show, Eq, Ord)  instance Pretty Hiding where   pretty = \case@@ -280,7 +280,7 @@   { whHiding :: !Hiding   , whThing  :: a   }-  deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  instance Decoration WithHiding where   traverseF f (WithHiding h a) = WithHiding h <$> f a@@ -416,7 +416,7 @@       -- ^ Cohesion/what was in Agda-flat.       --   see "Brouwer's fixed-point theorem in real-cohesive homotopy type theory" (arXiv:1509.07584)       --   Currently only the comonad is implemented.-  } deriving (Data, Eq, Ord, Show, Generic)+  } deriving (Eq, Ord, Show, Generic)  -- | Dominance ordering. instance PartialOrd Modality where@@ -621,21 +621,21 @@   = Q0Inferred       -- ^ User wrote nothing.   | Q0       Range   -- ^ User wrote "@0".   | Q0Erased Range   -- ^ User wrote "@erased".-  deriving (Data, Show, Generic, Eq, Ord)+  deriving (Show, Generic, Eq, Ord)  -- | Origin of 'Quantity1'. data Q1Origin   = Q1Inferred       -- ^ User wrote nothing.   | Q1       Range   -- ^ User wrote "@1".   | Q1Linear Range   -- ^ User wrote "@linear".-  deriving (Data, Show, Generic, Eq, Ord)+  deriving (Show, Generic, Eq, Ord)  -- | Origin of 'Quantityω'. data QωOrigin   = QωInferred       -- ^ User wrote nothing.   | Qω       Range   -- ^ User wrote "@ω".   | QωPlenty Range   -- ^ User wrote "@plenty".-  deriving (Data, Show, Generic, Eq, Ord)+  deriving (Show, Generic, Eq, Ord)  -- *** Instances for 'Q0Origin'. @@ -776,7 +776,7 @@   | Quantity1 Q1Origin -- ^ Linear use @{1}@ (could be updated destructively).     -- Mostly TODO (needs postponable constraints between quantities to compute uses).   | Quantityω QωOrigin -- ^ Unrestricted use @ℕ@.-  deriving (Data, Show, Generic, Eq, Ord)+  deriving (Show, Generic, Eq, Ord)     -- @Ord@ instance in case @Quantity@ is used in keys for maps etc.  -- | Equality ignoring origin.@@ -995,7 +995,7 @@ data Erased   = Erased Q0Origin   | NotErased QωOrigin-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | The default value of type 'Erased': not erased. @@ -1065,7 +1065,7 @@                 --   Therefore, it is irrelevant at run-time.                 --   It is treated relevantly during equality checking.   | Irrelevant  -- ^ The argument is irrelevant at compile- and runtime.-    deriving (Data, Show, Eq, Enum, Bounded, Generic)+    deriving (Show, Eq, Enum, Bounded, Generic)  allRelevances :: [Relevance] allRelevances = [minBound..maxBound]@@ -1244,7 +1244,6 @@ nonStrictToIrr NonStrict = Irrelevant nonStrictToIrr rel       = rel - --------------------------------------------------------------------------- -- * Annotations ---------------------------------------------------------------------------@@ -1254,7 +1253,7 @@   { annLock :: Lock     -- ^ Fitch-style dependent right adjoints.     --   See Modal Dependent Type Theory and Dependent Right Adjoints, arXiv:1804.05236.-  } deriving (Data, Eq, Ord, Show, Generic)+  } deriving (Eq, Ord, Show, Generic)  instance HasRange Annotation where   getRange _ = noRange@@ -1300,7 +1299,7 @@ data Lock = IsNotLock           | IsLock -- ^ In the future there might be different kinds of them.                    --   For now we assume lock weakening.-  deriving (Data, Show, Generic, Eq, Enum, Bounded, Ord)+  deriving (Show, Generic, Eq, Enum, Bounded, Ord)  defaultLock :: Lock defaultLock = IsNotLock@@ -1326,7 +1325,7 @@  instance LensLock ArgInfo where   getLock = annLock . argInfoAnnotation-  setLock l info = info { argInfoAnnotation = Annotation l }+  setLock l info = info { argInfoAnnotation = (argInfoAnnotation info){ annLock = l } }  instance LensLock (Arg t) where   getLock = getLock . getArgInfo@@ -1344,7 +1343,7 @@   | Continuous  -- ^ identity modality.   -- | Sharp    -- ^ same points, codiscrete topology, idempotent monad, diamond-like.   | Squash      -- ^ single point space, artificially added for Flat left-composition.-    deriving (Data, Show, Eq, Enum, Bounded, Generic)+    deriving (Show, Eq, Enum, Bounded, Generic)  allCohesions :: [Cohesion] allCohesions = [minBound..maxBound]@@ -1514,7 +1513,7 @@   | Reflected    -- ^ Produced by the reflection machinery.   | CaseSplit    -- ^ Produced by an interactive case split.   | Substitution -- ^ Named application produced to represent a substitution. E.g. "?0 (x = n)" instead of "?0 n"-  deriving (Data, Show, Eq, Ord)+  deriving (Show, Eq, Ord)  instance HasRange Origin where   getRange _ = noRange@@ -1534,7 +1533,7 @@   { woOrigin :: !Origin   , woThing  :: a   }-  deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  instance Decoration WithOrigin where   traverseF f (WithOrigin h a) = WithOrigin h <$> f a@@ -1587,7 +1586,7 @@ -----------------------------------------------------------------------------  data FreeVariables = UnknownFVs | KnownFVs IntSet-  deriving (Data, Eq, Ord, Show)+  deriving (Eq, Ord, Show)  instance Semigroup FreeVariables where   UnknownFVs   <> _            = UnknownFVs@@ -1659,7 +1658,7 @@   , argInfoAnnotation    :: Annotation     -- ^ Sometimes we want a different kind of binder/pi-type, without it     --   supporting any of the @Modality@ interface.-  } deriving (Data, Eq, Ord, Show)+  } deriving (Eq, Ord, Show)  instance HasRange ArgInfo where   getRange (ArgInfo h m o _fv a) = getRange (h, m, o, a)@@ -1791,7 +1790,7 @@ data Arg e  = Arg   { argInfo :: ArgInfo   , unArg :: e-  } deriving (Data, Eq, Ord, Show, Functor, Foldable, Traversable)+  } deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  instance Decoration Arg where   traverseF f (Arg ai a) = Arg ai <$> f a@@ -1961,7 +1960,7 @@     Named { nameOf     :: Maybe name           , namedThing :: a           }-    deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)+    deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  -- | Standard naming. type Named_ = Named NamedName@@ -2130,7 +2129,7 @@   { rangeOf     :: Range   , rangedThing :: a   }-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Show, Functor, Foldable, Traversable)  -- | Thing with no range info. unranged :: a -> Ranged a@@ -2188,7 +2187,7 @@   | ConOCon     -- ^ User wrote a constructor (pattern).   | ConORec     -- ^ User wrote a record (pattern).   | ConOSplit   -- ^ Generated by interactive case splitting.-  deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic)+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)  instance NFData ConOrigin @@ -2205,7 +2204,7 @@   = ProjPrefix    -- ^ User wrote a prefix projection.   | ProjPostfix   -- ^ User wrote a postfix projection.   | ProjSystem    -- ^ Projection was generated by the system.-  deriving (Data, Show, Eq, Ord, Enum, Bounded, Generic)+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)  instance NFData ProjOrigin @@ -2219,7 +2218,7 @@ -- | Functions can be defined in both infix and prefix style. See --   'Agda.Syntax.Concrete.LHS'. data IsInfix = InfixDef | PrefixDef-    deriving (Data, Show, Eq, Ord)+    deriving (Show, Eq, Ord)  -- ** private blocks, public imports @@ -2229,7 +2228,7 @@       -- ^ Store the 'Origin' of the private block that lead to this qualifier.       --   This is needed for more faithful printing of declarations.   | PublicAccess-    deriving (Data, Show, Eq, Ord)+    deriving (Show, Eq, Ord)  instance Pretty Access where   pretty = text . \case@@ -2249,7 +2248,7 @@  -- | Abstract or concrete. data IsAbstract = AbstractDef | ConcreteDef-    deriving (Data, Show, Eq, Ord, Generic)+    deriving (Show, Eq, Ord, Generic)  -- | Semigroup computes if any of several is an 'AbstractDef'. instance Semigroup IsAbstract where@@ -2291,7 +2290,7 @@ data IsInstance   = InstanceDef Range  -- ^ Range of the @instance@ keyword.   | NotInstanceDef-    deriving (Data, Show, Eq, Ord)+    deriving (Show, Eq, Ord)  instance KillRange IsInstance where   killRange = \case@@ -2311,7 +2310,7 @@  -- | Is this a macro definition? data IsMacro = MacroDef | NotMacroDef-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  instance KillRange IsMacro where killRange = id instance HasRange  IsMacro where getRange _ = noRange@@ -2322,16 +2321,26 @@ -- * NameId --------------------------------------------------------------------------- -newtype ModuleNameHash = ModuleNameHash Word64-  deriving (Eq, Ord, Show, Data)+newtype ModuleNameHash = ModuleNameHash { moduleNameHash :: Word64 }+  deriving (Eq, Ord, Hashable) +instance HasTag ModuleNameHash where+  type Tag ModuleNameHash = ModuleNameHash+  tag = Just . id+ noModuleNameHash :: ModuleNameHash noModuleNameHash = ModuleNameHash 0 +-- | The record selector is not included in the resulting strings.++instance Show ModuleNameHash where+  showsPrec p (ModuleNameHash h) = showParen (p > 0) $+    showString "ModuleNameHash " . shows h+ -- | The unique identifier of a name. Second argument is the top-level module --   identifier. data NameId = NameId {-# UNPACK #-} !Word64 {-# UNPACK #-} !ModuleNameHash-    deriving (Eq, Ord, Data, Generic, Show)+    deriving (Eq, Ord, Generic, Show)  instance KillRange NameId where   killRange = id@@ -2359,23 +2368,41 @@ -- * Meta variables --------------------------------------------------------------------------- --- | A meta variable identifier is just a natural number.----newtype MetaId = MetaId { metaId :: Nat }-    deriving (Eq, Ord, Num, Real, Enum, Integral, Data, Generic)+-- | Meta-variable identifiers use the same structure as 'NameId's. +data MetaId = MetaId+  { metaId     :: {-# UNPACK #-} !Word64+  , metaModule :: {-# UNPACK #-} !ModuleNameHash+  }+  deriving (Eq, Ord, Generic)+ instance Pretty MetaId where-  pretty (MetaId n) = text $ "_" ++ show n+  pretty (MetaId n m) =+    text $ "_" ++ show n ++ "@" ++ show (moduleNameHash m) --- | Show non-record version of this newtype.+instance Enum MetaId where+  succ MetaId{..} = MetaId { metaId = succ metaId, .. }+  pred MetaId{..} = MetaId { metaId = pred metaId, .. }++  -- The following functions should not be used.+  toEnum   = __IMPOSSIBLE__+  fromEnum = __IMPOSSIBLE__++-- | The record selectors are not included in the resulting strings.+ instance Show MetaId where-  showsPrec p (MetaId n) = showParen (p > 0) $-    showString "MetaId " . shows n+  showsPrec p (MetaId n m) = showParen (p > 0) $+    showString "MetaId " .+    showsPrec 11 n .+    showString " " .+    showsPrec 11 m  instance NFData MetaId where-  rnf (MetaId x) = rnf x+  rnf (MetaId x y) = rnf x `seq` rnf y -instance Hashable MetaId+instance Hashable MetaId where+  {-# INLINE hashWithSalt #-}+  hashWithSalt salt (MetaId n m) = hashWithSalt salt (n, m)  newtype Constr a = Constr a @@ -2386,7 +2413,7 @@ -- | A "problem" consists of a set of constraints and the same constraint can be part of multiple --   problems. newtype ProblemId = ProblemId Nat-  deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData)+  deriving (Eq, Ord, Enum, Real, Integral, Num, NFData)  -- This particular Show instance is ok because of the Num instance. instance Show   ProblemId where show   (ProblemId n) = show n@@ -2407,7 +2434,7 @@     -- @foo_bar@.   | End     -- ^ The following underscore is at the end of the name: @foo_@.-  deriving (Show, Eq, Ord, Data)+  deriving (Show, Eq, Ord)  -- | Placeholders are used to represent the underscores in a section. @@ -2416,7 +2443,7 @@   | NoPlaceholder !(Strict.Maybe PositionInName) e     -- ^ The second argument is used only (but not always) for name     -- parts other than underscores.-  deriving (Data, Eq, Ord, Functor, Foldable, Traversable, Show)+  deriving (Eq, Ord, Functor, Foldable, Traversable, Show)  -- | An abbreviation: @noPlaceholder = 'NoPlaceholder' -- 'Strict.Nothing'@.@@ -2448,7 +2475,6 @@              , Integral              , Real              , Enum-             , Data              , NFData              ) @@ -2470,7 +2496,7 @@     -- ^ No fixity declared.   | Related !PrecedenceLevel     -- ^ Fixity level declared as the number.-  deriving (Eq, Ord, Show, Data)+  deriving (Eq, Ord, Show)  instance Null FixityLevel where   null Unrelated = True@@ -2484,7 +2510,7 @@ -- | Associativity.  data Associativity = NonAssoc | LeftAssoc | RightAssoc-   deriving (Eq, Ord, Show, Data)+   deriving (Eq, Ord, Show)  -- | Fixity of operators. @@ -2494,7 +2520,7 @@   , fixityLevel :: !FixityLevel   , fixityAssoc :: !Associativity   }-  deriving (Data, Show)+  deriving Show  noFixity :: Fixity noFixity = Fixity noRange Unrelated NonAssoc@@ -2534,7 +2560,7 @@       -- ^ Range of the name in the fixity declaration       --   (used for correct highlighting, see issue #2140).     }-  deriving (Data, Show)+  deriving Show  noFixity' :: Fixity' noFixity' = Fixity' noFixity noNotation noRange@@ -2591,7 +2617,7 @@   , impRenaming    :: RenamingDirective' n m   , publicOpen     :: Maybe Range -- ^ Only for @open@. Exports the opened names from the current module.   }-  deriving (Data, Eq)+  deriving Eq  type HidingDirective'   n m = [ImportedName' n m] type RenamingDirective' n m = [Renaming' n m]@@ -2629,7 +2655,7 @@ data Using' n m   = UseEverything              -- ^ No @using@ clause given.   | Using [ImportedName' n m]  -- ^ @using@ the specified names.-  deriving (Data, Eq)+  deriving Eq  instance Semigroup (Using' n m) where   UseEverything <> u             = u@@ -2654,7 +2680,7 @@ data ImportedName' n m   = ImportedModule  m  -- ^ Imported module name of type @m@.   | ImportedName    n  -- ^ Imported name of type @n@.-  deriving (Data, Eq, Ord, Show)+  deriving (Eq, Ord, Show)  fromImportedName :: ImportedName' a a -> a fromImportedName = \case@@ -2690,7 +2716,7 @@   , renToRange :: Range     -- ^ The range of the \"to\" keyword.  Retained for highlighting purposes.   }-  deriving (Data, Eq)+  deriving Eq  -- ** HasRange instances @@ -2761,7 +2787,7 @@     -- ^ Treat as terminating (unsafe).  Same effect as 'NoTerminationCheck'.   | TerminationMeasure Range m     -- ^ Skip termination checking but use measure instead.-    deriving (Data, Show, Eq, Functor)+    deriving (Show, Eq, Functor)  instance KillRange m => KillRange (TerminationCheck m) where   killRange (TerminationMeasure _ m) = TerminationMeasure noRange (killRange m)@@ -2780,7 +2806,7 @@  -- | Positivity check? (Default = True). data PositivityCheck = YesPositivityCheck | NoPositivityCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance KillRange PositivityCheck where   killRange = id@@ -2803,7 +2829,7 @@  -- | Universe check? (Default is yes). data UniverseCheck = YesUniverseCheck | NoUniverseCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance KillRange UniverseCheck where   killRange = id@@ -2816,7 +2842,7 @@  -- | Coverage check? (Default is yes). data CoverageCheck = YesCoverageCheck | NoCoverageCheck-  deriving (Eq, Ord, Show, Bounded, Enum, Data, Generic)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance KillRange CoverageCheck where   killRange = id@@ -2847,7 +2873,7 @@ data RewriteEqn' qn nm p e   = Rewrite (List1 (qn, e))             -- ^ @rewrite e@   | Invert qn (List1 (Named nm (p, e))) -- ^ @with p <- e in eq@-  deriving (Data, Eq, Show, Functor, Foldable, Traversable)+  deriving (Eq, Show, Functor, Foldable, Traversable)  instance (NFData qn, NFData nm, NFData p, NFData e) => NFData (RewriteEqn' qn nm p e) where   rnf = \case@@ -2888,7 +2914,7 @@   , ellipsisWithArgs :: Int   }   | NoEllipsis-  deriving (Data, Show, Eq)+  deriving (Show, Eq)  instance Null ExpandedEllipsis where   null  = (== NoEllipsis)@@ -2912,65 +2938,98 @@   rnf NoEllipsis             = ()  -- | Notation as provided by the @syntax@ declaration.-type Notation = [GenPart]+type Notation = [NotationPart]  noNotation :: Notation noNotation = [] --- | Part of a Notation-data GenPart-  = BindHole Range (Ranged Int)-    -- ^ Argument is the position of the hole (with binding) where the binding should occur.-    --   First range is the rhs range and second is the binder.-  | NormalHole Range (NamedArg (Ranged Int))-    -- ^ Argument is where the expression should go.-  | WildHole (Ranged Int)-    -- ^ An underscore in binding position.-  | IdPart RString-  deriving (Data, Show)+-- | Positions of variables in syntax declarations. -instance Eq GenPart where-  BindHole _ i   == BindHole _ j   = i == j-  NormalHole _ x == NormalHole _ y = x == y-  WildHole i     == WildHole j     = i == j-  IdPart x       == IdPart y       = x == y-  _              == _              = False+data BoundVariablePosition = BoundVariablePosition+  { holeNumber :: !Int+    -- ^ The position (in the left-hand side of the syntax+    -- declaration) of the hole in which the variable is bound,+    -- counting from zero (and excluding parts that are not holes).+    -- For instance, for @syntax Σ A (λ x → B) = B , A , x@ the number+    -- for @x@ is @1@, corresponding to @B@ (@0@ would correspond to+    -- @A@).+  , varNumber :: !Int+    -- ^ The position in the list of variables for this particular+    -- variable, counting from zero, and including wildcards. For+    -- instance, for @syntax F (λ x _ y → A) = y ! A ! x@ the number+    -- for @x@ is @0@, the number for @_@ is @1@, and the number for+    -- @y@ is @2@.+  }+  deriving (Eq, Ord, Show) -instance Ord GenPart where-  BindHole _ i   `compare` BindHole _ j   = i `compare` j-  NormalHole _ x `compare` NormalHole _ y = x `compare` y-  WildHole i     `compare` WildHole j     = i `compare` j-  IdPart x       `compare` IdPart y       = x `compare` y-  BindHole{}     `compare` _              = LT-  _              `compare` BindHole{}     = GT-  NormalHole{}   `compare` _              = LT-  _              `compare` NormalHole{}   = GT-  WildHole{}     `compare` _              = LT-  _              `compare` WildHole{}     = GT+-- | Notation parts. -instance HasRange GenPart where+data NotationPart+  = IdPart RString+    -- ^ An identifier part. For instance, for @_+_@ the only+    -- identifier part is @+@.+  | HolePart Range (NamedArg (Ranged Int))+    -- ^ A hole: a place where argument expressions can be written.+    -- For instance, for @_+_@ the two underscores are holes, and for+    -- @syntax Σ A (λ x → B) = B , A , x@ the variables @A@ and @B@+    -- are holes. The number is the position of the hole, counting+    -- from zero. For instance, the number for @A@ is @0@, and the+    -- number for @B@ is @1@.+  | VarPart Range (Ranged BoundVariablePosition)+    -- ^ A bound variable.+    --+    -- The first range is the range of the variable in the right-hand+    -- side of the syntax declaration, and the second range is the+    -- range of the variable in the left-hand side.+  | WildPart (Ranged BoundVariablePosition)+    -- ^ A wildcard (an underscore in binding position).+  deriving Show++instance Eq NotationPart where+  VarPart _ i  == VarPart _ j  = i == j+  HolePart _ x == HolePart _ y = x == y+  WildPart i   == WildPart j   = i == j+  IdPart x     == IdPart y     = x == y+  _            == _            = False++instance Ord NotationPart where+  VarPart _ i  `compare` VarPart _ j  = i `compare` j+  HolePart _ x `compare` HolePart _ y = x `compare` y+  WildPart i   `compare` WildPart j   = i `compare` j+  IdPart x     `compare` IdPart y     = x `compare` y+  VarPart{}    `compare` _            = LT+  _            `compare` VarPart{}    = GT+  HolePart{}   `compare` _            = LT+  _            `compare` HolePart{}   = GT+  WildPart{}   `compare` _            = LT+  _            `compare` WildPart{}   = GT++instance HasRange NotationPart where   getRange = \case-    IdPart x       -> getRange x-    BindHole r _   -> r-    WildHole i     -> getRange i-    NormalHole r _ -> r+    IdPart x     -> getRange x+    VarPart r _  -> r+    WildPart i   -> getRange i+    HolePart r _ -> r -instance SetRange GenPart where+instance SetRange NotationPart where   setRange r = \case-    IdPart x       -> IdPart x-    BindHole _ i   -> BindHole r i-    WildHole i     -> WildHole i-    NormalHole _ i -> NormalHole r i+    IdPart x     -> IdPart x+    VarPart _ i  -> VarPart r i+    WildPart i   -> WildPart i+    HolePart _ i -> HolePart r i -instance KillRange GenPart where+instance KillRange NotationPart where   killRange = \case-    IdPart x       -> IdPart $ killRange x-    BindHole _ i   -> BindHole noRange $ killRange i-    WildHole i     -> WildHole $ killRange i-    NormalHole _ x -> NormalHole noRange $ killRange x+    IdPart x     -> IdPart $ killRange x+    VarPart _ i  -> VarPart noRange $ killRange i+    WildPart i   -> WildPart $ killRange i+    HolePart _ x -> HolePart noRange $ killRange x -instance NFData GenPart where-  rnf (BindHole _ a)   = rnf a-  rnf (NormalHole _ a) = rnf a-  rnf (WildHole a)     = rnf a-  rnf (IdPart a)       = rnf a+instance NFData BoundVariablePosition where+  rnf = (`seq` ())++instance NFData NotationPart where+  rnf (VarPart _ a)  = rnf a+  rnf (HolePart _ a) = rnf a+  rnf (WildPart a)   = rnf a+  rnf (IdPart a)     = rnf a
src/full/Agda/Syntax/Concrete.hs view
@@ -61,7 +61,6 @@   , Module(..)   , ThingWithFixity(..)   , HoleContent, HoleContent'(..)-  , topLevelModuleName   , spanAllowedBeforeModule   )   where@@ -70,7 +69,7 @@  import Control.DeepSeq -import Data.Data        ( Data )+import qualified Data.DList as DL import Data.Functor.Identity import Data.Set         ( Set  ) import Data.Text        ( Text )@@ -103,14 +102,14 @@     -- ^ An abstraction inside a special syntax declaration     --   (see Issue 358 why we introduce this).   | Ordinary e-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  fromOrdinary :: e -> OpApp e -> e fromOrdinary d (Ordinary e) = e fromOrdinary d _            = d  data FieldAssignment' a = FieldAssignment { _nameFieldA :: Name, _exprFieldA :: a }-  deriving (Data, Functor, Foldable, Traversable, Show, Eq)+  deriving (Functor, Foldable, Traversable, Show, Eq)  type FieldAssignment = FieldAssignment' Expr @@ -119,7 +118,7 @@                            , _exprModA      :: [Expr]                            , _importDirModA :: ImportDirective                            }-  deriving (Data, Eq)+  deriving Eq  type RecordAssignment  = Either FieldAssignment ModuleAssignment type RecordAssignments = [RecordAssignment]@@ -170,7 +169,6 @@   | As Range Name Expr                         -- ^ ex: @x\@p@, only in patterns   | Dot Range Expr                             -- ^ ex: @.p@, only in patterns   | DoubleDot Range Expr                       -- ^ ex: @..A@, used for parsing @..A -> B@-  | ETel Telescope                             -- ^ only used for printing telescopes   | Quote Range                                -- ^ ex: @quote@, should be applied to a name   | QuoteTerm Range                            -- ^ ex: @quoteTerm@, should be applied to a term   | Tactic Range Expr                          -- ^ ex: @\@(tactic t)@, used to declare tactic arguments@@ -179,7 +177,7 @@   | Equal Range Expr Expr                      -- ^ ex: @a = b@, used internally in the parser   | Ellipsis Range                             -- ^ @...@, used internally to parse patterns.   | Generalized Expr-  deriving (Data, Eq)+  deriving Eq  type OpAppArgs = OpAppArgs' Expr type OpAppArgs' e = [NamedArg (MaybePlaceholder (OpApp e))]@@ -210,19 +208,19 @@                                            --   Second arg is @Nothing@ before expansion, and                                            --   @Just p@ after expanding ellipsis to @p@.   | WithP Range Pattern                    -- ^ @| p@, for with-patterns.-  deriving (Data, Eq)+  deriving Eq  data DoStmt   = DoBind Range Pattern Expr [LamClause]   -- ^ @p ← e where cs@   | DoThen Expr   | DoLet Range (List1 Declaration)-  deriving (Data, Eq)+  deriving Eq  -- | A Binder @x\@p@, the pattern is optional data Binder' a = Binder   { binderPattern :: Maybe Pattern   , binderName    :: a-  } deriving (Data, Eq, Functor, Foldable, Traversable)+  } deriving (Eq, Functor, Foldable, Traversable)  type Binder = Binder' BoundName @@ -240,7 +238,7 @@     -- ^ . @x@ or @{x}@ or @.x@ or @.{x}@ or @{.x}@ or @x\@p@ or @(p)@   | DomainFull a     -- ^ . @(xs : e)@ or @{xs : e}@-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  -- | Drop type annotations and lets from bindings. dropTypeAndModality :: LamBinding -> [LamBinding]@@ -250,11 +248,12 @@ dropTypeAndModality (DomainFree x) = [DomainFree $ setModality defaultModality x]  data BoundName = BName-  { boundName   :: Name-  , bnameFixity :: Fixity'-  , bnameTactic :: TacticAttribute -- From @tactic attribute+  { boundName       :: Name+  , bnameFixity     :: Fixity'+  , bnameTactic     :: TacticAttribute -- From @tactic attribute+  , bnameIsFinite   :: Bool   }-  deriving (Data, Eq)+  deriving Eq  type TacticAttribute = Maybe Expr @@ -262,7 +261,7 @@ mkBoundName_ x = mkBoundName x noFixity'  mkBoundName :: Name -> Fixity' -> BoundName-mkBoundName x f = BName x f Nothing+mkBoundName x f = BName x f Nothing False  -- | A typed binding. @@ -273,7 +272,7 @@     -- ^ Binding @(x1\@p1 ... xn\@pn : A)@.   | TLet  Range (List1 Declaration)     -- ^ Let binding @(let Ds)@ or @(open M args)@.-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  -- | A telescope is a sequence of typed bindings. Bound variables are in scope --   in later types.@@ -327,7 +326,7 @@   , lhsWithExpr        :: [WithExpr]     -- ^ @with e1 in eq | {e2} | ...@ (many)   }-  deriving (Data, Eq)+  deriving Eq  type RewriteEqn = RewriteEqn' () Name Pattern Expr type WithExpr   = Named Name (Arg Expr)@@ -351,13 +350,13 @@              { lhsEllipsisRange :: Range              , lhsEllipsisPat   :: LHSCore           -- ^ Pattern that was expanded from an ellipsis @...@.              }-  deriving (Data, Eq)+  deriving Eq  type RHS = RHS' Expr data RHS' e   = AbsurdRHS -- ^ No right hand side because of absurd match.   | RHS e-  deriving (Data, Functor, Foldable, Traversable, Eq)+  deriving (Functor, Foldable, Traversable, Eq)  -- | @where@ block following a clause. type WhereClause = WhereClause' [Declaration]@@ -375,14 +374,14 @@       --   The 'Access' flag applies to the 'Name' (not the module contents!)       --   and is propagated from the parent function.       --   List of declarations can be empty.-  deriving (Data, Eq, Functor, Foldable, Traversable)+  deriving (Eq, Functor, Foldable, Traversable)  data LamClause = LamClause   { lamLHS      :: [Pattern]   -- ^ Possibly empty sequence.   , lamRHS      :: RHS   , lamCatchAll :: Bool   }-  deriving (Data, Eq)+  deriving Eq  -- | An expression followed by a where clause. --   Currently only used to give better a better error message in interaction.@@ -406,7 +405,7 @@   , asRange :: Range     -- ^ The range of the \"as\" keyword.  Retained for highlighting purposes.   }-  deriving (Data, Show, Functor, Foldable, Traversable, Eq)+  deriving (Show, Functor, Foldable, Traversable, Eq)  -- | From the parser, we get an expression for the @as@-'Name', which --   we have to parse into a 'Name'.@@ -434,7 +433,7 @@        -- ^ Range of @[no-]eta-equality@ keyword.    | PatternOrCopattern Range        -- ^ If declaration @pattern@ is present, give its range.-   deriving (Data,Eq,Show)+   deriving (Eq, Show)  type RecordDirectives = RecordDirectives' (Name, IsInstance) @@ -479,9 +478,13 @@   | ModuleMacro Range  Name ModuleApplication !OpenShortHand ImportDirective   | Module      Range QName Telescope [Declaration]   | UnquoteDecl Range [Name] Expr+      -- ^ @unquoteDecl xs = e@   | UnquoteDef  Range [Name] Expr+      -- ^ @unquoteDef xs = e@+  | UnquoteData Range Name [Name] Expr+      -- ^ @unquoteDecl data d constructor xs = e@   | Pragma      Pragma-  deriving (Data, Eq)+  deriving Eq  -- | Extract a record directive isRecordDirective :: Declaration -> Maybe RecordDirective@@ -494,10 +497,10 @@     -- ^ @tel. M args@   | RecordModuleInstance Range QName     -- ^ @M {{...}}@-  deriving (Data, Eq)+  deriving Eq  data OpenShortHand = DoOpen | DontOpen-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  -- Pragmas ---------------------------------------------------------------- @@ -539,7 +542,9 @@   | PolarityPragma            Range Name [Occurrence]   | NoUniverseCheckPragma     Range     -- ^ Applies to the following data/record type.-  deriving (Data, Eq)+  | NotProjectionLikePragma   Range QName+    -- ^ Applies to the stated function+  deriving Eq  --------------------------------------------------------------------------- @@ -550,19 +555,6 @@   , modDecls   :: [Declaration]   } --- | Computes the top-level module name.------ Precondition: The 'Module' has to be well-formed.--- This means that there are only allowed declarations before the--- first module declaration, typically import declarations.--- See 'spanAllowedBeforeModule'.--topLevelModuleName :: Module -> TopLevelModuleName-topLevelModuleName (Mod _ []) = __IMPOSSIBLE__-topLevelModuleName (Mod _ ds) = case spanAllowedBeforeModule ds of-  (_, Module _ n _ _ : _) -> toTopLevelModuleName n-  _ -> __IMPOSSIBLE__- -- | Splits off allowed (= import) declarations before the first --   non-allowed declaration. --   After successful parsing, the first non-allowed declaration@@ -610,14 +602,18 @@ data AppView = AppView Expr [NamedArg Expr]  appView :: Expr -> AppView-appView = \case-    App r e1 e2      -> vApp (appView e1) e2-    RawApp _ (List2 e1 e2 es)-                     -> AppView e1 $ map arg (e2:es)-    e                -> AppView e []+appView e = f (DL.toList ess)   where-    vApp (AppView e es) arg = AppView e (es ++ [arg])+    (f, ess) = appView' e +    appView' = \case+      App r e1 e2      -> vApp (appView' e1) e2+      RawApp _ (List2 e1 e2 es)+                       -> (AppView e1, DL.fromList (map arg (e2 : es)))+      e                -> (AppView e, mempty)++    vApp (f, es) arg = (f, es `DL.snoc` arg)+     arg (HiddenArg   _ e) = hide         $ defaultArg e     arg (InstanceArg _ e) = makeInstance $ defaultArg e     arg e                 = defaultArg (unnamed e)@@ -823,7 +819,6 @@       InstanceArg r _    -> r       Rec r _            -> r       RecUpdate r _ _    -> r-      ETel tel           -> getRange tel       Quote r            -> r       QuoteTerm r        -> r       Unquote r          -> r@@ -903,6 +898,7 @@   getRange (PatternSyn r _ _ _)    = r   getRange (UnquoteDecl r _ _)     = r   getRange (UnquoteDef r _ _)      = r+  getRange (UnquoteData r _ _ _)   = r   getRange (Pragma p)              = getRange p  instance HasRange LHS where@@ -946,6 +942,7 @@   getRange (NoPositivityCheckPragma r)       = r   getRange (PolarityPragma r _ _)            = r   getRange (NoUniverseCheckPragma r)         = r+  getRange (NotProjectionLikePragma r _)     = r  instance HasRange AsName where   getRange a = getRange (asRange a, asName a)@@ -1011,7 +1008,7 @@   killRange (Binder a b) = killRange2 Binder a b  instance KillRange BoundName where-  killRange (BName n f t) = killRange3 BName n f t+  killRange (BName n f t b) = killRange4 BName n f t b  instance KillRange RecordDirective where   killRange (Induction a)          = killRange1 Induction a@@ -1050,6 +1047,7 @@   killRange (Module _ q t d)        = killRange3 (Module noRange) q t d   killRange (UnquoteDecl _ x t)     = killRange2 (UnquoteDecl noRange) x t   killRange (UnquoteDef _ x t)      = killRange2 (UnquoteDef noRange) x t+  killRange (UnquoteData _ xs cs t) = killRange3 (UnquoteData noRange) xs cs t   killRange (Pragma p)              = killRange1 Pragma p  instance KillRange Expr where@@ -1078,7 +1076,6 @@   killRange (As _ n e)            = killRange2 (As noRange) n e   killRange (Dot _ e)             = killRange1 (Dot noRange) e   killRange (DoubleDot _ e)       = killRange1 (DoubleDot noRange) e-  killRange (ETel t)              = killRange1 ETel t   killRange (Quote _)             = Quote noRange   killRange (QuoteTerm _)         = QuoteTerm noRange   killRange (Unquote _)           = Unquote noRange@@ -1150,6 +1147,7 @@   killRange (NoPositivityCheckPragma _)       = NoPositivityCheckPragma noRange   killRange (PolarityPragma _ q occs)         = killRange1 (\q -> PolarityPragma noRange q occs) q   killRange (NoUniverseCheckPragma _)         = NoUniverseCheckPragma noRange+  killRange (NotProjectionLikePragma _ q)     = NotProjectionLikePragma noRange q  instance KillRange RHS where   killRange AbsurdRHS = AbsurdRHS@@ -1195,7 +1193,6 @@   rnf (As _ a b)          = rnf a `seq` rnf b   rnf (Dot _ a)           = rnf a   rnf (DoubleDot _ a)     = rnf a-  rnf (ETel a)            = rnf a   rnf (Quote _)           = ()   rnf (QuoteTerm _)       = ()   rnf (Tactic _ a)        = rnf a@@ -1265,6 +1262,7 @@   rnf (Module _ a b c)        = rnf a `seq` rnf b `seq` rnf c   rnf (UnquoteDecl _ a b)     = rnf a `seq` rnf b   rnf (UnquoteDef _ a b)      = rnf a `seq` rnf b+  rnf (UnquoteData _ a b c)   = rnf a `seq` rnf b `seq` rnf c   rnf (Pragma a)              = rnf a  instance NFData OpenShortHand@@ -1291,6 +1289,7 @@   rnf (NoPositivityCheckPragma _)       = ()   rnf (PolarityPragma _ a b)            = rnf a `seq` rnf b   rnf (NoUniverseCheckPragma _)         = ()+  rnf (NotProjectionLikePragma _ q)     = rnf q  -- | Ranges are not forced. @@ -1342,7 +1341,7 @@   rnf (Binder a b) = rnf a `seq` rnf b  instance NFData BoundName where-  rnf (BName a b c) = rnf a `seq` rnf b `seq` rnf c+  rnf (BName a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d  instance NFData a => NFData (RHS' a) where   rnf AbsurdRHS = ()
src/full/Agda/Syntax/Concrete/Attribute.hs view
@@ -93,6 +93,18 @@   , ("flat" , Flat)   ] +-- | Information about cohesion attributes (printed representations+-- and positions).+--+-- This information is returned by the parser. Code that calls the+-- parser should, if appropriate, complain if support for cohesion+-- attributes has not been enabled and the returned list is non-empty.+-- This can be taken care of by+-- 'Agda.Syntax.Translation.ConcreteToAbstract.checkCohesionAttributes',+-- which should not be called until after pragma options have been set.++type CohesionAttributes = [(String, Range)]+ -- | Modifiers for 'Quantity'.  lockAttributeTable :: [(String, Lock)]
src/full/Agda/Syntax/Concrete/Definitions.hs view
@@ -60,7 +60,6 @@ import Control.Monad.Trans   ( lift )  import Data.Bifunctor-import Data.Data (Data) import Data.Either (isLeft, isRight) import Data.Function (on) import qualified Data.Map as Map@@ -150,27 +149,28 @@   deriving (Eq, Show)  declKind :: NiceDeclaration -> DeclKind-declKind (FunSig r _ _ _ _ _ tc cc x _)     = LoneSigDecl r (FunName tc cc) x-declKind (NiceRecSig r _ _ pc uc x pars _)  = LoneSigDecl r (RecName pc uc) x-declKind (NiceDataSig r _ _ pc uc x pars _) = LoneSigDecl r (DataName pc uc) x-declKind (FunDef r _ abs ins tc cc x _)     = LoneDefs (FunName tc cc) [x]-declKind (NiceDataDef _ _ _ pc uc x pars _) = LoneDefs (DataName pc uc) [x]+declKind (FunSig r _ _ _ _ _ tc cc x _)      = LoneSigDecl r (FunName tc cc) x+declKind (NiceRecSig r _ _ pc uc x pars _)   = LoneSigDecl r (RecName pc uc) x+declKind (NiceDataSig r _ _ pc uc x pars _)  = LoneSigDecl r (DataName pc uc) x+declKind (FunDef r _ abs ins tc cc x _)      = LoneDefs (FunName tc cc) [x]+declKind (NiceDataDef _ _ _ pc uc x pars _)  = LoneDefs (DataName pc uc) [x]+declKind (NiceUnquoteData _ _ _ pc uc x _ _) = LoneDefs (DataName pc uc) [x] declKind (NiceRecDef _ _ _ pc uc x _ pars _) = LoneDefs (RecName pc uc) [x]-declKind (NiceUnquoteDef _ _ _ tc cc xs _)  = LoneDefs (FunName tc cc) xs-declKind Axiom{}                            = OtherDecl-declKind NiceField{}                        = OtherDecl-declKind PrimitiveFunction{}                = OtherDecl-declKind NiceMutual{}                       = OtherDecl-declKind NiceModule{}                       = OtherDecl-declKind NiceModuleMacro{}                  = OtherDecl-declKind NiceOpen{}                         = OtherDecl-declKind NiceImport{}                       = OtherDecl-declKind NicePragma{}                       = OtherDecl-declKind NiceFunClause{}                    = OtherDecl-declKind NicePatternSyn{}                   = OtherDecl-declKind NiceGeneralize{}                   = OtherDecl-declKind NiceUnquoteDecl{}                  = OtherDecl-declKind NiceLoneConstructor{}              = OtherDecl+declKind (NiceUnquoteDef _ _ _ tc cc xs _)   = LoneDefs (FunName tc cc) xs+declKind Axiom{}                             = OtherDecl+declKind NiceField{}                         = OtherDecl+declKind PrimitiveFunction{}                 = OtherDecl+declKind NiceMutual{}                        = OtherDecl+declKind NiceModule{}                        = OtherDecl+declKind NiceModuleMacro{}                   = OtherDecl+declKind NiceOpen{}                          = OtherDecl+declKind NiceImport{}                        = OtherDecl+declKind NicePragma{}                        = OtherDecl+declKind NiceFunClause{}                     = OtherDecl+declKind NicePatternSyn{}                    = OtherDecl+declKind NiceGeneralize{}                    = OtherDecl+declKind NiceUnquoteDecl{}                   = OtherDecl+declKind NiceLoneConstructor{}               = OtherDecl  -- | Replace (Data/Rec/Fun)Sigs with Axioms for postulated names --   The first argument is a list of axioms only.@@ -307,6 +307,10 @@         Generalize r sigs -> do           gs <- forM sigs $ \case             sig@(TypeSig info tac x t) -> do+              -- Andreas, 2022-03-25, issue #5850:+              -- Warn about @variable {x} : A@ which is equivalent to @variable x : A@.+              when (getHiding info == Hidden) $+                declarationWarning $ HiddenGeneralize $ getRange x               return $ NiceGeneralize (getRange sig) PublicAccess info tac x t             _ -> __IMPOSSIBLE__           return (gs, ds)@@ -488,6 +492,11 @@               mapM_ removeLoneSig xs               return ([NiceUnquoteDef r PublicAccess ConcreteDef TerminationCheck YesCoverageCheck xs e] , ds) +        UnquoteData r xs cs e -> do+          pc <- use positivityCheckPragma+          uc <- use universeCheckPragma+          return ([NiceUnquoteData r PublicAccess ConcreteDef pc uc xs cs e], ds)+         Pragma p -> nicePragma p ds      nicePragma :: Pragma -> [Declaration] -> Nice ([NiceDeclaration], [Declaration])@@ -1032,6 +1041,7 @@             NiceGeneralize{}    -> top             NiceUnquoteDecl{}   -> top             NiceUnquoteDef{}    -> bottom+            NiceUnquoteData{}   -> top             NicePragma r pragma -> case pragma of                OptionsPragma{}           -> top     -- error thrown in the type checker@@ -1051,6 +1061,7 @@                StaticPragma{}            -> bottom               InlinePragma{}            -> bottom+              NotProjectionLikePragma{} -> bottom                ImpossiblePragma{}        -> top     -- error thrown in scope checker               EtaPragma{}               -> bottom  -- needs record definition@@ -1135,6 +1146,7 @@         termCheck NicePatternSyn{}    = TerminationCheck         termCheck NiceGeneralize{}    = TerminationCheck         termCheck NiceLoneConstructor{} = TerminationCheck+        termCheck NiceUnquoteData{}   = TerminationCheck          covCheck :: NiceDeclaration -> CoverageCheck         covCheck (FunSig _ _ _ _ _ _ _ cc _ _)      = cc@@ -1159,6 +1171,7 @@         covCheck NicePatternSyn{}    = YesCoverageCheck         covCheck NiceGeneralize{}    = YesCoverageCheck         covCheck NiceLoneConstructor{} = YesCoverageCheck+        covCheck NiceUnquoteData{}   = YesCoverageCheck          -- ASR (26 December 2015): Do not positivity check a mutual         -- block if any of its inner declarations comes with a@@ -1227,6 +1240,7 @@         d@NiceRecDef{}                 -> return d         d@NicePatternSyn{}             -> return d         d@NiceGeneralize{}             -> return d+        d@NiceUnquoteData{}            -> return d      setInstance       :: Range  -- Range of @instance@ keyword.@@ -1290,6 +1304,7 @@       -- Need to set updater state to dirty!       NiceUnquoteDecl r p _ i tc cc x e -> tellDirty $> NiceUnquoteDecl r p AbstractDef i tc cc x e       NiceUnquoteDef r p _ tc cc x e    -> tellDirty $> NiceUnquoteDef r p AbstractDef tc cc x e+      NiceUnquoteData r p _ tc cc x xs e -> tellDirty $> NiceUnquoteData r p AbstractDef tc cc x xs e       d@NiceModule{}                 -> return d       d@NiceModuleMacro{}            -> return d       d@NicePragma{}                 -> return d@@ -1363,6 +1378,7 @@       FunDef r ds a i tc cc x cls              -> FunDef r ds a i tc cc x <$> mkPrivate o cls       d@NiceDataDef{}                          -> return d       d@NiceRecDef{}                           -> return d+      d@NiceUnquoteData{}                      -> return d  instance MakePrivate Clause where   mkPrivate o (Clause x catchall lhs rhs wh with) = do@@ -1408,6 +1424,7 @@     NiceGeneralize r _ i tac n e   -> [Generalize r [TypeSig i tac n e]]     NiceUnquoteDecl r _ _ i _ _ x e -> inst i [UnquoteDecl r x e]     NiceUnquoteDef r _ _ _ _ x e    -> [UnquoteDef r x e]+    NiceUnquoteData r _ _ _ _ x xs e  -> [UnquoteData r x xs e]   where     inst (InstanceDef r) ds = [InstanceB r ds]     inst NotInstanceDef  ds = ds@@ -1436,3 +1453,4 @@     NiceGeneralize{}              -> Nothing     NiceUnquoteDecl _ _ a _ _ _ _ _ -> Just a     NiceUnquoteDef _ _ a _ _ _ _    -> Just a+    NiceUnquoteData _ _ a _ _ _ _ _ -> Just a
src/full/Agda/Syntax/Concrete/Definitions/Errors.hs view
@@ -2,8 +2,6 @@  import Control.DeepSeq -import Data.Data- import GHC.Generics (Generic)  import Agda.Syntax.Position@@ -47,7 +45,7 @@       --   Range is of mutual block.   | UnquoteDefRequiresSignature (List1 Name)   | BadMacroDef NiceDeclaration-    deriving (Data, Show)+    deriving Show  ------------------------------------------------------------------------ -- Warnings@@ -70,6 +68,10 @@   | EmptyPostulate Range   -- ^ Empty @postulate@ block.   | EmptyPrivate Range     -- ^ Empty @private@   block.   | EmptyPrimitive Range   -- ^ Empty @primitive@ block.+  | HiddenGeneralize Range+      -- ^ A 'Hidden' identifier in a @variable@ declaration.+      --   Hiding has no effect there as generalized variables are always hidden+      --   (or instance variables).   | InvalidCatchallPragma Range       -- ^ A {-\# CATCHALL \#-} pragma       --   that does not precede a function clause.@@ -115,7 +117,7 @@       -- ^ @instance@ block with nothing that can (newly) become an instance.   | UselessPrivate Range       -- ^ @private@ block with nothing that can (newly) be made private.-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  declarationWarningName :: DeclarationWarning -> WarningName declarationWarningName = declarationWarningName' . dwWarning@@ -133,6 +135,7 @@   EmptyPrivate{}                    -> EmptyPrivate_   EmptyPostulate{}                  -> EmptyPostulate_   EmptyPrimitive{}                  -> EmptyPrimitive_+  HiddenGeneralize{}                -> HiddenGeneralize_   InvalidCatchallPragma{}           -> InvalidCatchallPragma_   InvalidConstructor{}              -> InvalidConstructor_   InvalidConstructorBlock{}         -> InvalidConstructorBlock_@@ -174,6 +177,7 @@   EmptyPrivate{}                    -> False   EmptyPostulate{}                  -> False   EmptyPrimitive{}                  -> False+  HiddenGeneralize{}                -> False   InvalidCatchallPragma{}           -> False   InvalidConstructor{}              -> False   InvalidConstructorBlock{}         -> False@@ -243,6 +247,7 @@   getRange (EmptyGeneralize r)                  = r   getRange (EmptyPrimitive r)                   = r   getRange (EmptyField r)                       = r+  getRange (HiddenGeneralize r)                 = r   getRange (InvalidTerminationCheckPragma r)    = r   getRange (InvalidCoverageCheckPragma r)       = r   getRange (InvalidNoPositivityCheckPragma r)   = r@@ -340,6 +345,7 @@   pretty (EmptyGeneralize _) = fsep $ pwords "Empty variable block."   pretty (EmptyPrimitive _)  = fsep $ pwords "Empty primitive block."   pretty (EmptyField _)      = fsep $ pwords "Empty field block."+  pretty (HiddenGeneralize _) = fsep $ pwords "Declaring a variable as hidden has no effect in a variable block. Generalization never introduces visible arguments."   pretty InvalidRecordDirective{} = fsep $     pwords "Record directives can only be used inside record definitions and before field declarations."   pretty (InvalidTerminationCheckPragma _) = fsep $
src/full/Agda/Syntax/Concrete/Definitions/Monad.hs view
@@ -113,9 +113,9 @@ addLoneSig :: Range -> Name -> DataRecOrFun -> Nice Name addLoneSig r x k = do   -- Andreas, 2020-05-19, issue #4157, make '_' unique.-  x' <- if not $ isNoName x then return x else do-    i <- nextNameId-    return x{ nameId = i }+  x' <- case x of+    Name{}     -> pure x+    NoName r _ -> NoName r <$> nextNameId   loneSigs %== \ s -> do     let (mr, s') = Map.insertLookupWithKey (\ _k new _old -> new) x (LoneSig r x' k) s     case mr of
src/full/Agda/Syntax/Concrete/Definitions/Types.hs view
@@ -2,7 +2,6 @@  import Control.DeepSeq -import Data.Data import Data.Map (Map) import Data.Semigroup ( Semigroup(..) ) @@ -80,7 +79,8 @@   | NiceGeneralize Range Access ArgInfo TacticAttribute Name Expr   | NiceUnquoteDecl Range Access IsAbstract IsInstance TerminationCheck CoverageCheck [Name] Expr   | NiceUnquoteDef Range Access IsAbstract TerminationCheck CoverageCheck [Name] Expr-  deriving (Data, Show, Generic)+  | NiceUnquoteData Range Access IsAbstract PositivityCheck UniverseCheck Name [Name] Expr+  deriving (Show, Generic)  instance NFData NiceDeclaration @@ -100,7 +100,7 @@ -- | One clause in a function definition. There is no guarantee that the 'LHS' --   actually declares the 'Name'. We will have to check that later. data Clause = Clause Name Catchall LHS RHS WhereClause [Clause]-    deriving (Data, Show, Generic)+    deriving (Show, Generic)  instance NFData Clause @@ -174,8 +174,10 @@ interleavedDecl :: Name -> InterleavedDecl -> [(DeclNum, NiceDeclaration)] interleavedDecl k = \case   InterleavedData i d@(NiceDataSig _ acc abs pc uc _ pars _) ds ->-    let fpars = concatMap dropTypeAndModality pars-        ddef  = NiceDataDef noRange UserWritten abs pc uc k fpars+    let fpars   = concatMap dropTypeAndModality pars+        r       = getRange (k, fpars)+        ddef cs = NiceDataDef (getRange (r, cs)) UserWritten+                    abs pc uc k fpars cs     in (i,d) : maybe [] (\ (j, dss) -> [(j, ddef (sconcat (List1.reverse dss)))]) ds   InterleavedFun i d@(FunSig r acc abs inst mac info tc cc n e) dcs ->     let fdef dcss = let (dss, css) = List1.unzip dcss in@@ -191,7 +193,7 @@   | FieldBlock      -- ^ @field@.  Ensured by parser.   | DataBlock       -- ^ @data ... where@.  Here we got a bad error message for Agda-2.5 (Issue 1698).   | ConstructorBlock  -- ^ @constructor@, in @interleaved mutual@.-  deriving (Data, Eq, Ord, Show)+  deriving (Eq, Ord, Show)   instance HasRange NiceDeclaration where@@ -215,7 +217,8 @@   getRange (NiceGeneralize r _ _ _ _ _)    = r   getRange (NiceFunClause r _ _ _ _ _ _)   = r   getRange (NiceUnquoteDecl r _ _ _ _ _ _ _) = r-  getRange (NiceUnquoteDef r _ _ _ _ _ _)    = r+  getRange (NiceUnquoteDef r _ _ _ _ _ _)  = r+  getRange (NiceUnquoteData r _ _ _ _ _ _ _) = r  instance Pretty NiceDeclaration where   pretty = \case@@ -240,6 +243,7 @@     NiceGeneralize _ _ _ _ x _     -> text "variable" <+> pretty x     NiceUnquoteDecl _ _ _ _ _ _ xs _ -> text "<unquote declarations>"     NiceUnquoteDef _ _ _ _ _ xs _    -> text "<unquote definitions>"+    NiceUnquoteData _ _ _ _ _ x xs _ -> text "<unquote data types>"  declName :: NiceDeclaration -> String declName Axiom{}             = "Postulates"@@ -255,6 +259,7 @@ declName NiceGeneralize{}    = "Generalized variables" declName NiceUnquoteDecl{}   = "Unquoted declarations" declName NiceUnquoteDef{}    = "Unquoted definitions"+declName NiceUnquoteData{}   = "Unquoted data types" declName NiceRecSig{}        = "Records" declName NiceDataSig{}       = "Data types" declName NiceFunClause{}     = "Functions without a type signature"@@ -285,7 +290,7 @@     -- ^ Name of a record type   | FunName TerminationCheck CoverageCheck     -- ^ Name of a function.-  deriving (Data, Show)+  deriving Show  -- Ignore pragmas when checking equality instance Eq DataRecOrFun where
src/full/Agda/Syntax/Concrete/Fixity.hs view
@@ -91,10 +91,12 @@     return (f, p)     where     mergePolarities p1 p2-      | Set.null i = return (Map.union p1 p2)-      | otherwise  = throwMultiplePolarityPragmas (Set.toList i)+      | Map.null i = return (Map.union p1 p2)+      | otherwise  = throwMultiplePolarityPragmas $+                     map fst $ Map.toList i       where-      i = Set.intersection (Map.keysSet p1) (Map.keysSet p2)+      -- Only the keys are used.+      i = Map.intersection p1 p2  instance MonadFixityError m => Monoid (MonadicFixPol m) where   mempty  = MonadicFixPol $ return (Map.empty, Map.empty)@@ -180,6 +182,7 @@   Module          {}  -> mempty   UnquoteDecl     {}  -> mempty   UnquoteDef      {}  -> mempty+  UnquoteData     {}  -> mempty   Pragma          {}  -> mempty  data DeclaredNames = DeclaredNames { _allNames, _postulates, _privateNames :: Set Name }@@ -208,39 +211,40 @@ --   i.e., do not go into modules. declaredNames :: Declaration -> DeclaredNames declaredNames = \case-  TypeSig _ _ x _      -> declaresName x-  FieldSig _ _ x _     -> declaresName x-  Field _ fs           -> foldMap declaredNames fs+  TypeSig _ _ x _       -> declaresName x+  FieldSig _ _ x _      -> declaresName x+  Field _ fs            -> foldMap declaredNames fs   FunClause (LHS p [] []) _ _ _     | IdentP (QName x) <- removeParenP p-                       -> declaresName x-  FunClause{}          -> mempty-  DataSig _ x _ _      -> declaresName x-  DataDef _ _ _ cs     -> foldMap declaredNames cs-  Data _ x _ _ cs      -> declaresName x <> foldMap declaredNames cs-  RecordSig _ x _ _    -> declaresName x-  RecordDef _ x d _ _  -> declaresNames $     foldMap (:[]) (fst <$> recConstructor d)-  Record _ x d _ _ _   -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d)-  RecordDirective _    -> mempty-  Infix _ _            -> mempty-  Syntax _ _           -> mempty-  PatternSyn _ x _ _   -> declaresName x-  Mutual    _ ds       -> foldMap declaredNames ds+                        -> declaresName x+  FunClause{}           -> mempty+  DataSig _ x _ _       -> declaresName x+  DataDef _ _ _ cs      -> foldMap declaredNames cs+  Data _ x _ _ cs       -> declaresName x <> foldMap declaredNames cs+  RecordSig _ x _ _     -> declaresName x+  RecordDef _ x d _ _   -> declaresNames $     foldMap (:[]) (fst <$> recConstructor d)+  Record _ x d _ _ _    -> declaresNames $ x : foldMap (:[]) (fst <$> recConstructor d)+  RecordDirective _     -> mempty+  Infix _ _             -> mempty+  Syntax _ _            -> mempty+  PatternSyn _ x _ _    -> declaresName x+  Mutual    _ ds        -> foldMap declaredNames ds   InterleavedMutual    _ ds -> foldMap declaredNames ds-  LoneConstructor _ ds -> foldMap declaredNames ds-  Abstract  _ ds       -> foldMap declaredNames ds-  Private _ _ ds       -> allPrivateNames $ foldMap declaredNames ds-  InstanceB _ ds       -> foldMap declaredNames ds-  Macro     _ ds       -> foldMap declaredNames ds-  Postulate _ ds       -> allPostulates $ foldMap declaredNames ds-  Primitive _ ds       -> foldMap declaredNames ds-  Generalize _ ds      -> foldMap declaredNames ds-  Open{}               -> mempty-  Import{}             -> mempty-  ModuleMacro{}        -> mempty-  Module{}             -> mempty-  UnquoteDecl _ xs _   -> declaresNames xs-  UnquoteDef{}         -> mempty+  LoneConstructor _ ds  -> foldMap declaredNames ds+  Abstract  _ ds        -> foldMap declaredNames ds+  Private _ _ ds        -> allPrivateNames $ foldMap declaredNames ds+  InstanceB _ ds        -> foldMap declaredNames ds+  Macro     _ ds        -> foldMap declaredNames ds+  Postulate _ ds        -> allPostulates $ foldMap declaredNames ds+  Primitive _ ds        -> foldMap declaredNames ds+  Generalize _ ds       -> foldMap declaredNames ds+  Open{}                -> mempty+  Import{}              -> mempty+  ModuleMacro{}         -> mempty+  Module{}              -> mempty+  UnquoteDecl _ xs _    -> declaresNames xs+  UnquoteDef{}          -> mempty+  UnquoteData _ x cs _  -> declaresNames (x:cs)   -- BUILTIN pragmas which do not require an accompanying definition declare   -- the (unqualified) name they mention.   Pragma (BuiltinPragma _ b (QName x))
src/full/Agda/Syntax/Concrete/Generic.hs view
@@ -131,7 +131,6 @@      As r x e           -> f $ As r x                 $ mapE e      Dot r e            -> f $ Dot r                  $ mapE e      DoubleDot r e      -> f $ DoubleDot r            $ mapE e-     ETel tel           -> f $ ETel                   $ mapE tel      Tactic r e         -> f $ Tactic r     (mapE e)      Quote{}            -> f $ e0      QuoteTerm{}        -> f $ e0@@ -246,6 +245,7 @@      Module r n tel ds         -> Module r n (mapE tel)                $ mapE ds      UnquoteDecl r x e         -> UnquoteDecl r x (mapE e)      UnquoteDef r x e          -> UnquoteDef r x (mapE e)+     UnquoteData r x xs e      -> UnquoteData r x xs (mapE e)      e@Pragma{}                -> e    where      mapE :: ExprLike e => e -> e
src/full/Agda/Syntax/Concrete/Name.hs view
@@ -3,30 +3,26 @@ -} module Agda.Syntax.Concrete.Name where +import Prelude hiding ((!!))+ import Control.DeepSeq  import Data.ByteString.Char8 (ByteString)-import Data.Function+import Data.Function (on) import qualified Data.Foldable as Fold-import qualified Data.List as List-import Data.Data (Data)  import GHC.Generics (Generic) -import System.FilePath- import Agda.Syntax.Common import Agda.Syntax.Concrete.Glyph import Agda.Syntax.Position -import Agda.Utils.FileName import Agda.Utils.Lens-import Agda.Utils.List  (last1)+import Agda.Utils.List  ((!!), last1) import Agda.Utils.List1 (List1, pattern (:|), (<|)) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Pretty import Agda.Utils.Singleton-import Agda.Utils.Size import Agda.Utils.Suffix  import Agda.Utils.Impossible@@ -49,7 +45,6 @@     { nameRange     :: Range     , nameId        :: NameId     }-  deriving Data  type NameParts = List1 NamePart @@ -72,7 +67,7 @@ data NamePart   = Hole       -- ^ @_@ part.   | Id RawName  -- ^ Identifier part.-  deriving (Data, Generic)+  deriving Generic  -- | Define equality on @Name@ to ignore range so same names in different --   locations are equal.@@ -115,27 +110,13 @@ data QName   = Qual  Name QName -- ^ @A.rest@.   | QName Name       -- ^ @x@.-  deriving (Data, Eq, Ord)+  deriving (Eq, Ord)  instance Underscore QName where   underscore = QName underscore   isUnderscore (QName x) = isUnderscore x   isUnderscore Qual{}    = False --- | Top-level module names.  Used in connection with the file system.------   Invariant: The list must not be empty.--data TopLevelModuleName = TopLevelModuleName-  { moduleNameRange :: Range-  , moduleNameParts :: List1 String-  }-  deriving (Show, Data, Generic)--instance Eq    TopLevelModuleName where (==)    = (==)    `on` moduleNameParts-instance Ord   TopLevelModuleName where compare = compare `on` moduleNameParts-instance Sized TopLevelModuleName where size    = size     .   moduleNameParts- ------------------------------------------------------------------------ -- * Constructing simple 'Name's. ------------------------------------------------------------------------@@ -179,7 +160,7 @@ stringNameParts :: String -> NameParts stringNameParts ""  = singleton $ Id "_"  -- NoName stringNameParts "_" = singleton $ Id "_"  -- NoName-stringNameParts s = List1.fromList $ loop s+stringNameParts s = List1.fromListSafe __IMPOSSIBLE__ $ loop s   where   loop ""                              = []   loop ('_':s)                         = Hole : loop s@@ -223,7 +204,7 @@ ------------------------------------------------------------------------  data NameInScope = InScope | NotInScope-  deriving (Eq, Show, Data)+  deriving (Eq, Show)  class LensInScope a where   lensInScope :: Lens' NameInScope a@@ -377,37 +358,6 @@ isUnqualified (QName n) = Just n  --------------------------------------------------------------------------- * Operations on 'TopLevelModuleName'----------------------------------------------------------------------------- | Turns a qualified name into a 'TopLevelModuleName'. The qualified--- name is assumed to represent a top-level module name.--toTopLevelModuleName :: QName -> TopLevelModuleName-toTopLevelModuleName q = TopLevelModuleName (getRange q) $-  fmap nameToRawName $ qnameParts q---- | Turns a top-level module name into a file name with the given--- suffix.--moduleNameToFileName :: TopLevelModuleName -> String -> FilePath-moduleNameToFileName (TopLevelModuleName _ ms) ext =-  joinPath (List1.init ms) </> List1.last ms <.> ext---- | Finds the current project's \"root\" directory, given a project--- file and the corresponding top-level module name.------ Example: If the module \"A.B.C\" is located in the file--- \"/foo/A/B/C.agda\", then the root is \"/foo/\".------ Precondition: The module name must be well-formed.--projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath-projectRoot file (TopLevelModuleName _ m) =-  mkAbsolute $-    iterate takeDirectory (filePath file) !! length m-------------------------------------------------------------------------- -- * No name stuff ------------------------------------------------------------------------ @@ -445,8 +395,6 @@ instance IsNoName a => IsNoName (Ranged a) where instance IsNoName a => IsNoName (WithOrigin a) where --- no instance for TopLevelModuleName- ------------------------------------------------------------------------ -- * Showing names ------------------------------------------------------------------------@@ -473,9 +421,6 @@     | otherwise      = pretty m <> "." <> pretty x   pretty (QName x)  = pretty x -instance Pretty TopLevelModuleName where-  pretty (TopLevelModuleName _ ms) = text $ List.intercalate "." $ List1.toList ms- ------------------------------------------------------------------------ -- * Range instances ------------------------------------------------------------------------@@ -488,9 +433,6 @@     getRange (QName  x) = getRange x     getRange (Qual n x) = fuseRange n x -instance HasRange TopLevelModuleName where-  getRange = moduleNameRange- instance SetRange Name where   setRange r (Name _ nis ps) = Name r nis ps   setRange r (NoName _ i)  = NoName r i@@ -499,9 +441,6 @@   setRange r (QName x)  = QName (setRange r x)   setRange r (Qual n x) = Qual (setRange r n) (setRange r x) -instance SetRange TopLevelModuleName where-  setRange r (TopLevelModuleName _ x) = TopLevelModuleName r x- instance KillRange QName where   killRange (QName x) = QName $ killRange x   killRange (Qual n x) = killRange n `Qual` killRange x@@ -510,9 +449,6 @@   killRange (Name r nis ps)  = Name (killRange r) nis ps   killRange (NoName r i)     = NoName (killRange r) i -instance KillRange TopLevelModuleName where-  killRange (TopLevelModuleName _ x) = TopLevelModuleName noRange x- ------------------------------------------------------------------------ -- * NFData instances ------------------------------------------------------------------------@@ -534,5 +470,3 @@ instance NFData QName where   rnf (Qual a b) = rnf a `seq` rnf b   rnf (QName a)  = rnf a--instance NFData TopLevelModuleName
src/full/Agda/Syntax/Concrete/Operators.hs view
@@ -19,12 +19,12 @@     ) where  import Control.Applicative ( Alternative((<|>)))-import Control.Arrow (second) import Control.Monad.Except (throwError)  import Data.Either (partitionEithers) import qualified Data.Foldable as Fold-import Data.Function+import Data.Function (on)+import qualified Data.Function import qualified Data.List as List import Data.Maybe import Data.Map (Map)@@ -42,6 +42,7 @@ import Agda.Syntax.Position import Agda.Syntax.Notation import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Flat import Agda.Syntax.Scope.Monad  import Agda.TypeChecking.Monad.Base (typeError, TypeError(..), LHSOrPatSyn(..))@@ -81,45 +82,6 @@ -- * Building the parser --------------------------------------------------------------------------- -type FlatScope = Map QName [AbstractName]---- | Compute all defined names in scope and their fixities/notations.--- Note that overloaded names (constructors) can have several--- fixities/notations. Then we 'mergeNotations'. (See issue 1194.)-getDefinedNames :: KindsOfNames -> FlatScope -> [[NewNotation]]-getDefinedNames kinds names =-  [ mergeNotations $ map (namesToNotation x . A.qnameName . anameName) ds-  | (x, ds) <- Map.toList names-  , any ((`elemKindsOfNames` kinds) . anameKind) ds-  , not (null ds)-  ]-  -- Andreas, 2013-03-21 see Issue 822-  -- Names can have different kinds, i.e., 'defined' and 'constructor'.-  -- We need to consider all names that have *any* matching kind,-  -- not only those whose first appearing kind is matching.---- | Compute all names (first component) and operators/notations--- (second component) in scope.-localNames :: FlatScope -> ScopeM ([QName], [NewNotation])-localNames flat = do-  let defs = getDefinedNames allKindsOfNames flat-  locals <- nubOn fst . notShadowedLocals <$> getLocalVars-  -- Note: Debug printout aligned with the one in buildParsers.-  reportS "scope.operators" 50-    [ "flat  = " ++ prettyShow flat-    , "defs  = " ++ prettyShow defs-    , "locals= " ++ prettyShow locals-    ]-  let localNots  = map localOp locals-      notLocal   = not . hasElem (map notaName localNots) . notaName-      otherNots  = concatMap (filter notLocal) defs-  return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots-  where-    localOp (x, y) = namesToNotation (QName x) y-    split          = partitionEithers . concatMap opOrNot-    opOrNot n      = Left (notaName n) :-                     [Right n | not (null (notation n))]- -- | A data structure used internally by 'buildParsers'. data InternalParsers e = InternalParsers   { pTop    :: Parser e e@@ -181,7 +143,9 @@ buildParsers kind exprNames = do     flat         <- flattenScope (qualifierModules exprNames) <$>                       getScope-    (names, ops) <- localNames flat+    (names, ops0) <- localNames flat+    let ops | kind == IsPattern = filter (not . isLambdaNotation) ops0+            | otherwise         = ops0      let -- All names.         namesInExpr :: Set QName@@ -224,9 +188,9 @@           Trie.member (addHole withHole p) partListsInExpr           where           p = case n of-            NormalHole{} : IdPart p : _ -> rangedThing p-            IdPart p : _                -> rangedThing p-            _                           -> __IMPOSSIBLE__+            HolePart{} : IdPart p : _ -> rangedThing p+            IdPart p : _              -> rangedThing p+            _                         -> __IMPOSSIBLE__          -- Is the last identifier part present in n present in the         -- expression, without any succeeding name parts, except for a@@ -235,9 +199,9 @@           Trie.member (addHole withHole p) reversedPartListsInExpr           where           p = case reverse n of-            NormalHole{} : IdPart p : _ -> rangedThing p-            IdPart p : _                -> rangedThing p-            _                           -> __IMPOSSIBLE__+            HolePart{} : IdPart p : _ -> rangedThing p+            IdPart p : _              -> rangedThing p+            _                         -> __IMPOSSIBLE__          -- Are the initial and final identifier parts present with         -- the right mix of leading and trailing underscores?
src/full/Agda/Syntax/Concrete/Operators/Parser.hs view
@@ -7,7 +7,9 @@ import Control.Monad ((<=<))  import Data.Either+import Data.Function (on) import Data.Kind ( Type )+import qualified Data.List as List import Data.Maybe import qualified Data.Strict.Maybe as Strict import Data.Set (Set)@@ -277,39 +279,39 @@    where -  (leadingHoles, syn1)                  = span    isNormalHole syn-  (withoutExternalHoles, trailingHoles) = spanEnd isNormalHole syn1+  (leadingHoles, syn1)                  = span    isAHole syn+  (withoutExternalHoles, trailingHoles) = spanEnd isAHole syn1    leadingHole = case leadingHoles of-    [NormalHole _ h] -> h-    _                -> __IMPOSSIBLE__+    [HolePart _ h] -> h+    _              -> __IMPOSSIBLE__    trailingHole = case trailingHoles of-    [NormalHole _ h] -> h-    _                -> __IMPOSSIBLE__+    [HolePart _ h] -> h+    _              -> __IMPOSSIBLE__    worker ::     [Name] -> Notation ->     Parser e (Range, [Either (MaybePlaceholder e, NamedArg (Ranged Int))-                             (LamBinding, Ranged Int)])+                             (LamBinding, Ranged BoundVariablePosition)])   worker ms []              = pure (noRange, [])   worker ms (IdPart x : xs) =     (\r1 (r2, es) -> (fuseRanges r1 r2, es))       <$> partP ms (rangedThing x)       <*> worker [] xs           -- Only the first part is qualified.-  worker ms (NormalHole _ h : xs) =+  worker ms (HolePart _ h : xs) =     (\e (r, es) -> (r, Left (e, h) : es))       <$> maybePlaceholder             (if isOp && parseSections == ParseSections              then Just Middle else Nothing)             p       <*> worker ms xs-  worker ms (WildHole h : xs) =+  worker ms (WildPart h : xs) =     (\(r, es) -> let anon = mkBinder_ simpleHole                  in (r, Right (mkBinding h anon) : es))       <$> worker ms xs-  worker ms (BindHole _ h : xs) = do+  worker ms (VarPart _ h : xs) = do     (\ b (r, es) -> (r, Right (mkBinding h b) : es))            -- Andreas, 2011-04-07 put just 'Relevant' here, is this            -- correct?@@ -322,13 +324,19 @@    findExprFor ::     [(MaybePlaceholder e, NamedArg (Ranged Int))] ->-    [(LamBinding, Ranged Int)] -> Int ->+    [(LamBinding, Ranged BoundVariablePosition)] -> Int ->     NamedArg (MaybePlaceholder (OpApp e))   findExprFor normalHoles binders n =     case [ h | h@(_, m) <- normalHoles, rangedThing (namedArg m) == n ] of       [(Placeholder p,     arg)] -> set (Placeholder p) arg       [(NoPlaceholder _ e, arg)] ->-        List1.ifNull [ b | (b, m) <- binders, rangedThing m == n ]+        List1.ifNull+          (map snd $+           List.sortBy (compare `on` fst)+             [ (varNumber (rangedThing m), b)+             | (b, m) <- binders+             , holeNumber (rangedThing m) == n+             ])         {-then-} (set (noPlaceholder (Ordinary e)) arg) -- no variable to bind         {-else-} $ \ bs -> set (noPlaceholder (SyntaxBindingLambda (fuseRange bs e) bs e)) arg       _ -> __IMPOSSIBLE__
src/full/Agda/Syntax/Concrete/Pattern.hs view
@@ -101,6 +101,7 @@  -- | Add applicative patterns (non-projection / non-with patterns) to the right. lhsCoreApp :: LHSCore -> [NamedArg Pattern] -> LHSCore+lhsCoreApp (LHSEllipsis r core) ps = LHSEllipsis r $ lhsCoreApp core ps lhsCoreApp core ps = core { lhsPats = lhsPats core ++ ps }  -- | Add with-patterns to the right.
src/full/Agda/Syntax/Concrete/Pretty.hs view
@@ -80,23 +80,25 @@     NotHidden  -> parens  prettyRelevance :: LensRelevance a => a -> Doc -> Doc-prettyRelevance a d =-  if render d == "_" then d else pretty (getRelevance a) <> d+prettyRelevance a = (pretty (getRelevance a) <>)  prettyQuantity :: LensQuantity a => a -> Doc -> Doc-prettyQuantity a d =-  if render d == "_" then d else pretty (getQuantity a) <+> d+prettyQuantity a = (pretty (getQuantity a) <+>)  prettyErased :: Erased -> Doc -> Doc prettyErased = prettyQuantity . asQuantity  prettyCohesion :: LensCohesion a => a -> Doc -> Doc-prettyCohesion a d =-  if render d == "_" then d else pretty (getCohesion a) <+> d+prettyCohesion a = (pretty (getCohesion a) <+>)  prettyTactic :: BoundName -> Doc -> Doc prettyTactic = prettyTactic' . bnameTactic +prettyFiniteness :: BoundName -> Doc -> Doc+prettyFiniteness name+  | bnameIsFinite name = ("@finite" <+>)+  | otherwise = id+ prettyTactic' :: TacticAttribute -> Doc -> Doc prettyTactic' Nothing  d = d prettyTactic' (Just t) d = "@" <> (parens ("tactic" <+> pretty t) <+> d)@@ -151,6 +153,28 @@     , pretty (getCohesion mod)     ] +-- | Show the attributes necessary to recover a modality, in long-form+-- (e.g. using at-syntax rather than dots). For the default modality,+-- the result is at-ω (rather than the empty document). Suitable for+-- showing modalities outside of binders.+attributesForModality :: Modality -> Doc+attributesForModality mod+  | mod == defaultModality = text "@ω"+  | otherwise = fsep $ catMaybes [relevance, quantity, cohesion]+  where+    relevance = case getRelevance mod of+      Relevant   -> Nothing+      Irrelevant -> Just "@irrelevant"+      NonStrict  -> Just "@shape-irrelevant"+    quantity = case getQuantity mod of+      Quantity0{} -> Just "@0"+      Quantity1{} -> Just "@1"+      Quantityω{} -> Nothing+    cohesion = case getCohesion mod of+      Flat{}       -> Just "@♭"+      Continuous{} -> Nothing+      Squash{}     -> Just "@⊤"+ instance Pretty (OpApp Expr) where   pretty (Ordinary e) = pretty e   pretty (SyntaxBindingLambda r bs e) = pretty (Lam r bs e)@@ -216,8 +240,6 @@             Rec _ xs  -> sep ["record", bracesAndSemicolons (map pretty xs)]             RecUpdate _ e xs ->               sep ["record" <+> pretty e, bracesAndSemicolons (map pretty xs)]-            ETel []  -> "()"-            ETel tel -> fsep $ map pretty tel             Quote _ -> "quote"             QuoteTerm _ -> "quoteTerm"             Unquote _  -> "unquote"@@ -300,6 +322,7 @@     pretty (TBind _ xs e) = fsep       [ prettyRelevance y         $ prettyHiding y parens+        $ prettyFiniteness (binderName $ namedArg y)         $ prettyCohesion y         $ prettyQuantity y         $ prettyTactic (binderName $ namedArg y) $@@ -386,128 +409,125 @@   pretty (DoLet _ ds) = "let" <+> vcat (fmap pretty ds)  instance Pretty Declaration where-    prettyList = vcat . map pretty-    pretty d =-        case d of-            TypeSig i tac x e ->-                sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ pretty x <+> ":"-                    , nest 2 $ pretty e-                    ]--            FieldSig inst tac x (Arg i e) ->-                mkInst inst $ mkOverlap i $-                prettyRelevance i $ prettyHiding i id $ prettyCohesion i $ prettyQuantity i $-                pretty $ TypeSig (setRelevance Relevant i) tac x e--                where--                  mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ]-                  mkInst NotInstanceDef  d = d--                  mkOverlap i d | isOverlappable i = "overlap" <+> d-                                | otherwise        = d+  prettyList = vcat . map pretty+  pretty = \case+    TypeSig i tac x e ->+      sep [ prettyTactic' tac $ prettyRelevance i $ prettyCohesion i $ prettyQuantity i $ pretty x <+> ":"+          , nest 2 $ pretty e+          ]+    FieldSig inst tac x (Arg i e) ->+      mkInst inst $ mkOverlap i $+      prettyRelevance i $ prettyHiding i id $ prettyCohesion i $ prettyQuantity i $+      pretty $ TypeSig (setRelevance Relevant i) tac x e+      where+        mkInst (InstanceDef _) d = sep [ "instance", nest 2 d ]+        mkInst NotInstanceDef  d = d -            Field _ fs ->-              sep [ "field"-                  , nest 2 $ vcat (map pretty fs)+        mkOverlap i d | isOverlappable i = "overlap" <+> d+                      | otherwise        = d+    Field _ fs ->+      sep [ "field"+          , nest 2 $ vcat (map pretty fs)+          ]+    FunClause lhs rhs wh _ ->+      sep [ pretty lhs+          , nest 2 $ pretty rhs+          ] $$ nest 2 (pretty wh)+    DataSig _ x tel e ->+      sep [ hsep  [ "data"+                  , pretty x+                  , fcat (map pretty tel)                   ]-            FunClause lhs rhs wh _ ->-                sep [ pretty lhs-                    , nest 2 $ pretty rhs-                    ] $$ nest 2 (pretty wh)-            DataSig _ x tel e ->-                sep [ hsep  [ "data"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ ":"-                            , pretty e-                            ]-                    ]-            Data _ x tel e cs ->-                sep [ hsep  [ "data"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ ":"-                            , pretty e-                            , "where"-                            ]-                    ] $$ nest 2 (vcat $ map pretty cs)-            DataDef _ x tel cs ->-                sep [ hsep  [ "data"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ "where"-                    ] $$ nest 2 (vcat $ map pretty cs)-            RecordSig _ x tel e ->-                sep [ hsep  [ "record"-                            , pretty x-                            , fcat (map pretty tel)-                            ]-                    , nest 2 $ hsep-                            [ ":"-                            , pretty e-                            ]-                    ]-            Record _ x dir tel e cs ->-              pRecord x dir tel (Just e) cs-            RecordDef _ x dir tel cs ->-              pRecord x dir tel Nothing cs-            RecordDirective r -> pRecordDirective r-            Infix f xs  ->-                pretty f <+> fsep (punctuate comma $ fmap pretty xs)-            Syntax n xs -> "syntax" <+> pretty n <+> "..."-            PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as)-                                     <+> "=" <+> pretty p-            Mutual _ ds     -> namedBlock "mutual" ds-            InterleavedMutual _ ds  -> namedBlock "interleaved mutual" ds-            LoneConstructor _ ds -> namedBlock "constructor" ds-            Abstract _ ds   -> namedBlock "abstract" ds-            Private _ _ ds  -> namedBlock "private" ds-            InstanceB _ ds  -> namedBlock "instance" ds-            Macro _ ds      -> namedBlock "macro" ds-            Postulate _ ds  -> namedBlock "postulate" ds-            Primitive _ ds  -> namedBlock "primitive" ds-            Generalize _ ds -> namedBlock "variable" ds-            Module _ x tel ds ->-                hsep [ "module"-                     , pretty x-                     , fcat (map pretty tel)-                     , "where"-                     ] $$ nest 2 (vcat $ map pretty ds)-            ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x ->-                sep [ pretty DoOpen-                    , nest 2 $ pretty e-                    , nest 4 $ pretty i-                    ]-            ModuleMacro _ x (SectionApp _ tel e) open i ->-                sep [ pretty open <+> "module" <+> pretty x <+> fcat (map pretty tel)-                    , nest 2 $ "=" <+> pretty e <+> pretty i-                    ]-            ModuleMacro _ x (RecordModuleInstance _ rec) open i ->-                sep [ pretty open <+> "module" <+> pretty x-                    , nest 2 $ "=" <+> pretty rec <+> "{{...}}"-                    ]-            Open _ x i  -> hsep [ "open", pretty x, pretty i ]-            Import _ x rn open i   ->-                hsep [ pretty open, "import", pretty x, as rn, pretty i ]-                where-                    as Nothing  = empty-                    as (Just x) = "as" <+> pretty (asName x)-            UnquoteDecl _ xs t ->-              sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]-            UnquoteDef _ xs t ->-              sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]-            Pragma pr   -> sep [ "{-#" <+> pretty pr, "#-}" ]-        where-            namedBlock s ds =-                sep [ text s-                    , nest 2 $ vcat $ map pretty ds-                    ]+          , nest 2 $ hsep+                  [ ":"+                  , pretty e+                  ]+          ]+    Data _ x tel e cs ->+      sep [ hsep  [ "data"+                  , pretty x+                  , fcat (map pretty tel)+                  ]+          , nest 2 $ hsep+                  [ ":"+                  , pretty e+                  , "where"+                  ]+          ] $$ nest 2 (vcat $ map pretty cs)+    DataDef _ x tel cs ->+      sep [ hsep  [ "data"+                  , pretty x+                  , fcat (map pretty tel)+                  ]+          , nest 2 $ "where"+          ] $$ nest 2 (vcat $ map pretty cs)+    RecordSig _ x tel e ->+      sep [ hsep  [ "record"+                  , pretty x+                  , fcat (map pretty tel)+                  ]+          , nest 2 $ hsep+                  [ ":"+                  , pretty e+                  ]+          ]+    Record _ x dir tel e cs ->+      pRecord x dir tel (Just e) cs+    RecordDef _ x dir tel cs ->+      pRecord x dir tel Nothing cs+    RecordDirective r -> pRecordDirective r+    Infix f xs  ->+      pretty f <+> fsep (punctuate comma $ fmap pretty xs)+    Syntax n xs -> "syntax" <+> pretty n <+> "..."+    PatternSyn _ n as p -> "pattern" <+> pretty n <+> fsep (map pretty as)+                             <+> "=" <+> pretty p+    Mutual _ ds     -> namedBlock "mutual" ds+    InterleavedMutual _ ds  -> namedBlock "interleaved mutual" ds+    LoneConstructor _ ds -> namedBlock "constructor" ds+    Abstract _ ds   -> namedBlock "abstract" ds+    Private _ _ ds  -> namedBlock "private" ds+    InstanceB _ ds  -> namedBlock "instance" ds+    Macro _ ds      -> namedBlock "macro" ds+    Postulate _ ds  -> namedBlock "postulate" ds+    Primitive _ ds  -> namedBlock "primitive" ds+    Generalize _ ds -> namedBlock "variable" ds+    Module _ x tel ds ->+      hsep [ "module"+           , pretty x+           , fcat (map pretty tel)+           , "where"+           ] $$ nest 2 (vcat $ map pretty ds)+    ModuleMacro _ x (SectionApp _ [] e) DoOpen i | isNoName x ->+      sep [ pretty DoOpen+          , nest 2 $ pretty e+          , nest 4 $ pretty i+          ]+    ModuleMacro _ x (SectionApp _ tel e) open i ->+      sep [ pretty open <+> "module" <+> pretty x <+> fcat (map pretty tel)+          , nest 2 $ "=" <+> pretty e <+> pretty i+          ]+    ModuleMacro _ x (RecordModuleInstance _ rec) open i ->+      sep [ pretty open <+> "module" <+> pretty x+          , nest 2 $ "=" <+> pretty rec <+> "{{...}}"+          ]+    Open _ x i  -> hsep [ "open", pretty x, pretty i ]+    Import _ x rn open i   ->+      hsep [ pretty open, "import", pretty x, as rn, pretty i ]+      where+        as Nothing  = empty+        as (Just x) = "as" <+> pretty (asName x)+    UnquoteDecl _ xs t ->+      sep [ "unquoteDecl" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+    UnquoteDef _ xs t ->+      sep [ "unquoteDef" <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+    UnquoteData _ x xs t ->+      sep [ "unquoteData" <+> pretty x <+> fsep (map pretty xs) <+> "=", nest 2 $ pretty t ]+    Pragma pr   -> sep [ "{-#" <+> pretty pr, "#-}" ]+    where+      namedBlock s ds =+          sep [ text s+              , nest 2 $ vcat $ map pretty ds+              ]  pHasEta0 :: HasEta0 -> Doc pHasEta0 = \case@@ -584,6 +604,8 @@       hsep $ ["INJECTIVE", pretty i]     pretty (InlinePragma _ True i) =       hsep $ ["INLINE", pretty i]+    pretty (NotProjectionLikePragma _ i) =+      hsep $ ["NOT_PROJECTION_LIKE", pretty i]     pretty (InlinePragma _ False i) =       hsep $ ["NOINLINE", pretty i]     pretty (ImpossiblePragma _ strs) =@@ -623,11 +645,11 @@     Unrelated  -> empty     Related{}  -> pretty ass <+> pretty level -instance Pretty GenPart where-    pretty (IdPart x)   = text $ rangedThing x-    pretty BindHole{}   = underscore-    pretty NormalHole{} = underscore-    pretty WildHole{}   = underscore+instance Pretty NotationPart where+    pretty (IdPart x) = text $ rangedThing x+    pretty HolePart{} = underscore+    pretty VarPart{}  = underscore+    pretty WildPart{} = underscore      prettyList = hcat . map pretty
src/full/Agda/Syntax/Fixity.hs view
@@ -5,8 +5,6 @@  import Control.DeepSeq -import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Syntax.Position@@ -21,7 +19,7 @@  -- | Decorating something with @Fixity'@. data ThingWithFixity x = ThingWithFixity x Fixity'-  deriving (Functor, Foldable, Traversable, Data, Show)+  deriving (Functor, Foldable, Traversable, Show)  instance LensFixity' (ThingWithFixity a) where   lensFixity' f (ThingWithFixity a fix') = ThingWithFixity a <$> f fix'@@ -32,7 +30,7 @@ -- | Do we prefer parens around arguments like @λ x → x@ or not? --   See 'lamBrackets'. data ParenPreference = PreferParen | PreferParenless-  deriving (Eq, Ord, Show, Data, Generic)+  deriving (Eq, Ord, Show, Generic)  instance NFData ParenPreference @@ -49,7 +47,7 @@                 | LeftOperandCtx Fixity | RightOperandCtx Fixity ParenPreference                 | FunctionCtx | ArgumentCtx ParenPreference | InsideOperandCtx                 | WithFunCtx | WithArgCtx | DotPatternCtx-    deriving (Show, Data, Eq, Generic)+    deriving (Show, Eq, Generic)  instance NFData Precedence
src/full/Agda/Syntax/Info.hs view
@@ -11,7 +11,6 @@  import Control.DeepSeq -import Data.Data (Data) import Data.Semigroup (Semigroup)  import GHC.Generics (Generic)@@ -36,7 +35,7 @@   , metaNumber         :: Maybe MetaId   , metaNameSuggestion :: String   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  emptyMetaInfo :: MetaInfo emptyMetaInfo = MetaInfo@@ -59,7 +58,7 @@  --------------------------------------------------------------------------}  newtype ExprInfo = ExprRange Range-  deriving (Data, Show, Eq, Null, NFData)+  deriving (Show, Eq, Null, NFData)  exprNoRange :: ExprInfo exprNoRange = ExprRange noRange@@ -80,7 +79,7 @@   , appOrigin :: Origin   , appParens :: ParenPreference -- ^ Do we prefer a lambda argument with or without parens?   }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Default is system inserted and prefer parens. defaultAppInfo :: Range -> AppInfo@@ -117,7 +116,7 @@   , minfoDirective :: Maybe ImportDirective     -- ^ Retained for @abstractToConcrete@ of 'ModuleMacro'.   }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  instance HasRange ModuleInfo where   getRange = minfoRange@@ -135,7 +134,7 @@ ---------------------------------------------------------------------------  newtype LetInfo = LetRange Range-  deriving (Data, Show, Eq, Null, NFData)+  deriving (Show, Eq, Null, NFData)  instance HasRange LetInfo where   getRange (LetRange r)   = r@@ -156,7 +155,7 @@   , defInfo     :: DeclInfo   , defTactic   :: Maybe t   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  mkDefInfo :: Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t mkDefInfo x f a ab r = mkDefInfoInstance x f a ab NotInstanceDef NotMacroDef r@@ -191,7 +190,7 @@   { declName  :: Name   , declRange :: Range   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  instance HasRange DeclInfo where   getRange = declRange@@ -214,7 +213,7 @@   , mutualPositivityCheck  :: PositivityCheck   , mutualRange            :: Range   }-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Default value for 'MutualInfo'. instance Null MutualInfo where@@ -235,7 +234,7 @@ data LHSInfo = LHSInfo   { lhsRange    :: Range   , lhsEllipsis :: ExpandedEllipsis-  } deriving (Data, Show, Eq, Generic)+  } deriving (Show, Eq, Generic)  instance HasRange LHSInfo where   getRange (LHSInfo r _) = r@@ -256,7 +255,7 @@ -- | For a general pattern we remember the source code position. newtype PatInfo   = PatRange Range-  deriving (Data, Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange,+  deriving (Eq, Null, Semigroup, Monoid, Show, SetRange, HasRange,             KillRange, NFData)  -- | Empty range for patterns.@@ -271,7 +270,7 @@   , conPatInfo     :: PatInfo   , conPatLazy     :: ConPatLazy   }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  instance HasRange ConPatInfo where   getRange = getRange . conPatInfo@@ -288,6 +287,6 @@ data ConPatLazy   = ConPatLazy   -- ^ Dotted constructor.   | ConPatEager  -- ^ Ordinary constructor.-  deriving (Data, Eq, Ord, Show, Bounded, Enum, Generic)+  deriving (Eq, Ord, Show, Bounded, Enum, Generic)  instance NFData ConPatLazy
src/full/Agda/Syntax/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE PatternSynonyms            #-}  module Agda.Syntax.Internal@@ -13,7 +14,7 @@ import Control.Monad.Identity import Control.DeepSeq -import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe import Data.Semigroup ( Semigroup, (<>), Sum(..) )@@ -21,7 +22,6 @@ import Data.Set (Set)  import Data.Traversable-import Data.Data (Data)  import GHC.Generics (Generic) @@ -65,34 +65,35 @@ --   'Arg' is used for actual arguments ('Var', 'Con', 'Def' etc.) --   and in 'Abstract' syntax and other situations. -----   [ cubical ] When @domFinite = True@ for the domain of a 'Pi'---   type, the elements should be compared by tabulating the domain type.---   Only supported in case the domain type is primIsOne, to obtain---   the correct equality for partial elements.+--   [ cubical ] When @annFinite (argInfoAnnotation domInfo) = True@ for+--   the domain of a 'Pi' type, the elements should be compared by+--   tabulating the domain type.  Only supported in case the domain type+--   is primIsOne, to obtain the correct equality for partial elements. -- data Dom' t e = Dom   { domInfo   :: ArgInfo-  , domFinite :: !Bool   , domName   :: Maybe NamedName  -- ^ e.g. @x@ in @{x = y : A} -> B@.+  , domIsFinite :: Bool+    -- ^ Is this a Π-type (False), or a partial type (True)?   , domTactic :: Maybe t        -- ^ "@tactic e".   , unDom     :: e-  } deriving (Data, Show, Functor, Foldable, Traversable)+  } deriving (Show, Functor, Foldable, Traversable)  type Dom = Dom' Term  instance Decoration (Dom' t) where-  traverseF f (Dom ai b x t a) = Dom ai b x t <$> f a+  traverseF f (Dom ai x t b a) = Dom ai x t b <$> f a  instance HasRange a => HasRange (Dom' t a) where   getRange = getRange . unDom  instance (KillRange t, KillRange a) => KillRange (Dom' t a) where-  killRange (Dom info b x t a) = killRange5 Dom info b x t a+  killRange (Dom info x t b a) = killRange4 Dom info x t b a  -- | Ignores 'Origin' and 'FreeVariables' and tactic. instance Eq a => Eq (Dom' t a) where-  Dom (ArgInfo h1 m1 _ _ a1) b1 s1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) b2 s2 _ x2 =-    (h1, m1, a1, b1, s1, x1) == (h2, m2, a2, b2, s2, x2)+  Dom (ArgInfo h1 m1 _ _ a1) s1 f1 _ x1 == Dom (ArgInfo h2 m2 _ _ a2) s2 f2 _ x2 =+    (h1, m1, a1, s1, f1, x1) == (h2, m2, a2, s2, f2, x2)  instance LensNamed (Dom' t e) where   type NameOf (Dom' t e) = NamedName@@ -129,10 +130,10 @@ -- often for class AddContext.  domFromArg :: Arg a -> Dom a-domFromArg (Arg i a) = Dom i False Nothing Nothing a+domFromArg (Arg i a) = Dom i Nothing False Nothing a  domFromNamedArg :: NamedArg a -> Dom a-domFromNamedArg (Arg i a) = Dom i False (nameOf a) Nothing (namedThing a)+domFromNamedArg (Arg i a) = Dom i (nameOf a) False Nothing (namedThing a)  defaultDom :: a -> Dom a defaultDom = defaultArgDom defaultArgInfo@@ -151,7 +152,7 @@ data DataOrRecord   = IsData   | IsRecord PatternOrCopattern-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Store the names of the record fields in the constructor. --   This allows reduction of projection redexes outside of TCM.@@ -163,7 +164,7 @@   , conFields     :: [Arg QName]   -- ^ The name of the record fields.       --   'Arg' is stored since the info in the constructor args       --   might not be accurate because of subtyping (issue #2170).-  } deriving (Data, Show, Generic)+  } deriving (Show, Generic)  instance Eq ConHead where   (==) = (==) `on` conName@@ -225,7 +226,7 @@             --   where they can affect type checking, so syntactic checks are free to ignore the             --   eliminators, which are only there to ease debugging when a dummy term incorrectly             --   leaks into a relevant position.-  deriving (Data, Show)+  deriving Show  type ConInfo = ConOrigin @@ -242,7 +243,7 @@                -- ^ The body has (at least) one free variable.                --   Danger: 'unAbs' doesn't shift variables properly            | NoAbs { absName :: ArgName, unAbs :: a }-  deriving (Data, Functor, Foldable, Traversable, Generic)+  deriving (Functor, Foldable, Traversable, Generic)  instance Decoration Abs where   traverseF f (Abs   x a) = Abs   x <$> f a@@ -251,7 +252,7 @@ -- | Types are terms with a sort annotation. -- data Type'' t a = El { _getSort :: Sort' t, unEl :: a }-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Show, Functor, Foldable, Traversable)  type Type' a = Type'' Term a @@ -284,22 +285,23 @@ --   and so on. data Tele a = EmptyTel             | ExtendTel a (Abs (Tele a))  -- ^ 'Abs' is never 'NoAbs'.-  deriving (Data, Show, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  type Telescope = Tele (Dom Type)  data IsFibrant = IsFibrant | IsStrict-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Sorts. -- data Sort' t   = Type (Level' t)  -- ^ @Set ℓ@.   | Prop (Level' t)  -- ^ @Prop ℓ@.-  | Inf IsFibrant Integer      -- ^ @Setωᵢ@.+  | Inf IsFibrant !Integer      -- ^ @Setωᵢ@.   | SSet (Level' t)  -- ^ @SSet ℓ@.   | SizeUniv    -- ^ @SizeUniv@, a sort inhabited by type @Size@.   | LockUniv    -- ^ @LockUniv@, a sort for locks.+  | IntervalUniv -- ^ @IntervalUniv@, a sort inhabited by the cubical interval.   | PiSort (Dom' t t) (Sort' t) (Abs (Sort' t)) -- ^ Sort of the pi type.   | FunSort (Sort' t) (Sort' t) -- ^ Sort of a (non-dependent) function type.   | UnivSort (Sort' t) -- ^ Sort of another sort.@@ -310,19 +312,19 @@     --   Replaces the abuse of @Prop@ for a dummy sort.     --   The @String@ typically describes the location where we create this dummy,     --   but can contain other information as well.-  deriving (Data, Show)+  deriving Show  type Sort = Sort' Term  -- | A level is a maximum expression of a closed level and 0..n --   'PlusLevel' expressions each of which is an atom plus a number.-data Level' t = Max Integer [PlusLevel' t]-  deriving (Show, Data, Functor, Foldable, Traversable)+data Level' t = Max !Integer [PlusLevel' t]+  deriving (Show, Functor, Foldable, Traversable)  type Level = Level' Term -data PlusLevel' t = Plus Integer t-  deriving (Show, Data, Functor, Foldable, Traversable)+data PlusLevel' t = Plus !Integer t+  deriving (Show, Functor, Foldable, Traversable)  type PlusLevel = PlusLevel' Term type LevelAtom = Term@@ -333,7 +335,7 @@  -- | Newtypes for terms that produce a dummy, rather than crash, when --   applied to incompatible eliminations.-newtype BraveTerm = BraveTerm { unBrave :: Term } deriving (Data, Show)+newtype BraveTerm = BraveTerm { unBrave :: Term } deriving Show  --------------------------------------------------------------------------- -- * Blocked Terms@@ -366,21 +368,21 @@ --  For the purpose of the permutation and the body dot patterns count --  as variables. TODO: Change this! data Clause = Clause-    { clauseLHSRange  :: Range-    , clauseFullRange :: Range-    , clauseTel       :: Telescope+    { clauseLHSRange    :: Range+    , clauseFullRange   :: Range+    , clauseTel         :: Telescope       -- ^ @Δ@: The types of the pattern variables in dependency order.-    , namedClausePats :: NAPs+    , namedClausePats   :: NAPs       -- ^ @Δ ⊢ ps@.  The de Bruijn indices refer to @Δ@.-    , clauseBody      :: Maybe Term+    , clauseBody        :: Maybe Term       -- ^ @Just v@ with @Δ ⊢ v@ for a regular clause, or @Nothing@ for an       --   absurd one.-    , clauseType      :: Maybe (Arg Type)+    , clauseType        :: Maybe (Arg Type)       -- ^ @Δ ⊢ t@.  The type of the rhs under @clauseTel@.       --   Used, e.g., by @TermCheck@.       --   Can be 'Irrelevant' if we encountered an irrelevant projection       --   pattern on the lhs.-    , clauseCatchall  :: Bool+    , clauseCatchall    :: Bool       -- ^ Clause has been labelled as CATCHALL.     , clauseExact       :: Maybe Bool       -- ^ Pattern matching of this clause is exact, no catch-all case.@@ -400,10 +402,12 @@       --   @Nothing@ means coverage checker has not run yet (clause may be unreachable).       --   @Just False@ means clause is not unreachable.       --   @Just True@ means clause is unreachable.-    , clauseEllipsis  :: ExpandedEllipsis+    , clauseEllipsis    :: ExpandedEllipsis       -- ^ Was this clause created by expansion of an ellipsis?+    , clauseWhereModule :: Maybe ModuleName+      -- ^ Keeps track of the module name associate with the clause's where clause.     }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  clausePats :: Clause -> [Arg DeBruijnPattern] clausePats = map (fmap namedThing) . namedClausePats@@ -423,7 +427,7 @@ data PatternInfo = PatternInfo   { patOrigin :: PatOrigin   , patAsNames :: [Name]-  } deriving (Data, Show, Eq, Generic)+  } deriving (Show, Eq, Generic)  defaultPatternInfo :: PatternInfo defaultPatternInfo = PatternInfo PatOSystem []@@ -439,7 +443,7 @@   | PatORec            -- ^ User wrote a record pattern   | PatOLit            -- ^ User wrote a literal pattern   | PatOAbsurd         -- ^ User wrote an absurd pattern-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  -- | Patterns are variables, constructors, or wildcards. --   @QName@ is used in @ConP@ rather than @Name@ since@@ -463,7 +467,7 @@     -- ^ Path elimination pattern, like @VarP@ but keeps track of endpoints.   | DefP PatternInfo QName [NamedArg (Pattern' x)]     -- ^ Used for HITs, the QName should be the one from primHComp.-  deriving (Data, Show, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  type Pattern = Pattern' PatVarName     -- ^ The @PatVarName@ is a name suggestion.@@ -480,8 +484,8 @@ -- | Type used when numbering pattern variables. data DBPatVar = DBPatVar   { dbPatVarName  :: PatVarName-  , dbPatVarIndex :: Int-  } deriving (Data, Show, Eq, Generic)+  , dbPatVarIndex :: !Int+  } deriving (Show, Eq, Generic)  type DeBruijnPattern = Pattern' DBPatVar @@ -528,7 +532,7 @@     --   variables they bind are unused. The GHC backend compiles lazy matches     --   to lazy patterns in Haskell (TODO: not yet).   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  noConPatternInfo :: ConPatternInfo noConPatternInfo = ConPatternInfo defaultPatternInfo False False Nothing False@@ -648,14 +652,16 @@     --     Γ ⊢ u :# ρ : Δ, A     --   @ -  | Strengthen Impossible (Substitution' a)+  | Strengthen Impossible !Int (Substitution' a)     -- ^ Strengthening substitution.  First argument is @__IMPOSSIBLE__@.-    --   Apply this to a term which does not contain variable 0-    --   to lower all de Bruijn indices by one.-    --   @-    --             Γ ⊢ ρ : Δ+    --   In @'Strengthen err n ρ@ the number @n@ must be non-negative.+    --   This substitution should only be applied to values @t@ for+    --   which none of the variables @0@ up to @n - 1@ are free in+    --   @t[ρ]@, and in that case @n@ is subtracted from all free de+    --   Bruijn indices in @t[ρ]@.+    --        Γ ⊢ ρ : Δ    |Θ| = n     --     ----------------------------    --     Γ ⊢ Strengthen ρ : Δ, A+    --     Γ ⊢ Strengthen n ρ : Δ, Θ     --   @    | Wk !Int (Substitution' a)@@ -701,17 +707,35 @@ -- | View type as equality type.  data EqualityView-  = EqualityType-    { eqtSort  :: Sort     -- ^ Sort of this type.-    , eqtName  :: QName    -- ^ Builtin EQUALITY.-    , eqtParams :: [Arg Term] -- ^ Hidden.  Empty or @Level@.-    , eqtType  :: Arg Term -- ^ Hidden-    , eqtLhs   :: Arg Term -- ^ NotHidden-    , eqtRhs   :: Arg Term -- ^ NotHidden-    }+  = EqualityViewType EqualityTypeData   | OtherType Type -- ^ reduced   | IdiomType Type -- ^ reduced +data EqualityTypeData = EqualityTypeData+    { _eqtSort   :: Sort        -- ^ Sort of this type.+    , _eqtName   :: QName       -- ^ Builtin EQUALITY.+    , _eqtParams :: Args        -- ^ Hidden.  Empty or @Level@.+    , _eqtType   :: Arg Term    -- ^ Hidden.+    , _eqtLhs    :: Arg Term    -- ^ NotHidden.+    , _eqtRhs    :: Arg Term    -- ^ NotHidden.+    }++pattern EqualityType+  :: Sort+  -> QName+  -> Args+  -> Arg Term+  -> Arg Term+  -> Arg Term+  -> EqualityView+pattern EqualityType{ eqtSort, eqtName, eqtParams, eqtType, eqtLhs, eqtRhs } =+  EqualityViewType (EqualityTypeData eqtSort eqtName eqtParams eqtType eqtLhs eqtRhs)++-- The COMPLETE pragma is new in GHC 8.2+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE EqualityType, OtherType, IdiomType #-}+#endif+ isEqualityType :: EqualityView -> Bool isEqualityType EqualityType{} = True isEqualityType OtherType{}    = False@@ -1022,10 +1046,6 @@     MetaV x es -> Just (MetaV x, es)     Con{}      -> Nothing     Lit{}      -> Nothing-    -- Andreas, 2016-04-13, Issue 1932: We convert λ x → x .f  into f-    Lam h (Abs _ v) | visible h -> case v of-      Var 0 [Proj _o f] -> Just (Def f, [])-      _ -> Nothing     Lam{}      -> Nothing     Pi{}       -> Nothing     Sort{}     -> Nothing@@ -1045,11 +1065,12 @@ -- | A 'null' clause is one with no patterns and no rhs. --   Should not exist in practice. instance Null Clause where-  empty = Clause empty empty empty empty empty empty False Nothing Nothing Nothing empty-  null (Clause _ _ tel pats body _ _ _ _ _ _)+  empty = Clause empty empty empty empty empty empty False Nothing Nothing Nothing empty empty+  null (Clause _ _ tel pats body _ _ _ _ _ _ wm)     =  null tel     && null pats     && null body+    && null wm   ---------------------------------------------------------------------------@@ -1120,6 +1141,7 @@     SSet l    -> 1 + tsize l     SizeUniv  -> 1     LockUniv  -> 1+    IntervalUniv -> 1     PiSort a s1 s2 -> 1 + tsize a + tsize s1 + tsize s2     FunSort s1 s2 -> 1 + tsize s1 + tsize s2     UnivSort s -> 1 + tsize s@@ -1134,12 +1156,12 @@   tsize (Plus _ a)      = tsize a  instance TermSize a => TermSize (Substitution' a) where-  tsize IdS                = 1-  tsize (EmptyS _)         = 1-  tsize (Wk _ rho)         = 1 + tsize rho-  tsize (t :# rho)         = 1 + tsize t + tsize rho-  tsize (Strengthen _ rho) = 1 + tsize rho-  tsize (Lift _ rho)       = 1 + tsize rho+  tsize IdS                  = 1+  tsize (EmptyS _)           = 1+  tsize (Wk _ rho)           = 1 + tsize rho+  tsize (t :# rho)           = 1 + tsize t + tsize rho+  tsize (Strengthen _ _ rho) = 1 + tsize rho+  tsize (Lift _ rho)         = 1 + tsize rho  --------------------------------------------------------------------------- -- * KillRange instances.@@ -1179,6 +1201,7 @@     Inf f n    -> Inf f n     SizeUniv   -> SizeUniv     LockUniv   -> LockUniv+    IntervalUniv -> IntervalUniv     Type a     -> killRange1 Type a     Prop a     -> killRange1 Prop a     SSet a     -> killRange1 SSet a@@ -1190,12 +1213,12 @@     s@DummyS{} -> s  instance KillRange Substitution where-  killRange IdS                  = IdS-  killRange (EmptyS err)         = EmptyS err-  killRange (Wk n rho)           = killRange1 (Wk n) rho-  killRange (t :# rho)           = killRange2 (:#) t rho-  killRange (Strengthen err rho) = killRange1 (Strengthen err) rho-  killRange (Lift n rho)         = killRange1 (Lift n) rho+  killRange IdS                    = IdS+  killRange (EmptyS err)           = EmptyS err+  killRange (Wk n rho)             = killRange1 (Wk n) rho+  killRange (t :# rho)             = killRange2 (:#) t rho+  killRange (Strengthen err n rho) = killRange1 (Strengthen err n) rho+  killRange (Lift n rho)           = killRange1 (Lift n) rho  instance KillRange PatOrigin where   killRange = id@@ -1221,8 +1244,8 @@       DefP o q ps      -> killRange2 (DefP o) q ps  instance KillRange Clause where-  killRange (Clause rl rf tel ps body t catchall exact recursive unreachable ell) =-    killRange10 Clause rl rf tel ps body t catchall exact recursive unreachable ell+  killRange (Clause rl rf tel ps body t catchall exact recursive unreachable ell wm) =+    killRange11 Clause rl rf tel ps body t catchall exact recursive unreachable ell wm  instance KillRange a => KillRange (Tele a) where   killRange = fmap killRange@@ -1241,12 +1264,16 @@   prettyPrec = pr     where     pr p rho = case rho of-      IdS              -> "idS"-      EmptyS err       -> "emptyS"-      t :# rho         -> mparens (p > 2) $ sep [ pr 2 rho <> ",", prettyPrec 3 t ]-      Strengthen _ rho -> mparens (p > 9) $ "strS" <+> pr 10 rho-      Wk n rho         -> mparens (p > 9) $ text ("wkS " ++ show n) <+> pr 10 rho-      Lift n rho       -> mparens (p > 9) $ text ("liftS " ++ show n) <+> pr 10 rho+      IdS                -> "idS"+      EmptyS err         -> "emptyS"+      t :# rho           -> mparens (p > 2) $+                            sep [ pr 2 rho <> ",", prettyPrec 3 t ]+      Strengthen _ n rho -> mparens (p > 9) $+                            text ("strS " ++ show n) <+> pr 10 rho+      Wk n rho           -> mparens (p > 9) $+                            text ("wkS " ++ show n) <+> pr 10 rho+      Lift n rho         -> mparens (p > 9) $+                            text ("liftS " ++ show n) <+> pr 10 rho  instance Pretty Term where   prettyPrec p v =@@ -1338,10 +1365,10 @@       SSet l -> mparens (p > 9) $ "SSet" <+> prettyPrec 10 l       SizeUniv -> "SizeUniv"       LockUniv -> "LockUniv"+      IntervalUniv -> "IntervalUniv"       PiSort a s1 s2 -> mparens (p > 9) $-        "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a))-                      <+> parens (sep [ text ("λ " ++ absName s2 ++ " ->")-                                      , nest 2 $ pretty (unAbs s2) ])+        "piSort" <+> pDom (domInfo a) (text (absName s2) <+> ":" <+> pretty (unDom a) <+> ":" <+> pretty s1)+                      <+> parens (pretty (unAbs s2))       FunSort a b -> mparens (p > 9) $         "funSort" <+> prettyPrec 10 a <+> prettyPrec 10 b       UnivSort s -> mparens (p > 9) $ "univSort" <+> prettyPrec 10 s@@ -1380,6 +1407,10 @@   prettyPrec n (IApplyP _o _ _ x) = prettyPrec n x --  prettyPrec n (IApplyP _o u0 u1 x) = text "@[" <> prettyPrec 0 u0 <> text ", " <> prettyPrec 0 u1 <> text "]" <> prettyPrec n x +instance Pretty a => Pretty (Blocked a) where+  pretty (Blocked x a) = ("[" <+> pretty a <+> "]") <> pretty x+  pretty (NotBlocked _ x) = pretty x+ ----------------------------------------------------------------------------- -- * NFData instances -----------------------------------------------------------------------------@@ -1411,6 +1442,7 @@     SSet l   -> rnf l     SizeUniv -> ()     LockUniv -> ()+    IntervalUniv -> ()     PiSort a b c -> rnf (a, b, unAbs c)     FunSort a b -> rnf (a, b)     UnivSort a -> rnf a@@ -1425,7 +1457,7 @@   rnf (Plus n l) = rnf (n, l)  instance NFData e => NFData (Dom e) where-  rnf (Dom a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e+  rnf (Dom a c d e f) = rnf a `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f  instance NFData DataOrRecord instance NFData ConHead
src/full/Agda/Syntax/Internal/Blockers.hs view
@@ -3,7 +3,6 @@  import Control.DeepSeq -import Data.Data (Data) import Data.Set (Set) import qualified Data.Set as Set import Data.Semigroup@@ -11,6 +10,7 @@ import GHC.Generics (Generic)  import Agda.Syntax.Common+import Agda.Syntax.Abstract.Name (QName) import Agda.Syntax.Internal.Elim  import Agda.Utils.Pretty hiding ((<>))@@ -30,8 +30,8 @@     -- ^ Not enough arguments were supplied to complete the matching.   | AbsurdMatch     -- ^ We matched an absurd clause, results in a neutral 'Def'.-  | MissingClauses-    -- ^ We ran out of clauses, all considered clauses+  | MissingClauses QName+    -- ^ We ran out of clauses for 'QName', all considered clauses     --   produced an actual mismatch.     --   This can happen when try to reduce a function application     --   but we are still missing some function clauses.@@ -39,7 +39,7 @@   | ReallyNotBlocked     -- ^ Reduction was not blocked, we reached a whnf     --   which can be anything but a stuck @'Def'@.-  deriving (Show, Data, Generic)+  deriving (Show, Generic)  -- | 'ReallyNotBlocked' is the unit. --   'MissingClauses' is dominant.@@ -47,8 +47,8 @@ instance Semigroup (NotBlocked' t) where   ReallyNotBlocked <> b = b   -- MissingClauses is dominant (absorptive)-  b@MissingClauses <> _ = b-  _ <> b@MissingClauses = b+  b@MissingClauses{} <> _ = b+  _ <> b@MissingClauses{} = b   -- StuckOn is second strongest   b@StuckOn{}      <> _ = b   _ <> b@StuckOn{}      = b@@ -67,7 +67,8 @@              | UnblockOnAny (Set Blocker)              | UnblockOnMeta MetaId     -- ^ Unblock if meta is instantiated              | UnblockOnProblem ProblemId-  deriving (Data, Show, Eq, Ord, Generic)+             | UnblockOnDef QName       -- ^ Unblock when function is defined+  deriving (Show, Eq, Ord, Generic)  instance NFData Blocker @@ -101,12 +102,18 @@ unblockOnEither :: Blocker -> Blocker -> Blocker unblockOnEither a b = unblockOnAny $ Set.fromList [a, b] +unblockOnBoth :: Blocker -> Blocker -> Blocker+unblockOnBoth a b = unblockOnAll $ Set.fromList [a, b]+ unblockOnMeta :: MetaId -> Blocker unblockOnMeta = UnblockOnMeta  unblockOnProblem :: ProblemId -> Blocker unblockOnProblem = UnblockOnProblem +unblockOnDef :: QName -> Blocker+unblockOnDef = UnblockOnDef+ unblockOnAllMetas :: Set MetaId -> Blocker unblockOnAllMetas = unblockOnAll . Set.mapMonotonic unblockOnMeta @@ -118,39 +125,52 @@ onBlockingMetasM f (UnblockOnAny bs)    = unblockOnAny . Set.fromList <$> mapM (onBlockingMetasM f) (Set.toList bs) onBlockingMetasM f (UnblockOnMeta x)    = f x onBlockingMetasM f b@UnblockOnProblem{} = pure b+onBlockingMetasM f b@UnblockOnDef{}     = pure b  allBlockingMetas :: Blocker -> Set MetaId allBlockingMetas (UnblockOnAll us)  = Set.unions $ map allBlockingMetas $ Set.toList us allBlockingMetas (UnblockOnAny us)  = Set.unions $ map allBlockingMetas $ Set.toList us allBlockingMetas (UnblockOnMeta x)  = Set.singleton x allBlockingMetas UnblockOnProblem{} = Set.empty+allBlockingMetas UnblockOnDef{}     = Set.empty  allBlockingProblems :: Blocker -> Set ProblemId allBlockingProblems (UnblockOnAll us)    = Set.unions $ map allBlockingProblems $ Set.toList us allBlockingProblems (UnblockOnAny us)    = Set.unions $ map allBlockingProblems $ Set.toList us allBlockingProblems UnblockOnMeta{}      = Set.empty allBlockingProblems (UnblockOnProblem p) = Set.singleton p+allBlockingProblems UnblockOnDef{}       = Set.empty --- Note: We pick the All rather than the Any as the semigroup instance.+allBlockingDefs :: Blocker -> Set QName+allBlockingDefs (UnblockOnAll us)  = Set.unions $ map allBlockingDefs $ Set.toList us+allBlockingDefs (UnblockOnAny us)  = Set.unions $ map allBlockingDefs $ Set.toList us+allBlockingDefs UnblockOnMeta{}    = Set.empty+allBlockingDefs UnblockOnProblem{} = Set.empty+allBlockingDefs (UnblockOnDef q)   = Set.singleton q++{- There are two possible instances of Semigroup, so we don't commit+   to either one. instance Semigroup Blocker where   x <> y = unblockOnAll $ Set.fromList [x, y]  instance Monoid Blocker where   mempty = alwaysUnblock   mappend = (<>)+-}  instance Pretty Blocker where   pretty (UnblockOnAll us)      = "all" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us)   pretty (UnblockOnAny us)      = "any" <> parens (fsep $ punctuate "," $ map pretty $ Set.toList us)   pretty (UnblockOnMeta m)      = pretty m   pretty (UnblockOnProblem pid) = "problem" <+> pretty pid+  pretty (UnblockOnDef q)       = "definition" <+> pretty q  -- | Something where a meta variable may block reduction. Notably a top-level meta is considered --   blocking. This did not use to be the case (pre Aug 2020). data Blocked' t a   = Blocked    { theBlocker      :: Blocker,       ignoreBlocking :: a }   | NotBlocked { blockingStatus  :: NotBlocked' t, ignoreBlocking :: a }-  deriving (Data, Show, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  instance Decoration (Blocked' t) where   traverseF f (Blocked b x)     = Blocked b <$> f x@@ -162,7 +182,7 @@   f <*> e = ((f $> ()) `mappend` (e $> ())) $> ignoreBlocking f (ignoreBlocking e)  instance Semigroup a => Semigroup (Blocked' t a) where-  Blocked x a    <> Blocked y b    = Blocked (x <> y) (a <> b)+  Blocked x a    <> Blocked y b    = Blocked (unblockOnBoth x y) (a <> b)   b@Blocked{}    <> NotBlocked{}   = b   NotBlocked{}   <> b@Blocked{}    = b   NotBlocked x a <> NotBlocked y b = NotBlocked (x <> y) (a <> b)@@ -198,10 +218,9 @@ --   (Missing ordinary pattern would mean the @e@ is of function type, --   but we cannot match against something of function type.) stuckOn :: Elim' t -> NotBlocked' t -> NotBlocked' t-stuckOn e r =-  case r of-    MissingClauses   -> r-    StuckOn{}        -> r+stuckOn e = \case+    r@MissingClauses{} -> r+    r@StuckOn{}        -> r     Underapplied     -> r'     AbsurdMatch      -> r'     ReallyNotBlocked -> r'@@ -227,6 +246,10 @@ notBlocked_ :: Blocked' t () notBlocked_ = notBlocked () +getBlocker :: Blocked' t a -> Blocker+getBlocker (Blocked b _) = b+getBlocker NotBlocked{}  = neverUnblock+ ----------------------------------------------------------------------------- -- * Waking up logic -----------------------------------------------------------------------------@@ -256,10 +279,18 @@   where     u' = unblockMeta x u +wakeIfBlockedOnDef :: QName -> Blocker -> WakeUp+wakeIfBlockedOnDef q u+  | u' == alwaysUnblock = WakeUp+  | otherwise           = DontWakeUp (Just u')+  where+    u' = unblockDef q u+ unblockMeta :: MetaId -> Blocker -> Blocker unblockMeta x u@(UnblockOnMeta y) | x == y    = alwaysUnblock                                   | otherwise = u unblockMeta _ u@UnblockOnProblem{} = u+unblockMeta _ u@UnblockOnDef{}     = u unblockMeta x (UnblockOnAll us)    = unblockOnAll $ Set.map (unblockMeta x) us unblockMeta x (UnblockOnAny us)    = unblockOnAny $ Set.map (unblockMeta x) us @@ -267,5 +298,14 @@ unblockProblem p u@(UnblockOnProblem q) | p == q    = alwaysUnblock                                         | otherwise = u unblockProblem _ u@UnblockOnMeta{} = u+unblockProblem _ u@UnblockOnDef{}  = u unblockProblem p (UnblockOnAll us) = unblockOnAll $ Set.map (unblockProblem p) us unblockProblem p (UnblockOnAny us) = unblockOnAny $ Set.map (unblockProblem p) us++unblockDef :: QName -> Blocker -> Blocker+unblockDef q u@(UnblockOnDef q') | q == q'   = alwaysUnblock+                                 | otherwise = u+unblockDef q u@UnblockOnMeta{} = u+unblockDef q u@UnblockOnProblem{} = u+unblockDef q (UnblockOnAll us) = unblockOnAll $ Set.map (unblockDef q) us+unblockDef q (UnblockOnAny us) = unblockOnAny $ Set.map (unblockDef q) us
src/full/Agda/Syntax/Internal/Defs.hs view
@@ -81,6 +81,7 @@     SSet l    -> getDefs l     SizeUniv  -> return ()     LockUniv  -> return ()+    IntervalUniv -> return ()     PiSort a s1 s2 -> getDefs a >> getDefs s1 >> getDefs s2     FunSort s1 s2 -> getDefs s1 >> getDefs s2     UnivSort s  -> getDefs s@@ -105,3 +106,11 @@  instance (GetDefs a, GetDefs b) => GetDefs (a,b) where   getDefs (a,b) = getDefs a >> getDefs b++instance GetDefs Telescope where+  getDefs = getDefs . telToList++-- no defs here++instance {-# OVERLAPPING #-} GetDefs String where+  getDefs _ = return ()
src/full/Agda/Syntax/Internal/Elim.hs view
@@ -2,7 +2,6 @@ module Agda.Syntax.Internal.Elim where  import Control.DeepSeq-import Data.Data (Data)  import Agda.Syntax.Common import Agda.Syntax.Concrete.Pretty () -- Pretty Arg instance@@ -20,7 +19,7 @@   = Apply (Arg a)         -- ^ Application.   | Proj ProjOrigin QName -- ^ Projection.  'QName' is name of a record projection.   | IApply a a a -- ^ IApply x y r, x and y are the endpoints-  deriving (Data, Show, Functor, Foldable, Traversable)+  deriving (Show, Functor, Foldable, Traversable)  -- | This instance cheats on 'Proj', use with care. --   'Proj's are always assumed to be 'UserWritten', since they have no 'ArgInfo'.@@ -42,6 +41,13 @@ isApplyElim' :: Empty -> Elim' a -> Arg a isApplyElim' e = fromMaybe (absurd e) . isApplyElim +-- | Only 'Apply' variant.+isProperApplyElim :: Elim' a -> Bool+isProperApplyElim = \case+  Apply _  -> True+  IApply{} -> False+  Proj{}   -> False+ -- | Drop 'Apply' constructors. (Safe) allApplyElims :: [Elim' a] -> Maybe [Arg a] allApplyElims = mapM isApplyElim@@ -80,4 +86,3 @@   rnf (Apply x) = rnf x   rnf Proj{}    = ()   rnf (IApply x y r) = rnf x `seq` rnf y `seq` rnf r-
src/full/Agda/Syntax/Internal/Generic.hs view
@@ -96,7 +96,7 @@     t@Lit{}     -> f t     Sort s      -> f =<< Sort <$> traverseTermM f s     DontCare mv -> f =<< DontCare <$> traverseTermM f mv-    t@Dummy{}   -> f t+    Dummy s xs  -> f =<< Dummy s <$> traverseTermM f xs    foldTerm f t = f t `mappend` case t of     Var i xs    -> foldTerm f xs@@ -109,7 +109,7 @@     Lit _       -> mempty     Sort s      -> foldTerm f s     DontCare mv -> foldTerm f mv-    Dummy{}     -> mempty+    Dummy _ xs  -> foldTerm f xs  instance TermLike Level where   traverseTermM f (Max n as) = Max n <$> traverseTermM f as@@ -131,12 +131,13 @@     SSet l     -> SSet <$> traverseTermM f l     s@SizeUniv -> pure s     s@LockUniv -> pure s+    s@IntervalUniv -> pure s     PiSort a b c -> PiSort   <$> traverseTermM f a <*> traverseTermM f b <*> traverseTermM f c     FunSort a b -> FunSort   <$> traverseTermM f a <*> traverseTermM f b     UnivSort a -> UnivSort <$> traverseTermM f a     MetaS x es -> MetaS x  <$> traverseTermM f es     DefS q es  -> DefS q   <$> traverseTermM f es-    s@DummyS{} -> pure s+    s@(DummyS _) -> pure s    foldTerm f = \case     Type l     -> foldTerm f l@@ -145,12 +146,13 @@     SSet l     -> foldTerm f l     SizeUniv   -> mempty     LockUniv   -> mempty+    IntervalUniv -> mempty     PiSort a b c -> foldTerm f a <> foldTerm f b <> foldTerm f c     FunSort a b -> foldTerm f a <> foldTerm f b     UnivSort a -> foldTerm f a     MetaS _ es -> foldTerm f es     DefS _ es  -> foldTerm f es-    DummyS{}   -> mempty+    DummyS _   -> mempty  instance TermLike EqualityView where
src/full/Agda/Syntax/Internal/MetaVars.hs view
@@ -23,13 +23,18 @@ instance AllMetas Type instance TermLike a => AllMetas (Elim' a) instance TermLike a => AllMetas (Tele a)-instance TermLike a => AllMetas (Dom a) +instance (AllMetas a, AllMetas b) => AllMetas (Dom' a b) where+  allMetas f (Dom _ _ _ t e) = allMetas f t <> allMetas f e+ -- These types need to be packed up as a Term to get the metas. instance AllMetas Sort      where allMetas f   = allMetas f . Sort instance AllMetas Level     where allMetas f   = allMetas f . Level instance AllMetas PlusLevel where allMetas f l = allMetas f (Max 0 [l]) +instance {-# OVERLAPPING #-} AllMetas String where+  allMetas f _ = mempty+ -- Generic instances instance (AllMetas a, AllMetas b) => AllMetas (a, b) where   allMetas f (x, y) = allMetas f x <> allMetas f y@@ -57,6 +62,7 @@   sortMetas Inf{}         = mempty   sortMetas SizeUniv{}    = mempty   sortMetas LockUniv{}    = mempty+  sortMetas IntervalUniv{} = mempty   sortMetas (PiSort _ s1 s2)  = sortMetas s1 <> sortMetas (unAbs s2)  -- the domain is a term so is covered by the fold   sortMetas (FunSort a b) = sortMetas a <> sortMetas b   sortMetas (UnivSort s)  = sortMetas s
src/full/Agda/Syntax/Internal/Names.hs view
@@ -1,9 +1,9 @@---- | Extract all names from things.+-- | Extract all names and meta-variables from things.  module Agda.Syntax.Internal.Names where -import Data.List.NonEmpty (NonEmpty(..))+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap import Data.Map (Map) import Data.Set (Set) @@ -12,206 +12,376 @@ import Agda.Syntax.Internal import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Treeless  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.CompiledClause +import Agda.Utils.List1 (List1)+import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Singleton import Agda.Utils.Impossible +-- | Some or all of the 'QName's that can be found in the given thing.+ namesIn :: (NamesIn a, Collection QName m) => a -> m namesIn = namesIn' singleton +-- | Some or all of the 'QName's that can be found in the given thing.++namesIn' :: (NamesIn a, Monoid m) => (QName -> m) -> a -> m+namesIn' f = namesAndMetasIn' (either f mempty)++-- | Some or all of the meta-variables that can be found in the given+-- thing.++metasIn :: (NamesIn a, Collection MetaId m) => a -> m+metasIn = metasIn' singleton++-- | Some or all of the meta-variables that can be found in the given+-- thing.++-- TODO: Does this function make+-- Agda.Syntax.Internal.MetaVars.allMetas superfluous? Maybe not,+-- allMetas ignores the first argument of PiSort.++metasIn' :: (NamesIn a, Monoid m) => (MetaId -> m) -> a -> m+metasIn' f = namesAndMetasIn' (either mempty f)++-- | Some or all of the names and meta-variables that can be found in+-- the given thing.++namesAndMetasIn ::+  (NamesIn a, Collection QName m1, Collection MetaId m2) =>+  a -> (m1, m2)+namesAndMetasIn =+  namesAndMetasIn'+    (either (\x -> (singleton x, mempty))+            (\m -> (mempty, singleton m)))+ class NamesIn a where-  namesIn' :: Monoid m => (QName -> m) -> a -> m+  -- | Some or all of the names and meta-variables that can be found+  -- in the given thing.+  namesAndMetasIn' :: Monoid m => (Either QName MetaId -> m) -> a -> m -  default namesIn' :: (Monoid m, Foldable f, NamesIn b, f b ~ a) => (QName -> m) -> a -> m-  namesIn' = foldMap . namesIn'+  default namesAndMetasIn' ::+    (Monoid m, Foldable f, NamesIn b, f b ~ a) =>+    (Either QName MetaId -> m) -> a -> m+  namesAndMetasIn' = foldMap . namesAndMetasIn'  -- Generic collections instance NamesIn a => NamesIn (Maybe a)+instance NamesIn a => NamesIn (Strict.Maybe a) instance NamesIn a => NamesIn [a]-instance NamesIn a => NamesIn (NonEmpty a)+instance NamesIn a => NamesIn (List1 a) instance NamesIn a => NamesIn (Set a) instance NamesIn a => NamesIn (Map k a)  -- Decorations instance NamesIn a => NamesIn (Arg a)-instance NamesIn a => NamesIn (Dom a) instance NamesIn a => NamesIn (Named n a) instance NamesIn a => NamesIn (Abs a) instance NamesIn a => NamesIn (WithArity a) instance NamesIn a => NamesIn (Open a) instance NamesIn a => NamesIn (C.FieldAssignment' a) +instance (NamesIn a, NamesIn b) => NamesIn (Dom' a b) where+  namesAndMetasIn' sg (Dom _ _ _ t e) =+    mappend (namesAndMetasIn' sg t) (namesAndMetasIn' sg e)++ -- Specific collections instance NamesIn a => NamesIn (Tele a)  -- Tuples  instance (NamesIn a, NamesIn b) => NamesIn (a, b) where-  namesIn' sg (x, y) = mappend (namesIn' sg x) (namesIn' sg y)+  namesAndMetasIn' sg (x, y) =+    mappend (namesAndMetasIn' sg x) (namesAndMetasIn' sg y)  instance (NamesIn a, NamesIn b, NamesIn c) => NamesIn (a, b, c) where-  namesIn' sg (x, y, z) = namesIn' sg (x, (y, z))+  namesAndMetasIn' sg (x, y, z) = namesAndMetasIn' sg (x, (y, z))  instance (NamesIn a, NamesIn b, NamesIn c, NamesIn d) => NamesIn (a, b, c, d) where-  namesIn' sg (x, y, z, u) = namesIn' sg ((x, y), (z, u))+  namesAndMetasIn' sg (x, y, z, u) =+    namesAndMetasIn' sg ((x, y), (z, u)) +instance+  (NamesIn a, NamesIn b, NamesIn c, NamesIn d, NamesIn e) =>+  NamesIn (a, b, c, d, e) where+  namesAndMetasIn' sg (x, y, z, u, v) =+    namesAndMetasIn' sg ((x, y), (z, (u, v)))++instance+  (NamesIn a, NamesIn b, NamesIn c, NamesIn d, NamesIn e, NamesIn f) =>+  NamesIn (a, b, c, d, e, f) where+  namesAndMetasIn' sg (x, y, z, u, v, w) =+    namesAndMetasIn' sg ((x, (y, z)), (u, (v, w)))+ instance NamesIn CompKit where-  namesIn' sg (CompKit a b) = namesIn' sg (a,b)+  namesAndMetasIn' sg (CompKit a b) = namesAndMetasIn' sg (a,b) --- Base case+-- Base cases  instance NamesIn QName where-  namesIn' sg x = sg x  -- interesting case!+  namesAndMetasIn' sg x = sg (Left x)  -- interesting case! +instance NamesIn MetaId where+  namesAndMetasIn' sg x = sg (Right x)+ instance NamesIn ConHead where-  namesIn' sg h = namesIn' sg (conName h)+  namesAndMetasIn' sg h = namesAndMetasIn' sg (conName h) +instance NamesIn Bool where+  namesAndMetasIn' _ _ = mempty+ -- Andreas, 2017-07-27 -- In the following clauses, the choice of fields is not obvious -- to the reader.  Please comment on the choices.------ Also, this would be more robust if these were constructor-style--- matches instead of record-style matches.--- If someone adds a field containing names, this would go unnoticed.  instance NamesIn Definition where-  namesIn' sg def = namesIn' sg (defType def, theDef def, defDisplay def)+  namesAndMetasIn' sg+    (Defn _ _ t _ _ _ _ disp _ _ _ _ _ _ _ _ _ _ def) =+    namesAndMetasIn' sg (t, def, disp)  instance NamesIn Defn where-  namesIn' sg = \case+  namesAndMetasIn' sg = \case     Axiom _            -> mempty-    DataOrRecSig{}     -> mempty-    GeneralizableVar{} -> mempty-    PrimitiveSort{}    -> mempty+    DataOrRecSig _     -> mempty+    GeneralizableVar   -> mempty+    PrimitiveSort _ s  -> namesAndMetasIn' sg s     AbstractDefn{}     -> __IMPOSSIBLE__     -- Andreas 2017-07-27, Q: which names can be in @cc@ which are not already in @cl@?-    Function    { funClauses = cl, funCompiled = cc }-      -> namesIn' sg (cl, cc)-    Datatype    { dataClause = cl, dataCons = cs, dataSort = s }-      -> namesIn' sg (cl, cs, s)-    Record      { recClause = cl, recConHead = c, recFields = fs, recComp = comp }-      -> namesIn' sg (cl, c, fs, comp)-      -- Don't need recTel since those will be reachable from the constructor-    Constructor { conSrcCon = c, conData = d, conComp = kit, conProj = fs }-      -> namesIn' sg (c, d, kit, fs)-    Primitive   { primClauses = cl, primCompiled = cc }-      -> namesIn' sg (cl, cc)+    Function cl cc _ _ _ _ _ _ _ _ _ _ el _ _+      -> namesAndMetasIn' sg (cl, cc, el)+    Datatype _ _ cl cs s _ _ _ trX trD+      -> namesAndMetasIn' sg (cl, cs, s, trX, trD)+    Record _ cl c _ fs recTel _ _ _ _ _ _ comp+      -> namesAndMetasIn' sg (cl, c, fs, recTel, comp)+    Constructor _ _ c d _ _ kit fs _ _+      -> namesAndMetasIn' sg (c, d, kit, fs)+    Primitive _ _ cl _ cc+      -> namesAndMetasIn' sg (cl, cc)  instance NamesIn Clause where-  namesIn' sg Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = b, clauseType = t } =-    namesIn' sg (tel, ps, b, t)+  namesAndMetasIn' sg (Clause _ _ tel ps b t _ _ _ _ _ _) =+    namesAndMetasIn' sg (tel, ps, b, t)  instance NamesIn CompiledClauses where-  namesIn' sg (Case _ c) = namesIn' sg c-  namesIn' sg (Done _ v) = namesIn' sg v-  namesIn' sg Fail{}     = mempty+  namesAndMetasIn' sg (Case _ c) = namesAndMetasIn' sg c+  namesAndMetasIn' sg (Done _ v) = namesAndMetasIn' sg v+  namesAndMetasIn' sg (Fail _)   = mempty  -- Andreas, 2017-07-27 -- Why ignoring the litBranches? instance NamesIn a => NamesIn (Case a) where-  namesIn' sg Branches{ conBranches = bs, catchAllBranch = c } =-    namesIn' sg (bs, c)+  namesAndMetasIn' sg (Branches _ bs _ _ c _ _) =+    namesAndMetasIn' sg (bs, c)  instance NamesIn (Pattern' a) where-  namesIn' sg = \case-    VarP{}          -> mempty-    LitP _ l        -> namesIn' sg l-    DotP _ v        -> namesIn' sg v-    ConP c _ args   -> namesIn' sg (c, args)-    DefP o q args   -> namesIn' sg (q, args)-    ProjP _ f       -> namesIn' sg f-    IApplyP _ t u _ -> namesIn' sg (t, u)+  namesAndMetasIn' sg = \case+    VarP _ _        -> mempty+    LitP _ l        -> namesAndMetasIn' sg l+    DotP _ v        -> namesAndMetasIn' sg v+    ConP c _ args   -> namesAndMetasIn' sg (c, args)+    DefP o q args   -> namesAndMetasIn' sg (q, args)+    ProjP _ f       -> namesAndMetasIn' sg f+    IApplyP _ t u _ -> namesAndMetasIn' sg (t, u)  instance NamesIn a => NamesIn (Type' a) where-  namesIn' sg (El s t) = namesIn' sg (s, t)+  namesAndMetasIn' sg (El s t) = namesAndMetasIn' sg (s, t)  instance NamesIn Sort where-  namesIn' sg = \case-    Type l      -> namesIn' sg l-    Prop l      -> namesIn' sg l+  namesAndMetasIn' sg = \case+    Type l      -> namesAndMetasIn' sg l+    Prop l      -> namesAndMetasIn' sg l     Inf _ _     -> mempty-    SSet l      -> namesIn' sg l+    SSet l      -> namesAndMetasIn' sg l     SizeUniv    -> mempty     LockUniv    -> mempty-    PiSort a b c  -> namesIn' sg (a, b, c)-    FunSort a b -> namesIn' sg (a, b)-    UnivSort a  -> namesIn' sg a-    MetaS _ es  -> namesIn' sg es-    DefS d es   -> namesIn' sg (d, es)-    DummyS{}    -> mempty+    IntervalUniv -> mempty+    PiSort a b c  -> namesAndMetasIn' sg (a, b, c)+    FunSort a b -> namesAndMetasIn' sg (a, b)+    UnivSort a  -> namesAndMetasIn' sg a+    MetaS x es  -> namesAndMetasIn' sg (x, es)+    DefS d es   -> namesAndMetasIn' sg (d, es)+    DummyS _    -> mempty  instance NamesIn Term where-  namesIn' sg = \case-    Var _ args   -> namesIn' sg args-    Lam _ b      -> namesIn' sg b-    Lit l        -> namesIn' sg l-    Def f args   -> namesIn' sg (f, args)-    Con c _ args -> namesIn' sg (c, args)-    Pi a b       -> namesIn' sg (a, b)-    Sort s       -> namesIn' sg s-    Level l      -> namesIn' sg l-    MetaV _ args -> namesIn' sg args-    DontCare v   -> namesIn' sg v-    Dummy{}      -> mempty+  namesAndMetasIn' sg = \case+    Var _ args   -> namesAndMetasIn' sg args+    Lam _ b      -> namesAndMetasIn' sg b+    Lit l        -> namesAndMetasIn' sg l+    Def f args   -> namesAndMetasIn' sg (f, args)+    Con c _ args -> namesAndMetasIn' sg (c, args)+    Pi a b       -> namesAndMetasIn' sg (a, b)+    Sort s       -> namesAndMetasIn' sg s+    Level l      -> namesAndMetasIn' sg l+    MetaV x args -> namesAndMetasIn' sg (x, args)+    DontCare v   -> namesAndMetasIn' sg v+    Dummy _ args -> namesAndMetasIn' sg args  instance NamesIn Level where-  namesIn' sg (Max _ ls) = namesIn' sg ls+  namesAndMetasIn' sg (Max _ ls) = namesAndMetasIn' sg ls  instance NamesIn PlusLevel where-  namesIn' sg (Plus _ l) = namesIn' sg l+  namesAndMetasIn' sg (Plus _ l) = namesAndMetasIn' sg l --- For QName literals!+-- For QName and Meta literals! instance NamesIn Literal where-  namesIn' sg = \case-    LitNat{}      -> mempty-    LitWord64{}   -> mempty-    LitString{}   -> mempty-    LitChar{}     -> mempty-    LitFloat{}    -> mempty-    LitQName    x -> namesIn' sg x-    LitMeta{}     -> mempty+  namesAndMetasIn' sg = \case+    LitNat _    -> mempty+    LitWord64 _ -> mempty+    LitString _ -> mempty+    LitChar _   -> mempty+    LitFloat _  -> mempty+    LitQName x  -> namesAndMetasIn' sg x+    LitMeta _ m -> namesAndMetasIn' sg m  instance NamesIn a => NamesIn (Elim' a) where-  namesIn' sg (Apply arg)      = namesIn' sg arg-  namesIn' sg (Proj _ f)       = namesIn' sg f-  namesIn' sg (IApply x y arg) = namesIn' sg (x, y, arg)+  namesAndMetasIn' sg (Apply arg)      = namesAndMetasIn' sg arg+  namesAndMetasIn' sg (Proj _ f)       = namesAndMetasIn' sg f+  namesAndMetasIn' sg (IApply x y arg) = namesAndMetasIn' sg (x, y, arg) +instance NamesIn a => NamesIn (Substitution' a) where+  namesAndMetasIn' sg = \case+    IdS              -> mempty+    EmptyS _         -> mempty+    t :# s           -> namesAndMetasIn' sg (t, s)+    Strengthen _ _ s -> namesAndMetasIn' sg s+    Wk _ s           -> namesAndMetasIn' sg s+    Lift _ s         -> namesAndMetasIn' sg s+ instance NamesIn DisplayForm where-  namesIn' sg (Display _ ps v) = namesIn' sg (ps, v)+  namesAndMetasIn' sg (Display _ ps v) = namesAndMetasIn' sg (ps, v)  instance NamesIn DisplayTerm where-  namesIn' sg = \case-    DWithApp v us es -> namesIn' sg (v, us, es)-    DCon c _ vs      -> namesIn' sg (c, vs)-    DDef f es        -> namesIn' sg (f, es)-    DDot v           -> namesIn' sg v-    DTerm v          -> namesIn' sg v+  namesAndMetasIn' sg = \case+    DWithApp v us es -> namesAndMetasIn' sg (v, us, es)+    DCon c _ vs      -> namesAndMetasIn' sg (c, vs)+    DDef f es        -> namesAndMetasIn' sg (f, es)+    DDot v           -> namesAndMetasIn' sg v+    DTerm v          -> namesAndMetasIn' sg v +instance NamesIn a => NamesIn (Builtin a) where+  namesAndMetasIn' sg = \case+    Builtin t -> namesAndMetasIn' sg t+    Prim x    -> namesAndMetasIn' sg x+    BuiltinRewriteRelations xs -> namesAndMetasIn' sg xs++-- | Note that the 'primFunImplementation' is skipped.+instance NamesIn PrimFun where+  namesAndMetasIn' sg = \case+    PrimFun x _ _ -> namesAndMetasIn' sg x++instance NamesIn Section where+  namesAndMetasIn' sg = \case+    Section tel -> namesAndMetasIn' sg tel++instance NamesIn NLPat where+  namesAndMetasIn' sg = \case+    PVar _ _      -> mempty+    PDef a b      -> namesAndMetasIn' sg (a, b)+    PLam _ a      -> namesAndMetasIn' sg a+    PPi a b       -> namesAndMetasIn' sg (a, b)+    PSort a       -> namesAndMetasIn' sg a+    PBoundVar _ a -> namesAndMetasIn' sg a+    PTerm a       -> namesAndMetasIn' sg a++instance NamesIn NLPType where+  namesAndMetasIn' sg = \case+    NLPType a b -> namesAndMetasIn' sg (a, b)++instance NamesIn NLPSort where+  namesAndMetasIn' sg = \case+    PType a       -> namesAndMetasIn' sg a+    PProp a       -> namesAndMetasIn' sg a+    PSSet a       -> namesAndMetasIn' sg a+    PInf _ _      -> mempty+    PSizeUniv     -> mempty+    PLockUniv     -> mempty+    PIntervalUniv -> mempty++instance NamesIn RewriteRule where+  namesAndMetasIn' sg = \case+    RewriteRule a b c d e f _ ->+      namesAndMetasIn' sg (a, b, c, d, e, f)++instance (NamesIn a, NamesIn b) => NamesIn (HashMap a b) where+  namesAndMetasIn' sg = namesAndMetasIn' sg . HMap.toList++instance NamesIn System where+  namesAndMetasIn' sg (System tel cs) = namesAndMetasIn' sg (tel, cs)++instance NamesIn ExtLamInfo where+  namesAndMetasIn' sg (ExtLamInfo _ _ s) = namesAndMetasIn' sg s++instance NamesIn a => NamesIn (FunctionInverse' a) where+  namesAndMetasIn' sg = \case+    NotInjective -> mempty+    Inverse m  -> namesAndMetasIn' sg m++instance NamesIn TTerm where+  namesAndMetasIn' sg = \case+    TVar _         -> mempty+    TPrim _        -> mempty+    TDef x         -> namesAndMetasIn' sg x+    TApp t xs      -> namesAndMetasIn' sg (t, xs)+    TLam t         -> namesAndMetasIn' sg t+    TLit l         -> namesAndMetasIn' sg l+    TCon x         -> namesAndMetasIn' sg x+    TLet t1 t2     -> namesAndMetasIn' sg (t1, t2)+    TCase _ c t ts -> namesAndMetasIn' sg (c, t, ts)+    TUnit          -> mempty+    TSort          -> mempty+    TErased        -> mempty+    TCoerce t      -> namesAndMetasIn' sg t+    TError _       -> mempty++instance NamesIn TAlt where+  namesAndMetasIn' sg = \case+    TACon x _ t   -> namesAndMetasIn' sg (x, t)+    TAGuard t1 t2 -> namesAndMetasIn' sg (t1, t2)+    TALit l t     -> namesAndMetasIn' sg (l, t)++instance NamesIn CaseType where+  namesAndMetasIn' sg = \case+    CTData _ x -> namesAndMetasIn' sg x+    CTNat      -> mempty+    CTInt      -> mempty+    CTChar     -> mempty+    CTString   -> mempty+    CTFloat    -> mempty+    CTQName    -> mempty++instance NamesIn CaseInfo where+  namesAndMetasIn' sg (CaseInfo _ t) = namesAndMetasIn' sg t++instance NamesIn Compiled where+  namesAndMetasIn' sg (Compiled t _) = namesAndMetasIn' sg t+ -- Pattern synonym stuff --  newtype PSyn = PSyn A.PatternSynDefn instance NamesIn PSyn where-  namesIn' sg (PSyn (_args, p)) = namesIn' sg p+  namesAndMetasIn' sg (PSyn (_args, p)) = namesAndMetasIn' sg p  instance NamesIn (A.Pattern' a) where-  namesIn' sg = \case-    A.VarP{}               -> mempty-    A.ConP _ c args        -> namesIn' sg (c, args)-    A.ProjP _ _ d          -> namesIn' sg d-    A.DefP _ f args        -> namesIn' sg (f, args)-    A.WildP{}              -> mempty-    A.AsP _ _ p            -> namesIn' sg p-    A.AbsurdP{}            -> mempty-    A.LitP _ l             -> namesIn' sg l-    A.PatternSynP _ c args -> namesIn' sg (c, args)-    A.RecP _ fs            -> namesIn' sg fs+  namesAndMetasIn' sg = \case+    A.VarP _               -> mempty+    A.ConP _ c args        -> namesAndMetasIn' sg (c, args)+    A.ProjP _ _ d          -> namesAndMetasIn' sg d+    A.DefP _ f args        -> namesAndMetasIn' sg (f, args)+    A.WildP _              -> mempty+    A.AsP _ _ p            -> namesAndMetasIn' sg p+    A.AbsurdP _            -> mempty+    A.LitP _ l             -> namesAndMetasIn' sg l+    A.PatternSynP _ c args -> namesAndMetasIn' sg (c, args)+    A.RecP _ fs            -> namesAndMetasIn' sg fs     A.DotP{}               -> __IMPOSSIBLE__    -- Dot patterns are not allowed in pattern synonyms     A.EqualP{}             -> __IMPOSSIBLE__    -- Andrea: should we allow these in pattern synonyms?-    A.WithP _ p            -> namesIn' sg p+    A.WithP _ p            -> namesAndMetasIn' sg p     A.AnnP _ a p           -> __IMPOSSIBLE__    -- Type annotations are not (yet) allowed in pattern synonyms  instance NamesIn AmbiguousQName where-  namesIn' sg (AmbQ cs) = namesIn' sg cs+  namesAndMetasIn' sg (AmbQ cs) = namesAndMetasIn' sg cs
src/full/Agda/Syntax/Internal/Pattern.hs view
@@ -355,3 +355,10 @@       LitP{}      -> []       ProjP{}     -> []       IApplyP _ _ _ x -> [(x, defaultModality)]+++hasDefP :: [NamedArg DeBruijnPattern] -> Bool+hasDefP ps = getAny $ flip foldPattern ps $ \ (x :: DeBruijnPattern) ->+                  case x of+                    DefP{} -> Any True+                    _      -> Any False
src/full/Agda/Syntax/Internal/SanityCheck.hs view
@@ -40,9 +40,9 @@           unless (size delta > 0) $ err $ "consS: empty target"           sanityCheckVars gamma v           sanityCheckSubst gamma rho (dropLast delta)-        Strengthen _ rho -> do-          unless (size delta > 0) $ err $ "strS: empty target"-          sanityCheckSubst gamma rho (dropLast delta)+        Strengthen _ n rho -> do+          unless (size delta >= n) $ err $ "strS: empty target"+          sanityCheckSubst gamma rho (dropLastN n delta)         Wk n rho -> do           unless (size gamma >= n) $ err $ "wkS:" <+> sep [ "|" <> pretty gamma <> "|"                                                                , text $ "< " ++ show n ]
src/full/Agda/Syntax/Literal.hs view
@@ -5,13 +5,14 @@ import Data.Char import Data.Word -import Data.Data (Data) import Data.Text (Text) import qualified Data.Text as T  import Agda.Syntax.Position import Agda.Syntax.Common import Agda.Syntax.Abstract.Name+import {-# SOURCE #-} Agda.Syntax.TopLevelModuleName+  (TopLevelModuleName) import Agda.Utils.FileName import Agda.Utils.Float ( doubleDenotEq, doubleDenotOrd ) import Agda.Utils.Pretty@@ -24,8 +25,8 @@   | LitString !Text   | LitChar   !Char   | LitQName  !QName-  | LitMeta   AbsolutePath MetaId-  deriving (Data, Show)+  | LitMeta   !TopLevelModuleName !MetaId+  deriving Show  instance Pretty Literal where     pretty (LitNat n)     = pretty n@@ -92,7 +93,7 @@   killRange (LitString x) = LitString x   killRange (LitChar   x) = LitChar   x   killRange (LitQName  x) = killRange1 LitQName x-  killRange (LitMeta f x) = LitMeta f x+  killRange (LitMeta m x) = LitMeta (killRange m) x  -- | Ranges are not forced. @@ -103,4 +104,4 @@   rnf (LitString _  ) = ()   rnf (LitChar _    ) = ()   rnf (LitQName a   ) = rnf a-  rnf (LitMeta _ x  ) = rnf x+  rnf (LitMeta m _  ) = rnf m
src/full/Agda/Syntax/Notation.hs view
@@ -34,18 +34,20 @@  import Agda.Utils.Lens import Agda.Utils.List+import Agda.Utils.List1 (List1) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Null import Agda.Utils.Pretty  import Agda.Utils.Impossible --- | Data type constructed in the Happy parser; converted to 'GenPart'---   before it leaves the Happy code.+-- | Data type constructed in the Happy parser; converted to+-- 'NotationPart' before it leaves the Happy code. data HoleName-  = LambdaHole { _bindHoleName :: RString-               , holeName      :: RString }-    -- ^ @\ x -> y@; 1st argument is the bound name (unused for now).+  = LambdaHole { _bindHoleNames :: List1 RString+               , holeName       :: RString+               }+    -- ^ @λ x₁ … xₙ → y@: The first argument contains the bound names.   | ExprHole   { holeName      :: RString }     -- ^ Simple named hole with hiding. @@ -59,32 +61,25 @@ stringParts gs = [ rangedThing x | IdPart x <- gs ]  -- | Target argument position of a part (Nothing if it is not a hole).-holeTarget :: GenPart -> Maybe Int-holeTarget (BindHole _   n) = Just $ rangedThing n-holeTarget (WildHole     n) = Just $ rangedThing n-holeTarget (NormalHole _ n) = Just $ rangedThing $ namedArg n-holeTarget IdPart{}         = Nothing---- | Is the part a hole? WildHoles don't count since they don't correspond to---   anything the user writes.-isAHole :: GenPart -> Bool-isAHole BindHole{}   = True-isAHole NormalHole{} = True-isAHole WildHole{}   = False-isAHole IdPart{}     = False+holeTarget :: NotationPart -> Maybe Int+holeTarget (VarPart _ n)  = Just $ holeNumber $ rangedThing n+holeTarget (WildPart n)   = Just $ holeNumber $ rangedThing n+holeTarget (HolePart _ n) = Just $ rangedThing $ namedArg n+holeTarget IdPart{}       = Nothing --- | Is the part a normal hole?-isNormalHole :: GenPart -> Bool-isNormalHole NormalHole{} = True-isNormalHole BindHole{}   = False-isNormalHole WildHole{}   = False-isNormalHole IdPart{}     = False+-- | Is the part a hole?+isAHole :: NotationPart -> Bool+isAHole HolePart{} = True+isAHole VarPart{}  = False+isAHole WildPart{} = False+isAHole IdPart{}   = False  -- | Is the part a binder?-isBindingHole :: GenPart -> Bool-isBindingHole BindHole{} = True-isBindingHole WildHole{} = True-isBindingHole _          = False+isBinder :: NotationPart -> Bool+isBinder HolePart{} = False+isBinder VarPart{}  = True+isBinder WildPart{} = True+isBinder IdPart{}   = False  -- | Classification of notations. @@ -101,7 +96,7 @@ notationKind :: Notation -> NotationKind notationKind []  = NoNotation notationKind (h:syn) =-  case (isNormalHole h, isNormalHole $ last1 h syn) of+  case (isAHole h, isAHole $ last1 h syn) of     (True , True ) -> InfixNotation     (True , False) -> PostfixNotation     (False, True ) -> PrefixNotation@@ -109,16 +104,16 @@  -- | From notation with names to notation with indices. -----   Example:---   @---      ids   = ["for", "x", "∈", "xs", "return", "e"]---      holes = [ LambdaHole "x" "e",  ExprHole "xs" ]---   @---   creates the notation+--   An example (with some parts of the code omitted):+--   The lists+--   @["for", "x", "∈", "xs", "return", "e"]@+--   and+--   @['LambdaHole' ("x" :| []) "e", 'ExprHole' "xs"]@+--   are mapped to the following notation: --   @---      [ IdPart "for"    , BindHole 0---      , IdPart "∈"      , NormalHole 1---      , IdPart "return" , NormalHole 0+--      [ 'IdPart' "for"    , 'VarPart' ('BoundVariablePosition' 0 0)+--      , 'IdPart' "∈"      , 'HolePart' 1+--      , 'IdPart' "return" , 'HolePart' 0 --      ] --   @ mkNotation :: [NamedArg HoleName] -> [RString] -> Either String Notation@@ -136,11 +131,11 @@   -- Andreas, 2018-10-18, issue #3285:   -- syntax that is just a single hole is ill-formed and crashes the operator parser   when   (isSingleHole xs)   $ throwError "syntax cannot be a single hole"-  return $ insertWildHoles xs+  return $ insertWildParts xs     where       holeNames :: [RString]       holeNames = map namedArg holes >>= \case-        LambdaHole x y -> [x, y]+        LambdaHole _ y -> [y]         ExprHole y     -> [y]        prettyHoles :: String@@ -153,55 +148,86 @@       numberedHoles :: [(Int, NamedArg HoleName)]       numberedHoles = zip holeNumbers holes -      -- The WildHoles don't correspond to anything in the right-hand side so+      -- The WildParts don't correspond to anything in the right-hand side so       -- we add them next to their corresponding body. Slightly subtle: due to       -- the way the operator parsing works they can't be added first or last.-      insertWildHoles :: [GenPart] -> [GenPart]-      insertWildHoles xs = foldr ins xs wilds+      insertWildParts :: [NotationPart] -> [NotationPart]+      insertWildParts xs = foldr ins xs wilds         where-          wilds = [ i | (_, WildHole i) <- holeMap ]-          ins w (NormalHole r h : hs)-            | namedArg h == w = NormalHole r h : WildHole w : hs+          wilds = [ i | (_, WildPart i) <- holeMap ]++          ins w (HolePart r h : hs)+            | namedArg h == fmap holeNumber w =+              HolePart r h : WildPart w : hs           ins w (h : hs) = h : insBefore w hs           ins _ [] = __IMPOSSIBLE__ -          insBefore w (NormalHole r h : hs)-            | namedArg h == w = WildHole w : NormalHole r h : hs+          insBefore w (HolePart r h : hs)+            | namedArg h == fmap holeNumber w =+              WildPart w : HolePart r h : hs           insBefore w (h : hs) = h : insBefore w hs           insBefore _ [] = __IMPOSSIBLE__ -      -- Create a map (association list) from hole names to holes.-      -- A @LambdaHole@ contributes two entries:-      -- both names are mapped to the same number,-      -- but distinguished by BindHole vs. NormalHole.-      holeMap :: [(RString, GenPart)]+      -- A map (association list) from hole names to notation parts. A+      -- @LambdaHole@ contributes one or more entries, one @HolePart@+      -- and zero or more @VarPart@s or @WildParts@, all mapped to the+      -- same number.+      holeMap :: [(RString, NotationPart)]       holeMap = do-        (i, h) <- numberedHoles    -- v This range is filled in by mkPart-        let ri x = Ranged (getRange x) i-            normalHole y = NormalHole noRange $ fmap (ri y <$) h+        (i, h) <- numberedHoles+        let ri x   = Ranged (getRange x) i+            rp x n = Ranged (getRange x) $+                     BoundVariablePosition+                       { holeNumber = i+                       , varNumber  = n+                       }+            hole y = HolePart noRange $ fmap (ri y <$) h+                              -- This range is filled in by mkPart.         case namedArg h of-          ExprHole y       -> [(y, normalHole y)]-          LambdaHole x y-            | "_" <- rangedThing x -> [(x, WildHole (ri x)),         (y, normalHole y)]-            | otherwise            -> [(x, BindHole noRange (ri x)), (y, normalHole y)]-                                                 -- Filled in by mkPart+          ExprHole y      -> [(y, hole y)]+          LambdaHole xs y -> [(y, hole y)] +++            zipWith+              (\ n x -> case rangedThing x of+                "_" -> (x, WildPart (rp x n))+                _   -> (x, VarPart noRange (rp x n)))+                                   -- Filled in by mkPart.+              [0..]+              (List1.toList xs)        -- Check whether all hole names are distinct.       -- The hole names are the keys of the @holeMap@.       uniqueHoleNames = distinct [ x | (x, _) <- holeMap, rangedThing x /= "_" ] -      isExprLinear   xs = List.sort [ i | x <- xs, isNormalHole x, let Just i = holeTarget x ] == holeNumbers-      isLambdaLinear xs = List.sort [ rangedThing x | BindHole _ x <- xs ] ==-                          [ i | (i, h) <- numberedHoles,-                                LambdaHole x _ <- [namedArg h], rangedThing x /= "_" ]+      isExprLinear xs =+        List.sort [ i | x <- xs, isAHole x, let Just i = holeTarget x ]+          ==+        holeNumbers -      noAdjacentHoles :: [GenPart] -> Bool-      noAdjacentHoles []       = __IMPOSSIBLE__-      noAdjacentHoles [x]      = True-      noAdjacentHoles (x:y:xs) =-        not (isAHole x && isAHole y) && noAdjacentHoles (y:xs)+      isLambdaLinear xs =+        List.sort [ rangedThing x | VarPart _ x <- xs ]+          ==+        [ BoundVariablePosition { holeNumber = i, varNumber = v }+        | (i, h) <- numberedHoles+        , LambdaHole vs _ <- [namedArg h]+        , (v, x) <- zip [0..] $ map rangedThing $ List1.toList vs+        , x /= "_"+        ] -      isSingleHole :: [GenPart] -> Bool+      noAdjacentHoles :: [NotationPart] -> Bool+      noAdjacentHoles =+        noAdj .+        filter (\h -> case h of+                   HolePart{} -> True+                   IdPart{}   -> True+                   _          -> False)+        where+        noAdj []       = __IMPOSSIBLE__+        noAdj [x]      = True+        noAdj (x:y:xs) =+          not (isAHole x && isAHole y) &&+          noAdj (y:xs)++      isSingleHole :: [NotationPart] -> Bool       isSingleHole = \case         [ IdPart{} ] -> False         [ _hole ]    -> True@@ -260,7 +286,7 @@  -- | Create a 'Notation' (without binders) from a concrete 'Name'. --   Does the obvious thing:---   'Hole's become 'NormalHole's, 'Id's become 'IdParts'.+--   'Hole's become 'HolePart's, 'Id's become 'IdParts'. --   If 'Name' has no 'Hole's, it returns 'noNotation'. syntaxOf :: Name -> Notation syntaxOf y@@ -272,7 +298,7 @@     -- Result will have no 'BindingHole's.     mkSyn :: Int -> [NamePart] -> Notation     mkSyn n []          = []-    mkSyn n (Hole : xs) = NormalHole noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs+    mkSyn n (Hole : xs) = HolePart noRange (defaultNamedArg $ unranged n) : mkSyn (1 + n) xs     mkSyn n (Id x : xs) = IdPart (unranged x) : mkSyn n xs  -- | Merges 'NewNotation's that have the same precedence level and@@ -336,6 +362,15 @@   merge :: [NewNotation] -> NewNotation   merge []         = __IMPOSSIBLE__   merge ns@(n : _) = n { notaNames = Set.unions $ map notaNames ns }++-- | Check if a notation contains any lambdas (in which case it cannot be used in a pattern).+isLambdaNotation :: NewNotation -> Bool+isLambdaNotation n = any isBinder (notation n)+  where+    isBinder VarPart{}  = True+    isBinder WildPart{} = True+    isBinder IdPart{}   = False+    isBinder HolePart{} = False  -- | Lens for 'Fixity' in 'NewNotation'.
src/full/Agda/Syntax/Parser.hs view
@@ -41,6 +41,7 @@ import Agda.Syntax.Parser.Lexer import Agda.Syntax.Parser.Literate import Agda.Syntax.Concrete+import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Parser.Tokens  import Agda.Utils.FileName@@ -71,19 +72,21 @@  -- | Embed a 'ParseResult' as 'PM' computation. -wrap :: ParseResult a -> PM a+wrap :: ParseResult a -> PM (a, CohesionAttributes) wrap (ParseFailed err)  = throwError err wrap (ParseOk s x)      = do   modify' (parseWarnings s ++)-  return x+  return (x, parseCohesion s) -wrapM :: IO (ParseResult a) -> PM a+wrapM :: IO (ParseResult a) -> PM (a, CohesionAttributes) wrapM m = liftIO m >>= wrap  -- | Returns the contents of the given file. -readFilePM :: AbsolutePath -> PM Text-readFilePM path = wrapIOM (ReadFileError path) (readTextFile $ filePath path)+readFilePM :: RangeFile -> PM Text+readFilePM file =+  wrapIOM (ReadFileError file) $+  readTextFile (filePath $ rangeFilePath file)  wrapIOM :: (MonadError e m, MonadIO m) => (IOError -> e) -> IO a -> m a wrapIOM f m = do@@ -103,7 +106,8 @@   , parseLiterate  :: LiterateParser a   } -type LiterateParser a = Parser a -> [Layer] -> PM a+type LiterateParser a =+  Parser a -> [Layer] -> PM (a, CohesionAttributes)  -- | Initial state for lexing. @@ -117,7 +121,7 @@  -- | Parse without top-level layout. -parse :: Parser a -> String -> PM a+parse :: Parser a -> String -> PM (a, CohesionAttributes) parse p = wrapM . return . M.parse (parseFlags p) normalLexState (parser p)  -- | Parse with top-level layout.@@ -126,7 +130,7 @@   :: SrcFile   -- ^ Name of source file.   -> Parser a  -- ^ Parser to use.   -> String    -- ^ Contents of source file.-  -> PM a+  -> PM (a, CohesionAttributes) parseFileFromString src p = wrapM . return . M.parseFromSrc (parseFlags p) layoutLexState (parser p) src  -- | Parse with top-level layout.@@ -138,32 +142,33 @@  parseLiterateWithComments :: LiterateParser [Token] parseLiterateWithComments p layers = do-  code <- parseLiterateWithoutComments p layers+  (code, coh) <- parseLiterateWithoutComments p layers   let literate = filter (not . isCodeLayer) layers   let (terms, overlaps) = interleaveRanges (map Left code) (map Right literate)    forM_ (map fst overlaps) $ \c ->     warning $ OverlappingTokensWarning { warnRange = getRange c } -  return $ forMaybe terms $ \case+  (, coh) <$> (return $ forMaybe terms $ \case     Left t                           -> Just t     Right (Layer Comment interval s) -> Just $ TokTeX    (interval, s)     Right (Layer Markup  interval s) -> Just $ TokMarkup (interval, s)-    Right (Layer Code _ _)           -> Nothing+    Right (Layer Code _ _)           -> Nothing)   parseLiterateFile   :: Processor   -> Parser a-  -> AbsolutePath-     -- ^ The path to the file.+  -> RangeFile+     -- ^ The file.   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.-  -> PM a+  -> PM (a, CohesionAttributes) parseLiterateFile po p path = parseLiterate p p . po (startPos (Just path)) -parsePosString :: Parser a -> Position -> String -> PM a+parsePosString ::+  Parser a -> Position -> String -> PM (a, CohesionAttributes) parsePosString p pos = wrapM . return . M.parsePosString pos (parseFlags p) normalLexState (parser p)  -- | Extensions supported by `parseFile`.@@ -174,24 +179,26 @@ parseFile   :: Show a   => Parser a-  -> AbsolutePath-     -- ^ The path to the file.+  -> RangeFile+     -- ^ The file.   -> String      -- ^ The file contents. Note that the file is /not/ read from      -- disk.-  -> PM (a, FileType)+  -> PM ((a, CohesionAttributes), FileType) parseFile p file input =-  if ".agda" `List.isSuffixOf` filePath file then+  if ".agda" `List.isSuffixOf` path then     (, AgdaFileType) <$> parseFileFromString (Strict.Just file) p input   else     go literateProcessors   where+    path = filePath (rangeFilePath file)+     go [] = throwError InvalidExtensionError                    { errPath = file                    , errValidExts = acceptableFileExts                    }     go ((ext, (po, ft)) : pos)-      | ext `List.isSuffixOf` filePath file =+      | ext `List.isSuffixOf` path =           (, ft) <$> parseLiterateFile po p file input       | otherwise = go pos
src/full/Agda/Syntax/Parser/Layout.hs view
@@ -13,7 +13,7 @@     > [Layout 12, Layout 4, Layout 0]      The closest layout block is the one following @do@ which is-    started by token @foo@ at column 12.  The second closest block is the+    started by token @y@ at column 12.  The second closest block is the     @where@ clause started by the @x'@ token which has indentation 4.     Finally, there is a top-level layout block with indentation 0.
src/full/Agda/Syntax/Parser/LexActions.hs view
@@ -1,4 +1,3 @@- {-| This module contains the building blocks used to construct the lexer. -} module Agda.Syntax.Parser.LexActions@@ -35,6 +34,8 @@ import Agda.Syntax.Literal  import Agda.Utils.List+import Agda.Utils.List1 (String1, toList)+import qualified Agda.Utils.List1 as List1  import Agda.Utils.Impossible @@ -251,15 +252,15 @@ -- | Parse an identifier. Identifiers can be qualified (see 'Name'). --   Example: @Foo.Bar.f@ identifier :: LexAction Token-identifier = qualified (either TokId TokQId)+identifier = qualified $ either (TokId . second toList) (TokQId . map (second toList))   -- | Parse a possibly qualified name.-qualified :: (Either (Interval, String) [(Interval, String)] -> a) -> LexAction a+qualified :: (Either (Interval, String1) [(Interval, String1)] -> a) -> LexAction a qualified tok =     token $ \s ->     do  i <- getParseInterval-        case mkName i $ wordsBy (=='.') s of+        case mkName i $ List1.wordsBy (== '.') s of             []  -> lexError "lex error on .."             [x] -> return $ tok $ Left  x             xs  -> return $ tok $ Right xs@@ -267,7 +268,7 @@         -- Compute the ranges for the substrings (separated by '.') of         -- a name. Dots are included: the intervals generated for         -- "A.B.x" correspond to "A.", "B." and "x".-        mkName :: Interval -> [String] -> [(Interval, String)]+        mkName :: Interval -> [String1] -> [(Interval, String1)]         mkName _ []     = []         mkName i [x]    = [(i, x)]         mkName i (x:xs) = (i0, x) : mkName i1 xs
src/full/Agda/Syntax/Parser/Lexer.x view
@@ -90,6 +90,7 @@ <pragma_>   "INJECTIVE"                { keyword KwINJECTIVE } <pragma_>   "INLINE"                   { keyword KwINLINE } <pragma_>   "NOINLINE"                 { keyword KwNOINLINE }+<pragma_>   "NOT_PROJECTION_LIKE"      { keyword KwNOT_PROJECTION_LIKE } <pragma_>   "LINE"                     { keyword KwLINE } <pragma_>   "MEASURE"                  { keyword KwMEASURE } <pragma_>   "NO_POSITIVITY_CHECK"      { keyword KwNO_POSITIVITY_CHECK }
src/full/Agda/Syntax/Parser/Monad.hs view
@@ -37,11 +37,11 @@ import Control.Monad.State  import Data.Int-import Data.Data  ( Data ) import Data.Maybe ( listToMaybe )  import Agda.Interaction.Options.Warnings +import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Position import Agda.Syntax.Parser.Tokens ( Keyword( KwMutual ) ) @@ -76,6 +76,8 @@                                              --   (states can be nested so we need a stack)     , parseFlags    :: ParseFlags            -- ^ parametrization of the parser     , parseWarnings :: ![ParseWarning]       -- ^ In reverse order.+    , parseCohesion :: !CohesionAttributes+      -- ^ Every encountered occurrence of a cohesion attribute.     }     deriving Show @@ -151,12 +153,12 @@    -- | Parse errors that concern a whole file.   | InvalidExtensionError-    { errPath      :: !AbsolutePath+    { errPath      :: !RangeFile                       -- ^ The file which the error concerns.     , errValidExts :: [String]     }   | ReadFileError-    { errPath      :: !AbsolutePath+    { errPath      :: !RangeFile     , errIOError   :: IOError     }   deriving Show@@ -172,7 +174,7 @@     -- ^ Unsupported attribute.   | MultipleAttributes Range !(Maybe String)     -- ^ Multiple attributes.-  deriving (Data, Show)+  deriving Show  instance NFData ParseWarning where   rnf (OverlappingTokensWarning _) = ()@@ -293,6 +295,7 @@                                                 -- Just for better errors on stray @constructor@ decls.                 , parseFlags        = flags                 , parseWarnings     = []+                , parseCohesion     = []                 }   where   pos' = pos { srcFile = () }@@ -300,8 +303,8 @@ -- | Constructs the initial state of the parser. The string argument --   is the input string, the file path is only there because it's part --   of a position.-initState :: Maybe AbsolutePath -> ParseFlags -> String -> [LexState]-          -> ParseState+initState ::+  Maybe RangeFile -> ParseFlags -> String -> [LexState] -> ParseState initState file = initStatePos (startPos file)  -- | The default flags.
src/full/Agda/Syntax/Parser/Parser.y view
@@ -31,9 +31,12 @@  import Control.Applicative ( (<|>) ) import Control.Monad+import Control.Monad.State  import Data.Bifunctor (first, second) import Data.Char+import Data.DList (DList)+import qualified Data.DList as DL import qualified Data.List as List import Data.Maybe import Data.Semigroup ((<>), sconcat)@@ -166,6 +169,7 @@     'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $$ }     'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $$ }     'NON_COVERING'            { TokKeyword KwNON_COVERING $$ }+    'NOT_PROJECTION_LIKE'     { TokKeyword KwNOT_PROJECTION_LIKE $$ }     'OPTIONS'                 { TokKeyword KwOPTIONS $$ }     'POLARITY'                { TokKeyword KwPOLARITY $$ }     'WARNING_ON_USAGE'        { TokKeyword KwWARNING_ON_USAGE $$ }@@ -294,6 +298,7 @@     | 'NO_UNIVERSE_CHECK'       { TokKeyword KwNO_UNIVERSE_CHECK $1 }     | 'NON_TERMINATING'         { TokKeyword KwNON_TERMINATING $1 }     | 'NON_COVERING'            { TokKeyword KwNON_COVERING $1 }+    | 'NOT_PROJECTION_LIKE'     { TokKeyword KwNOT_PROJECTION_LIKE $1 }     | 'OPTIONS'                 { TokKeyword KwOPTIONS $1 }     | 'POLARITY'                { TokKeyword KwPOLARITY $1 }     | 'REWRITE'                 { TokKeyword KwREWRITE $1 }@@ -572,11 +577,12 @@ Strings : {- empty -}    { [] }         | string Strings { $1 : $2 } -ForeignCode :: { [(Interval, String)] }+ForeignCode :: { DList (Interval, String) } ForeignCode-  : {- empty -} { [] }-  | string ForeignCode { $1 : $2 }-  | '{-#' ForeignCode '#-}' ForeignCode { [($1, "{-#")] ++ $2 ++ [($3, "#-}")] ++ $4 }+  : {- empty -} { mempty }+  | string ForeignCode { $1 `DL.cons` $2 }+  | '{-#' ForeignCode '#-}' ForeignCode+    { (($1, "{-#") `DL.cons` $2) <> (($3, "#-}") `DL.cons` $4) }  PragmaName :: { Name } PragmaName : string {% mkName $1 }@@ -851,7 +857,7 @@   : LamBinds '->' {%       case absurdBinding $1 of         Just{}  -> parseError "Absurd lambda cannot have a body."-        Nothing -> return $ List1.fromList $ lamBindings $1+        Nothing -> return $ List1.fromListSafe __IMPOSSIBLE__ $ lamBindings $1       }  AbsurdLamBindings :: { Either ([LamBinding], Hiding) (List1 Expr) }@@ -1307,6 +1313,8 @@ UnquoteDecl :: { Declaration } UnquoteDecl   : 'unquoteDecl' '=' Expr { UnquoteDecl (fuseRange $1 $3) [] $3 }+  | 'unquoteDecl' 'data' Id '=' Expr { UnquoteData (getRange($1, $2, $5)) $3 [] $5 }+  | 'unquoteDecl' 'data' Id 'constructor' SpaceIds '=' Expr { UnquoteData (getRange($1, $2, $4, $7)) $3 (List1.toList $5) $7 }   | 'unquoteDecl' SpaceIds '=' Expr { UnquoteDecl (fuseRange $1 $4) (List1.toList $2) $4 }   | 'unquoteDef'  SpaceIds '=' Expr { UnquoteDef (fuseRange $1 $4) (List1.toList $2) $4 } @@ -1314,7 +1322,7 @@ Syntax :: { Declaration } Syntax : 'syntax' Id HoleNames '=' SimpleIds  {%   case $2 of-    Name _ _ (_ :| []) -> case mkNotation $3 $5 of+    Name _ _ (_ :| []) -> case mkNotation (DL.toList $3) (reverse $5) of       Left err -> parseError $ "Malformed syntax declaration: " ++ err       Right n -> return $ Syntax $2 n     _ -> parseError "Syntax declarations are allowed only for simple names (without holes)"@@ -1330,14 +1338,23 @@ PatternSynArgs :: { [Arg Name] } PatternSynArgs : DomainFreeBindings    {% patternSynArgs $1 } +-- The list should be reversed.+ SimpleIds :: { [RString] }-SimpleIds : SimpleId { [$1] }-          | SimpleIds SimpleId {$1 ++ [$2]}+SimpleIds : SimpleId           { [$1] }+          | SimpleIds SimpleId { $2 : $1 } -HoleNames :: { [NamedArg HoleName] }-HoleNames :                    { [] }-          | HoleNames HoleName {$1 ++ [$2]}+-- The list should be reversed. +SimpleIdsOrWildcards :: { List1 RString }+SimpleIdsOrWildcards+  : SimpleIdOrWildcard                      { List1.singleton $1 }+  | SimpleIdsOrWildcards SimpleIdOrWildcard { $2 <| $1 }++HoleNames :: { DList (NamedArg HoleName) }+HoleNames :                    { mempty }+          | HoleNames HoleName { $1 `DL.snoc` $2 }+ HoleName :: { NamedArg HoleName } HoleName   : SimpleTopHole { defaultNamedArg $1 }@@ -1349,20 +1366,24 @@ SimpleTopHole :: { HoleName } SimpleTopHole   : SimpleId { ExprHole $1 }-  | '(' '\\' SimpleId '->' SimpleId ')' { LambdaHole $3 $5 }-  | '(' '\\' '_'      '->' SimpleId ')' { LambdaHole (Ranged (getRange $3) "_") $5 }+  | '(' '\\' SimpleIdsOrWildcards '->' SimpleId ')'+    { LambdaHole (List1.reverse $3) $5 }  SimpleHole :: { HoleName } SimpleHole   : SimpleId { ExprHole $1 }-  | '\\' SimpleId '->' SimpleId { LambdaHole $2 $4 }-  | '\\' '_'      '->' SimpleId { LambdaHole (Ranged (getRange $3) "_") $4 }--- Variable name hole to be implemented later.+  | '\\' SimpleIdsOrWildcards '->' SimpleId+    { LambdaHole (List1.reverse $2) $4 }  -- Discard the interval. SimpleId :: { RString } SimpleId : id  { Ranged (getRange $ fst $1) (stringToRawName $ snd $1) } +SimpleIdOrWildcard :: { RString }+SimpleIdOrWildcard+  : SimpleId { $1 }+  | '_'      { Ranged (getRange $1) "_" }+ MaybeOpen :: { Maybe Range } MaybeOpen : 'open'      { Just (getRange $1) }           | {- empty -} { Nothing }@@ -1500,6 +1521,7 @@   | NonTerminatingPragma     { $1 }   | NoTerminationCheckPragma { $1 }   | NonCoveringPragma        { $1 }+  | NotProjectionLikePragma  { $1 }   | WarningOnUsagePragma     { $1 }   | WarningOnImportPragma    { $1 }   | MeasurePragma            { $1 }@@ -1532,7 +1554,9 @@  ForeignPragma :: { Pragma } ForeignPragma-  : '{-#' 'FOREIGN' string ForeignCode '#-}' { ForeignPragma (getRange ($1, $2, fst $3, $5)) (mkRString $3) (recoverLayout $4) }+  : '{-#' 'FOREIGN' string ForeignCode '#-}'+    { ForeignPragma (getRange ($1, $2, fst $3, $5))+        (mkRString $3) (recoverLayout (DL.toList $4)) }  CompilePragma :: { Pragma } CompilePragma@@ -1554,6 +1578,11 @@   : '{-#' 'NOINLINE' PragmaQName '#-}'     { InlinePragma (getRange ($1,$2,$3,$4)) False $3 } +NotProjectionLikePragma :: { Pragma }+NotProjectionLikePragma+  : '{-#' 'NOT_PROJECTION_LIKE' PragmaQName '#-}'+    { NotProjectionLikePragma (getRange ($1,$2,$3,$4)) $3 }+ InjectivePragma :: { Pragma } InjectivePragma   : '{-#' 'INJECTIVE' PragmaQName '#-}'@@ -2375,8 +2404,15 @@  -- | Parse an attribute. toAttribute :: Expr -> Parser Attr-toAttribute x = maybe failure (return . Attr (getRange x) y) $ exprToAttribute x+toAttribute x = do+  attr <- maybe failure (return . Attr r y) $ exprToAttribute x+  case theAttr attr of+    CohesionAttribute{} ->+      modify' (\s -> s { parseCohesion = (y, r) : parseCohesion s })+    _                   -> return ()+  return attr   where+  r = getRange x   y = prettyShow x   failure = parseErrorRange x $ "Unknown attribute: " ++ y
src/full/Agda/Syntax/Parser/Tokens.hs view
@@ -24,6 +24,7 @@         | KwIMPOSSIBLE | KwSTATIC | KwINJECTIVE | KwINLINE | KwNOINLINE         | KwETA         | KwNO_TERMINATION_CHECK | KwTERMINATING | KwNON_TERMINATING+        | KwNOT_PROJECTION_LIKE         | KwNON_COVERING         | KwWARNING_ON_USAGE | KwWARNING_ON_IMPORT         | KwMEASURE | KwDISPLAY
src/full/Agda/Syntax/Position.hs view
@@ -7,6 +7,8 @@   , PositionWithoutFile   , Position'(..)   , SrcFile+  , RangeFile(..)+  , mkRangeFile   , positionInvariant   , startPos   , movePos@@ -34,6 +36,8 @@   , intervalToRange   , rangeIntervals   , rangeFile+  , rangeModule'+  , rangeModule   , rightMargin   , noRange   , posToRange, posToRange'@@ -63,17 +67,17 @@ import Prelude hiding ( null )  import Control.DeepSeq+import Control.Monad import Control.Monad.Writer (runWriter, tell)  import qualified Data.Foldable as Fold-import Data.Function+import Data.Function (on) import Data.Int-import Data.List hiding (null)+import Data.List (sort) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Data.Data (Data) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Semigroup (Semigroup(..))@@ -81,6 +85,9 @@  import GHC.Generics (Generic) +import {-# SOURCE #-} Agda.Syntax.TopLevelModuleName+  (TopLevelModuleName)+ import Agda.Utils.FileName import Agda.Utils.List import Agda.Utils.List1 (List1)@@ -115,7 +122,7 @@   , posCol  :: !Int32     -- ^ Column number, counting from 1.   }-  deriving (Show, Data, Functor, Foldable, Traversable, Generic)+  deriving (Show, Functor, Foldable, Traversable, Generic)  positionInvariant :: Position' a -> Bool positionInvariant p =@@ -130,8 +137,50 @@ instance Ord a => Ord (Position' a) where   compare = compare `on` importantPart -type SrcFile = Strict.Maybe AbsolutePath+type SrcFile = Strict.Maybe RangeFile +-- | File information used in the 'Position', 'Interval' and 'Range'+-- types.+data RangeFile = RangeFile+  { rangeFilePath :: !AbsolutePath+    -- ^ The file's path.+  , rangeFileName :: !(Maybe TopLevelModuleName)+    -- ^ The file's top-level module name.+    --+    -- This field is optional, but some things may break if the field+    -- is not instantiated with an actual top-level module name. For+    -- instance, the 'Eq' and 'Ord' instances only make use of this+    -- field.+    --+    -- The field uses 'Maybe' rather than 'Strict.Maybe' because it+    -- should be possible to instantiate it with something that is not+    -- yet defined (see 'Agda.Interaction.Imports.parseSource').+    --+    -- This 'TopLevelModuleName' should not contain a range.+  }+  deriving (Show, Generic)++-- | A smart constructor for 'RangeFile'.++mkRangeFile :: AbsolutePath -> Maybe TopLevelModuleName -> RangeFile+mkRangeFile f top = RangeFile+  { rangeFilePath = f+  , rangeFileName = killRange top+  }++-- | Only the 'rangeFileName' component is compared.++instance Eq RangeFile where+  (==) = (==) `on` rangeFileName++-- | Only the 'rangeFileName' component is compared.++instance Ord RangeFile where+  compare = compare `on` rangeFileName++instance NFData RangeFile where+  rnf (RangeFile _ n) = rnf n+ type Position            = Position' SrcFile type PositionWithoutFile = Position' () @@ -145,7 +194,7 @@ -- -- Note the invariant which intervals have to satisfy: 'intervalInvariant'. data Interval' a = Interval { iStart, iEnd :: !(Position' a) }-  deriving (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic)+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)  type Interval            = Interval' SrcFile type IntervalWithoutFile = Interval' ()@@ -196,7 +245,7 @@   = NoRange   | Range !a (Seq IntervalWithoutFile)   deriving-    (Show, Data, Eq, Ord, Functor, Foldable, Traversable, Generic)+    (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)  type Range = Range' SrcFile @@ -208,19 +257,17 @@    empty = NoRange -instance Semigroup a => Semigroup (Range' a) where+instance Eq a => Semigroup (Range' a) where   NoRange <> r = r   r <> NoRange = r-  Range f is <> Range f' is' = Range (f <> f') (is <> is')+  Range f is <> Range f' is'+    | f /= f'   = __IMPOSSIBLE__+    | otherwise = Range f (is <> is') -instance Semigroup a => Monoid (Range' a) where+instance Eq a => Monoid (Range' a) where   mempty  = empty   mappend = (<>) --- | To get @'Semigroup' 'Range'@, we need a semigroup instance for 'AbsolutePath'.-instance Semigroup AbsolutePath where-  f <> f' = if f == f' then f else __IMPOSSIBLE__- -- | The intervals that make up the range. The intervals are -- consecutive and separated ('consecutiveAndSeparated'). rangeIntervals :: Range' a -> [IntervalWithoutFile]@@ -261,6 +308,20 @@ rangeFile NoRange     = Strict.Nothing rangeFile (Range f _) = f +-- | The range's top-level module name, if any.+--+-- If there is no range, then 'Nothing' is returned. If there is a+-- range without a module name, then @'Just' 'Nothing'@ is returned.+rangeModule' :: Range -> Maybe (Maybe TopLevelModuleName)+rangeModule' NoRange     = Nothing+rangeModule' (Range f _) = Just $ case f of+  Strict.Nothing -> Nothing+  Strict.Just f  -> rangeFileName f++-- | The range's top-level module name, if any.+rangeModule :: Range -> Maybe TopLevelModuleName+rangeModule = join . rangeModule'+ -- | Conflate a range to its right margin. rightMargin :: Range -> Range rightMargin r@NoRange      = r@@ -543,6 +604,9 @@ -- Printing ------------------------------------------------------------------------ +instance Pretty RangeFile where+  pretty = pretty . rangeFilePath+ instance Pretty a => Pretty (Position' (Strict.Maybe a)) where   pretty (Pn Strict.Nothing  _ l c) = pretty l <> "," <> pretty c   pretty (Pn (Strict.Just f) _ l c) =@@ -594,7 +658,7 @@   }  -- | The first position in a file: position 1, line 1, column 1.-startPos :: Maybe AbsolutePath -> Position+startPos :: Maybe RangeFile -> Position startPos = startPos' . Strict.toStrict  -- | Ranges between two unknown positions@@ -612,8 +676,8 @@ -- | Advance the position by a string. -- --   > movePosByString = foldl' movePos-movePosByString :: Position' a -> String -> Position' a-movePosByString = foldl' movePos+movePosByString :: Foldable t => Position' a -> t Char -> Position' a+movePosByString = Fold.foldl' movePos  -- | Backup the position by one character. --
+ src/full/Agda/Syntax/Position.hs-boot view
@@ -0,0 +1,3 @@+module Agda.Syntax.Position where++class KillRange a
src/full/Agda/Syntax/Scope/Base.hs view
@@ -12,7 +12,7 @@  import Data.Either (partitionEithers) import Data.Foldable ( length, toList )-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map@@ -21,8 +21,6 @@ import Data.Maybe import Data.Semigroup ( Semigroup(..) ) -import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Benchmarking@@ -41,7 +39,9 @@ import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.List1 ( List1, pattern (:|) )+import Agda.Utils.List2 ( List2 ) import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe (filterMaybe) import Agda.Utils.Null import Agda.Utils.Pretty hiding ((<>))@@ -62,19 +62,19 @@       , scopeImports        :: Map C.QName A.ModuleName       , scopeDatatypeModule :: Maybe DataOrRecordModule       }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  data DataOrRecordModule   = IsDataModule   | IsRecordModule-  deriving (Data, Show, Eq, Enum, Bounded, Generic)+  deriving (Show, Eq, Enum, Bounded, Generic)  -- | See 'Agda.Syntax.Common.Access'. data NameSpaceId   = PrivateNS        -- ^ Things not exported by this module.   | PublicNS         -- ^ Things defined and exported by this module.   | ImportedNS       -- ^ Things from open public, exported by this module.-  deriving (Data, Eq, Bounded, Enum, Show, Generic)+  deriving (Eq, Bounded, Enum, Show, Generic)  allNameSpaces :: [NameSpaceId] allNameSpaces = [minBound..maxBound]@@ -121,7 +121,7 @@       , _scopeFixities      :: C.Fixities    -- ^ Maps concrete names C.Name to fixities       , _scopePolarities    :: C.Polarities  -- ^ Maps concrete names C.Name to polarities       }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | For the sake of highlighting, the '_scopeInverseName' map also stores --   the 'KindOfName' of an @A.QName@.@@ -129,7 +129,7 @@   { qnameKind     :: KindOfName     -- ^ The 'anameKind'.   , qnameConcrete :: List1 C.QName  -- ^ Possible renderings of the abstract name.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | Invariant: the 'KindOfName' components should be equal --   whenever we have to concrete renderings of an abstract name.@@ -154,7 +154,7 @@   | PatternBound -- ^ @f ... =@   | LetBound     -- ^ @let ... in@   | WithBound    -- ^ @| ... in q@-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  instance Pretty BindingSource where   pretty = \case@@ -175,7 +175,7 @@      -- ^ If this list is not empty, the local variable is      --   shadowed by one or more imports.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  instance Eq LocalVar where   (==) = (==) `on` localVar@@ -310,7 +310,7 @@         -- ^ All abstract names targeted by a concrete name in scope.         --   Computed by 'recomputeInScopeSets'.       }-  deriving (Data, Eq, Show, Generic)+  deriving (Eq, Show, Generic)  type ThingsInScope a = Map C.Name [a] type NamesInScope    = ThingsInScope AbstractName@@ -344,7 +344,7 @@  -- | Non-dependent tag for name or module. data NameOrModule = NameNotModule | ModuleNotName-  deriving (Data, Eq, Ord, Show, Enum, Bounded, Generic)+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)  ------------------------------------------------------------------------ -- * Decorated names@@ -375,7 +375,7 @@   | PrimName                 -- ^ Name of a @primitive@.   | OtherDefName             -- ^ A @DefName@, but either other kind or don't know which kind.   -- End @DefName@.  Keep these together in sequence, for sake of @isDefName@!-  deriving (Eq, Ord, Show, Data, Enum, Bounded, Generic)+  deriving (Eq, Ord, Show, Enum, Bounded, Generic)  isDefName :: KindOfName -> Bool isDefName = (>= DataName)@@ -437,7 +437,7 @@ data WithKind a = WithKind   { theKind     :: KindOfName   , kindedThing :: a-  } deriving (Data, Show, Eq, Ord, Functor, Foldable, Traversable)+  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)  -- | Where does a name come from? --@@ -450,7 +450,7 @@     -- ^ Imported from another module.   | Applied C.QName WhyInScope     -- ^ Imported by a module application.-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | A decoration of 'Agda.Syntax.Abstract.Name.QName'. data AbstractName = AbsName@@ -464,11 +464,11 @@     -- ^ Additional information needed during scope checking. Currently used     --   for generalized data/record params.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  data NameMetadata = NoMetadata                   | GeneralizedVarsMetadata (Map A.QName A.Name)-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  -- | A decoration of abstract syntax module names. data AbstractModule = AbsModule@@ -477,7 +477,7 @@   , amodLineage :: WhyInScope     -- ^ Explanation where this name came from.   }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  instance Eq AbstractName where   (==) = (==) `on` anameName@@ -524,7 +524,7 @@    | -- | Unbound name.     UnknownName-  deriving (Data, Show, Eq, Generic)+  deriving (Show, Eq, Generic)  instance Pretty ResolvedName where   pretty = \case@@ -539,6 +539,40 @@   pretty NoSuffix   = mempty   pretty (Suffix i) = text (show i) +-- | Why is a resolved name ambiguous?  What did it resolve to?+--+--   Invariant (statically enforced): At least two resolvents in total.+data AmbiguousNameReason+  = AmbiguousLocalVar LocalVar (List1 AbstractName)+      -- ^ The name resolves both to a local variable and some declared names.+  | AmbiguousDeclName (List2 AbstractName)+      -- ^ The name resolves to at least 2 declared names.+  deriving (Show, Generic)++-- | The flat list of ambiguous names in 'AmbiguousNameReason'.+ambiguousNamesInReason :: AmbiguousNameReason -> List2 (A.QName)+ambiguousNamesInReason = \case+  AmbiguousLocalVar (LocalVar y _ _) xs -> List2.cons (A.qualify_ y) $ fmap anameName xs+  AmbiguousDeclName xs -> fmap anameName xs++data WhyInScopeData+  = WhyInScopeData+      C.QName+        -- ^ The name @x@ this explanation is about.+      FilePath+        -- ^ The directory in which the current module resides.+      (Maybe LocalVar)+        -- ^ The local variable that @x@ could denote, if any.+      [AbstractName]+        -- ^ The defined names that @x@ could denote.+      [AbstractModule]+        -- ^ The modules that @x@ could denote.++whyInScopeDataFromAmbiguousNameReason :: C.QName -> AmbiguousNameReason -> WhyInScopeData+whyInScopeDataFromAmbiguousNameReason q = \case+  AmbiguousLocalVar x ys -> WhyInScopeData q empty (Just x) (toList ys) empty+  AmbiguousDeclName ys   -> WhyInScopeData q empty Nothing  (toList ys) empty+ -- * Operations on name and module maps.  mergeNames :: Eq a => ThingsInScope a -> ThingsInScope a -> ThingsInScope a@@ -725,6 +759,16 @@   mergeNamesMany [ map (, nameSpaceAccess nsId) <$> inNameSpace ns                  | (nsId, ns) <- scopeNameSpaces s ] +-- | Look up a single name in the current scope.+--+-- This is equivalent to @Map.lookup n . allNamesInScope'@, but more efficient+-- when only a single name needs to be looked up.+findNameInScope :: InScope a => C.Name -> Scope -> [(a, Access)]+findNameInScope n s =+  [ (name, nameSpaceAccess nsId)+  | (nsId, ns) <- scopeNameSpaces s+  , name <- Map.findWithDefault [] n $ inNameSpace ns ]+ -- | Returns the scope's non-private names. exportedNamesInScope :: InScope a => Scope -> ThingsInScope a exportedNamesInScope = namesInScope [PublicNS, ImportedNS]@@ -1031,41 +1075,6 @@         imports = map lookP $ Map.elems $ scopeImports s         submods = map (lookP . amodName) $ concat $ Map.elems $ Map.filterWithKey inscope $ allNamesInScope s --- | Compute a flattened scope. Only include unqualified names or names--- qualified by modules in the first argument.-flattenScope :: [[C.Name]] -> ScopeInfo -> Map C.QName [AbstractName]-flattenScope ms scope =-  Map.unionWith (++)-    (build ms allNamesInScope root)-    imported-  where-    current = moduleScope $ scope ^. scopeCurrent-    root    = mergeScopes $ current : map moduleScope (scopeParents current)--    imported = Map.unionsWith (++)-               [ qual c (build ms' exportedNamesInScope $ moduleScope a)-               | (c, a) <- Map.toList $ scopeImports root-               , let -- get the suffixes of c in ms-                     ms' = mapMaybe (List.stripPrefix $ List1.toList $ C.qnameParts c) ms-               , not $ null ms' ]-    qual c = Map.mapKeys (q c)-      where-        q (C.QName x)  = C.Qual x-        q (C.Qual m x) = C.Qual m . q x--    build :: [[C.Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map C.QName [AbstractName]-    build ms getNames s = Map.unionsWith (++) $-        Map.mapKeysMonotonic C.QName (getNames s) :-          [ Map.mapKeysMonotonic (\ y -> C.Qual x y) $-              build ms' exportedNamesInScope $ moduleScope m-          | (x, mods) <- Map.toList (getNames s)-          , let ms' = [ tl | hd:tl <- ms, hd == x ]-          , not $ null ms'-          , AbsModule m _ <- mods ]--    moduleScope :: A.ModuleName -> Scope-    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules- -- | Get all concrete names in scope. Includes bound variables. concreteNamesInScope :: ScopeInfo -> Set C.QName concreteNamesInScope scope =@@ -1086,7 +1095,9 @@      build :: (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Set C.QName     build getNames s = Set.unions $-        Set.fromList (map C.QName $ Map.keys (getNames s :: ThingsInScope AbstractName)) :+        Set.fromAscList+          (map C.QName $+           Map.keys (getNames s :: ThingsInScope AbstractName)) :           [ Set.mapMonotonic (\ y -> C.Qual x y) $               build exportedNamesInScope $ moduleScope m           | (x, mods) <- Map.toList (getNames s)@@ -1120,16 +1131,16 @@     -- Find a concrete, possibly qualified name in scope @s@.     findName :: forall a. InScope a => C.QName -> Scope -> [(a, Access)]     findName q0 s = case q0 of-      C.QName x  -> lookupName x s+      C.QName x  -> findNameInScope x s       C.Qual x q -> do         let -- Get the modules named @x@ in scope @s@.             mods :: [A.ModuleName]-            mods = amodName . fst <$> lookupName x s+            mods = amodName . fst <$> findNameInScope x s             -- Get the definitions named @x@ in scope @s@ and interpret them as modules.             -- Andreas, 2013-05-01: Issue 836 debates this feature:             -- Qualified constructors are qualified by their datatype rather than a module             defs :: [A.ModuleName] -- NB:: Defined but not used-            defs = qnameToMName . anameName . fst <$> lookupName x s+            defs = qnameToMName . anameName . fst <$> findNameInScope x s         -- Andreas, 2013-05-01:  Issue 836 complains about the feature         -- that constructors can also be qualified by their datatype         -- and projections by their record type.  This feature is off@@ -1145,9 +1156,6 @@         -- trace ("ss' = " ++ show ss') $ do         s' <- maybeToList ss'         findName q s'-      where-        lookupName :: forall a. InScope a => C.Name -> Scope -> [(a, Access)]-        lookupName x s = fromMaybe [] $ Map.lookup x $ allNamesInScope' s      -- 2. Finding a name in the top imports. @@ -1438,3 +1446,4 @@ instance NFData NameMetadata instance NFData AbstractModule instance NFData ResolvedName+instance NFData AmbiguousNameReason
+ src/full/Agda/Syntax/Scope/Flat.hs view
@@ -0,0 +1,106 @@+-- | Flattened scopes.+module Agda.Syntax.Scope.Flat+  ( FlatScope+  , flattenScope+  , getDefinedNames+  , localNames+  ) where++import Data.Bifunctor+import Data.Either (partitionEithers)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map++import qualified Agda.Syntax.Abstract.Name as A+import Agda.Syntax.Concrete+import Agda.Syntax.Notation+import Agda.Syntax.Scope.Base+import Agda.Syntax.Scope.Monad++import Agda.TypeChecking.Monad.Debug++import Agda.Utils.Impossible+import Agda.Utils.Lens+import Agda.Utils.List+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Maybe+import Agda.Utils.Pretty++-- | Flattened scopes.+newtype FlatScope = Flat (Map QName [AbstractName])+  deriving Pretty++-- | Compute a flattened scope. Only include unqualified names or names+-- qualified by modules in the first argument.+flattenScope :: [[Name]] -> ScopeInfo -> FlatScope+flattenScope ms scope =+  Flat $+  Map.unionWith (++)+    (build ms allNamesInScope root)+    imported+  where+    current = moduleScope $ scope ^. scopeCurrent+    root    = mergeScopes $ current : map moduleScope (scopeParents current)++    imported = Map.unionsWith (++)+               [ qual c (build ms' exportedNamesInScope $ moduleScope a)+               | (c, a) <- Map.toList $ scopeImports root+               , let -- get the suffixes of c in ms+                     ms' = mapMaybe (List.stripPrefix $ List1.toList $ qnameParts c) ms+               , not $ null ms' ]+    qual c = Map.mapKeysMonotonic (q c)+      where+        q (QName x)  = Qual x+        q (Qual m x) = Qual m . q x++    build :: [[Name]] -> (forall a. InScope a => Scope -> ThingsInScope a) -> Scope -> Map QName [AbstractName]+    build ms getNames s = Map.unionsWith (++) $+        Map.mapKeysMonotonic QName (getNames s) :+          [ Map.mapKeysMonotonic (\ y -> Qual x y) $+              build ms' exportedNamesInScope $ moduleScope m+          | (x, mods) <- Map.toList (getNames s)+          , let ms' = [ tl | hd:tl <- ms, hd == x ]+          , not $ null ms'+          , AbsModule m _ <- mods ]++    moduleScope :: A.ModuleName -> Scope+    moduleScope m = fromMaybe __IMPOSSIBLE__ $ Map.lookup m $ scope ^. scopeModules++-- | Compute all defined names in scope and their fixities/notations.+-- Note that overloaded names (constructors) can have several+-- fixities/notations. Then we 'mergeNotations'. (See issue 1194.)+getDefinedNames :: KindsOfNames -> FlatScope -> [[NewNotation]]+getDefinedNames kinds (Flat names) =+  [ mergeNotations $ map (namesToNotation x . A.qnameName . anameName) ds+  | (x, ds) <- Map.toList names+  , any ((`elemKindsOfNames` kinds) . anameKind) ds+  , not (null ds)+  ]+  -- Andreas, 2013-03-21 see Issue 822+  -- Names can have different kinds, i.e., 'defined' and 'constructor'.+  -- We need to consider all names that have *any* matching kind,+  -- not only those whose first appearing kind is matching.++-- | Compute all names (first component) and operators/notations+-- (second component) in scope.+localNames :: FlatScope -> ScopeM ([QName], [NewNotation])+localNames flat = do+  let defs = getDefinedNames allKindsOfNames flat+  locals <- nubOn fst . notShadowedLocals <$> getLocalVars+  -- Note: Debug printout aligned with the one in+  -- Agda.Syntax.Concrete.Operators.buildParsers.+  reportS "scope.operators" 50+    [ "flat  = " ++ prettyShow flat+    , "defs  = " ++ prettyShow defs+    , "locals= " ++ prettyShow locals+    ]+  let localNots  = map localOp locals+      notLocal   = not . hasElem (map notaName localNots) . notaName+      otherNots  = concatMap (filter notLocal) defs+  return $ second (map useDefaultFixity) $ split $ localNots ++ otherNots+  where+    localOp (x, y) = namesToNotation (QName x) y+    split          = partitionEithers . concatMap opOrNot+    opOrNot n      = Left (notaName n) :+                     [Right n | not (null (notation n))]
src/full/Agda/Syntax/Scope/Monad.hs view
@@ -51,8 +51,8 @@ import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List-import Agda.Utils.List1 (List1, pattern (:|), nonEmpty)-import Agda.Utils.List2 (List2(List2))+import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, toList)+import Agda.Utils.List2 (List2(List2), toList) import qualified Agda.Utils.List1 as List1 import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe@@ -328,11 +328,15 @@ resolveName' ::   KindsOfNames -> Maybe (Set A.Name) -> C.QName -> ScopeM ResolvedName resolveName' kinds names x = runExceptT (tryResolveName kinds names x) >>= \case-  Left ys  -> traceCall (SetRange $ getRange x) $ typeError $ AmbiguousName x ys+  Left reason  -> do+    reportS "scope.resolve" 60 $ unlines $+      "resolveName': ambiguous name" :+      map (show . qnameName) (toList $ ambiguousNamesInReason reason)+    setCurrentRange x $ typeError $ AmbiguousName x reason   Right x' -> return x'  tryResolveName-  :: (ReadTCState m, HasBuiltins m, MonadError (List1 A.QName) m)+  :: forall m. (ReadTCState m, HasBuiltins m, MonadError AmbiguousNameReason m)   => KindsOfNames       -- ^ Restrict search to these kinds of names.   -> Maybe (Set A.Name) -- ^ Unless 'Nothing', restrict search to match any of these names.   -> C.QName            -- ^ Name to be resolved@@ -341,13 +345,14 @@   scope <- getScope   let vars     = AssocList.mapKeysMonotonic C.QName $ scope ^. scopeLocals   case lookup x vars of+     -- Case: we have a local variable x, but is (perhaps) shadowed by some imports ys.-    Just (LocalVar y b ys) ->+    Just var@(LocalVar y b ys) ->       -- We may ignore the imports filtered out by the @names@ filter.-      ifNull (filterNames id ys)-        {-then-} (return $ VarName y{ nameConcrete = unqualify x } b)-        {-else-} $ \ ys' ->-          throwError $ A.qualify_ y :| map anameName ys'+      case nonEmpty $ filterNames id ys of+        Nothing  -> return $ VarName y{ nameConcrete = unqualify x } b+        Just ys' -> throwError $ AmbiguousLocalVar var ys'+     -- Case: we do not have a local variable x.     Nothing -> do       -- Consider only names that are in the given set of names and@@ -372,15 +377,19 @@         Just ds  | all ((PatternSynName ==) . anameKind . fst) ds , isNothing suffixedNames ->           return $ PatternSynResName $ fmap (upd . fst) ds -        Just ((d, a) :| []) | isNothing suffixedNames ->-          return $ DefinedName a (upd d) A.NoSuffix--        Just ds -> throwError $ fmap (anameName . fst) $ caseMaybe suffixedNames id ((<>) . snd) ds+        Just ((d, a) :| ds) -> case (suffixedNames, ds) of+          (Nothing, []) ->+            return $ DefinedName a (upd d) A.NoSuffix+          (Nothing, (d',_) : ds') ->+            throwError $ AmbiguousDeclName $ List2 d d' $ map fst ds'+          (Just (_, ss), _) ->+            throwError $ AmbiguousDeclName $ List2.append (d :| map fst ds) (fmap fst ss)          Nothing -> case suffixedNames of           Nothing -> return UnknownName           Just (suffix , (d, a) :| []) -> return $ DefinedName a (upd d) suffix-          Just (suffix , sds) -> throwError $ fmap (anameName . fst) sds+          Just (suffix , (d1,_) :| (d2,_) : sds) ->+            throwError $ AmbiguousDeclName $ List2 d1 d2 $ map fst sds    where   -- @names@ intended semantics: a filter on names.@@ -529,7 +538,13 @@ --   later on. rebindName :: Access -> KindOfName -> C.Name -> A.QName -> ScopeM () rebindName acc kind x y = do-  modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x+  if kind == ConName+    then modifyCurrentScope $+           mapScopeNS (localNameSpace acc)+                      (Map.update (toList <.> nonEmpty . (filter ((==) ConName . anameKind))) x)+                      id+                      id+    else modifyCurrentScope $ removeNameFromScope (localNameSpace acc) x   bindName acc kind x y  -- | Bind a module name.@@ -1004,11 +1019,15 @@             modClashes = filter (\ (_c, as) -> length as >= 2) $ Map.toList $ nsModules exported              -- No ambiguity if concrete identifier is only mapped to-            -- constructor names or only to projection names.-            defClash (_, qs) = not $ all (isJust . isConName) ks || all (==FldName) ks+            -- constructor names or only to projection names or only to pattern synonyms.+            defClash (_, qs) = not $ or+              [ all (isJust . isConName) ks+              , all (== FldName)         ks+              , all (== PatternSynName)  ks+              ]               where ks = map anameKind qs         -- We report the first clashing exported identifier.-        unlessNull (filter (\ x -> defClash x) defClashes) $+        unlessNull (filter defClash defClashes) $           \ ((x, q:_) : _) -> typeError $ ClashingDefinition (C.QName x) (anameName q) Nothing          unlessNull modClashes $ \ ((_, ms) : _) -> do
+ src/full/Agda/Syntax/TopLevelModuleName.hs view
@@ -0,0 +1,237 @@+------------------------------------------------------------------------+-- Top-level module names+------------------------------------------------------------------------++module Agda.Syntax.TopLevelModuleName where++import Control.DeepSeq++import Data.Function (on)+import Data.Hashable+import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as T++import GHC.Generics (Generic)++import System.FilePath++import qualified Agda.Syntax.Abstract.Name as A+import Agda.Syntax.Common+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Position++import Agda.Utils.BiMap (HasTag(..))+import Agda.Utils.FileName+import Agda.Utils.Hash+import Agda.Utils.Impossible+import Agda.Utils.Lens+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1+import Agda.Utils.Pretty+import Agda.Utils.Singleton+import Agda.Utils.Size++------------------------------------------------------------------------+-- Raw top-level module names++-- | A top-level module name has one or more name parts.++type TopLevelModuleNameParts = List1 Text++-- | Raw top-level module names (with linear-time comparisons).++data RawTopLevelModuleName = RawTopLevelModuleName+  { rawModuleNameRange :: Range+  , rawModuleNameParts :: TopLevelModuleNameParts+  }+  deriving (Show, Generic)++instance Eq RawTopLevelModuleName where+  (==) = (==) `on` rawModuleNameParts++instance Ord RawTopLevelModuleName where+  compare = compare `on` rawModuleNameParts++instance Sized RawTopLevelModuleName where+  size = size . rawModuleNameParts++instance Pretty RawTopLevelModuleName where+  pretty = text . rawTopLevelModuleNameToString++instance HasRange RawTopLevelModuleName where+  getRange = rawModuleNameRange++instance SetRange RawTopLevelModuleName where+  setRange r (RawTopLevelModuleName _ x) = RawTopLevelModuleName r x++instance KillRange RawTopLevelModuleName where+  killRange (RawTopLevelModuleName _ x) =+    RawTopLevelModuleName noRange x++instance C.IsNoName RawTopLevelModuleName where+  isNoName m = rawModuleNameParts m == singleton "_"++-- | The 'Range' is not forced.++instance NFData RawTopLevelModuleName where+  rnf (RawTopLevelModuleName _ x) = rnf x++-- | Turns a raw top-level module name into a string.++rawTopLevelModuleNameToString :: RawTopLevelModuleName -> String+rawTopLevelModuleNameToString =+  List.intercalate "." .+  map T.unpack . List1.toList . rawModuleNameParts++-- | Hashes a raw top-level module name.++hashRawTopLevelModuleName :: RawTopLevelModuleName -> ModuleNameHash+hashRawTopLevelModuleName =+  ModuleNameHash . hashString . rawTopLevelModuleNameToString++-- | Turns a qualified name into a 'RawTopLevelModuleName'. The+-- qualified name is assumed to represent a top-level module name.++rawTopLevelModuleNameForQName :: C.QName -> RawTopLevelModuleName+rawTopLevelModuleNameForQName q = RawTopLevelModuleName+  { rawModuleNameRange = getRange q+  , rawModuleNameParts =+      fmap (T.pack . C.nameToRawName) $ C.qnameParts q+  }++-- | Computes the 'RawTopLevelModuleName' corresponding to the given+-- module name, which is assumed to represent a top-level module name.+--+-- Precondition: The module name must be well-formed.++rawTopLevelModuleNameForModuleName ::+  A.ModuleName -> RawTopLevelModuleName+rawTopLevelModuleNameForModuleName (A.MName []) = __IMPOSSIBLE__+rawTopLevelModuleNameForModuleName (A.MName ms) =+  List1.ifNull ms __IMPOSSIBLE__ $ \ms ->+  RawTopLevelModuleName+    { rawModuleNameRange = getRange ms+    , rawModuleNameParts =+        fmap (T.pack . C.nameToRawName . A.nameConcrete) ms+    }++-- | Computes the top-level module name.+--+-- Precondition: The 'C.Module' has to be well-formed.+-- This means that there are only allowed declarations before the+-- first module declaration, typically import declarations.+-- See 'spanAllowedBeforeModule'.++rawTopLevelModuleNameForModule :: C.Module -> RawTopLevelModuleName+rawTopLevelModuleNameForModule (C.Mod _ []) = __IMPOSSIBLE__+rawTopLevelModuleNameForModule (C.Mod _ ds) =+  case C.spanAllowedBeforeModule ds of+    (_, C.Module _ n _ _ : _) -> rawTopLevelModuleNameForQName n+    _                         -> __IMPOSSIBLE__++------------------------------------------------------------------------+-- Top-level module names++-- | Top-level module names (with constant-time comparisons).++data TopLevelModuleName = TopLevelModuleName+  { moduleNameRange :: Range+  , moduleNameId    :: {-# UNPACK #-} !ModuleNameHash+  , moduleNameParts :: TopLevelModuleNameParts+  }+  deriving (Show, Generic)++instance HasTag TopLevelModuleName where+  type Tag TopLevelModuleName = ModuleNameHash+  tag = Just . moduleNameId++instance Eq TopLevelModuleName where+  (==) = (==) `on` moduleNameId++instance Ord TopLevelModuleName where+  compare = compare `on` moduleNameId++instance Hashable TopLevelModuleName where+  hashWithSalt salt = hashWithSalt salt . moduleNameId++instance Sized TopLevelModuleName where+  size = size . rawTopLevelModuleName++instance Pretty TopLevelModuleName where+  pretty = pretty . rawTopLevelModuleName++instance HasRange TopLevelModuleName where+  getRange = moduleNameRange++instance SetRange TopLevelModuleName where+  setRange r (TopLevelModuleName _ h x) = TopLevelModuleName r h x++instance KillRange TopLevelModuleName where+  killRange (TopLevelModuleName _ h x) = TopLevelModuleName noRange h x++-- | The 'Range' is not forced.++instance NFData TopLevelModuleName where+  rnf (TopLevelModuleName _ x y) = rnf (x, y)++-- | A lens focusing on the 'moduleNameParts'.++lensTopLevelModuleNameParts ::+  Lens' TopLevelModuleNameParts TopLevelModuleName+lensTopLevelModuleNameParts f m =+  f (moduleNameParts m) <&> \ xs -> m{ moduleNameParts = xs }++-- | Converts a top-level module name to a raw top-level module name.++rawTopLevelModuleName :: TopLevelModuleName -> RawTopLevelModuleName+rawTopLevelModuleName m = RawTopLevelModuleName+  { rawModuleNameRange = moduleNameRange m+  , rawModuleNameParts = moduleNameParts m+  }++-- | Converts a raw top-level module name and a hash to a top-level+-- module name.+--+-- This function does not ensure that there are no hash collisions,+-- that is taken care of by+-- 'Agda.TypeChecking.Monad.State.topLevelModuleName'.++unsafeTopLevelModuleName ::+  RawTopLevelModuleName -> ModuleNameHash -> TopLevelModuleName+unsafeTopLevelModuleName m h = TopLevelModuleName+  { moduleNameRange = rawModuleNameRange m+  , moduleNameParts = rawModuleNameParts m+  , moduleNameId    = h+  }++-- | A corresponding 'C.QName'. The range of each 'Name' part is the+-- whole range of the 'TopLevelModuleName'.++topLevelModuleNameToQName :: TopLevelModuleName -> C.QName+topLevelModuleNameToQName m =+  List1.foldr C.Qual C.QName $+  fmap (C.Name (getRange m) C.NotInScope .+        C.stringNameParts . T.unpack) $+  moduleNameParts m++-- | Turns a top-level module name into a file name with the given+-- suffix.++moduleNameToFileName :: TopLevelModuleName -> String -> FilePath+moduleNameToFileName TopLevelModuleName{ moduleNameParts = ms } ext =+  joinPath (map T.unpack $ List1.init ms) </>+  T.unpack (List1.last ms) <.> ext++-- | Finds the current project's \"root\" directory, given a project+-- file and the corresponding top-level module name.+--+-- Example: If the module \"A.B.C\" is located in the file+-- \"/foo/A/B/C.agda\", then the root is \"/foo/\".+--+-- Precondition: The module name must be well-formed.++projectRoot :: AbsolutePath -> TopLevelModuleName -> AbsolutePath+projectRoot file TopLevelModuleName{ moduleNameParts = m } =+  mkAbsolute $+    iterate takeDirectory (filePath file) !! length m
+ src/full/Agda/Syntax/TopLevelModuleName.hs-boot view
@@ -0,0 +1,13 @@+module Agda.Syntax.TopLevelModuleName where++import Control.DeepSeq++import {-# SOURCE #-} Agda.Syntax.Position (KillRange)++data TopLevelModuleName++instance Eq        TopLevelModuleName+instance Ord       TopLevelModuleName+instance Show      TopLevelModuleName+instance NFData    TopLevelModuleName+instance KillRange TopLevelModuleName
src/full/Agda/Syntax/Translation/AbstractToConcrete.hs view
@@ -36,15 +36,15 @@  import qualified Data.Map as Map import Data.Maybe-import Data.Monoid+import Data.Monoid hiding ((<>)) import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Foldable as Fold import Data.Void import Data.List (sortBy)-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty+import Data.Semigroup (Semigroup, (<>))+import Data.String  import Agda.Syntax.Common import Agda.Syntax.Position@@ -64,8 +64,13 @@  import Agda.TypeChecking.Monad.State (getScope, getAllPatternSyns) import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.MetaVars+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Signature+import {-# SOURCE #-} Agda.TypeChecking.Pretty (prettyTCM) import Agda.Interaction.Options  import qualified Agda.Utils.AssocList as AssocList@@ -79,7 +84,7 @@ import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null-import Agda.Utils.Pretty+import Agda.Utils.Pretty hiding ((<>)) import Agda.Utils.Singleton import Agda.Utils.Suffix @@ -91,7 +96,7 @@                   -- ^ Abstract names currently in scope. Unlike the                   --   ScopeInfo, this includes names for hidden                   --   arguments inserted by the system.-               , takenDefNames :: Set C.Name+               , takenDefNames :: Set C.NameParts                   -- ^ Concrete names of all definitions in scope                , currentScope :: ScopeInfo                , builtins     :: Map String A.QName@@ -132,15 +137,21 @@         , foldPatternSynonyms = foldPatSyns         }   where+    defs = Set.map nameParts . Map.keysSet $+        Map.filterWithKey usefulDef $+        nsNames $ everythingInScope scope+     -- Jesper, 2018-12-10: It's fine to shadow generalizable names as     -- they will never show up directly in printed terms.     notGeneralizeName AbsName{ anameKind = k }  =       not (k == GeneralizeName || k == DisallowedGeneralizeName) -    defs = Map.keysSet $-           Map.filter (all notGeneralizeName) $-           nsNames $ everythingInScope scope+    usefulDef C.NoName{} _ = False+    usefulDef C.Name{} names = all notGeneralizeName names +    nameParts (C.NoName {}) = __IMPOSSIBLE__+    nameParts (C.Name { nameNameParts }) = nameNameParts+ currentPrecedence :: AbsToCon PrecedenceStack currentPrecedence = asks $ (^. scopePrecedence) . currentScope @@ -179,7 +190,7 @@   where is m q b = Just q == Map.lookup b m  -- | Resolve a concrete name. If illegally ambiguous fail with the ambiguous names.-resolveName :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> AbsToCon (Either (NonEmpty A.QName) ResolvedName)+resolveName :: KindsOfNames -> Maybe (Set A.Name) -> C.QName -> AbsToCon (Either AmbiguousNameReason ResolvedName) resolveName kinds candidates q = runExceptT $ tryResolveName kinds candidates q  -- | Treat illegally ambiguous names as UnknownNames.@@ -188,20 +199,17 @@  -- The Monad -------------------------------------------------------------- --- | We need:---   - Read access to the AbsToCon environment---   - Read access to the TC environment---   - Read access to the TC state---   - Read and write access to the stConcreteNames part of the TC state---   - Read access to the options---   - Permission to print debug messages+-- | The function 'runAbsToCon' can target any monad that satisfies+-- the constraints of 'MonadAbsToCon'. type MonadAbsToCon m =-  ( MonadTCEnv m-  , ReadTCState m+  ( MonadFresh NameId m+  , MonadInteractionPoints m   , MonadStConcreteNames m   , HasOptions m-  , HasBuiltins m-  , MonadDebug m+  , PureTCM m+  , IsString (m Doc)+  , Null (m Doc)+  , Semigroup (m Doc)   )  newtype AbsToCon a = AbsToCon@@ -261,10 +269,48 @@   traceDebugMessage  k n s cont = AbsToCon $ traceDebugMessage  k n s $ unAbsToCon cont  -- can't eta-reduce!   verboseBracket     k n s cont = AbsToCon $ verboseBracket     k n s $ unAbsToCon cont  -- because of GHC-9.0 -  getVerbosity     = defaultGetVerbosity-  isDebugPrinting  = defaultIsDebugPrinting-  nowDebugPrinting = defaultNowDebugPrinting+  getVerbosity      = defaultGetVerbosity+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting +instance HasConstInfo AbsToCon where+  getConstInfo' a      = AbsToCon (getConstInfo' a)+  getRewriteRulesFor a = AbsToCon (getRewriteRulesFor a)++instance MonadAddContext AbsToCon where+  addCtx a b c = AbsToCon (addCtx a b (unAbsToCon c))++  addLetBinding' a b c d =+    AbsToCon (addLetBinding' a b c (unAbsToCon d))++  updateContext a b c = AbsToCon (updateContext a b (unAbsToCon c))++  withFreshName a b c =+    AbsToCon (withFreshName a b (\x -> unAbsToCon (c x)))++instance MonadReduce AbsToCon where+  liftReduce a = AbsToCon (liftReduce a)++instance PureTCM AbsToCon where++instance MonadFresh NameId AbsToCon where+  fresh = AbsToCon fresh++instance MonadInteractionPoints AbsToCon where+  freshInteractionId        = AbsToCon freshInteractionId+  modifyInteractionPoints a = AbsToCon (modifyInteractionPoints a)++instance IsString (AbsToCon Doc) where+  fromString a = AbsToCon (fromString a)++instance Null (AbsToCon Doc) where+  empty = AbsToCon empty+  null  = __IMPOSSIBLE__++instance Semigroup (AbsToCon Doc) where+  a <> b = AbsToCon (unAbsToCon a <> unAbsToCon b)+ runAbsToCon :: MonadAbsToCon m => AbsToCon c -> m c runAbsToCon m = do   scope <- getScope@@ -362,7 +408,9 @@ -- | For the given abstract name, return the names that could shadow it. shadowingNames :: (ReadTCState m, MonadStConcreteNames m)                => A.Name -> m (Set RawName)-shadowingNames x = Set.fromList . Map.findWithDefault [] x <$> useR stShadowingNames+shadowingNames x =+  Set.fromList . Fold.toList . Map.findWithDefault mempty x <$>+    useR stShadowingNames  toConcreteName :: A.Name -> AbsToCon C.Name toConcreteName x | y <- nameConcrete x , isNoName y = return y@@ -399,13 +447,21 @@     return $ nameConcrete x   -- Otherwise we pick a name that does not shadow other names   _ -> do+    takenDefs <- asks takenDefNames     taken   <- takenNames     toAvoid <- shadowingNames x     glyphMode <- optUseUnicode <$> pragmaOptions     let freshNameMode = case glyphMode of           UnicodeOk -> A.UnicodeSubscript           AsciiOnly -> A.AsciiCounter-    let shouldAvoid = (`Set.member` (taken `Set.union` toAvoid)) . C.nameToRawName++        shouldAvoid C.NoName {} = False+        shouldAvoid name@C.Name { nameNameParts } =+          let raw = C.nameToRawName name in+          nameNameParts `Set.member` takenDefs ||+          raw `Set.member` taken ||+          raw `Set.member` toAvoid+         y = firstNonTakenName freshNameMode shouldAvoid $ nameConcrete x     reportSLn "toConcrete.bindName" 80 $ render $ vcat       [ "picking concrete name for:" <+> text (C.nameToRawName $ nameConcrete x)@@ -418,11 +474,10 @@   where     takenNames :: AbsToCon (Set RawName)     takenNames = do-      xs <- asks takenDefNames       ys0 <- asks takenVarNames       reportSLn "toConcrete.bindName" 90 $ render $ "abstract names of local vars: " <+> prettyList_ (map (C.nameToRawName . nameConcrete) $ Set.toList ys0)       ys <- Set.fromList . concat <$> mapM hasConcreteNames (Set.toList ys0)-      return $ Set.map C.nameToRawName $ xs `Set.union` ys+      return $ Set.map C.nameToRawName ys   -- | Add a abstract name to the scope and produce an available concrete version of it.@@ -680,9 +735,9 @@   toConcrete = \case     VarName x _          -> C.QName <$> toConcrete x     DefinedName _ x s    -> addSuffixConcrete s $ toConcrete x-    FieldName xs         -> toConcrete (NonEmpty.head xs)-    ConstructorName _ xs -> toConcrete (NonEmpty.head xs)-    PatternSynResName xs -> toConcrete (NonEmpty.head xs)+    FieldName xs         -> toConcrete (List1.head xs)+    ConstructorName _ xs -> toConcrete (List1.head xs)+    PatternSynResName xs -> toConcrete (List1.head xs)     UnknownName          -> __IMPOSSIBLE__  addSuffixConcrete :: HasOptions m => A.Suffix -> m C.QName -> m C.QName@@ -727,9 +782,10 @@       return $ C.QuestionMark (getRange i) $                  interactionId ii <$ guard (preserve || isJust (metaNumber i)) -    toConcrete (A.Underscore i)     = return $-      C.Underscore (getRange i) $-        prettyShow . NamedMeta (metaNameSuggestion i) . MetaId . metaId <$> metaNumber i+    toConcrete (A.Underscore i) =+      C.Underscore (getRange i) <$>+      traverse (render <.> prettyTCM)+        (NamedMeta (metaNameSuggestion i) <$> metaNumber i)      toConcrete (A.Dot i e) =       C.Dot (getRange i) <$> toConcrete e@@ -826,7 +882,7 @@                 reportSLn "extendedlambda" 50 $ "abstractToConcrete extended lambda patterns ps = " ++ prettyShow ps                 return $ LamClause ps rhs ca               decl2clause _ = __IMPOSSIBLE__-          C.ExtendedLam (getRange i) erased . List1.fromList <$>+          C.ExtendedLam (getRange i) erased . List1.fromListSafe __IMPOSSIBLE__ <$>             mapM decl2clause decls             -- TODO List1: can we demonstrate non-emptiness? @@ -875,8 +931,6 @@       bracket appBrackets $ do         C.RecUpdate (getRange i) <$> toConcrete e <*> toConcreteTop fs -    toConcrete (A.ETel tel) = C.ETel . catMaybes <$> toConcrete tel-     toConcrete (A.ScopedExpr _ e) = toConcrete e     toConcrete (A.Quote i) = return $ C.Quote (getRange i)     toConcrete (A.QuoteTerm i) = return $ C.QuoteTerm (getRange i)@@ -892,7 +946,7 @@ makeDomainFree b@(A.DomainFull (A.TBind _ tac (x :| []) t)) =   case unScope t of     A.Underscore A.MetaInfo{metaNumber = Nothing} ->-      A.DomainFree tac x+      A.DomainFree (tbTacticAttr tac) x     _ -> b makeDomainFree b = b @@ -946,10 +1000,10 @@     type ConOfAbs A.TypedBinding = Maybe C.TypedBinding      bindToConcrete (A.TBind r t xs e) ret = do-        t <- traverse toConcrete t+        tac <- traverse toConcrete (tbTacticAttr t)         bindToConcrete (fmap forceNameIfHidden xs) $ \ xs -> do           e <- toConcreteTop e-          let setTac x = x { bnameTactic = t }+          let setTac x = x { bnameTactic = tac , C.bnameIsFinite = tbFinite t }           ret $ Just $ C.TBind r (fmap (updateNamedArg (fmap setTac)) xs) e     bindToConcrete (A.TLet r lbs) ret =         bindToConcrete lbs $ \ ds -> do@@ -992,15 +1046,15 @@ instance ToConcrete A.WhereDeclarations where   type ConOfAbs A.WhereDeclarations = WhereClause -  bindToConcrete (A.WhereDecls _ Nothing) ret = ret C.NoWhere-  bindToConcrete (A.WhereDecls (Just am) (Just (A.Section _ _ _ ds))) ret = do+  bindToConcrete (A.WhereDecls _ _ Nothing) ret = ret C.NoWhere+  bindToConcrete (A.WhereDecls (Just am) False (Just (A.Section _ _ _ ds))) ret = do     ds' <- declsToConcrete ds     cm  <- unqualify <$> lookupModule am     -- Andreas, 2016-07-08 I put PublicAccess in the following SomeWhere     -- Should not really matter for printing...     let wh' = (if isNoName cm then AnyWhere noRange else SomeWhere noRange cm PublicAccess) $ ds'     local (openModule' am defaultImportDir id) $ ret wh'-  bindToConcrete (A.WhereDecls _ (Just d)) ret =+  bindToConcrete (A.WhereDecls _ _ (Just d)) ret =     ret . AnyWhere noRange =<< toConcrete d  mergeSigAndDef :: [C.Declaration] -> [C.Declaration]@@ -1223,7 +1277,9 @@     xs <- mapM (unqual <=< toConcrete) xs     (:[]) . C.UnquoteDef (getRange i) xs <$> toConcrete e +  toConcrete (A.UnquoteData i xs uc j cs e) = __IMPOSSIBLE__ + data RangeAndPragma = RangeAndPragma Range A.Pragma  instance ToConcrete RangeAndPragma where@@ -1240,6 +1296,7 @@     A.StaticPragma x -> C.StaticPragma r <$> toConcrete x     A.InjectivePragma x -> C.InjectivePragma r <$> toConcrete x     A.InlinePragma b x -> C.InlinePragma r b <$> toConcrete x+    A.NotProjectionLikePragma q -> C.NotProjectionLikePragma r <$> toConcrete q     A.EtaPragma x    -> C.EtaPragma    r <$> toConcrete x     A.DisplayPragma f ps rhs ->       C.DisplayPragma r <$> toConcrete (A.DefP (PatRange noRange) (unambiguous f) ps) <*> toConcrete rhs@@ -1776,5 +1833,5 @@  instance ToConcrete NamedMeta where     type ConOfAbs NamedMeta = C.Expr-    toConcrete i = do-      return $ C.Underscore noRange (Just $ prettyShow i)+    toConcrete i =+      C.Underscore noRange . Just . render <$> prettyTCM i
src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs view
@@ -15,6 +15,7 @@     , NewName, OldQName     , PatName, APatName     , importPrimitives+    , checkCohesionAttributes     ) where  import Prelude hiding ( null )@@ -29,15 +30,14 @@ import Data.Map (Map) import Data.Functor (void) import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import qualified Data.Map as Map import Data.Maybe import Data.Monoid (First(..)) import Data.Void -import Agda.Syntax.Concrete as C hiding (topLevelModuleName)+import Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Attribute import Agda.Syntax.Concrete.Generic import Agda.Syntax.Concrete.Operators import Agda.Syntax.Concrete.Pattern@@ -58,11 +58,13 @@ import Agda.Syntax.Translation.AbstractToConcrete (ToConcrete, ConOfAbs) import Agda.Syntax.DoNotation import Agda.Syntax.IdiomBrackets+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad.Base hiding (ModuleInfo, MetaInfo) import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Trace (traceCall, setCurrentRange)-import Agda.TypeChecking.Monad.State+import Agda.TypeChecking.Monad.State hiding (topLevelModuleName)+import qualified Agda.TypeChecking.Monad.State as S import Agda.TypeChecking.Monad.MetaVars (registerInteractionPoint) import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Env (insideDotPattern, isInsideDotPattern, getCurrentPath)@@ -174,7 +176,11 @@     buildType :: [C.NiceDeclaration] -> ScopeM A.Expr       -- TODO: Telescope instead of Expr in abstract RecDef     buildType ds = do-      dummy <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+      -- The constructor target type is computed in the type checker.+      -- For now, we put a dummy expression there.+      -- Andreas, 2022-10-06, issue #6165:+      -- The dummy was builtinSet, but this might not be defined yet.+      let dummy = A.Lit empty $ LitString "TYPE"       tel   <- catMaybes <$> mapM makeBinding ds       return $ A.mkPi (ExprRange (getRange ds)) tel dummy @@ -183,7 +189,7 @@       let failure = typeError $ NotValidBeforeField d           r       = getRange d           mkLet d = Just . A.TLet r <$> toAbstract (LetDef d)-      traceCall (SetRange r) $ case d of+      setCurrentRange r $ case d of          C.NiceField r pr ab inst tac x a -> do           fx  <- getConcreteFixity x@@ -225,6 +231,7 @@         C.NiceGeneralize{}    -> failure         C.NiceUnquoteDecl{}   -> failure         C.NiceUnquoteDef{}    -> failure+        C.NiceUnquoteData{}   -> failure  checkModuleApplication   :: C.ModuleApplication@@ -608,8 +615,8 @@     q -> return q  data APatName = VarPatName A.Name-              | ConPatName (NonEmpty AbstractName)-              | PatternSynPatName (NonEmpty AbstractName)+              | ConPatName (List1 AbstractName)+              | PatternSynPatName (List1 AbstractName)  instance ToAbstract PatName where   type AbsOfCon PatName = APatName@@ -667,9 +674,9 @@       DefinedName _ d NoSuffix -> return $ anameName d       DefinedName _ d Suffix{} -> notInScopeError (toQName x)       -- We can get the cases below for DISPLAY pragmas-      ConstructorName _ ds -> return $ anameName (NonEmpty.head ds)   -- We'll throw out this one, so it doesn't matter which one we pick-      FieldName ds         -> return $ anameName (NonEmpty.head ds)-      PatternSynResName ds -> return $ anameName (NonEmpty.head ds)+      ConstructorName _ ds -> return $ anameName (List1.head ds)   -- We'll throw out this one, so it doesn't matter which one we pick+      FieldName ds         -> return $ anameName (List1.head ds)+      PatternSynResName ds -> return $ anameName (List1.head ds)       VarName x _          -> genericError $ "Not a defined name: " ++ prettyShow x       UnknownName          -> notInScopeError (toQName x) @@ -835,7 +842,7 @@       setScope si  -- This turns into an A.ScopedExpr si $ A.ExtendedLam...       return $         A.ExtendedLam (ExprRange r) di erased qname' $-        List1.fromList cs+        List1.fromListSafe __IMPOSSIBLE__ cs     _ -> __IMPOSSIBLE__  -- | Raise an error if argument is a C.Dot with Hiding info.@@ -1013,7 +1020,6 @@       C.Absurd _ -> notAnExpression e    -- Impossible things-      C.ETel _  -> __IMPOSSIBLE__       C.Equal{} -> genericError "Parse error: unexpected '='"       C.Ellipsis _ -> genericError "Parse error: unexpected '...'"       C.DoubleDot _ _ -> genericError "Parse error: unexpected '..'"@@ -1091,13 +1097,16 @@   toAbstract (C.TBind r xs t) = do     t' <- toAbstractCtx TopCtx t     tac <- traverse toAbstract $-             case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of-               []      -> Nothing-               tac : _ -> Just tac-               -- Invariant: all tactics are the same-               -- (distributed in the parser, TODO: don't)+      -- Invariant: all tactics are the same+      -- (distributed in the parser, TODO: don't)+      case List1.mapMaybe (bnameTactic . C.binderName . namedArg) xs of+        []      -> Nothing+        tac : _ -> Just tac++    let fin = all (bnameIsFinite . C.binderName . namedArg) xs     xs' <- toAbstract $ fmap (updateNamedArg (fmap $ NewName LambdaBound)) xs-    return $ Just $ A.TBind r tac xs' t'++    return $ Just $ A.TBind r (TypedBindingInfo tac fin) xs' t'   toAbstract (C.TLet r ds) = A.mkTLet r <$> toAbstract (LetDefs ds)  -- | Scope check a module (top level function).@@ -1246,7 +1255,7 @@ data TopLevel a = TopLevel   { topLevelPath           :: AbsolutePath     -- ^ The file path from which we loaded this module.-  , topLevelExpectedName   :: C.TopLevelModuleName+  , topLevelExpectedName   :: TopLevelModuleName     -- ^ The expected module name     --   (coming from the import statement that triggered scope checking this file).   , topLevelTheThing       :: a@@ -1278,13 +1287,13 @@          -- If there are declarations after the top-level module         -- we have to report a parse error here.-        (_, C.Module{} : d : _) -> traceCall (SetRange $ getRange d) $+        (_, C.Module{} : d : _) -> setCurrentRange d $           genericError $ "No declarations allowed after top-level module."          -- Otherwise, proceed.         (outsideDecls, [ C.Module r m0 tel insideDecls ]) -> do           -- If the module name is _ compute the name from the file path-          m <- if isNoName m0+          (m, top) <- if isNoName m0                 then do                   -- Andreas, 2017-07-28, issue #1077                   -- Check if the insideDecls end in a single module which has the same@@ -1296,7 +1305,8 @@                   -- report an error.                   case flip span insideDecls $ \case { C.Module{} -> False; _ -> True } of                     (ds0, (C.Module _ m1 _ _ : _))-                       | C.toTopLevelModuleName m1 == expectedMName+                       | rawTopLevelModuleNameForQName m1 ==+                         rawTopLevelModuleName expectedMName                          -- If the anonymous module comes from the user,                          -- the range cannot be the beginningOfFile.                          -- That is the range if the parser inserted the anon. module.@@ -1309,12 +1319,17 @@                          void $ toAbstract (Declarations outsideDecls)                          void $ toAbstract (Declarations ds0)                          -- Fail with a crude error otherwise-                         traceCall (SetRange $ getRange ds0) $ genericError+                         setCurrentRange ds0 $ genericError                            "Illegal declaration(s) before top-level module"                      -- Otherwise, reconstruct the top-level module name-                    _ -> return $ C.QName $ setRange (getRange m0) $-                           C.simpleName $ stringToRawName $ rootNameModule file+                    _ -> do+                      let m = C.QName $ setRange (getRange m0) $+                              C.simpleName $ stringToRawName $+                              rootNameModule file+                      top <- S.topLevelModuleName+                               (rawTopLevelModuleNameForQName m)+                      return (m, top)                 -- Andreas, 2017-05-17, issue #2574, keep name as jump target!                 -- Andreas, 2016-07-12, ALTERNATIVE:                 -- -- We assign an anonymous file module the name expected from@@ -1329,9 +1344,11 @@                 -- We need to check the module name against the file name here.                 -- Otherwise one could sneak in a lie and confuse the scope                 -- checker.-                  checkModuleName (C.toTopLevelModuleName m0) (SourceFile file) $ Just expectedMName-                  return m0-          setTopLevelModule m+                  top <- S.topLevelModuleName+                           (rawTopLevelModuleNameForQName m0)+                  checkModuleName top (SourceFile file) (Just expectedMName)+                  return (m0, top)+          setTopLevelModule top           am <- toAbstract (NewModuleQName m)           primitiveImport <- importPrimitives           -- Scope check the declarations outside@@ -1472,6 +1489,7 @@        C.RewritePragma{}    -> Nothing        -- @CompilePragma@ already handled in the nicifier        C.CompilePragma{}    -> Nothing+       C.NotProjectionLikePragma{} -> Nothing   newtype LetDefs = LetDefs (List1 C.Declaration)@@ -1719,7 +1737,9 @@    -- Definitions (possibly mutual)     NiceMutual r tc cc pc ds -> do+      reportSLn "scope.mutual" 20 ("starting checking mutual definitions: " ++ prettyShow ds)       ds' <- toAbstract ds+      reportSLn "scope.mutual" 20 ("finishing checking mutual definitions")       -- We only termination check blocks that do not have a measure.       return [ A.Mutual (MutualInfo tc cc pc r) ds' ] @@ -1925,7 +1945,7 @@       dir <- notPublicWithoutOpen open dir        -- Andreas, 2018-11-03, issue #3364, parse expression in as-clause as Name.-      let illformedAs s = traceCall (SetRange $ getRange as) $ do+      let illformedAs s = setCurrentRange as $ do             -- If @as@ is followed by something that is not a simple name,             -- throw a warning and discard the as-clause.             Nothing <$ warning (IllformedAsClause s)@@ -1938,16 +1958,18 @@         Just (AsName (Left (C.Ident C.Qual{})) r) -> illformedAs "; a qualified name is not allowed here"         Just (AsName (Left e)                  r) -> illformedAs "" +      top <- S.topLevelModuleName (rawTopLevelModuleNameForQName x)       -- First scope check the imported module and return its name and       -- interface. This is done with that module as the top-level module.       -- This is quite subtle. We rely on the fact that when setting the       -- top-level module and generating a fresh module name, the generated       -- name will be exactly the same as the name generated when checking       -- the imported module.-      (m, i) <- withCurrentModule noModuleName $ withTopLevelModule x $ do+      (m, i) <- withCurrentModule noModuleName $+                withTopLevelModule top $ do         m <- toAbstract $ NewModuleQName x  -- (No longer erases the contents of @m@.)         printScope "import" 10 "before import:"-        (m, i) <- scopeCheckImport m+        (m, i) <- scopeCheckImport top m         printScope "import" 10 $ "scope checked import: " ++ prettyShow i         -- We don't want the top scope of the imported module (things happening         -- before the module declaration)@@ -2039,6 +2061,34 @@       zipWithM_ (rebindName p OtherDefName) xs ys       return [ A.UnquoteDef [ mkDefInfo x fx PublicAccess a r | (fx, x) <- zip fxs xs ] ys e ] +    NiceUnquoteData r p a pc uc x cs e -> do+      fx <- getConcreteFixity x+      x' <- freshAbstractQName fx x+      bindName p QuotableName x x'++      -- Create the module for the qualified constructors+      checkForModuleClash x+      let m = qnameToMName x'+      createModule (Just IsDataModule) m+      bindModule p x m  -- make it a proper module++      cs' <- mapM (bindUnquoteConstructorName m p) cs++      e <- withCurrentModule m $ toAbstract e++      rebindName p DataName x x'+      zipWithM_ (rebindName p ConName) cs cs'+      withCurrentModule m $ zipWithM_ (rebindName p ConName) cs cs'++      fcs <- mapM getConcreteFixity cs+      let mi = MutualInfo TerminationCheck YesCoverageCheck pc r+      return+        [ A.Mutual+          mi [A.UnquoteData+            [ mkDefInfo x fx p a r ] x' uc+            [ mkDefInfo c fc p a r | (fc, c) <- zip fcs cs] cs' e ]+        ]+     NicePatternSyn r a n as p -> do       reportSLn "scope.pat" 10 $ "found nice pattern syn: " ++ prettyShow n       (as, p) <- withLocalVars $ do@@ -2237,6 +2287,25 @@            AbstractDef -> PrivateAccess Inserted            _           -> p +bindUnquoteConstructorName :: ModuleName -> Access -> C.Name -> TCM A.QName+bindUnquoteConstructorName m p c = do++  r <- resolveName (C.QName c)+  fc <- getConcreteFixity c+  c' <- withCurrentModule m $ freshAbstractQName fc c+  let aname qn = AbsName qn QuotableName Defined NoMetadata+      addName = modifyCurrentScope $ addNameToScope (localNameSpace p) c $ aname c'+      success = addName >> (withCurrentModule m $ addName)+  case r of+    _ | isNoName c       -> success+    UnknownName          -> success+    ConstructorName i ds -> if all (isJust . isConName . anameKind) ds+      then success+      else typeError $ ClashingDefinition (C.QName c) (anameName $ List1.head ds) Nothing+    _ -> typeError $ GenericError $+       "The name " ++ prettyShow c ++ " already has non-constructor definitions"+  return c'+ instance ToAbstract DataConstrDecl where   type AbsOfCon DataConstrDecl = A.Declaration @@ -2326,6 +2395,15 @@             sINLINE ++ " used on ambiguous name " ++ prettyShow x           _        -> genericError $ "Target of " ++ sINLINE ++ " pragma should be a function"       return [ A.InlinePragma b y ]+  toAbstract (C.NotProjectionLikePragma _ x) = do+      e <- toAbstract $ OldQName x Nothing+      y <- case e of+          A.Def  x -> return x+          A.Proj _ p | Just x <- getUnambiguous p -> return x+          A.Proj _ x -> genericError $+            "NOT_PROJECTION_LIKE used on ambiguous name " ++ prettyShow x+          _        -> genericError $ "Target of NOT_PROJECTION_LIKE pragma should be a function"+      return [ A.NotProjectionLikePragma y ]   toAbstract (C.BuiltinPragma _ rb qx)     | isUntypedBuiltin b = do         q <- toAbstract $ ResolveQName qx@@ -2524,7 +2602,7 @@    void $ -- We can ignore the returned default A.ImportDirective.     openModule TopOpenModule (Just am) (C.QName m) $       defaultImportDir { publicOpen = Just noRange }-  return (x, A.WhereDecls (am <$ whname) $ singleton d)+  return (x, A.WhereDecls (Just am) (isNothing whname) $ singleton d)  data TerminationOrPositivity = Termination | Positivity   deriving (Show)@@ -2963,9 +3041,9 @@     -- Get the notation for the operator.     nota <- getNotation op ns     let parts = notation nota-    -- We can throw away the @BindingHoles@, since binders+    -- We can throw away the @VarPart@s, since binders     -- have been preprocessed into @OpApp C.Expr@.-    let nonBindingParts = filter (not . isBindingHole) parts+    let nonBindingParts = filter (not . isBinder) parts     -- We should be left with as many holes as we have been given args @es@.     -- If not, crash.     unless (length (filter isAHole nonBindingParts) == length es) __IMPOSSIBLE__@@ -3042,6 +3120,20 @@       set :: a -> NamedArg b -> NamedArg a       set x arg = fmap (fmap (const x)) arg +-- | Raises an error if the list of cohesion attributes is non-empty+-- and cohesion modalities are not supported.++checkCohesionAttributes :: CohesionAttributes -> ScopeM ()+checkCohesionAttributes attrs =+  unlessM (optCohesion <$> pragmaOptions) $+  case attrs of+    []         -> return ()+    (s, r) : _ ->+      setCurrentRange r $+      typeError $ GenericDocError $ P.fsep $+      P.pwords "Cohesion modalities have not been enabled" +++      P.pwords "(use --cohesion to enable them):" +++      [P.text s]  {--------------------------------------------------------------------------     Things we parse but are not part of the Agda file syntax
src/full/Agda/Syntax/Translation/InternalToAbstract.hs view
@@ -177,9 +177,9 @@     type ReifiesTo MetaId = Expr      reifyWhen = reifyWhenE-    reify x@(MetaId n) = do+    reify x = do       b <- asksTC envPrintMetasBare-      mi  <- mvInfo <$> lookupMeta x+      mi  <- mvInfo <$> lookupLocalMeta x       let mi' = Info.MetaInfo                  { metaRange          = getRange $ miClosRange mi                  , metaScope          = clScope $ miClosRange mi@@ -435,9 +435,11 @@ reifyTerm expandAnonDefs0 v0 = do   -- Jesper 2018-11-02: If 'PrintMetasBare', drop all meta eliminations.   metasBare <- asksTC envPrintMetasBare+  reportSDoc "reify.term" 80 $ pure $ "reifyTerm v0 = " <+> pretty v0   v <- instantiate v0 >>= \case     I.MetaV x _ | metasBare -> return $ I.MetaV x []     v -> return v+  reportSDoc "reify.term" 80 $ pure $ "reifyTerm v = " <+> pretty v   -- Ulf 2014-07-10: Don't expand anonymous when display forms are disabled   -- (i.e. when we don't care about nice printing)   expandAnonDefs <- return expandAnonDefs0 `and2M` displayFormsEnabled@@ -445,6 +447,7 @@   -- then we print system-generated projections as postfix, else prefix.   havePfp <- optPostfixProjections <$> pragmaOptions   let pred = if havePfp then (== ProjPrefix) else (/= ProjPostfix)+  reportSDoc "reify.term" 80 $ pure $ "reifyTerm (unSpine v) = " <+> pretty (unSpine' pred v)   case unSpine' pred v of     -- Hack to print generalized field projections with nicer names. Should     -- only show up in errors. Check the spined form!@@ -528,11 +531,15 @@     I.Level l      -> reify l     I.Pi a b       -> case b of         NoAbs _ b'-          | visible a   -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b')+          | visible a, not (domIsFinite a) -> uncurry (A.Fun $ noExprInfo) <$> reify (a, b')             -- Andreas, 2013-11-11 Hidden/Instance I.Pi must be A.Pi             -- since (a) the syntax {A} -> B or {{A}} -> B is not legal             -- and (b) the name of the binder might matter.             -- See issue 951 (a) and 952 (b).+            --+            -- Amy, 2022-09-05: Can't be finite either, since otherwise+            -- we say ".(IsOne φ) → A ≠ .(IsOne φ) → A" with no+            -- indication of which is finite and which isn't           | otherwise   -> mkPi b =<< reify a         b               -> mkPi b =<< do           ifM (domainFree a (absBody b))@@ -543,7 +550,9 @@           tac <- traverse reify $ domTactic a           (x, b) <- reify b           let xs = singleton $ Arg info $ Named (domName a) $ mkBinder_ x-          return $ A.Pi noExprInfo (singleton $ TBind noRange tac xs a') b+          return $ A.Pi noExprInfo+            (singleton $ TBind noRange (TypedBindingInfo tac (domIsFinite a)) xs a')+            b         -- We can omit the domain type if it doesn't have any free variables         -- and it's mentioned in the target type.         domainFree a b = do@@ -556,7 +565,7 @@            es' <- reify es -          mv <- lookupMeta x+          mv <- lookupLocalMeta x           (msub1,meta_tel,msub2) <- do             local_chkpt <- viewTC eCurrentCheckpoint             (chkpt, tel, msub2) <- enterClosure mv $ \ _ ->@@ -689,7 +698,7 @@         alreadyPrinting <- viewTC ePrintingPatternLambdas          extLam <- case def of-          Function{ funExtLam = Just{}, funProjection = Just{} } -> __IMPOSSIBLE__+          Function{ funExtLam = Just{}, funProjection = Right{} } -> __IMPOSSIBLE__           Function{ funExtLam = Just (ExtLamInfo m b sys) } ->             Just . (,Strict.toLazy sys) . size <$> lookupSection m           _ -> return Nothing@@ -703,7 +712,7 @@           _ -> do            (pad, nes :: [Elim' (Named_ Term)]) <- case def of -            Function{ funProjection = Just Projection{ projIndex = np } } | np > 0 -> do+            Function{ funProjection = Right Projection{ projIndex = np } } | np > 0 -> do               reportSLn "reify.def" 70 $ "  def. is a projection with projIndex = " ++ show np                -- This is tricky:@@ -795,7 +804,7 @@       :: MonadReify m       => QName -> ArgInfo -> Int -> Maybe System -> [I.Clause]       -> I.Elims -> m Expr-    reifyExtLam x i npars msys cls es = do+    reifyExtLam x ai npars msys cls es = do       reportSLn "reify.def" 10 $ "reifying extended lambda " ++ prettyShow x       reportSLn "reify.def" 50 $ render $ nest 2 $ vcat         [ "npars =" <+> pretty npars@@ -815,13 +824,14 @@       let cx     = nameConcrete $ qnameName x           dInfo  = mkDefInfo cx noFixity' PublicAccess ConcreteDef                      (getRange x)-          erased = case getQuantity i of+          erased = case getQuantity ai of             Quantity0 o -> Erased o             Quantityω o -> NotErased o             Quantity1 o -> __IMPOSSIBLE__-      elims (A.ExtendedLam exprNoRange dInfo erased x $-             List1.fromList cls)-        =<< reify rest+          lam = case cls of+            []       -> A.AbsurdLam exprNoRange NotHidden+            (cl:cls) -> A.ExtendedLam exprNoRange dInfo erased x (cl :| cls)+      elims lam =<< reify rest  -- | @nameFirstIfHidden (x:a) ({e} es) = {x = e} es@ nameFirstIfHidden :: Dom (ArgName, t) -> [Elim' a] -> [Elim' (Named_ a)]@@ -1047,7 +1057,6 @@     A.Let _ _ _              -> __IMPOSSIBLE__     A.Rec i es               -> A.Rec i $ blank bound es     A.RecUpdate i e es       -> uncurry (A.RecUpdate i) $ blank bound (e, es)-    A.ETel _                 -> __IMPOSSIBLE__     A.Quote {}               -> __IMPOSSIBLE__     A.QuoteTerm {}           -> __IMPOSSIBLE__     A.Unquote {}             -> __IMPOSSIBLE__@@ -1347,8 +1356,8 @@         result = A.Clause (spineToLhs lhs) [] rhs A.noWhereDecls False       return result -instance Reify Type where-    type ReifiesTo Type = Expr+instance Reify I.Type where+    type ReifiesTo I.Type = A.Type      reifyWhen = reifyWhenE     reify (I.El _ t) = reify t@@ -1359,7 +1368,7 @@     reifyWhen = reifyWhenE     reify s = do       s <- instantiateFull s-      SortKit{..} <- sortKit+      SortKit{..} <- infallibleSortKit       case s of         I.Type (I.ClosedLevel 0) -> return $ A.Def' nameOfSet A.NoSuffix         I.Type (I.ClosedLevel n) -> return $ A.Def' nameOfSet (A.Suffix n)@@ -1383,6 +1392,9 @@         I.LockUniv  -> do           lockU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinLockUniv           return $ A.Def lockU+        I.IntervalUniv -> do+          intervalU <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinIntervalUniv+          return $ A.Def intervalU         I.PiSort a s1 s2 -> do           pis <- freshName_ ("piSort" :: String) -- TODO: hack           (e1,e2) <- reify (s1, I.Lam defaultArgInfo $ fmap Sort s2)@@ -1438,7 +1450,7 @@         name = domName arg     tac <- traverse reify $ domTactic arg     let xs = singleton $ Arg info $ Named name $ A.mkBinder_ x-    return $ TBind r tac xs e : bs+    return $ TBind r (TypedBindingInfo tac (domIsFinite arg)) xs e : bs  instance Reify i => Reify (Dom i) where     type ReifiesTo (Dom i) = Arg (ReifiesTo i)
src/full/Agda/Syntax/Translation/ReflectedToAbstract.hs view
@@ -17,7 +17,11 @@ import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Common-import Agda.Syntax.Abstract as A hiding (Apply)+import Agda.Syntax.Abstract+  ( Name, QName, QNamed(QNamed)+  , isNoName, nameConcrete, nextName, qualify, unambiguous+  )+import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Pattern import Agda.Syntax.Reflected as R import Agda.Syntax.Internal (Dom,Dom'(..))@@ -133,37 +137,42 @@ instance ToAbstract r => ToAbstract [Arg r] where   type AbsOfRef [Arg r] = [NamedArg (AbsOfRef r)] --- instance ToAbstract r Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where-instance (ToAbstract r, AbsOfRef r ~ Expr) => ToAbstract (Dom r, Name) where+-- instance ToAbstract r A.Expr => ToAbstract (Dom r, Name) (A.TypedBinding) where+instance (ToAbstract r, AbsOfRef r ~ A.Expr) => ToAbstract (Dom r, Name) where   type AbsOfRef (Dom r, Name) = A.TypedBinding-  toAbstract (Dom{domInfo = i,unDom = x, domTactic = tac}, name) = do+  toAbstract (Dom{domInfo = i, domIsFinite = isfin, unDom = x, domTactic = tac}, name) = do     dom <- toAbstract x-    return $ mkTBind noRange (singleton $ unnamedArg i $ mkBinder_ name) dom+    -- TODO(Amy): Anyone know why this discards the tactic? It was like+    -- that when I got here!+    return $ A.TBind noRange+      (A.TypedBindingInfo Nothing isfin)+      (singleton $ unnamedArg i $ A.mkBinder_ name)+      dom -instance ToAbstract (Expr, Elim) where-  type AbsOfRef (Expr, Elim) = Expr+instance ToAbstract (A.Expr, Elim) where+  type AbsOfRef (A.Expr, Elim) = A.Expr   toAbstract (f, Apply arg) = do     arg     <- toAbstract arg     showImp <- showImplicitArguments     return $ if showImp || visible arg-             then App (setOrigin Reflected defaultAppInfo_) f arg+             then A.App (setOrigin Reflected defaultAppInfo_) f arg              else f -instance ToAbstract (Expr, Elims) where-  type AbsOfRef (Expr, Elims) = Expr+instance ToAbstract (A.Expr, Elims) where+  type AbsOfRef (A.Expr, Elims) = A.Expr   toAbstract (f, elims) = foldM (curry toAbstract) f elims  instance ToAbstract r => ToAbstract (R.Abs r) where   type AbsOfRef (R.Abs r) = (AbsOfRef r, Name)-  toAbstract (Abs s x) = withName s' $ \name -> (,) <$> toAbstract x <*> return name+  toAbstract (Abs s x) = withName s' $ \name -> (,name) <$> toAbstract x     where s' = if (isNoName s) then "z" else s -- TODO: only do this when var is free  instance ToAbstract Literal where-  type AbsOfRef Literal = Expr+  type AbsOfRef Literal = A.Expr   toAbstract l = return $ A.Lit empty l  instance ToAbstract Term where-  type AbsOfRef Term = Expr+  type AbsOfRef Term = A.Expr   toAbstract = \case     R.Var i es -> do       name <- mkVarName i@@ -175,7 +184,7 @@     R.Lam h t  -> do       (e, name) <- toAbstract t       let info  = setHiding h $ setOrigin Reflected defaultArgInfo-      return $ A.Lam exprNoRange (mkDomainFree $ unnamedArg info $ mkBinder_ name) e+      return $ A.Lam exprNoRange (A.mkDomainFree $ unnamedArg info $ A.mkBinder_ name) e     R.ExtLam cs es -> do       name <- freshName_ extendedLambdaName       m    <- getCurrentModule@@ -195,7 +204,7 @@       info <- mkMetaInfo       let info' = info{ metaNumber = Just x }       toAbstract (A.Underscore info', es)-    R.Unknown      -> Underscore <$> mkMetaInfo+    R.Unknown      -> A.Underscore <$> mkMetaInfo  mkMetaInfo :: ReadTCState m => m MetaInfo mkMetaInfo = do@@ -203,15 +212,23 @@   return $ emptyMetaInfo { metaScope = scope }  mkDef :: HasConstInfo m => QName -> m A.Expr-mkDef f =-  ifM (isMacro . theDef <$> getConstInfo f)-      (return $ A.Macro f)-      (return $ A.Def f)+mkDef f = getConstInfo f <&> theDef <&> \case -mkApp :: Expr -> Expr -> Expr-mkApp e1 e2 = App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2+  Constructor{}+    -> A.Con $ unambiguous f +  Function{ funProjection = Right Projection{ projProper = Just{} } }+    -> A.Proj ProjSystem $ unambiguous f +  d@Function{} | isMacro d+    -> A.Macro f++  _ -> A.Def f++mkApp :: A.Expr -> A.Expr -> A.Expr+mkApp e1 e2 = A.App (setOrigin Reflected defaultAppInfo_) e1 $ defaultNamedArg e2++ mkVar :: MonadReflectedToAbstract m => Int -> m (Name, R.Type) mkVar i = ifJustM (askVar i) return $ do   cxt   <- getContextTelescope@@ -228,7 +245,7 @@   return $ A.AnnP patNoRange t p  instance ToAbstract Sort where-  type AbsOfRef Sort = Expr+  type AbsOfRef Sort = A.Expr   toAbstract s = do     setName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet     propName <- fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinProp@@ -239,7 +256,7 @@       PropS x -> mkApp (A.Def propName) <$> toAbstract x       PropLitS x -> return $ A.Def' propName $ A.Suffix x       InfS x -> return $ A.Def' infName $ A.Suffix x-      UnknownS -> mkApp (A.Def setName) . Underscore <$> mkMetaInfo+      UnknownS -> mkApp (A.Def setName) . A.Underscore <$> mkMetaInfo  instance ToAbstract R.Pattern where   type AbsOfRef R.Pattern = A.Pattern@@ -250,7 +267,7 @@     R.DotP t -> A.DotP patNoRange <$> toAbstract t     R.VarP i -> do       (x, t) <- mkVar i-      annotatePattern i t $ A.VarP $ mkBindName x+      annotatePattern i t $ A.VarP $ A.mkBindName x     R.LitP l  -> return $ A.LitP patNoRange l     R.AbsurdP i -> do       (_, t) <- mkVar i@@ -264,13 +281,13 @@     checkClauseTelescopeBindings tel pats     pats <- toAbstract pats     rhs  <- toAbstract rhs-    let lhs = spineToLhs $ SpineLHS empty name pats-    return $ A.Clause lhs [] (RHS rhs Nothing) noWhereDecls False+    let lhs = spineToLhs $ A.SpineLHS empty name pats+    return $ A.Clause lhs [] (A.RHS rhs Nothing) A.noWhereDecls False   toAbstract (QNamed name (R.AbsurdClause tel pats)) = withVars (map (Text.unpack *** unArg) tel) $ \_ -> do     checkClauseTelescopeBindings tel pats     pats <- toAbstract pats-    let lhs = spineToLhs $ SpineLHS empty name pats-    return $ A.Clause lhs [] AbsurdRHS noWhereDecls False+    let lhs = spineToLhs $ A.SpineLHS empty name pats+    return $ A.Clause lhs [] A.AbsurdRHS A.noWhereDecls False  instance ToAbstract [QNamed R.Clause] where   type AbsOfRef [QNamed R.Clause] = [A.Clause]
src/full/Agda/Syntax/Treeless.hs view
@@ -14,7 +14,6 @@ import Control.Arrow (first, second) import Control.DeepSeq -import Data.Data (Data) import Data.Word  import GHC.Generics (Generic)@@ -29,13 +28,13 @@   , cArgUsage :: Maybe [ArgUsage]       -- ^ 'Nothing' if treeless usage analysis has not run yet.   }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Usage status of function arguments in treeless code. data ArgUsage   = ArgUsed   | ArgUnused-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | The treeless compiler can behave differently depending on the target --   language evaluation strategy. For instance, more aggressive erasure for@@ -72,7 +71,7 @@            | TCoerce TTerm  -- ^ Used by the GHC backend            | TError TError            -- ^ A runtime error, something bad has happened.-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Compiler-related primitives. This are NOT the same thing as primitives -- in Agda's surface or internal syntax!@@ -100,7 +99,7 @@   | PIf   | PSeq   | PITo64 | P64ToI-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  isPrimEq :: TPrim -> Bool isPrimEq p = p `elem` [PEqI, PEqF, PEqS, PEqC, PEqQ, PEq64]@@ -204,12 +203,12 @@   | CTString   | CTFloat   | CTQName-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  data CaseInfo = CaseInfo   { caseLazy :: Bool   , caseType :: CaseType }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  data TAlt   = TACon    { aCon  :: QName, aArity :: Int, aBody :: TTerm }@@ -219,7 +218,7 @@   | TAGuard  { aGuard :: TTerm, aBody :: TTerm }   -- ^ Binds no variables   | TALit    { aLit :: Literal,   aBody:: TTerm }-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  data TError   = TUnreachable@@ -231,7 +230,7 @@   -- ^ Code which could not be obtained because of a hole in the program.   -- This should throw a runtime error.   -- The string gives some information about the meta variable that got compiled.-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)   class Unreachable a where
src/full/Agda/Termination/Monad.hs view
@@ -18,7 +18,10 @@ import Control.Monad.Except import Control.Monad.Reader +import Data.DList (DList)+import qualified Data.DList as DL import Data.Semigroup ( Semigroup(..) )+import Data.Set (Set) import qualified Data.Set as Set  import Agda.Interaction.Options (optTerminationDepth)@@ -31,7 +34,7 @@  import Agda.Termination.CutOff import Agda.Termination.Order (Order,le,unknown)-import Agda.Termination.RecCheck (anyDefs)+import Agda.Termination.RecCheck (MutualNames, anyDefs)  import Agda.TypeChecking.Monad import Agda.TypeChecking.Monad.Benchmark@@ -56,16 +59,16 @@  import Agda.Utils.Impossible --- | The mutual block we are checking.------   The functions are numbered according to their order of appearance---   in this list.--type MutualNames = [QName]- -- | The target of the function we are checking. -type Target = QName+data Target+  = TargetDef QName+      -- ^ The target of recursion is a @record@, @data@, or unreducible @Def@.+  | TargetRecord+      -- ^ We are termination-checking a record.+  | TargetOther+      -- ^ None of the above two or unknown.+  deriving (Eq, Show)  -- | The current guardedness level. @@ -94,13 +97,13 @@     -- ^ The names of the functions in the mutual block we are checking.     --   This includes the internally generated functions     --   (with, extendedlambda, coinduction).-  , terUserNames :: [QName]+  , terUserNames :: Set QName     -- ^ The list of name actually appearing in the file (abstract syntax).     --   Excludes the internally generated functions.   , terHaveInlinedWith :: Bool     -- ^ Does the actual clause result from with-inlining?     --   (If yes, it may be ill-typed.)-  , terTarget  :: Maybe Target+  , terTarget  :: Target     -- ^ Target type of the function we are currently termination checking.     --   Only the constructors of 'Target' are considered guarding.   , terDelayed :: Delayed@@ -153,7 +156,7 @@   , terMutual                   = __IMPOSSIBLE__ -- needs to be set!   , terCurrent                  = __IMPOSSIBLE__ -- needs to be set!   , terHaveInlinedWith          = False-  , terTarget                   = Nothing+  , terTarget                   = TargetOther   , terDelayed                  = NotDelayed   , terMaskArgs                 = repeat False   -- use all arguments (mask none)   , terMaskResult               = False          -- use result (do not mask)@@ -279,13 +282,13 @@ terGetMutual :: TerM MutualNames terGetMutual = terAsks terMutual -terGetUserNames :: TerM [QName]+terGetUserNames :: TerM (Set QName) terGetUserNames = terAsks terUserNames -terGetTarget :: TerM (Maybe Target)+terGetTarget :: TerM Target terGetTarget = terAsks terTarget -terSetTarget :: Maybe Target -> TerM a -> TerM a+terSetTarget :: Target -> TerM a -> TerM a terSetTarget t = terLocal $ \ e -> e { terTarget = t }  terGetHaveInlinedWith :: TerM Bool@@ -575,7 +578,11 @@  -- * Call pathes --- | The call information is stored as free monoid+-- | Call paths.++-- An old comment:+--+--   The call information is stored as free monoid --   over 'CallInfo'.  As long as we never look at it, --   only accumulate it, it does not matter whether we use --   'Set', (nub) list, or 'Tree'.@@ -584,16 +591,24 @@ --   Since we define no order on 'CallInfo' (expensive), --   we cannot use a 'Set' or nub list. --   Performance-wise, I could not see a difference between Set and list.+--+-- If the binary tree is balanced "incorrectly", then forcing it could+-- be expensive, so a switch was made to difference lists. -newtype CallPath = CallPath { callInfos :: [CallInfo] }+newtype CallPath = CallPath (DList CallInfo)   deriving (Show, Semigroup, Monoid) +-- | The calls making up the call path.++callInfos :: CallPath -> [CallInfo]+callInfos (CallPath cs) = DL.toList cs+ -- | Only show intermediate nodes.  (Drop last 'CallInfo'). instance Pretty CallPath where-  pretty (CallPath cis0) = if null cis then empty else+  pretty cis0 = if null cis then empty else     P.hsep (map (\ ci -> arrow P.<+> P.pretty ci) cis) P.<+> arrow     where-      cis   = init cis0+      cis   = init (callInfos cis0)       arrow = "-->"  -- * Size depth estimation@@ -601,16 +616,23 @@ -- | A very crude way of estimating the @SIZELT@ chains --   @i > j > k@ in context.  Returns 3 in this case. --   Overapproximates.+class TerSetSizeDepth b where+  terSetSizeDepth :: b -> TerM a -> TerM a +instance TerSetSizeDepth Telescope where+  terSetSizeDepth = terSetSizeDepth . telToList+ -- TODO: more precise analysis, constructing a tree -- of relations between size variables.-terSetSizeDepth :: Telescope -> TerM a -> TerM a-terSetSizeDepth tel cont = do-  n <- liftTCM $ sum <$> do-    forM (telToList tel) $ \ dom -> do-      a <- reduce $ snd $ unDom dom-      ifM (isJust <$> isSizeType a) (return 1) {- else -} $-        case unEl a of-          MetaV{} -> return 1-          _       -> return 0-  terLocal (set terSizeDepth n) cont+instance TerSetSizeDepth ListTel where+  terSetSizeDepth doms cont = do+    n <- liftTCM $ sum <$> do+      forM doms $ \ dom -> do+        -- Andreas, 2022-03-12, TODO:+        -- use ifBlocked?  Shouldn't blocked types be treated like metas?+        a <- reduce $ snd $ unDom dom+        ifM (isJust <$> isSizeType a) (return 1) {- else -} $+          case unEl a of+            MetaV{} -> return 1+            _       -> return 0+    terLocal (set terSizeDepth n) cont
src/full/Agda/Termination/RecCheck.hs view
@@ -13,16 +13,19 @@   module Agda.Termination.RecCheck-    ( recursive+    ( MutualNames+    , recursive     , anyDefs     )  where  import Control.Monad (forM, forM_)+import Data.Foldable import Data.Graph import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set@@ -37,6 +40,13 @@  import Agda.Utils.Impossible +-- | The mutual block we are checking.+--+--   The functions are numbered according to their order of appearance+--   in this set.++type MutualNames = Set QName+ -- | We compute for each clause the set of potentially recursive names. type NamesPerClause = IntMap (Set QName) @@ -46,16 +56,21 @@ -- --   As a side effect, update the 'clauseRecursive' field in the --   clauses belonging to the given functions.-recursive :: [QName] -> TCM [[QName]]+recursive :: Set QName -> TCM [MutualNames] recursive names = do+  let names' = toList names   -- For each function, get names per clause and total.-  (perClauses, nss) <- unzip <$> mapM (recDef (names `hasElem`)) names+  (perClauses, nss) <- unzip <$> mapM (recDef (`Set.member` names)) names'   -- Create graph suitable for stronglyConnComp.   -- Nodes are identical to node keys.-  let graph  = zipWith (\ x ns -> (x, x, Set.toList ns)) names nss+  let graph  = zipWith (\ x ns -> (x, x, Set.toList ns)) names' nss   let sccs   = stronglyConnComp graph-  let nonRec = mapMaybe (\case{ AcyclicSCC x -> Just x ; _ -> Nothing}) sccs-  let recs   = mapMaybe (\case{ CyclicSCC xs -> Just xs; _ -> Nothing}) sccs+  let nonRec = mapMaybe (\case AcyclicSCC x -> Just x+                               _            -> Nothing)+                 sccs+  let recs   = mapMaybe (\case CyclicSCC xs -> Just (Set.fromList xs)+                               _            -> Nothing)+                 sccs    reportSLn "rec.graph" 60 $ show graph @@ -65,7 +80,7 @@   -- Mark individual clauses of recursive functions:   --------------------------------------------------   -- Map names to clause numbers to sets of mentioned names.-  let clMap = Map.fromListWith __IMPOSSIBLE__ $ zip names perClauses+  let clMap = Map.fromListWith __IMPOSSIBLE__ $ zip names' perClauses   -- Walk through SCCs.   forM_ recs $ \ scc -> do     -- Does a set of names have an overlap with the current scc?@@ -88,6 +103,9 @@    { funTerminates = Just True    , funClauses    = map (\ cl -> cl { clauseRecursive = Just False }) $ funClauses def    }+  def@Record{} -> def+   { recTerminates = Just True+   }   def -> def  -- | Mark all clauses of a function as recursive or non-recursive.@@ -112,11 +130,17 @@    -- Get names in body   (perClause, ns2) <- case theDef def of+     Function{ funClauses = cls } -> do       perClause <- do         forM (zip [0..] cls) $ \ (i, cl) ->           (i,) <$> anyDefs include cl       return (IntMap.fromList perClause, mconcat $ map snd perClause)++    Record{ recTel } -> do+      ns <- anyDefs include recTel+      return (IntMap.singleton 0 ns, ns)+     _ -> return (mempty, mempty)    reportS "rec.graph" 20@@ -131,14 +155,16 @@ anyDefs :: GetDefs a => (QName -> Bool) -> a -> TCM (Set QName) anyDefs include a = do   -- Prepare function to lookup metas outside of TCM-  st <- getMetaStore-  let lookup (MetaId x) = (mvInstantiation <$> IntMap.lookup x st) >>= \case-        InstV _ v                      -> Just v    -- TODO: ignoring the lambdas might be bad?-        Open                           -> Nothing-        OpenInstance                   -> Nothing-        BlockedConst{}                 -> Nothing-        PostponedTypeCheckingProblem{} -> Nothing+  st <- useR stSolvedMetaStore+  let lookup x = inst . mvInstantiation <$> MapS.lookup x st       -- we collect only those used definitions that are in @names@       emb d = if include d then Set.singleton d else Set.empty   -- get all the Defs that are in names   return $ getDefs' lookup emb a+  where+  -- TODO: Is it bad to ignore the lambdas?+  inst (InstV i)                      = instBody i+  inst Open                           = __IMPOSSIBLE__+  inst OpenInstance                   = __IMPOSSIBLE__+  inst BlockedConst{}                 = __IMPOSSIBLE__+  inst PostponedTypeCheckingProblem{} = __IMPOSSIBLE__
src/full/Agda/Termination/SparseMatrix.hs view
@@ -48,7 +48,7 @@   ) where  import Data.Array-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Maybe
src/full/Agda/Termination/TermCheck.hs view
@@ -24,6 +24,7 @@ import Data.Foldable (toList) import qualified Data.List as List import Data.Monoid hiding ((<>))+import Data.Set (Set) import qualified Data.Set as Set  import qualified Agda.Syntax.Abstract as A@@ -115,13 +116,17 @@     A.ScopedDecl scope ds -> {- withScope_ scope $ -} termDecls ds         -- scope is irrelevant as we are termination checking Syntax.Internal     A.RecSig{}            -> return mempty-    A.RecDef _ r _ _ _ _ ds -> termDecls ds-    -- These should all be wrapped in mutual blocks+    A.RecDef _ x _ _ _ _ ds -> termMutual [x] <> termDecls ds+        -- Andreas, 2022-10-23, issue #5823+        -- Also check record types for termination.+        -- They are unfolded during construction of unique inhabitants of eta-records.+    -- These should all be wrapped in mutual blocks:     A.FunDef{}      -> __IMPOSSIBLE__     A.DataSig{}     -> __IMPOSSIBLE__     A.DataDef{}     -> __IMPOSSIBLE__     A.UnquoteDecl{} -> __IMPOSSIBLE__     A.UnquoteDef{}  -> __IMPOSSIBLE__+    A.UnquoteData{} -> __IMPOSSIBLE__   where     termDecls ds = concat <$> mapM termDecl' ds @@ -129,7 +134,7 @@     -- for symbols that need to be termination-checked.     getNames = concatMap getName     getName (A.FunDef i x delayed cs)   = [x]-    getName (A.RecDef _ _ _ _ _ _ ds)   = getNames ds+    getName (A.RecDef _ x _ _ _ _ ds)   = x : getNames ds     getName (A.Mutual _ ds)             = getNames ds     getName (A.Section _ _ _ ds)        = getNames ds     getName (A.ScopedDecl _ ds)         = getNames ds@@ -153,8 +158,9 @@   -- during type-checking.   mid <- fromMaybe __IMPOSSIBLE__ <$> asksTC envMutualBlock   mutualBlock <- lookupMutualBlock mid-  let allNames = filter (not . isAbsurdLambdaName) $ Set.elems $ mutualNames mutualBlock-      names    = if null names0 then allNames else names0+  let allNames = Set.filter (not . isAbsurdLambdaName) $+                 mutualNames mutualBlock+      names    = if null names0 then allNames else Set.fromList names0       i        = mutualInfo mutualBlock    -- We set the range to avoid panics when printing error messages.@@ -196,7 +202,7 @@      forM sccs $ \ allNames -> do       -- Set the mutual names in the termination environment.-     let namesSCC = filter (allNames `hasElem`) names+     let namesSCC = Set.filter (`Set.member` allNames) names      let setNames e = e            { terMutual    = allNames            , terUserNames = namesSCC@@ -207,23 +213,15 @@              " with cutoff=" ++ show cutoff ++ "..."            terLocal setNames cont -     -- New check currently only makes a difference for copatterns.+     -- New check currently only makes a difference for copatterns and record types.      -- Since it is slow, only invoke it if-     -- any of the definitions uses copatterns.-     res <- ifM (orM $ map usesCopatterns allNames)+     -- any of the definitions uses copatterns or is a record type.+     ifM (anyM allNames $ \ q -> usesCopatterns q `or2M` (isJust <$> isRecord q))          -- Then: New check, one after another.          (runTerm $ forM' allNames $ termFunction)          -- Else: Old check, all at once.          (runTerm $ termMutual') -     -- Record result of termination check in signature.-     -- If there are some termination errors, we collect them in-     -- the state and mark the definition as non-terminating so-     -- that it does not get unfolded-     let terminates = null res-     forM_ allNames $ \ q -> setTerminates q terminates-     return res- -- | @termMutual'@ checks all names of the current mutual block, --   henceforth called @allNames@, for termination. --@@ -268,19 +266,25 @@   -- the names the user has declared.  This is for error reporting.   names <- terGetUserNames   case r of-    Left calls -> return $ singleton $ terminationError names $ callInfos calls++    Left calls -> do+      mapM_ (`setTerminates` False) allNames+      return $ singleton $ terminationError names calls+     Right{} -> do       liftTCM $ reportSLn "term.warn.yes" 2 $         prettyShow (names) ++ " does termination check"+      mapM_ (`setTerminates` True) allNames       return mempty  -- | Smart constructor for 'TerminationError'. --   Removes 'termErrFunctions' that are not mentioned in 'termErrCalls'.-terminationError :: [QName] -> [CallInfo] -> TerminationError-terminationError names calls = TerminationError names' calls+terminationError :: Set QName -> CallPath -> TerminationError+terminationError names calls = TerminationError names' calls'   where-  names'    = filter (hasElem mentioned) names-  mentioned = map callInfoTarget calls+  calls'    = callInfos calls+  mentioned = map callInfoTarget calls'+  names'    = filter (hasElem mentioned) $ toList names  billToTerGraph :: a -> TerM a billToTerGraph a = liftTCM $ billPureTo [Benchmark.Termination, Benchmark.Graph] a@@ -343,20 +347,27 @@     return ()  -- | @termFunction name@ checks @name@ for termination.+-- If it passes the termination check it is marked as "terminates" in the signature.  termFunction :: QName -> TerM Result-termFunction name = do+termFunction name = inConcreteOrAbstractMode name $ \ def -> do    -- Function @name@ is henceforth referred to by its @index@   -- in the list of @allNames@ of the mutual block.    allNames <- terGetMutual-  let index = fromMaybe __IMPOSSIBLE__ $ List.elemIndex name allNames+  let index = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex name allNames    -- Retrieve the target type of the function to check.   -- #4256: Don't use typeOfConst (which instantiates type with module params), since termination   -- checking is running in the empty context, but with the current module unchanged.-  target <- liftTCM $ do typeEndsInDef . defType =<< getConstInfo name+  target <- case theDef def of+    -- We are termination-checking a record (calls to record will not be guarding):+    Record{} -> return TargetRecord+    -- We are termination-checking a definition:+    _ -> typeEndsInDef (defType def) <&> \case+           Just d  -> TargetDef d+           Nothing -> TargetOther   reportTarget target   terSetTarget target $ do @@ -368,7 +379,10 @@           if null todo then return $ Left calls else do             -- Extract calls originating from indices in @todo@.             new <- forM' todo $ \ i ->-              termDef $ fromMaybe __IMPOSSIBLE__ $ allNames !!! i+              termDef $+              if i < 0 || i >= Set.size allNames+              then __IMPOSSIBLE__+              else Set.elemAt i allNames             -- Mark those functions as processed and add the calls to the result.             let done'  = done `mappend` todo                 calls' = new  `mappend` calls@@ -385,26 +399,61 @@      cutoff <- terGetCutOff      let ?cutoff = cutoff      r <- billToTerGraph $ Term.terminatesFilter (== index) calls1-     case r of++     -- Andrea: 22/04/2020.+     -- With cubical we will always have a clause where the dot+     -- patterns are instead replaced with a variable, so they+     -- cannot be relied on for termination.+     -- See issue #4606 for a counterexample involving HITs.+     --+     -- Without the presence of HITs I conjecture that dot patterns+     -- could be turned into actual splits, because no-confusion+     -- would make the other cases impossible, so I do not disable+     -- this for --without-K entirely.+     --+     -- Andreas, 2022-03-21: The check for --cubical was missing here.+     ifM (isJust . optCubical <$> pragmaOptions) (return r) {- else -} $ case r of        Right () -> return $ Right ()-       Left{}    -> do+       Left{}   -> do          -- Try again, but include the dot patterns this time.          calls2 <- terSetUseDotPatterns True $ collect          reportCalls "" calls2-         billToTerGraph $ mapLeft callInfos $ Term.terminatesFilter (== index) calls2+         billToTerGraph $ Term.terminatesFilter (== index) calls2      names <- terGetUserNames-    case r of-      Left calls -> return $ singleton $ terminationError ([name] `List.intersect` names) calls+    case mapLeft callInfos r of++      Left calls -> do+        -- Mark as non-terminating.+        setTerminates name False++        -- Functions must be terminating, records types need not...+        case theDef def of++          -- Records need not terminate, so we just put the error on the debug log.+          Record{} -> do+            reportSDoc "term.warn.no" 10 $ vcat $+              hsep [ "Record type", prettyTCM name, "does not termination check.", "Problematic calls:" ] :+              (map (nest 2 . prettyTCM) $ List.sortOn getRange calls)+            mempty++          -- Functions must terminate, so we report the error.+          _ -> do+            let err = TerminationError [name | name `elem` names] calls+            return $ singleton err+       Right () -> do-        liftTCM $ reportSLn "term.warn.yes" 2 $+        reportSLn "term.warn.yes" 2 $           prettyShow name ++ " does termination check"+        setTerminates name True         return mempty    where-     reportTarget r = liftTCM $-       reportSLn "term.target" 20 $ "  target type " ++-         caseMaybe r "not recognized" (\ q ->-           "ends in " ++ prettyShow q)+     reportTarget :: MonadDebug m => Target -> m ()+     reportTarget tgt = reportSLn "term.target" 20 $ ("  " ++) $+       case tgt of+         TargetRecord -> "termination checking a record type"+         TargetDef q  -> unwords [ "target type ends in", prettyShow q ]+         TargetOther  -> "target type not recognized"  -- | To process the target type. typeEndsInDef :: MonadTCM tcm => Type -> tcm (Maybe QName)@@ -427,6 +476,13 @@ termDef :: QName -> TerM Calls termDef name = terSetCurrent name $ inConcreteOrAbstractMode name $ \ def -> do + -- Skip calls to record types unless we are checking a record type in the first place.+ let isRecord_ = case theDef def of { Record{} -> True; _ -> False }+ let notTargetRecord = terGetTarget <&> \case+       TargetRecord -> False+       _ -> True+ ifM (pure isRecord_ `and2M` notTargetRecord) mempty {-else-} $ do+   -- Retrieve definition   let t = defType def @@ -459,14 +515,28 @@               then return empty               else termClause cl +        -- @record R pars : Set where field tel@+        -- is treated like function @R pars = tel@.+        Record{ recPars, recTel } -> termRecTel recPars recTel+         _ -> return empty-  where-    hasDefP :: [NamedArg DeBruijnPattern] -> Bool-    hasDefP ps = getAny $ flip foldPattern ps $ \ (x :: DeBruijnPattern) ->-                  case x of-                    DefP{} -> Any True-                    _      -> Any False +-- | Extract "calls" to the field types from a record constructor telescope.+-- Does not extract from the parameters, but treats these as the "pattern variables"+-- (the lhs of the "function").+termRecTel :: Nat -> Telescope -> TerM Calls+termRecTel npars tel = do+  -- Set up the record parameters like function parameters.+  let (pars, fields) = splitAt npars $ telToList tel+  addContext pars $ do+    ps <- mkPats npars+    terSetPatterns ps $ terSetSizeDepth pars $ do+      -- Treat the record fields like the body of a function.+      extract $ telFromList fields+  where+  -- create n variable patterns+  mkPats n  = zipWith mkPat (downFrom n) <$> getContextNames+  mkPat i x = notMasked $ VarP defaultPatternInfo $ DBPatVar (prettyShow x) i  -- | Collect calls in type signature @f : (x1:A1)...(xn:An) -> B@. --   It is treated as if there were the additional function clauses.@@ -505,50 +575,43 @@   (ds, d) <- liftTCM $ do     TelV tel core <- telViewPath t     -- Check argument types-    ds <- forM (telToList tel) $ \ t -> do-      TelV _ t <- telViewPath $ snd $ unDom t-      d <- (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)-      when d $-        reportSDoc "term.mask" 20 $ do-          "argument type "-            <+> prettyTCM t-            <+> " is not data or record type, ignoring structural descent for --without-K"-      return d+    ds <- checkArgumentTypes tel     -- Check result types-    d  <- isNothing <.> isDataOrRecord . unEl $ core+    d  <- addContext tel $ isNothing <.> isDataOrRecord . unEl $ core     when d $       reportSLn "term.mask" 20 $ "result type is not data or record type, ignoring guardedness for --without-K"     return (ds, d)   terSetMaskArgs (ds ++ repeat True) $ terSetMaskResult d $ cont +  where+    checkArgumentTypes :: Telescope -> TCM [Bool]+    checkArgumentTypes EmptyTel = return []+    checkArgumentTypes (ExtendTel dom atel) = do+      TelV tel2 t <- telViewPath $ unDom dom+      d <- addContext tel2 $+        (isNothing <$> isDataOrRecord (unEl t)) `or2M` (isJust <$> isSizeType t)+      when d $+        reportSDoc "term.mask" 20 $ do+          "argument type "+            <+> prettyTCM t+            <+> " is not data or record type, ignoring structural descent for --without-K"+      underAbstraction dom atel $ \tel -> (d:) <$> checkArgumentTypes tel  -- | Is the current target type among the given ones? -targetElem :: [Target] -> TerM Bool-targetElem ds = maybe False (`elem` ds) <$> terGetTarget+targetElem :: [QName] -> TerM Bool+targetElem ds = terGetTarget <&> \case+  TargetDef d  -> d `elem` ds+  TargetRecord -> False+  TargetOther  -> False -{---- | The target type of the considered recursive definition.-data Target-  = Set        -- ^ Constructing a Set (only meaningful with 'guardingTypeConstructors').-  | Data QName -- ^ Constructing a coinductive or mixed type (could be data or record).-  deriving (Eq, Show) --- | Check wether a 'Target" corresponds to the current one.-matchingTarget :: DBPConf -> Target -> TCM Bool-matchingTarget conf t = maybe (return True) (match t) (currentTarget conf)-  where-    match Set      Set       = return True-    match (Data d) (Data d') = mutuallyRecursive d d'-    match _ _                = return False--}- -- | Convert a term (from a dot pattern) to a DeBruijn pattern. -- --   The term is first normalized and stripped of all non-coinductive projections.  termToDBP :: Term -> TerM DeBruijnPattern-termToDBP t = ifNotM terGetUseDotPatterns (return unusedVar) $ {- else -} do+termToDBP t =   termToPattern =<< do liftTCM $ stripAllProjections =<< normalise t  -- | Convert a term (from a dot pattern) to a pattern for the purposes of the termination checker.@@ -572,18 +635,25 @@ instance TermToPattern Term DeBruijnPattern where   termToPattern t = liftTCM (constructorForm t) >>= \case     -- Constructors.-    Con c _ args -> ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args)-    Def s [Apply arg] -> do+    Con c _ args -> ifDotPatsOrRecord c $+      ConP c noConPatternInfo . map (fmap unnamed) <$> termToPattern (fromMaybe __IMPOSSIBLE__ $ allApplyElims args)+    Def s [Apply arg] -> ifDotPats $ do       suc <- terGetSizeSuc       if Just s == suc then ConP (ConHead s IsData Inductive []) noConPatternInfo . map (fmap unnamed) <$> termToPattern [arg]-       else return $ dotP t+       else fallback     DontCare t  -> termToPattern t -- OR: __IMPOSSIBLE__  -- removed by stripAllProjections     -- Leaves.     Var i []    -> varP . (`DBPatVar` i) . prettyShow <$> nameOfBV i     Lit l       -> return $ litP l     Dummy s _   -> __IMPOSSIBLE_VERBOSE__ s-    t           -> return $ dotP t-+    t           -> fallback+    where+    -- Andreas, 2022-06-14, issues #5953 and #4725+    -- Recognize variable and record patterns in dot patterns regardless+    -- of whether dot-pattern termination is on.+    ifDotPats           = ifNotM terGetUseDotPatterns fallback+    ifDotPatsOrRecord c = ifM (pure (IsData == conDataRecord c) `and2M` do not <$> terGetUseDotPatterns) fallback+    fallback            = return $ dotP t  -- | Masks all non-data/record type patterns if --without-K. --   See issue #1023.@@ -686,6 +756,7 @@       Inf f n    -> return empty       SizeUniv   -> return empty       LockUniv   -> return empty+      IntervalUniv -> return empty       Type t     -> terUnguarded $ extract t  -- no guarded levels       Prop t     -> terUnguarded $ extract t       SSet t     -> terUnguarded $ extract t@@ -701,6 +772,11 @@ instance ExtractCalls Type where   extract (El s t) = extract (s, t) +instance ExtractCalls a => ExtractCalls (Tele a) where+  extract = \case+    EmptyTel        -> mempty+    ExtendTel a tel -> extract a <> extract tel+ -- | Extract recursive calls from a constructor application.  constructor@@ -756,13 +832,16 @@           ]      -- insert this call into the call list-    case List.elemIndex g names of+    case Set.lookupIndex g names of         -- call leads outside the mutual block and can be ignored        Nothing   -> return calls -       -- call is to one of the mutally recursive functions+       -- call is to one of the mutally recursive functions/record        Just gInd -> do+         cutoff <- terGetCutOff+         let ?cutoff = cutoff+          delayed <- terGetDelayed          -- Andreas, 2017-02-14, issue #2458:          -- If we have inlined with-functions, we could be illtyped,@@ -798,15 +877,30 @@          -- spent on call matrix generation          (nrows, ncols, matrix) <- billTo [Benchmark.Termination, Benchmark.Compare] $            compareArgs es-         -- only a delayed definition can be guarded-         let ifDelayed o | Order.decreasing o && delayed == NotDelayed = Order.le-                         | otherwise                                  = o++         -- Andreas, 2022-03-21, #5823:+         -- If we are "calling" a record type we are guarded unless the origin+         -- of the termination analysis is itself a record.+         -- This is because we usually do not "unfold" record types into their+         -- field telescope.  We only do so when trying to construct the+         -- unique inhabitant of record type (singleton analysis).+         -- In the latter case, a call to a record type is not guarding.+         guarded' <- isRecord g >>= \case+           Just{} -> terGetTarget >>= \case+             TargetRecord+               -> return guarded+             _ -> return (guarded .*. Order.lt)+                    -- guarding when we call a record and not termination checking a record+           Nothing+             -- only a delayed definition can be guarded+             | Order.decreasing guarded && delayed == NotDelayed+               -> return Order.le+             | otherwise+               -> return guarded          liftTCM $ reportSLn "term.guardedness" 20 $            "composing with guardedness " ++ prettyShow guarded ++-           " counting as " ++ prettyShow (ifDelayed guarded)-         cutoff <- terGetCutOff-         let ?cutoff = cutoff-         let matrix' = composeGuardedness (ifDelayed guarded) matrix+           " counting as " ++ prettyShow guarded'+         let matrix' = composeGuardedness guarded' matrix           -- Andreas, 2013-04-26 FORBIDDINGLY expensive!          -- This PrettyTCM QName cost 50% of the termination time for std-lib!!@@ -830,14 +924,14 @@            -- Andreas, 2017-01-05, issue #2376            -- Remove arguments inserted by etaExpandClause. -         let src  = fromMaybe __IMPOSSIBLE__ $ List.elemIndex f names+         let src  = fromMaybe __IMPOSSIBLE__ $ Set.lookupIndex f names              tgt  = gInd              cm   = makeCM ncols nrows matrix'-             info = CallPath [CallInfo+             info = CallPath $ singleton $+                    CallInfo                       { callInfoTarget = g-                      , callInfoRange  = getRange g                       , callInfoCall   = doc-                      }]+                      }          verboseS "term.kept.call" 5 $ do            pats <- terGetPatterns            reportSDoc "term.kept.call" 5 $ vcat@@ -887,7 +981,7 @@    -- Finally, try to reduce with the non-recursive clauses (and no rewrite rules).   r <- liftTCM $ modifyAllowedReductions (SmallSet.delete UnconfirmedReductions) $-    runReduceM $ appDefE' v0 cls [] (map notReduced es)+    runReduceM $ appDefE' g v0 cls [] (map notReduced es)   case r of     NoReduction{}    -> fallback     YesReduction _ v -> do@@ -909,29 +1003,36 @@  instance ExtractCalls Term where   extract t = do-    liftTCM $ reportSDoc "term.check.term" 50 $ do+    reportSDoc "term.check.term" 50 $ do       "looking for calls in" <+> prettyTCM t      -- Instantiate top-level MetaVar.-    t <- liftTCM $ instantiate t-    case t of+    instantiate t >>= \case        -- Constructed value.       Con ConHead{conName = c, conDataRecord = dataOrRec} _ es -> do         let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es         -- A constructor preserves the guardedness of all its arguments.-        let argsg = zip args $ repeat True+        -- Andreas, 2022-09-19, issue #6108:+        -- A higher constructor does not.  So check if there is an @IApply@ amoung @es@.+        let argsg = zip args $ repeat $ all isProperApplyElim es          -- If we encounter a coinductive record constructor         -- in a type mutual with the current target         -- then we count it as guarding.-        let inductive   = return Inductive-            coinductive = return CoInductive+        let inductive   = return Inductive    -- not guarding, but preserving+            coinductive = return CoInductive  -- guarding+        -- ♯ is guarding         ind <- ifM ((Just c ==) <$> terGetSharp) coinductive $ {-else-} do+          -- data constructors are not guarding           if dataOrRec == IsData then inductive else do-          caseMaybeM (liftTCM $ isRecordConstructor c) inductive $ \ (q, def) -> do+          -- abstract constructors are not guarding+          caseMaybeM (isRecordConstructor c) inductive $ \ (q, def) -> do             reportSLn "term.check.term" 50 $ "constructor " ++ prettyShow c ++ " has record type " ++ prettyShow q+            -- inductive record constructors are not guarding             if recInduction def /= Just CoInductive then inductive else do+            -- coinductive constructors unrelated to the mutually+            -- constructed inhabitants of coinductive types are not guarding             ifM (targetElem . fromMaybe __IMPOSSIBLE__ $ recMutual def)                {-then-} coinductive                {-else-} inductive@@ -946,17 +1047,16 @@       -- Neutral term. Destroys guardedness.       Var i es -> terUnguarded $ extract es -      -- Dependent function space. Destroys guardedness.+      -- Dependent function space.       Pi a (Abs x b) ->-        terUnguarded $         CallGraph.union <$>         extract a <*> do           a <- maskSizeLt a  -- OR: just do not add a to the context!           addContext (x, a) $ terRaise $ extract b -      -- Non-dependent function space. Destroys guardedness.+      -- Non-dependent function space.       Pi a (NoAbs _ b) ->-        terUnguarded $ CallGraph.union <$> extract a <*> extract b+        CallGraph.union <$> extract a <*> extract b        -- Literal.       Lit l -> return empty@@ -1035,7 +1135,7 @@   let guardedness =         if useGuardedness         then decr True $ projsCaller - projsCallee-        else Order.Unknown+        else Order.le   liftTCM $ reportSDoc "term.guardedness" 30 $ sep     [ "compareArgs:"     , nest 2 $ text $ "projsCaller = " ++ prettyShow projsCaller@@ -1328,14 +1428,17 @@ compareConArgs ts ps = do   cutoff <- terGetCutOff   let ?cutoff = cutoff-  -- we may assume |ps| >= |ts|, otherwise c ps would be of functional type-  -- which is impossible-  case (length ts, length ps) of-    (0,0) -> return Order.le        -- c <= c-    (0,1) -> return Order.unknown   -- c not<= c x-    (1,0) -> __IMPOSSIBLE__-    (1,1) -> compareTerm' (unArg (head ts)) (notMasked $ namedArg $ head ps)-    (_,_) -> foldl (Order..*.) Order.le <$>+  case compare (length ts) (length ps) of++    -- We may assume |ps| >= |ts|, otherwise c ps would be of functional type+    -- which is impossible.+    GT -> __IMPOSSIBLE__++    -- Andreas, 2022-08-31, issue #6059: doing anything smarter than+    -- @unknown@ here can lead to non-termination.+    LT -> return Order.unknown++    EQ -> List.foldl' (Order..*.) Order.le <$>                zipWithM compareTerm' (map unArg ts) (map (notMasked . namedArg) ps)        -- corresponds to taking the size, not the height        -- allows examples like (x, y) < (Succ x, y)
src/full/Agda/TypeChecking/Abstract.hs view
@@ -5,7 +5,7 @@ import Control.Monad import Control.Monad.Except -import Data.Function+import Data.Function (on) import qualified Data.HashMap.Strict as HMap  import Agda.Syntax.Common@@ -81,9 +81,10 @@   pure $ mkPi (setHiding (getHiding info) $ defaultDom ("w", a))        $ mkPi (setHiding NotHidden        $ defaultDom ("eq", eq))        $ b-piAbstract (Arg info (prf, eqt@(EqualityType _ _ _ (Arg _ a) v _))) b = do+piAbstract (Arg info (prf, EqualityViewType eqt@(EqualityTypeData _ _ _ (Arg _ a) v _))) b = do   s <- sortOf a-  let prfTy = equalityUnview eqt+  let prfTy :: Type+      prfTy = equalityUnview eqt       vTy   = El s a   b <- abstractType prfTy prf b   b <- addContext ("w" :: String, defaultDom prfTy) $@@ -92,8 +93,10 @@   where     funType str a = mkPi $ setArgInfo info $ defaultDom (str, a)     -- Abstract the lhs (@a@) of the equality only.+    eqt1 :: EqualityTypeData     eqt1  = raise 1 eqt-    eqTy' = equalityUnview $ eqt1 { eqtLhs = eqtLhs eqt1 $> var 0 }+    eqTy' :: Type+    eqTy' = equalityUnview $ eqt1{ _eqtLhs = _eqtLhs eqt1 $> var 0 }   -- | @isPrefixOf u v = Just es@ if @v == u `applyE` es@.@@ -208,6 +211,7 @@     SSet n     -> SSet $ absS n     SizeUniv   -> SizeUniv     LockUniv   -> LockUniv+    IntervalUniv -> LockUniv     PiSort a s1 s2 -> PiSort (absS a) (absS s1) (absS s2)     FunSort s1 s2 -> FunSort (absS s1) (absS s2)     UnivSort s -> UnivSort $ absS s@@ -329,9 +333,9 @@  -- | Ignore the tactic. instance EqualSy a => EqualSy (Dom a) where-  equalSy d@(Dom ai b x _tac a) d'@(Dom ai' b' x' _tac' a') = and+  equalSy d@(Dom ai x f _tac a) d'@(Dom ai' x' f' _tac' a') = and     [ x == x'-    , b == b'+    , f == f'     , equalSy ai ai'     , equalSy a a'     ]
src/full/Agda/TypeChecking/CheckInternal.hs view
@@ -41,6 +41,7 @@   import Agda.Utils.Functor (($>))+import Agda.Utils.Pretty  (prettyShow) import Agda.Utils.Size  import Agda.Utils.Impossible@@ -162,12 +163,12 @@     [ "checking internal "     , nest 2 $ sep [ prettyTCM v <+> ":"                    , nest 2 $ prettyTCM t ] ]-  reportSDoc "tc.check.internal" 30 $ sep+  reportSDoc "tc.check.internal" 60 $ sep     [ "checking internal with DB indices"     , nest 2 $ sep [ pretty v <+> ":"                    , nest 2 $ pretty t ] ]   ctx <- getContextTelescope-  reportSDoc "tc.check.internal" 30 $ sep+  unless (null ctx) $ reportSDoc "tc.check.internal" 30 $ sep     [ "In context"     , nest 2 $ sep [ prettyTCM ctx ] ]   -- Bring projection-like funs in post-fix form,@@ -215,7 +216,7 @@                                NoAbs{} -> id       a <- mkDom <$> checkInternal' action (unEl $ unDom a) CmpLeq (sort sa)       v' <- goInside $ Pi a . mkRng <$> checkInternal' action (unEl $ unAbs b) CmpLeq (sort sb)-      s' <- sortOf v'+      s' <- sortOf v -- Issue #6205: do not use v' since it might not be valid syntax       compareSort cmp s' s       return v'     Sort s     -> do@@ -227,7 +228,7 @@       return $ Sort s     Level l    -> do       l <- checkLevel action l-      lt <- levelType+      lt <- levelType'       compareType cmp lt t       return $ Level l     DontCare v -> DontCare <$> checkInternal' action v cmp t@@ -322,8 +323,7 @@  -- | Infer type of a neutral term. infer :: (MonadCheckInternal m) => Term -> m Type-infer v = do-  case v of+infer = \case     Var i es   -> do       a <- typeOfBV i       snd <$> inferSpine a (Var i   []) es@@ -332,7 +332,10 @@     MetaV x es -> do -- we assume meta instantiations to be well-typed       a <- metaType x       snd <$> inferSpine a (MetaV x []) es-    _ -> __IMPOSSIBLE__+    v -> __IMPOSSIBLE_VERBOSE__ $ unlines+      [ "CheckInternal.infer: non-inferable term:"+      , "  " ++ prettyShow v+      ]  -- | Infer ordinary function application. inferDef :: (MonadCheckInternal m) => QName -> Elims -> m Type@@ -370,7 +373,7 @@     , "type t = " <+> pretty t     , "self  = " <+> pretty self     , "self' = " <+> pretty self'-    , "eliminated by e = " <+> text (show e)+    , "eliminated by e = " <+> pretty e     ]   case e of     IApply x y r -> do@@ -426,6 +429,7 @@     SSet l   -> SSet <$> checkLevel action l     SizeUniv -> return SizeUniv     LockUniv -> return LockUniv+    IntervalUniv -> return IntervalUniv     PiSort dom s1 s2 -> do       let a = unDom dom       s1' <- checkSort action s1@@ -465,7 +469,7 @@     checkPlusLevel (Plus k l)      = Plus k <$> checkLevelAtom l      checkLevelAtom l = do-      lvl <- levelType+      lvl <- levelType'       checkInternal' action l CmpLeq lvl  -- | Universe subsumption and type equality (subtyping for sizes, resp.).
src/full/Agda/TypeChecking/CompiledClause.hs view
@@ -14,11 +14,6 @@ import Data.Map (Map) import Data.Semigroup hiding (Arg(..)) ----import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Syntax.Common@@ -33,7 +28,7 @@ import Agda.Utils.Impossible  data WithArity c = WithArity { arity :: Int, content :: c }-  deriving (Data, Functor, Foldable, Traversable, Show, Generic)+  deriving (Functor, Foldable, Traversable, Show, Generic)  -- | Branches in a case tree. @@ -57,7 +52,7 @@     -- ^ Lazy pattern match. Requires single (non-copattern) branch with no lit     --   branches and no catch-all.   }-  deriving (Data, Functor, Foldable, Traversable, Show, Generic)+  deriving (Functor, Foldable, Traversable, Show, Generic)  -- | Case tree with bodies. @@ -75,7 +70,7 @@   | Fail [Arg ArgName]     -- ^ Absurd case. Add the free variables here as well so we can build correct     --   number of lambdas for strict backends. (#4280)-  deriving (Data, Functor, Traversable, Foldable, Show, Generic)+  deriving (Functor, Traversable, Foldable, Show, Generic)  type CompiledClauses = CompiledClauses' Term
src/full/Agda/TypeChecking/CompiledClause/Match.hs view
@@ -198,7 +198,7 @@   caseMaybeM (asksTC envAppDef) __IMPOSSIBLE__ $ \ f -> do     pds <- getPartialDefs     if f `elem` pds-    then return (NoReduction $ NotBlocked MissingClauses [])+    then return (NoReduction $ NotBlocked (MissingClauses f) [])     else do       ifM (optRewriting <$> pragmaOptions)       {-then-} (return (NoReduction $ NotBlocked ReallyNotBlocked [])) -- See #5396
src/full/Agda/TypeChecking/Constraints.hs view
@@ -26,6 +26,7 @@  import Agda.TypeChecking.Irrelevance import {-# SOURCE #-} Agda.TypeChecking.Rules.Application+import {-# SOURCE #-} Agda.TypeChecking.Rules.Data ( checkDataSort ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Def import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Conversion@@ -40,6 +41,7 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty (prettyShow)+import qualified Agda.Utils.ProfileOptions as Profile  import Agda.Utils.Impossible @@ -58,7 +60,14 @@       pids <- asksTC envActiveProblems       reportSDoc "tc.constr.add" 20 $ hsep         [ "adding constraint"-        , prettyTCM . PConstr pids unblock =<< buildClosure c ]+        , prettyTCM . PConstr pids unblock =<< buildClosure c+        , "unblocker: " , prettyTCM unblock+        ]+      -- Jesper, 2022-10-22: We should never block on a meta that is+      -- already solved. However, currently this is not always+      -- strictly adhered to. TODO: pull off the band-aid and+      -- uncomment the following line.+      -- whenM (anyM (Set.toList $ allBlockingMetas unblock) isInstantiatedMeta) __IMPOSSIBLE__       -- Need to reduce to reveal possibly blocking metas       c <- reduce =<< instantiateFull c       caseMaybeM (simpl c) {-no-} (addConstraint' unblock c) $ {-yes-} \ cs -> do@@ -192,16 +201,8 @@     stealConstraints pid     handler --- | Wake constraints matching the given predicate (and aren't instance---   constraints if 'shouldPostponeInstanceSearch').-wakeConstraints' :: (ProblemConstraint -> WakeUp) -> TCM ()-wakeConstraints' p = do-  skipInstance <- shouldPostponeInstanceSearch-  let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c)-  wakeConstraints $ wakeUpWhen (not . skip) p- -- | Wake up the constraints depending on the given meta.-wakeupConstraints :: MetaId -> TCM ()+wakeupConstraints :: MonadMetaSolver m => MetaId -> m () wakeupConstraints x = do   wakeConstraints' (wakeIfBlockedOnMeta x . constraintUnblocker)   solveAwakeConstraints@@ -215,17 +216,11 @@     wakeup u | Set.null $ allBlockingProblems u = WakeUp              | otherwise                        = DontWakeUp Nothing -solveAwakeConstraints :: (MonadConstraint m) => m ()-solveAwakeConstraints = solveAwakeConstraints' False--solveAwakeConstraints' :: (MonadConstraint m) => Bool -> m ()-solveAwakeConstraints' = solveSomeAwakeConstraints (const True)- -- | Solve awake constraints matching the predicate. If the second argument is --   True solve constraints even if already 'isSolvingConstraints'. solveSomeAwakeConstraintsTCM :: (ProblemConstraint -> Bool) -> Bool -> TCM () solveSomeAwakeConstraintsTCM solveThis force = do-    verboseS "profile.constraints" 10 $ liftTCM $ tickMax "max-open-constraints" . List.genericLength =<< getAllConstraints+    whenProfile Profile.Constraints $ liftTCM $ tickMax "max-open-constraints" . List.genericLength =<< getAllConstraints     whenM ((force ||) . not <$> isSolvingConstraints) $ nowSolvingConstraints $ do      -- solveSizeConstraints -- Andreas, 2012-09-27 attacks size constrs too early      -- Ulf, 2016-12-06: Don't inherit problems here! Stored constraints@@ -242,7 +237,7 @@  solveConstraintTCM :: Constraint -> TCM () solveConstraintTCM c = do-    verboseS "profile.constraints" 10 $ liftTCM $ tick "attempted-constraints"+    whenProfile Profile.Constraints $ liftTCM $ tick "attempted-constraints"     verboseBracket "tc.constr.solve" 20 "solving constraint" $ do       pids <- asksTC envActiveProblems       reportSDoc "tc.constr.solve.constr" 20 $ text (show $ Set.toList pids) <+> prettyTCM c@@ -262,8 +257,8 @@         reportSDoc "tc.constr.unblock" 15 $ hsep ["not unblocking", prettyTCM m, "because",                                                   ifM (isFrozen m) "it's frozen" "meta assignments are turned off"]         addConstraint alwaysUnblock $ UnBlock m) $ do-    inst <- mvInstantiation <$> lookupMeta m-    reportSDoc "tc.constr.unblock" 65 $ text ("unblocking a metavar yields the constraint: " ++ show inst)+    inst <- lookupMetaInstantiation m+    reportSDoc "tc.constr.unblock" 65 $ "unblocking a metavar yields the constraint:" <+> pretty inst     case inst of       BlockedConst t -> do         reportSDoc "tc.constr.blocked" 15 $@@ -296,9 +291,10 @@ solveConstraint_ (CheckLockedVars a b c d)   = checkLockedVars a b c d solveConstraint_ (HasBiggerSort a)      = hasBiggerSort a solveConstraint_ (HasPTSRule a b)       = hasPTSRule a b+solveConstraint_ (CheckDataSort q s)    = checkDataSort q s solveConstraint_ (CheckMetaInst m)      = checkMetaInst m solveConstraint_ (CheckType t)          = checkType t-solveConstraint_ (UsableAtModality mod t) = usableAtModality mod t+solveConstraint_ (UsableAtModality cc ms mod t) = usableAtModality' ms cc mod t  checkTypeCheckingProblem :: TypeCheckingProblem -> TCM Term checkTypeCheckingProblem = \case
src/full/Agda/TypeChecking/Constraints.hs-boot view
@@ -10,7 +10,6 @@  instance MonadConstraint TCM where -solveAwakeConstraints' :: MonadConstraint m => Bool -> m () noConstraints          :: (MonadConstraint m, MonadWarning m, MonadError TCErr m, MonadFresh ProblemId m)                        => m a -> m a ifNoConstraints_       :: TCM () -> TCM a -> (ProblemId -> TCM a) -> TCM a
src/full/Agda/TypeChecking/Conversion.hs view
@@ -8,12 +8,14 @@ -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) -import Data.Function+import Data.Function (on) import Data.Semigroup ((<>))-import qualified Data.List as List-import qualified Data.Map as Map-import qualified Data.Set as Set+import Data.IntMap (IntMap)++import qualified Data.List   as List+import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet+import qualified Data.Set    as Set  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -29,7 +31,7 @@ import qualified Agda.TypeChecking.SyntacticEquality as SynEq import Agda.TypeChecking.Telescope import Agda.TypeChecking.Constraints-import Agda.TypeChecking.Conversion.Pure (pureCompareAs)+import Agda.TypeChecking.Conversion.Pure (pureCompareAs, runPureConversion) import {-# SOURCE #-} Agda.TypeChecking.CheckInternal (infer) import Agda.TypeChecking.Forcing (isForced, nextIsForced) import Agda.TypeChecking.Free@@ -53,6 +55,9 @@ import Agda.Utils.Maybe import Agda.Utils.Permutation import Agda.Utils.Pretty (prettyShow)+import qualified Agda.Utils.ProfileOptions as Profile+import Agda.Utils.BoolSet (BoolSet)+import qualified Agda.Utils.BoolSet as BoolSet import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.WithDefault@@ -152,14 +157,17 @@     , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v     , nest 2 $ prettyTCM a     ]-  -- Check syntactic equality. This actually saves us quite a bit of work.-  ((u, v), equal) <- SynEq.checkSyntacticEquality u v+  whenProfile Profile.Conversion $ tick "compare"+   -- OLD CODE, traverses the *full* terms u v at each step, even if they   -- are different somewhere.  Leads to infeasibility in issue 854.   -- (u, v) <- instantiateFull (u, v)   -- let equal = u == v-  if equal then verboseS "profile.sharing" 20 $ tick "equal terms" else do-      verboseS "profile.sharing" 20 $ tick "unequal terms"++  -- Check syntactic equality. This actually saves us quite a bit of work.+  SynEq.checkSyntacticEquality u v+    (\_ _ -> whenProfile Profile.Conversion $ tick "compare equal") $+    \u v -> do       reportSDoc "tc.conv.term" 15 $ sep $         [ "compareTerm (not syntactically equal)"         , nest 2 $ prettyTCM u <+> prettyTCM cmp <+> prettyTCM v@@ -198,6 +206,7 @@           -- but irrelevant projections since they are applied to their parameters.           if isJust $ isRelevantProjection_ def then fallback else do           pol <- getPolarity' cmp f+          whenProfile Profile.Conversion $ tick "compare first-order shortcut"           compareElims pol [] (defType def) (Def f []) es es' `orelse` fallback         _               -> fallback   where@@ -209,9 +218,11 @@         , nest 2 $ prettyTCM (MetaV x es) <+> ":=" <+> prettyTCM v         ]       whenM (isInstantiatedMeta x) (patternViolation alwaysUnblock) -- Already instantiated, retry right away+      whenProfile Profile.Conversion $ tick "compare meta shortcut"       assignE dir x es v a $ compareAsDir dir a       reportSDoc "tc.conv.term.shortcut" 50 $         "shortcut successful" $$ nest 2 ("result:" <+> (pretty =<< instantiate (MetaV x es)))+      whenProfile Profile.Conversion $ tick "compare meta shortcut successful"     -- Should be ok with catchError_ but catchError is much safer since we don't     -- rethrow errors.     orelse :: m () -> m () -> m ()@@ -221,7 +232,8 @@ --   and run conversion check again. assignE :: (MonadConversion m)         => CompareDirection -> MetaId -> Elims -> Term -> CompareAs -> (Term -> Term -> m ()) -> m ()-assignE dir x es v a comp = assignWrapper dir x es v $ do+assignE dir x es v a comp = do+  whenProfile Profile.Conversion $ tick "compare meta"   case allApplyElims es of     Just vs -> assignV dir x vs v a     Nothing -> do@@ -241,7 +253,7 @@           comp w v         Nothing ->  do           reportSLn "tc.conv.assign" 30 "eta expansion did not instantiate meta"-          patternViolation (unblockOnAnyMetaIn (MetaV x es)) -- nothing happened, give up+          patternViolation $ unblockOnMeta x -- nothing happened, give up  compareAsDir :: MonadConversion m => CompareDirection -> CompareAs -> Term -> Term -> m () compareAsDir dir a = dirToCmp (`compareAs'` a) dir@@ -263,6 +275,9 @@     isSize   <- isJust <$> isSizeType a'     (bs, s)  <- reduceWithBlocker $ getSort a'     mlvl     <- getBuiltin' builtinLevel+    reportSDoc "tc.conv.term" 40 $ fsep+      [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a'+      , "at sort", prettyTCM s]     reportSDoc "tc.conv.level" 60 $ nest 2 $ sep       [ "a'   =" <+> pretty a'       , "mlvl =" <+> pretty mlvl@@ -277,11 +292,17 @@           b <- levelView n           equalLevel a b         a@Pi{}    -> equalFun s a m n-        Lam _ _   -> __IMPOSSIBLE__+        Lam _ _   -> do+          reportSDoc "tc.conv.term.sort" 10 $ fsep+            [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a'+            , "at sort", prettyTCM s+            ]+          __IMPOSSIBLE__         Def r es  -> do           isrec <- isEtaRecord r           if isrec             then do+              whenProfile Profile.Conversion $ tick "compare at eta record"               sig <- getSignature               let ps = fromMaybe __IMPOSSIBLE__ $ allApplyElims es               -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem@@ -303,24 +324,26 @@               mNeutral <- isNeutral m               n <- reduceB n               nNeutral <- isNeutral n-              case (m, n) of-                _ | isMeta m || isMeta n ->-                    compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)--                _ | mNeutral && nNeutral -> do-                    -- Andreas 2011-03-23: (fixing issue 396)-                    -- if we are dealing with a singleton record,-                    -- we can succeed immediately-                    ifM (isSingletonRecordModuloRelevance r ps) (return ()) $-                      -- do not eta-expand if comparing two neutrals-                      compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)-                _ -> do-                  (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m-                  (_  , n') <- etaExpandRecord r ps $ ignoreBlocking n-                  -- No subtyping on record terms-                  c <- getRecordConstructor r-                  -- Record constructors are covariant (see test/succeed/CovariantConstructors).-                  compareArgs (repeat $ polFromCmp cmp) [] (telePi_ tel __DUMMY_TYPE__) (Con c ConOSystem []) m' n'+              if | isMeta m || isMeta n -> do+                     whenProfile Profile.Conversion $ tick "compare at eta-record: meta"+                     compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)+                 | mNeutral && nNeutral -> do+                     whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral"+                     -- Andreas 2011-03-23: (fixing issue 396)+                     -- if we are dealing with a singleton record,+                     -- we can succeed immediately+                     let profUnitEta = whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral at unit"+                     ifM (isSingletonRecordModuloRelevance r ps) (profUnitEta) $ do+                       -- do not eta-expand if comparing two neutrals+                       compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)+                 | otherwise -> do+                     whenProfile Profile.Conversion $ tick "compare at eta-record: eta-expanding"+                     (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m+                     (_  , n') <- etaExpandRecord r ps $ ignoreBlocking n+                     -- No subtyping on record terms+                     c <- getRecordConstructor r+                     -- Record constructors are covariant (see test/succeed/CovariantConstructors).+                     compareArgs (repeat $ polFromCmp cmp) [] (telePi_ tel __DUMMY_TYPE__) (Con c ConOSystem []) m' n'              else (do pathview <- pathView a'                      equalPath pathview a' m n)@@ -328,21 +351,26 @@   where     -- equality at function type (accounts for eta)     equalFun :: (MonadConversion m) => Sort -> Term -> Term -> Term -> m ()-    equalFun s a@(Pi dom b) m n | domFinite dom = do+    equalFun s a@(Pi dom b) m n | domIsFinite dom = do        mp <- fmap getPrimName <$> getBuiltin' builtinIsOne+       let asFn = El s (Pi (dom { domIsFinite = False }) b)        case unEl $ unDom dom of           Def q [Apply phi]-              | Just q == mp -> compareTermOnFace cmp (unArg phi) (El s (Pi (dom {domFinite = False}) b)) m n-          _                  -> equalFun s (Pi (dom{domFinite = False}) b) m n-    equalFun _ (Pi dom@Dom{domInfo = info} b) m n | not $ domFinite dom = do+              | Just q == mp -> compareTermOnFace cmp (unArg phi) asFn m n+          _                  -> equalFun s (unEl asFn) m n++    equalFun _ (Pi dom@Dom{domInfo = info} b) m n = do+        whenProfile Profile.Conversion $ tick "compare at function type"         let name = suggests [ Suggestion b , Suggestion m , Suggestion n ]         addContext (name, dom) $ compareTerm cmp (absBody b) m' n'       where         (m',n') = raise 1 (m,n) `apply` [Arg info $ var 0]+     equalFun _ _ _ _ = __IMPOSSIBLE__      equalPath :: (MonadConversion m) => PathView -> Type -> Term -> Term -> m ()     equalPath (PathType s _ l a x y) _ m n = do+        whenProfile Profile.Conversion $ tick "compare at path type"         let name = "i" :: String         interval <- el primInterval         let (m',n') = raise 1 (m, n) `applyE` [IApply (raise 1 $ unArg x) (raise 1 $ unArg y) (var 0)]@@ -364,7 +392,23 @@               unglue <- prim_unglue               let mkUnglue m = apply unglue $ map (setHiding Hidden) args ++ [argN m]               reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n)-              compareTermOnFace cmp (unArg phi) a' m n++              -- When φ is an interval expression which can be+              -- decomposed into substitutions σ, then we also compare+              -- the terms m[σ] = n[σ] at the type (Glue a φ _)[σ]. This+              -- is because, under decomposing φ, the Glue type might+              -- reduce.+              phi' <- decomposeInterval' (unArg phi)+              -- However if φ is *not* decomposable (e.g. because it is+              -- a function application φ i, see Issue #5955), then we+              -- do not recur, otherwise we'd just end up right back+              -- here.+              unless (IntMap.null (foldMap fst phi')) $+                compareTermOnFace cmp (unArg phi) a' m n++              -- And in the general case, we compare the glued things by+              -- "eta": m and n are the same if they unglue to the same+              -- thing.               compareTerm cmp aty (mkUnglue m) (mkUnglue n)          Def q es | Just q == mHComp, Just (sl:s:args@[phi,u,u0]) <- allApplyElims es                   , Sort (Type lvl) <- unArg s@@ -414,6 +458,7 @@     targ <- abortIfBlocked targ     fromMaybeM __IMPOSSIBLE__ $ getDefType f targ + -- | Syntax directed equality on atomic values -- compareAtom :: forall m. MonadConversion m => Comparison -> CompareAs -> Term -> Term -> m ()@@ -427,15 +472,17 @@                              , prettyTCM n                              , prettyTCM t                              ]+    whenProfile Profile.Conversion $ tick "compare by reduction"+    -- Are we currently defining mutual functions? Which?+    currentMutuals <- maybe (pure Set.empty) (mutualNames <.> lookupMutualBlock) =<< asksTC envMutualBlock+     -- Andreas: what happens if I cut out the eta expansion here?     -- Answer: Triggers issue 245, does not resolve 348     (mb',nb') <- do       mb' <- etaExpandBlocked =<< reduceB m       nb' <- etaExpandBlocked =<< reduceB n       return (mb', nb')-    let getBlocker (Blocked b _) = b-        getBlocker NotBlocked{}  = neverUnblock-        blocker = unblockOnEither (getBlocker mb') (getBlocker nb')+    let blocker = unblockOnEither (getBlocker mb') (getBlocker nb')     reportSLn "tc.conv.atom.size" 50 $ "term size after reduce: " ++ show (termSize $ ignoreBlocking mb', termSize $ ignoreBlocking nb')      -- constructorForm changes literal to constructors@@ -468,48 +515,15 @@                              , prettyTCM t                              ]     reportSDoc "tc.conv.atom" 80 $-      "compareAtom" <+> fsep [ (text . show) mb <+> prettyTCM cmp-                                  , (text . show) nb-                                  , ":" <+> (text . show) t ]+      "compareAtom" <+> fsep [ pretty mb <+> prettyTCM cmp+                                  , pretty nb+                                  , ":" <+> pretty t ]     case (mb, nb) of       -- equate two metas x and y.  if y is the younger meta,       -- try first y := x and then x := y       _ | MetaV x xArgs <- ignoreBlocking mb,   -- Can be either Blocked or NotBlocked depending on           MetaV y yArgs <- ignoreBlocking nb -> -- envCompareBlocked check above.-        if | x == y, cmpBlocked -> do-              a <- metaType x-              blockOnError (unblockOnMeta x) $-                compareElims [] [] a (MetaV x []) xArgs yArgs-           | x == y -> blockOnError (unblockOnMeta x) $-            case intersectVars xArgs yArgs of-              -- all relevant arguments are variables-              Just kills -> do-                -- kills is a list with 'True' for each different var-                killResult <- killArgs kills x-                case killResult of-                  NothingToPrune   -> return ()-                  PrunedEverything -> return ()-                  PrunedNothing    -> checkDefinitionalEquality-                  PrunedSomething  -> checkDefinitionalEquality-              -- not all relevant arguments are variables-              Nothing -> checkDefinitionalEquality -- Check definitional equality on meta-variables-                              -- (same as for blocked terms)-           | otherwise -> do-              [p1, p2] <- mapM getMetaPriority [x,y]-              -- First try the one with the highest priority. If that doesn't-              -- work, try the low priority one.-              let (solve1, solve2)-                    | (p1, x) > (p2, y) = (l1, r2)-                    | otherwise         = (r1, l2)-                    where l1 = assign dir x xArgs n-                          r1 = assign rid y yArgs m-                          -- Careful: the first attempt might prune the low-                          -- priority meta! (Issue #2978)-                          l2 = ifM (isInstantiatedMeta x) (compareAsDir dir t m n) l1-                          r2 = ifM (isInstantiatedMeta y) (compareAsDir rid t n m) r1--              -- Unblock on both unblockers of solve1 and solve2-              catchPatternErr (`addOrUnblocker` solve2) solve1+        compareMetas cmp t x xArgs y yArgs        -- one side a meta       _ | MetaV x es <- ignoreBlocking mb -> assign dir x es n@@ -517,7 +531,8 @@       (Blocked{}, Blocked{}) | not cmpBlocked  -> checkDefinitionalEquality       (Blocked b _, _) | not cmpBlocked -> useInjectivity (fromCmp cmp) b t m n   -- The blocked term  goes first       (_, Blocked b _) | not cmpBlocked -> useInjectivity (flipCmp $ fromCmp cmp) b t n m-      _ -> blockOnError blocker $ do+      bs -> do+        blockOnError blocker $ do         -- -- Andreas, 2013-10-20 put projection-like function         -- -- into the spine, to make compareElims work.         -- -- 'False' means: leave (Def f []) unchanged even for@@ -665,15 +680,63 @@                 [ "t1 =" <+> prettyTCM t1                 , "t2 =" <+> prettyTCM t2                 ]-              compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC $+              compareDom cmp dom2 dom1 b1 b2 errH errR errQ errC errF $                 compareType cmp (absBody b1) (absBody b2)             where             errH = typeError $ UnequalHiding t1 t2             errR = typeError $ UnequalRelevance cmp t1 t2             errQ = typeError $ UnequalQuantity  cmp t1 t2             errC = typeError $ UnequalCohesion cmp t1 t2+            errF = typeError $ UnequalFiniteness cmp t1 t2           _ -> __IMPOSSIBLE__ +-- | Check whether @x xArgs `cmp` y yArgs@+compareMetas :: MonadConversion m => Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> m ()+compareMetas cmp t x xArgs y yArgs | x == y = blockOnError (unblockOnMeta x) $ do+  cmpBlocked <- viewTC eCompareBlocked+  let ok    = return ()+      notOk = patternViolation neverUnblock+      fallback = do+        -- Fallback: check definitional equality+        a <- metaType x+        runPureConversion (compareElims [] [] a (MetaV x []) xArgs yArgs) >>= \case+          Just{}  -> ok+          Nothing -> notOk+  if | cmpBlocked -> do+         a <- metaType x+         compareElims [] [] a (MetaV x []) xArgs yArgs+     | otherwise -> case intersectVars xArgs yArgs of+         -- all relevant arguments are variables+         Just kills -> do+           -- kills is a list with 'True' for each different var+           killResult <- killArgs kills x+           case killResult of+             NothingToPrune   -> ok+             PrunedEverything -> ok+             PrunedNothing    -> fallback+             PrunedSomething  -> fallback+         -- not all relevant arguments are variables+         Nothing -> fallback+compareMetas cmp t x xArgs y yArgs = do+  [p1, p2] <- mapM getMetaPriority [x,y]+  let dir = fromCmp cmp+      rid = flipCmp dir     -- The reverse direction.  Bad name, I know.+      retry = patternViolation alwaysUnblock+  -- First try the one with the highest priority. If that doesn't+  -- work, try the low priority one.+  let (solve1, solve2)+        | (p1, x) > (p2, y) = (l1, r2)+        | otherwise         = (r1, l2)+        where l1 = assignE dir x xArgs (MetaV y yArgs) t $ \ _ _ -> retry+              r1 = assignE rid y yArgs (MetaV x xArgs) t $ \ _ _ -> retry+              -- Careful: the first attempt might prune the low+              -- priority meta! (Issue #2978)+              l2 = ifM (isInstantiatedMeta x) retry l1+              r2 = ifM (isInstantiatedMeta y) retry r1++  -- Unblock on both unblockers of solve1 and solve2+  catchPatternErr (`addOrUnblocker` solve2) solve1+ -- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@. compareDom :: (MonadConversion m , Free c)   => Comparison -- ^ @cmp@ The comparison direction@@ -685,18 +748,18 @@   -> m ()     -- ^ Continuation if mismatch in 'Relevance'.   -> m ()     -- ^ Continuation if mismatch in 'Quantity'.   -> m ()     -- ^ Continuation if mismatch in 'Cohesion'.+  -> m ()     -- ^ Continuation if mismatch in 'annFinite'.   -> m ()     -- ^ Continuation if comparison is successful.   -> m () compareDom cmp0   dom1@(Dom{domInfo = i1, unDom = a1})   dom2@(Dom{domInfo = i2, unDom = a2})-  b1 b2 errH errR errQ errC cont = do-  hasSubtyping <- collapseDefault . optSubtyping <$> pragmaOptions-  let cmp = if hasSubtyping then cmp0 else CmpEq+  b1 b2 errH errR errQ errC errF cont = do   if | not $ sameHiding dom1 dom2 -> errH-     | not $ compareRelevance cmp (getRelevance dom1) (getRelevance dom2) -> errR-     | not $ compareQuantity  cmp (getQuantity  dom1) (getQuantity  dom2) -> errQ-     | not $ compareCohesion  cmp (getCohesion  dom1) (getCohesion  dom2) -> errC+     | not $ (==)         (getRelevance dom1) (getRelevance dom2) -> errR+     | not $ sameQuantity (getQuantity  dom1) (getQuantity  dom2) -> errQ+     | not $ sameCohesion (getCohesion  dom1) (getCohesion  dom2) -> errC+     | not $ domIsFinite dom1 == domIsFinite dom2 -> errF      | otherwise -> do       let r = max (getRelevance dom1) (getRelevance dom2)               -- take "most irrelevant"@@ -715,18 +778,6 @@         -- Only the domain type in context will be blocked.         -- But see issue #1258. -compareRelevance :: Comparison -> Relevance -> Relevance -> Bool-compareRelevance CmpEq  = (==)-compareRelevance CmpLeq = (<=)--compareQuantity :: Comparison -> Quantity -> Quantity -> Bool-compareQuantity CmpEq  = sameQuantity-compareQuantity CmpLeq = moreQuantity--compareCohesion :: Comparison -> Cohesion -> Cohesion -> Bool-compareCohesion CmpEq  = sameCohesion-compareCohesion CmpLeq = moreCohesion- -- | When comparing argument spines (in compareElims) where the first arguments --   don't match, we keep going, substituting the anti-unification of the two --   terms in the telescope. More precisely:@@ -746,8 +797,7 @@ --   #2384. antiUnify :: MonadConversion m => ProblemId -> Type -> Term -> Term -> m Term antiUnify pid a u v = do-  ((u, v), eq) <- SynEq.checkSyntacticEquality u v-  if eq then return u else do+  SynEq.checkSyntacticEquality u v (\u _ -> return u) $ \u v -> do   (u, v) <- reduce (u, v)   reportSDoc "tc.conv.antiUnify" 30 $ vcat     [ "antiUnify"@@ -1000,12 +1050,14 @@     [ nest 2 $ "v =" <+> pretty v     , nest 2 $ "w =" <+> pretty w     ]+  whenProfile Profile.Conversion $ tick "compare irrelevant"   try v w $ try w v $ return ()   where     try (MetaV x es) w fallback = do-      mv <- lookupMeta x-      let rel  = getMetaRelevance mv-          inst = case mvInstantiation mv of+      mi <- lookupMetaInstantiation x+      mm <- lookupMetaModality x+      let rel  = getRelevance mm+          inst = case mi of                    InstV{} -> True                    _       -> False       reportSDoc "tc.conv.irr" 20 $ vcat@@ -1171,28 +1223,51 @@ --   unrelated to the other universes. -- leqSort :: forall m. MonadConversion m => Sort -> Sort -> m ()-leqSort s1 s2 = (catchConstraint (SortCmp CmpLeq s1 s2) :: m () -> m ()) $ do-  (s1,s2) <- reduce (s1,s2)-  let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) (SortCmp CmpLeq s1 s2)-      no       = typeError $ NotLeqSort s1 s2-      yes      = return ()-      synEq    = ifNotM (optSyntacticEquality <$> pragmaOptions) postpone $ do-        ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2-        if | equal     -> yes-           | otherwise -> postpone+leqSort s1 s2 = do   reportSDoc "tc.conv.sort" 30 $     sep [ "leqSort"         , nest 2 $ fsep [ prettyTCM s1 <+> "=<"                         , prettyTCM s2 ]         ]-  propEnabled <- isPropEnabled-  typeInTypeEnabled <- typeInType-  omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions+  reportSDoc "tc.conv.sort" 60 $+    sep [ "leqSort"+        , nest 2 $ fsep [ pretty s1 <+> "=<"+                        , pretty s2 ]+        ]+  whenProfile Profile.Conversion $ tick "compare sorts" -  let fvsRHS = (`IntSet.member` allFreeVars s2)-  badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS+  SynEq.checkSyntacticEquality s1 s2 (\_ _ -> return ()) $ \s1 s2 -> do -  case (s1, s2) of+    s1b <- reduceB s1+    s2b <- reduceB s2++    let (s1,s2) = (ignoreBlocking s1b , ignoreBlocking s2b)+        blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b)+        postpone = patternViolation blocker++    let postponeIfBlocked = catchPatternErr $ \blocker -> do+          if | blocker == neverUnblock -> typeError $ NotLeqSort s1 s2+             | otherwise -> do+                 reportSDoc "tc.conv.sort" 30 $ vcat+                   [ "Postponing constraint"+                   , nest 2 $ fsep [ prettyTCM s1 <+> "=<"+                                   , prettyTCM s2 ]+                   ]+                 reportSDoc "tc.conv.sort" 60 $ vcat+                   [ "Postponing constraint"+                   , nest 2 $ fsep [ pretty s1 <+> "=<"+                                   , pretty s2 ]+                   ]+                 addConstraint blocker $ SortCmp CmpLeq s1 s2++    propEnabled <- isPropEnabled+    typeInTypeEnabled <- typeInType+    omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions++    let fvsRHS = (`IntSet.member` allFreeVars s2)+    badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS++    postponeIfBlocked $ case (s1, s2) of       -- Andreas, 2018-09-03: crash on dummy sort       (DummyS s, _) -> impossibleSort s       (_, DummyS s) -> impossibleSort s@@ -1232,15 +1307,16 @@       (SSet{}  , Inf IsStrict _) -> yes       (SSet{}  , Inf IsFibrant _) -> no -      -- @SizeUniv@ and @Prop0@ are bottom sorts.+      -- @LockUniv@, @IntervalUniv@, @SizeUniv@, and @Prop0@ are bottom sorts.       -- So is @Set0@ if @Prop@ is not enabled.       (_       , LockUniv) -> equalSort s1 s2+      (_       , IntervalUniv) -> equalSort s1 s2       (_       , SizeUniv) -> equalSort s1 s2       (_       , Prop (Max 0 [])) -> equalSort s1 s2       (_       , Type (Max 0 []))         | not propEnabled  -> equalSort s1 s2 -      -- SizeUniv is unrelated to any @Set l@ or @Prop l@+      -- @SizeUniv@ and @LockUniv@ are unrelated to any @Set l@ or @Prop l@       (SizeUniv, Type{}  ) -> no       (SizeUniv, Prop{}  ) -> no       (SizeUniv , Inf{}  ) -> no@@ -1250,27 +1326,37 @@       (LockUniv , Inf{}  ) -> no       (LockUniv, SSet{}  ) -> no +      -- @IntervalUniv@ is below @SSet l@, but not @Set l@ or @Prop l@+      (IntervalUniv, Type{}) -> no+      (IntervalUniv, Prop{}) -> no+      (IntervalUniv , Inf IsStrict _) -> yes+      (IntervalUniv , Inf IsFibrant _) -> no+      (IntervalUniv , SSet b) -> leqLevel (ClosedLevel 0) b+       -- If the first sort is a small sort that rigidly depends on a       -- variable and the second sort does not mention this variable,       -- the second sort must be at least @Setω@.-      (_       , _       ) | Just (True,f) <- isSmallSort s1 , badRigid -> leqSort (Inf f 0) s2+      (_       , _       ) | Right (SmallSort f) <- sizeOfSort s1 , badRigid -> leqSort (Inf f 0) s2        -- PiSort, FunSort, UnivSort and MetaS might reduce once we instantiate       -- more metas, so we postpone.-      (PiSort{}, _       ) -> synEq-      (_       , PiSort{}) -> synEq-      (FunSort{}, _      ) -> synEq-      (_      , FunSort{}) -> synEq-      (UnivSort{}, _     ) -> synEq-      (_     , UnivSort{}) -> synEq-      (MetaS{} , _       ) -> synEq-      (_       , MetaS{} ) -> synEq+      (PiSort{}, _       ) -> postpone+      (_       , PiSort{}) -> postpone+      (FunSort{}, _      ) -> postpone+      (_      , FunSort{}) -> postpone+      (UnivSort{}, _     ) -> postpone+      (_     , UnivSort{}) -> postpone+      (MetaS{} , _       ) -> postpone+      (_       , MetaS{} ) -> postpone        -- DefS are postulated sorts, so they do not reduce.-      (DefS{} , _     ) -> synEq-      (_      , DefS{}) -> synEq+      (DefS{} , _     ) -> no+      (_      , DefS{}) -> no    where+  no  = patternViolation neverUnblock+  yes = return ()+   leqFib IsFibrant _ = True   leqFib IsStrict IsStrict = True   leqFib _ _ = False@@ -1287,9 +1373,15 @@         "compareLevel" <+>           sep [ prettyTCM a <+> "=<"               , prettyTCM b ]+      whenProfile Profile.Conversion $ tick "compare levels" -      (a, b) <- reduce (a, b)-      ((a, b), equal) <- SynEq.checkSyntacticEquality a b+      (a, b) <- normalise (a, b)+      SynEq.checkSyntacticEquality' a b+        (\_ _ ->+          reportSDoc "tc.conv.level" 60+            "checkSyntacticEquality returns True") $ \a b -> do+      reportSDoc "tc.conv.level" 60+        "checkSyntacticEquality returns False"        let notok    = unlessM typeInType $ typeError $ NotLeqSort (Type a) (Type b)           postpone = patternViolation (unblockOnAnyMetaIn (a, b))@@ -1298,10 +1390,6 @@             TypeError{} -> notok             err         -> throwError err -      reportSDoc "tc.conv.level" 60 $-        "checkSyntacticEquality returns" <+> prettyTCM equal-      unless equal $ do-       cumulativity <- optCumulativity <$> pragmaOptions       areWeComputingOverlap <- viewTC eConflComputingOverlap       reportSDoc "tc.conv.level" 40 $@@ -1369,7 +1457,7 @@           , not areWeComputingOverlap           , Just (mb@(MetaV x es) , bs') <- singleMetaView $ (map . fmap) ignoreBlocking (List1.toList bs)           , null bs' || noMetas (Level a , unSingleLevels bs') -> do-            mv <- lookupMeta x+            mv <- lookupLocalMeta x             -- Jesper, 2019-10-13: abort if this is an interaction             -- meta or a generalizable meta             abort <- (isJust <$> isInteractionMeta x) `or2M`@@ -1420,6 +1508,7 @@ equalLevel :: forall m. MonadConversion m => Level -> Level -> m () equalLevel a b = do   reportSDoc "tc.conv.level" 50 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ]+  whenProfile Profile.Conversion $ tick "compare levels"   -- Andreas, 2013-10-31 remove common terms (that don't contain metas!)   -- THAT's actually UNSOUND when metas are instantiated, because   --     max a b == max a c  does not imply  b == c@@ -1436,22 +1525,27 @@                               ]                ]         ]+  reportSDoc "tc.conv.level" 80 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ] -  (a, b) <- reduce (a, b)-  ((a, b), equal) <- SynEq.checkSyntacticEquality a b-  reportSDoc "tc.conv.level" 60 $-    "checkSyntacticEquality returns" <+> prettyTCM equal-  unless equal $ do+  (a, b) <- normalise (a, b)    -- Jesper, 2014-02-02 remove terms that certainly do not contribute   -- to the maximum   let (a', b') = removeSubsumed a b +  SynEq.checkSyntacticEquality' a' b'+    (\_ _ ->+      reportSDoc "tc.conv.level" 60+        "checkSyntacticEquality returns True") $ \a b -> do++  reportSDoc "tc.conv.level" 60 "checkSyntacticEquality returns False"+   let notok    = unlessM typeInType notOk       notOk    = typeError $ UnequalLevel CmpEq a' b'       postpone = do         reportSDoc "tc.conv.level" 30 $ hang "postponing:" 2 $ hang (pretty a' <+> "==") 0 (pretty b')-        patternViolation (unblockOnAnyMetaIn (a', b'))+        blocker <- unblockOnAnyMetaIn <$> instantiateFull (a', b')+        patternViolation blocker    reportSDoc "tc.conv.level" 50 $     sep [ "equalLevel (w/o subsumed)"@@ -1465,18 +1559,18 @@       bs  = levelMaxView b'   reportSDoc "tc.conv.level" 50 $     sep [ text "equalLevel"-        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as+        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (prettyTCM . unSingleLevel) as                               , "=="-                              , prettyList_ $ fmap (pretty . unSingleLevel) bs+                              , prettyList_ $ fmap (prettyTCM . unSingleLevel) bs                               ]                ]         ]    reportSDoc "tc.conv.level" 80 $     sep [ text "equalLevel"-        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (text . show . unSingleLevel) as+        , vcat [ nest 2 $ sep [ prettyList_ $ fmap (pretty . unSingleLevel) as                               , "=="-                              , prettyList_ $ fmap (text . show . unSingleLevel) bs+                              , prettyList_ $ fmap (pretty . unSingleLevel) bs                               ]                ]         ]@@ -1512,8 +1606,8 @@           | MetaV x as' <- ignoreBlocking a           , MetaV y bs' <- ignoreBlocking b           , k == l -> do-              lvl <- levelType-              equalAtom (AsTermsOf lvl) (MetaV x as') (MetaV y bs')+              lvl <- levelType'+              compareMetas CmpEq (AsTermsOf lvl) x as' y bs'         (SinglePlus (Plus k a) :| [] , _)           | MetaV x as' <- ignoreBlocking a           , Just b' <- subLevel k b -> meta x as' b'@@ -1540,19 +1634,19 @@               List1.zipWithM_ ((===) `on` levelTm . unSingleLevel . fmap ignoreBlocking) as bs          -- more cases?-        _ | noMetas (Level a , Level b) -> notok-          | otherwise                   -> postpone+        _ | noMetas (a , b) -> notok+          | otherwise       -> postpone        where         a === b = unlessM typeInType $ do-          lvl <- levelType+          lvl <- levelType'           equalAtom (AsTermsOf lvl) a b          -- perform assignment (MetaV x as) := b         meta x as b = do           reportSLn "tc.meta.level" 30 $ "Assigning meta level"           reportSDoc "tc.meta.level" 50 $ "meta" <+> sep [prettyList $ map pretty as, pretty b]-          lvl <- levelType+          lvl <- levelType'           assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms          isNeutral (SinglePlus (Plus _ NotBlocked{})) = True@@ -1584,26 +1678,44 @@ -- | Check that the first sort equal to the second. equalSort :: forall m. MonadConversion m => Sort -> Sort -> m () equalSort s1 s2 = do-    catchConstraint (SortCmp CmpEq s1 s2) $ do-        (s1,s2) <- reduce (s1,s2)-        let yes      = return ()-            no       = typeError $ UnequalSorts s1 s2+  reportSDoc "tc.conv.sort" 30 $ sep+    [ "equalSort"+    , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> "=="+                           , prettyTCM s2 ]+           ]+    ]+  reportSDoc "tc.conv.sort" 60 $ sep+    [ "equalSort"+    , vcat [ nest 2 $ fsep [ pretty s1 <+> "=="+                           , pretty s2 ]+           ]+    ]+  whenProfile Profile.Conversion $ tick "compare sorts" -        reportSDoc "tc.conv.sort" 30 $ sep-          [ "equalSort"-          , vcat [ nest 2 $ fsep [ prettyTCM s1 <+> "=="-                                 , prettyTCM s2 ]-                 , nest 2 $ fsep [ pretty s1 <+> "=="-                                 , pretty s2 ]-                 ]-          ]+  SynEq.checkSyntacticEquality s1 s2 (\_ _ -> return ()) $ \s1 s2 -> do -        propEnabled <- isPropEnabled-        typeInTypeEnabled <- typeInType-        omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions+    s1b <- reduceB s1+    s2b <- reduceB s2 -        case (s1, s2) of+    let (s1,s2) = (ignoreBlocking s1b, ignoreBlocking s2b)+        blocker = unblockOnEither (getBlocker s1b) (getBlocker s2b) +    let postponeIfBlocked = catchPatternErr $ \blocker ->+          if | blocker == neverUnblock -> typeError $ UnequalSorts s1 s2+             | otherwise -> do+                 reportSDoc "tc.conv.sort" 30 $ vcat+                   [ "Postponing constraint"+                   , nest 2 $ fsep [ prettyTCM s1 <+> "=="+                                   , prettyTCM s2 ]+                   ]+                 addConstraint blocker $ SortCmp CmpEq s1 s2++    propEnabled <- isPropEnabled+    typeInTypeEnabled <- typeInType+    omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions++    postponeIfBlocked $ case (s1, s2) of+             -- Andreas, 2018-09-03: crash on dummy sort             (DummyS s, _) -> impossibleSort s             (_, DummyS s) -> impossibleSort s@@ -1611,10 +1723,7 @@             -- one side is a meta sort: try to instantiate             -- In case both sides are meta sorts, instantiate the             -- bigger (i.e. more recent) one.-            (MetaS x es , MetaS y es')-              | x == y                 -> synEq s1 s2-              | x < y                  -> meta y es' s1-              | otherwise              -> meta x es s2+            (MetaS x es , MetaS y es') -> compareMetas CmpEq AsTypes x es y es'             (MetaS x es , _          ) -> meta x es s2             (_          , MetaS x es ) -> meta x es s1 @@ -1622,6 +1731,7 @@             (Type a     , Type b     ) -> equalLevel a b `catchInequalLevel` no             (SizeUniv   , SizeUniv   ) -> yes             (LockUniv   , LockUniv   ) -> yes+            (IntervalUniv , IntervalUniv) -> yes             (Prop a     , Prop b     ) -> equalLevel a b `catchInequalLevel` no             (Inf f m    , Inf f' n   ) ->               if f == f' && (m == n || typeInTypeEnabled || omegaInOmegaEnabled) then yes else no@@ -1634,26 +1744,32 @@               | typeInTypeEnabled      -> yes              -- equating @PiSort a b@ to another sort-            (s1 , PiSort a b c) -> piSortEquals s1 a b c-            (PiSort a b c , s2) -> piSortEquals s2 a b c+            (s1 , PiSort a b c) -> piSortEquals s1 a b c blocker+            (PiSort a b c , s2) -> piSortEquals s2 a b c blocker              -- equating @FunSort a b@ to another sort-            (s1 , FunSort a b) -> funSortEquals s1 a b-            (FunSort a b , s2) -> funSortEquals s2 a b+            (s1 , FunSort a b) -> funSortEquals s1 a b blocker+            (FunSort a b , s2) -> funSortEquals s2 a b blocker              -- equating @UnivSort s@ to another sort-            (s1          , UnivSort s2) -> univSortEquals s1 s2-            (UnivSort s1 , s2         ) -> univSortEquals s2 s1+            (s1          , UnivSort s2) -> univSortEquals s1 s2 blocker+            (UnivSort s1 , s2         ) -> univSortEquals s2 s1 blocker              -- postulated sorts can only be equal if they have the same head             (DefS d es  , DefS d' es')-              | d == d'                -> synEq s1 s2+              | d == d'                -> do+                  pol <- getPolarity' CmpEq d+                  a <- computeElimHeadType d es es'+                  compareElims pol [] a (Def d []) es es'               | otherwise              -> no              -- any other combinations of sorts are not equal             (_          , _          ) -> no      where+      yes = return ()+      no  = patternViolation neverUnblock+       -- perform assignment (MetaS x es) := s       meta :: MetaId -> [Elim' Term] -> Sort -> m ()       meta x es s = do@@ -1661,27 +1777,16 @@         reportSDoc "tc.meta.sort" 50 $ "meta" <+> sep [pretty x, prettyList $ map pretty es, pretty s]         assignE DirEq x es (Sort s) AsTypes __IMPOSSIBLE__ -      -- fall back to syntactic equality check, postpone if it fails-      synEq :: Sort -> Sort -> m ()-      synEq s1 s2 = do-        let postpone = addConstraint (unblockOnAnyMetaIn (s1, s2)) $ SortCmp CmpEq s1 s2-        doSynEq <- optSyntacticEquality <$> pragmaOptions-        if | doSynEq -> do-               ((s1,s2) , equal) <- SynEq.checkSyntacticEquality s1 s2-               if | equal     -> return ()-                  | otherwise -> postpone-           | otherwise -> postpone-       -- Equate a sort @s1@ to @univSort s2@       -- Precondition: @s1@ and @univSort s2@ are already reduced.-      univSortEquals :: Sort -> Sort -> m ()-      univSortEquals s1 s2 = do+      univSortEquals :: Sort -> Sort -> Blocker -> m ()+      univSortEquals s1 s2 blocker = do         reportSDoc "tc.conv.sort" 35 $ vcat           [ "univSortEquals"           , "  s1 =" <+> prettyTCM s1           , "  s2 =" <+> prettyTCM s2           ]-        let no = typeError $ UnequalSorts s1 (UnivSort s2)+        let postpone = patternViolation blocker         case s1 of           -- @Set l1@ is the successor sort of either @Set l2@ or           -- @Prop l2@ where @l1 == lsuc l2@.@@ -1701,7 +1806,7 @@                        return l2                    equalSort (Type l2) s2                -- Otherwise we postpone-               | otherwise -> synEq (Type l1) (UnivSort s2)+               | otherwise -> postpone           -- @Setωᵢ@ is a successor sort if n > 0, or if           -- --type-in-type or --omega-in-omega is enabled.           Inf f n | n > 0 -> equalSort (Inf f $ n - 1) s2@@ -1713,14 +1818,14 @@           Prop{}     -> no           SizeUniv{} -> no           -- Anything else: postpone-          _          -> synEq s1 (UnivSort s2)+          _          -> postpone         -- Equate a sort @s@ to @piSort a s1 s2@       -- Precondition: @s@ and @piSort a s1 s2@ are already reduced.-      piSortEquals :: Sort -> Dom Term -> Sort -> Abs Sort -> m ()-      piSortEquals s a s1 NoAbs{} = __IMPOSSIBLE__-      piSortEquals s a s1 s2Abs@(Abs x s2) = do+      piSortEquals :: Sort -> Dom Term -> Sort -> Abs Sort -> Blocker -> m ()+      piSortEquals s a s1 NoAbs{} blocker = __IMPOSSIBLE__+      piSortEquals s a s1 s2Abs@(Abs x s2) blocker = do         let adom = El s1 <$> a         reportSDoc "tc.conv.sort" 35 $ vcat           [ "piSortEquals"@@ -1730,22 +1835,23 @@           , "  s2 =" <+> addContext (x,adom) (prettyTCM s2)           ]         propEnabled <- isPropEnabled+        let postpone = patternViolation blocker            -- If @s2@ is dependent, then @piSort a s1 s2@ computes to            -- @Setωi@. Hence, if @s@ is small, then @s2@            -- cannot be dependent.-        if | Just (True,_) <- isSmallSort s -> do+        if | isSmallSort s -> do                -- We force @s2@ to be non-dependent by unifying it with                -- a fresh meta that does not depend on @x : a@                s2' <- newSortMeta                addContext (x , adom) $ equalSort s2 (raise 1 s2')-               funSortEquals s s1 s2'+               funSortEquals s s1 s2' blocker            -- Otherwise: postpone-           | otherwise                  -> synEq (PiSort a s1 s2Abs) s+           | otherwise -> postpone        -- Equate a sort @s@ to @funSort s1 s2@       -- Precondition: @s@ and @funSort s1 s2@ are already reduced-      funSortEquals :: Sort -> Sort -> Sort -> m ()-      funSortEquals s0 s1 s2 = do+      funSortEquals :: Sort -> Sort -> Sort -> Blocker -> m ()+      funSortEquals s0 s1 s2 blocker = do         reportSDoc "tc.conv.sort" 35 $ vcat           [ "funSortEquals"           , "  s0 =" <+> prettyTCM s0@@ -1754,30 +1860,40 @@           ]         propEnabled <- isPropEnabled         sizedTypesEnabled <- sizedTypesOption+        cubicalEnabled <- isJust . optCubical <$> pragmaOptions+        let postpone = patternViolation blocker         case s0 of           -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must           -- be @Setωᵢ@.-          Inf f n | Just (True,_) <- isSmallSort s1, Just (True,_) <- isSmallSort s2 -> do+          Inf f n | isSmallSort s1, isSmallSort s2 -> do                     typeError $ UnequalSorts s0 (FunSort s1 s2)-                  | Just (True, IsFibrant) <- isSmallSort s1 -> equalSort (Inf f n) s2-                  | Just (True, IsFibrant) <- isSmallSort s2 -> equalSort (Inf f n) s1+                  | Right (SmallSort IsFibrant) <- sizeOfSort s1 -> equalSort (Inf f n) s2+                  | Right (SmallSort IsFibrant) <- sizeOfSort s2 -> equalSort (Inf f n) s1                   -- TODO 2ltt: handle IsStrict cases.-                  | otherwise                   -> synEq s0 (FunSort s1 s2)+                  | otherwise -> postpone           -- If @Set l == funSort s1 s2@, then @s2@ must be of the-          -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@, or-          -- @SizeUniv@.+          -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@,+          -- @SizeUniv@, or @IUniv@.           Type l -> do             l2 <- forceType s2             -- We must have @l2 =< l@, this might help us to solve             -- more constraints (in particular when @l == 0@).             leqLevel l2 l+            -- Jesper, 2022-10-22, #6211: the operations `forceType`+            -- and `leqLevel` above might have instantiated some+            -- metas, so we need to reduce s1 again to get an+            -- up-to-date Blocker.+            s1b <- reduceB s1+            let s1 = ignoreBlocking s1b+                blocker = getBlocker s1b             -- Jesper, 2019-12-27: SizeUniv is disabled at the moment.-            if | {- sizedTypesEnabled || -} propEnabled -> case funSort' s1 (Type l2) of+            if | {- sizedTypesEnabled || -} propEnabled || cubicalEnabled ->+                case funSort' s1 (Type l2) of                    -- If the work we did makes the @funSort@ compute,                    -- continue working.-                   Just s  -> equalSort (Type l) s+                   Right s -> equalSort (Type l) s                    -- Otherwise: postpone-                   Nothing -> synEq (Type l) (FunSort s1 $ Type l2)+                   Left{}  -> patternViolation blocker                -- If both Prop and sized types are disabled, only the                -- case @s1 == Set l1@ remains.                | otherwise -> do@@ -1789,16 +1905,19 @@           Prop l -> do             l2 <- forceProp s2             leqLevel l2 l+            s1b <- reduceB s1+            let s1 = ignoreBlocking s1b+                blocker = getBlocker s1b             case funSort' s1 (Prop l2) of                    -- If the work we did makes the @funSort@ compute,                    -- continue working.-                   Just s  -> equalSort (Prop l) s+                   Right s -> equalSort (Prop l) s                    -- Otherwise: postpone-                   Nothing -> synEq (Prop l) (FunSort s1 $ Prop l2)+                   Left _  -> patternViolation blocker           -- We have @SizeUniv == funSort s1 s2@ iff @s2 == SizeUniv@           SizeUniv -> equalSort SizeUniv s2           -- Anything else: postpone-          _        -> synEq s0 (FunSort s1 s2)+          _        -> postpone        -- check if the given sort @s0@ is a (closed) bottom sort       -- i.e. @piSort a b == s0@ implies @b == s0@.@@ -1854,7 +1973,12 @@ --   xs <- mapM (mapM (\ (i,b) -> (,) i <$> intervalUnview (if b then IOne else IZero))) as --   return xs -forallFaceMaps :: MonadConversion m => Term -> (Map.Map Int Bool -> Blocker -> Term -> m a) -> (Substitution -> m a) -> m [a]+forallFaceMaps+  :: MonadConversion m+  => Term+  -> (IntMap Bool -> Blocker -> Term -> m a)+  -> (IntMap Bool -> Substitution -> m a)+  -> m [a] forallFaceMaps t kb k = do   reportSDoc "conv.forall" 20 $       fsep ["forallFaceMaps"@@ -1867,7 +1991,7 @@     return (\b -> if b then io else iz)   forM as $ \ (ms,ts) -> do    ifBlockeds ts (kb ms) $ \ _ _ -> do-    let xs = map (second boolToI) $ Map.toAscList ms+    let xs = map (second boolToI) $ IntMap.toAscList ms     cxt <- getContext     reportSDoc "conv.forall" 20 $       fsep ["substContextN"@@ -1882,16 +2006,16 @@         tel <- getContextTelescope         m <- currentModule         sub <- getModuleParameterSub m-        reportS "conv.forall" 10-          [ replicate 10 '-'-          , show (envCurrentModule $ clEnv cl)-          , show (envLetBindings $ clEnv cl)-          , show tel -- (toTelescope $ envContext $ clEnv cl)-          , show sigma-          , show m-          , show sub+        reportSDoc "conv.forall" 30 $ vcat+          [ text (replicate 10 '-')+          , prettyTCM (envCurrentModule $ clEnv cl)+          -- , prettyTCM (envLetBindings $ clEnv cl)+          , prettyTCM tel -- (toTelescope $ envContext $ clEnv cl)+          , prettyTCM sigma+          , prettyTCM m+          , prettyTCM sub           ]-        k sigma+        k ms sigma   where     -- TODO Andrea: inefficient because we try to reduce the ts which we know are in whnf     ifBlockeds ts blocked unblocked = do@@ -1931,6 +2055,7 @@ compareInterval cmp i t u = do   reportSDoc "tc.conv.interval" 15 $     sep [ "{ compareInterval" <+> prettyTCM t <+> "=" <+> prettyTCM u ]+  whenProfile Profile.Conversion $ tick "compare at interval type"   tb <- reduceB t   ub <- reduceB u   let t = ignoreBlocking tb@@ -1960,7 +2085,7 @@    isBlocked NotBlocked{} = False  -type Conj = (Map.Map Int (Set.Set Bool),[Term])+type Conj = (IntMap BoolSet, [Term])  isCanonical :: [Conj] -> Bool isCanonical = all (null . snd)@@ -1979,10 +2104,10 @@ -- ' {q_j | j} ⊆ {r_i | i} leqConj :: MonadConversion m => Conj -> Conj -> m Bool leqConj (rs, rst) (qs, qst) = do-  if toSet qs `Set.isSubsetOf` toSet rs+  if IntMap.isSubmapOfBy BoolSet.isSubsetOf qs rs     then do       interval <--        elSSet $ fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval+        El IntervalUniv . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinInterval       -- we don't want to generate new constraints here because       -- 1. in some situations the same constraint would get generated twice.       -- 2. unless things are completely accepted we are going to@@ -1993,24 +2118,26 @@       listSubset qst rst     else       return False-  where-    toSet m = Set.fromList [(i, b) | (i, bs) <- Map.toList m, b <- Set.toList bs]  -- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A equalTermOnFace :: MonadConversion m => Term -> Type -> Term -> Term -> m () equalTermOnFace = compareTermOnFace CmpEq  compareTermOnFace :: MonadConversion m => Comparison -> Term -> Type -> Term -> Term -> m ()-compareTermOnFace = compareTermOnFace' compareTerm+compareTermOnFace = compareTermOnFace' (const compareTerm) -compareTermOnFace' :: MonadConversion m => (Comparison -> Type -> Term -> Term -> m ()) -> Comparison -> Term -> Type -> Term -> Term -> m ()+compareTermOnFace'+  :: MonadConversion m+  => (Substitution -> Comparison -> Type -> Term -> Term -> m ())+  -> Comparison -> Term -> Type -> Term -> Term -> m () compareTermOnFace' k cmp phi ty u v = do   reportSDoc "tc.conv.face" 40 $     text "compareTermOnFace:" <+> pretty phi <+> "|-" <+> pretty u <+> "==" <+> pretty v <+> ":" <+> pretty ty+  whenProfile Profile.Conversion $ tick "compare at face type"    phi <- reduce phi-  _ <- forallFaceMaps phi postponed-         $ \ alpha -> k cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v)+  _ <- forallFaceMaps phi postponed $ \ faces alpha ->+      k alpha cmp (applySubst alpha ty) (applySubst alpha u) (applySubst alpha v)   return ()  where   postponed ms blocker psi = do@@ -2019,7 +2146,7 @@              ineg <- cl $ getPrimitiveTerm "primINeg"              psi <- open psi              let phi = foldr (\ (i,b) r -> do i <- open (var i); pure imin <@> (if b then i else pure ineg <@> i) <@> r)-                          psi (Map.toList ms) -- TODO Andrea: make a view?+                          psi (IntMap.toList ms) -- TODO Andrea: make a view?              phi     addConstraint blocker (ValueCmpOnFace cmp phi ty u v)
src/full/Agda/TypeChecking/Conversion/Pure.hs view
@@ -56,21 +56,31 @@ runPureConversion   :: (MonadBlock m, PureTCM m, Show a)   => PureConversionT m a -> m (Maybe a)-runPureConversion (PureConversionT m) = locallyTC eCompareBlocked (const True) $ do+runPureConversion (PureConversionT m) = locallyTC eCompareBlocked (const True) $+  verboseBracket "tc.conv.pure" 40 "runPureConversion" $ do   i <- useR stFreshInt   pid <- useR stFreshProblemId   nid <- useR stFreshNameId   let frsh = FreshThings i pid nid   result <- fst <$> runStateT (runExceptT m) frsh-  reportSLn "tc.conv.pure" 40 $ "runPureConversion result: " ++ show result   case result of     Left (PatternErr block)-     | block == neverUnblock -> return Nothing-     | otherwise             -> patternViolation block-    Left TypeError{}   -> return Nothing+     | block == neverUnblock -> do+         debugResult "stuck"+         return Nothing+     | otherwise             -> do+         debugResult $ "blocked on" <+> prettyTCM block+         patternViolation block+    Left TypeError{}   -> do+      debugResult "type error"+      return Nothing     Left Exception{}   -> __IMPOSSIBLE__     Left IOException{} -> __IMPOSSIBLE__-    Right x            -> return $ Just x+    Right x            -> do+      debugResult "success"+      return $ Just x+  where+    debugResult msg = reportSDoc "tc.conv.pure" 40 $ "runPureConversion result: " <+> msg  instance MonadTrans PureConversionT where   lift = PureConversionT . lift . lift
src/full/Agda/TypeChecking/Coverage.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeApplications #-}  {-| Coverage checking, case splitting, and splitting for refine tactics. @@ -46,7 +47,10 @@  import Agda.TypeChecking.Coverage.Match import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Coverage.SplitClause+import Agda.TypeChecking.Coverage.Cubical + import Agda.TypeChecking.Conversion (tryConversion, equalType) import Agda.TypeChecking.Datatypes (getConForm) import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType )@@ -72,60 +76,15 @@ import Agda.Utils.Pretty (prettyShow) import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.Tuple import Agda.Utils.WithDefault  import Agda.Utils.Impossible+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Control.Monad.State -data SplitClause = SClause-  { scTel    :: Telescope-    -- ^ Type of variables in @scPats@.-  , scPats   :: [NamedArg SplitPattern]-    -- ^ The patterns leading to the currently considered branch of-    --   the split tree.-  , scSubst  :: Substitution' SplitPattern-    -- ^ Substitution from 'scTel' to old context.-    --   Only needed directly after split on variable:-    --   * To update 'scTarget'-    --   * To rename other split variables when splitting on-    --     multiple variables.-    --   @scSubst@ is not ``transitive'', i.e., does not record-    --   the substitution from the original context to 'scTel'-    --   over a series of splits.  It is freshly computed-    --   after each split by 'computeNeighborhood'; also-    --   'splitResult', which does not split on a variable,-    --   should reset it to the identity 'idS', lest it be-    --   applied to 'scTarget' again, leading to Issue 1294.-  , scCheckpoints :: Map CheckpointId Substitution-    -- ^ We need to keep track of the module parameter checkpoints for the-    -- clause for the purpose of inferring missing instance clauses.-  , scTarget :: Maybe (Dom Type)-    -- ^ The type of the rhs, living in context 'scTel'.-    --   'fixTargetType' computes the new 'scTarget' by applying-    --   substitution 'scSubst'.-  } --- | A @Covering@ is the result of splitting a 'SplitClause'.-data Covering = Covering-  { covSplitArg     :: Arg Nat-     -- ^ De Bruijn level (counting dot patterns) of argument we split on.-  , covSplitClauses :: [(SplitTag, SplitClause)]-      -- ^ Covering clauses, indexed by constructor/literal these clauses share.-  }---- | Project the split clauses out of a covering.-splitClauses :: Covering -> [SplitClause]-splitClauses (Covering _ qcs) = map snd qcs---- | Create a split clause from a clause in internal syntax. Used by make-case.-clauseToSplitClause :: Clause -> SplitClause-clauseToSplitClause cl = SClause-  { scTel    = clauseTel cl-  , scPats   = toSplitPatterns $ namedClausePats cl-  , scSubst  = idS  -- Andreas, 2014-07-15  TODO: Is this ok?-  , scCheckpoints = Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing-  , scTarget = domFromArg <$> clauseType cl-  }- type CoverM = ExceptT SplitError TCM  -- | Top-level function for checking pattern coverage.@@ -202,7 +161,9 @@   -- Storing the covering clauses so that checkIApplyConfluence_ can   -- find them later.   -- Andreas, 2019-03-27, only needed when --cubical-  whenM (isJust . optCubical <$> pragmaOptions) $ do+  -- Jesper, 2022-10-18, also needed for some backends, so keep when flag says so+  opts <- pragmaOptions+  when (isJust (optCubical opts) || optKeepCoveringClauses opts) $     modifySignature $ updateDefinition f $ updateTheDef $ updateCovering $ const qss  @@ -219,17 +180,18 @@         -- ifNotM (isEmptyTel tel) (return True) $ do       -- Jesper, 2018-11-28, Issue #3407: if the clause is absurd,       -- add the appropriate absurd clause to the definition.-      let cl = Clause { clauseLHSRange    = noRange-                      , clauseFullRange   = noRange-                      , clauseTel         = tel-                      , namedClausePats   = applySubst sub ps-                      , clauseBody        = Nothing-                      , clauseType        = Nothing+      let cl = Clause { clauseLHSRange  = noRange+                      , clauseFullRange = noRange+                      , clauseTel       = tel+                      , namedClausePats = applySubst sub ps+                      , clauseBody      = Nothing+                      , clauseType      = Nothing                       , clauseCatchall    = True       -- absurd clauses are safe as catch-all                       , clauseExact       = Just False                       , clauseRecursive   = Just False                       , clauseUnreachable = Just False                       , clauseEllipsis    = NoEllipsis+                      , clauseWhereModule = Nothing                       }       reportSDoc "tc.cover.missing" 20 $ inTopContext $ do         sep [ "adding missing absurd clause"@@ -305,15 +267,6 @@  -- to the user.  Rather, assume the clause is not already covered.  `catchError` \ _ -> return False -data CoverResult = CoverResult-  { coverSplitTree       :: SplitTree-  , coverUsedClauses     :: IntSet -- Set Nat-  , coverMissingClauses  :: [(Telescope, [NamedArg DeBruijnPattern])]-  , coverPatterns        :: [Clause]-  -- ^ The set of patterns used as cover.-  , coverNoExactClauses  :: IntSet -- Set Nat-  }- -- | @cover f cs (SClause _ _ ps _) = return (splitTree, used, pss)@. --   checks that the list of clauses @cs@ covers the given split clause. --   Returns the @splitTree@, the @used@ clauses, and missing cases @pss@.@@ -329,6 +282,14 @@     , nest 2 $ "target sort =" <+> do addContext tel $ maybe (text "<none>") (prettyTCM . getSort . unDom) target     ]   reportSLn "tc.cover.cover" 80 $ "raw target =\n" ++ show target+  verboseS  "tc.cover.matching" 20 $ do+    reportSLn "tc.cover.matching" 20 $ "clauses when matching:"+    forM_ cs $ \ c -> do+      let gamma = clauseTel c+          ps = namedClausePats c+      reportSDoc "tc.cover.matching" 20 $ addContext gamma $+          "ps   :" <+> prettyTCM (fmap namedArg ps)+   match cs ps >>= \case     Yes (i,mps) -> do       reportSLn "tc.cover.cover" 10 $ "pattern covered by clause " ++ show i@@ -397,11 +358,63 @@           Block{} -> Just c           No{}    -> Nothing +    -- Rename the variables in a telescope in accordance with their+    -- first appearance in the given NAPs. This is done to preserve+    -- variable names in IApplyConfluence error messages. Specifically,+    -- consider e.g.+    --+    --  data T : Set where+    --    x : T+    --    p : Path (Path T x x) refl refl+    --  f (p i j) = ...+    --+    -- When generating the covering clause corresponding to f's clause,+    -- the names we have in scope are i and i₁, since those are the+    -- names of both PathP binder arguments. (recall Path A x y = PathP (λ i → A) x y)+    -- So if we tried to print (Var 0 []) in the context of+    -- IApplyConfluence for that clause, what we see isn't j, it's i₁.+    --+    -- This function takes "name suggestions" from both variable+    -- patterns and IApply co/patterns, and replaces any existing names+    -- in the telescope by the name in that pattern.+    renTeleFromNap :: Telescope -> NAPs -> Telescope+    renTeleFromNap tel ps = telFromList $ evalState (traverse upd (telToList tel)) (size - 1)+      where+        -- Fold a single pattern into a map of name suggestions:+        -- In the running example above, we have+        --    f (p i@1 j@0)+        -- so the map that nameSuggest (p ...) returns is {0 → j, 1 → j}+        nameSuggest :: DeBruijnPattern -> IntMap ArgName+        nameSuggest ps = flip foldPattern ps $ \case+          VarP _ i | dbPatVarName i /= "_" ->+            IntMap.singleton (dbPatVarIndex i) (dbPatVarName i)+          IApplyP _ _ _ i | dbPatVarName i /= "_" ->+            IntMap.singleton (dbPatVarIndex i) (dbPatVarName i)+          _ -> mempty++        -- Suggestions from all patterns..+        suggestions = foldMap (nameSuggest . namedThing . unArg) ps++        -- The state will start counting from (length Γ - 1), which is+        -- the *highest* variable index, i.e. the index of the variable+        -- with level 0. Instead of doing a lot of de Bruijn arithmetic+        -- + recursion, traverse handles iteration and the State handles+        -- counting down.+        size = length (telToList tel)+        upd :: Dom (ArgName , Type) -> State Int (Dom (ArgName , Type))+        upd dom = state $ \s -> do+          case IntMap.lookup s suggestions of+            Just nm' -> ( dom{ domName = Just (WithOrigin CaseSplit (unranged nm'))+                             , unDom = (nm' , snd (unDom dom))+                             } , s - 1)+            Nothing -> (dom , s - 1)+     applyCl :: SplitClause -> Clause -> [(Nat, SplitPattern)] -> TCM Clause-    applyCl SClause{scTel = tel, scPats = sps} cl mps = addContext tel $ do+    applyCl SClause{scTel = pretel, scPats = sps} cl mps+        | tel <- renTeleFromNap pretel (namedClausePats cl) = addContext tel $ do         let ps = namedClausePats cl         reportSDoc "tc.cover.applyCl" 40 $ "applyCl"-        reportSDoc "tc.cover.applyCl" 40 $ "tel    =" <+> prettyTCM tel+        reportSDoc "tc.cover.applyCl" 40 $ "tel    =" <+> pretty tel         reportSDoc "tc.cover.applyCl" 40 $ "ps     =" <+> pretty ps         reportSDoc "tc.cover.applyCl" 40 $ "mps    =" <+> pretty mps         reportSDoc "tc.cover.applyCl" 40 $ "s      =" <+> pretty s@@ -437,16 +450,21 @@                     , namedClausePats = (s `applySubst` ps) ++ extra                     , clauseBody      = (`applyE` patternsToElims extra) . (s `applyPatSubst`) <$> clauseBody cl                     , clauseType      = ty-                    , clauseCatchall  = clauseCatchall cl-                    , clauseExact     = clauseExact cl-                    , clauseRecursive = clauseRecursive cl+                    , clauseCatchall    = clauseCatchall cl+                    , clauseExact       = clauseExact cl+                    , clauseRecursive   = clauseRecursive cl                     , clauseUnreachable = clauseUnreachable cl-                    , clauseEllipsis  = clauseEllipsis cl+                    , clauseEllipsis    = clauseEllipsis cl+                    , clauseWhereModule = clauseWhereModule cl                     }       where-        (vs,qs) = unzip mps-        mps' = zip vs $ map namedArg $ fromSplitPatterns $ map defaultNamedArg qs-        s = parallelS (for [0..maximum (-1:vs)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i mps')))+      mps' =+        Map.fromList $+        map (mapSnd (namedArg . fromSplitPattern . defaultNamedArg)) mps+      s = parallelS (for (case Map.lookupMax mps' of+                            Nothing     -> []+                            Just (i, _) -> [0..i]) $ \ i ->+                     fromMaybe (deBruijnVar i) (Map.lookup i mps'))      updateRelevance :: TCM a -> TCM a     updateRelevance cont =@@ -472,16 +490,24 @@           -- TODO Andrea: I guess an empty pattern is not part of the cover?           let qs = []           return $ CoverResult (SplittingDone (size tel)) empty [] qs empty-        Right (Covering n scs, x) -> do-          cs <- do-            let fallback = return cs+        Right (Covering n scs', x) -> do+          let scs = map (\(t,(sc,i)) -> (t,sc)) scs'++          (results_trX, cs) <- createMissingIndexedClauses f n x sc scs' cs+          (scs, cs, results_hc) <- do+            let fallback = return (scs, cs, [])             caseMaybeM (getPrimitiveName' builtinHComp) fallback $ \ comp -> do             let isComp = \case                   SplitCon c -> comp == c                   _ -> False-            caseMaybe (List.find (isComp . fst) scs) fallback $ \ (_, newSc) -> do-            snoc cs <$> createMissingHCompClause f n x sc newSc-          results <- mapM ((cover f cs) . snd) scs+            caseMaybe (List.find (isComp . fst) scs) fallback $ \ (sp, newSc) -> do+            (res,cs') <- createMissingHCompClause f n x sc newSc cs+            let scs2 = filter (not . isComp . fst) scs+            return (scs2,cs',res)+          let results_extra = results_hc ++ results_trX+              trees_extra = map (\(sp,cr) -> (sp, coverSplitTree cr)) results_extra++          results <- (++ map snd (results_extra)) <$> mapM ((cover f cs) . snd) scs           let trees = map coverSplitTree      results               useds = map coverUsedClauses    results               psss  = map coverMissingClauses results@@ -498,9 +524,8 @@               , "ps  = " <+> prettyTCMPatternList (fromSplitPatterns ps)               ]             ]-          -- TODO Andrea: do something with etaRecordSplits and qsss?           let trees' = zipWith (etaRecordSplits (unArg n) ps) scs trees-              tree   = SplitAt n StrictSplit trees'   -- TODO: Lazy?+              tree   = SplitAt n StrictSplit (trees' ++ trees_extra) -- TODO: Lazy?           return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex)      -- Try to split result@@ -554,7 +579,7 @@         Right (Covering n scs) -> do           -- If result splitting was successful, continue coverage checking.           (projs, results) <- unzip <$> do-            mapM (traverseF $ cover f cs <=< (snd <.> insertTrailingArgs False)) scs+            mapM (traverseF $ cover f cs <=< (snd <.> insertTrailingArgs False)) (map (\(t,(sc,i)) -> (t,sc)) scs)             -- OR:             -- forM scs $ \ (proj, sc') -> (proj,) <$> do             --   cover f cs =<< do@@ -611,241 +636,6 @@       (q , addEtaSplits 0 (gatherEtaSplits n sc ps) t)  ----- | Append an hcomp clause to the clauses of a function.-createMissingHCompClause-  :: QName-       -- ^ Function name.-  -> Arg Nat -- ^ index of hcomp pattern-  -> BlockingVar -- ^ Blocking var that lead to hcomp split.-  -> SplitClause -- ^ Clause before the hcomp split-  -> SplitClause-       -- ^ Clause to add.-   -> TCM Clause-createMissingHCompClause f n x old_sc (SClause tel ps _sigma' cps (Just t)) = setCurrentRange f $ do-  reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "Trying to create right-hand side of type" <+> prettyTCM t-  reportSDoc "tc.cover.hcomp" 30 $ addContext tel $ text "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps)-  reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel--  io      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne-  iz      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero-  let-    cannotCreate :: forall m a. (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> Closure (Abs Type) -> m a-    cannotCreate doc t = do-      typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t-  let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc-      old_t  = fromJust $ scTarget old_sc-      old_tel = scTel old_sc-      -- old_tel = Γ(x:H)Δ-      -- Γ(x:H)Δ ⊢ old_t-      -- vs = iApplyVars old_ps-      -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]--      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]-      -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ]-      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0)--      -- Extra assumption:-      -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ'-      -- ps = old_ps[x = hcomp φ u u0],ps'-      -- with Δ' and ps' introduced by fixTarget.-      -- So final clause will be:-      -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps'-      getLevel t = do-        s <- reduce $ getSort t-        case s of-          Type l -> pure (Level l)-          s      -> do-            reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s-            typeError . GenericDocError =<<-                    (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"")--      -- Γ ⊢ hdelta = (x : H)(δ : Δ)-      (gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel--      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢-      (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel--      -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)-      {- rhoS = liftS (size hdelta) $ raiseS 3 -}-      vs = iApplyVars (scPats old_sc)--  -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]-  alphab <- forM vs $ \ i -> do-               let-                 -- Γ(x:H)(δ : Δ) ⊢-                 tm = Def f old_ps-               -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems-               (l,r) <- reduce (inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)-               return $ (var i, (l, r))----  cl <- do-    (ty,rhs) <- addContext working_tel $ do-      -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ]-      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]-      -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i]-      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill     = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i]-      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]]-      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i])-      --                 (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]]-      --                         α ↦ b[x = hfill φ u u0 i,δ_fill[i]]-      --                        ])-      --                 (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ]--      runNamesT [] $ do-          tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr-          tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax-          tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin-          tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg-          tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp-          tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans-          extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps-          let-            ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            trFillTel' a b c d = do-              m <- trFillTel <$> a <*> b <*> c <*> d-              x <- lift $ runExceptT m-              case x of-                Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t-                Right args -> return args-          comp <- do-            let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))-                                              <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                              <@> r-                                              <@> u-            return $ \ la bA phi u u0 ->-              pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                        <@> lam "i" (\ i -> ilam "o" $ \ o ->-                                forward la bA i (u <@> i <..> o))-                        <@> forward la bA (pure iz) u0-          let-            hcomp la bA phi u u0 = pure tHComp <#> la <#> bA-                                               <#> phi-                                               <@> u-                                               <@> u0--            hfill la bA phi u u0 i = hcomp la bA-                                               (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA)-                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> ilam "o" (\ _ -> u0)-                                                   )-                                               u0-          -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)-          hcompS <- lift $ do-            hdom <- pure $ raise 3 hdom-            let-              [phi,u,u0] = map (pure . var) [2,1,0]-              htype = pure $ unEl . unDom $ hdom-              lvl = getLevel $ unDom hdom-            hc <- pure tHComp <#> lvl <#> htype-                                      <#> phi-                                      <@> u-                                      <@> u0-            return $ liftS (size delta) $ hc `consS` raiseS 3-          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom-          hdom <- pure $ raise (3+size delta) hdom-          htype <- open $ unEl . unDom $ hdom-          lvl <- open =<< (lift . getLevel $ unDom hdom)--          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢-          [phi,u,u0] <- mapM (open . raise (size delta) . var) [2,1,0]-          -- Γ,x,Δ ⊢ f old_ps-          -- Γ ⊢ abstract hdelta (f old_ps)-          g <- open $ raise (3+size delta) $ abstract hdelta (Def f old_ps)-          old_t <- open $ raise (3+size delta) $ abstract hdelta (unDom old_t)-          let bapp a x = lazyAbsApp <$> a <*> x-          (delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do-            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ-            delta <- open $ raise (3+size delta) delta-            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i))-            deltaf <- open =<< bind "i" (\ i ->-                           (delta `bapp` hfill lvl htype phi u u0 (ineg i)))-            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0]-            args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz)-            bind "i" $ \ i -> addContext ("i" :: String) $ do -- for error messages.-              -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i)-              trFillTel' deltaf (pure iz) args (ineg i)-          let-            apply_delta_fill i f = apply <$> f <*> (delta_fill `bapp` i)-            call v i = apply_delta_fill i $ g <@> v-          ty <- do-                return $ \ i -> do-                    v <- hfill lvl htype phi u u0 i-                    hd <- old_t-                    args <- delta_fill `bapp` i-                    lift $ piApplyM hd $ Arg (domInfo hdom) v : args-          ty_level <- do-            t <- bind "i" ty-            s <- reduce $ getSort (absBody t)-            reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s-            case s of-              Type l -> open =<< lam "i" (\ _ -> pure $ Level l)-              _      -> cannotCreate "Cannot compose with type family:" =<< liftTCM (buildClosure t)--          let-            pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i)-                                               <@> phi <@> psi-                                               <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1-          alpha <- do-            vars <- mapM (open . applySubst hcompS . fst) alphab-            return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars--          -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]-          b <- do-             sides <- forM alphab $ \ (psi,(side0,side1)) -> do-                psi <- open $ hcompS `applySubst` psi--                [side0,side1] <- mapM (open . raise (3+size delta) . abstract hdelta) [side0,side1]-                return $ (ineg psi `imax` psi, \ i -> pOr_ty i (ineg psi) psi (ilam "o" $ \ _ -> apply_delta_fill i $ side0 <@> hfill lvl htype phi u u0 i)-                                                            (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i))-             let recurse []           i = __IMPOSSIBLE__-                 recurse [(psi,u)]    i = u i-                 recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i)-             return $ recurse sides--          ((,) <$> ty (pure io) <*>) $ do-            comp ty_level-               (lam "i" $ fmap unEl . ty)-                           (phi `imax` alpha)-                           (lam "i" $ \ i ->-                               let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i)-                               in if null alphab then rhs else-                                   pOr_ty i phi alpha rhs (b i)-                           )-                           (call u0 (pure iz))-    reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel-    let n = size tel - (size gamma + 3 + size delta)-    reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n)-    (TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty-    rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs--    cxt <- getContextTelescope-    reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt-    reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel-    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t-    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs--    return $ Clause { clauseLHSRange  = noRange-                    , clauseFullRange = noRange-                    , clauseTel       = tel-                    , namedClausePats = fromSplitPatterns ps-                    , clauseBody      = Just $ rhs-                    , clauseType      = Just $ defaultArg t-                    , clauseCatchall  = False-                    , clauseExact       = Just True-                    , clauseRecursive   = Nothing     -- TODO: can it be recursive?-                    , clauseUnreachable = Just False  -- missing, thus, not unreachable-                    , clauseEllipsis  = NoEllipsis-                    }-  addClauses f [cl]  -- Important: add at the end.-  return cl-createMissingHCompClause _ _ _ _ (SClause _ _ _ _ Nothing) = __IMPOSSIBLE__- -- | Append a instance clause to the clauses of a function. inferMissingClause   :: QName@@ -875,11 +665,12 @@                   , namedClausePats = fromSplitPatterns ps                   , clauseBody      = Just rhs                   , clauseType      = Just (argFromDom t)-                  , clauseCatchall  = False+                  , clauseCatchall    = False                   , clauseExact       = Just True                   , clauseRecursive   = Nothing     -- could be recursive                   , clauseUnreachable = Just False  -- missing, thus, not unreachable-                  , clauseEllipsis  = NoEllipsis+                  , clauseEllipsis    = NoEllipsis+                  , clauseWhereModule = Nothing                   }   addClauses f [cl]  -- Important: add at the end.   return cl@@ -986,7 +777,7 @@   let fallback = return (empty, sc)   caseMaybe target fallback $ \ a -> do     if isJust (domTactic a) && not force then fallback else do-    (TelV tel b) <- telViewUpTo (-1) $ unDom a+    (TelV tel b) <- addContext sctel $ telViewUpTo (-1) $ unDom a     reportSDoc "tc.cover.target" 15 $ sep       [ "target type telescope: " <+> do           addContext sctel $ prettyTCM tel@@ -1038,6 +829,15 @@   | visible ai = setOrigin UserWritten ai   | otherwise  = setOrigin Inserted ai ++-- | Checks if a type in this sort supports hcomp.+--   currently all such types will have a Level.+--   precondition: Sort in whnf and not blocked.+hasHComp :: Sort -> Maybe Level+hasHComp (Type l) = Just l+hasHComp _        = Nothing++ computeHCompSplit  :: Telescope   -- ^ Telescope before split point.   -> PatVarName                   -- ^ Name of pattern variable at split point.   -> Telescope                    -- ^ Telescope after split point.@@ -1051,13 +851,18 @@   -- -> QName                        -- ^ Constructor to fit into hole.   -> CoverM (Maybe (SplitTag,SplitClause))   -- ^ New split clause if successful. computeHCompSplit delta1 n delta2 d pars ixs hix tel ps cps = do+  withK   <- not . collapseDefault . optCubicalCompatible <$> pragmaOptions+  if withK then return Nothing else do     -- Get the type of the datatype   -- Δ1 ⊢ dtype   dsort <- liftTCM $ (parallelS (reverse $ map unArg pars) `applySubst`) . dataSort . theDef <$> getConstInfo d   hCompName <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp   theHCompT <- defType <$> getConstInfo hCompName++  -- TODO can dsort be blocked or not in whnf?+  caseMaybe (hasHComp dsort) (return Nothing) $ \ dlvl' -> do   let-    dlvl = Level . (\ (Type s) -> s) $ dsort+    dlvl = Level dlvl'     dterm = Def d [] `apply` (pars ++ ixs)   -- Δ1 ⊢ gamma   TelV gamma _ <- lift $ telView (theHCompT `piApply` [setHiding Hidden $ defaultArg $ dlvl , defaultArg $ dterm])@@ -1068,7 +873,7 @@       -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ       let (rho1,rho2) = splitS (size gamma) $ toSplitPSubst rho0 -      let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $+      let defp = DefP defaultPatternInfo hCompName . map (setOrigin Inserted) $ -- should there be a different Origin here?                    map (fmap unnamed) [setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dlvl                                       ,setHiding Hidden $ defaultArg $ applySubst rho1 $ DotP defaultPatternInfo $ dterm]                    ++ applySubst rho2 (teleNamedArgs gamma) -- rho0?@@ -1091,7 +896,6 @@       return $ Just . (SplitCon hCompName,) $ SClause delta' ps' rho cps' Nothing -- target fixed later  - -- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps con@ -- --   @@@ -1120,7 +924,7 @@   -> [NamedArg SplitPattern]      -- ^ Patterns before doing the split.   -> Map CheckpointId Substitution -- ^ Current checkpoints   -> QName                        -- ^ Constructor to fit into hole.-  -> CoverM (Maybe SplitClause)   -- ^ New split clause if successful.+  -> CoverM (Maybe (SplitClause, IInfo))   -- ^ New split clause if successful. computeNeighbourhood delta1 n delta2 d pars ixs hix tel ps cps c = do    -- Get the type of the datatype@@ -1136,7 +940,8 @@    -- Lookup the type of the constructor at the given parameters   (gamma0, cixs, boundary) <- do-    (TelV gamma0 (El _ d), boundary) <- liftTCM $ telViewPathBoundaryP (ctype `piApply` pars)+    (TelV gamma0 (El _ d), boundary) <- liftTCM $ addContext delta1 $+      telViewPathBoundaryP (ctype `piApply` pars)     let Def _ es = d         Just cixs = allApplyElims es     return (gamma0, cixs, boundary)@@ -1166,22 +971,34 @@   -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope   -- TODO: should we propagate the modality in general?   -- See also LHS checking.-  dtype <- do+  dtype <- addContext delta1 $ do          let updCoh = composeCohesion (getCohesion info)          TelV dtel dt <- telView dtype          return $ abstract (mapCohesion updCoh <$> dtel) dt+  dsort <- addContext delta1 $ reduce (getSort dtype) -  withKIfStrict <- addContext delta1 $ reduce (getSort dtype) >>= \case+  withKIfStrict <- case dsort of     SSet{} -> return $ locallyTC eSplitOnStrict $ const True     _      -> return id -  r <- withKIfStrict $ unifyIndices+  -- Should we attempt to compute a left inverse for this clause? When+  -- --cubical-compatible --flat-split is given, we don't generate a+  -- left inverse (at all). This means that, when the coverage checker+  -- gets to the clause this was in, it won't generate a (malformed!)+  -- transpX clause for @♭ matching.+  -- TODO(Amy): properly support transpX when @♭ stuff is in the+  -- context.+  let flatSplit = boolToMaybe (getCohesion info == Flat) SplitOnFlat++  r <- withKIfStrict $ lift $ unifyIndices' flatSplit          delta1Gamma          flex          (raise (size gamma) dtype)          conIxs          givenIxs +  TelV eqTel _ <- telView $ (raise (size gamma) dtype)+   let stuck b errs = do         debugCantSplit         throwError $ UnificationStuck b (conName con) (delta1 `abstract` gamma) conIxs givenIxs errs@@ -1194,7 +1011,25 @@      UnifyStuck errs -> stuck Nothing errs -    Unifies (delta1',rho0,_) -> do+    Unifies (delta1',rho0,eqs,tauInv) -> do++      let unifyInfo | Type _ <- dsort     -- only types of sort Type l have trX constructors:+                                          -- re #3733: update if we add transp for other sorts.+                    , not $ null $ conIxs -- no point propagating this info if trivial?+                    , Right (tau,leftInv) <- tauInv+            = TheInfo $ UE delta1Gamma delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv+                    | otherwise+            = NoInfo++      case tauInv of+        Right{} -> return ()+        Left SplitOnStrict -> return ()+        Left x -> do+          whenM (collapseDefault . optCubicalCompatible <$>+                 pragmaOptions) $ do+            -- re #3733: TODO better error msg.+            lift $ warning . UnsupportedIndexedMatch =<< prettyTCM x+       debugSubst "rho0" rho0        let rho0' = toSplitPSubst rho0@@ -1227,7 +1062,7 @@        let cps'  = applySplitPSubst rho cps -      return $ Just $ SClause delta' ps' rho cps' Nothing -- target fixed later+      return $ Just . (,unifyInfo) $ SClause delta' ps' rho cps' Nothing -- target fixed later    where     debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix = liftTCM $ do@@ -1243,7 +1078,7 @@           , "ixs    =" <+> do addContext delta1 $ prettyList $ map prettyTCM ixs           , "cixs   =" <+> do addContext gamma  $ prettyList $ map prettyTCM cixs           , "delta1 =" <+> do inTopContext $ prettyTCM delta1-          , "delta2 =" <+> do inTopContext $ addContext delta1 $ addContext gamma $ prettyTCM delta2+          , "delta2 =" <+> do inTopContext $ addContext delta1 $ addContext n $ prettyTCM delta2           , "gamma  =" <+> do inTopContext $ addContext delta1 $ prettyTCM gamma           , "tel  =" <+> do inTopContext $ prettyTCM tel           , "hix    =" <+> text (show hix)@@ -1412,17 +1247,20 @@         -- Andreas, 2010-09-21, isDatatype now directly throws an exception if it fails         -- cons = constructors of this datatype         (dr, d, pars, ixs, cons', isHIT) <- inContextOfT $ isDatatype ind t+        isFib <- lift $ isFibrant t         cons <- case checkEmpty of           CheckEmpty   -> ifM (liftTCM $ inContextOfT $ isEmptyType $ unDom t) (pure []) (pure cons')           NoCheckEmpty -> pure cons'         mns  <- forM cons $ \ con -> fmap (SplitCon con,) <$>           computeNeighbourhood delta1 n delta2 d pars ixs x tel ps cps con-        hcompsc <- if isHIT && inserttrailing == DoInsertTrailing+        hcompsc <- if isFib && (isHIT || (size ixs > 0)) && not (null mns) && inserttrailing == DoInsertTrailing                    then computeHCompSplit delta1 n delta2 d pars ixs x tel ps cps                    else return Nothing+        let ns = catMaybes mns         return ( dr                , not (null ixs) -- Is "d" indexed?-               , catMaybes (mns ++ [hcompsc])+               , length $ ns+               , ns ++ catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns])                )        computeLitNeighborhoods = do@@ -1452,21 +1290,24 @@         -- to an inductive family (with at least one index), then the         -- following code should be changed (the constructor False         -- stands for "not indexed").-        return (IsData, False, ns ++ [ ca ])+        let ns' = map ((fmap (,NoInfo))) $ ns ++ [ ca ]+        return (IsData, False, length ns', ns') -  (dr, isIndexed, ns) <- if null pcons' && not (null plits)+  -- numMatching is the number of proper constructors matching, excluding hcomp.+  -- for literals this considers the catchall clause as 1 extra constructor.+  (dr, isIndexed, numMatching, ns) <- if null pcons' && not (null plits)         then computeLitNeighborhoods         else computeNeighborhoods    ns <- case target of-    Just a  -> forM ns $ \ (con, sc) -> lift $ (con,) <$>+    Just a  -> forM ns $ \ (con,(sc,info)) -> lift $ (con,) . (,info) <$>                  fixTargetType (getQuantity t) con sc a     Nothing -> return ns    ns <- case inserttrailing of     DontInsertTrailing -> return ns-    DoInsertTrailing   -> lift $ forM ns $ \(con,sc) ->-      (con,) . snd <$> insertTrailingArgs False sc+    DoInsertTrailing   -> lift $ forM ns $ \(con,(sc,info)) ->+      (con,) . (,info) . snd <$> insertTrailingArgs False sc    mHCompName <- getPrimitiveName' builtinHComp   withoutK   <- collapseDefault . optWithoutK <$> pragmaOptions@@ -1477,8 +1318,8 @@         throwError . ErasedDatatype causedByWithoutK =<<           do liftTCM $ inContextOfT $ buildClosure (unDom t) -  case ns of-    []  -> do+  case numMatching of+    0  -> do       let absurdp = VarP (PatternInfo PatOAbsurd []) $ SplitPatVar underscore 0 []           rho = liftS x $ consS absurdp $ raiseS 1           ps' = applySubst rho ps@@ -1491,13 +1332,13 @@                }      -- Andreas, 2018-10-17: If more than one constructor matches, we cannot erase.-    _ : _ : _ | not erased && not (usableQuantity t) ->+    n | n > 1 && not erased && not (usableQuantity t) ->       erasedError False      -- If exactly one constructor matches and the K rule is turned     -- off, then we only allow erasure for non-indexed data types     -- (#4172).-    [_] | not erased && not (usableQuantity t) &&+    1 | not erased && not (usableQuantity t) &&           withoutK && isIndexed ->       erasedError True @@ -1512,7 +1353,7 @@       let all_tags = Set.fromList ptags `Set.union` inferred_tags        when (allowPartialCover == NoAllowPartialCover && not overlap) $-        for_ ns $ \(tag, sc) -> do+        for_ ns $ \(tag, (sc, _)) -> do           unless (tag `Set.member` all_tags) $ do             isImpossibleClause <- liftTCM $ isEmptyTel $ scTel sc             unless isImpossibleClause $ do@@ -1522,7 +1363,7 @@                 ]               throwError (GenericSplitError "precomputed set of constructors does not cover all cases") -      liftTCM $ checkSortOfSplitVar dr (unDom t) delta2 target+      liftTCM $ inContextOfT $ checkSortOfSplitVar dr (unDom t) delta2 target       return $ Right $ Covering (lookupPatternVar sc x) ns    where@@ -1645,7 +1486,7 @@             reportSDoc "tc.cover.copattern" 40 $ vcat               [ "fieldSub for" <+> prettyTCM (unDom proj)               , nest 2 $ pretty fieldSub ]-            return (SplitCon (unDom proj), sc')+            return (SplitCon (unDom proj), (sc', NoInfo))       _ -> addContext tel $ do         buildClosure (unDom t) >>= failure . CosplitNoRecordType   -- Andreas, 2018-06-09, issue #2170: splitting with irrelevant fields is always fine!
+ src/full/Agda/TypeChecking/Coverage/Cubical.hs view
@@ -0,0 +1,1391 @@+{-# LANGUAGE NondecreasingIndentation #-}++module Agda.TypeChecking.Coverage.Cubical where++import Prelude hiding (null, (!!))  -- do not use partial functions like !!++import Control.Monad+import Control.Monad.Except+import Control.Monad.Trans ( lift )++import Data.Foldable (for_)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Internal hiding (DataOrRecord(..))+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))++import Agda.TypeChecking.Names+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Monad++import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar)+import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars)+import Agda.TypeChecking.Rules.LHS.Unify+import Agda.TypeChecking.Rules.Term (unquoteTactic)++import Agda.TypeChecking.Coverage.Match+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Coverage.SplitClause+++import Agda.TypeChecking.Conversion (tryConversion, equalType)+import Agda.TypeChecking.Datatypes (getConForm, getDatatypeArgs)+import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType )+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Records+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Warnings++import Agda.Interaction.Options++import Agda.Utils.Either+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.WithDefault++import Agda.Utils.Impossible+++createMissingIndexedClauses :: QName+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> [(SplitTag,(SplitClause,IInfo))]+                            -> [Clause]+                            -> TCM ([(SplitTag,CoverResult)],[Clause])+createMissingIndexedClauses f n x old_sc scs cs = do+  reflId <- getName' builtinReflId+  let infos = [(c,i) | (SplitCon c, (_,TheInfo i)) <- scs ]+  case scs of+    [(SplitCon c,(_newSc,i@TheInfo{}))] | Just c == reflId -> do+      mc <- createMissingConIdClause f n x old_sc i+      caseMaybe mc (return ([],cs)) $ \ ((sp,tree),cl) -> do+      let res = CoverResult tree (IntSet.singleton (length cs)) [] [cl] IntSet.empty+      return ([(sp,res)],snoc cs cl)+    xs | not $ null infos -> do+         reportSDoc "tc.cover.indexed" 20 $ text "size (xs,infos):" <+> pretty (size xs,size infos)+         reportSDoc "tc.cover.indexed" 20 $ text "xs :" <+> pretty (map fst xs)++         unless (size xs == size infos + 1) $+            reportSDoc "tc.cover.indexed" 20 $ text "missing some infos"+            -- Andrea: what to do when we only managed to build a unification proof for some of the constructors?+         Constructor{conData} <- theDef <$> getConstInfo (fst (head infos))+         Datatype{dataPars = pars, dataIxs = nixs, dataTranspIx} <- theDef <$> getConstInfo conData+         hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp+         trX <- fromMaybe __IMPOSSIBLE__ <$> pure dataTranspIx+         trX_cl <- createMissingTrXTrXClause trX f n x old_sc+         hcomp_cl <- createMissingTrXHCompClause trX f n x old_sc+         (trees,cls) <- fmap unzip . forM infos $ \ (c,i) -> do+           cl <- createMissingTrXConClause trX f n x old_sc c i+           return $ ((SplitCon c , SplittingDone (size $ clauseTel cl)) , cl)+         let extra = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl)+                                           , (SplitCon hcomp, SplittingDone $ size $ clauseTel hcomp_cl)+                                           ]+                 --  = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl) ]+             extraCl = [trX_cl, hcomp_cl]+                 --  = [trX_cl]+         let clauses = cls ++ extraCl+         let tree = SplitAt ((+(pars+nixs+1)) <$> n) StrictSplit $+                                           trees+                                        ++ extra+             res = CoverResult+               { coverSplitTree      = tree+               , coverUsedClauses    = IntSet.fromList (map (length cs +) [0..length clauses-1])+               , coverMissingClauses = []+               , coverPatterns       = clauses+               , coverNoExactClauses = IntSet.empty+               }+         reportSDoc "tc.cover.indexed" 20 $+           "tree:" <+> pretty tree+         addClauses f clauses+         return $ ([(SplitCon trX,res)],cs++clauses)+--         return $ ([],[])+    xs | otherwise -> return ([],cs)++covFillTele :: QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]+covFillTele func tel face d j = do+  ed_f <- liftTCM $ runExceptT $ trFillTel tel face d j+  case ed_f of+    Right d_f -> pure $ map unArg d_f+    Left failed_t -> enterClosure failed_t $ \failed_t -> addContext ("i" :: String, __DUMMY_DOM__) $ do+      typeError . GenericDocError =<< vcat+        [ "Could not generate a transport clause for" <+> prettyTCM func+        , "because a term of type" <+> prettyTCM (unAbs failed_t)+        , "lives in the sort" <+> prettyTCM (getSort (unAbs failed_t)) <+> "and thus can not be transported"+        ]++createMissingTrXTrXClause :: QName -- ^ trX+                            -> QName -- ^ f defined+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> TCM Clause+createMissingTrXTrXClause q_trX f n x old_sc = do+  let+   old_tel = scTel old_sc+   old_ps = fromSplitPatterns $ scPats old_sc+   old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc++  reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f+  reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $+    [ "old_tel:" <+> prettyTCM old_tel+    , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)+    , "old_t  :" <+> addContext old_tel (prettyTCM old_t)+    ]++  -- TODO: redo comments, the strategy changed.+  -- old_tel = Γ1, (x : D η v), Δ+  -- α = boundary(old_ps)+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]++  -- α' = boundary(old_ps[x = pat])+  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v++  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat]++  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.++  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']+                                -- , φ  ↦ w1[φ = i1, p = refl]+                                -- , ψ  ↦ w1[ψ = i1, q = refl]+                                -- ]+  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)+  -- Ξ ⊢ pat_rec[0] = pat : D η v+  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v+  -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)++  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ+  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.++  interval <- elInf primInterval+  iz <- primIZero+  io <- primIOne+  tHComp <- primHComp+  tNeg <- primINeg+  let neg i = pure tNeg <@> i+  let min i j = cl primIMin <@> i <@> j+  let max i j = cl primIMax <@> i <@> j+  let+    old_tel = scTel old_sc+    old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc+    old_ps = pure $ old_ps'+    old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- old_tel = Γ(x: D η v)Δ+  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)+    (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel+    delta = pure $ AbsN (teleNames gamma1x) $ delta'+    gamma1_size = (size gamma1x - 1)+    (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x++  old_sides <- forM old_ps' $ \ ps -> do+    let vs = iApplyVars ps+    let tm = Def f $ patternsToElims ps+    xs <- forM vs $ \ v ->+        -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)+          fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+    return $ concatMap (\(v,(l,r)) -> [(tNeg `apply` [argN v],l),(v,r)]) xs+  let+    gamma1ArgNames = teleArgNames gamma1+    deltaArgNames = teleArgNames delta'+  (params,xTel,dT) <- addContext gamma1 $ do+    Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'+    def <- getConstInfo d+    let dTy = defType def+    let Datatype{dataSort = s} = theDef def+    TelV tel _ <- telView dTy+    let params = AbsN (teleNames gamma1) ps+        xTel = AbsN (teleNames gamma1) (tel `apply` ps)++    dT <- runNamesT [] $ do+          s <- open $ AbsN (teleNames tel) s+          bindNArg (teleArgNames gamma1) $ \ g1 -> do+          bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do+          params <- pure params `applyN` (fmap unArg <$> g1)+          x      <- sequence x+          s <- s `applyN` (map (pure . unArg) $ params ++ x)+          pure $ El s $ Def d [] `apply` (params ++ x)+    return $ (params, xTel,dT)++  let+    xTelI = pure $ expTelescope interval <$> xTel+    xTelIArgNames = teleArgNames (unAbsN xTel) -- same names++  -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0)+  let trX' = bindNArg gamma1ArgNames $ \ g1 -> do+             bindNArg ([defaultArg "phi"] ++ xTelIArgNames) $ \ phi_p -> do+             bindNArg [defaultArg "x0"] $ \ x0 -> do+             param_args <- fmap (map (setHiding Hidden . fmap (unnamed . dotP))) $+               pure params `applyN` (fmap unArg <$> g1)+             (phi:p) <- sequence phi_p+             x0 <- sequence x0+             pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0+      trX = (fmap . fmap . fmap) patternToTerm <$> trX'+  let pat' =+            bindN (map unArg gamma1ArgNames) $ \ g1 -> do+            bindN (map unArg $ ([defaultArg "phi"] ++ xTelIArgNames)) $ \ phi_p -> do+            bindN (map unArg $ ([defaultArg "psi"] ++ xTelIArgNames)) $ \ psi_q -> do+            bindN (map unArg $ [defaultArg "x0"]) $ \ x0 -> do+            -- (phi:p) <- sequence phi_p+            -- (psi:q) <- sequence psi_q+            -- x0 <- sequence x0+            let trX = trX' `applyN` g1+            trX `applyN` phi_p `applyN` [trX `applyN` psi_q `applyN` x0]+          --  pure $ trX $ p ++ [phi, defaultArg $ unnamed $ trX $ q ++ [psi] ++ x0]+      pat = (fmap . fmap . fmap . fmap) patternToTerm <$> pat'+  let deltaPat g1 phi p psi q x0 =+        delta `applyN` (g1 ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]])+  -- Ξ+  cTel <- runNamesT [] $+    abstractN (pure gamma1) $ \ g1 -> do+    abstractT "φ" (pure interval) $ \ phi -> do+    abstractN (xTelI `applyN` g1) $ \ p -> do+    abstractT "ψ" (pure interval) $ \ psi -> do+    abstractN (xTelI `applyN` g1) $ \ q -> do+    abstractT "x0" (pure dT `applyN` g1 `applyN` (flip map q $ \ f -> f <@> pure iz)) $ \ x0 -> do+    deltaPat g1 phi p psi q x0++  ps_ty_rhs <- runNamesT [] $ do+    bindN (map unArg gamma1ArgNames) $ \ g1 -> do+    bind "φ" $ \ phi -> do+    bindN (map unArg xTelIArgNames) $ \ p -> do+    bind "ψ" $ \ psi -> do+    bindN (map unArg xTelIArgNames) $ \ q -> do+    bind "x0" $ \ x0 -> do+    bindN (map unArg deltaArgNames) $ \ d -> do+    let+      ps :: NamesT TCM NAPs+      ps = old_ps `applyN` (g1+                          ++ [pat' `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]]+                          ++ d)++      rhsTy = old_ty `applyN` (g1+                          ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` (psi:q) `applyN` [x0]]+                          ++ d)++    xTel <- (open =<<) $ pure xTel `applyN` g1+    q4_f <- (open =<<) $ bind "i" $ \ i -> lamTel $ bind "j" $ \ j -> do+      ty <- bind "i" $ \ _ -> xTel+      face <- max phi $ max (neg j) (neg i)+      base <- map defaultArg <$> appTel (sequence q) j+      u  <- liftM2 (,) (max j psi) $ bind "h" $ \ h -> do+              appTel (sequence p) (min j (min h i))+      Right xs <- lift $ runExceptT $ transpSysTel' False ty [u] face base+      pure $ map unArg xs+    -- Ξ ⊢ pat_rec[0] = pat : D η v+    -- Ξ ⊢ pat_rec[1] = trX q4 (φ ∧ ψ) x0 : D η v+    -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q4_f i) (ψ ∧ (φ ∨ ~ i)) t)+    pat_rec <- (open =<<) $ bind "i" $ \ i -> do+          p_conn <- (mapM open =<<) $ lamTel $ bind "i" $ \ j -> sequence p `appTel` max i j+          q4_f' <- (mapM open =<<) $ absApp <$> q4_f <*> i+          trX `applyN` g1 `applyN` (max i phi:p_conn)+              `applyN` [trX `applyN` g1 `applyN` (min psi (max phi (neg i)):q4_f') `applyN` [x0]]++    let mkBndry args = do+            args1 <- (mapM open =<<) $ (absApp <$> args <*> pure io)+            -- faces ought to be constant on "j"+            faces <- pure (fmap (map fst) old_sides) `applyN` args1+            us <- forM (mapM (map snd) old_sides) $ \ u -> do+                  lam "j" $ \ j -> ilam "o" $ \ _ -> do+                    args <- (mapM open =<<) $ (absApp <$> args <*> j)+                    pure u `applyN` args+            forM (zip faces us) $ \ (phi,u) -> liftM2 (,) (open phi) (open u)+    let mkComp pr = bind "i" $ \ i -> do+          d_f <- (open =<<) $ bind "j" $ \ j -> do+            tel <- bind "j" $ \ j -> delta `applyN` (g1 ++ [pr `applyN` [i,j]])+            face <- min phi psi `max` (min i (max phi psi))+            j <- j+            d <- map defaultArg <$> sequence d+            lift $ covFillTele f tel face d j+          let args = bind "j" $ \ j -> do+                g1 <- sequence g1+                x <- pr `applyN` [i,neg j]+                ys <- absApp <$> d_f <*> neg j+                pure $ g1 ++ x:ys+          ty <- (open =<<) $ bind "j" $ \ j -> do+               args <- (mapM open =<<) $ absApp <$> args <*> j+               fmap unDom $ old_ty `applyN` args+          let face = max i (min phi psi)+          base <- (open =<<) $ do+            args' <- (mapM open =<<) $ absApp <$> args <*> pure iz+            fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'+          sys <- mkBndry args+          transpSys ty sys face base++    -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ+    -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+    -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.+    syspsi <- (open =<<) $ lam "i" $ \ i -> ilam "o" $ \ _ -> do+      c <- mkComp $ bindN ["i","j"] $ \ [i,j] -> do+        Abs n (data_ty,lines) <- bind "k" $ \ k -> do+          let phi_k = max phi (neg k)+          let p_k = flip map p $ \ p -> lam "h" $ \ h -> p <@> (min k h)+          data_ty <- pure dT `applyN` g1 `applyN` (flip map p $ \ p -> p <@> k)+          line1 <- trX `applyN` g1 `applyN` (phi_k:p_k) `applyN` [x0]++          line2 <- trX `applyN` g1+                       `applyN` (max phi_k j      : (flip map p_k $ \ p -> lam "h" $ \ h -> p <@> (max h j)))+                       `applyN`+                  [trX `applyN` g1+                       `applyN` (max phi_k (neg j): (flip map p_k $ \ p -> lam "h" $ \ h -> p <@> (min h j)))+                       `applyN` [x0]]+          pure (data_ty,[line1,line2])+        data_ty <- open $ Abs n data_ty+        [line1,line2] <- mapM (open . Abs n) lines+        let sys = [(neg i, lam "k" $ \ k -> ilam "o" $ \ _ -> absApp <$> line2 <*> k)+                  ,(neg j `max` j `max` i `max` phi, lam "k" $ \ k -> ilam "o" $ \ _ -> absApp <$> line1 <*> k)+                  ]+        transpSys data_ty sys (pure iz) x0+      absApp <$> pure c <*> i+    sysphi <- (open =<<) $ lam "i" $ \ i -> ilam "o" $ \ o -> do+      c <- mkComp $ bindN ["i","j"] $ \ _ij -> do+        trX `applyN` g1 `applyN` (psi:q) `applyN` [x0]+      absApp <$> pure c <*> i+    syse <- mkBndry $ bind "j" $ \ _ -> sequence $ g1 ++ [absApp <$> pat_rec <*> pure iz] ++ d+    let sys = syse ++ [(phi,sysphi)] ++ [(psi,syspsi)]+    w0 <- (open =<<) $ do+      let w = mkComp (bindN ["i","j"] $ \ [_i, j] -> absApp <$> pat_rec <*> j)+      absApp <$> w <*> pure iz+    let rhs = hcomp (unDom <$> rhsTy) sys w0+    (,,) <$> ps <*> rhsTy <*> rhs+  let (ps,ty,rhs) = unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs+  reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f+  let c = Clause { clauseLHSRange  = noRange+                 , clauseFullRange = noRange+                 , clauseTel       = cTel+                 , namedClausePats = ps+                 , clauseBody      = Just rhs+                 , clauseType      = Just $ Arg (getArgInfo ty) (unDom ty)+                 , clauseCatchall    = False+                 , clauseExact       = Nothing+                 , clauseRecursive   = Just True+                 , clauseUnreachable = Just False+                 , clauseEllipsis    = NoEllipsis+                 , clauseWhereModule = Nothing+                 }+  debugClause "tc.cover.trx.trx" c+  return $ c+createMissingTrXHCompClause :: QName+                            -> QName+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> TCM Clause+createMissingTrXHCompClause q_trX f n x old_sc = do+  let+   old_tel = scTel old_sc+   old_ps = fromSplitPatterns $ scPats old_sc+   old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc++  reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f+  reportSDoc "tc.cover.trx.hcomp" 20 $ nest 2 $ vcat $+    [ "old_tel:" <+> prettyTCM old_tel+    , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)+    , "old_t  :" <+> addContext old_tel (prettyTCM old_t)+    ]++  -- old_tel = Γ1, (x : D η v), Δ+  -- α = boundary(old_ps)+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]++  -- α' = boundary(old_ps[x = pat])+  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : I -> [ψ] → D η (p i0), u0 : D η (p i0) ⊢ pat := trX p φ (hcomp ψ u u0) : D η v++  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : ..., u0 : D η (p i0), Δ[x = pat]++  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.++  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']+                                -- , φ  ↦ w1[φ = i1, p = refl]   = f old_ps[γ1,x = hcomp ψ u u0    ,δ]+                                -- , ψ  ↦ w1[ψ = i1]             = f old_ps[γ1,x = trX p φ (u i1 _),δ]+                                -- ]++  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)+  -- Ξ ⊢ pat_rec[0] = pat : D η v+  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v+  -- Ξ ⊢ pat-rec[i] := trX (\ j → q (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)++  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ : Δ[γ1,x = pat_rec[1]]+  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.++  q_hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp+  let+   old_tel = scTel old_sc+   old_ps = fromSplitPatterns $ scPats old_sc+   old_t = fromMaybe __IMPOSSIBLE__ $ scTarget old_sc++  reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f+  reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $+    [ "old_tel:" <+> prettyTCM old_tel+    , "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)+    , "old_t  :" <+> addContext old_tel (prettyTCM old_t)+    ]++  -- TODO: redo comments, the strategy changed.+  -- old_tel = Γ1, (x : D η v), Δ+  -- α = boundary(old_ps)+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]++  -- α' = boundary(old_ps[x = pat])+  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v++  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat]++  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.++  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']+                                -- , φ  ↦ w1[φ = i1, p = refl]+                                -- , ψ  ↦ w1[ψ = i1, q = refl]+                                -- ]+  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)+  -- Ξ ⊢ pat_rec[0] = pat : D η v+  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v+  -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)++  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ+  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]+  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.++  interval <- elInf primInterval+  iz <- primIZero+  io <- primIOne+  tHComp <- primHComp+  tNeg <- primINeg+  let neg i = pure tNeg <@> i+  let min i j = cl primIMin <@> i <@> j+  let max i j = cl primIMax <@> i <@> j+  let+    old_tel = scTel old_sc+    old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc+    old_ps = pure $ old_ps'+    old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- old_tel = Γ(x: D η v)Δ+  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)+    (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel+    delta = pure $ AbsN (teleNames gamma1x) $ delta'+    gamma1_size = (size gamma1x - 1)+    (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x++  old_sides <- forM old_ps' $ \ ps -> do+    let vs = iApplyVars ps+    let tm = Def f $ patternsToElims ps+    xs <- forM vs $ \ v ->+        -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)+          fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+    return $ concatMap (\(v,(l,r)) -> [(tNeg `apply` [argN v],l),(v,r)]) xs+  let+    gamma1ArgNames = teleArgNames gamma1+    deltaArgNames = teleArgNames delta'+  (params,xTel,dT) <- addContext gamma1 $ do+    Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'+    def <- getConstInfo d+    let dTy = defType def+    let Datatype{dataSort = s} = theDef def+    TelV tel _ <- telView dTy+    let params = AbsN (teleNames gamma1) ps+        xTel = AbsN (teleNames gamma1) (tel `apply` ps)++    dT <- runNamesT [] $ do+          s <- open $ AbsN (teleNames tel) s+          bindNArg (teleArgNames gamma1) $ \ g1 -> do+          bindNArg (teleArgNames $ unAbsN xTel) $ \ x -> do+          params <- pure params `applyN` (fmap unArg <$> g1)+          x      <- sequence x+          s <- s `applyN` (map (pure . unArg) $ params ++ x)+          pure $ El s $ Def d [] `apply` (params ++ x)+    return $ (params, xTel,dT)++  let+    xTelI = pure $ expTelescope interval <$> xTel+    xTelIArgNames = teleArgNames (unAbsN xTel) -- same names++  -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0)+  let trX' = bindNArg gamma1ArgNames $ \ g1 -> do+             bindNArg ([defaultArg "phi"] ++ xTelIArgNames) $ \ phi_p -> do+             bindNArg [defaultArg "x0"] $ \ x0 -> do+             param_args <- fmap (map (setHiding Hidden . fmap (unnamed . dotP))) $+               pure params `applyN` (fmap unArg <$> g1)+             (phi:p) <- sequence phi_p+             x0 <- sequence x0+             pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0+      trX = (fmap . fmap . fmap) patternToTerm <$> trX'+  let+    hcompD' g1 v =+        bindNArg [argH "psi",argN "u", argN "u0"] $ \ x0 -> do+        x0 <- sequence x0+        Just (LEl l t) <- (toLType =<<) $ pure dT `applyN` g1 `applyN` v+        let ty = map (fmap (unnamed . dotP) . argH) [Level l,t]+        pure $ DefP defaultPatternInfo q_hcomp $ ty ++ x0+  hcompD <- runNamesT [] $+            bindN (map unArg $ gamma1ArgNames) $ \ g1 -> do+            bindN (teleNames $ unAbsN $ xTel) $ \ v -> do+            fmap patternToTerm <$> hcompD' g1 v+  let pat' =+            bindN (map unArg gamma1ArgNames) $ \ g1 -> do+            bindN (map unArg $ ([defaultArg "phi"] ++ xTelIArgNames)) $ \ phi_p -> do+            bindN ["psi","u","u0"] $ \ x0 -> do+            let trX = trX' `applyN` g1+            let p0 = flip map (tail phi_p) $ \ p -> p <@> pure iz+            trX `applyN` phi_p `applyN` [hcompD' g1 p0 `applyN` x0]+      pat = (fmap . fmap . fmap) patternToTerm <$> pat'+  let deltaPat g1 phi p x0 =+        delta `applyN` (g1 ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` x0])+  -- Ξ+  cTel <- runNamesT [] $+    abstractN (pure gamma1) $ \ g1 -> do+    abstractT "φ" (pure interval) $ \ phi -> do+    abstractN (xTelI `applyN` g1) $ \ p -> do+    let p0 = flip map p $ \ p -> p <@> pure iz+    let ty = pure dT `applyN` g1 `applyN` p0+    abstractT "ψ" (pure interval) $ \ psi -> do+    abstractT "u" (pure interval --> pPi' "o" psi (\ _ -> ty)) $ \ u -> do+    abstractT "u0" ty $ \ u0 -> do+    deltaPat g1 phi p [psi,u,u0]++  ps_ty_rhs <- runNamesT [] $ do+    bindN (map unArg gamma1ArgNames) $ \ g1 -> do+    bind "φ" $ \ phi -> do+    bindN (map unArg xTelIArgNames) $ \ p -> do+    bind "ψ" $ \ psi -> do+    bind "u" $ \ u -> do+    bind "u0" $ \ u0 -> do+    bindN (map unArg deltaArgNames) $ \ d -> do+    let+      x0 :: Vars TCM+      x0 = [psi,u,u0]+      ps :: NamesT TCM NAPs+      ps = old_ps `applyN` (g1+                          ++ [pat' `applyN` g1 `applyN` (phi:p) `applyN` x0]+                          ++ d)++      rhsTy = old_ty `applyN` (g1+                          ++ [pat `applyN` g1 `applyN` (phi:p) `applyN` x0]+                          ++ d)++    xTel <- (open =<<) $ pure xTel `applyN` g1+    -- Ξ ⊢ pat-rec[i] := trX .. (hfill ... (~ i))+    pat_rec <- (open =<<) $ bind "i" $ \ i -> do+          let tr x = trX `applyN` g1 `applyN` (phi:p) `applyN` [x]+          let p0 = flip map p $ \ p -> p <@> pure iz+          tr (hcomp (pure dT `applyN` g1 `applyN` p0)+                    [(psi,lam "j" $ \ j -> u <@> (min j (neg i)))+                    ,(i  ,lam "j" $ \ _ -> ilam "o" $ \ _ -> u0)]+                    u0)+    --   args : (i.old_tel)  -> ...+    let mkBndry args = do+            args1 <- (mapM open =<<) $ (absApp <$> args <*> pure io)+            -- faces ought to be constant on "j"+            faces <- pure (fmap (map fst) old_sides) `applyN` args1+            us <- forM (mapM (map snd) old_sides) $ \ u -> do+                  lam "j" $ \ j -> ilam "o" $ \ _ -> do+                    args <- (mapM open =<<) $ (absApp <$> args <*> j)+                    pure u `applyN` args+            forM (zip faces us) $ \ (phi,u) -> liftM2 (,) (open phi) (open u)+    rhs <- do+      d_f <- (open =<<) $ bind "j" $ \ j -> do+        tel <- bind "j" $ \ j -> delta `applyN` (g1 ++ [absApp <$> pat_rec <*> j])+        let face = iz+        j <- j+        d <- map defaultArg <$> sequence d+        lift $ covFillTele f tel face d j+      let args = bind "j" $ \ j -> do+            g1 <- sequence g1+            x <- absApp <$> pat_rec <*> neg j+            ys <- absApp <$> d_f <*> neg j+            pure $ g1 ++ x:ys+      ty <- (open =<<) $ bind "j" $ \ j -> do+           args <- (mapM open =<<) $ absApp <$> args <*> j+           fmap unDom $ old_ty `applyN` args+      let face = pure iz+      othersys <- (open =<<) $ lam "j" $ \ j -> ilam "o" $ \ _ -> do+        args' <- (mapM open =<<) $ absApp <$> args <*> j+        fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'+      sys <- mkBndry args+      let+        -- we could specialize all of sysphi/syspsi/base to compute+        -- away trX or the hcomp respectively, should lead to+        -- smaller/more efficient terms.+        --+        -- we could also ditch sysphi completely,+        -- as the computation rule for hcomp would achieve the same.+        sysphi = othersys+        syspsi = othersys+      base <- (open =<<) $ do+        args' <- (mapM open =<<) $ absApp <$> args <*> pure iz+        fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'+      transpSys ty ((phi,sysphi):(psi,syspsi):sys) face base+    (,,) <$> ps <*> rhsTy <*> pure rhs+  let (ps,ty,rhs) = unAbsN $ unAbs $ unAbs $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs+  reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f+  let c = Clause { clauseLHSRange  = noRange+                 , clauseFullRange = noRange+                 , clauseTel       = cTel+                 , namedClausePats = ps+                 , clauseBody      = Just rhs+                 , clauseType      = Just $ Arg (getArgInfo ty) (unDom ty)+                 , clauseCatchall    = False+                 , clauseExact       = Nothing+                 , clauseRecursive   = Just True+                 , clauseUnreachable = Just False+                 , clauseEllipsis    = NoEllipsis+                 , clauseWhereModule = Nothing+                 }+  debugClause "tc.cover.trx.hcomp" c+  return c+createMissingTrXConClause :: QName -- trX+                            -> QName -- f defined+                            -> Arg Nat+                            -> BlockingVar+                            -> SplitClause+                            -> QName -- constructor name+                            -> UnifyEquiv+                            -> TCM Clause+createMissingTrXConClause q_trX f n x old_sc c (UE gamma gamma' xTel u v rho tau leftInv) = do+  reportSDoc "tc.cover.trxcon" 20 $ "trX-con clause for" <+> prettyTCM f <+> "with con" <+> prettyTCM c+  reportSDoc "tc.cover.trxcon" 20 $ nest 2 $ vcat $+    [ "gamma" <+> prettyTCM gamma+    , "gamma'" <+> prettyTCM gamma'+    , "xTel" <+> addContext gamma (prettyTCM xTel)+    , "u"  <+> addContext gamma (prettyTCM u)+    , "v"  <+> addContext gamma (prettyTCM v)+    , "rho" <+> addContext gamma' (prettyTCM rho)+    ]++  Constructor{conSrcCon = chead} <- theDef <$> getConstInfo c++  -- = TheInfo $ UE delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv++  -- η : Params_D ⊢ c : (a : Args(η)) → D η (ξ(η,a))++  -- scTel old_sc = Γ1, (x : D η v), Δ+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)]++  -- Γ = Γ1, a : Args(η)+  -- Γ ⊢ u = ξ(η,a)+  -- Γ ⊢ c a : D η u++  -- Γ' ⊢ ρ : Γ++  -- Γ' ⊢ u[ρ] = v[ρ] : X(η)[ρ]++  -- Γ' ⊢ c a[ρ] : (D η v)[ρ]++  -- Γ' ⊢ ρx := ρ,x = c a[ρ] : Γ,(x : D η v)++  -- Γ',Δ[ρx] ⊢ old_t[ρx]+  -- Γ',Δ[ρx] ⊢ f old_ps[ρx] : old_t[ρx] [α[ρx] ↦ e[γ1,x,δ][ρx]]++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ τ : Γ'++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ [ρx][τ] = [ρ[τ], x = c a[ρ[τ]]] : Γ,(x : D η v)++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path X(η) u v)++  -- Γ,(φ : I),(p : Path X(η) u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path X(η) u v)++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path X(η) u v)+  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i1 = γ   ,φ ,p    : Γ,(φ : I),(p : Path X(η) u v)+  --                                 leftInv[φ = i1][i] = idS++  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢ τ' = liftS |Δ[ρx]| τ : Γ',Δ[ρx]++  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢+  --            w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ]++  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ], α(γ1,x,δ)[ρx][τ'] ⊢ w = e(γ1,x,δ)[ρx][τ']++  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v+++  -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat])++  -- Ξ ⊢ δ_f[1] = trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]]++  -- Ξ ⊢ w[δ_f[1]] : old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ_f[1]]+  -- Ξ, α(γ1,x,δ)[ρx][τ'][δ = δ_f[1]] ⊢ w[δ_f[1]] = e(γ1,x,δ)[ρx][τ'][δ_f[1]]++  -- Ξ, α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1]) ⊢ w[δ_f[1]] = e(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1])++  -- Recap:+  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)]+  -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat])+  -- Ξ ⊢ δ_f[1] := trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]]+  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢+  --            w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ]+  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v+++  -- Ξ ⊢ ?rhs : old_t[γ1,x = pat,δ] [α(γ1,pat,δ) ↦ e(γ1,pat,δ)+  --                               ,φ           ↦ w+  --                               ]++  -- ?rhs := transp (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]]) φ (w[δ_f[1]])++  -- we shall consider α(γ1,pat,δ) = α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1])+  -- also rather than (p : Path X(η) u v) we'll have (p : I -> X(η)), same as the type of trX.++  iz <- primIZero+  interval <- elInf primInterval+  let+      old_tel = scTel old_sc+      old_ps = pure $ AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc+      old_ty = pure $ AbsN (teleNames old_tel) $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- old_tel = Γ(x: D η v)Δ+  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)+      (gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel+  let+    gammaArgNames = teleArgNames gamma+    deltaArgNames = teleArgNames delta'+  let+    xTelI = pure $ AbsN (teleNames gamma) $ expTelescope interval xTel+    delta = pure $ AbsN (teleNames gamma1x) $ delta'+    gamma1_size = (size gamma1x - 1)+    (gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x+  params <- addContext gamma1 $ do+    Just (_d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'+    return $ AbsN (teleNames gamma1) ps+  -- Γ, φ , p ⊢ pat := trX p φ (c a)+  let pat' =+            bindNArg gammaArgNames $ \ g1_args -> do+            bindNArg ([defaultArg "phi"] ++ teleArgNames xTel) $ \ phi_p -> do+            let (g1,args) = splitAt gamma1_size g1_args+            (phi:p) <- sequence phi_p+            args <- sequence args+            let cargs = defaultArg $ unnamed $ ConP chead noConPatternInfo args+            -- Amy (2022-11-06): Set the parameters to quantity-0.+            param_args <- fmap (map (setQuantity (Quantity0 Q0Inferred) . setHiding Hidden . fmap (unnamed . dotP))) $+              pure params `applyN` take gamma1_size (fmap unArg <$> g1_args)+            pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi,cargs]+      pat = (fmap . fmap) patternToTerm <$> pat'+      pat_left' = (fmap . fmap) (Abs "i" . (applySubst leftInv)) <$> pat+      g1_left' = bindN (map unArg gammaArgNames) $ \ g1_args -> do+                bindN (map unArg $ [defaultArg "phi"] ++ teleArgNames xTel) $ \ phi_p -> do+                g1 <- sequence $ take gamma1_size g1_args :: NamesT TCM [Term]+                pure $ Abs "i" (applySubst leftInv g1)++  gamma <- return $ pure gamma+  let deltaPat g1_args phi p =+        delta `applyN` (take gamma1_size g1_args ++ [pat `applyN` g1_args `applyN` (phi:p)])+  let neg i = cl primINeg <@> i+  -- Ξ+  cTel <- runNamesT [] $+    abstractN gamma $ \ g1_args -> do+    abstractT "φ" (pure interval) $ \ phi -> do+    abstractN (xTelI `applyN` g1_args) $ \ p -> do+    deltaPat g1_args phi p+  ps_ty_rhs <- runNamesT [] $ do+    bindN (map unArg gammaArgNames) $ \ g1_args -> do+    bind "phi" $ \ phi -> do+    bindN (teleNames xTel) $ \ p -> do+    bindN (map unArg $ deltaArgNames) $ \ d -> do+    let+      g1_left = g1_left' `applyN` g1_args `applyN` (phi:p)+      pat_left = pat_left' `applyN` g1_args `applyN` (phi:p)+      g1 :: Vars TCM+      g1 = take gamma1_size g1_args++      args :: Vars TCM+      args = drop gamma1_size g1_args++      ps :: NamesT TCM NAPs+      ps = old_ps `applyN` (g1 ++ [pat' `applyN` g1_args `applyN` (phi:p)] ++ d)++      rhsTy = old_ty `applyN` (g1 ++ [pat `applyN` g1_args `applyN` (phi:p)] ++ d)++    -- (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]])+    delta_f <- (open =<<) $ bind "i" $ \ i -> do+      let ni = neg i+      dargs <- (mapM open =<<) $ do+        xs <- absApp <$> g1_left <*> ni+        y <- absApp <$> pat_left <*> ni+        return $ xs ++ [y]+      delta `applyN` dargs++    --  trFillTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ+    d_f <- (open =<<) $ bind "i" $ \ i -> do+      delta_f <- delta_f+      phi <- phi+      d <- map defaultArg <$> sequence d+      i <- i+      lift $ covFillTele f delta_f phi d i++    -- w = Def f (old_ps[g1_left[i],pat_left[i],d_f[~ i]])+    w <- (open =<<) $ bind "i" $ \ i -> do+      psargs <- (mapM open =<<) $ do+        xs <- absApp <$> g1_left <*> i+        y <- absApp <$> pat_left <*> i+        zs <- absApp <$> d_f <*> neg i+        return $ xs ++ [y] ++ zs+      ps <- (fmap patternsToElims <$> old_ps) `applyN` psargs+      pure $ Def f ps+++    -- (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]])+    ty <- (open =<<) $ bind "i" $ \ i -> do+      tyargs <- (mapM open =<<) $ do+        xs <- absApp <$> g1_left <*> i+        y <- absApp <$> pat_left <*> i+        zs <- absApp <$> d_f <*> neg i+        return $ xs ++ [y] ++ zs+      fmap unDom $ old_ty `applyN` tyargs++    sys <- do+      sides <- do+        neg <- primINeg+        io <- primIOne+        vs <- iApplyVars <$> ps+        tm <- w+        xs <- forM vs $ \ v ->+            -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)+              fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+        return $ concatMap (\(v,(l,r)) -> [(neg `apply` [argN v],l),(v,r)]) xs+      forM sides $ \ (psi,u') -> do+        u' <- open u'+        u <- lam "i" $ \ i -> ilam "o" $ \ o -> absApp <$> u' <*> i+        (,) <$> open psi <*> open u++    let rhs = transpSys ty sys phi (absApp <$> w <*> pure iz)++    (,,) <$> ps <*> rhsTy <*> rhs++  let (ps,ty,rhs) = unAbsN $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs+  qs <- mapM (fmap (fromMaybe __IMPOSSIBLE__) . getName') [builtinINeg, builtinIMax, builtinIMin]+  rhs <- addContext cTel $+           locallyReduceDefs (OnlyReduceDefs (Set.fromList $ q_trX : qs)) $ normalise rhs+  let cl = Clause { clauseLHSRange  = noRange+                  , clauseFullRange = noRange+                  , clauseTel       = cTel+                  , namedClausePats = ps+                  , clauseBody      = Just rhs+                  , clauseType      = Just $ Arg (getArgInfo ty) (unDom ty)+                  , clauseCatchall    = False+                  , clauseExact       = Nothing+                  , clauseRecursive   = Just True+                  , clauseUnreachable = Just False+                  , clauseEllipsis    = NoEllipsis+                  , clauseWhereModule = Nothing+                  }+++  debugClause "tc.cover.trxcon" cl++  reportSDoc "tc.cover.trxcon" 20 $ vcat $+    [ "clause:"+    ,  nest 2 $ prettyTCM . QNamed f $ cl+    ]++  let mod =+        setRelevance Irrelevant $  -- See #5611.+        getModality $ fromMaybe __IMPOSSIBLE__ $ scTarget old_sc+  -- we follow what `cover` does when updating the modality from the target.+  applyModalityToContext mod $ do+    unlessM (asksTC hasQuantity0) $ do+    reportSDoc "tc.cover.trxcon" 20 $ text "testing usable at mod: " <+> pretty mod+    addContext cTel $ usableAtModality IndexedClause mod rhs++  return cl++-- | If given @TheInfo{}@ then assumes "x : Id u v" and+--   returns both a @SplittingDone@ for conId, and the @Clause@ that covers it.+createMissingConIdClause :: QName         -- ^ function being defined+                         -> Arg Nat       -- ^ @covSplitArg@ index+                         -> BlockingVar   -- ^ @x@ variable being split on.+                         -> SplitClause   -- ^ clause before split+                         -> IInfo         -- ^ info from unification+                         -> TCM (Maybe ((SplitTag,SplitTree),Clause))+createMissingConIdClause f _n x old_sc (TheInfo info) = setCurrentRange f $ do+  let+    -- iΓ'+    itel = infoTel+    -- with 3 params, reflId : Id A u u -- no arguments.+    -- iΓ' ⊢ iρ : Γ+    --+    -- Δ = Γ,φ,(p : u ≡ v) ⊢ iτ : iΓ'+    -- ρ = iρ+    -- τ = iτ+    irho = infoRho info+    itau = infoTau info+    ileftInv = infoLeftInv info+  interval <- elInf primInterval+  tTrans  <- primTrans+  tComp  <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp+  conId <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinConId+  let bindSplit (tel1,tel2) = (tel1,AbsN (teleNames tel1) tel2)+  let+      old_tel = scTel old_sc++  -- old_tel = Γ(x: Id A u v)Δ+  -- Γ(x: Id A u v)Δ ⊢ old_t+  -- Γ ⊢ hdelta = (x : Id A u v)(δ : Δ)+      pair@(_gamma,_hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel+      (gamma,hdelta) = bindSplit pair+      old_t  = AbsN (teleNames old_tel) $ fromJust $ scTarget old_sc+      old_ps = AbsN (teleNames old_tel) $ patternsToElims $ fromSplitPatterns $ scPats old_sc+      old_ps' = AbsN (teleNames old_tel) $ fromSplitPatterns $ scPats old_sc++  params <- runNamesT [] $ do+    hdelta <- open hdelta+    bindN (teleNames gamma) $ \ args -> do+       hdelta@(ExtendTel hdom _) <- applyN hdelta args+       Def _Id es@[_,_,_,_] <- reduce $ unEl $ unDom hdom+       return $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es++  working_tel <- runNamesT [] $ do+    hdelta <- open hdelta+    params <- open params+    abstractN (pure gamma) $ \ args -> do+      pTel <- open =<< (lift $ pathTelescope (infoEqTel info) (map defaultArg $ infoEqLHS info) (map defaultArg $ infoEqRHS info))+      abstractN (pure (telFromList [defaultDom ("phi",interval)] :: Telescope)) $ \ [phi] ->+        abstractN pTel $ \ [p] -> do+          [l,bA,x,y] <- mapM open =<< applyN params args+          apply1 <$> applyN hdelta args <*> (cl primConId <#> l <#> bA <#> x <#> y <@> phi <@> p)+  -- working_tel ⊢ i. γ[leftInv i]+  (gamma_args_left :: Abs [Term], con_phi_p_left :: Abs Term) <- fmap (raise (size delta) . unAbsN) . runNamesT [] $ do+    params <- open params+    bindN (teleNames gamma ++ ["phi","p"]) $ \ args' -> do+      let (args,[phi,p]) = splitAt (size gamma) args'+      [l,bA,x,y] <- mapM open =<< applyN params args+      gargs <- Abs "i" . applySubst ileftInv <$> sequence args+      con_phi_p <- Abs "i" . applySubst ileftInv <$> do+        (cl primConId <#> l <#> bA <#> x <#> y <@> phi <@> p)+      return (gargs,con_phi_p)+  ps <- fmap unAbsN . runNamesT [] $ do+    old_ps' <- open $ old_ps'+    params <- open params+    bindN (teleNames working_tel) $ \ (wargs :: [NamesT TCM Term]) -> do+      let (g,phi:p:d) = splitAt (size gamma) $ telePatterns working_tel []+      params <- map (argH . unnamed . dotP) <$> applyN params (take (size gamma) wargs)+      let x = DefP defaultPatternInfo conId $ params ++ [phi,p]+      args <- open $ map namedArg g ++ [x] ++ map namedArg d+      applyN' old_ps' args+  -- tel = Γ',Δ[ρ,x = refl]+  -- Γ' ⊢ ρ : Γ+  -- Γ' ⊢ u[ρ] = v[ρ] : A[ρ]++  -- Γ' ⊢ ρ,x=refl : Γ,(x : Id A u v)++  -- Γ',Δ[ρ,x = refl] ⊢ old_t[ρ,x=refl] = Δ₂ -> t+  -- Γ',Δ[ρ,x = refl] ⊢ f old_ps[ρ,x = refl] : old_t[ρ,x = refl]+  -- Γ,(φ : I),(p : Path A u v) ⊢ τ : Γ'++  -- Γ' ⊢ [ρ,x = refl u[ρ]] : Γ,(x : Id A u v)++  -- Γ,(φ : I),(p : Path A u v) ⊢ [ρ,x = refl u[ρ]][τ] = [ρ[τ], x = refl u[ρ[τ]]] : Γ,(x : Id A u v)++  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path A u v)++  -- Γ,(φ : I),(p : Path A u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path A u v)++  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path A u v)+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = γ   ,φ ,p : Γ,(φ : I),(p : Path A u v)+  --                      leftInv[φ = i1][i] = idS++  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl]++  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢+  --            w = f old_ps[ρ[τ],x = refl u[ρ[τ]],δ] : old_t[ρ,x = refl][τ'] = old_t[ρ[τ],x = refl u[ρ[τ]],δ]++  -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨φ,p⟩[leftInv (~i)] : (Id A u v)[γ[leftInv (~ i)]]+  --                                     μ[0] = ⟨ φ             , p    ⟩+  --                                     μ[1] = ⟨ 1             , refl ⟩++  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢+  --         δ_f[1] = vecTransp (i. Δ[γ[leftInv (~ i)], ⟨φ,p⟩[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]]++  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ w[δ_f[1]] : old_t[ρ[τ],x = refl u[ρ[τ]],δ_f[1]]+  -- Γ,(φ : I),(p : Path A u v),Δ[x = ⟨ φ , p ⟩] ⊢ rhs = transp (i. old_t[γ[leftInv i],x = ⟨φ,p⟩[leftInv i], δ_f[~i]]) φ (w[δ_f[1]]) : old_t[γ,x = ⟨ φ , p ⟩,δ]+  let+      getLevel t = do+        s <- reduce $ getSort t+        case s of+          Type l -> pure (Level l)+          s      -> do+            reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s+            typeError . GenericDocError =<<+                    (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"")+  (ty,rhs) <- addContext working_tel $ runNamesT [] $ do+    let+        raiseFrom :: Subst a => Telescope -> a -> a+        raiseFrom tel x = raise (size working_tel - size tel) x+        all_args = teleArgs working_tel :: Args+        (gamma_args,phi:p:delta_args) = splitAt (size gamma) all_args+    old_t <- open $ raiseFrom EmptyTel old_t+    old_ps <- open $ raiseFrom EmptyTel old_ps+    delta_args <- open delta_args+    gamma_args_left <- open gamma_args_left+    con_phi_p_left <- open con_phi_p_left+    hdelta <- open $ raiseFrom gamma hdelta+    delta_f <- bind "i" $ \ i -> do+      apply1 <$> applyN' hdelta (lazyAbsApp <$> gamma_args_left <*> (cl primINeg <@> i)) <*> (lazyAbsApp <$> con_phi_p_left <*> (cl primINeg <@> i))+    delta_f <- open delta_f+    [phi,p] <- mapM (open . unArg) [phi,p]+    delta_args_f <- bind "i" $ \ i -> do++      m <- trFillTel' True <$> delta_f <*> phi <*> delta_args <*> i+      either __IMPOSSIBLE__ id <$> (lift $ runExceptT m)+    delta_args_f <- open delta_args_f+    old_t_f <- (open =<<) $ bind "i" $ \ i -> do+      g <- lazyAbsApp <$> gamma_args_left <*> i+      x <- lazyAbsApp <$> con_phi_p_left <*> i+      d <- lazyAbsApp <$> delta_args_f <*> (cl primINeg <@> i)+      args <- open $ g ++ [x] ++ map unArg d+      applyN' old_t args+    w <- (open =<<) $ bind "i" $ \ i -> do+      g <- lazyAbsApp <$> gamma_args_left <*> i+      x <- lazyAbsApp <$> con_phi_p_left <*> i+      d <- lazyAbsApp <$> delta_args_f <*> (cl primINeg <@> i)+      args <- open $ g ++ [x] ++ map unArg d+      Def f <$> applyN' old_ps args++    ps <- open ps+    max <- primIMax+    iz <- primIZero+    alphas <- (open =<<) $ do+      vs <- iApplyVars <$> ps+      neg <- primINeg+      zero <- primIZero+      return $ foldr (\ x r -> max `apply` [argN $ max `apply` [argN x, argN (neg `apply` [argN x])], argN r]) zero $ map var vs+    sides <- (open =<<) $ do+      neg <- primINeg+      io <- primIOne+      bind "i" $ \ i -> do+        vs <- iApplyVars <$> ps+        tm <- lazyAbsApp <$> w <*> i+        xs <- forM vs $ \ v ->+          -- have to reduce these under the appropriate substitutions, otherwise non-normalizing+          fmap (var v,) . reduce $ (inplaceS v iz `applySubst` tm, inplaceS v io `applySubst` tm)+        phiv <- fromMaybe __IMPOSSIBLE__ . deBruijnView <$> phi+        -- extra assumption: phi |- w i = w 0, otherwise we need [ phi -> w 0 ] specifically+        tm_phi <- reduce $ inplaceS phiv io `applySubst` tm+        phi <- phi+        return $ (phi,tm_phi) : concatMap (\(v,(l,r)) -> [(neg `apply` [argN v],l),(v,r)]) xs++    let imax i j = apply max $ map argN [i,j]+    tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr+    let+      pOr l ty phi psi u0 u1 = do+          [phi,psi] <- mapM open [phi,psi]+          pure tPOr <#> l+                    <@> phi <@> psi+                    <#> (ilam "o" $ \ _ -> ty) <@> noilam u0 <@> u1++      noilam u = do+         u <- open u+         ilam "o" $ \ _ -> u++      combine l ty [] = __IMPOSSIBLE__+      combine l ty [(psi,u)] = noilam u+      combine l ty ((psi,u):xs) = pOr l ty psi (foldr imax iz (map fst xs)) u (combine l ty xs)++    let ty i = lazyAbsApp <$> old_t_f <*> i+    l <- (open =<<) $ lam "i" $ \ i -> do+           t <- unDom <$> ty i+           lift $ getLevel t+    ((,) <$> ty (cl primIOne) <*>) $ do+         n <- length . unAbs <$> sides+         -- TODO don't comp if the family and the sides "j. [ α ↦ u ]" are constant?+         if n > 1 then+           pure tComp <#> l <@> (lam "i" $ \ i -> unEl . unDom <$> ty i)+                <@> (cl primIMax <@> phi <@> alphas)+                <@> (lam "i" $ \ i -> combine (l <@> i) (unEl . unDom <$> ty i) =<< (lazyAbsApp <$> sides <*> i))+                <@> (lazyAbsApp <$> w <*> primIZero)+         else+           pure tTrans <#> l <@> (lam "i" $ \ i -> unEl . unDom <$> ty i)+                <@> phi+                <@> (lazyAbsApp <$> w <*> primIZero)++  reportSDoc "tc.cover.conid" 20 $ text "conid case for" <+> text (show f)+  reportSDoc "tc.cover.conid" 20 $ text "tel =" <+> prettyTCM working_tel+  reportSDoc "tc.cover.conid" 25 $ addContext working_tel $ prettyTCM rhs++  let cl =   Clause { clauseLHSRange  = noRange+                    , clauseFullRange = noRange+                    , clauseTel       = working_tel+                    , namedClausePats = ps+                    , clauseBody      = Just $ rhs+                    , clauseType      = Just $ Arg (domInfo ty) (unDom ty)+                    , clauseCatchall    = False+                    , clauseUnreachable = Just False  -- missing, thus, not unreachable+                    , clauseRecursive   = Just False+                    , clauseEllipsis    = NoEllipsis+                    , clauseExact       = Nothing+                    , clauseWhereModule = Nothing+                    }+  addClauses f [cl]+  return $ Just ((SplitCon conId,SplittingDone (size working_tel)),cl)+createMissingConIdClause f n x old_sc NoInfo = return Nothing+++{-+  OLD leftInv case+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ] ≡ wkS 2 : Γ+  -- Γ,(φ : I),(p : Path A u v)(i : I) ⊢ leftInv i : Γ+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ] : Γ+  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = wkS 2 : Γ+  -- leftInv[φ = i1][i] = wkS 2++  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl]++  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ w = f old_ps[ρ,x = refl][τ'] : old_t[ρ,x = refl][τ']++  -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨ (φ ∨ ~ i) , (\ j → p (i ∧ j)) ⟩ : Id A u (p i) =?= (Id A u v)[leftInv (~ i)]+                                  μ[0] = ⟨ 1 , (\ _ → u[ρ[τ]]) ⟩+                                  μ[1] = ⟨ φ , p               ⟩+  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ vecTransp (i. Δ[leftInv (~ i),μ[i]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]]+-}++-- | Append an hcomp clause to the clauses of a function.+createMissingHCompClause+  :: QName+       -- ^ Function name.+  -> Arg Nat -- ^ index of hcomp pattern+  -> BlockingVar -- ^ Blocking var that lead to hcomp split.+  -> SplitClause -- ^ Clause before the hcomp split+  -> SplitClause+       -- ^ Clause to add.+  -> [Clause]+   -> TCM ([(SplitTag,CoverResult)], [Clause])+createMissingHCompClause f n x old_sc (SClause tel ps _sigma' _cps (Just t)) cs = setCurrentRange f $ do+  reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "Trying to create right-hand side of type" <+> prettyTCM t+  reportSDoc "tc.cover.hcomp" 30 $ addContext tel $ text "ps = " <+> prettyTCMPatternList (fromSplitPatterns ps)+  reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel++  io      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIOne+  iz      <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero+  let+    cannotCreate :: MonadTCError m => Doc -> Closure (Abs Type) -> m a+    cannotCreate doc t = do+      typeError . SplitError $ CannotCreateMissingClause f (tel,fromSplitPatterns ps) doc t+  let old_ps = patternsToElims $ fromSplitPatterns $ scPats old_sc+      old_t  = fromJust $ scTarget old_sc+      old_tel = scTel old_sc+      -- old_tel = Γ(x:H)Δ+      -- Γ(x:H)Δ ⊢ old_t+      -- vs = iApplyVars old_ps+      -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]++      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]+      -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ]+      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0)++      -- Extra assumption:+      -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ'+      -- ps = old_ps[x = hcomp φ u u0],ps'+      -- with Δ' and ps' introduced by fixTarget.+      -- So final clause will be:+      -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps'+      getLevel t = do+        s <- reduce $ getSort t+        case s of+          Type l -> pure (Level l)+          s      -> do+            reportSDoc "tc.cover.hcomp" 20 $ text "getLevel, s = " <+> prettyTCM s+            typeError . GenericDocError =<<+                    (text "The sort of" <+> prettyTCM t <+> text "should be of the form \"Set l\"")++      -- Γ ⊢ hdelta = (x : H)(δ : Δ)+      (gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel++      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢+      (working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel++      -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)+      {- rhoS = liftS (size hdelta) $ raiseS 3 -}+      vs = iApplyVars (scPats old_sc)++  -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]+  alphab <- forM vs $ \ i -> do+               let+                 -- Γ(x:H)(δ : Δ) ⊢+                 tm = Def f old_ps+               -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems+               (l,r) <- reduce (inplaceS i iz `applySubst` tm, inplaceS i io `applySubst` tm)+               return $ (var i, (l, r))++++  cl <- do+    (ty,rhs) <- addContext working_tel $ do+      -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ]+      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]+      -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i]+      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill     = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i]+      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]]+      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i])+      --                 (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]]+      --                         α ↦ b[x = hfill φ u u0 i,δ_fill[i]]+      --                        ])+      --                 (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ]++      runNamesT [] $ do+          tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr+          tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax+          tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin+          tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg+          tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp+          tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans+          extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps+          let+            ineg j = pure tINeg <@> j+            imax i j = pure tIMax <@> i <@> j+            trFillTel' a b c d = do+              m <- trFillTel <$> a <*> b <*> c <*> d+              x <- lift $ runExceptT m+              case x of+                Left bad_t -> cannotCreate "Cannot transport with type family:" bad_t+                Right args -> return args+          comp <- mkCompLazy "hcompClause"+          let+            hcomp la bA phi u u0 = pure tHComp <#> la <#> bA+                                               <#> phi+                                               <@> u+                                               <@> u0++            hfill la bA phi u u0 i = hcomp la bA+                                               (pure tIMax <@> phi <@> (pure tINeg <@> i))+                                               (lam "j" $ \ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <#> ilam "o" (\ _ -> bA)+                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)+                                                     <@> ilam "o" (\ _ -> u0)+                                                   )+                                               u0+          -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)+          hcompS <- lift $ do+            hdom <- pure $ raise 3 hdom+            let+              [phi,u,u0] = map (pure . var) [2,1,0]+              htype = pure $ unEl . unDom $ hdom+              lvl = getLevel $ unDom hdom+            hc <- pure tHComp <#> lvl <#> htype+                                      <#> phi+                                      <@> u+                                      <@> u0+            return $ liftS (size delta) $ hc `consS` raiseS 3+          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom+          hdom <- pure $ raise (3+size delta) hdom+          htype <- open $ unEl . unDom $ hdom+          lvl <- open =<< (lift . getLevel $ unDom hdom)++          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢+          [phi,u,u0] <- mapM (open . raise (size delta) . var) [2,1,0]+          -- Γ,x,Δ ⊢ f old_ps+          -- Γ ⊢ abstract hdelta (f old_ps)+          g <- open $ raise (3+size delta) $ abstract hdelta (Def f old_ps)+          old_t <- open $ raise (3+size delta) $ abstract hdelta (unDom old_t)+          let bapp a x = lazyAbsApp <$> a <*> x+          (delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do+            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ+            delta <- open $ raise (3+size delta) delta+            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i))+            deltaf <- open =<< bind "i" (\ i ->+                           (delta `bapp` hfill lvl htype phi u u0 (ineg i)))+            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0]+            args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz)+            bind "i" $ \ i -> addContext ("i" :: String) $ do -- for error messages.+              -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i)+              trFillTel' deltaf (pure iz) args (ineg i)+          let+            apply_delta_fill i f = apply <$> f <*> (delta_fill `bapp` i)+            call v i = apply_delta_fill i $ g <@> v+          ty <- do+                return $ \ i -> do+                    v <- hfill lvl htype phi u u0 i+                    hd <- old_t+                    args <- delta_fill `bapp` i+                    lift $ piApplyM hd $ Arg (domInfo hdom) v : args+          ty_level <- do+            t <- bind "i" $ \ x -> ty x+            s <- reduce $ getSort (absBody t)+            reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s+            case s of+              Type l -> open =<< lam "i" (\ _ -> pure $ Level l)+              _      -> do cl <- liftTCM (buildClosure t)+                           liftTCM (cannotCreate "Cannot compose with type family:" cl)++          let+            pOr_ty i phi psi u0 u1 = pure tPOr <#> (ty_level <@> i)+                                               <@> phi <@> psi+                                               <#> ilam "o" (\ _ -> unEl <$> ty i) <@> u0 <@> u1+          alpha <- do+            vars <- mapM (open . applySubst hcompS . fst) alphab+            return $ foldr (imax . (\ v -> v `imax` ineg v)) (pure iz) vars++          -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]+          b <- do+             sides <- forM alphab $ \ (psi,(side0,side1)) -> do+                psi <- open $ hcompS `applySubst` psi++                [side0,side1] <- mapM (open . raise (3+size delta) . abstract hdelta) [side0,side1]+                return $ (ineg psi `imax` psi, \ i -> pOr_ty i (ineg psi) psi (ilam "o" $ \ _ -> apply_delta_fill i $ side0 <@> hfill lvl htype phi u u0 i)+                                                            (ilam "o" $ \ _ -> apply_delta_fill i $ side1 <@> hfill lvl htype phi u u0 i))+             let recurse []           i = __IMPOSSIBLE__+                 recurse [(psi,u)]    i = u i+                 recurse ((psi,u):xs) i = pOr_ty i psi (foldr (imax . fst) (pure iz) xs) (u i) (recurse xs i)+             return $ recurse sides++          ((,) <$> ty (pure io) <*>) $ do+            comp ty_level+               (lam "i" $ fmap unEl . ty)+                           (phi `imax` alpha)+                           (lam "i" $ \ i ->+                               let rhs = (ilam "o" $ \ o -> call (u <@> i <..> o) i)+                               in if null alphab then rhs else+                                   pOr_ty i phi alpha rhs (b i)+                           )+                           (call u0 (pure iz))+    reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel+    let n = size tel - (size gamma + 3 + size delta)+    reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n)+    (TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty+    rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs++    cxt <- getContextTelescope+    reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt+    reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel+    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t+    reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs++    return $ Clause { clauseLHSRange  = noRange+                    , clauseFullRange = noRange+                    , clauseTel       = tel+                    , namedClausePats = fromSplitPatterns ps+                    , clauseBody      = Just $ rhs+                    , clauseType      = Just $ defaultArg t+                    , clauseCatchall    = False+                    , clauseExact       = Just True+                    , clauseRecursive   = Nothing     -- TODO: can it be recursive?+                    , clauseUnreachable = Just False  -- missing, thus, not unreachable+                    , clauseEllipsis    = NoEllipsis+                    , clauseWhereModule = Nothing+                    }+  addClauses f [cl]  -- Important: add at the end.+  let result = CoverResult+          { coverSplitTree      = SplittingDone (size (clauseTel cl))+          , coverUsedClauses    = IntSet.singleton (length cs)+          , coverMissingClauses = []+          , coverPatterns       = [cl]+          , coverNoExactClauses = IntSet.empty+          }+  hcompName <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp+  return ([(SplitCon hcompName,result)],cs++[cl])+createMissingHCompClause _ _ _ _ (SClause _ _ _ _ Nothing) _ = __IMPOSSIBLE__
src/full/Agda/TypeChecking/Coverage/Match.hs view
@@ -13,7 +13,8 @@  module Agda.TypeChecking.Coverage.Match   ( Match(..), match, matchClause-  , SplitPattern, SplitPatVar(..), fromSplitPatterns, toSplitPatterns+  , SplitPattern, SplitPatVar(..)+  , fromSplitPattern, fromSplitPatterns, toSplitPatterns   , toSplitPSubst, applySplitPSubst   , isTrivialPattern   , BlockingVar(..), BlockingVars, BlockedOnResult(..)@@ -25,6 +26,8 @@  import Prelude hiding ( null ) +import Data.DList (DList)+import Data.Foldable (toList) import qualified Data.List as List import Data.Maybe (mapMaybe, fromMaybe) import Data.Semigroup ( Semigroup, (<>))@@ -43,6 +46,7 @@ import Agda.Utils.Null import Agda.Utils.Pretty ( Pretty(..), text, (<+>), cat , prettyList_ ) import Agda.Utils.Monad+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -110,7 +114,7 @@             => Nat  -- Clause number.             -> Clause             -> m (Match (Nat, SplitInstantiation))-    matchIt i c = fmap (i,) <$> matchClause ps c+    matchIt i c = fmap (\s -> (i, toList s)) <$> matchClause ps c  -- | For each variable in the patterns of a split clause, we remember the --   de Bruijn-index and the literals excluded by previous matches.@@ -147,8 +151,11 @@ toSplitPatterns :: [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern] toSplitPatterns = (fmap . fmap . fmap . fmap) toSplitVar +fromSplitPattern :: NamedArg SplitPattern -> NamedArg DeBruijnPattern+fromSplitPattern = (fmap . fmap . fmap) fromSplitVar+ fromSplitPatterns :: [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]-fromSplitPatterns = (fmap . fmap . fmap . fmap) fromSplitVar+fromSplitPatterns = fmap fromSplitPattern  type SplitPSubstitution = Substitution' SplitPattern @@ -219,7 +226,7 @@  -- | If matching succeeds, we return the instantiation of the clause pattern vector --   to obtain the split clause pattern vector.-type MatchResult = Match SplitInstantiation+type MatchResult = Match (DList (Nat, SplitPattern))  instance Pretty BlockingVar where   pretty (BlockingVar i cs ls o l) = cat@@ -342,7 +349,7 @@   -> m MatchResult      -- ^ Result.      --   If 'Yes' the instantiation @rs@ such that @ps[rs] == qs@.-matchPats [] [] = yes []+matchPats [] [] = yes mempty matchPats (p:ps) (q:qs) =   matchPat (namedArg p) (namedArg q) `combine` matchPats ps qs @@ -352,8 +359,8 @@ -- Thus, if the split clause has copatterns left, -- the current (shorter) clause is not considered covering. matchPats [] qs@(_:_) = case mapMaybe isProjP qs of-  [] -> yes [] -- no proj. patterns left-  _  -> no     -- proj. patterns left+  [] -> yes mempty -- no proj. patterns left+  _  -> no         -- proj. patterns left  -- Patterns left in candidate clause: -- If the current clause has additional copatterns in@@ -408,9 +415,10 @@      --   to produce the split clause pattern, @p[rs] = q@. matchPat p q = case p of -  VarP _ x   -> yes [(fromMaybe __IMPOSSIBLE__ (deBruijnView x),q)]+  VarP _ x ->+    yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q) -  DotP{}   -> yes []+  DotP{} -> yes mempty   -- Jesper, 2014-11-04: putting 'Yes [q]' here triggers issue 1333.   -- Not checking for trivial patterns should be safe here, as dot patterns are   -- guaranteed to match if the rest of the pattern does, so some extra splitting@@ -421,16 +429,17 @@                 then no                 else blockedOnLiteral (splitPatVarIndex x) l     _ -> isLitP q >>= \case-      Just l' -> if l == l' then yes [] else no+      Just l' -> if l == l' then yes mempty else no       Nothing -> no    ProjP _ d -> case q of     ProjP _ d' -> do       d <- getOriginalProjection d-      if d == d' then yes [] else no+      if d == d' then yes mempty else no     _          -> __IMPOSSIBLE__ -  IApplyP _ _ _ x -> yes [(fromMaybe __IMPOSSIBLE__ (deBruijnView x),q)]+  IApplyP _ _ _ x ->+    yes $ singleton (fromMaybe __IMPOSSIBLE__ (deBruijnView x), q)                             --    Issue #4179: If the inferred pattern is a literal                            -- v  we need to turn it into a constructor pattern.@@ -446,7 +455,7 @@     IApplyP _ _ _ x -> blockedOnConstructor (splitPatVarIndex x) c ci    DefP o c ps -> unDotP q >>= \case-    VarP _ x -> __IMPOSSIBLE__ -- blockedOnConstructor (splitPatVarIndex x) c+    VarP _ x -> no     ConP c' i qs -> no     DotP o t  -> no     LitP{}    -> no
+ src/full/Agda/TypeChecking/Coverage/SplitClause.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NondecreasingIndentation #-}++{-| SplitClause and CoverResult types.++ -}++module Agda.TypeChecking.Coverage.SplitClause where++import Prelude hiding (null, (!!))  -- do not use partial functions like !!++import Control.Monad+import Control.Monad.Except+import Control.Monad.Trans ( lift )++import Data.Foldable (for_)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Agda.Syntax.Common+import Agda.Syntax.Position+import Agda.Syntax.Internal hiding (DataOrRecord(..))+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))++import Agda.TypeChecking.Names+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Monad++import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar)+import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars)+import Agda.TypeChecking.Rules.LHS.Unify+import Agda.TypeChecking.Rules.Term (unquoteTactic)++import Agda.TypeChecking.Coverage.Match+import Agda.TypeChecking.Coverage.SplitTree++import Agda.TypeChecking.Conversion (tryConversion, equalType)+import Agda.TypeChecking.Datatypes (getConForm)+import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType )+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Records+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.MetaVars+import Agda.TypeChecking.Warnings++import Agda.Interaction.Options++import Agda.Utils.Either+import Agda.Utils.Functor+import Agda.Utils.List+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Pretty (prettyShow)+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.WithDefault++import Agda.Utils.Impossible+++data SplitClause = SClause+  { scTel    :: Telescope+    -- ^ Type of variables in @scPats@.+  , scPats   :: [NamedArg SplitPattern]+    -- ^ The patterns leading to the currently considered branch of+    --   the split tree.+  , scSubst  :: Substitution' SplitPattern+    -- ^ Substitution from 'scTel' to old context.+    --   Only needed directly after split on variable:+    --   * To update 'scTarget'+    --   * To rename other split variables when splitting on+    --     multiple variables.+    --   @scSubst@ is not ``transitive'', i.e., does not record+    --   the substitution from the original context to 'scTel'+    --   over a series of splits.  It is freshly computed+    --   after each split by 'computeNeighborhood'; also+    --   'splitResult', which does not split on a variable,+    --   should reset it to the identity 'idS', lest it be+    --   applied to 'scTarget' again, leading to Issue 1294.+  , scCheckpoints :: Map CheckpointId Substitution+    -- ^ We need to keep track of the module parameter checkpoints for the+    -- clause for the purpose of inferring missing instance clauses.+  , scTarget :: Maybe (Dom Type)+    -- ^ The type of the rhs, living in context 'scTel'.+    --   'fixTargetType' computes the new 'scTarget' by applying+    --   substitution 'scSubst'.+  }++data UnifyEquiv = UE { infoTel0 :: Telescope          -- Γ0+                     , infoTel :: Telescope           -- Γ'+                     , infoEqTel :: Telescope         -- Γ0 ⊢ Δ+                     , infoEqLHS :: [Term]            -- Γ0 ⊢ us : Δ+                     , infoEqRHS :: [Term]            -- Γ0 ⊢ vs : Δ+                     , infoRho :: PatternSubstitution -- Γ' ⊢ ρ : Γ0+                                                      -- Γ = Γ0,(φ : I),(eqs : Paths Δ us vs)+                                                      -- Γ' ⊢ ρ,i1,refls : Γ+                     , infoTau :: Substitution        -- Γ  ⊢ τ           : Γ'+                     , infoLeftInv :: Substitution    -- Γ | (i : I) ⊢ leftInv : Γ+                     -- leftInv[i=0] = ρ[τ],i1s,refls+                     -- leftInv[i=1] = idS+                     }+                  deriving Show++data IInfo = TheInfo UnifyEquiv | NoInfo deriving Show++-- | A @Covering@ is the result of splitting a 'SplitClause'.+data Covering = Covering+  { covSplitArg     :: Arg Nat+     -- ^ De Bruijn level (counting dot patterns) of argument we split on.+  , covSplitClauses :: [(SplitTag, (SplitClause, IInfo))]+      -- ^ Covering clauses, indexed by constructor/literal these clauses share.+  }++-- | Project the split clauses out of a covering.+splitClauses :: Covering -> [SplitClause]+splitClauses (Covering _ qcs) = map (fst . snd) qcs++-- | Create a split clause from a clause in internal syntax. Used by make-case.+clauseToSplitClause :: Clause -> SplitClause+clauseToSplitClause cl = SClause+  { scTel    = clauseTel cl+  , scPats   = toSplitPatterns $ namedClausePats cl+  , scSubst  = idS  -- Andreas, 2014-07-15  TODO: Is this ok?+  , scCheckpoints = Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing+  , scTarget = domFromArg <$> clauseType cl+  }+++---------------------------------------------+-- Record type for the results of @cover@+---------------------------------------------++data CoverResult = CoverResult+  { coverSplitTree       :: SplitTree+  , coverUsedClauses     :: IntSet -- Set Nat+  , coverMissingClauses  :: [(Telescope, [NamedArg DeBruijnPattern])]+  , coverPatterns        :: [Clause]+  -- ^ The set of patterns used as cover.+  , coverNoExactClauses  :: IntSet -- Set Nat+  }
src/full/Agda/TypeChecking/Coverage/SplitTree.hs view
@@ -15,7 +15,6 @@ import Control.DeepSeq  import Data.Tree-import Data.Data (Data)  import GHC.Generics (Generic) @@ -46,10 +45,10 @@     , splitLazy  :: LazySplit     , splitTrees :: SplitTrees' a -- ^ Sub split trees.     }-  deriving (Data, Show, Generic)+  deriving (Show, Generic)  data LazySplit = LazySplit | StrictSplit-  deriving (Data, Show, Eq, Ord, Generic)+  deriving (Show, Eq, Ord, Generic)  -- | Split tree branching.  A finite map from constructor names to splittrees --   A list representation seems appropriate, since we are expecting not@@ -64,7 +63,7 @@   = SplitCon QName   | SplitLit Literal   | SplitCatchall-  deriving (Show, Eq, Ord, Data, Generic)+  deriving (Show, Eq, Ord, Generic)  instance Pretty SplitTag where   pretty (SplitCon c) = pretty c
src/full/Agda/TypeChecking/Datatypes.hs view
@@ -33,6 +33,9 @@     Record     { recConHead = c' } -> return c'     _ -> throwError $ SigUnknown $ prettyShow c ++ " is not a constructor" +isConstructor :: (HasConstInfo m) => QName -> m Bool+isConstructor q = isRight <$> getConHead q+ -- | Get true constructor with fields, expanding literals to constructors --   if possible. getConForm :: QName -> TCM (Either SigError ConHead)@@ -66,6 +69,15 @@     Record{} -> return False     _  -> __IMPOSSIBLE__ +isPathCons :: HasConstInfo m => QName -> m Bool+isPathCons c = do+  d <- getConstructorData c+  def <- theDef <$> getConstInfo d+  case def of+    Datatype {dataPathCons = xs} -> return $ c `elem` xs+    Record{} -> return False+    _  -> __IMPOSSIBLE__+ -- | @getConType c t@ computes the constructor parameters from type @t@ --   and returns them plus the instantiated type of constructor @c@. --   This works also if @t@ is a function type ending in a data/record type;@@ -165,16 +177,19 @@ --   For getting just the arity of constructor @c@, --   use @either id size <$> getConstructorArity c@. getConstructorInfo :: HasConstInfo m => QName -> m ConstructorInfo-getConstructorInfo c = do+getConstructorInfo c = fromMaybe __IMPOSSIBLE__ <$> getConstructorInfo' c++getConstructorInfo' :: HasConstInfo m => QName -> m (Maybe ConstructorInfo)+getConstructorInfo' c = do   (theDef <$> getConstInfo c) >>= \case-    Constructor{ conData = d, conArity = n } -> do+    Constructor{ conData = d, conArity = n } -> Just <$> do       (theDef <$> getConstInfo d) >>= \case         r@Record{ recFields = fs } ->            return $ RecordCon (recPatternMatching r) (recEtaEquality r) fs         Datatype{} ->            return $ DataCon n         _ -> __IMPOSSIBLE__-    _ -> __IMPOSSIBLE__+    _ -> return Nothing  --------------------------------------------------------------------------- -- * Data types@@ -211,6 +226,23 @@     Record{ recPars = n }      -> return $ Just n     Constructor{ conPars = n } -> return $ Just n     _                          -> return Nothing++-- | This is a simplified version of @isDatatype@ from @Coverage@,+--   useful when we do not want to import the module.+getDatatypeArgs :: HasConstInfo m => Type -> m (Maybe (QName, Args, Args))+getDatatypeArgs t = do+  case unEl t of+    Def d es -> do+      let ~(Just args) = allApplyElims es+      def <- theDef <$> getConstInfo d+      case def of+        Datatype{dataPars = np} -> do+          let !(ps, is) = splitAt np args+          return $ Just (d,   ps, is)+        Record{} -> do+          return $ Just (d, args, [])+        _ -> return Nothing+    _ -> return Nothing  getNotErasedConstructors :: QName -> TCM [QName] getNotErasedConstructors d = do
src/full/Agda/TypeChecking/DeadCode.hs view
@@ -1,14 +1,22 @@ module Agda.TypeChecking.DeadCode (eliminateDeadCode) where +import qualified Control.Exception as E+import Control.Monad.Trans++import Data.Maybe import Data.Monoid (All(..))-import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap +import Agda.Interaction.Options+ import qualified Agda.Syntax.Abstract as A +import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.MetaVars import Agda.Syntax.Internal.Names import Agda.Syntax.Scope.Base @@ -18,34 +26,122 @@ import Agda.TypeChecking.Monad import Agda.TypeChecking.Reduce +import Agda.Utils.Impossible import Agda.Utils.Lens+import Agda.Utils.WithDefault --- | Run before serialisation to remove any definitions that are not reachable---   from the public interface to the module.-eliminateDeadCode :: DisplayForms -> Signature -> TCM (DisplayForms, Signature)-eliminateDeadCode disp sig = Bench.billTo [Bench.DeadCode] $ do+-- | Run before serialisation to remove any definitions and+-- meta-variables that are not reachable from the module's public+-- interface.+--+-- Things that are reachable only from warnings are removed.++eliminateDeadCode ::+  BuiltinThings PrimFun -> DisplayForms -> Signature ->+  LocalMetaStore ->+  TCM (DisplayForms, Signature, RemoteMetaStore)+eliminateDeadCode bs disp sig ms = Bench.billTo [Bench.DeadCode] $ do   patsyn <- getPatternSyns   public <- Set.mapMonotonic anameName . publicNames <$> getScope-  defs <- traverse instantiateFull $ sig ^. sigDefinitions+  save   <- collapseDefault . optSaveMetas <$> pragmaOptions+  defs   <- (if save then return else traverse instantiateFull)+                 (sig ^. sigDefinitions)   -- #2921: Eliminating definitions with attached COMPILE pragmas results in   -- the pragmas not being checked. Simple solution: don't eliminate these.-  let hasCompilePragma = Set.fromList . HMap.keys . HMap.filter (not . Map.null . defCompiledRep) $ defs-  let r     = reachableFrom (Set.union public hasCompilePragma) patsyn defs-      dead  = Set.fromList (HMap.keys defs) `Set.difference` r+  -- #6022 (Andreas, 2022-09-30): Eliminating cubical primitives can lead to crashes.+   -- Simple solution: retain all primitives (shouldn't be many).+  let hasCompilePragma = not . MapS.null . defCompiledRep+      isPrimitive = \case+        Primitive{}     -> True+        PrimitiveSort{} -> True+        _ -> False+      extraRootsFilter (name, def)+        | hasCompilePragma def || isPrimitive (theDef def) = Just name+        | otherwise = Nothing+      extraRoots =+        Set.fromList $ mapMaybe extraRootsFilter $ HMap.toList defs++      rootNames = Set.union public extraRoots+      rootMetas =+        if not save then Set.empty else metasIn+          ( bs+          , sig ^. sigSections+          , sig ^. sigRewriteRules+          , HMap.filterWithKey (\x _ -> Set.member x rootNames) disp+          )+      (rns, rms) =+        reachableFrom (rootNames, rootMetas) patsyn disp defs ms+      dead  = Set.fromList (HMap.keys defs) `Set.difference` rns       valid = getAll . namesIn' (All . (`Set.notMember` dead))  -- no used name is dead       defs' = HMap.map ( \ d -> d { defDisplay = filter valid (defDisplay d) } )-            $ HMap.filterWithKey (\ x _ -> Set.member x r) defs+            $ HMap.filterWithKey (\ x _ -> Set.member x rns) defs       disp' = HMap.filter (not . null) $ HMap.map (filter valid) disp-  reportSLn "tc.dead" 10 $ "Removed " ++ show (HMap.size defs - HMap.size defs') ++ " unused definitions."-  return (disp', set sigDefinitions defs' sig)+      ms'   = HMap.fromList $+              mapMaybe+                (\(m, mv) ->+                  if not (Set.member m rms)+                  then Nothing+                  else Just (m, remoteMetaVariable mv)) $+              MapS.toList ms+  -- The hashmaps are forced to WHNF to ensure that the computations+  -- are billed to the right account.+  disp' <- liftIO $ E.evaluate disp'+  defs' <- liftIO $ E.evaluate defs'+  ms'   <- liftIO $ E.evaluate ms'+  reportSLn "tc.dead" 10 $+    "Removed " ++ show (HMap.size defs - HMap.size defs') +++    " unused definitions and " ++ show (MapS.size ms - HMap.size ms') +++    " unused meta-variables."+  return (disp', set sigDefinitions defs' sig, ms') -reachableFrom :: Set QName -> A.PatternSynDefns -> Definitions -> Set QName-reachableFrom names psyns defs = follow names (Set.toList names)+reachableFrom+  :: (Set QName, Set MetaId)  -- ^ Roots.+  -> A.PatternSynDefns -> DisplayForms -> Definitions -> LocalMetaStore+  -> (Set QName, Set MetaId)+reachableFrom (ids, ms) psyns disp defs insts =+  follow (ids, ms)+    (map Left (Set.toList ids) ++ map Right (Set.toList ms))   where-    follow visited [] = visited-    follow visited (x : xs) = follow (Set.union visited new) (Set.toList new ++ xs)-      where-        new = names `Set.difference` visited-        names = case HMap.lookup x defs of-                  Nothing -> namesIn (PSyn <$> Map.lookup x psyns)-                  Just d  -> namesIn d+  follow seen        []       = seen+  follow (!ids, !ms) (x : xs) =+    follow (Set.union ids'' ids, Set.union ms'' ms)+      (map Left  (Set.toList ids'') +++       map Right (Set.toList ms'')  +++       xs)+    where+    ids'' = ids' `Set.difference` ids+    ms''  = ms'  `Set.difference` ms++    (ids', ms') = case x of+      Left x ->+        namesAndMetasIn+          ( HMap.lookup x defs+          , PSyn <$> MapS.lookup x psyns+          , HMap.lookup x disp+          )+      Right m -> case MapS.lookup m insts of+        Nothing -> (Set.empty, Set.empty)+        Just mv -> namesAndMetasIn (instBody (theInstantiation mv))++-- | Returns the instantiation.+--+-- Precondition: The instantiation must be of the form @'InstV' inst@.++theInstantiation :: MetaVariable -> Instantiation+theInstantiation mv = case mvInstantiation mv of+  InstV inst                     -> inst+  Open{}                         -> __IMPOSSIBLE__+  OpenInstance{}                 -> __IMPOSSIBLE__+  BlockedConst{}                 -> __IMPOSSIBLE__+  PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__++-- | Converts from 'MetaVariable' to 'RemoteMetaVariable'.+--+-- Precondition: The instantiation must be of the form @'InstV' inst@.++remoteMetaVariable :: MetaVariable -> RemoteMetaVariable+remoteMetaVariable mv = RemoteMetaVariable+  { rmvInstantiation = theInstantiation mv+  , rmvModality      = getModality mv+  , rmvJudgement     = mvJudgement mv+  }
src/full/Agda/TypeChecking/DisplayForm.hs view
@@ -137,7 +137,7 @@  unionMatch :: Monad m => MatchResult -> MatchResult -> MaybeT m MatchResult unionMatch m1 m2-  | Set.disjoint (Map.keysSet m1) (Map.keysSet m2) = return $ Map.union m1 m2+  | null (Map.intersection m1 m2) = return $ Map.union m1 m2   | otherwise = mzero  -- Non-linear pattern, fail for now.  unionsMatch :: Monad m => [MatchResult] -> MaybeT m MatchResult
src/full/Agda/TypeChecking/Empty.hs view
@@ -21,6 +21,7 @@ import Agda.TypeChecking.Coverage import Agda.TypeChecking.Coverage.Match ( fromSplitPatterns ) import Agda.TypeChecking.Records+import Agda.TypeChecking.Reduce ( instantiateFull ) import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope @@ -36,7 +37,7 @@   | DontKnow Blocker   -- ^ Emptyness check blocked  instance Semigroup ErrorNonEmpty where-  DontKnow u1     <> DontKnow u2  = DontKnow $ u1 <> u2  -- Both must unblock for this to proceed+  DontKnow u1     <> DontKnow u2  = DontKnow $ unblockOnBoth u1 u2  -- Both must unblock for this to proceed   e@DontKnow{}    <> _            = e   _               <> e@DontKnow{} = e   FailBecause err <> _            = FailBecause err@@ -88,7 +89,9 @@       dontAssignMetas $ do         r <- splitLast Inductive tel ps         case r of-          Left UnificationStuck{} -> return $ Left $ DontKnow $ unblockOnAnyMetaIn tel+          Left UnificationStuck{} -> do+            blocker <- unblockOnAnyMetaIn <$> instantiateFull tel -- TODO Jesper: get proper blocking information from unification+            return $ Left $ DontKnow blocker           Left _                  -> return $ Left Fail           Right cov -> do             let ps = map (namedArg . lastWithDefault __IMPOSSIBLE__ . fromSplitPatterns . scPats) $ splitClauses cov
src/full/Agda/TypeChecking/Errors.hs view
@@ -17,17 +17,19 @@   , dropTopLevelModule   , topLevelModuleDropper   , stringTCErr+  , explainWhyInScope+  , Verbalize(verbalize)   ) where  import Prelude hiding ( null, foldl ) +import qualified Control.Exception as E import Control.Monad.Except  import qualified Data.CaseInsensitive as CaseInsens import Data.Foldable (foldl)-import Data.Function+import Data.Function (on) import Data.List (sortBy, dropWhileEnd, intercalate)-import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe import qualified Data.Set as Set import qualified Text.PrettyPrint.Boxes as Boxes@@ -48,6 +50,7 @@ import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Debug+import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.SizedTypes ( sizeType ) import Agda.TypeChecking.Monad.State@@ -107,7 +110,7 @@ tcErrString err = prettyShow (getRange err) ++ " " ++ case err of   TypeError _ _ cl  -> errorString $ clValue cl   Exception r s     -> prettyShow r ++ " " ++ show s-  IOException _ r e -> prettyShow r ++ " " ++ show e+  IOException _ r e -> prettyShow r ++ " " ++ E.displayException e   PatternErr{}      -> "PatternErr"  stringTCErr :: String -> TCErr@@ -232,6 +235,7 @@   UnequalRelevance{}                       -> "UnequalRelevance"   UnequalQuantity{}                        -> "UnequalQuantity"   UnequalCohesion{}                        -> "UnequalCohesion"+  UnequalFiniteness{}                      -> "UnequalFiniteness"   UnequalHiding{}                          -> "UnequalHiding"   UnequalLevel{}                           -> "UnequalLevel"   UnequalSorts{}                           -> "UnequalSorts"@@ -291,14 +295,10 @@  -- | Produces a function which drops the filename component of the qualified name. topLevelModuleDropper :: (MonadDebug m, MonadTCEnv m, ReadTCState m) => m (QName -> QName)-topLevelModuleDropper = do-  caseMaybeM (asksTC envCurrentPath) (return id) $ \ f -> do-  reportSDoc "err.dropTopLevel" 60 $ vcat-    [ "current path =" <+> (text . filePath) f-    , "moduleToSource =" <+> do text . show =<< useR stModuleToSource-    ]-  m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f-  return $ dropTopLevelModule' $ size m+topLevelModuleDropper =+  caseMaybeM currentTopLevelModule+    (return id)+    (return . dropTopLevelModule' . size)  instance PrettyTCM TypeError where   prettyTCM err = case err of@@ -597,6 +597,11 @@       pwords "because one is a non-flat function type and the other is a flat function type"       -- FUTURE Cohesion: update message if/when introducing sharp. +    UnequalFiniteness cmp a b -> fsep $+      [prettyTCM a, notCmp cmp, prettyTCM b] +++      pwords "because one is a type of partial elements and the other is a function type"+      -- FUTURE Cohesion: update message if/when introducing sharp.+     UnequalHiding a b -> fsep $       [prettyTCM a, "!=", prettyTCM b] ++       pwords "because one is an implicit function type and the other is an explicit function type"@@ -804,11 +809,11 @@      NoSuchModule x -> fsep $ pwords "No module" ++ [pretty x] ++ pwords "in scope" -    AmbiguousName x ys -> vcat+    AmbiguousName x reason -> vcat       [ fsep $ pwords "Ambiguous name" ++ [pretty x <> "."] ++                pwords "It could refer to any one of"-      , nest 2 $ vcat $ fmap nameWithBinding ys-      , fwords "(hint: Use C-c C-w (in Emacs) if you want to know why)"+      , nest 2 $ vcat $ fmap nameWithBinding $ ambiguousNamesInReason reason+      , explainWhyInScope $ whyInScopeDataFromAmbiguousNameReason x reason       ]      AmbiguousModule x ys -> vcat@@ -937,7 +942,7 @@       , fsep $ pwords "(hint: overloaded pattern synonyms must be equal up to variable and constructor names)"       ]       where-        (x, _) = NonEmpty.head defs+        (x, _) = List1.head defs         prDef (x, (xs, p)) = prettyA (A.PatternSynDef x (map (fmap BindName) xs) p) <?> ("at" <+> pretty r)           where r = nameBindingSite $ qnameName x @@ -1005,14 +1010,14 @@                sortBy (compare `on` prettyShow . notaName . sectNotation) $                filter (not . closedWithoutHoles) sects))       where-      trimLeft  = dropWhile isNormalHole-      trimRight = dropWhileEnd isNormalHole+      trimLeft  = dropWhile isAHole+      trimRight = dropWhileEnd isAHole        closedWithoutHoles sect =         sectKind sect == NonfixNotation           &&-        null [ () | NormalHole {} <- trimLeft $ trimRight $-                                       notation (sectNotation sect) ]+        null [ () | HolePart{} <- trimLeft $ trimRight $+                                    notation (sectNotation sect) ]        prettyName n = Boxes.text $         P.render (P.pretty n) ++@@ -1261,7 +1266,7 @@     (d1, d2, d) <- prettyInEqual t1 t2     fsep $ return d1 : ncmp : return d2 : return d : [] -instance PrettyUnequal Type where+instance PrettyUnequal I.Type where   prettyUnequal t1 ncmp t2 = prettyUnequal (unEl t1) ncmp (unEl t2)  instance PrettyTCM SplitError where@@ -1328,7 +1333,7 @@       pwords "Case to handle:") $$ nest 2 (vcat $ [display cl])                                 $$ ((pure msg <+> enterClosure t displayAbs) <> ".")         where-        displayAbs :: Abs Type -> m Doc+        displayAbs :: Abs I.Type -> m Doc         displayAbs (Abs x t) = addContext x $ prettyTCM t         displayAbs (NoAbs x t) = prettyTCM t         display (tel, ps) = prettyTCM $ NamedClause f True $@@ -1379,6 +1384,84 @@       pwords "modality"  ++explainWhyInScope :: forall m. MonadPretty m => WhyInScopeData -> m Doc+explainWhyInScope (WhyInScopeData y _ Nothing [] []) = text (prettyShow  y ++ " is not in scope.")+explainWhyInScope (WhyInScopeData y _ v xs ms) = vcat+  [ text (prettyShow y ++ " is in scope as")+  , nest 2 $ vcat [variable v xs, modules ms]+  ]+  where+    -- variable :: Maybe _ -> [_] -> m Doc+    variable Nothing vs = names vs+    variable (Just x) vs+      | null vs   = asVar+      | otherwise = vcat+         [ sep [ asVar, nest 2 $ shadowing x]+         , nest 2 $ names vs+         ]+      where+        asVar :: m Doc+        asVar = do+          "* a variable bound at" <+> prettyTCM (nameBindingSite $ localVar x)+        shadowing :: LocalVar -> m Doc+        shadowing (LocalVar _ _ [])    = "shadowing"+        shadowing _ = "in conflict with"+    names   = vcat . map pName+    modules = vcat . map pMod++    pKind = \case+      ConName                  -> "constructor"+      CoConName                -> "coinductive constructor"+      FldName                  -> "record field"+      PatternSynName           -> "pattern synonym"+      GeneralizeName           -> "generalizable variable"+      DisallowedGeneralizeName -> "generalizable variable from let open"+      MacroName                -> "macro name"+      QuotableName             -> "quotable name"+      -- previously DefName:+      DataName                 -> "data type"+      RecName                  -> "record type"+      AxiomName                -> "postulate"+      PrimName                 -> "primitive function"+      FunName                  -> "defined name"+      OtherDefName             -> "defined name"++    pName :: AbstractName -> m Doc+    pName a = sep+      [ "* a"+        <+> pKind (anameKind a)+        <+> text (prettyShow $ anameName a)+      , nest 2 $ "brought into scope by"+      ] $$+      nest 2 (pWhy (nameBindingSite $ qnameName $ anameName a) (anameLineage a))+    pMod :: AbstractModule -> m Doc+    pMod  a = sep+      [ "* a module" <+> text (prettyShow $ amodName a)+      , nest 2 $ "brought into scope by"+      ] $$+      nest 2 (pWhy (nameBindingSite $ qnameName $ mnameToQName $ amodName a) (amodLineage a))++    pWhy :: Range -> WhyInScope -> m Doc+    pWhy r Defined = "- its definition at" <+> prettyTCM r+    pWhy r (Opened (C.QName x) w) | isNoName x = pWhy r w+    pWhy r (Opened m w) =+      "- the opening of"+      <+> prettyTCM m+      <+> "at"+      <+> prettyTCM (getRange m)+      $$+      pWhy r w+    pWhy r (Applied m w) =+      "- the application of"+      <+> prettyTCM m+      <+> "at"+      <+> prettyTCM (getRange m)+      $$+      pWhy r w+++ --------------------------------------------------------------------------- -- * Natural language ---------------------------------------------------------------------------@@ -1412,6 +1495,13 @@       Flat       -> "flat"       Continuous -> "continuous"       Squash     -> "squashed"++instance Verbalize Modality where+  verbalize mod | mod == defaultModality = "default"+  verbalize (Modality rel qnt coh) = intercalate "," $+    [ verbalize rel | rel /= defaultRelevance ] +++    [ verbalize qnt | qnt /= defaultQuantity ] +++    [ verbalize coh | coh /= defaultCohesion ]  -- | Indefinite article. data Indefinite a = Indefinite a
src/full/Agda/TypeChecking/Errors.hs-boot view
@@ -1,6 +1,7 @@ module Agda.TypeChecking.Errors where  import Agda.Syntax.Abstract.Name+import Agda.Syntax.Common  import Agda.TypeChecking.Monad.Base import {-# SOURCE #-} Agda.TypeChecking.Monad.Debug (MonadDebug)
src/full/Agda/TypeChecking/Forcing.hs view
@@ -63,6 +63,11 @@     isForced,     nextIsForced ) where +import Data.Bifunctor+import Data.DList (DList)+import qualified Data.DList as DL+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Monoid -- for (<>) in GHC 8.0.2  import Agda.Interaction.Options@@ -104,7 +109,10 @@           _        -> __IMPOSSIBLE__         n = size tel         xs :: [(Modality, Nat)]-        xs = forcedVariables vs+        xs = DL.toList $ forcedVariables vs+        xs' :: IntMap [Modality]+        xs' = IntMap.map DL.toList $ IntMap.fromListWith (<>) $+              map (\(m, i) -> (i, DL.singleton m)) xs         -- #2819: We can only mark an argument as forced if it appears in the         -- type with a relevance below (i.e. more relevant) than the one of the         -- constructor argument. Otherwise we can't actually get the value from@@ -114,8 +122,9 @@         isForced m i =                (hasQuantity0 m || noUserQuantity m)             && (getRelevance m /= Irrelevant)-            && any (\(m', j) -> i == j-            && m' `moreUsableModality` m) xs+            && case IntMap.lookup i xs' of+                 Nothing -> False+                 Just ms -> any (`moreUsableModality` m) ms         forcedArgs =           [ if isForced m i then Forced else NotForced           | (i, m) <- zip (downFrom n) $ map getModality (telToList tel)@@ -129,9 +138,11 @@  -- | Compute the pattern variables of a term or term-like thing. class ForcedVariables a where-  forcedVariables :: a -> [(Modality, Nat)]+  forcedVariables :: a -> DList (Modality, Nat) -  default forcedVariables :: (ForcedVariables b, Foldable t, a ~ t b) => a -> [(Modality, Nat)]+  default forcedVariables ::+    (ForcedVariables b, Foldable t, a ~ t b) =>+    a -> DList (Modality, Nat)   forcedVariables = foldMap forcedVariables  instance ForcedVariables a => ForcedVariables [a] where@@ -139,19 +150,20 @@ -- Note that the 'a' does not include the 'Arg' in 'Apply'. instance ForcedVariables a => ForcedVariables (Elim' a) where   forcedVariables (Apply x) = forcedVariables x-  forcedVariables IApply{}  = []  -- No forced variables in path applications-  forcedVariables Proj{}    = []+  forcedVariables IApply{}  = mempty  -- No forced variables in path applications+  forcedVariables Proj{}    = mempty  instance ForcedVariables a => ForcedVariables (Arg a) where-  forcedVariables x = [ (composeModality m m', i) | (m', i) <- forcedVariables (unArg x) ]+  forcedVariables x =+    fmap (first (composeModality m)) (forcedVariables (unArg x))     where m = getModality x  -- | Assumes that the term is in normal form. instance ForcedVariables Term where   forcedVariables = \case-    Var i [] -> [(unitModality, i)]+    Var i []   -> DL.singleton (unitModality, i)     Con _ _ vs -> forcedVariables vs-    _ -> []+    _          -> mempty  isForced :: IsForced -> Bool isForced Forced    = True
src/full/Agda/TypeChecking/Free.hs view
@@ -57,7 +57,7 @@     , flexRigOccurrenceIn     , closed     , MetaSet-    , insertMetaSet, foldrMetaSet+    , insertMetaSet, foldrMetaSet, metaSetToBlocker     ) where  import Prelude hiding (null)@@ -178,17 +178,17 @@ -- ** Flexible /rigid occurrence info for a single variable.  -- | Get the full occurrence information of a free variable.-flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe (FlexRig' ())+flexRigOccurrenceIn :: Free a => Nat -> a -> Maybe FlexRig flexRigOccurrenceIn = flexRigOccurrenceIn' IgnoreNot -flexRigOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe (FlexRig' ())+flexRigOccurrenceIn' :: Free a => IgnoreSorts -> Nat -> a -> Maybe FlexRig flexRigOccurrenceIn' ig x t = theSingleFlexRig $ runFree sg ig t   where   sg y = if x == y then oneSingleFlexRig else mempty  -- | "Collection" just keeping track of the occurrence of a single variable. --   'Nothing' means variable does not occur freely.-newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe (FlexRig' ()) }+newtype SingleFlexRig = SingleFlexRig { theSingleFlexRig :: Maybe FlexRig }  oneSingleFlexRig :: SingleFlexRig oneSingleFlexRig = SingleFlexRig $ Just $ oneFlexRig@@ -204,8 +204,8 @@   mempty = SingleFlexRig Nothing   mappend = (<>) -instance IsVarSet () SingleFlexRig where-  withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ () <$ varFlexRig o) . theSingleFlexRig+instance IsVarSet MetaSet SingleFlexRig where+  withVarOcc o = SingleFlexRig . fmap (composeFlexRig $ varFlexRig o) . theSingleFlexRig  -- ** Plain free occurrence.
src/full/Agda/TypeChecking/Free/Lazy.hs view
@@ -65,10 +65,11 @@  import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap-import Data.IntSet (IntSet)-import qualified Data.IntSet as IntSet+import Data.HashSet (HashSet)+import qualified Data.HashSet as HashSet import Data.Semigroup ( Semigroup, (<>) )-+import qualified Data.Set as Set+import Data.Set (Set)   import Agda.Syntax.Common@@ -87,18 +88,21 @@  -- | A set of meta variables.  Forms a monoid under union. -newtype MetaSet = MetaSet { theMetaSet :: IntSet }+newtype MetaSet = MetaSet { theMetaSet :: HashSet MetaId }   deriving (Eq, Show, Null, Semigroup, Monoid)  instance Singleton MetaId MetaSet where-  singleton = MetaSet . singleton . metaId+  singleton = MetaSet . singleton  insertMetaSet :: MetaId -> MetaSet -> MetaSet-insertMetaSet (MetaId m) (MetaSet ms) = MetaSet $ IntSet.insert m ms+insertMetaSet m (MetaSet ms) = MetaSet $ HashSet.insert m ms  foldrMetaSet :: (MetaId -> a -> a) -> a -> MetaSet -> a-foldrMetaSet f e ms = IntSet.foldr (f . MetaId) e $ theMetaSet ms+foldrMetaSet f e ms = HashSet.foldr f e $ theMetaSet ms +metaSetToBlocker :: MetaSet -> Blocker+metaSetToBlocker ms = unblockOnAny $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms+ --------------------------------------------------------------------------- -- * Flexible and rigid occurrences (semigroup) @@ -548,6 +552,7 @@       SSet a     -> freeVars' a       SizeUniv   -> mempty       LockUniv   -> mempty+      IntervalUniv -> mempty       PiSort a s1 s2 -> underFlexRig (Flexible mempty) (freeVars' $ unDom a) `mappend`                         underFlexRig WeaklyRigid (freeVars' (s1, s2))       FunSort s1 s2 -> freeVars' s1 `mappend` freeVars' s2
src/full/Agda/TypeChecking/Free/Precompute.hs view
@@ -80,6 +80,7 @@       SSet a     -> SSet <$> precomputeFreeVars a       SizeUniv   -> pure s       LockUniv   -> pure s+      IntervalUniv -> pure s       PiSort a s1 s2 -> PiSort <$> precomputeFreeVars a <*> precomputeFreeVars s1 <*> precomputeFreeVars s2       FunSort s1 s2 -> uncurry FunSort <$> precomputeFreeVars (s1, s2)       UnivSort s -> UnivSort <$> precomputeFreeVars s
src/full/Agda/TypeChecking/Free/Reduce.hs view
@@ -4,9 +4,12 @@ module Agda.TypeChecking.Free.Reduce   ( ForceNotFree   , forceNotFree+  , reallyFree   , IsFree(..)   ) where +import Prelude hiding (null)+ import Control.Monad.Reader import Control.Monad.State @@ -22,7 +25,9 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Free import Agda.TypeChecking.Free.Precompute+ import Agda.Utils.Monad+import Agda.Utils.Null  -- | A variable can either not occur (`NotFree`) or it does occur --   (`MaybeFree`).  In the latter case, the occurrence may disappear@@ -45,6 +50,35 @@   (a, mxs) <- runStateT (runReaderT (forceNotFreeR $ precomputeFreeVars_ a) mempty) mxs   return (mxs, a) +-- | Checks if the given term contains any free variables that are in+--   the given set of variables, possibly reducing the term in the+--   process.  Returns `Right Nothing` if there are such variables,+--   `Right (Just v')` if there are none (where v' is the possibly+--   reduced version of the given term) or `Left b` if the problem is+--   blocked on a meta.+reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a)+           => IntSet -> a -> m (Either Blocked_ (Maybe a))+reallyFree xs v = do+  (mxs , v') <- forceNotFree xs v+  case IntMap.foldr pickFree NotFree mxs of+    MaybeFree ms+      | null ms   -> return $ Right Nothing+      | otherwise -> return $ Left $ Blocked blocker ()+      where blocker = metaSetToBlocker ms+    NotFree -> return $ Right (Just v')++  where+    -- Check if any of the variables occur freely.+    -- Prefer occurrences that do not depend on any metas.+    pickFree :: IsFree -> IsFree -> IsFree+    pickFree f1@(MaybeFree ms1) f2+      | null ms1  = f1+    pickFree f1@(MaybeFree ms1) f2@(MaybeFree ms2)+      | null ms2  = f2+      | otherwise = f1+    pickFree f1@(MaybeFree ms1) NotFree = f1+    pickFree NotFree f2 = f2+ type MonadFreeRed m =   ( MonadReader MetaSet m   , MonadState (IntMap IsFree) m@@ -151,4 +185,5 @@     s@(Inf _ _)-> return s     s@SizeUniv -> return s     s@LockUniv -> return s+    s@IntervalUniv -> return s     s@DummyS{} -> return s
src/full/Agda/TypeChecking/Functions.hs view
@@ -38,9 +38,9 @@ etaExpandClause :: MonadTCM tcm => Clause -> tcm Clause etaExpandClause clause = liftTCM $ do   case clause of-    Clause _  _  ctel ps _           Nothing  _ _ _ _ _ -> return clause-    Clause _  _  ctel ps Nothing     (Just t) _ _ _ _ _ -> return clause-    Clause rl rf ctel ps (Just body) (Just t) catchall exact recursive unreachable ell -> do+    Clause _  _  ctel ps _           Nothing  _ _ _ _ _ _ -> return clause+    Clause _  _  ctel ps Nothing     (Just t) _ _ _ _ _ _ -> return clause+    Clause rl rf ctel ps (Just body) (Just t) catchall exact recursive unreachable ell wm -> do        -- Get the telescope to expand the clause with.       TelV tel0 t' <- addContext ctel $ telView $ unArg t@@ -62,7 +62,7 @@         , "  xs      = " <+> text (prettyShow xs)         , "  new tel = " <+> prettyTCM ctel'         ]-      return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall exact recursive unreachable ell+      return $ Clause rl rf ctel' ps' (Just body') (Just (t $> t')) catchall exact recursive unreachable ell wm   where     -- Get all initial lambdas of the body.     peekLambdas :: Term -> [Arg ArgName]
src/full/Agda/TypeChecking/Generalize.hs view
@@ -10,12 +10,12 @@ import Control.Monad import Control.Monad.Except -import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import Data.List (partition, sortBy) import Data.Monoid import Data.Function (on)@@ -46,14 +46,15 @@ import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor import Agda.Utils.Impossible-import Agda.Utils.List   (hasElem)+import Agda.Utils.Lens+import Agda.Utils.List (downFrom, hasElem) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Permutation import Agda.Utils.Pretty (prettyShow)-+import Agda.Utils.Tuple  -- | Generalize a telescope over a set of generalizable variables. generalizeTelescope :: Map QName Name -> (forall a. (Telescope -> TCM a) -> TCM a) -> ([Maybe Name] -> Telescope -> TCM a) -> TCM a@@ -128,7 +129,7 @@  -- | Create metas for the generalizable variables and run the type check action. createMetasAndTypeCheck ::-  Set QName -> TCM a -> TCM (a, Map MetaId QName, MetaStore)+  Set QName -> TCM a -> TCM (a, Map MetaId QName, LocalMetaStores) createMetasAndTypeCheck s typecheckAction = do   ((namedMetas, x), allmetas) <- metasCreatedBy $ do     (metamap, genvals) <- createGenValues s@@ -147,26 +148,42 @@   genRecMeta <- newTypeMeta (mkType 0)   addContext (defaultDom ("genTel" :: String, genRecMeta)) $ ret genRecMeta --- | Compute the generalized telescope from metas created when checking the type/telescope to be+-- | Compute the generalized telescope from metas created when checking the *thing* (type or telescope) to be --   generalized. Called in the context extended with the telescope record variable (whose type is --   the first argument). Returns the telescope of generalized variables and a substitution from --   this telescope to the current context.-computeGeneralization ::-  Type -> Map MetaId name -> MetaStore ->-  TCM (Telescope, [Maybe name], Substitution)+computeGeneralization+  :: Type+       -- ^ The metavariable to be instantiated with record type containing+       --   as fields the variables generalized in the *thing*.+  -> Map MetaId name+       -- ^ Metas created from an occurrence of a @variable@. (The original free variables.)+       --   E.g. if you have+       --   @+       --     variable  l : Level; A : Set l+       --     postulate f : A → A+       --   @+       --   then @A@ would be in this @Map@, but not @l@.+  -> LocalMetaStores+       -- ^ The metas created when type-checking the *thing*.+  -> TCM (Telescope, [Maybe name], Substitution)+       -- ^ The telescope together with binder name (left-to-right order),+       --   and substitution from this telescope to the current context. computeGeneralization genRecMeta nameMap allmetas = postponeInstanceConstraints $ do    reportSDoc "tc.generalize" 10 $ "computing generalization for type" <+> prettyTCM genRecMeta    -- Pair metas with their metaInfo-  mvs <- mapM ((\ x -> (x,) <$> lookupMeta x) . MetaId) $ IntMap.keys allmetas+  let mvs = MapS.assocs (openMetas allmetas) +++            MapS.assocs (solvedMetas allmetas)    -- Issue 4727: filter out metavariables that were created before the   -- current checkpoint, since they are too old to be generalized.   -- TODO: make metasCreatedBy smarter so it doesn't see pruned   -- versions of old metas as new metas.   cp <- viewTC eCurrentCheckpoint-  let isFreshMeta (x,mv) = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp+  let isFreshMeta :: MonadReduce m => (MetaId, MetaVariable) -> m Bool+      isFreshMeta (x,mv) = enterClosure mv $ \ _ -> isJust <$> checkpointSubstitution' cp   mvs <- filterM isFreshMeta mvs   cs <- (++) <$> useTC stAwakeConstraints              <*> useTC stSleepingConstraints@@ -208,7 +225,7 @@   cp <- viewTC eCurrentCheckpoint   let canGeneralize x | isConstrained x = return False       canGeneralize x = do-          mv   <- lookupMeta x+          mv   <- lookupLocalMeta x           msub <- enterClosure mv $ \ _ ->                     checkpointSubstitution' cp           let sameContext =@@ -223,10 +240,10 @@                   (Just IdS, Perm m xs)        -> xs == [0 .. m - 1]                   (Just (Wk n IdS), Perm m xs) -> xs == [0 .. m - n - 1]                   _                            -> False-          unless sameContext $ do+          unless sameContext $ reportSDoc "tc.generalize" 20 $ do             ty <- getMetaType x             let Perm m xs = mvPermutation mv-            reportSDoc "tc.generalize" 20 $ vcat+            vcat               [ text "Don't know how to generalize over"               , nest 2 $ prettyTCM x <+> text ":" <+> prettyTCM ty               , text "in context"@@ -236,15 +253,18 @@           return sameContext   inherited <- fmap Set.unions $ forM generalizableClosed $ \ (x, mv) ->     case mvInstantiation mv of-      InstV _ v -> do+      InstV inst -> do         parentName <- getMetaNameSuggestion x-        metas <- filterM canGeneralize . Set.toList . allMetas Set.singleton =<< instantiateFull v+        metas <- filterM canGeneralize . Set.toList .+                 allMetas Set.singleton =<<+                 instantiateFull (instBody inst)         let suggestNames i [] = return ()             suggestNames i (m : ms) = do               -- #4291: Override existing meta name suggestion. If we solved the parent with a new               --        meta use the parent name for that, otherwise suffix with a number.-              let suf | null ms && i == 1, MetaV{} <- v = ""-                      | otherwise                       = "." ++ show i+              let suf | null ms && i == 1,+                        MetaV{} <- instBody inst = ""+                      | otherwise                = "." ++ show i               setMetaNameSuggestion m (parentName ++ suf)               suggestNames (i + 1) ms         unless (null metas) $@@ -304,7 +324,7 @@   teleTypes <- do     args <- getContextArgs     fmap concat $ forM sortedMetas $ \ m -> do-      mv   <- lookupMeta m+      mv <- lookupLocalMeta m       let info =             hideOrKeepInstance $             getArgInfo $ miGeneralizable $ mvInfo mv@@ -320,7 +340,9 @@   -- Now we need to prune the unsolved metas to make sure they respect the new   -- dependencies (#3672). Also update interaction points to point to pruned metas.   let inscope (ii, InteractionPoint{ipMeta = Just x})-        | IntMap.member (metaId x) allmetas = Just (x, ii)+        | MapS.member x (openMetas allmetas) ||+          MapS.member x (solvedMetas allmetas) =+          Just (x, ii)       inscope _ = Nothing   ips <- Map.fromDistinctAscList . mapMaybe inscope . fst . BiMap.toDistinctAscendingLists <$> useTC stInteractionPoints   pruneUnsolvedMetas genRecName genRecCon genTel genRecFields ips shouldGeneralize allSortedMetas@@ -332,6 +354,15 @@   -- value packing up the generalized variables for the genTel variable.   let sub = unpackSub genRecCon (map (argInfo . fst) teleTypes) (length teleTypes) +  -- Instantiate all fresh meta-variables to get rid of+  -- __DUMMY_TERM__.+  genTel <- flip instantiateWhen genTel $ \m -> do+    mv <- lookupMeta m+    case mv of+      Nothing         -> __IMPOSSIBLE__+      Just Left{}     -> return False+      Just (Right mv) -> isFreshMeta (m, mv)+   return (genTel, telNames, sub)  -- | Prune unsolved metas (#3672). The input includes also the generalized metas and is sorted in@@ -380,7 +411,7 @@     -- on any variables introduced after the genRec. See test/Fail/Issue3672b.agda for a test case.     prePrune x = do       cp <- viewTC eCurrentCheckpoint-      mv <- lookupMeta x+      mv <- lookupLocalMeta x       (i, _A) <- enterClosure mv $ \ _ -> do         δ <- checkpointSubstitution cp         _A <- case mvJudgement mv of@@ -432,7 +463,7 @@      pruneMeta _Θ x = do       cp <- viewTC eCurrentCheckpoint-      mv <- lookupMeta x+      mv <- lookupLocalMeta x       -- The reason we are doing all this inside the closure of x is so that if x is an interaction       -- meta we get the right context for the pruned interaction meta.       enterClosure mv $ \ _ ->@@ -555,10 +586,15 @@     findGenRec :: MetaVariable -> TCM (Maybe Int)     findGenRec mv = do       cxt <- instantiateFull =<< getContext-      let notPruned = permute (takeP (length cxt) $ mvPermutation mv) $-               reverse $ zipWith const [0..] cxt-      case [ i | (i, Dom{unDom = (_, El _ (Def q _))}) <- zip [0..] cxt,-                 q == genRecName, i `elem` notPruned ] of+      let n         = length cxt+          notPruned = IntSet.fromList $+                      permute (takeP n $ mvPermutation mv) $+                      downFrom n+      case [ i+           | (i, Dom{unDom = (_, El _ (Def q _))}) <- zip [0..] cxt+           , q == genRecName+           , i `IntSet.member` notPruned+           ] of         []    -> return Nothing         _:_:_ -> __IMPOSSIBLE__         [i]   -> return (Just i)@@ -782,12 +818,13 @@                , funMutual       = Just []                , funAbstr        = ConcreteDef                , funDelayed      = NotDelayed-               , funProjection   = Just proj+               , funProjection   = Right proj                , funFlags        = Set.empty                , funTerminates   = Just True                , funExtLam       = Nothing                , funWith         = Nothing                , funCovering     = []+               , funIsKanOp      = Nothing                }   addConstant' (conName genRecCon) defaultArgInfo (conName genRecCon) __DUMMY_TYPE__ $ -- Filled in later     Constructor { conPars   = 0@@ -814,6 +851,7 @@            , recEtaEquality' = Inferred YesEta            , recPatternMatching = CopatternMatching            , recInduction    = Nothing+           , recTerminates   = Just True    -- not recursive            , recAbstr        = ConcreteDef            , recComp         = emptyCompKit            }@@ -849,7 +887,6 @@   reportSDoc "tc.generalize" 40 $ text "Final genRecCon type:" <+> inTopContext (prettyTCM conType)   setType (conName con) conType   -- Record telescope: Includes both parameters and fields.-  modifyGlobalDefinition name $ \ r ->-    r { theDef = (theDef r) { recTel = fullTel } }+  modifyGlobalDefinition name $ set (lensTheDef . lensRecord . lensRecTel) fullTel   where     setType q ty = modifyGlobalDefinition q $ \ d -> d { defType = ty }
src/full/Agda/TypeChecking/IApplyConfluence.hs view
@@ -4,10 +4,15 @@ import Prelude hiding (null, (!!))  -- do not use partial functions like !!  import Control.Monad-import Control.Arrow (first,second)+import Control.Monad.Except -import qualified Data.List as List-import qualified Data.Map as Map+import Data.Bifunctor (first, second)+import Data.DList (DList)+import Data.Foldable (toList)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet  import Agda.Syntax.Common import Agda.Syntax.Position@@ -31,9 +36,11 @@ import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Maybe+import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Impossible import Agda.Utils.Functor+import Control.Monad.Reader   checkIApplyConfluence_ :: QName -> TCM ()@@ -49,10 +56,11 @@   case theDef d of     Function{funClauses = cls', funCovering = cls} -> do       reportSDoc "tc.cover.iapply" 10 $ text "length cls =" <+> pretty (length cls)-      when (null cls && not (null $ concatMap (iApplyVars . namedClausePats) cls')) $+      when (null cls && any (not . null . iApplyVars . namedClausePats) cls') $         __IMPOSSIBLE__-      modifySignature $ updateDefinition f $ updateTheDef-        $ updateCovering (const [])+      unlessM (optKeepCoveringClauses <$> pragmaOptions) $+        modifySignature $ updateDefinition f $ updateTheDef+          $ updateCovering (const [])        traceCall (CheckFunDefCall (getRange f) f [] False) $         forM_ cls $ checkIApplyConfluence f@@ -68,9 +76,10 @@                 , namedClausePats = ps                 , clauseType = Just t                 , clauseBody = Just body-                } -> setCurrentRange (getRange f) $ do+                } -> setCurrentRange (clauseLHSRange cl) $ do           let             trhs = unArg t+          oldCall <- asksTC envCall           reportSDoc "tc.cover.iapply" 40 $ "tel =" <+> prettyTCM clTel           reportSDoc "tc.cover.iapply" 40 $ "ps =" <+> pretty ps           ps <- normaliseProjP ps@@ -83,14 +92,53 @@             reportSDoc "tc.iapply" 40 $ text "clause:" <+> pretty ps <+> "->" <+> pretty body             reportSDoc "tc.iapply" 20 $ "body =" <+> prettyTCM body -            addContext clTel $ equalTermOnFace phi trhs lhs body+            let+              k :: Substitution -> Comparison -> Type -> Term -> Term -> TCM ()+              k phi cmp ty u v = do+                u_e <- simplify u+                ty_e <- simplify ty+                let+                  -- Make note of the context (literally): we're+                  -- checking that this specific clause in f is+                  -- confluent with IApply reductions. That way if we+                  -- can tell the user what the endpoints are.+                  why = CheckIApplyConfluence+                    (getRange cl) f+                    (applySubst phi lhs)+                    u_e v ty +                  -- But if the conversion checking failed really early, we drop the extra+                  -- information. In that case, it's just noise.+                  maybeDropCall e@(TypeError x y err)+                    | UnequalTerms _ u' v' _ <- clValue err = do+                      u <- prettyTCM u_e+                      v <- prettyTCM =<< simplify v+                      enterClosure err $ \e' -> do+                        u' <- prettyTCM =<< simplify u'+                        v' <- prettyTCM =<< simplify v'+                        -- Specifically, we compare how the things are pretty-printed, to avoid+                        -- double-printing, rather than a more refined heuristic, since the+                        -- “failure case” here is *at worst* accidentally reminding the user of how+                        -- IApplyConfluence works.+                        if (u == u' && v == v')+                          then localTC (\e -> e { envCall = oldCall }) $ typeError e'+                          else throwError e+                  maybeDropCall x = throwError x++                -- Note: Any postponed constraint with this call *will* have the extra+                -- information. This is a feature: if the constraint is woken up later,+                -- then it's probably a good idea to remind the user of what's going on,+                -- instead of presenting a mysterious error.+                traceCall why (compareTerm cmp ty u v `catchError` maybeDropCall)++            addContext clTel $ compareTermOnFace' k CmpEq phi trhs lhs body+             case body of               MetaV m es_m' | Just es_m <- allApplyElims es_m' ->                 caseMaybeM (isInteractionMeta m) (return ()) $ \ ii -> do                 cs' <- do                   reportSDoc "tc.iapply.ip" 20 $ "clTel =" <+> prettyTCM clTel-                  mv <- lookupMeta m+                  mv <- lookupLocalMeta m                   enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢                   ty <- getMetaType m                   mTel <- getContextTelescope@@ -110,7 +158,7 @@                    addContext clTel $ do -- mTel.clTel ⊢                     () <- reportSDoc "tc.iapply.ip" 40 $ "mTel.clTel =" <+> (prettyTCM =<< getContextTelescope)-                    forallFaceMaps phi __IMPOSSIBLE__ $ \ alpha -> do+                    forallFaceMaps phi __IMPOSSIBLE__ $ \_ alpha -> do                     -- mTel.clTel' ⊢                     -- mTel.clTel  ⊢ alpha : mTel.clTel'                     reportSDoc "tc.iapply.ip" 40 $ "mTel.clTel' =" <+> (prettyTCM =<< getContextTelescope)@@ -164,7 +212,6 @@                 modifyInteractionPoints (BiMap.adjust f ii)               _ -> return () - -- | current context is of the form Γ.Δ unifyElims :: Args               -- ^ variables to keep   Γ ⊢ x_n .. x_0 : Γ@@ -177,39 +224,54 @@               -- Γ.Δ', [(x = u)] ⊢ id_g = ts[σ] : Γ            -> TCM a unifyElims vs ts k = do-                      dom <- getContext-                      let (binds' , eqs' ) = candidate (map unArg vs) (map unArg ts)-                          (binds'', eqss') =-                            unzip $ map (\ (j,t:ts) -> ((j,t),map (,var j) ts)) $ Map.toList $ Map.fromListWith (++) (map (second (:[])) binds')-                          cod   = codomain s (map fst binds) dom-                          binds = map (second (raise (size cod - size vs))) binds''-                          eqs   = map (first  (raise $ size dom - size vs)) $ eqs' ++ concat eqss'-                          s     = bindS binds-                      updateContext s (codomain s (map fst binds)) $ do-                      k s (s `applySubst` eqs)+  dom <- getContext+  let (binds' , eqs' ) = candidate (map unArg vs) (map unArg ts)+      (binds'', eqss') =+        unzip $+        map (\(j, tts) -> case toList tts of+                t : ts -> ((j, t), map (, var j) ts)+                []     -> __IMPOSSIBLE__) $+        IntMap.toList $ IntMap.fromListWith (<>) binds'+      cod'  = codomain s (IntSet.fromList $ map fst binds'')+      cod   = cod' dom+      svs   = size vs+      binds = IntMap.fromList $+              map (second (raise (size cod - svs))) binds''+      eqs   = map (first  (raise (size dom - svs))) $+              eqs' ++ concat eqss'+      s     = bindS binds+  updateContext s cod' $ k s (s `applySubst` eqs)   where-    candidate :: [Term] -> [Term] -> ([(Nat,Term)],[(Term,Term)])-    candidate (i:is) (Var j []:ts) = first ((j,i):) (candidate is ts)-    candidate (i:is) (t:ts)        = second ((i,t):) (candidate is ts)-    candidate [] [] = ([],[])-    candidate _ _ = __IMPOSSIBLE__---    bindS binds = parallelS (for [0..maximum (-1:map fst binds)] $ (\ i -> fromMaybe (deBruijnVar i) (List.lookup i binds)))+  candidate :: [Term] -> [Term] -> ([(Nat, DList Term)], [(Term, Term)])+  candidate is ts = case (is, ts) of+    (i : is, Var j [] : ts) -> first ((j, singleton i) :) $+                               candidate is ts+    (i : is, t : ts)        -> second ((i, t) :) $+                               candidate is ts+    ([],     [])            -> ([], [])+    _                       -> __IMPOSSIBLE__ -    codomain :: Substitution-             -> [Nat]  -- support-             -> Context -> Context-    codomain s vs cxt = map snd $ filter (\ (i,c) -> i `List.notElem` vs) $ zip [0..] cxt'-     where-      cxt' = zipWith (\ n d -> dropS n s `applySubst` d) [1..] cxt+  bindS binds = parallelS $+    case IntMap.lookupMax binds of+      Nothing       -> []+      Just (max, _) -> for [0 .. max] $ \i ->+        fromMaybe (deBruijnVar i) (IntMap.lookup i binds) +  codomain+    :: Substitution+    -> IntSet  -- Support.+    -> Context -> Context+  codomain s vs =+    mapMaybe (\(i, c) -> if i `IntSet.member` vs+                         then Nothing+                         else Just c) .+    zipWith (\i c -> (i, dropS (i + 1) s `applySubst` c)) [0..]  -- | Like @unifyElims@ but @Γ@ is from the the meta's @MetaInfo@ and -- the context extension @Δ@ is taken from the @Closure@. unifyElimsMeta :: MetaId -> Args -> Closure Constraint -> ([(Term,Term)] -> Constraint -> TCM a) -> TCM a unifyElimsMeta m es_m cl k = ifM (isNothing . optCubical <$> pragmaOptions) (enterClosure cl $ k []) $ do-                  mv <- lookupMeta m+                  mv <- lookupLocalMeta m                   enterClosure (getMetaInfo mv) $ \ _ -> do -- mTel ⊢                   ty <- metaType m                   mTel0 <- getContextTelescope
src/full/Agda/TypeChecking/Injectivity.hs view
@@ -41,6 +41,7 @@ module Agda.TypeChecking.Injectivity where  import Control.Applicative+import Control.Monad import Control.Monad.Except import Control.Monad.Fail import Control.Monad.State@@ -52,15 +53,20 @@ import Data.Maybe import Data.Traversable hiding (for) import Data.Semigroup ((<>))+import Data.Foldable (fold)  import qualified Agda.Syntax.Abstract.Name as A import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern +import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Irrelevance (isIrrelevantOrPropM) import Agda.TypeChecking.Monad import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope.Path+import Agda.TypeChecking.Primitive.Base+import Agda.TypeChecking.Primitive.Cubical import Agda.TypeChecking.Reduce import {-# SOURCE #-} Agda.TypeChecking.MetaVars import {-# SOURCE #-} Agda.TypeChecking.Conversion@@ -68,6 +74,8 @@ import Agda.TypeChecking.Polarity import Agda.TypeChecking.Warnings +import Agda.Interaction.Options+ import Agda.Utils.Either import Agda.Utils.Functor import Agda.Utils.List@@ -75,6 +83,7 @@ import Agda.Utils.Monad import Agda.Utils.Permutation import Agda.Utils.Pretty ( prettyShow )+import qualified Agda.Utils.ProfileOptions as Profile  import Agda.Utils.Impossible @@ -110,7 +119,10 @@         Constructor{} -> __IMPOSSIBLE__         AbstractDefn{}-> __IMPOSSIBLE__     -- Andreas, 2019-07-10, issue #3900: canonicalName needs ignoreAbstractMode-    Con c _ _ -> ignoreAbstractMode $ Just . ConsHead <$> canonicalName (conName c)+    Con c _ _ -> ignoreAbstractMode $ do+                 q <- canonicalName (conName c)+                 ifM (isPathCons q) (return Nothing) $+                     {- else -}     return $ Just $ ConsHead q     Sort _  -> return (Just SortHead)     Pi _ _  -> return (Just PiHead)     Var i [] -> return (Just $ VarHead i) -- Only naked variables. Otherwise substituting a neutral term is not guaranteed to stay neutral.@@ -122,8 +134,28 @@     DontCare{} -> return Nothing     Dummy s _ -> __IMPOSSIBLE_VERBOSE__ s +-- | Is this a matchable definition, or constructor, which reduces based+-- on interval substitutions?+isUnstableDef :: PureTCM m => QName -> m Bool+isUnstableDef qn = do+  defn <- getConstInfo qn+  prims <- traverse getPrimitiveName'+    [ builtinHComp+    , builtinComp+    , builtinTrans+    , builtinGlue+    , builtin_glue+    , builtin_glueU ]+  case theDef defn of+    _ | any (Just qn ==) prims -> pure True+    Function{funIsKanOp = Just _} -> pure True+    _ -> pure False++ -- | Do a full whnf and treat neutral terms as rigid. Used on the arguments to---   an injective functions and to the right-hand side.+--   an injective functions and to the right-hand side. Only returns+--   heads which are stable under interval substitution, i.e. NOT path+--   constructors or generated hcomp/transp! headSymbol'   :: (PureTCM m, MonadError TCErr m)   => Term -> m (Maybe TermHead)@@ -132,8 +164,15 @@   case v of     Blocked{} -> return Nothing     NotBlocked _ v -> case v of-      Def g _    -> return $ Just $ ConsHead g-      Con c _ _  -> return $ Just $ ConsHead $ conName c+      Def g _    ->+        ifM (isUnstableDef g)+          (pure Nothing)+          (pure . Just $ ConsHead g)+      Con c _ _  -> do+        q <- canonicalName (conName c)+        ifM (isPathCons q)+          (pure Nothing)+          (return $ Just $ ConsHead q)       Var i _    -> return $ Just (VarHead i)       Sort _     -> return $ Just SortHead       Pi _ _     -> return $ Just PiHead@@ -188,13 +227,23 @@       varToArg _ h           = return h    -- We don't need to consider absurd clauses-  let computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = do+  let computeHead c | hasDefP (namedClausePats c) = return []+      -- hasDefP clauses are skipped, these matter only for --cubical, in which case the function will behave as NotInjective.+      computeHead c@Clause{ clauseBody = Just body , clauseType = Just tbody } = addContext (clauseTel c) $ do         maybeIrr <- fromRight (const True) <.> runBlocked $ isIrrelevantOrPropM tbody+        -- We treat ordinary clauses with IApply copatterns as *immediately*+        -- failing the injectivity check. Consider e.g.+        --   foo x = T+        --   foo (y i) = Glue U λ { (i = i0) → T , _ ; (i = i1) → T , _ }+        -- seeing foo α = Glue ... and inverting it to α = y β loses solutions. E.g. if we+        -- later had some other α = x, now we're screwed, x ≠ y β. But if we had postponed+        -- originally we'd just compare T = Glue ... which has a chance of going through.+        let ivars = iApplyVars (namedClausePats c)+        guard (null ivars)         h <- if maybeIrr then return UnknownHead else           varToArg c =<< do             lift $ fromMaybe UnknownHead <$> do-              addContext (clauseTel c) $-                headSymbol body+              headSymbol body         return [Map.singleton h [c]]       computeHead _ = return [] @@ -211,7 +260,6 @@       case uc of         [c] -> prettyTCM $ map namedArg $ namedClausePats c         _   -> "(multiple clauses)"-   return $ Inverse hdMap  -- | If a clause is over-applied we can't trust the head (Issue 2944). For@@ -272,9 +320,10 @@ functionInverse = \case   Def f es -> do     inv <- defInverse <$> getConstInfo f+    cubical <- optCubical <$> pragmaOptions     case inv of       NotInjective -> return NoInv-      Inverse m    -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m)+      Inverse m -> maybe NoInv (Inv f es) <$> (traverse (checkOverapplication es) =<< instantiateVarHeads f es m)         -- NB: Invertible functions are never classified as         --     projection-like, so this is fine, we are not         --     missing parameters.  (Andreas, 2013-11-01)@@ -302,6 +351,7 @@       reportSDoc "tc.inj.use" 30 $ fsep $         pwords "useInjectivity on" ++         [ prettyTCM blk, prettyTCM cmp, prettyTCM neu, prettyTCM ty]+      whenProfile Profile.Conversion $ tick "compare by reduction: injectivity"       let canReduceToSelf = Map.member (ConsHead f) hdMap || Map.member UnknownHead hdMap       case neu of         -- f us == f vs  <=>  us == vs@@ -319,6 +369,7 @@           fs  <- getForcedArgs f           pol <- getPolarity' cmp f           reportSDoc "tc.inj.invert.success" 20 $ hsep ["Successful spine comparison of", prettyTCM f]+          whenProfile Profile.Conversion $ tick "compare by reduction: injectivity successful"           app (compareElims pol fs fTy (Def f [])) blkArgs neuArgs          -- f us == c vs
src/full/Agda/TypeChecking/InstanceArguments.hs view
@@ -5,6 +5,7 @@   , isInstanceConstraint   , shouldPostponeInstanceSearch   , postponeInstanceConstraints+  , getInstanceCandidates   ) where  import Control.Monad        ( forM )@@ -13,6 +14,7 @@  import qualified Data.IntMap as IntMap import qualified Data.Map as Map+import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.List as List import Data.Bifunctor@@ -169,7 +171,7 @@               rel = getRelevance $ defArgInfo def           let v = case theDef def of                -- drop parameters if it's a projection function...-               Function{ funProjection = Just p } -> projDropParsApply p ProjSystem rel args+               Function{ funProjection = Right p } -> projDropParsApply p ProjSystem rel args                -- Andreas, 2014-08-19: constructors cannot be declared as                -- instances (at least as of now).                -- I do not understand why the Constructor case is not impossible.@@ -207,7 +209,7 @@ findInstance m Nothing = do   -- Andreas, 2015-02-07: New metas should be created with range of the   -- current instance meta, thus, we set the range.-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   setCurrentRange mv $ do     reportSLn "tc.instance" 20 $ "The type of the FindInstance constraint isn't known, trying to find it again."     t <- instantiate =<< getMetaTypeInContext m@@ -227,6 +229,19 @@ findInstance m (Just cands) =                          -- Note: if no blocking meta variable this will not unblock until the end of the mutual block   whenJustM (findInstance' m cands) $ (\ (cands, b) -> addConstraint b $ FindInstance m $ Just cands) +-- | Entry point for `tcGetInstances` primitive+getInstanceCandidates :: MetaId -> TCM (Either Blocker [Candidate])+getInstanceCandidates m = do+  mv <- lookupLocalMeta m+  setCurrentRange mv $ do+    t <- instantiate =<< getMetaTypeInContext m+    TelV tel t' <- telViewUpTo' (-1) notVisible t+    addContext tel $ initialInstanceCandidates t' >>= \case+      Left b -> return $ Left b+      Right cands -> checkCandidates m t' cands >>= \case+        Nothing -> return $ Right cands+        Just (_ , cands') -> return $ Right cands'+ -- | Result says whether we need to add constraint, and if so, the set of --   remaining candidates and an eventual blocking metavariable. findInstance' :: MetaId -> [Candidate] -> TCM (Maybe ([Candidate], Blocker))@@ -238,7 +253,7 @@     return $ Just (cands, neverUnblock)) $ billTo [Benchmark.Typing, Benchmark.InstanceSearch] $ do   -- Andreas, 2015-02-07: New metas should be created with range of the   -- current instance meta, thus, we set the range.-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   setCurrentRange mv $ do       reportSLn "tc.instance" 15 $         "findInstance 2: constraint: " ++ prettyShow m ++ "; candidates left: " ++ show (length cands)@@ -357,9 +372,12 @@ -- This is sufficient to reduce the list to a singleton should all be equal. dropSameCandidates :: MetaId -> [(Candidate, Term, a)] -> TCM [(Candidate, Term, a)] dropSameCandidates m cands0 = verboseBracket "tc.instance" 30 "dropSameCandidates" $ do-  metas <- getMetaStore-  -- Does `it` have any metas in the initial meta variable store?-  let freshMetas = getAny . allMetas (Any . (`IntMap.notMember` metas) . metaId)+  !nextMeta    <- nextLocalMeta+  isRemoteMeta <- isRemoteMeta+  -- Does "it" contain any fresh meta-variables?+  let freshMetas =+        getAny .+        allMetas (\m -> Any (not (isRemoteMeta m || m < nextMeta)))    -- Take overlappable candidates into account   let cands =@@ -372,7 +390,7 @@     , nest 2 $ vcat [ if freshMetas v then "(redacted)" else                       sep [ prettyTCM v ]                     | (_, v, _) <- cands ] ]-  rel <- getMetaRelevance <$> lookupMeta m+  rel <- getRelevance <$> lookupMetaModality m   case cands of     []            -> return cands     cvd : _ | isIrrelevant rel -> do@@ -450,7 +468,7 @@     checkCandidateForMeta m t (Candidate q term t' _) = checkDepth term t' $ do       -- Andreas, 2015-02-07: New metas should be created with range of the       -- current instance meta, thus, we set the range.-      mv <- lookupMeta m+      mv <- lookupLocalMeta m       setCurrentRange mv $ do         debugConstraints         verboseBracket "tc.instance" 20 ("checkCandidateForMeta " ++ prettyShow m) $@@ -540,16 +558,6 @@           handle err             | hardFailure err = return $ HellNo err             | otherwise       = No <$ debugTypeFail err--isInstanceConstraint :: Constraint -> Bool-isInstanceConstraint FindInstance{} = True-isInstanceConstraint _              = False--shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool-shouldPostponeInstanceSearch =-  and2M ((^. stConsideringInstance) <$> getTCState)-        (not . optOverlappingInstances <$> pragmaOptions)-  `or2M` ((^. stPostponeInstanceSearch) <$> getTCState)  nowConsideringInstance :: (ReadTCState m) => m a -> m a nowConsideringInstance = locallyTCState stConsideringInstance $ const True
src/full/Agda/TypeChecking/Irrelevance.hs view
@@ -83,6 +83,7 @@  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Concrete.Pretty  import Agda.TypeChecking.Monad import Agda.TypeChecking.Pretty@@ -93,6 +94,9 @@ import Agda.Utils.Lens import Agda.Utils.Maybe import Agda.Utils.Monad+import Agda.Utils.WithDefault+import qualified Agda.Utils.Null as Null+import Agda.Utils.WithDefault (collapseDefault)  -- | data 'Relevance' --   see "Agda.Syntax.Common".@@ -198,7 +202,7 @@ splittableCohesion :: (HasOptions m, LensCohesion a) => a -> m Bool splittableCohesion a = do   let c = getCohesion a-  pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do optFlatSplit <$> pragmaOptions)+  pure (usableCohesion c) `and2M` (pure (c /= Flat) `or2M` do collapseDefault . optFlatSplit <$> pragmaOptions)  -- | (Conditionally) wake up irrelevant variables and make them relevant. --   For instance,@@ -305,7 +309,7 @@     Sort s   -> usableRel rel s     Level l  -> return True     MetaV m vs -> do-      mrel <- getMetaRelevance <$> lookupMeta m+      mrel <- getRelevance <$> lookupMetaModality m       return (mrel `moreRelevant` rel) `and2M` usableRel rel vs     DontCare v -> usableRel rel v -- TODO: allow irrelevant things to be used in DontCare position?     Dummy{}  -> return True@@ -321,6 +325,7 @@     SSet l -> usableRel rel l     SizeUniv -> return True     LockUniv -> return True+    IntervalUniv -> return True     PiSort a s1 s2 -> usableRel rel (a,s1,s2)     FunSort s1 s2 -> usableRel rel (s1,s2)     UnivSort s -> usableRel rel s@@ -348,7 +353,7 @@   usableRel rel (Proj _ p) = do     prel <- relOfConst p     return $ prel `moreRelevant` rel-  usableRel rel (IApply x y v) = allM [x,y,v] $ usableRel rel+  usableRel rel (IApply x y v) = usableRel rel v  instance UsableRelevance a => UsableRelevance (Arg a) where   usableRel rel (Arg info u) =@@ -398,7 +403,15 @@         text ("has modality " ++ show fmod ++ ", which is a " ++               (if ok then "" else "NOT ") ++ "more usable modality than " ++ show mod)       return ok `and2M` usableMod mod vs-    Con c _ vs -> usableMod mod vs+    Con c o vs -> do+      cmod <- modalityOfConst (conName c)+      let ok = cmod `moreUsableModality` mod+      reportSDoc "tc.irr" 50 $+        "The constructor" <+> prettyTCM (Con c o []) <+>+        text ("has the modality " ++ show cmod ++ ", which is " +++              (if ok then "" else "NOT ") +++              "more usable than the modality " ++ show mod ++ ".")+      return ok `and2M` usableMod mod vs     Lit l    -> return True     Lam info v  -> usableModAbs info mod v     -- Even if Pi contains Type, here we check it as a constructor for terms in the universe.@@ -411,7 +424,7 @@     Sort s   -> usableMod mod s     Level l  -> return True     MetaV m vs -> do-      mmod <- getMetaModality <$> lookupMeta m+      mmod <- lookupMetaModality m       let ok = mmod `moreUsableModality` mod       reportSDoc "tc.irr" 50 $         "Metavariable" <+> prettyTCM (MetaV m []) <+>@@ -461,7 +474,7 @@   usableMod mod (Proj _ p) = do     pmod <- modalityOfConst p     return $ pmod `moreUsableModality` mod-  usableMod mod (IApply x y v) = allM [x,y,v] $ usableMod mod+  usableMod mod (IApply x y v) = usableMod mod v  instance UsableModality a => UsableModality (Arg a) where   usableMod mod (Arg info u) =@@ -471,16 +484,76 @@ instance UsableModality a => UsableModality (Dom a) where   usableMod mod Dom{unDom = u} = usableMod mod u -usableAtModality :: MonadConstraint TCM => Modality -> Term -> TCM ()-usableAtModality mod t = catchConstraint (UsableAtModality mod t) $ do-  res <- runExceptT $ usableMod mod t-  case res of-    Right b -> do-      unless b $-        typeError . GenericDocError =<< (prettyTCM t <+> "is not usable at the required modality" <+> prettyTCM mod)-    Left blocker -> patternViolation blocker+usableAtModality'+  :: MonadConstraint TCM+  -- Note: This weird-looking constraint is to trick GHC into accepting+  -- that an instance of MonadConstraint TCM will exist, even if we+  -- can't import the module in which it is defined.+  => Maybe Sort -> WhyCheckModality -> Modality -> Term -> TCM ()+usableAtModality' ms why mod t =+  catchConstraint (UsableAtModality why ms mod t) $ do+    whenM (maybe (pure True) isFibrant ms) $ do+      res <- runExceptT $ usableMod mod t+      case res of+        Right b -> unless b $+          typeError . GenericDocError =<< formatWhy+        Left blocker -> patternViolation blocker+  where+    formatWhy = do+      compatible <- collapseDefault . optCubicalCompatible <$> pragmaOptions+      cubical <- isJust . optCubical <$> pragmaOptions+      let+        context+          | cubical    = "in Cubical Agda,"+          | compatible = "to maintain compatibility with Cubical Agda,"+          | otherwise  = "when --without-K is enabled," +        explanation what+          | cubical || compatible =+            [ ""+            , fsep ( "Note:":pwords context+                  ++ pwords what ++ pwords "must be usable at the modality"+                  ++ pwords "in which the function was defined, since it will be"+                  ++ pwords "used for computing transports"+                  )+            , ""+            ]+          | otherwise = [] +      case why of+        IndexedClause ->+          vcat $+            ( fsep ( pwords "This clause has target type"+                  ++ [prettyTCM t]+                  ++ pwords "which is not usable at the required modality"+                  ++ [pure (attributesForModality mod) <> "."]+                   )+            : explanation "the target type")++        -- Arguments sometimes need to be transported too:+        IndexedClauseArg forced the_arg ->+          vcat $+            ( fsep (pwords "The argument" ++ [prettyTCM the_arg] ++ pwords "has type")+            : nest 2 (prettyTCM t)+            : fsep ( pwords "which is not usable at the required modality"+                  ++ [pure (attributesForModality mod) <> "."] )+            : explanation "this argument's type")++        -- Note: if a generated clause is modality-incorrect, that's a+        -- bug in the LHS modality check+        GeneratedClause ->+          __IMPOSSIBLE_VERBOSE__ . show =<<+                   prettyTCM t+              <+> "is not usable at the required modality"+              <+> pure (attributesForModality mod)+        _ -> prettyTCM t <+> "is not usable at the required modality"+         <+> pure (attributesForModality mod)+++usableAtModality :: MonadConstraint TCM => WhyCheckModality -> Modality -> Term -> TCM ()+usableAtModality = usableAtModality' Nothing++ -- * Propositions  -- | Is a type a proposition?  (Needs reduction.)@@ -513,6 +586,7 @@   SSet{}     -> False   SizeUniv{} -> False   LockUniv{} -> False+  IntervalUniv{} -> False   PiSort{}   -> False   FunSort{}  -> False   UnivSort{} -> False@@ -531,6 +605,7 @@   SSet{}     -> False   SizeUniv{} -> False   LockUniv{} -> True+  IntervalUniv{} -> True   PiSort{}   -> False   FunSort{}  -> False   UnivSort{} -> False
src/full/Agda/TypeChecking/Level.hs view
@@ -3,7 +3,6 @@  import Data.Maybe import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..)) import Data.Traversable (Traversable)  import Agda.Syntax.Common@@ -14,6 +13,7 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Reduce +import Agda.Utils.List1 ( List1, pattern (:|) ) import Agda.Utils.Maybe ( caseMaybeM, allJustM ) import Agda.Utils.Monad ( tryMaybe ) import Agda.Utils.Singleton@@ -31,10 +31,21 @@   , zeroName :: QName   } --- | Get the 'primLevel' as a 'Type'.-levelType :: (HasBuiltins m) => m Type-levelType = El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel+{-# SPECIALIZE levelType :: TCM Type #-}+-- | Get the 'primLevel' as a 'Type'.  Aborts if any of the level BUILTINs is undefined.+levelType :: (HasBuiltins m, MonadTCError m) => m Type+levelType = El (mkType 0) . lvlType <$> requireLevels+  -- Andreas, 2022-10-11, issue #6168+  -- It seems superfluous to require all level builtins here,+  -- but since we are in MonadTCError here, this is our chance to make sure+  -- that all level builtins are defined.+  -- Otherwise, we might run into an __IMPOSSIBLE__ later,+  -- e.g. if only BUILTIN LEVEL was defined by reallyUnLevelView requires all builtins. +-- | Get the 'primLevel' as a 'Type'.  Unsafe, crashes if the BUILTIN LEVEL is undefined.+levelType' :: (HasBuiltins m) => m Type+levelType' = El (mkType 0) . fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevel+ isLevelType :: PureTCM m => Type -> m Bool isLevelType a = reduce (unEl a) >>= \case   Def f [] -> do@@ -42,9 +53,6 @@     return $ f == lvl   _ -> return False -levelSucFunction :: TCM (Term -> Term)-levelSucFunction = apply1 <$> primLevelSuc- {-# SPECIALIZE builtinLevelKit :: TCM LevelKit #-} {-# SPECIALIZE builtinLevelKit :: ReduceM LevelKit #-} builtinLevelKit :: (HasBuiltins m) => m LevelKit@@ -64,9 +72,24 @@       , zeroName = z       } +{-# SPECIALIZE requireLevels :: TCM LevelKit #-} -- | Raises an error if no level kit is available.-requireLevels :: HasBuiltins m => m LevelKit-requireLevels = builtinLevelKit+requireLevels :: (HasBuiltins m, MonadTCError m) => m LevelKit+requireLevels = do+    level@(Def l []) <- getBuiltin builtinLevel+    zero@(Def z [])  <- getBuiltin builtinLevelZero+    suc@(Def s [])   <- getBuiltin builtinLevelSuc+    max@(Def m [])   <- getBuiltin builtinLevelMax+    return $ LevelKit+      { lvlType  = level+      , lvlSuc   = \ a -> suc `apply1` a+      , lvlMax   = \ a b -> max `applys` [a, b]+      , lvlZero  = zero+      , typeName = l+      , sucName  = s+      , maxName  = m+      , zeroName = z+      }  -- | Checks whether level kit is fully available. haveLevels :: HasBuiltins m => m Bool@@ -90,13 +113,7 @@ {-# SPECIALIZE reallyUnLevelView :: Level -> TCM Term #-} {-# SPECIALIZE reallyUnLevelView :: Level -> ReduceM Term #-} reallyUnLevelView :: (HasBuiltins m) => Level -> m Term-reallyUnLevelView nv = do-  suc <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelSuc-  zer <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinLevelZero-  case nv of-    Max n []       -> return $ unConstV zer (apply1 suc) n-    Max 0 [a]      -> return $ unPlusV (apply1 suc) a-    _              -> (`unlevelWithKit` nv) <$> builtinLevelKit+reallyUnLevelView nv = (`unlevelWithKit` nv) <$> builtinLevelKit  unlevelWithKit :: LevelKit -> Level -> Term unlevelWithKit LevelKit{ lvlZero = zer, lvlSuc = suc, lvlMax = max } = \case@@ -223,7 +240,7 @@     n = maximum $ 0 : [m | SingleClosed m <- ls]     as = [a | SinglePlus a <- ls] -levelMaxView :: Level' t -> NonEmpty (SingleLevel' t)+levelMaxView :: Level' t -> List1 (SingleLevel' t) levelMaxView (Max n [])     = singleton $ SingleClosed n levelMaxView (Max 0 (a:as)) = SinglePlus a :| map SinglePlus as levelMaxView (Max n as)     = SingleClosed n :| map SinglePlus as
src/full/Agda/TypeChecking/Level/Solve.hs view
@@ -5,7 +5,7 @@ import Control.Monad import Control.Monad.Except -import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as MapS import Data.Maybe  import Agda.Interaction.Options@@ -27,16 +27,17 @@ --   level, and instantiate them to the lowest level. defaultOpenLevelsToZero :: (PureTCM m, MonadMetaSolver m) => m a -> m a defaultOpenLevelsToZero f = ifNotM (optCumulativity <$> pragmaOptions) f $ do-  (result , newMetas) <- metasCreatedBy f-  defaultLevelsToZero newMetas+  (result, newMetas) <- metasCreatedBy f+  defaultLevelsToZero (openMetas newMetas)   return result -defaultLevelsToZero :: forall m. (PureTCM m, MonadMetaSolver m) => MetaStore -> m ()-defaultLevelsToZero xs = loop =<< openLevelMetas (map MetaId $ IntMap.keys xs)+defaultLevelsToZero ::+  forall m. (PureTCM m, MonadMetaSolver m) => LocalMetaStore -> m ()+defaultLevelsToZero xs = loop =<< openLevelMetas (MapS.keys xs)   where     loop :: [MetaId] -> m ()     loop xs = do-      let isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x+      let isOpen x = isOpenMeta <$> lookupMetaInstantiation x       xs <- filterM isOpen xs       allMetaTypes <- getOpenMetas >>= traverse metaType       let notInTypeOfMeta x = not $ mentionsMeta x allMetaTypes
src/full/Agda/TypeChecking/LevelConstraints.hs view
@@ -58,7 +58,7 @@         go _ [] = IdS         go y ren0@((y', x) : ren)           | y == y'   = Var x [] :# go (y + 1) ren-          | otherwise = Strengthen impossible $ go (y + 1) ren0+          | otherwise = strengthenS' impossible 1 $ go (y + 1) ren0  -- | Turn a level constraint into a list of inequalities between --   single levels, if possible.
src/full/Agda/TypeChecking/MetaVars.hs view
@@ -9,10 +9,10 @@ import Control.Monad.Except ( MonadError(..), ExceptT, runExceptT ) import Control.Monad.Trans  ( lift ) -import Data.Function-import qualified Data.IntMap as IntMap+import Data.Function (on) import qualified Data.IntSet as IntSet import qualified Data.List as List+import qualified Data.Map.Strict as MapS import qualified Data.Set as Set import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav@@ -58,7 +58,8 @@ import Agda.Utils.Size import Agda.Utils.Tuple import Agda.Utils.Permutation-import Agda.Utils.Pretty ( Pretty, prettyShow )+import Agda.Utils.Pretty (Pretty, prettyShow, render)+import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import qualified Agda.Utils.Graph.TopSort as Graph import Agda.Utils.VarSet (VarSet)@@ -90,16 +91,18 @@ findIdx :: Eq a => [a] -> a -> Maybe Int findIdx vs v = List.elemIndex v (reverse vs) +-- | Does the given local meta-variable have a twin meta-variable?+ hasTwinMeta :: MetaId -> TCM Bool hasTwinMeta x = do-    m <- lookupMeta x+    m <- lookupLocalMeta x     return $ isJust $ mvTwin m  -- | Check whether a meta variable is a place holder for a blocked term. isBlockedTerm :: MetaId -> TCM Bool isBlockedTerm x = do     reportSLn "tc.meta.blocked" 12 $ "is " ++ prettyShow x ++ " a blocked term? "-    i <- mvInstantiation <$> lookupMeta x+    i <- lookupMetaInstantiation x     let r = case i of             BlockedConst{}                 -> True             PostponedTypeCheckingProblem{} -> True@@ -107,12 +110,12 @@             Open{}                         -> False             OpenInstance{}                 -> False     reportSLn "tc.meta.blocked" 12 $-      if r then "  yes, because " ++ show i else "  no"+      if r then "  yes, because " ++ prettyShow i else "  no"     return r  isEtaExpandable :: [MetaKind] -> MetaId -> TCM Bool isEtaExpandable kinds x = do-    i <- mvInstantiation <$> lookupMeta x+    i <- lookupMetaInstantiation x     return $ case i of       Open{}                         -> True       OpenInstance{}                 -> Records `notElem` kinds@@ -143,13 +146,21 @@      -- verify (new) invariants     whenM (not <$> asksTC envAssignMetas) __IMPOSSIBLE__ -    verboseS "profile.metas" 10 $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-}-    modifyMetaStore $ ins x $ InstV tel $ killRange v+    whenProfile Profile.Metas $ liftTCM $ return () {-tickMax "max-open-metas" . (fromIntegral . size) =<< getOpenMetas-}+    updateMetaVarTCM x $ \ mv ->+      mv { mvInstantiation = InstV $ Instantiation+             { instTel = tel+             , instBody = v+             -- Andreas, 2022-04-28, issue #5875:+             -- Can't killRange the meta-solution, since this will destroy+             -- ranges of termination errors (and potentially other passes+             -- that run on internal syntax)!+             -- , instBody = killRange v+             }+         }     etaExpandListeners x     wakeupConstraints x     reportSLn "tc.meta.assign" 20 $ "completed assignment of " ++ prettyShow x-  where-    ins x i = IntMap.adjust (\ mv -> mv { mvInstantiation = i }) $ metaId x  -- * Creating meta variables. @@ -394,7 +405,7 @@     MetaVar       { mvInfo = MetaInfo{ miClosRange = Closure{ clEnv = TCEnv{ envContext = gamma }}}       , mvPermutation = p-      } <- fromMaybe __IMPOSSIBLE__ <$> lookupMeta' x+      } <- fromMaybe __IMPOSSIBLE__ <$> lookupLocalMeta' x     -- Get the current context Δ.     delta <- getContext     -- A bit hazardous:@@ -617,28 +628,8 @@ problemType (CheckLambda _ _ _ t     ) = t problemType (DoQuoteTerm _ _ t)        = t --- | Eta expand metavariables listening on the current meta.-etaExpandListeners :: MetaId -> TCM ()-etaExpandListeners m = do-  ls <- getMetaListeners m-  clearMetaListeners m  -- we don't really have to do this-  mapM_ wakeupListener ls---- | Wake up a meta listener and let it do its thing-wakeupListener :: Listener -> TCM ()-  -- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevance-wakeupListener (EtaExpand x)         = etaExpandMetaSafe x-wakeupListener (CheckConstraint _ c) = do-  reportSDoc "tc.meta.blocked" 20 $ "waking boxed constraint" <+> prettyTCM c-  modifyAwakeConstraints (c:)-  solveAwakeConstraints---- | Do safe eta-expansions for meta (@SingletonRecords,Levels@).-etaExpandMetaSafe :: (MonadMetaSolver m) => MetaId -> m ()-etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels]---- | Eta expand a metavariable, if it is of the specified kind.---   Don't do anything if the metavariable is a blocked term.+-- | Eta-expand a local meta-variable, if it is of the specified kind.+--   Don't do anything if the meta-variable is a blocked term. etaExpandMetaTCM :: [MetaKind] -> MetaId -> TCM () etaExpandMetaTCM kinds m = whenM ((not <$> isFrozen m) `and2M` asksTC envAssignMetas `and2M` isEtaExpandable kinds m) $ do   verboseBracket "tc.meta.eta" 20 ("etaExpandMeta " ++ prettyShow m) $ do@@ -652,7 +643,7 @@           reportSDoc "tc.meta.eta" 20 $ do             "we do not expand meta variable" <+> prettyTCM m <+>               text ("(requested was expansion of " ++ show kinds ++ ")")-    meta <- lookupMeta m+    meta <- lookupLocalMeta m     case mvJudgement meta of       IsSort{} -> dontExpand       HasType _ cmp a -> do@@ -676,7 +667,7 @@         -- they go unsolved: conversion will compare them at the         -- different cases for the domain, so it will not find the         -- solution for the whole meta.-        if any domFinite (flattenTel tel) then dontExpand else do+        if any domIsFinite (flattenTel tel) then dontExpand else do          -- Issue #3774: continue with the right context for b         addContext tel $ do@@ -742,7 +733,7 @@ assignWrapper dir x es v doAssign = do   ifNotM (asksTC envAssignMetas) dontAssign $ {- else -} do     reportSDoc "tc.meta.assign" 10 $ do-      "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ show dir) <+> prettyTCM v+      "term" <+> prettyTCM (MetaV x es) <+> text (":" ++ prettyShow dir) <+> prettyTCM v     nowSolvingConstraints doAssign `finally` solveAwakeConstraints    where dontAssign = do@@ -768,7 +759,7 @@ assign :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM () assign dir x args v target = addOrUnblocker (unblockOnMeta x) $ do -  mvar <- lookupMeta x  -- information associated with meta x+  mvar <- lookupLocalMeta x  -- information associated with meta x   let t = jMetaType $ mvJudgement mvar    -- Andreas, 2011-05-20 TODO!@@ -1057,7 +1048,7 @@           --   @           -- we need to check that @A <: A'@ (due to contravariance).           let sigma = parallelS $ reverse $ map unArg args-          hasSubtyping <- collapseDefault . optSubtyping <$> pragmaOptions+          hasSubtyping <- optCumulativity <$> pragmaOptions           when hasSubtyping $ forM_ ids $ \(i , u) -> do             -- @u@ is a (projected) variable, so we can infer its type             a  <- applySubst sigma <$> addContext tel' (infer u)@@ -1083,10 +1074,12 @@       let success = killResult `elem` [PrunedSomething,PrunedEverything]       reportSDoc "tc.meta.assign" 10 $         "pruning" <+> prettyTCM x <+> do text $ if success then "succeeded" else "failed"-      patternViolation (if success then alwaysUnblock  -- If pruning succeeded we want to retry right away-                                   else unblockOnAnyMetaIn $ MetaV x $ map Apply args)-                                        -- TODO: could be more precise: only unblock on metas-                                        --       applied to offending variables+      blocker <- if+        | success   -> return alwaysUnblock  -- If pruning succeeded we want to retry right away+        | otherwise -> unblockOnAnyMetaIn . MetaV x . map Apply <$> instantiateFull args+             -- TODO: could be more precise: only unblock on metas+             --       applied to offending variables+      patternViolation blocker  {- UNUSED -- | When faced with @_X us == D vs@ for an inert D we can solve this by@@ -1254,7 +1247,7 @@      -- Andreas, 2013-10-25 double check solution before assigning     whenM (optDoubleCheck  <$> pragmaOptions) $ do-      m <- lookupMeta x+      m <- lookupLocalMeta x       reportSDoc "tc.meta.check" 30 $ "double checking solution"       catchConstraint (CheckMetaInst x) $         addContext tel' $ checkSolutionForMeta x m v' a@@ -1281,18 +1274,19 @@ --   instantiated, add a constraint to check the instantiation later. checkMetaInst :: MetaId -> TCM () checkMetaInst x = do-  m <- lookupMeta x+  m <- lookupLocalMeta x   let postpone = addConstraint (unblockOnMeta x) $ CheckMetaInst x   case mvInstantiation m of     BlockedConst{} -> postpone     PostponedTypeCheckingProblem{} -> postpone     Open{} -> postpone     OpenInstance{} -> postpone-    InstV xs v -> do-      let n = size xs+    InstV inst -> do+      let n = size (instTel inst)           t = jMetaType $ mvJudgement m       (telv@(TelV tel a),bs) <- telViewUpToPathBoundary n t-      catchConstraint (CheckMetaInst x) $ addContext tel $ checkSolutionForMeta x m v a+      catchConstraint (CheckMetaInst x) $ addContext tel $+        checkSolutionForMeta x m (instBody inst) a  -- | Check that the instantiation of the metavariable with the given --   term is well-typed.@@ -1321,8 +1315,7 @@   reportSDoc "tc.meta.subtype" 30 $     "checking that subtype" <+> prettyTCM a <+>     "of" <+> prettyTCM b <+> "is actually equal."-  ((a, b), equal) <- SynEq.checkSyntacticEquality a b-  unless equal $ do+  SynEq.checkSyntacticEquality a b (\_ _ -> return ()) $ \a b -> do     cumulativity <- optCumulativity <$> pragmaOptions     abortIfBlocked (unEl b) >>= \case       Sort sb -> abortIfBlocked (unEl a) >>= \case@@ -1353,8 +1346,8 @@ -- @_Y args <= u@. subtypingForSizeLt   :: CompareDirection -- ^ @dir@-  -> MetaId           -- ^ The meta variable @x@.-  -> MetaVariable     -- ^ Its associated information @mvar <- lookupMeta x@.+  -> MetaId           -- ^ The local meta-variable @x@.+  -> MetaVariable     -- ^ Its associated information @mvar <- lookupLocalMeta x@.   -> Type             -- ^ Its type @t = jMetaType $ mvJudgement mvar@   -> Args             -- ^ Its arguments.   -> Term             -- ^ Its to-be-assigned value @v@, such that @x args `dir` v@.@@ -1571,86 +1564,88 @@ inverseSubst :: Args -> ExceptT InvertExcept TCM SubstCand inverseSubst args = map (mapFst unArg) <$> loop (zip args terms)   where-    loop  = foldM isVarOrIrrelevant []-    terms = map var (downFrom (size args))-    failure = do-      lift $ reportSDoc "tc.meta.assign" 15 $ vcat-        [ "not all arguments are variables: " <+> prettyTCM args-        , "  aborting assignment" ]-      throwError CantInvert-    neutralArg = throwError NeutralArg+  loop  = foldM isVarOrIrrelevant []+  terms = map var (downFrom (size args))+  failure = do+    lift $ reportSDoc "tc.meta.assign" 15 $ vcat+      [ "not all arguments are variables: " <+> prettyTCM args+      , "  aborting assignment" ]+    throwError CantInvert+  neutralArg = throwError NeutralArg -    isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res-    isVarOrIrrelevant vars (Arg info v, t) = do-      let irr | isIrrelevant info = True-              | DontCare{} <- v   = True-              | otherwise         = False-      case stripDontCare v of-        -- i := x-        Var i [] -> return $ (Arg info i, t) `cons` vars+  isVarOrIrrelevant :: Res -> (Arg Term, Term) -> ExceptT InvertExcept TCM Res+  isVarOrIrrelevant vars (Arg info v, t) = do+    let irr | isIrrelevant info = True+            | DontCare{} <- v   = True+            | otherwise         = False+    case stripDontCare v of+      -- i := x+      Var i [] -> return $ (Arg info i, t) `cons` vars -        -- π i := x  try to eta-expand projection π away!-        Var i es | Just qs <- mapM isProjElim es ->-          throwError $ ProjVar $ ProjectedVar i qs+      -- π i := x  try to eta-expand projection π away!+      Var i es | Just qs <- mapM isProjElim es ->+        throwError $ ProjVar $ ProjectedVar i qs -        -- (i, j) := x  becomes  [i := fst x, j := snd x]-        -- Andreas, 2013-09-17 but only if constructor is fully applied-        Con c ci es -> do-          let fallback-               | isIrrelevant info = return vars-               | otherwise                              = failure-          irrProj <- optIrrelevantProjections <$> pragmaOptions-          lift (isRecordConstructor $ conName c) >>= \case-            Just (_, r@Record{ recFields = fs })-              | YesEta <- recEtaEquality r  -- Andreas, 2019-11-10, issue #4185: only for eta-records-              , length fs == length es-              , hasQuantity0 info || all usableQuantity fs     -- Andreas, 2019-11-12/17, issue #4168b-              , irrProj || all isRelevant fs -> do-                let aux (Arg _ v) Dom{domInfo = info', unDom = f} = (Arg ai v,) $ t `applyE` [Proj ProjSystem f] where-                     ai = ArgInfo-                       { argInfoHiding   = min (getHiding info) (getHiding info')-                       , argInfoModality = Modality-                         { modRelevance  = max (getRelevance info) (getRelevance info')-                         , modQuantity   = max (getQuantity  info) (getQuantity  info')-                         , modCohesion   = max (getCohesion  info) (getCohesion  info')-                         }-                       , argInfoOrigin   = min (getOrigin info) (getOrigin info')-                       , argInfoFreeVariables = unknownFreeVariables-                       , argInfoAnnotation    = argInfoAnnotation info'-                       }-                    vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es-                res <- loop $ zipWith aux vs fs-                return $ res `append` vars-              | otherwise -> fallback-            _ -> fallback+      -- (i, j) := x  becomes  [i := fst x, j := snd x]+      -- Andreas, 2013-09-17 but only if constructor is fully applied+      Con c ci es -> do+        let fallback+             | isIrrelevant info = return vars+             | otherwise                              = failure+        irrProj <- optIrrelevantProjections <$> pragmaOptions+        lift (isRecordConstructor $ conName c) >>= \case+          Just (_, r@Record{ recFields = fs })+            | YesEta <- recEtaEquality r  -- Andreas, 2019-11-10, issue #4185: only for eta-records+            , length fs == length es+            , hasQuantity0 info || all usableQuantity fs     -- Andreas, 2019-11-12/17, issue #4168b+            , irrProj || all isRelevant fs -> do+              let aux (Arg _ v) Dom{domInfo = info', unDom = f} =+                    (Arg ai v,) $ t `applyE` [Proj ProjSystem f]+                    where+                    ai = ArgInfo+                      { argInfoHiding   = min (getHiding info) (getHiding info')+                      , argInfoModality = Modality+                        { modRelevance  = max (getRelevance info) (getRelevance info')+                        , modQuantity   = max (getQuantity  info) (getQuantity  info')+                        , modCohesion   = max (getCohesion  info) (getCohesion  info')+                        }+                      , argInfoOrigin   = min (getOrigin info) (getOrigin info')+                      , argInfoFreeVariables = unknownFreeVariables+                      , argInfoAnnotation    = argInfoAnnotation info'+                      }+                  vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es+              res <- loop $ zipWith aux vs fs+              return $ res `append` vars+            | otherwise -> fallback+          _ -> fallback -        -- An irrelevant argument which is not an irrefutable pattern is dropped-        _ | irr -> return vars+      -- An irrelevant argument which is not an irrefutable pattern is dropped+      _ | irr -> return vars -        -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure-        -- from those that can only put somewhere as a whole ==> neutralArg-        Var{}      -> neutralArg-        Def{}      -> neutralArg  -- Note that this Def{} is in normal form and might be prunable.-        Lam{}      -> failure-        Lit{}      -> failure-        MetaV{}    -> failure-        Pi{}       -> neutralArg-        Sort{}     -> neutralArg-        Level{}    -> neutralArg-        DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare-        Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s+      -- Distinguish args that can be eliminated (Con,Lit,Lam,unsure) ==> failure+      -- from those that can only put somewhere as a whole ==> neutralArg+      Var{}      -> neutralArg+      Def{}      -> neutralArg  -- Note that this Def{} is in normal form and might be prunable.+      Lam{}      -> failure+      Lit{}      -> failure+      MetaV{}    -> failure+      Pi{}       -> neutralArg+      Sort{}     -> neutralArg+      Level{}    -> neutralArg+      DontCare{} -> __IMPOSSIBLE__ -- Ruled out by stripDontCare+      Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s -    -- managing an assoc list where duplicate indizes cannot be irrelevant vars-    append :: Res -> Res -> Res-    append res vars = foldr cons vars res+  -- managing an assoc list where duplicate indizes cannot be irrelevant vars+  append :: Res -> Res -> Res+  append res vars = foldr cons vars res -    -- adding an irrelevant entry only if not present-    cons :: (Arg Nat, Term) -> Res -> Res-    cons a@(Arg ai i, t) vars-      | isIrrelevant ai = applyUnless (any ((i==) . unArg . fst) vars) (a :) vars-      | otherwise       = a :  -- adding a relevant entry-          -- filter out duplicate irrelevants-          filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars+  -- adding an irrelevant entry only if not present+  cons :: (Arg Nat, Term) -> Res -> Res+  cons a@(Arg ai i, t) vars+    | isIrrelevant ai = applyUnless (any ((i==) . unArg . fst) vars) (a :) vars+    | otherwise       = a :  -- adding a relevant entry+        -- filter out duplicate irrelevants+        filter (not . (\ a@(Arg info j, t) -> isIrrelevant info && i == j)) vars   -- | Turn open metas into postulates.@@ -1666,35 +1661,35 @@   m <- asksTC envCurrentModule    -- Go through all open metas.-  ms <- IntMap.assocs <$> useTC stMetaStore+  ms <- MapS.assocs <$> useTC stOpenMetaStore   forM_ ms $ \ (x, mv) -> do-    when (isOpenMeta $ mvInstantiation mv) $ do-      let t = dummyTypeToOmega $ jMetaType $ mvJudgement mv+    let t = dummyTypeToOmega $ jMetaType $ mvJudgement mv -      -- Create a name for the new postulate.-      let r = clValue $ miClosRange $ mvInfo mv-      -- s <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op-      let s = "unsolved#meta." ++ prettyShow x-      n <- freshName r s-      let q = A.QName m n+    -- Create a name for the new postulate.+    let r = clValue $ miClosRange $ mvInfo mv+    s' <- render <$> prettyTCM x -- Using _ is a bad idea, as it prints as prefix op+    let s = "unsolved#meta." ++ filter (/= '_') s'+    n <- freshName r s+    let q = A.QName m n -      -- Debug.-      reportSDoc "meta.postulate" 20 $ vcat-        [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ")-            <+> prettyTCM (MetaId x) <+> " into postulate."-        , nest 2 $ vcat-          [ "Name: " <+> prettyTCM q-          , "Type: " <+> prettyTCM t-          ]+    -- Debug.+    reportSDoc "meta.postulate" 20 $ vcat+      [ text ("Turning " ++ if isSortMeta_ mv then "sort" else "value" ++ " meta ")+          <+> prettyTCM x <+> " into postulate."+      , nest 2 $ vcat+        [ "Name: " <+> prettyTCM q+        , "Type: " <+> prettyTCM t         ]+      ] -      -- Add the new postulate to the signature.-      addConstant' q defaultArgInfo q t defaultAxiom+    -- Add the new postulate to the signature.+    addConstant' q defaultArgInfo q t defaultAxiom -      -- Solve the meta.-      let inst = InstV [] $ Def q []-      updateMetaVar (MetaId x) $ \ mv0 -> mv0 { mvInstantiation = inst }-      return ()+    -- Solve the meta.+    let inst = InstV $ Instantiation+                 { instTel = [], instBody = Def q [] }+    updateMetaVar x $ \ mv0 -> mv0 { mvInstantiation = inst }+    return ()   where     -- Unsolved sort metas can have a type ending in a Dummy if they are allowed to be instantiated     -- to Setω. This will crash the serializer (issue #3730). To avoid this we replace dummy type@@ -1709,15 +1704,20 @@ dependencySortMetas metas = do   metaGraph <- concat <$> do     forM metas $ \ m -> do-      deps <- allMetas (\ m' -> if m' `elem` metas then singleton m' else mempty) <$> getType m+      deps <- allMetas (\m' -> if m' `Set.member` metas'+                               then singleton m'+                               else mempty) <$>+                getType m       return [ (m, m') | m' <- Set.toList deps ] -  return $ Graph.topSort metas metaGraph+  return $ Graph.topSort metas' metaGraph    where+    metas' = Set.fromList metas+     -- Sort metas don't have types, but we still want to sort them.     getType m = do-      mv <- lookupMeta m-      case mvJudgement mv of+      j <- lookupMetaJudgement m+      case j of         IsSort{}                 -> return Nothing         HasType{ jMetaType = t } -> Just <$> instantiateFull t
src/full/Agda/TypeChecking/MetaVars.hs-boot view
@@ -11,7 +11,6 @@ newArgsMeta'      :: MonadMetaSolver m => Condition -> Type -> m Args newArgsMeta       :: MonadMetaSolver m => Type -> m Args assignTerm        :: MonadMetaSolver m => MetaId -> [Arg String] -> Term -> m ()-etaExpandMetaSafe :: MonadMetaSolver m => MetaId -> m () assign            :: CompareDirection -> MetaId -> Args -> Term -> CompareAs -> TCM () newInstanceMeta   :: MonadMetaSolver m => String -> Type -> m (MetaId, Term) newValueMeta      :: MonadMetaSolver m => RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
src/full/Agda/TypeChecking/MetaVars/Mention.hs view
@@ -43,6 +43,7 @@   mentionsMetas xs (UnblockOnAny bs)  = mentionsMetas xs $ Set.toList bs   mentionsMetas xs (UnblockOnMeta x)  = HashSet.member x xs   mentionsMetas xs UnblockOnProblem{} = False+  mentionsMetas xs UnblockOnDef{}     = False  instance MentionsMeta Type where     mentionsMetas xs (El s t) = mentionsMetas xs (s, t)@@ -55,6 +56,7 @@     SSet l     -> mentionsMetas xs l     SizeUniv   -> False     LockUniv   -> False+    IntervalUniv -> False     PiSort a s1 s2 -> mentionsMetas xs (a, s1, s2)     FunSort s1 s2 -> mentionsMetas xs (s1, s2)     UnivSort s -> mentionsMetas xs s@@ -117,10 +119,11 @@     HasBiggerSort a     -> mm a     HasPTSRule a b      -> mm (a, b)     UnquoteTactic tac hole goal -> False+    CheckDataSort q s   -> mm s     CheckMetaInst m     -> True   -- TODO     CheckType t         -> mm t     CheckLockedVars a b c d -> mm ((a, b), (c, d))-    UsableAtModality mod t -> mm t+    UsableAtModality _ ms mod t -> mm (ms, t)     where       mm :: forall t. MentionsMeta t => t -> Bool       mm = mentionsMetas xs
src/full/Agda/TypeChecking/MetaVars/Occurs.hs view
@@ -32,7 +32,7 @@ import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars -import Agda.TypeChecking.Constraints () -- instances+import Agda.TypeChecking.Constraints ( wakeupConstraints ) import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench import Agda.TypeChecking.Reduce@@ -190,7 +190,7 @@         [ "occursCheck: definition"         , prettyTCM d         , "has relevance"-        , prettyTCM (getRelevance dmod)+        , text . show $ getRelevance dmod         ]       abort neverUnblock $ MetaIrrelevantSolution m $ Def d []     unless (er || usableQuantity dmod) $ do@@ -198,7 +198,7 @@         [ "occursCheck: definition"         , prettyTCM d         , "has quantity"-        , prettyTCM (getQuantity dmod)+        , text . show $ getQuantity dmod         ]       abort neverUnblock $ MetaErasedSolution m $ Def d [] @@ -225,17 +225,17 @@   --   abort ctx $ MetaOccursInItself m'   when (m == m0) $ patternViolation' neverUnblock 50 $ "occursCheck failed: Found " ++ prettyShow m -  mv <- lookupMeta m-  let mmod = getMetaModality mv+  mv <- lookupLocalMeta m+  let mmod = getModality mv       mmod' = setRelevance rel $ setQuantity qnt $ mmod   if (mmod `moreUsableModality` mmod') then return m else do     reportSDoc "tc.meta.occurs" 35 $ hsep       [ "occursCheck: meta variable"       , prettyTCM m       , "has relevance"-      , prettyTCM (getRelevance mmod)+      , text . show $ getRelevance mmod       , "and quantity"-      , prettyTCM (getQuantity mmod)+      , text . show $ getQuantity mmod       ]     allowAssign <- asksTC envAssignMetas     -- Jesper, 2020-11-10: if we encounter a metavariable that is@@ -260,15 +260,10 @@     when (isUnguarded cxt)                   $ fail "occurrence is unguarded"      reportSDoc "tc.meta.occurs" 20 $ "Promoting meta" <+> prettyTCM m <+> "to modality" <+> prettyTCM mmod'-    let info' = setModality mmod' $ mvInfo mv-    m' <- liftTCM $ newMeta Instantiable info' (mvPriority mv) (mvPermutation mv) (mvJudgement mv)-    reportSDoc "tc.meta.occurs.qnt" 20 $ hsep-       [ "occursCheck: new meta variable"-       , prettyTCM m'-       ]-    liftTCM $ assignTerm m [] $ MetaV m' []-    reportSDoc "tc.meta.occurs" 35 $ "New name for" <+> prettyTCM m <+> "is" <+> prettyTCM m'-    return m'+    updateMetaVar m $ \ mv -> mv { mvInfo = setModality mmod' $ mvInfo mv }+    etaExpandListeners m+    wakeupConstraints m+    return m  -- | Construct a test whether a de Bruijn index is allowed --   or needs to be pruned.@@ -276,9 +271,9 @@ allowedVars = do   -- @n@ is the number of binders we have stepped under.   n  <- liftM2 (-) getContextSize (asks (occCxtSize . feExtra))-  xs <- asks ((IntMap.keysSet . theVarMap) . (occVars . feExtra))+  xs <- asks (theVarMap . occVars . feExtra)   -- Bound variables are allowed, and those mentioned in occVars.-  return $ \ i -> i < n || (i - n) `IntSet.member` xs+  return $ \ i -> i < n || (i - n) `IntMap.member` xs  -- ** Unfolding during occurs check. @@ -367,7 +362,7 @@   :: (Occurs a, InstantiateFull a, PrettyTCM a)   => MetaId -> VarMap -> a -> TCM a occursCheck m xs v = Bench.billTo [ Bench.Typing, Bench.OccursCheck ] $ do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   n  <- getContextSize   reportSLn "tc.meta.occurs" 35 $ "occursCheck " ++ show m ++ " " ++ show xs   let initEnv unf = FreeEnv@@ -378,7 +373,7 @@           , occCxtSize = n           }         , feFlexRig   = StronglyRigid -- ? Unguarded-        , feModality  = getMetaModality mv+        , feModality  = getModality mv         , feSingleton = variableCheck xs         }   initOccursCheck mv@@ -389,7 +384,7 @@       -- (unless metavariable is irrelevant, in which case the       -- constraint will anyway be dropped)       case err of-        PatternErr{} | not (isIrrelevant $ getMetaModality mv) -> do+        PatternErr{} | not (isIrrelevant $ getModality mv) -> do           initOccursCheck mv           occurs v `runReaderT` initEnv YesUnfold         _ -> throwError err@@ -401,19 +396,25 @@       TypeError _ _ cl -> case clValue cl of         MetaOccursInItself{} ->           typeError . GenericDocError =<<-            fsep [ text ("Refuse to construct infinite term by instantiating " ++ prettyShow m ++ " to")+            fsep [ text "Refuse to construct infinite term by instantiating"+                 , prettyTCM m+                 , "to"                  , prettyTCM =<< instantiateFull v                  ]         MetaCannotDependOn _ i ->           ifM (isSortMeta m `and2M` (not <$> hasUniversePolymorphism))           ( typeError . GenericDocError =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to")+            fsep [ text "Cannot instantiate the metavariable"+                 , prettyTCM m+                 , "to"                  , prettyTCM v                  , "since universe polymorphism is disabled"                  ]           ) {- else -}           ( typeError . GenericDocError =<<-              fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")+              fsep [ text "Cannot instantiate the metavariable"+                   , prettyTCM m+                   , "to solution"                    , prettyTCM v                    , "since it contains the variable"                    , enterClosure cl $ \_ -> prettyTCM (Var i [])@@ -422,13 +423,17 @@             )         MetaIrrelevantSolution _ _ ->           typeError . GenericDocError =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")+            fsep [ text "Cannot instantiate the metavariable"+                 , prettyTCM m+                 , "to solution"                  , prettyTCM v                  , "since (part of) the solution was created in an irrelevant context"                  ]         MetaErasedSolution _ _ ->           typeError . GenericDocError =<<-            fsep [ text ("Cannot instantiate the metavariable " ++ prettyShow m ++ " to solution")+            fsep [ text "Cannot instantiate the metavariable"+                 , prettyTCM m+                 , "to solution"                  , prettyTCM v                  , "since (part of) the solution was created in an erased context"                  ]@@ -613,6 +618,7 @@       SSet a     -> SSet <$> occurs a       s@SizeUniv -> return s       s@LockUniv -> return s+      s@IntervalUniv -> return s       UnivSort s -> UnivSort <$> do flexibly $ occurs s       MetaS x es -> do         MetaV x es <- occurs (MetaV x es)@@ -633,6 +639,7 @@       SSet a     -> metaOccurs m a       SizeUniv   -> return ()       LockUniv   -> return ()+      IntervalUniv -> return ()       UnivSort s -> metaOccurs m s       MetaS x es -> metaOccurs m $ MetaV x es       DefS d es  -> metaOccurs m $ Def d es@@ -822,7 +829,7 @@         -- If the definition is incomplete, arguments might disappear         -- by reductions that come with more clauses, thus, these         -- arguments are not rigid.-        NotBlocked MissingClauses _ -> return False+        NotBlocked (MissingClauses _) _ -> return False         -- _        -> mempty -- breaks: ImproveInertRHS, Issue442, PruneRecord, PruningNonMillerPattern         _        -> anyRigid f es       Con _ _ ts -> anyRigid f ts@@ -845,6 +852,7 @@       SSet l     -> anyRigid f l       SizeUniv   -> return False       LockUniv   -> return False+      IntervalUniv -> return False       PiSort a s1 s2 -> return False       FunSort s1 s2 -> return False       UnivSort s -> anyRigid f s@@ -898,7 +906,7 @@ killArgs kills _   | not (or kills) = return NothingToPrune  -- nothing to kill killArgs kills m = do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   allowAssign <- asksTC envAssignMetas   if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do       -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS@@ -940,9 +948,12 @@ killedType :: (MonadReduce m) => [(Dom (ArgName, Type), Bool)] -> Type -> m ([Arg Bool], Type) killedType args b = do +  let n = length args+  let iargs = zip (downFrom n) args+   -- Turn list of bools into an IntSet containing the variables we want to kill   -- (indices relative to b).-  let tokill = IntSet.fromList [ i | ((_, True), i) <- zip (reverse args) [0..] ]+  let tokill = IntSet.fromList [ i | (i, (_, True)) <- iargs ]    -- First, check the free variables of b to see if they prevent any kills.   (tokill, b) <- reallyNotFreeIn tokill b@@ -952,7 +963,7 @@    -- Turn the IntSet of killed variables into the list of Arg Bool's to return.   let kills = [ Arg (getArgInfo dom) (IntSet.member i killed)-              | (i, (dom, _)) <- reverse $ zip [0..] $ reverse args ]+              | (i, (dom, _)) <- iargs ]   return (kills, b)   where     down = IntSet.map pred@@ -990,7 +1001,7 @@           (ys, a) <- reallyNotFreeIn xs' a           -- Recurse on Δ, ys, and (x : A') → B, where A reduces to A' and ys ⊆ xs'           -- not free in A'. We already know ys not free in B.-          (zs, b) <- go args ys (mkPi ((name, a) <$ arg) b)+          (zs, b) <- go args ys $ mkPi ((name, a) <$ arg) b           -- Shift back up to make it relative to Δ (x : A) again.           return (up zs, b) @@ -1024,7 +1035,7 @@   -> Type          -- ^ The pruned type of the new meta var.   -> m () performKill kills m a = do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   when (mvFrozen mv == Frozen) __IMPOSSIBLE__   -- Arity of the old meta.   let n = size kills
src/full/Agda/TypeChecking/Monad/Base.hs view
@@ -1,4739 +1,5381 @@ {-# LANGUAGE CPP #-}--- {-# LANGUAGE UndecidableInstances #-}  -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT--module Agda.TypeChecking.Monad.Base-  ( module Agda.TypeChecking.Monad.Base-  , HasOptions (..)-  ) where--import Prelude hiding (null)--import Control.Applicative hiding (empty)-import qualified Control.Concurrent as C-import Control.DeepSeq-import qualified Control.Exception as E--import qualified Control.Monad.Fail as Fail--import Control.Monad                ( void )-import Control.Monad.Except-import Control.Monad.IO.Class       ( MonadIO(..) )-import Control.Monad.State          ( MonadState(..), modify, StateT(..), runStateT )-import Control.Monad.Reader         ( MonadReader(..), ReaderT(..), runReaderT )-import Control.Monad.Writer         ( WriterT )-import Control.Monad.Trans          ( MonadTrans(..), lift )-import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )-import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT )-import Control.Monad.Trans.Maybe    ( MaybeT(..) )--import Control.Parallel             ( pseq )--import Data.Array (Ix)-import Data.Function-import Data.Int-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import qualified Data.List as List-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map -- hiding (singleton, null, empty)-import Data.Sequence (Seq)-import Data.Set (Set)-import qualified Data.Set as Set -- hiding (singleton, null, empty)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HMap-import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )-import Data.Data (Data)-import Data.String-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import Data.IORef--import GHC.Generics (Generic)--import Agda.Benchmarking (Benchmark, Phase)--import Agda.Syntax.Concrete (TopLevelModuleName)-import Agda.Syntax.Common-import qualified Agda.Syntax.Concrete as C-import Agda.Syntax.Concrete.Definitions-  (NiceDeclaration, DeclarationWarning, dwWarning, declarationWarningName)-import qualified Agda.Syntax.Abstract as A-import Agda.Syntax.Internal as I-import Agda.Syntax.Internal.MetaVars-import Agda.Syntax.Internal.Generic (TermLike(..))-import Agda.Syntax.Parser (ParseWarning)-import Agda.Syntax.Parser.Monad (parseWarningName)-import Agda.Syntax.Treeless (Compiled)-import Agda.Syntax.Notation-import Agda.Syntax.Position-import Agda.Syntax.Scope.Base-import qualified Agda.Syntax.Info as Info--import Agda.TypeChecking.CompiledClause-import Agda.TypeChecking.Coverage.SplitTree-import Agda.TypeChecking.Positivity.Occurrence-import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)---- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend--- conflicts with Args, defined in Agda.Syntax.Internal and also imported here.--- This only matters when interpreted in ghci, which sees all of the module's--- exported symbols, not just the ones defined in the `.hs-boot`. See the--- comment in ../../Compiler/Backend.hs-boot-import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args)--import Agda.Interaction.Options-import Agda.Interaction.Options.Warnings-import {-# SOURCE #-} Agda.Interaction.Response-  (InteractionOutputCallback, defaultInteractionOutputCallback)-import Agda.Interaction.Highlighting.Precise-  (HighlightingInfo, NameKind)-import Agda.Interaction.Library--import Agda.Utils.Benchmark (MonadBench(..))-import Agda.Utils.BiMap (BiMap, HasTag(..))-import qualified Agda.Utils.BiMap as BiMap-import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )-import Agda.Utils.FileName-import Agda.Utils.Functor-import Agda.Utils.Hash-import Agda.Utils.Lens-import Agda.Utils.List-import Agda.Utils.ListT-import Agda.Utils.List1 (List1, pattern (:|))-import Agda.Utils.List2 (List2, pattern List2)-import qualified Agda.Utils.List1 as List1-import qualified Agda.Utils.Maybe.Strict as Strict-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Permutation-import Agda.Utils.Pretty-import Agda.Utils.Singleton-import Agda.Utils.SmallSet (SmallSet)-import qualified Agda.Utils.SmallSet as SmallSet-import Agda.Utils.Update-import Agda.Utils.WithDefault ( collapseDefault )--import Agda.Utils.Impossible-------------------------------------------------------------------------------- * Type checking state------------------------------------------------------------------------------data TCState = TCSt-  { stPreScopeState   :: !PreScopeState-    -- ^ The state which is frozen after scope checking.-  , stPostScopeState  :: !PostScopeState-    -- ^ The state which is modified after scope checking.-  , stPersistentState :: !PersistentTCState-    -- ^ State which is forever, like a diamond.-  }-  deriving Generic--class Monad m => ReadTCState m where-  getTCState :: m TCState-  locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b--  withTCState :: (TCState -> TCState) -> m a -> m a-  withTCState = locallyTCState id--  default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState-  getTCState = lift getTCState--  default locallyTCState-    :: (MonadTransControl t, ReadTCState n, t n ~ m)-    => Lens' a TCState -> (a -> a) -> m b -> m b-  locallyTCState l = liftThrough . locallyTCState l--instance ReadTCState m => ReadTCState (ListT m) where-  locallyTCState l = mapListT . locallyTCState l--instance ReadTCState m => ReadTCState (ChangeT m)-instance ReadTCState m => ReadTCState (ExceptT err m)-instance ReadTCState m => ReadTCState (IdentityT m)-instance ReadTCState m => ReadTCState (MaybeT m)-instance ReadTCState m => ReadTCState (ReaderT r m)-instance ReadTCState m => ReadTCState (StateT s m)-instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m)---instance Show TCState where-  show _ = "TCSt{}"--data PreScopeState = PreScopeState-  { stPreTokens             :: !HighlightingInfo-    -- ^ Highlighting info for tokens and Happy parser warnings (but-    -- not for those tokens/warnings for which highlighting exists in-    -- 'stPostSyntaxInfo').-  , stPreImports            :: !Signature  -- XX populated by scope checker-    -- ^ Imported declared identifiers.-    --   Those most not be serialized!-  , stPreImportedModules    :: !(Set ModuleName)  -- imports logic-  , stPreModuleToSource     :: !ModuleToSource   -- imports-  , stPreVisitedModules     :: !VisitedModules   -- imports-  , stPreScope              :: !ScopeInfo-    -- generated by scope checker, current file:-    -- which modules you have, public definitions, current file, maps concrete names to abstract names.-  , stPrePatternSyns        :: !A.PatternSynDefns-    -- ^ Pattern synonyms of the current file.  Serialized.-  , stPrePatternSynImports  :: !A.PatternSynDefns-    -- ^ Imported pattern synonyms.  Must not be serialized!-  , stPreGeneralizedVars    :: !(Strict.Maybe (Set QName))-    -- ^ Collected generalizable variables; used during scope checking of terms-  , stPrePragmaOptions      :: !PragmaOptions-    -- ^ Options applying to the current file. @OPTIONS@-    -- pragmas only affect this field.-  , stPreImportedBuiltins   :: !(BuiltinThings PrimFun)-  , stPreImportedDisplayForms :: !DisplayForms-    -- ^ Display forms added by someone else to imported identifiers-  , stPreImportedInstanceDefs :: !InstanceTable-  , stPreForeignCode        :: !(Map BackendName [ForeignCode])-    -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.-    -- Does not include code for imported modules.-  , stPreFreshInteractionId :: !InteractionId-  , stPreImportedUserWarnings :: !(Map A.QName Text)-    -- ^ Imported @UserWarning@s, not to be stored in the @Interface@-  , stPreLocalUserWarnings    :: !(Map A.QName Text)-    -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@-  , stPreWarningOnImport      :: !(Strict.Maybe Text)-    -- ^ Whether the current module should raise a warning when opened-  , stPreImportedPartialDefs :: !(Set QName)-    -- ^ Imported partial definitions, not to be stored in the @Interface@-  , stPreProjectConfigs :: !(Map FilePath ProjectConfig)-    -- ^ Map from directories to paths of closest enclosing .agda-lib-    --   files (or @Nothing@ if there are none).-  , stPreAgdaLibFiles   :: !(Map FilePath AgdaLibFile)-    -- ^ Contents of .agda-lib files that have already been parsed.-  }-  deriving Generic---- | Name disambiguation for the sake of highlighting.-data DisambiguatedName = DisambiguatedName NameKind A.QName-  deriving Generic-type DisambiguatedNames = IntMap DisambiguatedName--type ConcreteNames = Map Name [C.Name]--data PostScopeState = PostScopeState-  { stPostSyntaxInfo          :: !HighlightingInfo-    -- ^ Highlighting info.-  , stPostDisambiguatedNames  :: !DisambiguatedNames-    -- ^ Disambiguation carried out by the type checker.-    --   Maps position of first name character to disambiguated @'A.QName'@-    --   for each @'A.AmbiguousQName'@ already passed by the type checker.-  , stPostMetaStore           :: !MetaStore-  , stPostInteractionPoints   :: !InteractionPoints -- scope checker first-  , stPostAwakeConstraints    :: !Constraints-  , stPostSleepingConstraints :: !Constraints-  , stPostDirty               :: !Bool -- local-    -- ^ Dirty when a constraint is added, used to prevent pointer update.-    -- Currently unused.-  , stPostOccursCheckDefs     :: !(Set QName) -- local-    -- ^ Definitions to be considered during occurs check.-    --   Initialized to the current mutual block before the check.-    --   During occurs check, we remove definitions from this set-    --   as soon we have checked them.-  , stPostSignature           :: !Signature-    -- ^ Declared identifiers of the current file.-    --   These will be serialized after successful type checking.-  , stPostModuleCheckpoints   :: !(Map ModuleName CheckpointId)-    -- ^ For each module remember the checkpoint corresponding to the orignal-    --   context of the module parameters.-  , stPostImportsDisplayForms :: !DisplayForms-    -- ^ Display forms we add for imported identifiers-  , stPostCurrentModule       :: !(Strict.Maybe ModuleName)-    -- ^ The current module is available after it has been type-    -- checked.-  , stPostInstanceDefs        :: !TempInstanceTable-  , stPostConcreteNames       :: !ConcreteNames-    -- ^ Map keeping track of concrete names assigned to each abstract name-    --   (can be more than one name in case the first one is shadowed)-  , stPostUsedNames           :: !(Map RawName [RawName])-    -- ^ Map keeping track for each name root (= name w/o numeric-    -- suffixes) what names with the same root have been used during a-    -- TC computation. This information is used to build the-    -- @ShadowingNames@ map.-  , stPostShadowingNames      :: !(Map Name [RawName])-    -- ^ Map keeping track for each (abstract) name the list of all-    -- (raw) names that it could maybe be shadowed by.-  , stPostStatistics          :: !Statistics-    -- ^ Counters to collect various statistics about meta variables etc.-    --   Only for current file.-  , stPostTCWarnings          :: ![TCWarning]-  , stPostMutualBlocks        :: !(Map MutualId MutualBlock)-  , stPostLocalBuiltins       :: !(BuiltinThings PrimFun)-  , stPostFreshMetaId         :: !MetaId-  , stPostFreshMutualId       :: !MutualId-  , stPostFreshProblemId      :: !ProblemId-  , stPostFreshCheckpointId   :: !CheckpointId-  , stPostFreshInt            :: !Int-  , stPostFreshNameId         :: !NameId-  , stPostAreWeCaching        :: !Bool-  , stPostPostponeInstanceSearch :: !Bool-  , stPostConsideringInstance :: !Bool-  , stPostInstantiateBlocking :: !Bool-    -- ^ Should we instantiate away blocking metas?-    --   This can produce ill-typed terms but they are often more readable. See issue #3606.-    --   Best set to True only for calls to pretty*/reify to limit unwanted reductions.-  , stPostLocalPartialDefs    :: !(Set QName)-    -- ^ Local partial definitions, to be stored in the @Interface@-  }-  deriving (Generic)---- | A mutual block of names in the signature.-data MutualBlock = MutualBlock-  { mutualInfo  :: Info.MutualInfo-    -- ^ The original info of the mutual block.-  , mutualNames :: Set QName-  } deriving (Show, Eq, Generic)--instance Null MutualBlock where-  empty = MutualBlock empty empty---- | A part of the state which is not reverted when an error is thrown--- or the state is reset.-data PersistentTCState = PersistentTCSt-  { stDecodedModules    :: !DecodedModules-  , stPersistentOptions :: CommandLineOptions-  , stInteractionOutputCallback  :: InteractionOutputCallback-    -- ^ Callback function to call when there is a response-    --   to give to the interactive frontend.-    --   See the documentation of 'InteractionOutputCallback'.-  , stBenchmark         :: !Benchmark-    -- ^ Structure to track how much CPU time was spent on which Agda phase.-    --   Needs to be a strict field to avoid space leaks!-  , stAccumStatistics   :: !Statistics-    -- ^ Should be strict field.-  , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)-    -- ^ Cached typechecking state from the last loaded file.-    --   Should be @Nothing@ when checking imports.-  , stPersistBackends   :: [Backend]-    -- ^ Current backends with their options-  }-  deriving Generic--data LoadedFileCache = LoadedFileCache-  { lfcCached  :: !CachedTypeCheckLog-  , lfcCurrent :: !CurrentTypeCheckLog-  }-  deriving Generic---- | A log of what the type checker does and states after the action is--- completed.  The cached version is stored first executed action first.-type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)]---- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type--- checking of a module.  Stored in reverse order (last performed action--- first).-type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)]---- | A complete log for a module will look like this:------   * 'Pragmas'------   * 'EnterSection', entering the main module.------   * 'Decl'/'EnterSection'/'LeaveSection', for declarations and nested---     modules------   * 'LeaveSection', leaving the main module.-data TypeCheckAction-  = EnterSection !ModuleName !A.Telescope-  | LeaveSection !ModuleName-  | Decl !A.Declaration-    -- ^ Never a Section or ScopeDecl-  | Pragmas !PragmaOptions-  deriving (Generic)---- | Empty persistent state.--initPersistentState :: PersistentTCState-initPersistentState = PersistentTCSt-  { stPersistentOptions         = defaultOptions-  , stDecodedModules            = Map.empty-  , stInteractionOutputCallback = defaultInteractionOutputCallback-  , stBenchmark                 = empty-  , stAccumStatistics           = Map.empty-  , stPersistLoadedFileCache    = empty-  , stPersistBackends           = []-  }---- | Empty state of type checker.--initPreScopeState :: PreScopeState-initPreScopeState = PreScopeState-  { stPreTokens               = mempty-  , stPreImports              = emptySignature-  , stPreImportedModules      = Set.empty-  , stPreModuleToSource       = Map.empty-  , stPreVisitedModules       = Map.empty-  , stPreScope                = emptyScopeInfo-  , stPrePatternSyns          = Map.empty-  , stPrePatternSynImports    = Map.empty-  , stPreGeneralizedVars      = mempty-  , stPrePragmaOptions        = defaultInteractionOptions-  , stPreImportedBuiltins     = Map.empty-  , stPreImportedDisplayForms = HMap.empty-  , stPreImportedInstanceDefs = Map.empty-  , stPreForeignCode          = Map.empty-  , stPreFreshInteractionId   = 0-  , stPreImportedUserWarnings = Map.empty-  , stPreLocalUserWarnings    = Map.empty-  , stPreWarningOnImport      = empty-  , stPreImportedPartialDefs  = Set.empty-  , stPreProjectConfigs       = Map.empty-  , stPreAgdaLibFiles         = Map.empty-  }--initPostScopeState :: PostScopeState-initPostScopeState = PostScopeState-  { stPostSyntaxInfo           = mempty-  , stPostDisambiguatedNames   = IntMap.empty-  , stPostMetaStore            = IntMap.empty-  , stPostInteractionPoints    = empty-  , stPostAwakeConstraints     = []-  , stPostSleepingConstraints  = []-  , stPostDirty                = False-  , stPostOccursCheckDefs      = Set.empty-  , stPostSignature            = emptySignature-  , stPostModuleCheckpoints    = Map.empty-  , stPostImportsDisplayForms  = HMap.empty-  , stPostCurrentModule        = empty-  , stPostInstanceDefs         = (Map.empty , Set.empty)-  , stPostConcreteNames        = Map.empty-  , stPostUsedNames            = Map.empty-  , stPostShadowingNames       = Map.empty-  , stPostStatistics           = Map.empty-  , stPostTCWarnings           = []-  , stPostMutualBlocks         = Map.empty-  , stPostLocalBuiltins        = Map.empty-  , stPostFreshMetaId          = 0-  , stPostFreshMutualId        = 0-  , stPostFreshProblemId       = 1-  , stPostFreshCheckpointId    = 1-  , stPostFreshInt             = 0-  , stPostFreshNameId          = NameId 0 noModuleNameHash-  , stPostAreWeCaching         = False-  , stPostPostponeInstanceSearch = False-  , stPostConsideringInstance  = False-  , stPostInstantiateBlocking  = False-  , stPostLocalPartialDefs     = Set.empty-  }--initState :: TCState-initState = TCSt-  { stPreScopeState   = initPreScopeState-  , stPostScopeState  = initPostScopeState-  , stPersistentState = initPersistentState-  }---- * st-prefixed lenses---------------------------------------------------------------------------stTokens :: Lens' HighlightingInfo TCState-stTokens f s =-  f (stPreTokens (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}}--stImports :: Lens' Signature TCState-stImports f s =-  f (stPreImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}}--stImportedModules :: Lens' (Set ModuleName) TCState-stImportedModules f s =-  f (stPreImportedModules (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}}--stModuleToSource :: Lens' ModuleToSource TCState-stModuleToSource f s =-  f (stPreModuleToSource (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}}--stVisitedModules :: Lens' VisitedModules TCState-stVisitedModules f s =-  f (stPreVisitedModules (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}}--stScope :: Lens' ScopeInfo TCState-stScope f s =-  f (stPreScope (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}}--stPatternSyns :: Lens' A.PatternSynDefns TCState-stPatternSyns f s =-  f (stPrePatternSyns (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}}--stPatternSynImports :: Lens' A.PatternSynDefns TCState-stPatternSynImports f s =-  f (stPrePatternSynImports (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}}--stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState-stGeneralizedVars f s =-  f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}}--stPragmaOptions :: Lens' PragmaOptions TCState-stPragmaOptions f s =-  f (stPrePragmaOptions (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}}--stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState-stImportedBuiltins f s =-  f (stPreImportedBuiltins (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}}--stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState-stForeignCode f s =-  f (stPreForeignCode (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}}--stFreshInteractionId :: Lens' InteractionId TCState-stFreshInteractionId f s =-  f (stPreFreshInteractionId (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}--stImportedUserWarnings :: Lens' (Map A.QName Text) TCState-stImportedUserWarnings f s =-  f (stPreImportedUserWarnings (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}}--stLocalUserWarnings :: Lens' (Map A.QName Text) TCState-stLocalUserWarnings f s =-  f (stPreLocalUserWarnings (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}}--getUserWarnings :: ReadTCState m => m (Map A.QName Text)-getUserWarnings = do-  iuw <- useR stImportedUserWarnings-  luw <- useR stLocalUserWarnings-  return $ iuw `Map.union` luw--stWarningOnImport :: Lens' (Maybe Text) TCState-stWarningOnImport f s =-  f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}}--stImportedPartialDefs :: Lens' (Set QName) TCState-stImportedPartialDefs f s =-  f (stPreImportedPartialDefs (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}}--stLocalPartialDefs :: Lens' (Set QName) TCState-stLocalPartialDefs f s =-  f (stPostLocalPartialDefs (stPostScopeState s)) <&>-  \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}}--getPartialDefs :: ReadTCState m => m (Set QName)-getPartialDefs = do-  ipd <- useR stImportedPartialDefs-  lpd <- useR stLocalPartialDefs-  return $ ipd `Set.union` lpd--stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState-stLoadedFileCache f s =-  f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&>-  \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}}--stBackends :: Lens' [Backend] TCState-stBackends f s =-  f (stPersistBackends (stPersistentState s)) <&>-  \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}}--stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState-stProjectConfigs f s =-  f (stPreProjectConfigs (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreProjectConfigs = x}}--stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState-stAgdaLibFiles f s =-  f (stPreAgdaLibFiles (stPreScopeState s)) <&>-  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreAgdaLibFiles = x}}--stFreshNameId :: Lens' NameId TCState-stFreshNameId f s =-  f (stPostFreshNameId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}}--stSyntaxInfo :: Lens' HighlightingInfo TCState-stSyntaxInfo f s =-  f (stPostSyntaxInfo (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}}--stDisambiguatedNames :: Lens' DisambiguatedNames TCState-stDisambiguatedNames f s =-  f (stPostDisambiguatedNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}}--stMetaStore :: Lens' MetaStore TCState-stMetaStore f s =-  f (stPostMetaStore (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMetaStore = x}}--stInteractionPoints :: Lens' InteractionPoints TCState-stInteractionPoints f s =-  f (stPostInteractionPoints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}--stAwakeConstraints :: Lens' Constraints TCState-stAwakeConstraints f s =-  f (stPostAwakeConstraints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}}--stSleepingConstraints :: Lens' Constraints TCState-stSleepingConstraints f s =-  f (stPostSleepingConstraints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}}--stDirty :: Lens' Bool TCState-stDirty f s =-  f (stPostDirty (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}}--stOccursCheckDefs :: Lens' (Set QName) TCState-stOccursCheckDefs f s =-  f (stPostOccursCheckDefs (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}}--stSignature :: Lens' Signature TCState-stSignature f s =-  f (stPostSignature (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}}--stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState-stModuleCheckpoints f s =-  f (stPostModuleCheckpoints (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}}--stImportsDisplayForms :: Lens' DisplayForms TCState-stImportsDisplayForms f s =-  f (stPostImportsDisplayForms (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}}--stImportedDisplayForms :: Lens' DisplayForms TCState-stImportedDisplayForms f s =-  f (stPreImportedDisplayForms (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}}--stCurrentModule :: Lens' (Maybe ModuleName) TCState-stCurrentModule f s =-  f (Strict.toLazy $ stPostCurrentModule (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostCurrentModule = Strict.toStrict x}}--stImportedInstanceDefs :: Lens' InstanceTable TCState-stImportedInstanceDefs f s =-  f (stPreImportedInstanceDefs (stPreScopeState s)) <&>-  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}}--stInstanceDefs :: Lens' TempInstanceTable TCState-stInstanceDefs f s =-  f (stPostInstanceDefs (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}}--stConcreteNames :: Lens' ConcreteNames TCState-stConcreteNames f s =-  f (stPostConcreteNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}}--stUsedNames :: Lens' (Map RawName [RawName]) TCState-stUsedNames f s =-  f (stPostUsedNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}}--stShadowingNames :: Lens' (Map Name [RawName]) TCState-stShadowingNames f s =-  f (stPostShadowingNames (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}}--stStatistics :: Lens' Statistics TCState-stStatistics f s =-  f (stPostStatistics (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}--stTCWarnings :: Lens' [TCWarning] TCState-stTCWarnings f s =-  f (stPostTCWarnings (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}}--stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState-stMutualBlocks f s =-  f (stPostMutualBlocks (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}--stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState-stLocalBuiltins f s =-  f (stPostLocalBuiltins (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}}--stFreshMetaId :: Lens' MetaId TCState-stFreshMetaId f s =-  f (stPostFreshMetaId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}}--stFreshMutualId :: Lens' MutualId TCState-stFreshMutualId f s =-  f (stPostFreshMutualId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}}--stFreshProblemId :: Lens' ProblemId TCState-stFreshProblemId f s =-  f (stPostFreshProblemId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}--stFreshCheckpointId :: Lens' CheckpointId TCState-stFreshCheckpointId f s =-  f (stPostFreshCheckpointId (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}}--stFreshInt :: Lens' Int TCState-stFreshInt f s =-  f (stPostFreshInt (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}}---- use @areWeCaching@ from the Caching module instead.-stAreWeCaching :: Lens' Bool TCState-stAreWeCaching f s =-  f (stPostAreWeCaching (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}}--stPostponeInstanceSearch :: Lens' Bool TCState-stPostponeInstanceSearch f s =-  f (stPostPostponeInstanceSearch (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}}--stConsideringInstance :: Lens' Bool TCState-stConsideringInstance f s =-  f (stPostConsideringInstance (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}}--stInstantiateBlocking :: Lens' Bool TCState-stInstantiateBlocking f s =-  f (stPostInstantiateBlocking (stPostScopeState s)) <&>-  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}}--stBuiltinThings :: TCState -> BuiltinThings PrimFun-stBuiltinThings s = (s^.stLocalBuiltins) `Map.union` (s^.stImportedBuiltins)----- * Fresh things---------------------------------------------------------------------------class Enum i => HasFresh i where-    freshLens :: Lens' i TCState-    nextFresh' :: i -> i-    nextFresh' = succ--nextFresh :: HasFresh i => TCState -> (i, TCState)-nextFresh s =-  let !c = s^.freshLens-  in (c, set freshLens (nextFresh' c) s)--class Monad m => MonadFresh i m where-  fresh :: m i--  default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i-  fresh = lift fresh--instance MonadFresh i m => MonadFresh i (ReaderT r m)-instance MonadFresh i m => MonadFresh i (StateT s m)-instance MonadFresh i m => MonadFresh i (ListT m)-instance MonadFresh i m => MonadFresh i (IdentityT m)--instance HasFresh i => MonadFresh i TCM where-  fresh = do-        !s <- getTC-        let (!c , !s') = nextFresh s-        putTC s'-        return c--instance HasFresh MetaId where-  freshLens = stFreshMetaId--instance HasFresh MutualId where-  freshLens = stFreshMutualId--instance HasFresh InteractionId where-  freshLens = stFreshInteractionId--instance HasFresh NameId where-  freshLens = stFreshNameId-  -- nextFresh increments the current fresh name by 2 so @NameId@s used-  -- before caching starts do not overlap with the ones used after.-  nextFresh' = succ . succ--instance HasFresh Int where-  freshLens = stFreshInt--instance HasFresh ProblemId where-  freshLens = stFreshProblemId--newtype CheckpointId = CheckpointId Int-  deriving (Data, Eq, Ord, Enum, Real, Integral, Num, NFData)--instance Show CheckpointId where-  show (CheckpointId n) = show n--instance Pretty CheckpointId where-  pretty (CheckpointId n) = pretty n--instance HasFresh CheckpointId where-  freshLens = stFreshCheckpointId--freshName :: MonadFresh NameId m => Range -> String -> m Name-freshName r s = do-  i <- fresh-  return $ mkName r i s--freshNoName :: MonadFresh NameId m => Range -> m Name-freshNoName r =-    do  i <- fresh-        return $ makeName i (C.NoName noRange i) r noFixity' False--freshNoName_ :: MonadFresh NameId m => m Name-freshNoName_ = freshNoName noRange--freshRecordName :: MonadFresh NameId m => m Name-freshRecordName = do-  i <- fresh-  return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True---- | Create a fresh name from @a@.-class FreshName a where-  freshName_ :: MonadFresh NameId m => a -> m Name--instance FreshName (Range, String) where-  freshName_ = uncurry freshName--instance FreshName String where-  freshName_ = freshName noRange--instance FreshName Range where-  freshName_ = freshNoName--instance FreshName () where-  freshName_ () = freshNoName_-------------------------------------------------------------------------------- ** Managing file names-------------------------------------------------------------------------------- | Maps top-level module names to the corresponding source file--- names.--type ModuleToSource = Map TopLevelModuleName AbsolutePath---- | Maps source file names to the corresponding top-level module--- names.--type SourceToModule = Map AbsolutePath TopLevelModuleName---- | Creates a 'SourceToModule' map based on 'stModuleToSource'.------   O(n log n).------   For a single reverse lookup in 'stModuleToSource',---   rather use 'lookupModuleFromSourse'.--sourceToModule :: TCM SourceToModule-sourceToModule =-  Map.fromListWith __IMPOSSIBLE__-     .  List.map (\(m, f) -> (f, m))-     .  Map.toList-    <$> useTC stModuleToSource---- | Lookup an 'AbsolutePath' in 'sourceToModule'.------   O(n).--lookupModuleFromSource :: ReadTCState m => AbsolutePath -> m (Maybe TopLevelModuleName)-lookupModuleFromSource f =-  fmap fst . List.find ((f ==) . snd) . Map.toList <$> useR stModuleToSource--------------------------------------------------------------------------------- ** Associating concrete names to an abstract name-------------------------------------------------------------------------------- | A monad that has read and write access to the stConcreteNames---   part of the TCState. Basically, this is a synonym for `MonadState---   ConcreteNames m` (which cannot be used directly because of the---   limitations of Haskell's typeclass system).-class Monad m => MonadStConcreteNames m where-  runStConcreteNames :: StateT ConcreteNames m a -> m a--  useConcreteNames :: m ConcreteNames-  useConcreteNames = runStConcreteNames get--  modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m ()-  modifyConcreteNames = runStConcreteNames . modify--instance MonadStConcreteNames TCM where-  runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m--instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where-  runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m--instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where-  runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m)--instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where-  runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do-    ((x,ns'),s') <- runStateT (runStateT m ns) s-    return ((x,s'),ns')-------------------------------------------------------------------------------- ** Interface--------------------------------------------------------------------------------- | Distinguishes between type-checked and scope-checked interfaces---   when stored in the map of `VisitedModules`.-data ModuleCheckMode-  = ModuleScopeChecked-  | ModuleTypeChecked-  deriving (Eq, Ord, Bounded, Enum, Show, Generic)---data ModuleInfo = ModuleInfo-  { miInterface  :: Interface-  , miWarnings   :: [TCWarning]-    -- ^ Warnings were encountered when the module was type checked.-    --   These might include warnings not stored in the interface itself,-    --   specifically unsolved interaction metas.-    --   See "Agda.Interaction.Imports"-  , miPrimitive  :: Bool-    -- ^ 'True' if the module is a primitive module, which should always-    -- be importable.-  , miMode       :: ModuleCheckMode-    -- ^ The `ModuleCheckMode` used to create the `Interface`-  }-  deriving Generic---- Note that the use of 'C.TopLevelModuleName' here is a potential--- performance problem, because these names do not contain unique--- identifiers.--type VisitedModules = Map C.TopLevelModuleName ModuleInfo-type DecodedModules = Map C.TopLevelModuleName ModuleInfo--data ForeignCode = ForeignCode Range String-  deriving (Show, Generic)--data Interface = Interface-  { iSourceHash      :: Hash-    -- ^ Hash of the source code.-  , iSource          :: TL.Text-    -- ^ The source code. The source code is stored so that the HTML-    -- and LaTeX backends can generate their output without having to-    -- re-read the (possibly out of date) source code.-  , iFileType        :: FileType-    -- ^ Source file type, determined from the file extension-  , iImportedModules :: [(ModuleName, Hash)]-    -- ^ Imported modules and their hashes.-  , iModuleName      :: ModuleName-    -- ^ Module name of this interface.-  , iScope           :: Map ModuleName Scope-    -- ^ Scope defined by this module.-    ---    --   Andreas, AIM XX: Too avoid duplicate serialization, this field is-    --   not serialized, so if you deserialize an interface, @iScope@-    --   will be empty.-    --   But 'constructIScope' constructs 'iScope' from 'iInsideScope'.-  , iInsideScope     :: ScopeInfo-    -- ^ Scope after we loaded this interface.-    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'-    --   and     'Agda.Interaction.CommandLine.interactionLoop'.-  , iSignature       :: Signature-  , iDisplayForms    :: DisplayForms-    -- ^ Display forms added for imported identifiers.-  , iUserWarnings    :: Map A.QName Text-    -- ^ User warnings for imported identifiers-  , iImportWarning   :: Maybe Text-    -- ^ Whether this module should raise a warning when imported-  , iBuiltin         :: BuiltinThings (String, QName)-  , iForeignCode     :: Map BackendName [ForeignCode]-  , iHighlighting    :: HighlightingInfo-  , iDefaultPragmaOptions :: [OptionsPragma]-    -- ^ Pragma options set in library files.-  , iFilePragmaOptions    :: [OptionsPragma]-    -- ^ Pragma options set in the file.-  , iOptionsUsed     :: PragmaOptions-    -- ^ Options/features used when checking the file (can be different-    --   from options set directly in the file).-  , iPatternSyns     :: A.PatternSynDefns-  , iWarnings        :: [TCWarning]-  , iPartialDefs     :: Set QName-  }-  deriving (Show, Generic)--instance Pretty Interface where-  pretty (Interface-            sourceH source fileT importedM moduleN scope insideS signature-            display userwarn importwarn builtin foreignCode highlighting-            libPragmaO filePragmaO-            oUsed patternS warnings partialdefs) =--    hang "Interface" 2 $ vcat-      [ "source hash:"         <+> (pretty . show) sourceH-      , "source:"              $$  nest 2 (text $ TL.unpack source)-      , "file type:"           <+> (pretty . show) fileT-      , "imported modules:"    <+> (pretty . show) importedM-      , "module name:"         <+> pretty moduleN-      , "scope:"               <+> (pretty . show) scope-      , "inside scope:"        <+> (pretty . show) insideS-      , "signature:"           <+> (pretty . show) signature-      , "display:"             <+> (pretty . show) display-      , "user warnings:"       <+> (pretty . show) userwarn-      , "import warning:"      <+> (pretty . show) importwarn-      , "builtin:"             <+> (pretty . show) builtin-      , "Foreign code:"        <+> (pretty . show) foreignCode-      , "highlighting:"        <+> (pretty . show) highlighting-      , "library pragma options:" <+> (pretty . show) libPragmaO-      , "file pragma options:" <+> (pretty . show) filePragmaO-      , "options used:"        <+> (pretty . show) oUsed-      , "pattern syns:"        <+> (pretty . show) patternS-      , "warnings:"            <+> (pretty . show) warnings-      , "partial definitions:" <+> (pretty . show) partialdefs-      ]---- | Combines the source hash and the (full) hashes of the imported modules.-iFullHash :: Interface -> Hash-iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)---- | A lens for the 'iSignature' field of the 'Interface' type.--intSignature :: Lens' Signature Interface-intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s }-------------------------------------------------------------------------------- ** Closure------------------------------------------------------------------------------data Closure a = Closure-  { clSignature        :: Signature-  , clEnv              :: TCEnv-  , clScope            :: ScopeInfo-  , clModuleCheckpoints :: Map ModuleName CheckpointId-  , clValue            :: a-  }-    deriving (Functor, Foldable, Generic)--instance Show a => Show (Closure a) where-  show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }"--instance HasRange a => HasRange (Closure a) where-  getRange = getRange . clValue--class LensClosure a b | b -> a where-  lensClosure :: Lens' (Closure a) b--instance LensClosure a (Closure a) where-  lensClosure = id--instance LensTCEnv (Closure a) where-  lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }--buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a)-buildClosure x = do-    env   <- askTC-    sig   <- useR stSignature-    scope <- useR stScope-    cps   <- useR stModuleCheckpoints-    return $ Closure sig env scope cps x-------------------------------------------------------------------------------- ** Constraints------------------------------------------------------------------------------type Constraints = [ProblemConstraint]--data ProblemConstraint = PConstr-  { constraintProblems  :: Set ProblemId-  , constraintUnblocker :: Blocker-  , theConstraint       :: Closure Constraint-  }-  deriving (Show, Generic)--instance HasRange ProblemConstraint where-  getRange = getRange . theConstraint--data Constraint-  = ValueCmp Comparison CompareAs Term Term-  | ValueCmpOnFace Comparison Term Type Term Term-  | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim]-  | SortCmp Comparison Sort Sort-  | LevelCmp Comparison Level Level---  | ShortCut MetaId Term Type---    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.-  | HasBiggerSort Sort-  | HasPTSRule (Dom Type) (Abs Sort)-  | CheckMetaInst MetaId-  | CheckType Type-  | UnBlock MetaId-    -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved-    --   constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst'-    --   or 'PostponedTypeCheckingProblem'.-  | IsEmpty Range Type-    -- ^ The range is the one of the absurd pattern.-  | CheckSizeLtSat Term-    -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT.-  | FindInstance MetaId (Maybe [Candidate])-    -- ^ the first argument is the instance argument and the second one is the list of candidates-    --   (or Nothing if we haven’t determined the list of candidates yet)-  | CheckFunDef Delayed A.DefInfo QName [A.Clause] TCErr-    -- ^ Last argument is the error causing us to postpone.-  | UnquoteTactic Term Term Type   -- ^ First argument is computation and the others are hole and goal type-  | CheckLockedVars Term Type (Arg Term) Type     -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed.-  | UsableAtModality Modality Term   -- ^ is the term usable at the given modality?-  deriving (Show, Generic)--instance HasRange Constraint where-  getRange (IsEmpty r t) = r-  getRange _ = noRange-{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId-  getRange (ValueCmp cmp a u v) = getRange (a,u,v)-  getRange (ElimCmp pol a v es es') = getRange (a,v,es,es')-  getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel')-  getRange (SortCmp cmp s s') = getRange (s,s')-  getRange (LevelCmp cmp l l') = getRange (l,l')-  getRange (UnBlock x) = getRange x-  getRange (FindInstance x cands) = getRange x--}--instance Free Constraint where-  freeVars' c =-    case c of-      ValueCmp _ t u v      -> freeVars' (t, (u, v))-      ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v)))-      ElimCmp _ _ t u es es'  -> freeVars' ((t, u), (es, es'))-      SortCmp _ s s'        -> freeVars' (s, s')-      LevelCmp _ l l'       -> freeVars' (l, l')-      UnBlock _             -> mempty-      IsEmpty _ t           -> freeVars' t-      CheckSizeLtSat u      -> freeVars' u-      FindInstance _ cs     -> freeVars' cs-      CheckFunDef{}         -> mempty-      HasBiggerSort s       -> freeVars' s-      HasPTSRule a s        -> freeVars' (a , s)-      CheckLockedVars a b c d -> freeVars' ((a,b),(c,d))-      UnquoteTactic t h g   -> freeVars' (t, (h, g))-      CheckMetaInst m       -> mempty-      CheckType t           -> freeVars' t-      UsableAtModality mod t -> freeVars' t--instance TermLike Constraint where-  foldTerm f = \case-      ValueCmp _ t u v       -> foldTerm f (t, u, v)-      ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v)-      ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es')-      LevelCmp _ l l'        -> foldTerm f (Level l, Level l')  -- Note wrapping as term, to ensure f gets to act on l and l'-      IsEmpty _ t            -> foldTerm f t-      CheckSizeLtSat u       -> foldTerm f u-      UnquoteTactic t h g    -> foldTerm f (t, h, g)-      SortCmp _ s1 s2        -> foldTerm f (Sort s1, Sort s2)   -- Same as LevelCmp case-      UnBlock _              -> mempty-      CheckLockedVars a b c d -> foldTerm f (a, b, c, d)-      FindInstance _ _       -> mempty-      CheckFunDef{}          -> mempty-      HasBiggerSort s        -> foldTerm f s-      HasPTSRule a s         -> foldTerm f (a, Sort <$> s)-      CheckMetaInst m        -> mempty-      CheckType t            -> foldTerm f t-      UsableAtModality m t   -> foldTerm f t--  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented--instance AllMetas Constraint--data Comparison = CmpEq | CmpLeq-  deriving (Eq, Data, Show, Generic)--instance Pretty Comparison where-  pretty CmpEq  = "="-  pretty CmpLeq = "=<"---- | An extension of 'Comparison' to @>=@.-data CompareDirection = DirEq | DirLeq | DirGeq-  deriving (Eq, Show)--instance Pretty CompareDirection where-  pretty = text . \case-    DirEq  -> "="-    DirLeq -> "=<"-    DirGeq -> ">="---- | Embed 'Comparison' into 'CompareDirection'.-fromCmp :: Comparison -> CompareDirection-fromCmp CmpEq  = DirEq-fromCmp CmpLeq = DirLeq---- | Flip the direction of comparison.-flipCmp :: CompareDirection -> CompareDirection-flipCmp DirEq  = DirEq-flipCmp DirLeq = DirGeq-flipCmp DirGeq = DirLeq---- | Turn a 'Comparison' function into a 'CompareDirection' function.------   Property: @dirToCmp f (fromCmp cmp) = f cmp@-dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c-dirToCmp cont DirEq  = cont CmpEq-dirToCmp cont DirLeq = cont CmpLeq-dirToCmp cont DirGeq = flip $ cont CmpLeq---- | We can either compare two terms at a given type, or compare two---   types without knowing (or caring about) their sorts.-data CompareAs-  = AsTermsOf Type -- ^ @Type@ should not be @Size@.-                   --   But currently, we do not rely on this invariant.-  | AsSizes        -- ^ Replaces @AsTermsOf Size@.-  | AsTypes-  deriving (Data, Show, Generic)--instance Free CompareAs where-  freeVars' (AsTermsOf a) = freeVars' a-  freeVars' AsSizes       = mempty-  freeVars' AsTypes       = mempty--instance TermLike CompareAs where-  foldTerm f (AsTermsOf a) = foldTerm f a-  foldTerm f AsSizes       = mempty-  foldTerm f AsTypes       = mempty--  traverseTermM f = \case-    AsTermsOf a -> AsTermsOf <$> traverseTermM f a-    AsSizes     -> return AsSizes-    AsTypes     -> return AsTypes--instance AllMetas CompareAs-------------------------------------------------------------------------------- * Open things-------------------------------------------------------------------------------- | A thing tagged with the context it came from. Also keeps the substitution from previous---   checkpoints. This lets us handle the case when an open thing was created in a context that we---   have since exited. Remember which module it's from to make sure we don't get confused by---   checkpoints from other files.-data Open a = OpenThing { openThingCheckpoint    :: CheckpointId-                        , openThingCheckpointMap :: Map CheckpointId Substitution-                        , openThingModule        :: ModuleNameHash-                        , openThing              :: a }-    deriving (Show, Functor, Foldable, Traversable, Generic)--instance Decoration Open where-  traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x--instance Pretty a => Pretty (Open a) where-  prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $-    "OpenThing" <+> pretty cp <+> pretty (Map.toList env) <?> prettyPrec 10 x-------------------------------------------------------------------------------- * Judgements------ Used exclusively for typing of meta variables.-------------------------------------------------------------------------------- | Parametrized since it is used without MetaId when creating a new meta.-data Judgement a-  = HasType-    { jMetaId     :: a-    , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type?-    , jMetaType   :: Type-    }-  | IsSort-    { jMetaId   :: a-    , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas-    }-  deriving Generic--instance Pretty a => Pretty (Judgement a) where-    pretty (HasType a cmp t) = hsep [ pretty a, ":"    , pretty t ]-    pretty (IsSort  a t)     = hsep [ pretty a, ":sort", pretty t ]---------------------------------------------------------------------------------- ** Generalizable variables--------------------------------------------------------------------------------data DoGeneralize-  = YesGeneralizeVar  -- ^ Generalize because it is a generalizable variable.-  | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and-                      --   we're currently checking the type of a generalizable variable-                      --   (this should get the default modality).-  | NoGeneralize      -- ^ Don't generalize.-  deriving (Eq, Ord, Show, Data, Generic)---- | The value of a generalizable variable. This is created to be a---   generalizable meta before checking the type to be generalized.-data GeneralizedValue = GeneralizedValue-  { genvalCheckpoint :: CheckpointId-  , genvalTerm       :: Term-  , genvalType       :: Type-  } deriving (Show, Data, Generic)-------------------------------------------------------------------------------- ** Meta variables------------------------------------------------------------------------------data MetaVariable =-        MetaVar { mvInfo          :: MetaInfo-                , mvPriority      :: MetaPriority -- ^ some metavariables are more eager to be instantiated-                , mvPermutation   :: Permutation-                  -- ^ a metavariable doesn't have to depend on all variables-                  --   in the context, this "permutation" will throw away the-                  --   ones it does not depend on-                , mvJudgement     :: Judgement MetaId-                , mvInstantiation :: MetaInstantiation-                , mvListeners     :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one-                , mvFrozen        :: Frozen -- ^ are we past the point where we can instantiate this meta variable?-                , mvTwin          :: Maybe MetaId-                  -- ^ @Just m@ means that this meta-variable will be-                  -- equated to @m@ when the latter is unblocked. See-                  -- 'Agda.TypeChecking.MetaVars.blockTermOnProblem'.-                }-  deriving Generic--data Listener = EtaExpand MetaId-              | CheckConstraint Nat ProblemConstraint-  deriving Generic--instance Eq Listener where-  EtaExpand       x   == EtaExpand       y   = x == y-  CheckConstraint x _ == CheckConstraint y _ = x == y-  _ == _ = False--instance Ord Listener where-  EtaExpand       x   `compare` EtaExpand       y   = x `compare` y-  CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y-  EtaExpand{} `compare` CheckConstraint{} = LT-  CheckConstraint{} `compare` EtaExpand{} = GT---- | Frozen meta variable cannot be instantiated by unification.---   This serves to prevent the completion of a definition by its use---   outside of the current block.---   (See issues 118, 288, 399).-data Frozen-  = Frozen        -- ^ Do not instantiate.-  | Instantiable-    deriving (Eq, Show, Generic)--data MetaInstantiation-        = InstV [Arg String] Term -- ^ solved by term (abstracted over some free variables)-        | Open               -- ^ unsolved-        | OpenInstance       -- ^ open, to be instantiated by instance search-        | BlockedConst Term  -- ^ solution blocked by unsolved constraints-        | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)-  deriving Generic---- | Solving a 'CheckArgs' constraint may or may not check the target type. If---   it did, it returns a handle to any unsolved constraints.-data CheckedTarget = CheckedTarget (Maybe ProblemId)-                   | NotCheckedTarget--data PrincipalArgTypeMetas = PrincipalArgTypeMetas-  { patmMetas     :: Args -- ^ metas created for hidden and instance arguments-                          --   in the principal argument's type-  , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and-                          --   instance arguments-  }-  deriving Generic--data TypeCheckingProblem-  = CheckExpr Comparison A.Expr Type-  | CheckArgs Comparison ExpandHidden Range [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)-  | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Args Type Int Term Type PrincipalArgTypeMetas-  | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type-    -- ^ @(λ (xs : t₀) → e) : t@-    --   This is not an instance of 'CheckExpr' as the domain type-    --   has already been checked.-    --   For example, when checking-    --     @(λ (x y : Fin _) → e) : (x : Fin n) → ?@-    --   we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@-    --   is a 'Type' rather than an 'A.Expr'.-  | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`-  deriving Generic--instance Show MetaInstantiation where-  show (InstV tel t) = "InstV " ++ show tel ++ " (" ++ show t ++ ")"-  show Open      = "Open"-  show OpenInstance = "OpenInstance"-  show (BlockedConst t) = "BlockedConst (" ++ show t ++ ")"-  show (PostponedTypeCheckingProblem{}) = "PostponedTypeCheckingProblem (...)"---- | Meta variable priority:---   When we have an equation between meta-variables, which one---   should be instantiated?------   Higher value means higher priority to be instantiated.-newtype MetaPriority = MetaPriority Int-    deriving (Eq, Ord, Show, NFData)--data RunMetaOccursCheck-  = RunMetaOccursCheck-  | DontRunMetaOccursCheck-  deriving (Eq, Ord, Show, Generic)---- | @MetaInfo@ is cloned from one meta to the next during pruning.-data MetaInfo = MetaInfo-  { miClosRange       :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range.-  , miModality        :: Modality           -- ^ Instantiable with irrelevant/erased solution?-  , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions?-  , miNameSuggestion  :: MetaNameSuggestion-    -- ^ Used for printing.-    --   @Just x@ if meta-variable comes from omitted argument with name @x@.-  , miGeneralizable   :: Arg DoGeneralize-    -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo?-  }-  deriving Generic--instance LensModality MetaInfo where-  getModality = miModality-  setModality mod mi = mi { miModality = mod }-  mapModality f mi = mi { miModality = f $ miModality mi }--instance LensQuantity MetaInfo where-  getQuantity   = getQuantity . getModality-  mapQuantity f = mapModality (mapQuantity f)---- | Name suggestion for meta variable.  Empty string means no suggestion.-type MetaNameSuggestion = String---- | For printing, we couple a meta with its name suggestion.-data NamedMeta = NamedMeta-  { nmSuggestion :: MetaNameSuggestion-  , nmid         :: MetaId-  }--instance Pretty NamedMeta where-  pretty (NamedMeta "" x) = pretty x-  pretty (NamedMeta "_" x) = pretty x-  pretty (NamedMeta s  x) = text $ "_" ++ s ++ prettyShow x--type MetaStore = IntMap MetaVariable--instance HasRange MetaInfo where-  getRange = clValue . miClosRange--instance HasRange MetaVariable where-    getRange m = getRange $ getMetaInfo m--instance SetRange MetaInfo where-  setRange r m = m { miClosRange = (miClosRange m) { clValue = r }}--instance SetRange MetaVariable where-  setRange r m = m { mvInfo = setRange r (mvInfo m) }--instance LensModality MetaVariable where-  getModality = getModality . mvInfo-  setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv }-  mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv }--instance LensQuantity MetaVariable where-  getQuantity   = getQuantity . getModality-  mapQuantity f = mapModality (mapQuantity f)--normalMetaPriority :: MetaPriority-normalMetaPriority = MetaPriority 0--lowMetaPriority :: MetaPriority-lowMetaPriority = MetaPriority (-10)--highMetaPriority :: MetaPriority-highMetaPriority = MetaPriority 10--getMetaInfo :: MetaVariable -> Closure Range-getMetaInfo = miClosRange . mvInfo--getMetaScope :: MetaVariable -> ScopeInfo-getMetaScope m = clScope $ getMetaInfo m--getMetaEnv :: MetaVariable -> TCEnv-getMetaEnv m = clEnv $ getMetaInfo m--getMetaSig :: MetaVariable -> Signature-getMetaSig m = clSignature $ getMetaInfo m--getMetaRelevance :: MetaVariable -> Relevance-getMetaRelevance = getRelevance . getModality--getMetaModality :: MetaVariable -> Modality-getMetaModality = getModality---- Lenses--metaFrozen :: Lens' Frozen MetaVariable-metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }--_mvInfo :: Lens' MetaInfo MetaVariable-_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }---- Lenses onto Closure Range--instance LensClosure Range MetaInfo where-  lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }--instance LensClosure Range MetaVariable where-  lensClosure = _mvInfo . lensClosure---- Lenses onto IsAbstract--instance LensIsAbstract TCEnv where-  lensIsAbstract f env =-     -- Andreas, 2019-08-19-     -- Using $! to prevent space leaks like #1829.-     -- This can crash when trying to get IsAbstract from IgnoreAbstractMode.-    (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env))-    <&> \ a -> env { envAbstractMode = aDefToMode a }--instance LensIsAbstract (Closure a) where-  lensIsAbstract = lensTCEnv . lensIsAbstract--instance LensIsAbstract MetaInfo where-  lensIsAbstract = lensClosure . lensIsAbstract-------------------------------------------------------------------------------- ** Interaction meta variables-------------------------------------------------------------------------------- | Interaction points are created by the scope checker who sets the range.---   The meta variable is created by the type checker and then hooked up to the---   interaction point.-data InteractionPoint = InteractionPoint-  { ipRange :: Range        -- ^ The position of the interaction point.-  , ipMeta  :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.-  , ipSolved:: Bool         -- ^ Has this interaction point already been solved?-  , ipClause:: IPClause-      -- ^ The clause of the interaction point (if any).-      --   Used for case splitting.-  }-  deriving Generic--instance Eq InteractionPoint where (==) = (==) `on` ipMeta--instance HasTag InteractionPoint where-  type Tag InteractionPoint = MetaId-  tag = ipMeta---- | Data structure managing the interaction points.------   We never remove interaction points from this map, only set their---   'ipSolved' to @True@.  (Issue #2368)-type InteractionPoints = BiMap InteractionId InteractionPoint---- | Flag to indicate whether the meta is overapplied in the---   constraint.  A meta is overapplied if it has more arguments than---   the size of the telescope in its creation environment---   (as stored in MetaInfo).-data Overapplied = Overapplied | NotOverapplied-  deriving (Eq, Show, Data, Generic)---- | Datatype representing a single boundary condition:---   x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es-data IPBoundary' t = IPBoundary-  { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n]-  , ipbValue     :: t          -- ^ @t@-  , ipbMetaApp   :: t          -- ^ @?n es@-  , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ?-  }-  deriving (Show, Data, Functor, Foldable, Traversable, Generic)--type IPBoundary = IPBoundary' Term---- | Which clause is an interaction point located in?-data IPClause = IPClause-  { ipcQName    :: QName              -- ^ The name of the function.-  , ipcClauseNo :: Int                -- ^ The number of the clause of this function.-  , ipcType     :: Type               -- ^ The type of the function-  , ipcWithSub  :: Maybe Substitution -- ^ Module parameter substitution-  , ipcClause   :: A.SpineClause      -- ^ The original AST clause.-  , ipcClosure  :: Closure ()         -- ^ Environment for rechecking the clause.-  , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS.-  }-  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.-  deriving (Generic)--instance Eq IPClause where-  IPNoClause           == IPNoClause             = True-  IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i'-  _                    == _                      = False-------------------------------------------------------------------------------- ** Signature------------------------------------------------------------------------------data Signature = Sig-      { _sigSections    :: Sections-      , _sigDefinitions :: Definitions-      , _sigRewriteRules:: RewriteRuleMap  -- ^ The rewrite rules defined in this file.-      }-  deriving (Show, Generic)--sigSections :: Lens' Sections Signature-sigSections f s =-  f (_sigSections s) <&>-  \x -> s {_sigSections = x}--sigDefinitions :: Lens' Definitions Signature-sigDefinitions f s =-  f (_sigDefinitions s) <&>-  \x -> s {_sigDefinitions = x}--sigRewriteRules :: Lens' RewriteRuleMap Signature-sigRewriteRules f s =-  f (_sigRewriteRules s) <&>-  \x -> s {_sigRewriteRules = x}--type Sections    = Map ModuleName Section-type Definitions = HashMap QName Definition-type RewriteRuleMap = HashMap QName RewriteRules-type DisplayForms = HashMap QName [LocalDisplayForm]--newtype Section = Section { _secTelescope :: Telescope }-  deriving (Data, Show, NFData)--instance Pretty Section where-  pretty = pretty . _secTelescope--secTelescope :: Lens' Telescope Section-secTelescope f s =-  f (_secTelescope s) <&>-  \x -> s {_secTelescope = x}--emptySignature :: Signature-emptySignature = Sig Map.empty HMap.empty HMap.empty---- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a---   constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a---   more readable 'Abstract.Syntax'.------   The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables---   that matches any term.-data DisplayForm = Display-  { dfPatternVars :: Nat-    -- ^ Number @n@ of pattern variables in 'dfPats'.-  , dfPats :: Elims-    -- ^ Left hand side patterns, the @n@ first free variables are pattern variables,-    --   any variables above @n@ are fixed and only match that particular variable. This-    --   happens when you have display forms inside parameterised modules that match on the module-    --   parameters. The 'ArgInfo' is ignored in these patterns.-  , dfRHS :: DisplayTerm-    -- ^ Right hand side.-  }-  deriving (Data, Show, Generic)--type LocalDisplayForm = Open DisplayForm---- | A structured presentation of a 'Term' for reification into---   'Abstract.Syntax'.-data DisplayTerm-  = DWithApp DisplayTerm [DisplayTerm] Elims-    -- ^ @(f vs | ws) es@.-    --   The first 'DisplayTerm' is the parent function @f@ with its args @vs@.-    --   The list of 'DisplayTerm's are the with expressions @ws@.-    --   The 'Elims' are additional arguments @es@-    --   (possible in case the with-application is of function type)-    --   or projections (if it is of record type).-  | DCon ConHead ConInfo [Arg DisplayTerm]-    -- ^ @c vs@.-  | DDef QName [Elim' DisplayTerm]-    -- ^ @d vs@.-  | DDot Term-    -- ^ @.v@.-  | DTerm Term-    -- ^ @v@.-  deriving (Data, Show, Generic)--instance Free DisplayForm where-  freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t)--instance Free DisplayTerm where-  freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))-  freeVars' (DCon _ _ vs)      = freeVars' vs-  freeVars' (DDef _ es)        = freeVars' es-  freeVars' (DDot v)           = freeVars' v-  freeVars' (DTerm v)          = freeVars' v--instance Pretty DisplayTerm where-  prettyPrec p v =-    case v of-      DTerm v          -> prettyPrec p v-      DDot v           -> "." <> prettyPrec 10 v-      DDef f es        -> pretty f `pApp` es-      DCon c _ vs      -> pretty (conName c) `pApp` map Apply vs-      DWithApp h ws es ->-        mparens (p > 0)-          (sep [ pretty h-              , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ])-        `pApp` es-    where-      pApp :: Pretty el => Doc -> [el] -> Doc-      pApp d els = mparens (not (null els) && p > 9) $-                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]--instance Pretty DisplayForm where-  prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $-    "Display" <?> fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ]---- | By default, we have no display form.-defaultDisplayForm :: QName -> [LocalDisplayForm]-defaultDisplayForm c = []---- | Non-linear (non-constructor) first-order pattern.-data NLPat-  = PVar !Int [Arg Int]-    -- ^ Matches anything (modulo non-linearity) that only contains bound-    --   variables that occur in the given arguments.-  | PDef QName PElims-    -- ^ Matches @f es@-  | PLam ArgInfo (Abs NLPat)-    -- ^ Matches @λ x → t@-  | PPi (Dom NLPType) (Abs NLPType)-    -- ^ Matches @(x : A) → B@-  | PSort NLPSort-    -- ^ Matches a sort of the given shape.-  | PBoundVar {-# UNPACK #-} !Int PElims-    -- ^ Matches @x es@ where x is a lambda-bound variable-  | PTerm Term-    -- ^ Matches the term modulo β (ideally βη).-  deriving (Data, Show, Generic)-type PElims = [Elim' NLPat]--data NLPType = NLPType-  { nlpTypeSort :: NLPSort-  , nlpTypeUnEl :: NLPat-  } deriving (Data, Show, Generic)--data NLPSort-  = PType NLPat-  | PProp NLPat-  | PInf IsFibrant Integer-  | PSizeUniv-  | PLockUniv-  deriving (Data, Show, Generic)--type RewriteRules = [RewriteRule]---- | Rewrite rules can be added independently from function clauses.-data RewriteRule = RewriteRule-  { rewName    :: QName      -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@-                             --   where @≡@ is the rewrite relation.-  , rewContext :: Telescope  -- ^ @Γ@.-  , rewHead    :: QName      -- ^ @f@.-  , rewPats    :: PElims     -- ^ @Γ ⊢ f ps : t@.-  , rewRHS     :: Term       -- ^ @Γ ⊢ rhs : t@.-  , rewType    :: Type       -- ^ @Γ ⊢ t@.-  , rewFromClause :: Bool    -- ^ Was this rewrite rule created from a clause in the definition of the function?-  }-    deriving (Data, Show, Generic)--data Definition = Defn-  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.-  , defName           :: QName   -- ^ The canonical name, used e.g. in compilation.-  , defType           :: Type    -- ^ Type of the lifted definition.-  , defPolarity       :: [Polarity]-    -- ^ Variance information on arguments of the definition.-    --   Does not include info for dropped parameters to-    --   projection(-like) functions and constructors.-  , defArgOccurrences :: [Occurrence]-    -- ^ Positivity information on arguments of the definition.-    --   Does not include info for dropped parameters to-    --   projection(-like) functions and constructors.--    --   Sometimes Agda looks up 'Occurrence's in these lists based on-    --   their position, so one might consider replacing the list-    --   with, say, an 'IntMap'. However, presumably these lists tend-    --   to be short, in which case 'IntMap's could be slower than-    --   lists. For instance, at one point the longest list-    --   encountered for the standard library (in serialised-    --   interfaces) had length 27. Distribution:-    ---    --   Length, number of lists-    --   ------------------------    ---    --    0, 2444-    --    1,  721-    --    2,  433-    --    3,  668-    --    4,  602-    --    5,  624-    --    6,  626-    --    7,  484-    --    8,  375-    --    9,  264-    --   10,  305-    --   11,  188-    --   12,  171-    --   13,  108-    --   14,   84-    --   15,   80-    --   16,   38-    --   17,   23-    --   18,   16-    --   19,    8-    --   20,    7-    --   21,    5-    --   22,    2-    --   23,    3-    --   27,    1--  , defArgGeneralizable :: NumGeneralizableArgs-    -- ^ How many arguments should be generalised.-  , defGeneralizedParams :: [Maybe Name]-    -- ^ Gives the name of the (bound variable) parameter for named generalized-    --   parameters. This is needed to bring it into scope when type checking-    --   the data/record definition corresponding to a type with generalized-    --   parameters.-  , defDisplay        :: [LocalDisplayForm]-  , defMutual         :: MutualId-  , defCompiledRep    :: CompiledRepresentation-  , defInstance       :: Maybe QName-    -- ^ @Just q@ when this definition is an instance of class q-  , defCopy           :: Bool-    -- ^ Has this function been created by a module-                         -- instantiation?-  , defMatchable      :: Set QName-    -- ^ The set of symbols with rewrite rules that match against this symbol-  , defNoCompilation  :: Bool-    -- ^ should compilers skip this? Used for e.g. cubical's comp-  , defInjective      :: Bool-    -- ^ Should the def be treated as injective by the pattern matching unifier?-  , defCopatternLHS   :: Bool-    -- ^ Is this a function defined by copatterns?-  , defBlocked        :: Blocked_-    -- ^ What blocking tag to use when we cannot reduce this def?-    --   Used when checking a function definition is blocked on a meta-    --   in the type.-  , defLanguage       :: !Language-    -- ^ The language used for the definition.-  , theDef            :: Defn-  }-    deriving (Show, Generic)--instance LensArgInfo Definition where-  getArgInfo = defArgInfo-  mapArgInfo f def = def { defArgInfo = f $ defArgInfo def }--instance LensModality  Definition where-instance LensQuantity  Definition where-instance LensRelevance Definition where--data NumGeneralizableArgs-  = NoGeneralizableArgs-  | SomeGeneralizableArgs !Int-    -- ^ When lambda-lifting new args are generalizable if-    --   'SomeGeneralizableArgs', also when the number is zero.-  deriving (Data, Show)--theDefLens :: Lens' Defn Definition-theDefLens f d = f (theDef d) <&> \ df -> d { theDef = df }---- | Create a definition with sensible defaults.-defaultDefn ::-  ArgInfo -> QName -> Type -> Language -> Defn -> Definition-defaultDefn info x t lang def = Defn-  { defArgInfo        = info-  , defName           = x-  , defType           = t-  , defPolarity       = []-  , defArgOccurrences = []-  , defArgGeneralizable = NoGeneralizableArgs-  , defGeneralizedParams = []-  , defDisplay        = defaultDisplayForm x-  , defMutual         = 0-  , defCompiledRep    = noCompiledRep-  , defInstance       = Nothing-  , defCopy           = False-  , defMatchable      = Set.empty-  , defNoCompilation  = False-  , defInjective      = False-  , defCopatternLHS   = False-  , defBlocked        = NotBlocked ReallyNotBlocked ()-  , defLanguage       = lang-  , theDef            = def-  }---- | Polarity for equality and subtype checking.-data Polarity-  = Covariant      -- ^ monotone-  | Contravariant  -- ^ antitone-  | Invariant      -- ^ no information (mixed variance)-  | Nonvariant     -- ^ constant-  deriving (Data, Show, Eq, Generic)--instance Pretty Polarity where-  pretty = text . \case-    Covariant     -> "+"-    Contravariant -> "-"-    Invariant     -> "*"-    Nonvariant    -> "_"---- | Information about whether an argument is forced by the type of a function.-data IsForced-  = Forced-  | NotForced-  deriving (Data, Show, Eq, Generic)---- | The backends are responsible for parsing their own pragmas.-data CompilerPragma = CompilerPragma Range String-  deriving (Data, Show, Eq, Generic)--instance HasRange CompilerPragma where-  getRange (CompilerPragma r _) = r--type BackendName    = String--jsBackendName, ghcBackendName :: BackendName-jsBackendName  = "JS"-ghcBackendName = "GHC"--type CompiledRepresentation = Map BackendName [CompilerPragma]--noCompiledRep :: CompiledRepresentation-noCompiledRep = Map.empty---- A face represented as a list of equality constraints.--- (r,False) ↦ (r = i0)--- (r,True ) ↦ (r = i1)-type Face = [(Term,Bool)]---- | An alternative representation of partial elements in a telescope:---   Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T---   see cubicaltt paper (however we do not store the type T).-data System = System-  { systemTel :: Telescope-    -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ-  , systemClauses :: [(Face,Term)]-    -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ-  } deriving (Data, Show, Generic)---- | Additional information for extended lambdas.-data ExtLamInfo = ExtLamInfo-  { extLamModule    :: ModuleName-    -- ^ For complicated reasons the scope checker decides the QName of a-    --   pattern lambda, and thus its module. We really need to decide the-    --   module during type checking though, since if the lambda appears in a-    --   refined context the module picked by the scope checker has very much-    --   the wrong parameters.-  , extLamAbsurd :: Bool-    -- ^ Was this definition created from an absurd lambda @λ ()@?-  , extLamSys :: !(Strict.Maybe System)-  } deriving (Data, Show, Generic)--modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo-modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e'---- | Additional information for projection 'Function's.-data Projection = Projection-  { projProper    :: Maybe QName-    -- ^ @Nothing@ if only projection-like, @Just r@ if record projection.-    --   The @r@ is the name of the record type projected from.-    --   This field is updated by module application.-  , projOrig      :: QName-    -- ^ The original projection name-    --   (current name could be from module application).-  , projFromType  :: Arg QName-    -- ^ Type projected from. Original record type if @projProper = Just{}@.-    --   Also stores @ArgInfo@ of the principal argument.-    --   This field is unchanged by module application.-  , projIndex     :: Int-    -- ^ Index of the record argument.-    --   Start counting with 1, because 0 means that-    --   it is already applied to the record value.-    --   This can happen in module instantiation, but-    --   then either the record value is @var 0@, or @funProjection == Nothing@.-  , projLams :: ProjLams-    -- ^ Term @t@ to be be applied to record parameters and record value.-    --   The parameters will be dropped.-    --   In case of a proper projection, a postfix projection application-    --   will be created: @t = \ pars r -> r .p@-    --   (Invariant: the number of abstractions equals 'projIndex'.)-    --   In case of a projection-like function, just the function symbol-    --   is returned as 'Def':  @t = \ pars -> f@.-  } deriving (Data, Show, Generic)---- | Abstractions to build projection function (dropping parameters).-newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }-  deriving (Data, Show, Null, Generic)---- | Building the projection function (which drops the parameters).-projDropPars :: Projection -> ProjOrigin -> Term--- Proper projections:-projDropPars (Projection Just{} d _ _ lams) o =-  case initLast $ getProjLams lams of-    Nothing -> Def d []-    Just (pars, Arg i y) ->-      let core = Lam i $ Abs y $ Var 0 [Proj o d] in-      List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars--- Projection-like functions:-projDropPars (Projection Nothing d _ _ lams) o =-  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $-    initWithDefault __IMPOSSIBLE__ $ getProjLams lams---- | The info of the principal (record) argument.-projArgInfo :: Projection -> ArgInfo-projArgInfo (Projection _ _ _ _ lams) =-  maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams---- | Should a record type admit eta-equality?-data EtaEquality-  = Specified { theEtaEquality :: !HasEta }  -- ^ User specifed 'eta-equality' or 'no-eta-equality'.-  | Inferred  { theEtaEquality :: !HasEta }  -- ^ Positivity checker inferred whether eta is safe.-  deriving (Data, Show, Eq, Generic)--instance PatternMatchingAllowed EtaEquality where-  patternMatchingAllowed = patternMatchingAllowed . theEtaEquality--instance CopatternMatchingAllowed EtaEquality where-  copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality---- | Make sure we do not overwrite a user specification.-setEtaEquality :: EtaEquality -> HasEta -> EtaEquality-setEtaEquality e@Specified{} _ = e-setEtaEquality _ b = Inferred b--data FunctionFlag-  = FunStatic  -- ^ Should calls to this function be normalised at compile-time?-  | FunInline  -- ^ Should calls to this function be inlined by the compiler?-  | FunMacro   -- ^ Is this function a macro?-  deriving (Data, Eq, Ord, Enum, Show, Generic)--data CompKit = CompKit-  { nameOfHComp :: Maybe QName-  , nameOfTransp :: Maybe QName-  }-  deriving (Data, Eq, Ord, Show, Generic)--emptyCompKit :: CompKit-emptyCompKit = CompKit Nothing Nothing--defaultAxiom :: Defn-defaultAxiom = Axiom False--constTranspAxiom :: Defn-constTranspAxiom = Axiom True--data Defn = Axiom -- ^ Postulate-            { axiomConstTransp :: Bool-              -- ^ Can transp for this postulate be constant?-              --   Set to @True@ for bultins like String.-            }-          | DataOrRecSig-            { datarecPars :: Int }-            -- ^ Data or record type signature that doesn't yet have a definition-          | GeneralizableVar -- ^ Generalizable variable (introduced in `generalize` block)-          | AbstractDefn Defn-            -- ^ Returned by 'getConstInfo' if definition is abstract.-          | Function-            { funClauses        :: [Clause]-            , funCompiled       :: Maybe CompiledClauses-              -- ^ 'Nothing' while function is still type-checked.-              --   @Just cc@ after type and coverage checking and-              --   translation to case trees.-            , funSplitTree      :: Maybe SplitTree-              -- ^ The split tree constructed by the coverage-              --   checker. Needed to re-compile the clauses after-              --   forcing translation.-            , funTreeless       :: Maybe Compiled-              -- ^ Intermediate representation for compiler backends.-            , funCovering       :: [Clause]-              -- ^ Covering clauses computed by coverage checking.-              --   Erased by (IApply) confluence checking(?)-            , funInv            :: FunctionInverse-            , funMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this function.-              --   Empty list if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , funAbstr          :: IsAbstract-            , funDelayed        :: Delayed-              -- ^ Are the clauses of this definition delayed?-            , funProjection     :: Maybe Projection-              -- ^ Is it a record projection?-              --   If yes, then return the name of the record type and index of-              --   the record argument.  Start counting with 1, because 0 means that-              --   it is already applied to the record. (Can happen in module-              --   instantiation.) This information is used in the termination-              --   checker.-            , funFlags          :: Set FunctionFlag-            , funTerminates     :: Maybe Bool-              -- ^ Has this function been termination checked?  Did it pass?-            , funExtLam         :: Maybe ExtLamInfo-              -- ^ Is this function generated from an extended lambda?-              --   If yes, then return the number of hidden and non-hidden lambda-lifted arguments-            , funWith           :: Maybe QName-              -- ^ Is this a generated with-function? If yes, then what's the-              --   name of the parent function.-            }-          | Datatype-            { dataPars           :: Nat            -- ^ Number of parameters.-            , dataIxs            :: Nat            -- ^ Number of indices.-            , dataClause         :: (Maybe Clause) -- ^ This might be in an instantiated module.-            , dataCons           :: [QName]-              -- ^ Constructor names , ordered according to the order of their definition.-            , dataSort           :: Sort-            , dataMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this data type.-              --   Empty if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , dataAbstr          :: IsAbstract-            , dataPathCons       :: [QName]        -- ^ Path constructor names (subset of dataCons)-            }-          | Record-            { recPars           :: Nat-              -- ^ Number of parameters.-            , recClause         :: Maybe Clause-              -- ^ Was this record type created by a module application?-              --   If yes, the clause is its definition (linking back to the original record type).-            , recConHead        :: ConHead-              -- ^ Constructor name and fields.-            , recNamedCon       :: Bool-              -- ^ Does this record have a @constructor@?-            , recFields         :: [Dom QName]-              -- ^ The record field names.-            , recTel            :: Telescope-              -- ^ The record field telescope. (Includes record parameters.)-              --   Note: @TelV recTel _ == telView' recConType@.-              --   Thus, @recTel@ is redundant.-            , recMutual         :: Maybe [QName]-              -- ^ Mutually recursive functions, @data@s and @record@s.-              --   Does include this record.-              --   Empty if not recursive.-              --   @Nothing@ if not yet computed (by positivity checker).-            , recEtaEquality'    :: EtaEquality-              -- ^ Eta-expand at this record type?-              --   @False@ for unguarded recursive records and coinductive records-              --   unless the user specifies otherwise.-            , recPatternMatching :: PatternOrCopattern-              -- ^ In case eta-equality is off, do we allow pattern matching on the-              --   constructor or construction by copattern matching?-              --   Having both loses subject reduction, see issue #4560.-              --   After positivity checking, this field is obsolete, part of 'EtaEquality'.-            , recInduction      :: Maybe Induction-              -- ^ 'Inductive' or 'CoInductive'?  Matters only for recursive records.-              --   'Nothing' means that the user did not specify it, which is an error-              --   for recursive records.-            , recAbstr          :: IsAbstract-            , recComp           :: CompKit-            }-          | Constructor-            { conPars   :: Int         -- ^ Number of parameters.-            , conArity  :: Int         -- ^ Number of arguments (excluding parameters).-            , conSrcCon :: ConHead     -- ^ Name of (original) constructor and fields. (This might be in a module instance.)-            , conData   :: QName       -- ^ Name of datatype or record type.-            , conAbstr  :: IsAbstract-            , conInd    :: Induction   -- ^ Inductive or coinductive?-            , conComp   :: CompKit     -- ^ Cubical composition.-            , conProj   :: Maybe [QName] -- ^ Projections. 'Nothing' if not yet computed.-            , conForced :: [IsForced]-              -- ^ Which arguments are forced (i.e. determined by the type of the constructor)?-              --   Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@.-            , conErased :: Maybe [Bool]-              -- ^ Which arguments are erased at runtime (computed during compilation to treeless)?-              --   'True' means erased, 'False' means retained.-              --   'Nothing' if no erasure analysis has been performed yet.-              --   The length of the list is @conArity@.-            }-          | Primitive  -- ^ Primitive or builtin functions.-            { primAbstr :: IsAbstract-            , primName  :: String-            , primClauses :: [Clause]-              -- ^ 'null' for primitive functions, @not null@ for builtin functions.-            , primInv      :: FunctionInverse-              -- ^ Builtin functions can have inverses. For instance, natural number addition.-            , primCompiled :: Maybe CompiledClauses-              -- ^ 'Nothing' for primitive functions,-              --   @'Just' something@ for builtin functions.-            }-          | PrimitiveSort-            { primName :: String-            , primSort :: Sort-            }-    deriving (Data, Show, Generic)--instance Pretty Definition where-  pretty Defn{..} =-    "Defn {" <?> vcat-      [ "defArgInfo        =" <?> pshow defArgInfo-      , "defName           =" <?> pretty defName-      , "defType           =" <?> pretty defType-      , "defPolarity       =" <?> pshow defPolarity-      , "defArgOccurrences =" <?> pshow defArgOccurrences-      , "defGeneralizedParams =" <?> pshow defGeneralizedParams-      , "defDisplay        =" <?> pretty defDisplay-      , "defMutual         =" <?> pshow defMutual-      , "defCompiledRep    =" <?> pshow defCompiledRep-      , "defInstance       =" <?> pshow defInstance-      , "defCopy           =" <?> pshow defCopy-      , "defMatchable      =" <?> pshow (Set.toList defMatchable)-      , "defInjective      =" <?> pshow defInjective-      , "defCopatternLHS   =" <?> pshow defCopatternLHS-      , "theDef            =" <?> pretty theDef ] <+> "}"--instance Pretty Defn where-  pretty Axiom{} = "Axiom"-  pretty (DataOrRecSig n)   = "DataOrRecSig" <+> pretty n-  pretty GeneralizableVar{} = "GeneralizableVar"-  pretty (AbstractDefn def) = "AbstractDefn" <?> parens (pretty def)-  pretty Function{..} =-    "Function {" <?> vcat-      [ "funClauses      =" <?> vcat (map pretty funClauses)-      , "funCompiled     =" <?> pretty funCompiled-      , "funSplitTree    =" <?> pretty funSplitTree-      , "funTreeless     =" <?> pshow funTreeless-      , "funInv          =" <?> pretty funInv-      , "funMutual       =" <?> pshow funMutual-      , "funAbstr        =" <?> pshow funAbstr-      , "funDelayed      =" <?> pshow funDelayed-      , "funProjection   =" <?> pretty funProjection-      , "funFlags        =" <?> pshow funFlags-      , "funTerminates   =" <?> pshow funTerminates-      , "funWith         =" <?> pretty funWith ] <?> "}"-  pretty Datatype{..} =-    "Datatype {" <?> vcat-      [ "dataPars       =" <?> pshow dataPars-      , "dataIxs        =" <?> pshow dataIxs-      , "dataClause     =" <?> pretty dataClause-      , "dataCons       =" <?> pshow dataCons-      , "dataSort       =" <?> pretty dataSort-      , "dataMutual     =" <?> pshow dataMutual-      , "dataAbstr      =" <?> pshow dataAbstr ] <?> "}"-  pretty Record{..} =-    "Record {" <?> vcat-      [ "recPars         =" <?> pshow recPars-      , "recClause       =" <?> pretty recClause-      , "recConHead      =" <?> pretty recConHead-      , "recNamedCon     =" <?> pretty recNamedCon-      , "recFields       =" <?> pretty recFields-      , "recTel          =" <?> pretty recTel-      , "recMutual       =" <?> pshow recMutual-      , "recEtaEquality' =" <?> pshow recEtaEquality'-      , "recInduction    =" <?> pshow recInduction-      , "recAbstr        =" <?> pshow recAbstr ] <?> "}"-  pretty Constructor{..} =-    "Constructor {" <?> vcat-      [ "conPars   =" <?> pshow conPars-      , "conArity  =" <?> pshow conArity-      , "conSrcCon =" <?> pretty conSrcCon-      , "conData   =" <?> pretty conData-      , "conAbstr  =" <?> pshow conAbstr-      , "conInd    =" <?> pshow conInd-      , "conErased =" <?> pshow conErased ] <?> "}"-  pretty Primitive{..} =-    "Primitive {" <?> vcat-      [ "primAbstr    =" <?> pshow primAbstr-      , "primName     =" <?> pshow primName-      , "primClauses  =" <?> pshow primClauses-      , "primCompiled =" <?> pshow primCompiled ] <?> "}"-  pretty PrimitiveSort{..} =-    "PrimitiveSort {" <?> vcat-      [ "primName =" <?> pshow primName-      , "primSort =" <?> pshow primSort-      ] <?> "}"--instance Pretty Projection where-  pretty Projection{..} =-    "Projection {" <?> vcat-      [ "projProper   =" <?> pretty projProper-      , "projOrig     =" <?> pretty projOrig-      , "projFromType =" <?> pretty projFromType-      , "projIndex    =" <?> pshow projIndex-      , "projLams     =" <?> pretty projLams-      ]--instance Pretty c => Pretty (FunctionInverse' c) where-  pretty NotInjective = "NotInjective"-  pretty (Inverse inv) = "Inverse" <?>-    vcat [ pretty h <+> "->" <?> pretty cs-         | (h, cs) <- Map.toList inv ]--instance Pretty ProjLams where-  pretty (ProjLams args) = pretty args---- | Is the record type recursive?-recRecursive :: Defn -> Bool-recRecursive (Record { recMutual = Just qs }) = not $ null qs-recRecursive _ = __IMPOSSIBLE__--recEtaEquality :: Defn -> HasEta-recEtaEquality = theEtaEquality . recEtaEquality'---- | A template for creating 'Function' definitions, with sensible defaults.-emptyFunction :: Defn-emptyFunction = Function-  { funClauses     = []-  , funCompiled    = Nothing-  , funSplitTree   = Nothing-  , funTreeless    = Nothing-  , funInv         = NotInjective-  , funMutual      = Nothing-  , funAbstr       = ConcreteDef-  , funDelayed     = NotDelayed-  , funProjection  = Nothing-  , funFlags       = Set.empty-  , funTerminates  = Nothing-  , funExtLam      = Nothing-  , funWith        = Nothing-  , funCovering    = []-  }--funFlag :: FunctionFlag -> Lens' Bool Defn-funFlag flag f def@Function{ funFlags = flags } =-  f (Set.member flag flags) <&>-  \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags }-funFlag _ f def = f False $> def--funStatic, funInline, funMacro :: Lens' Bool Defn-funStatic       = funFlag FunStatic-funInline       = funFlag FunInline-funMacro        = funFlag FunMacro--isMacro :: Defn -> Bool-isMacro = (^. funMacro)---- | Checking whether we are dealing with a function yet to be defined.-isEmptyFunction :: Defn -> Bool-isEmptyFunction def =-  case def of-    Function { funClauses = [] } -> True-    _ -> False--isCopatternLHS :: [Clause] -> Bool-isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)--recCon :: Defn -> QName-recCon Record{ recConHead } = conName recConHead-recCon _ = __IMPOSSIBLE__--defIsRecord :: Defn -> Bool-defIsRecord Record{} = True-defIsRecord _        = False--defIsDataOrRecord :: Defn -> Bool-defIsDataOrRecord Record{}   = True-defIsDataOrRecord Datatype{} = True-defIsDataOrRecord _          = False--defConstructors :: Defn -> [QName]-defConstructors Datatype{dataCons = cs} = cs-defConstructors Record{recConHead = c} = [conName c]-defConstructors _ = __IMPOSSIBLE__--newtype Fields = Fields [(C.Name, Type)]-  deriving Null---- | Did we encounter a simplifying reduction?---   In terms of CIC, that would be a iota-reduction.---   In terms of Agda, this is a constructor or literal---   pattern that matched.---   Just beta-reduction (substitution) or delta-reduction---   (unfolding of definitions) does not count as simplifying?--data Simplification = YesSimplification | NoSimplification-  deriving (Data, Eq, Show, Generic)--instance Null Simplification where-  empty = NoSimplification-  null  = (== NoSimplification)--instance Semigroup Simplification where-  YesSimplification <> _ = YesSimplification-  NoSimplification  <> s = s--instance Monoid Simplification where-  mempty = NoSimplification-  mappend = (<>)--data Reduced no yes-  = NoReduction no-  | YesReduction Simplification yes-  deriving Functor--redReturn :: a -> ReduceM (Reduced a' a)-redReturn = return . YesReduction YesSimplification---- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@--redBind :: ReduceM (Reduced a a') -> (a -> b) ->-           (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')-redBind ma f k = do-  r <- ma-  case r of-    NoReduction x    -> return $ NoReduction $ f x-    YesReduction _ y -> k y---- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked.-data IsReduced-  = NotReduced-  | Reduced    (Blocked ())--data MaybeReduced a = MaybeRed-  { isReduced     :: IsReduced-  , ignoreReduced :: a-  }-  deriving (Functor)--instance IsProjElim e => IsProjElim (MaybeReduced e) where-  isProjElim = isProjElim . ignoreReduced--type MaybeReducedArgs = [MaybeReduced (Arg Term)]-type MaybeReducedElims = [MaybeReduced Elim]--notReduced :: a -> MaybeReduced a-notReduced x = MaybeRed NotReduced x--reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)-reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b---- | Controlling 'reduce'.-data AllowedReduction-  = ProjectionReductions     -- ^ (Projection and) projection-like functions may be reduced.-  | InlineReductions         -- ^ Functions marked INLINE may be reduced.-  | CopatternReductions      -- ^ Copattern definitions may be reduced.-  | FunctionReductions       -- ^ Non-recursive functions and primitives may be reduced.-  | RecursiveReductions      -- ^ Even recursive functions may be reduced.-  | LevelReductions          -- ^ Reduce @'Level'@ terms.-  | TypeLevelReductions      -- ^ Allow @allReductions@ in types, even-                             --   if not allowed at term level (used-                             --   by confluence checker)-  | UnconfirmedReductions    -- ^ Functions whose termination has not (yet) been confirmed.-  | NonTerminatingReductions -- ^ Functions that have failed termination checking.-  deriving (Show, Eq, Ord, Enum, Bounded, Ix, Data, Generic)--type AllowedReductions = SmallSet AllowedReduction---- | Not quite all reductions (skip non-terminating reductions)-allReductions :: AllowedReductions-allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions--reallyAllReductions :: AllowedReductions-reallyAllReductions = SmallSet.total--data ReduceDefs-  = OnlyReduceDefs (Set QName)-  | DontReduceDefs (Set QName)-  deriving (Data, Generic)--reduceAllDefs :: ReduceDefs-reduceAllDefs = DontReduceDefs empty--locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a-locallyReduceDefs = locallyTC eReduceDefs . const--locallyReduceAllDefs :: MonadTCEnv m => m a -> m a-locallyReduceAllDefs = locallyReduceDefs reduceAllDefs--shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool-shouldReduceDef f = asksTC envReduceDefs <&> \case-  OnlyReduceDefs defs -> f `Set.member` defs-  DontReduceDefs defs -> not $ f `Set.member` defs--instance Semigroup ReduceDefs where-  OnlyReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.intersection qs1 qs2-  OnlyReduceDefs qs1 <> DontReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs1 qs2-  DontReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs2 qs1-  DontReduceDefs qs1 <> DontReduceDefs qs2 = DontReduceDefs $ Set.union        qs1 qs2--instance Monoid ReduceDefs where-  mempty  = reduceAllDefs-  mappend = (<>)---locallyReconstructed :: MonadTCEnv m => m a -> m a-locallyReconstructed = locallyTC eReconstructed . const $ True--isReconstructed :: (MonadTCEnv m) => m Bool-isReconstructed = asksTC envReconstructed---- | Primitives--data PrimitiveImpl = PrimImpl Type PrimFun--data PrimFun = PrimFun-  { primFunName           :: QName-  , primFunArity          :: Arity-  , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)-  }-  deriving Generic--primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun-primFun q ar imp = PrimFun q ar (\ args _ -> imp args)--defClauses :: Definition -> [Clause]-defClauses Defn{theDef = Function{funClauses = cs}}        = cs-defClauses Defn{theDef = Primitive{primClauses = cs}}      = cs-defClauses Defn{theDef = Datatype{dataClause = Just c}}    = [c]-defClauses Defn{theDef = Record{recClause = Just c}}       = [c]-defClauses _                                               = []--defCompiled :: Definition -> Maybe CompiledClauses-defCompiled Defn{theDef = Function {funCompiled  = mcc}} = mcc-defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc-defCompiled _ = Nothing--defParameters :: Definition -> Maybe Nat-defParameters Defn{theDef = Datatype{dataPars = n}} = Just n-defParameters Defn{theDef = Record  {recPars  = n}} = Just n-defParameters _                                     = Nothing--defInverse :: Definition -> FunctionInverse-defInverse Defn{theDef = Function { funInv  = inv }} = inv-defInverse Defn{theDef = Primitive{ primInv = inv }} = inv-defInverse _                                         = NotInjective--defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma]-defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep-  -- reversed because we add new pragmas to the front of the list---- | Are the clauses of this definition delayed?-defDelayed :: Definition -> Delayed-defDelayed Defn{theDef = Function{funDelayed = d}} = d-defDelayed _                                       = NotDelayed---- | Has the definition failed the termination checker?-defNonterminating :: Definition -> Bool-defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True-defNonterminating _                                                   = False---- | Has the definition not termination checked or did the check fail?-defTerminationUnconfirmed :: Definition -> Bool-defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False-defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _        }} = True-defTerminationUnconfirmed _ = False--defAbstract :: Definition -> IsAbstract-defAbstract d = case theDef d of-    Axiom{}                   -> ConcreteDef-    DataOrRecSig{}            -> ConcreteDef-    GeneralizableVar{}        -> ConcreteDef-    AbstractDefn{}            -> AbstractDef-    Function{funAbstr = a}    -> a-    Datatype{dataAbstr = a}   -> a-    Record{recAbstr = a}      -> a-    Constructor{conAbstr = a} -> a-    Primitive{primAbstr = a}  -> a-    PrimitiveSort{}           -> ConcreteDef--defForced :: Definition -> [IsForced]-defForced d = case theDef d of-    Constructor{conForced = fs} -> fs-    Axiom{}                     -> []-    DataOrRecSig{}              -> []-    GeneralizableVar{}          -> []-    AbstractDefn{}              -> []-    Function{}                  -> []-    Datatype{}                  -> []-    Record{}                    -> []-    Primitive{}                 -> []-    PrimitiveSort{}             -> []-------------------------------------------------------------------------------- ** Injectivity------------------------------------------------------------------------------type FunctionInverse = FunctionInverse' Clause-type InversionMap c = Map TermHead [c]--data FunctionInverse' c-  = NotInjective-  | Inverse (InversionMap c)-  deriving (Data, Show, Functor, Generic)--data TermHead = SortHead-              | PiHead-              | ConsHead QName-              | VarHead Nat-              | UnknownHead-  deriving (Data, Eq, Ord, Show, Generic)--instance Pretty TermHead where-  pretty = \ case-    SortHead    -> "SortHead"-    PiHead      -> "PiHead"-    ConsHead q  -> "ConsHead" <+> pretty q-    VarHead i   -> text ("VarHead " ++ show i)-    UnknownHead -> "UnknownHead"-------------------------------------------------------------------------------- ** Mutual blocks------------------------------------------------------------------------------newtype MutualId = MutId Int32-  deriving (Data, Eq, Ord, Show, Num, Enum, NFData)-------------------------------------------------------------------------------- ** Statistics------------------------------------------------------------------------------type Statistics = Map String Integer-------------------------------------------------------------------------------- ** Trace------------------------------------------------------------------------------data Call-  = CheckClause Type A.SpineClause-  | CheckLHS A.SpineLHS-  | CheckPattern A.Pattern Telescope Type-  | CheckPatternLinearityType C.Name-  | CheckPatternLinearityValue C.Name-  | CheckLetBinding A.LetBinding-  | InferExpr A.Expr-  | CheckExprCall Comparison A.Expr Type-  | CheckDotPattern A.Expr Term-  | CheckProjection Range QName Type-  | IsTypeCall Comparison A.Expr Sort-  | IsType_ A.Expr-  | InferVar Name-  | InferDef QName-  | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type)-  | CheckMetaSolution Range MetaId Type Term-  | CheckTargetType Range Type Type-  | CheckDataDef Range QName [A.LamBinding] [A.Constructor]-  | CheckRecDef Range QName [A.LamBinding] [A.Constructor]-  | CheckConstructor QName Telescope Sort A.Constructor-  | CheckConstructorFitsIn QName Type Sort-  | CheckFunDefCall Range QName [A.Clause] Bool-    -- ^ Highlight (interactively) if and only if the boolean is 'True'.-  | CheckPragma Range A.Pragma-  | CheckPrimitive Range QName A.Expr-  | CheckIsEmpty Range Type-  | CheckConfluence QName QName-  | CheckWithFunctionType Type-  | CheckSectionApplication Range ModuleName A.ModuleApplication-  | CheckNamedWhere ModuleName-  | ScopeCheckExpr C.Expr-  | ScopeCheckDeclaration NiceDeclaration-  | ScopeCheckLHS C.QName C.Pattern-  | NoHighlighting-  | ModuleContents  -- ^ Interaction command: show module contents.-  | SetRange Range  -- ^ used by 'setCurrentRange'-  deriving (Data, Generic)--instance Pretty Call where-    pretty CheckClause{}             = "CheckClause"-    pretty CheckLHS{}                = "CheckLHS"-    pretty CheckPattern{}            = "CheckPattern"-    pretty CheckPatternLinearityType{}  = "CheckPatternLinearityType"-    pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue"-    pretty InferExpr{}               = "InferExpr"-    pretty CheckExprCall{}           = "CheckExprCall"-    pretty CheckLetBinding{}         = "CheckLetBinding"-    pretty CheckProjection{}         = "CheckProjection"-    pretty IsTypeCall{}              = "IsTypeCall"-    pretty IsType_{}                 = "IsType_"-    pretty InferVar{}                = "InferVar"-    pretty InferDef{}                = "InferDef"-    pretty CheckArguments{}          = "CheckArguments"-    pretty CheckMetaSolution{}       = "CheckMetaSolution"-    pretty CheckTargetType{}         = "CheckTargetType"-    pretty CheckDataDef{}            = "CheckDataDef"-    pretty CheckRecDef{}             = "CheckRecDef"-    pretty CheckConstructor{}        = "CheckConstructor"-    pretty CheckConstructorFitsIn{}  = "CheckConstructorFitsIn"-    pretty CheckFunDefCall{}         = "CheckFunDefCall"-    pretty CheckPragma{}             = "CheckPragma"-    pretty CheckPrimitive{}          = "CheckPrimitive"-    pretty CheckWithFunctionType{}   = "CheckWithFunctionType"-    pretty CheckNamedWhere{}         = "CheckNamedWhere"-    pretty ScopeCheckExpr{}          = "ScopeCheckExpr"-    pretty ScopeCheckDeclaration{}   = "ScopeCheckDeclaration"-    pretty ScopeCheckLHS{}           = "ScopeCheckLHS"-    pretty CheckDotPattern{}         = "CheckDotPattern"-    pretty SetRange{}                = "SetRange"-    pretty CheckSectionApplication{} = "CheckSectionApplication"-    pretty CheckIsEmpty{}            = "CheckIsEmpty"-    pretty CheckConfluence{}         = "CheckConfluence"-    pretty NoHighlighting{}          = "NoHighlighting"-    pretty ModuleContents{}          = "ModuleContents"--instance HasRange Call where-    getRange (CheckClause _ c)               = getRange c-    getRange (CheckLHS lhs)                  = getRange lhs-    getRange (CheckPattern p _ _)            = getRange p-    getRange (CheckPatternLinearityType x)   = getRange x-    getRange (CheckPatternLinearityValue x)  = getRange x-    getRange (InferExpr e)                   = getRange e-    getRange (CheckExprCall _ e _)           = getRange e-    getRange (CheckLetBinding b)             = getRange b-    getRange (CheckProjection r _ _)         = r-    getRange (IsTypeCall cmp e s)            = getRange e-    getRange (IsType_ e)                     = getRange e-    getRange (InferVar x)                    = getRange x-    getRange (InferDef f)                    = getRange f-    getRange (CheckArguments r _ _ _)        = r-    getRange (CheckMetaSolution r _ _ _)     = r-    getRange (CheckTargetType r _ _)         = r-    getRange (CheckDataDef i _ _ _)          = getRange i-    getRange (CheckRecDef i _ _ _)           = getRange i-    getRange (CheckConstructor _ _ _ c)      = getRange c-    getRange (CheckConstructorFitsIn c _ _)  = getRange c-    getRange (CheckFunDefCall i _ _ _)       = getRange i-    getRange (CheckPragma r _)               = r-    getRange (CheckPrimitive i _ _)          = getRange i-    getRange CheckWithFunctionType{}         = noRange-    getRange (CheckNamedWhere m)             = getRange m-    getRange (ScopeCheckExpr e)              = getRange e-    getRange (ScopeCheckDeclaration d)       = getRange d-    getRange (ScopeCheckLHS _ p)             = getRange p-    getRange (CheckDotPattern e _)           = getRange e-    getRange (SetRange r)                    = r-    getRange (CheckSectionApplication r _ _) = r-    getRange (CheckIsEmpty r _)              = r-    getRange (CheckConfluence rule1 rule2)   = max (getRange rule1) (getRange rule2)-    getRange NoHighlighting                  = noRange-    getRange ModuleContents                  = noRange-------------------------------------------------------------------------------- ** Instance table-------------------------------------------------------------------------------- | The instance table is a @Map@ associating to every name of---   record/data type/postulate its list of instances-type InstanceTable = Map QName (Set QName)---- | When typechecking something of the following form:------     instance---       x : _---       x = y------   it's not yet known where to add @x@, so we add it to a list of---   unresolved instances and we'll deal with it later.-type TempInstanceTable = (InstanceTable , Set QName)-------------------------------------------------------------------------------- ** Builtin things------------------------------------------------------------------------------data BuiltinDescriptor-  = BuiltinData (TCM Type) [String]-  | BuiltinDataCons (TCM Type)-  | BuiltinPrim String (Term -> TCM ())-  | BuiltinSort String-  | BuiltinPostulate Relevance (TCM Type)-  | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ())-    -- ^ Builtin of any kind.-    --   Type can be checked (@Just t@) or inferred (@Nothing@).-    --   The second argument is the hook for the verification function.--data BuiltinInfo =-   BuiltinInfo { builtinName :: String-               , builtinDesc :: BuiltinDescriptor }--type BuiltinThings pf = Map String (Builtin pf)--data Builtin pf-        = Builtin Term-        | Prim pf-    deriving (Show, Functor, Foldable, Traversable, Generic)-------------------------------------------------------------------------------- * Highlighting levels-------------------------------------------------------------------------------- | How much highlighting should be sent to the user interface?--data HighlightingLevel-  = None-  | NonInteractive-  | Interactive-    -- ^ This includes both non-interactive highlighting and-    -- interactive highlighting of the expression that is currently-    -- being type-checked.-    deriving (Eq, Ord, Show, Read, Data, Generic)---- | How should highlighting be sent to the user interface?--data HighlightingMethod-  = Direct-    -- ^ Via stdout.-  | Indirect-    -- ^ Both via files and via stdout.-    deriving (Eq, Show, Read, Data, Generic)---- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're--- type-checking the top-level module (or before we've started doing--- this) and either the highlighting level is /at least/ @l@ or @b@ is--- 'True'.--ifTopLevelAndHighlightingLevelIsOr ::-  MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIsOr l b m = do-  e <- askTC-  when (envHighlightingLevel e >= l || b) $-    case (envImportPath e) of-      -- Below the main module.-      (_:_:_) -> pure ()-      -- In or before the top-level module.-      _ -> m---- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're--- type-checking the top-level module (or before we've started doing--- this) and the highlighting level is /at least/ @l@.--ifTopLevelAndHighlightingLevelIs ::-  MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()-ifTopLevelAndHighlightingLevelIs l =-  ifTopLevelAndHighlightingLevelIsOr l False-------------------------------------------------------------------------------- * Type checking environment------------------------------------------------------------------------------data TCEnv =-    TCEnv { envContext             :: Context-          , envLetBindings         :: LetBindings-          , envCurrentModule       :: ModuleName-          , envCurrentPath         :: Maybe AbsolutePath-            -- ^ The path to the file that is currently being-            -- type-checked.  'Nothing' if we do not have a file-            -- (like in interactive mode see @CommandLine@).-          , envAnonymousModules    :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables-          , envImportPath          :: [C.TopLevelModuleName]-            -- ^ The module stack with the entry being the top-level module as-            --   Agda chases modules. It will be empty if there is no main-            --   module, will have a single entry for the top level module, or-            --   more when descending past the main module. This is used to-            --   detect import cycles and in some cases highlighting behavior.-            --   The level of a given module is not necessarily the same as the-            --   length, in the module dependency graph, of the shortest path-            --   from the top-level module; it depends on in which order Agda-            --   chooses to chase dependencies.-          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block-          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma-          , envCoverageCheck       :: CoverageCheck        -- ^ are we inside the scope of a coverage pragma-          , envMakeCase            :: Bool                 -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier)-          , envSolvingConstraints  :: Bool-                -- ^ Are we currently in the process of solving active constraints?-          , envCheckingWhere       :: Bool-                -- ^ Have we stepped into the where-declarations of a clause?-                --   Everything under a @where@ will be checked with this flag on.-          , envWorkingOnTypes      :: Bool-                -- ^ Are we working on types? Turned on by 'workOnTypes'.-          , envAssignMetas         :: Bool-            -- ^ Are we allowed to assign metas?-          , envActiveProblems      :: Set ProblemId-          , envAbstractMode        :: AbstractMode-                -- ^ When checking the typesignature of a public definition-                --   or the body of a non-abstract definition this is true.-                --   To prevent information about abstract things leaking-                --   outside the module.-          , envModality            :: Modality-                -- ^ 'Relevance' component:-                -- Are we checking an irrelevant argument? (=@Irrelevant@)-                -- Then top-level irrelevant declarations are enabled.-                -- Other value: @Relevant@, then only relevant decls. are available.-                ---                -- 'Quantity' component:-                -- Are we checking a runtime-irrelevant thing? (='Quantity0')-                -- Then runtime-irrelevant things are usable.-                -- Other value: @Quantity1@, runtime relevant.-                -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018.-          , envSplitOnStrict       :: Bool-                -- ^ Are we currently case-splitting on a strict-                --   datatype (i.e. in SSet)? If yes, the-                --   pattern-matching unifier will solve reflexive-                --   equations even --without-K.-          , envDisplayFormsEnabled :: Bool-                -- ^ Sometimes we want to disable display forms.-          , envRange :: Range-          , envHighlightingRange :: Range-                -- ^ Interactive highlighting uses this range rather-                --   than 'envRange'.-          , envClause :: IPClause-                -- ^ What is the current clause we are type-checking?-                --   Will be recorded in interaction points in this clause.-          , envCall  :: Maybe (Closure Call)-                -- ^ what we're doing at the moment-          , envHighlightingLevel  :: HighlightingLevel-                -- ^ Set to 'None' when imported modules are-                --   type-checked.-          , envHighlightingMethod :: HighlightingMethod-          , envExpandLast :: ExpandHidden-                -- ^ When type-checking an alias f=e, we do not want-                -- to insert hidden arguments in the end, because-                -- these will become unsolved metas.-          , envAppDef :: Maybe QName-                -- ^ We are reducing an application of this function.-                -- (For debugging of incomplete matches only.)-          , envSimplification :: Simplification-                -- ^ Did we encounter a simplification (proper match)-                --   during the current reduction process?-          , envAllowedReductions :: AllowedReductions-          , envReduceDefs :: ReduceDefs-          , envReconstructed :: Bool-          , envInjectivityDepth :: Int-                -- ^ Injectivity can cause non-termination for unsolvable contraints-                --   (#431, #3067). Keep a limit on the nesting depth of injectivity-                --   uses.-          , envCompareBlocked :: Bool-                -- ^ When @True@, the conversion checker will consider-                --   all term constructors as injective, including-                --   blocked function applications and metas. Warning:-                --   this should only be used when not assigning any-                --   metas (e.g. when @envAssignMetas@ is @False@ or-                --   when running @pureEqualTerms@) or else we get-                --   non-unique meta solutions.-          , envPrintDomainFreePi :: Bool-                -- ^ When @True@, types will be omitted from printed pi types if they-                --   can be inferred.-          , envPrintMetasBare :: Bool-                -- ^ When @True@, throw away meta numbers and meta elims.-                --   This is used for reifying terms for feeding into the-                --   user's source code, e.g., for the interaction tactics @solveAll@.-          , envInsideDotPattern :: Bool-                -- ^ Used by the scope checker to make sure that certain forms-                --   of expressions are not used inside dot patterns: extended-                --   lambdas and let-expressions.-          , envUnquoteFlags :: UnquoteFlags-          , envInstanceDepth :: !Int-                -- ^ Until we get a termination checker for instance search (#1743) we-                --   limit the search depth to ensure termination.-          , envIsDebugPrinting :: Bool-          , envPrintingPatternLambdas :: [QName]-                -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We-                --   don't have a good story for what to do in this case, but at least-                --   printing shouldn't loop. Here we keep track of which pattern lambdas-                --   we are currently in the process of printing.-          , envCallByNeed :: Bool-                -- ^ Use call-by-need evaluation for reductions.-          , envCurrentCheckpoint :: CheckpointId-                -- ^ Checkpoints track the evolution of the context as we go-                -- under binders or refine it by pattern matching.-          , envCheckpoints :: Map CheckpointId Substitution-                -- ^ Keeps the substitution from each previous checkpoint to-                --   the current context.-          , envGeneralizeMetas :: DoGeneralize-                -- ^ Should new metas generalized over.-          , envGeneralizedVars :: Map QName GeneralizedValue-                -- ^ Values for used generalizable variables.-          , envActiveBackendName :: Maybe BackendName-                -- ^ Is some backend active at the moment, and if yes, which?-                --   NB: we only store the 'BackendName' here, otherwise-                --   @instance Data TCEnv@ is not derivable.-                --   The actual backend can be obtained from the name via 'stBackends'.-          , envConflComputingOverlap :: Bool-                -- ^ Are we currently computing the overlap between-                --   two rewrite rules for the purpose of confluence checking?-          , envCurrentlyElaborating :: Bool-                -- ^ Are we currently in the process of executing an-                --   elaborate-and-give interactive command?-          }-    deriving (Generic)--initEnv :: TCEnv-initEnv = TCEnv { envContext             = []-                , envLetBindings         = Map.empty-                , envCurrentModule       = noModuleName-                , envCurrentPath         = Nothing-                , envAnonymousModules    = []-                , envImportPath          = []-                , envMutualBlock         = Nothing-                , envTerminationCheck    = TerminationCheck-                , envCoverageCheck       = YesCoverageCheck-                , envMakeCase            = False-                , envSolvingConstraints  = False-                , envCheckingWhere       = False-                , envActiveProblems      = Set.empty-                , envWorkingOnTypes      = False-                , envAssignMetas         = True-                , envAbstractMode        = ConcreteMode-  -- Andreas, 2013-02-21:  This was 'AbstractMode' until now.-  -- However, top-level checks for mutual blocks, such as-  -- constructor-headedness, should not be able to look into-  -- abstract definitions unless abstract themselves.-  -- (See also discussion on issue 796.)-  -- The initial mode should be 'ConcreteMode', ensuring you-  -- can only look into abstract things in an abstract-  -- definition (which sets 'AbstractMode').-                , envModality               = unitModality-                , envSplitOnStrict          = False-                , envDisplayFormsEnabled    = True-                , envRange                  = noRange-                , envHighlightingRange      = noRange-                , envClause                 = IPNoClause-                , envCall                   = Nothing-                , envHighlightingLevel      = None-                , envHighlightingMethod     = Indirect-                , envExpandLast             = ExpandLast-                , envAppDef                 = Nothing-                , envSimplification         = NoSimplification-                , envAllowedReductions      = allReductions-                , envReduceDefs             = reduceAllDefs-                , envReconstructed          = False-                , envInjectivityDepth       = 0-                , envCompareBlocked         = False-                , envPrintDomainFreePi      = False-                , envPrintMetasBare         = False-                , envInsideDotPattern       = False-                , envUnquoteFlags           = defaultUnquoteFlags-                , envInstanceDepth          = 0-                , envIsDebugPrinting        = False-                , envPrintingPatternLambdas = []-                , envCallByNeed             = True-                , envCurrentCheckpoint      = 0-                , envCheckpoints            = Map.singleton 0 IdS-                , envGeneralizeMetas        = NoGeneralize-                , envGeneralizedVars        = Map.empty-                , envActiveBackendName      = Nothing-                , envConflComputingOverlap  = False-                , envCurrentlyElaborating   = False-                }--class LensTCEnv a where-  lensTCEnv :: Lens' TCEnv a--instance LensTCEnv TCEnv where-  lensTCEnv = id--instance LensModality TCEnv where-  -- Cohesion shouldn't have an environment component.-  getModality = setCohesion defaultCohesion . envModality-  mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e }--instance LensRelevance TCEnv where-instance LensQuantity  TCEnv where--data UnquoteFlags = UnquoteFlags-  { _unquoteNormalise :: Bool }-  deriving (Data, Generic)--defaultUnquoteFlags :: UnquoteFlags-defaultUnquoteFlags = UnquoteFlags-  { _unquoteNormalise = False }--unquoteNormalise :: Lens' Bool UnquoteFlags-unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }--eUnquoteNormalise :: Lens' Bool TCEnv-eUnquoteNormalise = eUnquoteFlags . unquoteNormalise---- * e-prefixed lenses---------------------------------------------------------------------------eContext :: Lens' Context TCEnv-eContext f e = f (envContext e) <&> \ x -> e { envContext = x }--eLetBindings :: Lens' LetBindings TCEnv-eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }--eCurrentModule :: Lens' ModuleName TCEnv-eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }--eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv-eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }--eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv-eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }--eImportPath :: Lens' [C.TopLevelModuleName] TCEnv-eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }--eMutualBlock :: Lens' (Maybe MutualId) TCEnv-eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }--eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv-eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }--eCoverageCheck :: Lens' CoverageCheck TCEnv-eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }--eMakeCase :: Lens' Bool TCEnv-eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }--eSolvingConstraints :: Lens' Bool TCEnv-eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }--eCheckingWhere :: Lens' Bool TCEnv-eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }--eWorkingOnTypes :: Lens' Bool TCEnv-eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }--eAssignMetas :: Lens' Bool TCEnv-eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }--eActiveProblems :: Lens' (Set ProblemId) TCEnv-eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }--eAbstractMode :: Lens' AbstractMode TCEnv-eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }---- Andrea 23/02/2020: use get/setModality to enforce invariants of the---                    envModality field.-eModality :: Lens' Modality TCEnv-eModality f e = f (getModality e) <&> \ x -> setModality x e--eRelevance :: Lens' Relevance TCEnv-eRelevance = eModality . lModRelevance--eQuantity :: Lens' Quantity TCEnv-eQuantity = eModality . lModQuantity--eSplitOnStrict :: Lens' Bool TCEnv-eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x }--eDisplayFormsEnabled :: Lens' Bool TCEnv-eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }--eRange :: Lens' Range TCEnv-eRange f e = f (envRange e) <&> \ x -> e { envRange = x }--eHighlightingRange :: Lens' Range TCEnv-eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }--eCall :: Lens' (Maybe (Closure Call)) TCEnv-eCall f e = f (envCall e) <&> \ x -> e { envCall = x }--eHighlightingLevel :: Lens' HighlightingLevel TCEnv-eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }--eHighlightingMethod :: Lens' HighlightingMethod TCEnv-eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }--eExpandLast :: Lens' ExpandHidden TCEnv-eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }--eAppDef :: Lens' (Maybe QName) TCEnv-eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }--eSimplification :: Lens' Simplification TCEnv-eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }--eAllowedReductions :: Lens' AllowedReductions TCEnv-eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }--eReduceDefs :: Lens' ReduceDefs TCEnv-eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x }--eReconstructed :: Lens' Bool TCEnv-eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x }--eInjectivityDepth :: Lens' Int TCEnv-eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }--eCompareBlocked :: Lens' Bool TCEnv-eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }--ePrintDomainFreePi :: Lens' Bool TCEnv-ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }--ePrintMetasBare :: Lens' Bool TCEnv-ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x }--eInsideDotPattern :: Lens' Bool TCEnv-eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }--eUnquoteFlags :: Lens' UnquoteFlags TCEnv-eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }--eInstanceDepth :: Lens' Int TCEnv-eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }--eIsDebugPrinting :: Lens' Bool TCEnv-eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }--ePrintingPatternLambdas :: Lens' [QName] TCEnv-ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }--eCallByNeed :: Lens' Bool TCEnv-eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }--eCurrentCheckpoint :: Lens' CheckpointId TCEnv-eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }--eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv-eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }--eGeneralizeMetas :: Lens' DoGeneralize TCEnv-eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }--eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv-eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }--eActiveBackendName :: Lens' (Maybe BackendName) TCEnv-eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }--eConflComputingOverlap :: Lens' Bool TCEnv-eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x }--eCurrentlyElaborating :: Lens' Bool TCEnv-eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x }-------------------------------------------------------------------------------- ** Context-------------------------------------------------------------------------------- | The @Context@ is a stack of 'ContextEntry's.-type Context      = [ContextEntry]-type ContextEntry = Dom (Name, Type)-------------------------------------------------------------------------------- ** Let bindings------------------------------------------------------------------------------type LetBindings = Map Name (Open (Term, Dom Type))-------------------------------------------------------------------------------- ** Abstract mode------------------------------------------------------------------------------data AbstractMode-  = AbstractMode        -- ^ Abstract things in the current module can be accessed.-  | ConcreteMode        -- ^ No abstract things can be accessed.-  | IgnoreAbstractMode  -- ^ All abstract things can be accessed.-  deriving (Data, Show, Eq, Generic)--aDefToMode :: IsAbstract -> AbstractMode-aDefToMode AbstractDef = AbstractMode-aDefToMode ConcreteDef = ConcreteMode--aModeToDef :: AbstractMode -> Maybe IsAbstract-aModeToDef AbstractMode = Just AbstractDef-aModeToDef ConcreteMode = Just ConcreteDef-aModeToDef _ = Nothing-------------------------------------------------------------------------------- ** Insertion of implicit arguments------------------------------------------------------------------------------data ExpandHidden-  = ExpandLast      -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.-  | DontExpandLast  -- ^ Do not append implicit arguments.-  | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables.-  deriving (Eq, Data, Generic)--isDontExpandLast :: ExpandHidden -> Bool-isDontExpandLast ExpandLast           = False-isDontExpandLast DontExpandLast       = True-isDontExpandLast ReallyDontExpandLast = True--data CandidateKind-  = LocalCandidate-  | GlobalCandidate QName-  deriving (Show, Data, Generic)---- | A candidate solution for an instance meta is a term with its type.---   It may be the case that the candidate is not fully applied yet or---   of the wrong type, hence the need for the type.-data Candidate  = Candidate { candidateKind :: CandidateKind-                            , candidateTerm :: Term-                            , candidateType :: Type-                            , candidateOverlappable :: Bool-                            }-  deriving (Show, Data, Generic)--instance Free Candidate where-  freeVars' (Candidate _ t u _) = freeVars' (t, u)--------------------------------------------------------------------------------- ** Checking arguments------------------------------------------------------------------------------data ArgsCheckState a = ACState-       { acRanges :: [Maybe Range]-         -- ^ Ranges of checked arguments, where present.-         -- e.g. inserted implicits have no correponding abstract syntax.-       , acElims  :: Elims-         -- ^ Checked and inserted arguments so far.-       , acConstraints :: [Maybe (Abs Constraint)]-         -- ^ Constraints for the head so far,-         -- i.e. before applying the correponding elim.-       , acType   :: Type-         -- ^ Type for the rest of the application.-       , acData   :: a-       }-  deriving (Show)--------------------------------------------------------------------------------- * Type checking warnings (aka non-fatal errors)-------------------------------------------------------------------------------- | A non-fatal error is an error which does not prevent us from--- checking the document further and interacting with the user.--data Warning-  = NicifierIssue            DeclarationWarning-  | TerminationIssue         [TerminationError]-  | UnreachableClauses       QName [Range]-  -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs-  --   are unreachable-  | CoverageIssue            QName [(Telescope, [NamedArg DeBruijnPattern])]-  -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`-  | CoverageNoExactSplit     QName [Clause]-  | NotStrictlyPositive      QName (Seq OccursWhere)-  | UnsolvedMetaVariables    [Range]  -- ^ Do not use directly with 'warning'-  | UnsolvedInteractionMetas [Range]  -- ^ Do not use directly with 'warning'-  | UnsolvedConstraints      Constraints-    -- ^ Do not use directly with 'warning'-  | CantGeneralizeOverSorts [MetaId]-  | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern]-  | OldBuiltin               String String-    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new-  | EmptyRewritePragma-    -- ^ If the user wrote just @{-\# REWRITE \#-}@.-  | EmptyWhere-    -- ^ An empty @where@ block is dead code.-  | IllformedAsClause String-    -- ^ If the user wrote something other than an unqualified name-    --   in the @as@ clause of an @import@ statement.-    --   The 'String' gives optionally extra explanation.-  | ClashesViaRenaming NameOrModule [C.Name]-    -- ^ If a `renaming' import directive introduces a name or module name clash-    --   in the exported names of a module.-    --   (See issue #4154.)-  | UselessPatternDeclarationForRecord String-    -- ^ The 'pattern' declaration is useless in the presence-    --   of either @coinductive@ or @eta-equality@.-    --   Content of 'String' is "coinductive" or "eta", resp.-  | UselessPublic-    -- ^ If the user opens a module public before the module header.-    --   (See issue #2377.)-  | UselessHiding [C.ImportedName]-    -- ^ Names in `hiding` directive that don't hide anything-    --   imported by a `using` directive.-  | UselessInline            QName-  | WrongInstanceDeclaration-  | InstanceWithExplicitArg  QName-  -- ^ An instance was declared with an implicit argument, which means it-  --   will never actually be considered by instance search.-  | InstanceNoOutputTypeName Doc-  -- ^ The type of an instance argument doesn't end in a named or-  -- variable type, so it will never be considered by instance search.-  | InstanceArgWithExplicitArg Doc-  -- ^ As InstanceWithExplicitArg, but for local bindings rather than-  --   top-level instances.-  | InversionDepthReached    QName-  -- ^ The --inversion-max-depth was reached.-  | NoGuardednessFlag        QName-  -- ^ A coinductive record was declared but neither --guardedness nor-  --   --sized-types is enabled.--  -- Generic warnings for one-off things-  | GenericWarning           Doc-    -- ^ Harmless generic warning (not an error)-  | GenericNonFatalError     Doc-    -- ^ Generic error which doesn't abort proceedings (not a warning)-  | GenericUseless  Range    Doc-    -- ^ Generic warning when code is useless and thus ignored.-    --   'Range' is for dead code highlighting.--  -- Safe flag errors-  | SafeFlagPostulate C.Name-  | SafeFlagPragma [String]                -- ^ Unsafe OPTIONS.-  | SafeFlagNonTerminating-  | SafeFlagTerminating-  | SafeFlagWithoutKFlagPrimEraseEquality-  | WithoutKFlagPrimEraseEquality-  | SafeFlagNoPositivityCheck-  | SafeFlagPolarity-  | SafeFlagNoUniverseCheck-  | SafeFlagNoCoverageCheck-  | SafeFlagInjective-  | SafeFlagEta                            -- ^ ETA pragma is unsafe.-  | ParseWarning             ParseWarning-  | LibraryWarning           LibWarning-  | DeprecationWarning String String String-    -- ^ `DeprecationWarning old new version`:-    --   `old` is deprecated, use `new` instead. This will be an error in Agda `version`.-  | UserWarning Text-    -- ^ User-defined warning (e.g. to mention that a name is deprecated)-  | DuplicateUsing (List1 C.ImportedName)-    -- ^ Duplicate mentions of the same name in @using@ directive(s).-  | FixityInRenamingModule (List1 Range)-    -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity).-  | ModuleDoesntExport C.QName [C.Name] [C.Name] [C.ImportedName]-    -- ^ Some imported names are not actually exported by the source module.-    --   The second argument is the names that could be exported.-    --   The third  argument is the module names that could be exported.-  | InfectiveImport String ModuleName-    -- ^ Importing a file using an infective option into one which doesn't-  | CoInfectiveImport String ModuleName-    -- ^ Importing a file not using a coinfective option from one which does-  | RewriteNonConfluent Term Term Term Doc-    -- ^ Confluence checker found critical pair and equality checking-    --   resulted in a type error-  | RewriteMaybeNonConfluent Term Term [Doc]-    -- ^ Confluence checker got stuck on computing overlap between two-    --   rewrite rules-  | RewriteAmbiguousRules Term Term Term-    -- ^ The global confluence checker found a term @u@ that reduces-    --   to both @v1@ and @v2@ and there is no rule to resolve the-    --   ambiguity.-  | RewriteMissingRule Term Term Term-    -- ^ The global confluence checker found a term @u@ that reduces-    --   to @v@, but @v@ does not reduce to @rho(u)@.-  | PragmaCompileErased BackendName QName-    -- ^ COMPILE directive for an erased symbol-  | NotInScopeW [C.QName]-    -- ^ Out of scope error we can recover from-  | AsPatternShadowsConstructorOrPatternSynonym Bool-    -- ^ The as-name in an as-pattern may not shadow a constructor (@False@)-    --   or pattern synonym name (@True@),-    --   because this can be confusing to read.-  | RecordFieldWarning RecordFieldWarning-  deriving (Show, Generic)--data RecordFieldWarning-  = DuplicateFieldsWarning [(C.Name, Range)]-      -- ^ Each redundant field comes with a range of associated dead code.-  | TooManyFieldsWarning QName [C.Name] [(C.Name, Range)]-      -- ^ Record type, fields not supplied by user, non-fields but supplied.-      --   The redundant fields come with a range of associated dead code.-  deriving (Show, Data, Generic)--recordFieldWarningToError :: RecordFieldWarning -> TypeError-recordFieldWarningToError = \case-  DuplicateFieldsWarning    xrs -> DuplicateFields    $ map fst xrs-  TooManyFieldsWarning q ys xrs -> TooManyFields q ys $ map fst xrs--warningName :: Warning -> WarningName-warningName = \case-  -- special cases-  NicifierIssue dw             -> declarationWarningName dw-  ParseWarning pw              -> parseWarningName pw-  LibraryWarning lw            -> libraryWarningName lw-  AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_-  -- scope- and type-checking errors-  AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_-  CantGeneralizeOverSorts{}    -> CantGeneralizeOverSorts_-  CoverageIssue{}              -> CoverageIssue_-  CoverageNoExactSplit{}       -> CoverageNoExactSplit_-  DeprecationWarning{}         -> DeprecationWarning_-  EmptyRewritePragma           -> EmptyRewritePragma_-  EmptyWhere                   -> EmptyWhere_-  IllformedAsClause{}          -> IllformedAsClause_-  WrongInstanceDeclaration{}   -> WrongInstanceDeclaration_-  InstanceWithExplicitArg{}    -> InstanceWithExplicitArg_-  InstanceNoOutputTypeName{}   -> InstanceNoOutputTypeName_-  InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_-  DuplicateUsing{}             -> DuplicateUsing_-  FixityInRenamingModule{}     -> FixityInRenamingModule_-  GenericNonFatalError{}       -> GenericNonFatalError_-  GenericUseless{}             -> GenericUseless_-  GenericWarning{}             -> GenericWarning_-  InversionDepthReached{}      -> InversionDepthReached_-  ModuleDoesntExport{}         -> ModuleDoesntExport_-  NoGuardednessFlag{}          -> NoGuardednessFlag_-  NotInScopeW{}                -> NotInScope_-  NotStrictlyPositive{}        -> NotStrictlyPositive_-  OldBuiltin{}                 -> OldBuiltin_-  SafeFlagNoPositivityCheck    -> SafeFlagNoPositivityCheck_-  SafeFlagNonTerminating       -> SafeFlagNonTerminating_-  SafeFlagNoUniverseCheck      -> SafeFlagNoUniverseCheck_-  SafeFlagPolarity             -> SafeFlagPolarity_-  SafeFlagPostulate{}          -> SafeFlagPostulate_-  SafeFlagPragma{}             -> SafeFlagPragma_-  SafeFlagEta                  -> SafeFlagEta_-  SafeFlagInjective            -> SafeFlagInjective_-  SafeFlagNoCoverageCheck      -> SafeFlagNoCoverageCheck_-  SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_-  WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_-  SafeFlagTerminating          -> SafeFlagTerminating_-  TerminationIssue{}           -> TerminationIssue_-  UnreachableClauses{}         -> UnreachableClauses_-  UnsolvedInteractionMetas{}   -> UnsolvedInteractionMetas_-  UnsolvedConstraints{}        -> UnsolvedConstraints_-  UnsolvedMetaVariables{}      -> UnsolvedMetaVariables_-  UselessHiding{}              -> UselessHiding_-  UselessInline{}              -> UselessInline_-  UselessPublic{}              -> UselessPublic_-  UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_-  ClashesViaRenaming{}         -> ClashesViaRenaming_-  UserWarning{}                -> UserWarning_-  InfectiveImport{}            -> InfectiveImport_-  CoInfectiveImport{}          -> CoInfectiveImport_-  RewriteNonConfluent{}        -> RewriteNonConfluent_-  RewriteMaybeNonConfluent{}   -> RewriteMaybeNonConfluent_-  RewriteAmbiguousRules{}      -> RewriteAmbiguousRules_-  RewriteMissingRule{}         -> RewriteMissingRule_-  PragmaCompileErased{}        -> PragmaCompileErased_-  -- record field warnings-  RecordFieldWarning w -> case w of-    DuplicateFieldsWarning{}   -> DuplicateFieldsWarning_-    TooManyFieldsWarning{}     -> TooManyFieldsWarning_--data TCWarning-  = TCWarning-    { tcWarningLocation :: CallStack-        -- ^ Location in the internal Agda source code location where the error raised-    , tcWarningRange    :: Range-        -- ^ Range where the warning was raised-    , tcWarning         :: Warning-        -- ^ The warning itself-    , tcWarningPrintedWarning :: Doc-        -- ^ The warning printed in the state and environment where it was raised-    , tcWarningCached :: Bool-        -- ^ Should the warning be affected by caching.-    }-  deriving (Show, Generic)--tcWarningOrigin :: TCWarning -> SrcFile-tcWarningOrigin = rangeFile . tcWarningRange--instance HasRange TCWarning where-  getRange = tcWarningRange---- used for merging lists of warnings-instance Eq TCWarning where-  (==) = (==) `on` tcWarningPrintedWarning-------------------------------------------------------------------------------- * Type checking errors-------------------------------------------------------------------------------- | Information about a call.--data CallInfo = CallInfo-  { callInfoTarget :: QName-    -- ^ Target function name.-  , callInfoRange :: Range-    -- ^ Range of the target function.-  , callInfoCall :: Closure Term-    -- ^ To be formatted representation of the call.-  } deriving (Show, Generic)-    -- no Eq, Ord instances: too expensive! (see issues 851, 852)---- | We only 'show' the name of the callee.-instance Pretty CallInfo where pretty = pretty . callInfoTarget---- | Information about a mutual block which did not pass the--- termination checker.--data TerminationError = TerminationError-  { termErrFunctions :: [QName]-    -- ^ The functions which failed to check. (May not include-    -- automatically generated functions.)-  , termErrCalls :: [CallInfo]-    -- ^ The problematic call sites.-  } deriving (Show, Generic)---- | Error when splitting a pattern variable into possible constructor patterns.-data SplitError-  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.-  | BlockedType Blocker (Closure Type)  -- ^ Type could not be sufficiently reduced.-  | ErasedDatatype Bool (Closure Type)  -- ^ Data type, but in erased position.-                                        --   If the boolean is 'True',-                                        --   then the reason for the-                                        --   error is that the K rule-                                        --   is turned off.-  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.-  -- UNUSED, but keep!-  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor-  | UnificationStuck-    { cantSplitBlocker  :: Maybe Blocker -- ^ Blocking metavariable (if any)-    , cantSplitConName  :: QName        -- ^ Constructor.-    , cantSplitTel      :: Telescope    -- ^ Context for indices.-    , cantSplitConIdx   :: Args         -- ^ Inferred indices (from type of constructor).-    , cantSplitGivenIdx :: Args         -- ^ Expected indices (from checking pattern).-    , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck.-    }-  | CosplitCatchall-      -- ^ Copattern split with a catchall-  | CosplitNoTarget-      -- ^ We do not know the target type of the clause.-  | CosplitNoRecordType (Closure Type)-      -- ^ Target type is not a record type.-  | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type))--  | GenericSplitError String-  deriving (Show, Generic)--data NegativeUnification-  = UnifyConflict Telescope Term Term-  | UnifyCycle Telescope Int Term-  deriving (Show, Generic)--data UnificationFailure-  = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype-  | UnifyRecursiveEq Telescope Type Int Term          -- ^ Can't solve equation because variable occurs in (type of) lhs-  | UnifyReflexiveEq Telescope Type Term              -- ^ Can't solve reflexive equation because --without-K is enabled-  | UnifyUnusableModality Telescope Type Int Term Modality  -- ^ Can't solve equation because solution modality is less "usable"-  deriving (Show, Generic)--data UnquoteError-  = BadVisibility String (Arg I.Term)-  | ConInsteadOfDef QName String String-  | DefInsteadOfCon QName String String-  | NonCanonical String I.Term-  | BlockedOnMeta TCState Blocker-  | UnquotePanic String-  deriving (Show, Generic)--data TypeError-        = InternalError String-        | NotImplemented String-        | NotSupported String-        | CompilationError String-        | PropMustBeSingleton-        | DataMustEndInSort Term-{- UNUSED-        | DataTooManyParameters-            -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the-            --   the parameters given in the forward declaraion @data D Gamma : T@.--}-        | ShouldEndInApplicationOfTheDatatype Type-            -- ^ The target of a constructor isn't an application of its-            -- datatype. The 'Type' records what it does target.-        | ShouldBeAppliedToTheDatatypeParameters Term Term-            -- ^ The target of a constructor isn't its datatype applied to-            --   something that isn't the parameters. First term is the correct-            --   target and the second term is the actual target.-        | ShouldBeApplicationOf Type QName-            -- ^ Expected a type to be an application of a particular datatype.-        | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype-        | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)-          -- ^ Datatype, constructors.-        | DoesNotConstructAnElementOf QName Type -- ^ constructor, type-        | WrongHidingInLHS-            -- ^ The left hand side of a function definition has a hidden argument-            --   where a non-hidden was expected.-        | WrongHidingInLambda Type-            -- ^ Expected a non-hidden function and found a hidden lambda.-        | WrongHidingInApplication Type-            -- ^ A function is applied to a hidden argument where a non-hidden was expected.-        | WrongNamedArgument (NamedArg A.Expr) [NamedName]-            -- ^ A function is applied to a hidden named argument it does not have.-            -- The list contains names of possible hidden arguments at this point.-        | WrongIrrelevanceInLambda-            -- ^ Wrong user-given relevance annotation in lambda.-        | WrongQuantityInLambda-            -- ^ Wrong user-given quantity annotation in lambda.-        | WrongCohesionInLambda-            -- ^ Wrong user-given cohesion annotation in lambda.-        | QuantityMismatch Quantity Quantity-            -- ^ The given quantity does not correspond to the expected quantity.-        | HidingMismatch Hiding Hiding-            -- ^ The given hiding does not correspond to the expected hiding.-        | RelevanceMismatch Relevance Relevance-            -- ^ The given relevance does not correspond to the expected relevane.-        | UninstantiatedDotPattern A.Expr-        | ForcedConstructorNotInstantiated A.Pattern-        | IllformedProjectionPattern A.Pattern-        | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type-        | WrongNumberOfConstructorArguments QName Nat Nat-        | ShouldBeEmpty Type [DeBruijnPattern]-        | ShouldBeASort Type-            -- ^ The given type should have been a sort.-        | ShouldBePi Type-            -- ^ The given type should have been a pi.-        | ShouldBePath Type-        | ShouldBeRecordType Type-        | ShouldBeRecordPattern DeBruijnPattern-        | NotAProjectionPattern (NamedArg A.Pattern)-        | NotAProperTerm-        | InvalidTypeSort Sort-            -- ^ This sort is not a type expression.-        | InvalidType Term-            -- ^ This term is not a type expression.-        | FunctionTypeInSizeUniv Term-            -- ^ This term, a function type constructor, lives in-            --   @SizeUniv@, which is not allowed.-        | SplitOnIrrelevant (Dom Type)-        | SplitOnUnusableCohesion (Dom Type)-        -- UNUSED: -- | SplitOnErased (Dom Type)-        | SplitOnNonVariable Term Type-        | SplitOnNonEtaRecord QName-        | DefinitionIsIrrelevant QName-        | DefinitionIsErased QName-        | VariableIsIrrelevant Name-        | VariableIsErased Name-        | VariableIsOfUnusableCohesion Name Cohesion-        | UnequalLevel Comparison Level Level-        | UnequalTerms Comparison Term Term CompareAs-        | UnequalTypes Comparison Type Type---      | UnequalTelescopes Comparison Telescope Telescope -- UNUSED-        | UnequalRelevance Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalQuantity Comparison Term Term-            -- ^ The two function types have different relevance.-        | UnequalCohesion Comparison Term Term-            -- ^ The two function types have different cohesion.-        | UnequalHiding Term Term-            -- ^ The two function types have different hiding.-        | UnequalSorts Sort Sort-        | UnequalBecauseOfUniverseConflict Comparison Term Term-        | NotLeqSort Sort Sort-        | MetaCannotDependOn MetaId Nat-            -- ^ The arguments are the meta variable and the parameter that it wants to depend on.-        | MetaOccursInItself MetaId-        | MetaIrrelevantSolution MetaId Term-        | MetaErasedSolution MetaId Term-        | GenericError String-        | GenericDocError Doc-        | SortOfSplitVarError (Maybe Blocker) Doc-          -- ^ the meta is what we might be blocked on.-        | BuiltinMustBeConstructor String A.Expr-        | NoSuchBuiltinName String-        | DuplicateBuiltinBinding String Term Term-        | NoBindingForBuiltin String-        | NoSuchPrimitiveFunction String-        | DuplicatePrimitiveBinding String QName QName-        | WrongModalityForPrimitive String ArgInfo ArgInfo-        | ShadowedModule C.Name [A.ModuleName]-        | BuiltinInParameterisedModule String-        | IllegalLetInTelescope C.TypedBinding-        | IllegalPatternInTelescope C.Binder-        | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]-        | TooManyFields QName [C.Name] [C.Name]-          -- ^ Record type, fields not supplied by user, non-fields but supplied.-        | DuplicateFields [C.Name]-        | DuplicateConstructors [C.Name]-        | WithOnFreeVariable A.Expr Term-        | UnexpectedWithPatterns [A.Pattern]-        | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)-        | FieldOutsideRecord-        | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]-        | GeneralizeCyclicDependency-        | GeneralizeUnsolvedMeta-    -- Coverage errors--- UNUSED:        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off-        | SplitError SplitError-        | ImpossibleConstructor QName NegativeUnification-    -- Positivity errors-        | TooManyPolarities QName Int-    -- Import errors-        | LocalVsImportedModuleClash ModuleName-        | SolvedButOpenHoles-          -- ^ Some interaction points (holes) have not been filled by user.-          --   There are not 'UnsolvedMetas' since unification solved them.-          --   This is an error, since interaction points are never filled-          --   without user interaction.-        | CyclicModuleDependency [C.TopLevelModuleName]-        | FileNotFound C.TopLevelModuleName [AbsolutePath]-        | OverlappingProjects AbsolutePath C.TopLevelModuleName C.TopLevelModuleName-        | AmbiguousTopLevelModuleName C.TopLevelModuleName [AbsolutePath]-        | ModuleNameUnexpected C.TopLevelModuleName C.TopLevelModuleName-          -- ^ Found module name, expected module name.-        | ModuleNameDoesntMatchFileName C.TopLevelModuleName [AbsolutePath]-        | ClashingFileNamesFor ModuleName [AbsolutePath]-        | ModuleDefinedInOtherFile C.TopLevelModuleName AbsolutePath AbsolutePath-          -- ^ Module name, file from which it was loaded, file which-          -- the include path says contains the module.-    -- Scope errors-        | BothWithAndRHS-        | AbstractConstructorNotInScope A.QName-        | NotInScope [C.QName]-        | NoSuchModule C.QName-        | AmbiguousName C.QName (List1 A.QName)-        | AmbiguousModule C.QName (List1 A.ModuleName)-        | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration)-        | ClashingModule A.ModuleName A.ModuleName-        | ClashingImport C.Name A.QName-        | ClashingModuleImport C.Name A.ModuleName-        | PatternShadowsConstructor C.Name A.QName-        | DuplicateImports C.QName [C.ImportedName]-        | InvalidPattern C.Pattern-        | RepeatedVariablesInPattern [C.Name]-        | GeneralizeNotSupportedHere A.QName-        | MultipleFixityDecls [(C.Name, [Fixity'])]-        | MultiplePolarityPragmas [C.Name]-    -- Concrete to Abstract errors-        | NotAModuleExpr C.Expr-            -- ^ The expr was used in the right hand side of an implicit module-            --   definition, but it wasn't of the form @m Delta@.-        | NotAnExpression C.Expr-        | NotAValidLetBinding NiceDeclaration-        | NotValidBeforeField NiceDeclaration-        | NothingAppliedToHiddenArg C.Expr-        | NothingAppliedToInstanceArg C.Expr-    -- Pattern synonym errors-        | BadArgumentsToPatternSynonym A.AmbiguousQName-        | TooFewArgumentsToPatternSynonym A.AmbiguousQName-        | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))-        | UnusedVariableInPatternSynonym-    -- Operator errors-        | NoParseForApplication (List2 C.Expr)-        | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr)-        | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern-            -- ^ The list contains patterns that failed to be interpreted.-            --   If it is non-empty, the first entry could be printed as error hint.-        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]-            -- ^ Pattern and its possible interpretations.-        | OperatorInformation [NotationSection] TypeError-{- UNUSED-        | NoParseForPatternSynonym C.Pattern-        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]--}-    -- Usage errors-    -- Instance search errors-        | InstanceNoCandidate Type [(Term, TCErr)]-    -- Reflection errors-        | UnquoteFailed UnquoteError-        | DeBruijnIndexOutOfScope Nat Telescope [Name]-    -- Language option errors-        | NeedOptionCopatterns-        | NeedOptionRewriting-        | NeedOptionProp-        | NeedOptionTwoLevel-    -- Failure associated to warnings-        | NonFatalErrors [TCWarning]-    -- Instance search errors-        | InstanceSearchDepthExhausted Term Type Int-        | TriedToCopyConstrainedPrim QName-          deriving (Show, Generic)---- | Distinguish error message when parsing lhs or pattern synonym, resp.-data LHSOrPatSyn = IsLHS | IsPatSyn-  deriving (Eq, Show, Generic)---- | Type-checking errors.--data TCErr-  = TypeError-    { tcErrLocation :: CallStack-       -- ^ Location in the internal Agda source code where the error was raised-    , tcErrState    :: TCState-        -- ^ The state in which the error was raised.-    , tcErrClosErr  :: Closure TypeError-        -- ^ The environment in which the error as raised plus the error.-    }-  | Exception Range Doc-  | IOException TCState Range E.IOException-    -- ^ The first argument is the state in which the error was-    -- raised.-  | PatternErr Blocker-      -- ^ The exception which is usually caught.-      --   Raised for pattern violations during unification ('assignV')-      --   but also in other situations where we want to backtrack.-      --   Contains an unblocker to control when the computation should-      --   be retried.--instance Show TCErr where-  show (TypeError _ _ e)   = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e)-  show (Exception r d)     = prettyShow r ++ ": " ++ render d-  show (IOException _ r e) = prettyShow r ++ ": " ++ show e-  show PatternErr{}        = "Pattern violation (you shouldn't see this)"--instance HasRange TCErr where-  getRange (TypeError _ _ cl)  = envRange $ clEnv cl-  getRange (Exception r _)     = r-  getRange (IOException s r _) = r-  getRange PatternErr{}        = noRange--instance E.Exception TCErr---------------------------------------------------------------------------------- * Accessing options--------------------------------------------------------------------------------instance MonadIO m => HasOptions (TCMT m) where-  pragmaOptions = useTC stPragmaOptions--  commandLineOptions = do-    p  <- useTC stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> getTC-    return $ cl { optPragmaOptions = p }---- HasOptions lifts through monad transformers--- (see default signatures in the HasOptions class).---- Ternary options are annoying to deal with so we provide auxiliary--- definitions using @collapseDefault@.--sizedTypesOption :: HasOptions m => m Bool-sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions--guardednessOption :: HasOptions m => m Bool-guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions--withoutKOption :: HasOptions m => m Bool-withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions--enableCaching :: HasOptions m => m Bool-enableCaching = optCaching <$> pragmaOptions--------------------------------------------------------------------------------- * The reduce monad---------------------------------------------------------------------------------- | Environment of the reduce monad.-data ReduceEnv = ReduceEnv-  { redEnv :: TCEnv    -- ^ Read only access to environment.-  , redSt  :: TCState  -- ^ Read only access to state (signature, metas...).-  }--mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv-mapRedEnv f s = s { redEnv = f (redEnv s) }--mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv-mapRedSt f s = s { redSt = f (redSt s) }--mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv-            -> ReduceEnv-mapRedEnvSt f g (ReduceEnv e s) = ReduceEnv (f e) (g s)---- Lenses-reduceEnv :: Lens' TCEnv ReduceEnv-reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }--reduceSt :: Lens' TCState ReduceEnv-reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }--newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }---  deriving (Functor, Applicative, Monad)--onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-onReduceEnv f (ReduceM m) = ReduceM (m . f)--fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b-fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e-{-# INLINE fmapReduce #-}---- Andreas, 2021-05-12, issue #5379:--- It seems more stable to force to evaluate @mf <*> ma@--- from left to right, for the sake of printing--- debug messages in order.-apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b-apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e ->-  let g = f e-      a = x e-  in  g `pseq` a `pseq` g a-{-# INLINE apReduce #-}---- Andreas, 2021-05-12, issue #5379--- Since the MonadDebug instance of ReduceM is implemented via--- unsafePerformIO, we need to force results that later--- computations do not depend on, otherwise we lose debug messages.-thenReduce :: ReduceM a -> ReduceM b -> ReduceM b-thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e-{-# INLINE thenReduce #-}---- Andreas, 2021-05-14:--- `seq` does not force evaluation order, the optimizier is allowed to replace--- @---    a `seq` b`--- @--- by:--- @---    b `seq` a `seq` b--- @--- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html------ In contrast, `pseq` is only strict in its first argument, so such a permutation--- is forbidden.--- If we want to ensure that debug messages are printed before exceptions are--- propagated, we need to use `pseq`, as in:--- @---    unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG--- @-beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a-beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e ->-  let a = x e-  in  a `pseq` y e `pseq` a-{-# INLINE beforeReduce #-}--bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b-bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e-{-# INLINE bindReduce #-}--instance Functor ReduceM where-  fmap = fmapReduce--instance Applicative ReduceM where-  pure x = ReduceM (const x)-  (<*>) = apReduce-  (*>)  = thenReduce-  (<*)  = beforeReduce--instance Monad ReduceM where-  return = pure-  (>>=) = bindReduce-  (>>) = (*>)-#if __GLASGOW_HASKELL__ < 808-  fail = Fail.fail-#endif--instance Fail.MonadFail ReduceM where-  fail = error--instance ReadTCState ReduceM where-  getTCState = ReduceM redSt-  locallyTCState l f = onReduceEnv $ mapRedSt $ over l f--runReduceM :: ReduceM a -> TCM a-runReduceM m = TCM $ \ r e -> do-  s <- readIORef r-  E.evaluate $ unReduceM m $ ReduceEnv e s-  -- Andreas, 2021-05-13, issue #5379-  -- This was the following, which is apparently not strict enough-  -- to force all unsafePerformIOs...-  -- runReduceM m = do-  --   e <- askTC-  --   s <- getTC-  --   return $! unReduceM m (ReduceEnv e s)--runReduceF :: (a -> ReduceM b) -> TCM (a -> b)-runReduceF f = do-  e <- askTC-  s <- getTC-  return $ \x -> unReduceM (f x) (ReduceEnv e s)--instance MonadTCEnv ReduceM where-  askTC   = ReduceM redEnv-  localTC = onReduceEnv . mapRedEnv---- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084):------   useR forces the result of projecting the lens,---   this usually prevents retaining the whole structure when we only need a field.------ This fixes (or contributes to the fix of) the space leak issue #1829 (caching).-useR :: (ReadTCState m) => Lens' a TCState -> m a-useR l = do-  !x <- (^.l) <$> getTCState-  return x--askR :: ReduceM ReduceEnv-askR = ReduceM ask--localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a-localR f = ReduceM . local f . unReduceM--instance HasOptions ReduceM where-  pragmaOptions      = useR stPragmaOptions-  commandLineOptions = do-    p  <- useR stPragmaOptions-    cl <- stPersistentOptions . stPersistentState <$> getTCState-    return $ cl{ optPragmaOptions = p }--class ( Applicative m-      , MonadTCEnv m-      , ReadTCState m-      , HasOptions m-      ) => MonadReduce m where-  liftReduce :: ReduceM a -> m a--  default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a-  liftReduce = lift . liftReduce--instance MonadReduce ReduceM where-  liftReduce = id--instance MonadReduce m => MonadReduce (ChangeT m)-instance MonadReduce m => MonadReduce (ExceptT err m)-instance MonadReduce m => MonadReduce (IdentityT m)-instance MonadReduce m => MonadReduce (ListT m)-instance MonadReduce m => MonadReduce (MaybeT m)-instance MonadReduce m => MonadReduce (ReaderT r m)-instance MonadReduce m => MonadReduce (StateT w m)-instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m)-instance MonadReduce m => MonadReduce (BlockT m)-------------------------------------------------------------------------------- * Monad with read-only 'TCEnv'-------------------------------------------------------------------------------- | @MonadTCEnv@ made into its own dedicated service class.---   This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@.-class Monad m => MonadTCEnv m where-  askTC   :: m TCEnv-  localTC :: (TCEnv -> TCEnv) -> m a -> m a--  default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv-  askTC = lift askTC--  default localTC-    :: (MonadTransControl t, MonadTCEnv n, t n ~ m)-    =>  (TCEnv -> TCEnv) -> m a -> m a-  localTC = liftThrough . localTC--instance MonadTCEnv m => MonadTCEnv (ChangeT m)-instance MonadTCEnv m => MonadTCEnv (ExceptT err m)-instance MonadTCEnv m => MonadTCEnv (IdentityT m)-instance MonadTCEnv m => MonadTCEnv (MaybeT m)-instance MonadTCEnv m => MonadTCEnv (ReaderT r m)-instance MonadTCEnv m => MonadTCEnv (StateT s m)-instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m)--instance MonadTCEnv m => MonadTCEnv (ListT m) where-  localTC = mapListT . localTC--asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a-asksTC f = f <$> askTC--viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a-viewTC l = asksTC (^. l)---- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.-locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b-locallyTC l = localTC . over l-------------------------------------------------------------------------------- * Monad with mutable 'TCState'-------------------------------------------------------------------------------- | @MonadTCState@ made into its own dedicated service class.---   This allows us to use 'MonadState' for 'StateT' extensions of @TCM@.-class Monad m => MonadTCState m where-  getTC :: m TCState-  putTC :: TCState -> m ()-  modifyTC :: (TCState -> TCState) -> m ()--  default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState-  getTC = lift getTC--  default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()-  putTC = lift . putTC--  default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()-  modifyTC = lift . modifyTC--instance MonadTCState m => MonadTCState (MaybeT m)-instance MonadTCState m => MonadTCState (ListT m)-instance MonadTCState m => MonadTCState (ExceptT err m)-instance MonadTCState m => MonadTCState (ReaderT r m)-instance MonadTCState m => MonadTCState (StateT s m)-instance MonadTCState m => MonadTCState (ChangeT m)-instance MonadTCState m => MonadTCState (IdentityT m)-instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m)---- ** @TCState@ accessors (no lenses)--getsTC :: ReadTCState m => (TCState -> a) -> m a-getsTC f = f <$> getTCState---- | A variant of 'modifyTC' in which the computation is strict in the--- new state.-modifyTC' :: MonadTCState m => (TCState -> TCState) -> m ()-modifyTC' f = do-  s' <- getTC-  putTC $! f s'---- SEE TC.Monad.State--- -- | Restore the 'TCState' after computation.--- localTCState :: MonadTCState m => m a -> m a--- localTCState = bracket_ getTC putTC---- ** @TCState@ accessors via lenses--useTC :: ReadTCState m => Lens' a TCState -> m a-useTC l = do-  !x <- getsTC (^. l)-  return x--infix 4 `setTCLens`---- | Overwrite the part of the 'TCState' focused on by the lens.-setTCLens :: MonadTCState m => Lens' a TCState -> a -> m ()-setTCLens l = modifyTC . set l---- | Modify the part of the 'TCState' focused on by the lens.-modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()-modifyTCLens l = modifyTC . over l---- | Modify a part of the state monadically.-modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m ()-modifyTCLensM l f = putTC =<< l f =<< getTC---- | Modify the part of the 'TCState' focused on by the lens, and return some result.-stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r-stateTCLens l f = stateTCLensM l $ return . f---- | Modify a part of the state monadically, and return some result.-stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r-stateTCLensM l f = do-  s <- getTC-  (result , x) <- f $ s ^. l-  putTC $ set l x s-  return result--------------------------------------------------------------------------------- ** Monad with capability to block a computation------------------------------------------------------------------------------class Monad m => MonadBlock m where--  -- | `patternViolation b` aborts the current computation-  patternViolation :: Blocker -> m a--  default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a-  patternViolation = lift . patternViolation--  -- | `catchPatternErr handle m` runs m, handling pattern violations-  --    with `handle` (doesn't roll back the state)-  catchPatternErr :: (Blocker -> m a) -> m a -> m a--newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a }-  deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2-           , MonadIO, Fail.MonadFail-           , ReadTCState, HasOptions-           , MonadTCEnv, MonadTCState, MonadTCM-           )--instance Monad m => MonadBlock (BlockT m) where-  patternViolation = BlockT . throwError-  catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h)--instance Monad m => MonadBlock (ExceptT TCErr m) where-  patternViolation = throwError . PatternErr-  catchPatternErr h f = catchError f $ \case-    PatternErr b -> h b-    err          -> throwError err--runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)-runBlocked = runExceptT . unBlockT--instance MonadBlock m => MonadBlock (MaybeT m) where-  catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m--instance MonadBlock m => MonadBlock (ReaderT e m) where-  catchPatternErr h m = ReaderT $ \ e ->-    let run = flip runReaderT e in catchPatternErr (run . h) (run m)-------------------------------------------------------------------------------- * Type checking monad transformer-------------------------------------------------------------------------------- | The type checking monad transformer.--- Adds readonly 'TCEnv' and mutable 'TCState'.-newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }---- | Type checking monad.-type TCM = TCMT IO--{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}-mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a-mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e)--pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a-pureTCM f = TCM $ \ r e -> do-  s <- liftIO $ readIORef r-  return (f s e)---- One goal of the definitions and pragmas below is to inline the--- monad operations as much as possible. This doesn't seem to have a--- large effect on the performance of the normal executable, but (at--- least on one machine/configuration) it has a massive effect on the--- performance of the profiling executable [1], and reduces the time--- attributed to bind from over 90% to about 25%.------ [1] When compiled with -auto-all and run with -p: roughly 750%--- faster for one example.--returnTCMT :: Applicative m => a -> TCMT m a-returnTCMT = \x -> TCM $ \_ _ -> pure x-{-# INLINE returnTCMT #-}--bindTCMT :: Monad m => TCMT m a -> (a -> TCMT m b) -> TCMT m b-bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e-{-# INLINE bindTCMT #-}--thenTCMT :: Applicative m => TCMT m a -> TCMT m b -> TCMT m b-thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e *> m2 r e-{-# INLINE thenTCMT #-}--instance Functor m => Functor (TCMT m) where-  fmap = fmapTCMT--fmapTCMT :: Functor m => (a -> b) -> TCMT m a -> TCMT m b-fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e)-{-# INLINE fmapTCMT #-}--instance Applicative m => Applicative (TCMT m) where-  pure  = returnTCMT-  (<*>) = apTCMT--apTCMT :: Applicative m => TCMT m (a -> b) -> TCMT m a -> TCMT m b-apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> mf r e <*> m r e-{-# INLINE apTCMT #-}--instance MonadTrans TCMT where-    lift m = TCM $ \_ _ -> m---- We want a special monad implementation of fail.-#if __GLASGOW_HASKELL__ < 808-instance MonadIO m => Monad (TCMT m) where-#else--- Andreas, 2022-02-02, issue #5659:--- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here--- if we want @instance MonadTrans TCMT@.-instance Monad m => Monad (TCMT m) where-#endif-    return = pure-    (>>=)  = bindTCMT-    (>>)   = (*>)-#if __GLASGOW_HASKELL__ < 808-    fail   = Fail.fail-#endif--instance MonadIO m => Fail.MonadFail (TCMT m) where-  fail = internalError--instance MonadIO m => MonadIO (TCMT m) where-  liftIO m = TCM $ \ s env -> do-    liftIO $ wrap s (envRange env) $ do-      x <- m-      x `seq` return x-    where-      wrap s r m = E.catch m $ \ err -> do-        s <- readIORef s-        E.throwIO $ IOException s r err--instance MonadIO m => MonadTCEnv (TCMT m) where-  askTC             = TCM $ \ _ e -> return e-  localTC f (TCM m) = TCM $ \ s e -> m s (f e)--instance MonadIO m => MonadTCState (TCMT m) where-  getTC   = TCM $ \ r _e -> liftIO (readIORef r)-  putTC s = TCM $ \ r _e -> liftIO (writeIORef r s)-  modifyTC f = putTC . f =<< getTC--instance MonadIO m => ReadTCState (TCMT m) where-  getTCState = getTC-  locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l)--instance MonadBlock TCM where-  patternViolation b = throwError (PatternErr b)-  catchPatternErr handle v =-       catchError_ v $ \err ->-       case err of-            -- Not putting s (which should really be the what's already there) makes things go-            -- a lot slower (+20% total time on standard library). How is that possible??-            -- The problem is most likely that there are internal catchErrors which forgets the-            -- state. catchError should preserve the state on pattern violations.-           PatternErr u -> handle u-           _            -> throwError err---instance MonadError TCErr TCM where-  throwError = liftIO . E.throwIO-  catchError m h = TCM $ \ r e -> do  -- now we are in the IO monad-    oldState <- readIORef r-    unTCM m r e `E.catch` \err -> do-      -- Reset the state, but do not forget changes to the persistent-      -- component. Not for pattern violations.-      case err of-        PatternErr{} -> return ()-        _            ->-          liftIO $ do-            newState <- readIORef r-            writeIORef r $ oldState { stPersistentState = stPersistentState newState }-      unTCM (h err) r e---- | Like 'catchError', but resets the state completely before running the handler.---   This means it also loses changes to the 'stPersistentState'.------   The intended use is to catch internal errors during debug printing.---   In debug printing, we are not expecting state changes.-instance CatchImpossible TCM where-  catchImpossibleJust f m h = TCM $ \ r e -> do-    -- save the state-    s <- readIORef r-    catchImpossibleJust f (unTCM m r e) $ \ err -> do-      writeIORef r s-      unTCM (h err) r e--instance MonadIO m => MonadReduce (TCMT m) where-  liftReduce = liftTCM . runReduceM--instance (IsString a, MonadIO m) => IsString (TCMT m a) where-  fromString s = return (fromString s)---- | Strict (non-shortcut) semigroup.------   Note that there might be a lazy alternative, e.g.,---   for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation,---   to shortcut conjunction in case we already have 'False'.----instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where-  (<>) = liftA2 (<>)---- | Strict (non-shortcut) monoid.-instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where-  mempty  = pure mempty-  mappend = (<>)-  mconcat = mconcat <.> sequence--instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where-  empty = return empty-  null  = __IMPOSSIBLE__---- | Preserve the state of the failing computation.-catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a-catchError_ m h = TCM $ \r e ->-  unTCM m r e-  `E.catch` \err -> unTCM (h err) r e---- | Execute a finalizer even when an exception is thrown.---   Does not catch any errors.---   In case both the regular computation and the finalizer---   throw an exception, the one of the finalizer is propagated.-finally_ :: TCM a -> TCM b -> TCM a-finally_ m f = do-    x <- m `catchError_` \ err -> f >> throwError err-    _ <- f-    return x---- | Embedding a TCM computation.--class ( Applicative tcm, MonadIO tcm-      , MonadTCEnv tcm-      , MonadTCState tcm-      , HasOptions tcm-      ) => MonadTCM tcm where-    liftTCM :: TCM a -> tcm a--    default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a-    liftTCM = lift . liftTCM--{-# RULES "liftTCM/id" liftTCM = id #-}-instance MonadIO m => MonadTCM (TCMT m) where-    liftTCM = mapTCMT liftIO--instance MonadTCM tcm => MonadTCM (ChangeT tcm)-instance MonadTCM tcm => MonadTCM (ExceptT err tcm)-instance MonadTCM tcm => MonadTCM (IdentityT tcm)-instance MonadTCM tcm => MonadTCM (ListT tcm)-instance MonadTCM tcm => MonadTCM (MaybeT tcm)-instance MonadTCM tcm => MonadTCM (ReaderT r tcm)-instance MonadTCM tcm => MonadTCM (StateT s tcm)-instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm)---- | We store benchmark statistics in an IORef.---   This enables benchmarking pure computation, see---   "Agda.Benchmarking".-instance MonadBench TCM where-  type BenchPhase TCM = Phase-  getBenchmark = liftIO $ getBenchmark-  putBenchmark = liftIO . putBenchmark-  finally = finally_--instance Null (TCM Doc) where-  empty = return empty-  null = __IMPOSSIBLE__--internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a-internalError s = withCallerCallStack $ \ loc ->-  liftTCM $ typeError' loc $ InternalError s---- | The constraints needed for 'typeError' and similar.-type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)---- | Utility function for 1-arg constructed type errors.--- Note that the @HasCallStack@ constraint is on the *resulting* function.-locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b)-locatedTypeError f e = withCallerCallStack (flip typeError' (f e))--genericError :: (HasCallStack, MonadTCError m) => String -> m a-genericError = locatedTypeError GenericError--{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}-genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a-genericDocError = locatedTypeError GenericDocError--{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-}-typeError' :: MonadTCError m => CallStack -> TypeError -> m a-typeError' loc err = throwError =<< typeError'_ loc err--{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-}-typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a-typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err--{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-}-typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr-typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err--{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-}-typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr-typeError_ = withCallerCallStack . flip typeError'_---- | Running the type checking monad (most general form).-{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}-runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)-runTCM e s m = do-  r <- liftIO $ newIORef s-  a <- unTCM m r e-  s <- liftIO $ readIORef r-  return (a, s)---- | Running the type checking monad on toplevel (with initial state).-runTCMTop :: TCM a -> IO (Either TCErr a)-runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left)--runTCMTop' :: MonadIO m => TCMT m a -> m a-runTCMTop' m = do-  r <- liftIO $ newIORef initState-  unTCM m r initEnv---- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which---   cannot fail, except that it might raise 'IOException's) in the---   initial environment.--runSafeTCM :: TCM a -> TCState -> IO (a, TCState)-runSafeTCM m st =-  runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of-    IOException _ _ err -> E.throwIO err-    _                   -> __IMPOSSIBLE__---- | Runs the given computation in a separate thread, with /a copy/ of--- the current state and environment.------ Note that Agda sometimes uses actual, mutable state. If the--- computation given to @forkTCM@ tries to /modify/ this state, then--- bad things can happen, because accesses are not mutually exclusive.--- The @forkTCM@ function has been added mainly to allow the thread to--- /read/ (a snapshot of) the current state in a convenient way.------ Note also that exceptions which are raised in the thread are not--- propagated to the parent, so the thread should not do anything--- important.--forkTCM :: TCM a -> TCM ()-forkTCM m = do-  s <- getTC-  e <- askTC-  liftIO $ void $ C.forkIO $ void $ runTCM e s m-------------------------------------------------------------------------------- * Names for generated definitions-------------------------------------------------------------------------------- | Base name for patterns in telescopes-patternInTeleName :: String-patternInTeleName = ".patternInTele"---- | Base name for extended lambda patterns-extendedLambdaName :: String-extendedLambdaName = ".extendedlambda"---- | Check whether we have an definition from an extended lambda.-isExtendedLambdaName :: A.QName -> Bool-isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName---- | Name of absurdLambda definitions.-absurdLambdaName :: String-absurdLambdaName = ".absurdlambda"---- | Check whether we have an definition from an absurd lambda.-isAbsurdLambdaName :: QName -> Bool-isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName---- | Base name for generalized variable projections-generalizedFieldName :: String-generalizedFieldName = ".generalizedField-"---- | Check whether we have a generalized variable field-getGeneralizedFieldName :: A.QName -> Maybe String-getGeneralizedFieldName q-  | generalizedFieldName `List.isPrefixOf` strName = Just (drop (length generalizedFieldName) strName)-  | otherwise                                      = Nothing-  where strName = prettyShow $ nameConcrete $ qnameName q-------------------------------------------------------------------------------- * KillRange instances------------------------------------------------------------------------------instance KillRange Signature where-  killRange (Sig secs defs rews) = killRange2 Sig secs defs rews--instance KillRange Sections where-  killRange = fmap killRange--instance KillRange Definitions where-  killRange = fmap killRange--instance KillRange RewriteRuleMap where-  killRange = fmap killRange--instance KillRange Section where-  killRange (Section tel) = killRange1 Section tel--instance KillRange Definition where-  killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def) =-    killRange19 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def-    -- TODO clarify: Keep the range in the defName field?--instance KillRange NumGeneralizableArgs where-  killRange = id--instance KillRange NLPat where-  killRange (PVar x y) = killRange2 PVar x y-  killRange (PDef x y) = killRange2 PDef x y-  killRange (PLam x y) = killRange2 PLam x y-  killRange (PPi x y)  = killRange2 PPi x y-  killRange (PSort x)  = killRange1 PSort x-  killRange (PBoundVar x y) = killRange2 PBoundVar x y-  killRange (PTerm x)  = killRange1 PTerm x--instance KillRange NLPType where-  killRange (NLPType s a) = killRange2 NLPType s a--instance KillRange NLPSort where-  killRange (PType l) = killRange1 PType l-  killRange (PProp l) = killRange1 PProp l-  killRange s@(PInf f n) = s-  killRange PSizeUniv = PSizeUniv-  killRange PLockUniv = PLockUniv--instance KillRange RewriteRule where-  killRange (RewriteRule q gamma f es rhs t c) =-    killRange6 RewriteRule q gamma f es rhs t c--instance KillRange CompiledRepresentation where-  killRange = id---instance KillRange EtaEquality where-  killRange = id--instance KillRange System where-  killRange (System tel sys) = System (killRange tel) (killRange sys)--instance KillRange ExtLamInfo where-  killRange (ExtLamInfo m b sys) = killRange3 ExtLamInfo m b sys--instance KillRange FunctionFlag where-  killRange = id--instance KillRange CompKit where-  killRange = id--instance KillRange Defn where-  killRange def =-    case def of-      Axiom a -> Axiom a-      DataOrRecSig n -> DataOrRecSig n-      GeneralizableVar -> GeneralizableVar-      AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!-      Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with ->-        killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with-      Datatype a b c d e f g h       -> killRange7 Datatype a b c d e f g h-      Record a b c d e f g h i j k l -> killRange12 Record a b c d e f g h i j k l-      Constructor a b c d e f g h i j-> killRange10 Constructor a b c d e f g h i j-      Primitive a b c d e            -> killRange5 Primitive a b c d e-      PrimitiveSort a b              -> killRange2 PrimitiveSort a b--instance KillRange MutualId where-  killRange = id--instance KillRange c => KillRange (FunctionInverse' c) where-  killRange NotInjective = NotInjective-  killRange (Inverse m)  = Inverse $ killRangeMap m--instance KillRange TermHead where-  killRange SortHead     = SortHead-  killRange PiHead       = PiHead-  killRange (ConsHead q) = ConsHead $ killRange q-  killRange h@VarHead{}  = h-  killRange UnknownHead  = UnknownHead--instance KillRange Projection where-  killRange (Projection a b c d e) = killRange5 Projection a b c d e--instance KillRange ProjLams where-  killRange = id--instance KillRange a => KillRange (Open a) where-  killRange = fmap killRange--instance KillRange DisplayForm where-  killRange (Display n es dt) = killRange3 Display n es dt--instance KillRange Polarity where-  killRange = id--instance KillRange IsForced where-  killRange = id--instance KillRange DoGeneralize where-  killRange = id--instance KillRange DisplayTerm where-  killRange dt =-    case dt of-      DWithApp dt dts es -> killRange3 DWithApp dt dts es-      DCon q ci dts     -> killRange3 DCon q ci dts-      DDef q dts        -> killRange2 DDef q dts-      DDot v            -> killRange1 DDot v-      DTerm v           -> killRange1 DTerm v--instance KillRange a => KillRange (Closure a) where-  killRange = id-------------------------------------------------------------------------------- NFData instances------------------------------------------------------------------------------instance NFData NumGeneralizableArgs where-  rnf NoGeneralizableArgs       = ()-  rnf (SomeGeneralizableArgs _) = ()--instance NFData TCErr where-  rnf (TypeError a b c)   = rnf a `seq` rnf b `seq` rnf c-  rnf (Exception a b)     = rnf a `seq` rnf b-  rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c)-                            -- At the time of writing there is no-                            -- NFData instance for E.IOException.-  rnf (PatternErr a)      = rnf a---- | This instance could be optimised, some things are guaranteed to--- be forced.--instance NFData PreScopeState---- | This instance could be optimised, some things are guaranteed to--- be forced.--instance NFData PostScopeState--instance NFData TCState-instance NFData DisambiguatedName-instance NFData MutualBlock-instance NFData PersistentTCState-instance NFData LoadedFileCache-instance NFData TypeCheckAction-instance NFData ModuleCheckMode-instance NFData ModuleInfo-instance NFData ForeignCode-instance NFData Interface-instance NFData a => NFData (Closure a)-instance NFData ProblemConstraint-instance NFData Constraint-instance NFData Signature-instance NFData Comparison-instance NFData CompareAs-instance NFData a => NFData (Open a)-instance NFData a => NFData (Judgement a)-instance NFData DoGeneralize-instance NFData GeneralizedValue-instance NFData MetaVariable-instance NFData Listener-instance NFData MetaInstantiation-instance NFData Frozen-instance NFData PrincipalArgTypeMetas-instance NFData TypeCheckingProblem-instance NFData RunMetaOccursCheck-instance NFData MetaInfo-instance NFData InteractionPoint-instance NFData InteractionPoints-instance NFData Overapplied-instance NFData t => NFData (IPBoundary' t)-instance NFData IPClause-instance NFData DisplayForm-instance NFData DisplayTerm-instance NFData NLPat-instance NFData NLPType-instance NFData NLPSort-instance NFData RewriteRule-instance NFData Definition-instance NFData Polarity-instance NFData IsForced-instance NFData Projection-instance NFData ProjLams-instance NFData CompilerPragma-instance NFData System-instance NFData ExtLamInfo-instance NFData EtaEquality-instance NFData FunctionFlag-instance NFData CompKit+{-# LANGUAGE RecursiveDo #-}+-- {-# LANGUAGE UndecidableInstances #-}  -- ghc >= 8.2, GeneralizedNewtypeDeriving MonadTransControl BlockT++module Agda.TypeChecking.Monad.Base+  ( module Agda.TypeChecking.Monad.Base+  , HasOptions (..)+  ) where++import Prelude hiding (null)++import Control.Applicative hiding (empty)+import qualified Control.Concurrent as C+import Control.DeepSeq+import qualified Control.Exception as E++import qualified Control.Monad.Fail as Fail++import Control.Monad                ( void )+import Control.Monad.Except+import Control.Monad.Fix+import Control.Monad.IO.Class       ( MonadIO(..) )+import Control.Monad.State          ( MonadState(..), modify, StateT(..), runStateT )+import Control.Monad.Reader         ( MonadReader(..), ReaderT(..), runReaderT )+import Control.Monad.Writer         ( WriterT )+import Control.Monad.Trans          ( MonadTrans(..), lift )+import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough )+import Control.Monad.Trans.Identity ( IdentityT(..), runIdentityT )+import Control.Monad.Trans.Maybe    ( MaybeT(..) )++import Control.Parallel             ( pseq )++import Data.Array (Ix)+import Data.DList (DList)+import Data.Function (on)+import Data.Int+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map -- hiding (singleton, null, empty)+import Data.Sequence (Seq)+import Data.Set (Set)+import qualified Data.Set as Set -- hiding (singleton, null, empty)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import Data.HashSet (HashSet)+import Data.Semigroup ( Semigroup, (<>)) --, Any(..) )+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import Data.IORef++import GHC.Generics (Generic)++import Agda.Benchmarking (Benchmark, Phase)++import Agda.Syntax.Common+import qualified Agda.Syntax.Concrete as C+import Agda.Syntax.Concrete.Definitions+  (NiceDeclaration, DeclarationWarning, dwWarning, declarationWarningName)+import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.MetaVars+import Agda.Syntax.Internal.Generic (TermLike(..))+import Agda.Syntax.Parser (ParseWarning)+import Agda.Syntax.Parser.Monad (parseWarningName)+import Agda.Syntax.TopLevelModuleName+  (RawTopLevelModuleName, TopLevelModuleName)+import Agda.Syntax.Treeless (Compiled)+import Agda.Syntax.Notation+import Agda.Syntax.Position+import Agda.Syntax.Scope.Base+import qualified Agda.Syntax.Info as Info++import Agda.TypeChecking.CompiledClause+import Agda.TypeChecking.Coverage.SplitTree+import Agda.TypeChecking.Positivity.Occurrence+import Agda.TypeChecking.Free.Lazy (Free(freeVars'), underBinder', underBinder)++-- Args, defined in Agda.Syntax.Treeless and exported from Agda.Compiler.Backend+-- conflicts with Args, defined in Agda.Syntax.Internal and also imported here.+-- This only matters when interpreted in ghci, which sees all of the module's+-- exported symbols, not just the ones defined in the `.hs-boot`. See the+-- comment in ../../Compiler/Backend.hs-boot+import {-# SOURCE #-} Agda.Compiler.Backend hiding (Args)++import Agda.Interaction.Options+import Agda.Interaction.Options.Warnings+import {-# SOURCE #-} Agda.Interaction.Response+  (InteractionOutputCallback, defaultInteractionOutputCallback)+import Agda.Interaction.Highlighting.Precise+  (HighlightingInfo, NameKind)+import Agda.Interaction.Library++import Agda.Utils.Benchmark (MonadBench(..))+import Agda.Utils.BiMap (BiMap, HasTag(..))+import qualified Agda.Utils.BiMap as BiMap+import Agda.Utils.CallStack ( CallStack, HasCallStack, withCallerCallStack )+import Agda.Utils.FileName+import Agda.Utils.Functor+import Agda.Utils.Hash+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.List1 (List1, pattern (:|))+import Agda.Utils.List2 (List2, pattern List2)+import qualified Agda.Utils.List1 as List1+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Permutation+import Agda.Utils.Pretty+import Agda.Utils.Singleton+import Agda.Utils.SmallSet (SmallSet)+import qualified Agda.Utils.SmallSet as SmallSet+import Agda.Utils.Update+import Agda.Utils.WithDefault ( collapseDefault )++import Agda.Utils.Impossible++---------------------------------------------------------------------------+-- * Type checking state+---------------------------------------------------------------------------++data TCState = TCSt+  { stPreScopeState   :: !PreScopeState+    -- ^ The state which is frozen after scope checking.+  , stPostScopeState  :: !PostScopeState+    -- ^ The state which is modified after scope checking.+  , stPersistentState :: !PersistentTCState+    -- ^ State which is forever, like a diamond.+  }+  deriving Generic++class Monad m => ReadTCState m where+  getTCState :: m TCState+  locallyTCState :: Lens' a TCState -> (a -> a) -> m b -> m b++  withTCState :: (TCState -> TCState) -> m a -> m a+  withTCState = locallyTCState id++  default getTCState :: (MonadTrans t, ReadTCState n, t n ~ m) => m TCState+  getTCState = lift getTCState++  default locallyTCState+    :: (MonadTransControl t, ReadTCState n, t n ~ m)+    => Lens' a TCState -> (a -> a) -> m b -> m b+  locallyTCState l = liftThrough . locallyTCState l++instance ReadTCState m => ReadTCState (ListT m) where+  locallyTCState l = mapListT . locallyTCState l++instance ReadTCState m => ReadTCState (ChangeT m)+instance ReadTCState m => ReadTCState (ExceptT err m)+instance ReadTCState m => ReadTCState (IdentityT m)+instance ReadTCState m => ReadTCState (MaybeT m)+instance ReadTCState m => ReadTCState (ReaderT r m)+instance ReadTCState m => ReadTCState (StateT s m)+instance (Monoid w, ReadTCState m) => ReadTCState (WriterT w m)+++instance Show TCState where+  show _ = "TCSt{}"++data PreScopeState = PreScopeState+  { stPreTokens             :: !HighlightingInfo+    -- ^ Highlighting info for tokens and Happy parser warnings (but+    -- not for those tokens/warnings for which highlighting exists in+    -- 'stPostSyntaxInfo').+  , stPreImports            :: !Signature  -- XX populated by scope checker+    -- ^ Imported declared identifiers.+    --   Those most not be serialized!+  , stPreImportedModules    :: !(HashSet TopLevelModuleName)+    -- ^ The top-level modules imported by the current module.+  , stPreModuleToSource     :: !ModuleToSource   -- imports+  , stPreVisitedModules     :: !VisitedModules   -- imports+  , stPreScope              :: !ScopeInfo+    -- generated by scope checker, current file:+    -- which modules you have, public definitions, current file, maps concrete names to abstract names.+  , stPrePatternSyns        :: !A.PatternSynDefns+    -- ^ Pattern synonyms of the current file.  Serialized.+  , stPrePatternSynImports  :: !A.PatternSynDefns+    -- ^ Imported pattern synonyms.  Must not be serialized!+  , stPreGeneralizedVars    :: !(Strict.Maybe (Set QName))+    -- ^ Collected generalizable variables; used during scope checking of terms+  , stPrePragmaOptions      :: !PragmaOptions+    -- ^ Options applying to the current file. @OPTIONS@+    -- pragmas only affect this field.+  , stPreImportedBuiltins   :: !(BuiltinThings PrimFun)+  , stPreImportedDisplayForms :: !DisplayForms+    -- ^ Display forms added by someone else to imported identifiers+  , stPreImportedInstanceDefs :: !InstanceTable+  , stPreForeignCode        :: !(Map BackendName [ForeignCode])+    -- ^ @{-\# FOREIGN \#-}@ code that should be included in the compiled output.+    -- Does not include code for imported modules.+  , stPreFreshInteractionId :: !InteractionId+  , stPreImportedUserWarnings :: !(Map A.QName Text)+    -- ^ Imported @UserWarning@s, not to be stored in the @Interface@+  , stPreLocalUserWarnings    :: !(Map A.QName Text)+    -- ^ Locally defined @UserWarning@s, to be stored in the @Interface@+  , stPreWarningOnImport      :: !(Strict.Maybe Text)+    -- ^ Whether the current module should raise a warning when opened+  , stPreImportedPartialDefs :: !(Set QName)+    -- ^ Imported partial definitions, not to be stored in the @Interface@+  , stPreProjectConfigs :: !(Map FilePath ProjectConfig)+    -- ^ Map from directories to paths of closest enclosing .agda-lib+    --   files (or @Nothing@ if there are none).+  , stPreAgdaLibFiles   :: !(Map FilePath AgdaLibFile)+    -- ^ Contents of .agda-lib files that have already been parsed.+  , stPreImportedMetaStore :: !RemoteMetaStore+    -- ^ Used for meta-variables from other modules.+  }+  deriving Generic++-- | Name disambiguation for the sake of highlighting.+data DisambiguatedName = DisambiguatedName NameKind A.QName+  deriving Generic+type DisambiguatedNames = IntMap DisambiguatedName++type ConcreteNames = Map Name [C.Name]++data PostScopeState = PostScopeState+  { stPostSyntaxInfo          :: !HighlightingInfo+    -- ^ Highlighting info.+  , stPostDisambiguatedNames  :: !DisambiguatedNames+    -- ^ Disambiguation carried out by the type checker.+    --   Maps position of first name character to disambiguated @'A.QName'@+    --   for each @'A.AmbiguousQName'@ already passed by the type checker.+  , stPostOpenMetaStore       :: !LocalMetaStore+    -- ^ Used for open meta-variables.+  , stPostSolvedMetaStore     :: !LocalMetaStore+    -- ^ Used for local, instantiated meta-variables.+  , stPostInteractionPoints   :: !InteractionPoints -- scope checker first+  , stPostAwakeConstraints    :: !Constraints+  , stPostSleepingConstraints :: !Constraints+  , stPostDirty               :: !Bool -- local+    -- ^ Dirty when a constraint is added, used to prevent pointer update.+    -- Currently unused.+  , stPostOccursCheckDefs     :: !(Set QName) -- local+    -- ^ Definitions to be considered during occurs check.+    --   Initialized to the current mutual block before the check.+    --   During occurs check, we remove definitions from this set+    --   as soon we have checked them.+  , stPostSignature           :: !Signature+    -- ^ Declared identifiers of the current file.+    --   These will be serialized after successful type checking.+  , stPostModuleCheckpoints   :: !(Map ModuleName CheckpointId)+    -- ^ For each module remember the checkpoint corresponding to the orignal+    --   context of the module parameters.+  , stPostImportsDisplayForms :: !DisplayForms+    -- ^ Display forms we add for imported identifiers+  , stPostCurrentModule       ::+      !(Maybe (ModuleName, TopLevelModuleName))+    -- ^ The current module is available after it has been type+    -- checked.+  , stPostInstanceDefs        :: !TempInstanceTable+  , stPostConcreteNames       :: !ConcreteNames+    -- ^ Map keeping track of concrete names assigned to each abstract name+    --   (can be more than one name in case the first one is shadowed)+  , stPostUsedNames           :: !(Map RawName (DList RawName))+    -- ^ Map keeping track for each name root (= name w/o numeric+    -- suffixes) what names with the same root have been used during a+    -- TC computation. This information is used to build the+    -- @ShadowingNames@ map.+  , stPostShadowingNames      :: !(Map Name (DList RawName))+    -- ^ Map keeping track for each (abstract) name the list of all+    -- (raw) names that it could maybe be shadowed by.+  , stPostStatistics          :: !Statistics+    -- ^ Counters to collect various statistics about meta variables etc.+    --   Only for current file.+  , stPostTCWarnings          :: ![TCWarning]+  , stPostMutualBlocks        :: !(Map MutualId MutualBlock)+  , stPostLocalBuiltins       :: !(BuiltinThings PrimFun)+  , stPostFreshMetaId         :: !MetaId+  , stPostFreshMutualId       :: !MutualId+  , stPostFreshProblemId      :: !ProblemId+  , stPostFreshCheckpointId   :: !CheckpointId+  , stPostFreshInt            :: !Int+  , stPostFreshNameId         :: !NameId+  , stPostAreWeCaching        :: !Bool+  , stPostPostponeInstanceSearch :: !Bool+  , stPostConsideringInstance :: !Bool+  , stPostInstantiateBlocking :: !Bool+    -- ^ Should we instantiate away blocking metas?+    --   This can produce ill-typed terms but they are often more readable. See issue #3606.+    --   Best set to True only for calls to pretty*/reify to limit unwanted reductions.+  , stPostLocalPartialDefs    :: !(Set QName)+    -- ^ Local partial definitions, to be stored in the @Interface@+  }+  deriving (Generic)++-- | A mutual block of names in the signature.+data MutualBlock = MutualBlock+  { mutualInfo  :: Info.MutualInfo+    -- ^ The original info of the mutual block.+  , mutualNames :: Set QName+  } deriving (Show, Eq, Generic)++instance Null MutualBlock where+  empty = MutualBlock empty empty++-- | A part of the state which is not reverted when an error is thrown+-- or the state is reset.+data PersistentTCState = PersistentTCSt+  { stDecodedModules    :: !DecodedModules+  , stPersistentTopLevelModuleNames ::+      !(BiMap RawTopLevelModuleName ModuleNameHash)+    -- ^ Module name hashes for top-level module names (and vice+    -- versa).+  , stPersistentOptions :: CommandLineOptions+  , stInteractionOutputCallback  :: InteractionOutputCallback+    -- ^ Callback function to call when there is a response+    --   to give to the interactive frontend.+    --   See the documentation of 'InteractionOutputCallback'.+  , stBenchmark         :: !Benchmark+    -- ^ Structure to track how much CPU time was spent on which Agda phase.+    --   Needs to be a strict field to avoid space leaks!+  , stAccumStatistics   :: !Statistics+    -- ^ Should be strict field.+  , stPersistLoadedFileCache :: !(Strict.Maybe LoadedFileCache)+    -- ^ Cached typechecking state from the last loaded file.+    --   Should be @Nothing@ when checking imports.+  , stPersistBackends   :: [Backend]+    -- ^ Current backends with their options+  }+  deriving Generic++data LoadedFileCache = LoadedFileCache+  { lfcCached  :: !CachedTypeCheckLog+  , lfcCurrent :: !CurrentTypeCheckLog+  }+  deriving Generic++-- | A log of what the type checker does and states after the action is+-- completed.  The cached version is stored first executed action first.+type CachedTypeCheckLog = [(TypeCheckAction, PostScopeState)]++-- | Like 'CachedTypeCheckLog', but storing the log for an ongoing type+-- checking of a module.  Stored in reverse order (last performed action+-- first).+type CurrentTypeCheckLog = [(TypeCheckAction, PostScopeState)]++-- | A complete log for a module will look like this:+--+--   * 'Pragmas'+--+--   * 'EnterSection', entering the main module.+--+--   * 'Decl'/'EnterSection'/'LeaveSection', for declarations and nested+--     modules+--+--   * 'LeaveSection', leaving the main module.+data TypeCheckAction+  = EnterSection !ModuleName !A.Telescope+  | LeaveSection !ModuleName+  | Decl !A.Declaration+    -- ^ Never a Section or ScopeDecl+  | Pragmas !PragmaOptions+  deriving (Generic)++-- | Empty persistent state.++initPersistentState :: PersistentTCState+initPersistentState = PersistentTCSt+  { stPersistentOptions         = defaultOptions+  , stPersistentTopLevelModuleNames = empty+  , stDecodedModules            = Map.empty+  , stInteractionOutputCallback = defaultInteractionOutputCallback+  , stBenchmark                 = empty+  , stAccumStatistics           = Map.empty+  , stPersistLoadedFileCache    = empty+  , stPersistBackends           = []+  }++-- | An initial 'MetaId'.++initialMetaId :: MetaId+initialMetaId = MetaId+  { metaId     = 0+  , metaModule = noModuleNameHash+  }++-- | Empty state of type checker.++initPreScopeState :: PreScopeState+initPreScopeState = PreScopeState+  { stPreTokens               = mempty+  , stPreImports              = emptySignature+  , stPreImportedModules      = empty+  , stPreModuleToSource       = Map.empty+  , stPreVisitedModules       = Map.empty+  , stPreScope                = emptyScopeInfo+  , stPrePatternSyns          = Map.empty+  , stPrePatternSynImports    = Map.empty+  , stPreGeneralizedVars      = mempty+  , stPrePragmaOptions        = defaultInteractionOptions+  , stPreImportedBuiltins     = Map.empty+  , stPreImportedDisplayForms = HMap.empty+  , stPreImportedInstanceDefs = Map.empty+  , stPreForeignCode          = Map.empty+  , stPreFreshInteractionId   = 0+  , stPreImportedUserWarnings = Map.empty+  , stPreLocalUserWarnings    = Map.empty+  , stPreWarningOnImport      = empty+  , stPreImportedPartialDefs  = Set.empty+  , stPreProjectConfigs       = Map.empty+  , stPreAgdaLibFiles         = Map.empty+  , stPreImportedMetaStore    = HMap.empty+  }++initPostScopeState :: PostScopeState+initPostScopeState = PostScopeState+  { stPostSyntaxInfo           = mempty+  , stPostDisambiguatedNames   = IntMap.empty+  , stPostOpenMetaStore        = Map.empty+  , stPostSolvedMetaStore      = Map.empty+  , stPostInteractionPoints    = empty+  , stPostAwakeConstraints     = []+  , stPostSleepingConstraints  = []+  , stPostDirty                = False+  , stPostOccursCheckDefs      = Set.empty+  , stPostSignature            = emptySignature+  , stPostModuleCheckpoints    = Map.empty+  , stPostImportsDisplayForms  = HMap.empty+  , stPostCurrentModule        = empty+  , stPostInstanceDefs         = (Map.empty , Set.empty)+  , stPostConcreteNames        = Map.empty+  , stPostUsedNames            = Map.empty+  , stPostShadowingNames       = Map.empty+  , stPostStatistics           = Map.empty+  , stPostTCWarnings           = []+  , stPostMutualBlocks         = Map.empty+  , stPostLocalBuiltins        = Map.empty+  , stPostFreshMetaId          = initialMetaId+  , stPostFreshMutualId        = 0+  , stPostFreshProblemId       = 1+  , stPostFreshCheckpointId    = 1+  , stPostFreshInt             = 0+  , stPostFreshNameId          = NameId 0 noModuleNameHash+  , stPostAreWeCaching         = False+  , stPostPostponeInstanceSearch = False+  , stPostConsideringInstance  = False+  , stPostInstantiateBlocking  = False+  , stPostLocalPartialDefs     = Set.empty+  }++initState :: TCState+initState = TCSt+  { stPreScopeState   = initPreScopeState+  , stPostScopeState  = initPostScopeState+  , stPersistentState = initPersistentState+  }++-- * st-prefixed lenses+------------------------------------------------------------------------++stTokens :: Lens' HighlightingInfo TCState+stTokens f s =+  f (stPreTokens (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreTokens = x}}++stImports :: Lens' Signature TCState+stImports f s =+  f (stPreImports (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImports = x}}++stImportedModules ::+  Lens' (HashSet TopLevelModuleName) TCState+stImportedModules f s =+  f (stPreImportedModules (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedModules = x}}++stModuleToSource :: Lens' ModuleToSource TCState+stModuleToSource f s =+  f (stPreModuleToSource (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreModuleToSource = x}}++stVisitedModules :: Lens' VisitedModules TCState+stVisitedModules f s =+  f (stPreVisitedModules (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreVisitedModules = x}}++stScope :: Lens' ScopeInfo TCState+stScope f s =+  f (stPreScope (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreScope = x}}++stPatternSyns :: Lens' A.PatternSynDefns TCState+stPatternSyns f s =+  f (stPrePatternSyns (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSyns = x}}++stPatternSynImports :: Lens' A.PatternSynDefns TCState+stPatternSynImports f s =+  f (stPrePatternSynImports (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePatternSynImports = x}}++stGeneralizedVars :: Lens' (Maybe (Set QName)) TCState+stGeneralizedVars f s =+  f (Strict.toLazy $ stPreGeneralizedVars (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreGeneralizedVars = Strict.toStrict x}}++stPragmaOptions :: Lens' PragmaOptions TCState+stPragmaOptions f s =+  f (stPrePragmaOptions (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPrePragmaOptions = x}}++stImportedBuiltins :: Lens' (BuiltinThings PrimFun) TCState+stImportedBuiltins f s =+  f (stPreImportedBuiltins (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedBuiltins = x}}++stForeignCode :: Lens' (Map BackendName [ForeignCode]) TCState+stForeignCode f s =+  f (stPreForeignCode (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreForeignCode = x}}++stFreshInteractionId :: Lens' InteractionId TCState+stFreshInteractionId f s =+  f (stPreFreshInteractionId (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreFreshInteractionId = x}}++stImportedUserWarnings :: Lens' (Map A.QName Text) TCState+stImportedUserWarnings f s =+  f (stPreImportedUserWarnings (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedUserWarnings = x}}++stLocalUserWarnings :: Lens' (Map A.QName Text) TCState+stLocalUserWarnings f s =+  f (stPreLocalUserWarnings (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreLocalUserWarnings = x}}++getUserWarnings :: ReadTCState m => m (Map A.QName Text)+getUserWarnings = do+  iuw <- useR stImportedUserWarnings+  luw <- useR stLocalUserWarnings+  return $ iuw `Map.union` luw++stWarningOnImport :: Lens' (Maybe Text) TCState+stWarningOnImport f s =+  f (Strict.toLazy $ stPreWarningOnImport (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreWarningOnImport = Strict.toStrict x}}++stImportedPartialDefs :: Lens' (Set QName) TCState+stImportedPartialDefs f s =+  f (stPreImportedPartialDefs (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedPartialDefs = x}}++stLocalPartialDefs :: Lens' (Set QName) TCState+stLocalPartialDefs f s =+  f (stPostLocalPartialDefs (stPostScopeState s)) <&>+  \ x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalPartialDefs = x}}++getPartialDefs :: ReadTCState m => m (Set QName)+getPartialDefs = do+  ipd <- useR stImportedPartialDefs+  lpd <- useR stLocalPartialDefs+  return $ ipd `Set.union` lpd++stLoadedFileCache :: Lens' (Maybe LoadedFileCache) TCState+stLoadedFileCache f s =+  f (Strict.toLazy $ stPersistLoadedFileCache (stPersistentState s)) <&>+  \x -> s {stPersistentState = (stPersistentState s) {stPersistLoadedFileCache = Strict.toStrict x}}++stBackends :: Lens' [Backend] TCState+stBackends f s =+  f (stPersistBackends (stPersistentState s)) <&>+  \x -> s {stPersistentState = (stPersistentState s) {stPersistBackends = x}}++stProjectConfigs :: Lens' (Map FilePath ProjectConfig) TCState+stProjectConfigs f s =+  f (stPreProjectConfigs (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreProjectConfigs = x}}++stAgdaLibFiles :: Lens' (Map FilePath AgdaLibFile) TCState+stAgdaLibFiles f s =+  f (stPreAgdaLibFiles (stPreScopeState s)) <&>+  \ x -> s {stPreScopeState = (stPreScopeState s) {stPreAgdaLibFiles = x}}++stTopLevelModuleNames ::+  Lens' (BiMap RawTopLevelModuleName ModuleNameHash) TCState+stTopLevelModuleNames f s =+  f (stPersistentTopLevelModuleNames (stPersistentState s)) <&>+  \ x -> s {stPersistentState =+              (stPersistentState s) {stPersistentTopLevelModuleNames = x}}++stImportedMetaStore :: Lens' RemoteMetaStore TCState+stImportedMetaStore f s =+  f (stPreImportedMetaStore (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedMetaStore = x}}++stFreshNameId :: Lens' NameId TCState+stFreshNameId f s =+  f (stPostFreshNameId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshNameId = x}}++stSyntaxInfo :: Lens' HighlightingInfo TCState+stSyntaxInfo f s =+  f (stPostSyntaxInfo (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSyntaxInfo = x}}++stDisambiguatedNames :: Lens' DisambiguatedNames TCState+stDisambiguatedNames f s =+  f (stPostDisambiguatedNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDisambiguatedNames = x}}++stOpenMetaStore :: Lens' LocalMetaStore TCState+stOpenMetaStore f s =+  f (stPostOpenMetaStore (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostOpenMetaStore = x}}++stSolvedMetaStore :: Lens' LocalMetaStore TCState+stSolvedMetaStore f s =+  f (stPostSolvedMetaStore (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSolvedMetaStore = x}}++stInteractionPoints :: Lens' InteractionPoints TCState+stInteractionPoints f s =+  f (stPostInteractionPoints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInteractionPoints = x}}++stAwakeConstraints :: Lens' Constraints TCState+stAwakeConstraints f s =+  f (stPostAwakeConstraints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAwakeConstraints = x}}++stSleepingConstraints :: Lens' Constraints TCState+stSleepingConstraints f s =+  f (stPostSleepingConstraints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSleepingConstraints = x}}++stDirty :: Lens' Bool TCState+stDirty f s =+  f (stPostDirty (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostDirty = x}}++stOccursCheckDefs :: Lens' (Set QName) TCState+stOccursCheckDefs f s =+  f (stPostOccursCheckDefs (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostOccursCheckDefs = x}}++stSignature :: Lens' Signature TCState+stSignature f s =+  f (stPostSignature (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostSignature = x}}++stModuleCheckpoints :: Lens' (Map ModuleName CheckpointId) TCState+stModuleCheckpoints f s =+  f (stPostModuleCheckpoints (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostModuleCheckpoints = x}}++stImportsDisplayForms :: Lens' DisplayForms TCState+stImportsDisplayForms f s =+  f (stPostImportsDisplayForms (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostImportsDisplayForms = x}}++stImportedDisplayForms :: Lens' DisplayForms TCState+stImportedDisplayForms f s =+  f (stPreImportedDisplayForms (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedDisplayForms = x}}++-- | Note that the lens is \"strict\".++stCurrentModule ::+  Lens' (Maybe (ModuleName, TopLevelModuleName)) TCState+stCurrentModule f s =+  f (stPostCurrentModule (stPostScopeState s)) <&>+  \x -> s {stPostScopeState =+             (stPostScopeState s)+               {stPostCurrentModule = case x of+                  Nothing         -> Nothing+                  Just (!m, !top) -> Just (m, top)}}++stImportedInstanceDefs :: Lens' InstanceTable TCState+stImportedInstanceDefs f s =+  f (stPreImportedInstanceDefs (stPreScopeState s)) <&>+  \x -> s {stPreScopeState = (stPreScopeState s) {stPreImportedInstanceDefs = x}}++stInstanceDefs :: Lens' TempInstanceTable TCState+stInstanceDefs f s =+  f (stPostInstanceDefs (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstanceDefs = x}}++stConcreteNames :: Lens' ConcreteNames TCState+stConcreteNames f s =+  f (stPostConcreteNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConcreteNames = x}}++stUsedNames :: Lens' (Map RawName (DList RawName)) TCState+stUsedNames f s =+  f (stPostUsedNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostUsedNames = x}}++stShadowingNames :: Lens' (Map Name (DList RawName)) TCState+stShadowingNames f s =+  f (stPostShadowingNames (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostShadowingNames = x}}++stStatistics :: Lens' Statistics TCState+stStatistics f s =+  f (stPostStatistics (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostStatistics = x}}++stTCWarnings :: Lens' [TCWarning] TCState+stTCWarnings f s =+  f (stPostTCWarnings (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostTCWarnings = x}}++stMutualBlocks :: Lens' (Map MutualId MutualBlock) TCState+stMutualBlocks f s =+  f (stPostMutualBlocks (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostMutualBlocks = x}}++stLocalBuiltins :: Lens' (BuiltinThings PrimFun) TCState+stLocalBuiltins f s =+  f (stPostLocalBuiltins (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostLocalBuiltins = x}}++stFreshMetaId :: Lens' MetaId TCState+stFreshMetaId f s =+  f (stPostFreshMetaId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMetaId = x}}++stFreshMutualId :: Lens' MutualId TCState+stFreshMutualId f s =+  f (stPostFreshMutualId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshMutualId = x}}++stFreshProblemId :: Lens' ProblemId TCState+stFreshProblemId f s =+  f (stPostFreshProblemId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshProblemId = x}}++stFreshCheckpointId :: Lens' CheckpointId TCState+stFreshCheckpointId f s =+  f (stPostFreshCheckpointId (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshCheckpointId = x}}++stFreshInt :: Lens' Int TCState+stFreshInt f s =+  f (stPostFreshInt (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostFreshInt = x}}++-- use @areWeCaching@ from the Caching module instead.+stAreWeCaching :: Lens' Bool TCState+stAreWeCaching f s =+  f (stPostAreWeCaching (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostAreWeCaching = x}}++stPostponeInstanceSearch :: Lens' Bool TCState+stPostponeInstanceSearch f s =+  f (stPostPostponeInstanceSearch (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostPostponeInstanceSearch = x}}++stConsideringInstance :: Lens' Bool TCState+stConsideringInstance f s =+  f (stPostConsideringInstance (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostConsideringInstance = x}}++stInstantiateBlocking :: Lens' Bool TCState+stInstantiateBlocking f s =+  f (stPostInstantiateBlocking (stPostScopeState s)) <&>+  \x -> s {stPostScopeState = (stPostScopeState s) {stPostInstantiateBlocking = x}}++stBuiltinThings :: TCState -> BuiltinThings PrimFun+stBuiltinThings s = Map.unionWith unionBuiltin (s^.stLocalBuiltins) (s^.stImportedBuiltins)++-- | Union two 'Builtin's.  Only defined for 'BuiltinRewriteRelations'.+unionBuiltin :: Builtin a -> Builtin a -> Builtin a+unionBuiltin = curry $ \case+  (BuiltinRewriteRelations xs, BuiltinRewriteRelations ys) -> BuiltinRewriteRelations $ xs <> ys+  _ -> __IMPOSSIBLE__+++-- * Fresh things+------------------------------------------------------------------------++class Enum i => HasFresh i where+    freshLens :: Lens' i TCState+    nextFresh' :: i -> i+    nextFresh' = succ++nextFresh :: HasFresh i => TCState -> (i, TCState)+nextFresh s =+  let !c = s^.freshLens+  in (c, set freshLens (nextFresh' c) s)++class Monad m => MonadFresh i m where+  fresh :: m i++  default fresh :: (MonadTrans t, MonadFresh i n, t n ~ m) => m i+  fresh = lift fresh++instance MonadFresh i m => MonadFresh i (ReaderT r m)+instance MonadFresh i m => MonadFresh i (StateT s m)+instance MonadFresh i m => MonadFresh i (ListT m)+instance MonadFresh i m => MonadFresh i (IdentityT m)++instance HasFresh i => MonadFresh i TCM where+  fresh = do+        !s <- getTC+        let (!c , !s') = nextFresh s+        putTC s'+        return c++instance HasFresh MetaId where+  freshLens = stFreshMetaId++instance HasFresh MutualId where+  freshLens = stFreshMutualId++instance HasFresh InteractionId where+  freshLens = stFreshInteractionId++instance HasFresh NameId where+  freshLens = stFreshNameId+  -- nextFresh increments the current fresh name by 2 so @NameId@s used+  -- before caching starts do not overlap with the ones used after.+  nextFresh' = succ . succ++instance HasFresh Int where+  freshLens = stFreshInt++instance HasFresh ProblemId where+  freshLens = stFreshProblemId++newtype CheckpointId = CheckpointId Int+  deriving (Eq, Ord, Enum, Real, Integral, Num, NFData)++instance Show CheckpointId where+  show (CheckpointId n) = show n++instance Pretty CheckpointId where+  pretty (CheckpointId n) = pretty n++instance HasFresh CheckpointId where+  freshLens = stFreshCheckpointId++freshName :: MonadFresh NameId m => Range -> String -> m Name+freshName r s = do+  i <- fresh+  return $ mkName r i s++freshNoName :: MonadFresh NameId m => Range -> m Name+freshNoName r =+    do  i <- fresh+        return $ makeName i (C.NoName noRange i) r noFixity' False++freshNoName_ :: MonadFresh NameId m => m Name+freshNoName_ = freshNoName noRange++freshRecordName :: MonadFresh NameId m => m Name+freshRecordName = do+  i <- fresh+  return $ makeName i (C.setNotInScope $ C.simpleName "r") noRange noFixity' True++-- | Create a fresh name from @a@.+class FreshName a where+  freshName_ :: MonadFresh NameId m => a -> m Name++instance FreshName (Range, String) where+  freshName_ = uncurry freshName++instance FreshName String where+  freshName_ = freshName noRange++instance FreshName Range where+  freshName_ = freshNoName++instance FreshName () where+  freshName_ () = freshNoName_++---------------------------------------------------------------------------+-- ** Managing file names+---------------------------------------------------------------------------++-- | Maps top-level module names to the corresponding source file+-- names.++type ModuleToSource = Map TopLevelModuleName AbsolutePath++---------------------------------------------------------------------------+-- ** Associating concrete names to an abstract name+---------------------------------------------------------------------------++-- | A monad that has read and write access to the stConcreteNames+--   part of the TCState. Basically, this is a synonym for `MonadState+--   ConcreteNames m` (which cannot be used directly because of the+--   limitations of Haskell's typeclass system).+class Monad m => MonadStConcreteNames m where+  runStConcreteNames :: StateT ConcreteNames m a -> m a++  useConcreteNames :: m ConcreteNames+  useConcreteNames = runStConcreteNames get++  modifyConcreteNames :: (ConcreteNames -> ConcreteNames) -> m ()+  modifyConcreteNames = runStConcreteNames . modify++instance MonadStConcreteNames TCM where+  runStConcreteNames m = stateTCLensM stConcreteNames $ runStateT m++instance MonadStConcreteNames m => MonadStConcreteNames (IdentityT m) where+  runStConcreteNames m = IdentityT $ runStConcreteNames $ StateT $ runIdentityT . runStateT m++instance MonadStConcreteNames m => MonadStConcreteNames (ReaderT r m) where+  runStConcreteNames m = ReaderT $ runStConcreteNames . StateT . flip (runReaderT . runStateT m)++instance MonadStConcreteNames m => MonadStConcreteNames (StateT s m) where+  runStConcreteNames m = StateT $ \s -> runStConcreteNames $ StateT $ \ns -> do+    ((x,ns'),s') <- runStateT (runStateT m ns) s+    return ((x,s'),ns')++---------------------------------------------------------------------------+-- ** Interface+---------------------------------------------------------------------------+++-- | Distinguishes between type-checked and scope-checked interfaces+--   when stored in the map of `VisitedModules`.+data ModuleCheckMode+  = ModuleScopeChecked+  | ModuleTypeChecked+  deriving (Eq, Ord, Bounded, Enum, Show, Generic)+++data ModuleInfo = ModuleInfo+  { miInterface  :: Interface+  , miWarnings   :: [TCWarning]+    -- ^ Warnings were encountered when the module was type checked.+    --   These might include warnings not stored in the interface itself,+    --   specifically unsolved interaction metas.+    --   See "Agda.Interaction.Imports"+  , miPrimitive  :: Bool+    -- ^ 'True' if the module is a primitive module, which should always+    -- be importable.+  , miMode       :: ModuleCheckMode+    -- ^ The `ModuleCheckMode` used to create the `Interface`+  }+  deriving Generic++type VisitedModules = Map TopLevelModuleName ModuleInfo+type DecodedModules = Map TopLevelModuleName ModuleInfo++data ForeignCode = ForeignCode Range String+  deriving (Show, Generic)++data Interface = Interface+  { iSourceHash      :: Hash+    -- ^ Hash of the source code.+  , iSource          :: TL.Text+    -- ^ The source code. The source code is stored so that the HTML+    -- and LaTeX backends can generate their output without having to+    -- re-read the (possibly out of date) source code.+  , iFileType        :: FileType+    -- ^ Source file type, determined from the file extension+  , iImportedModules :: [(TopLevelModuleName, Hash)]+    -- ^ Imported modules and their hashes.+  , iModuleName      :: ModuleName+    -- ^ Module name of this interface.+  , iTopLevelModuleName :: TopLevelModuleName+    -- ^ The module's top-level module name.+  , iScope           :: Map ModuleName Scope+    -- ^ Scope defined by this module.+    --+    --   Andreas, AIM XX: Too avoid duplicate serialization, this field is+    --   not serialized, so if you deserialize an interface, @iScope@+    --   will be empty.+    --   But 'constructIScope' constructs 'iScope' from 'iInsideScope'.+  , iInsideScope     :: ScopeInfo+    -- ^ Scope after we loaded this interface.+    --   Used in 'Agda.Interaction.BasicOps.AtTopLevel'+    --   and     'Agda.Interaction.CommandLine.interactionLoop'.+  , iSignature       :: Signature+  , iMetaBindings    :: RemoteMetaStore+    -- ^ Instantiations for meta-variables that come from this module.+  , iDisplayForms    :: DisplayForms+    -- ^ Display forms added for imported identifiers.+  , iUserWarnings    :: Map A.QName Text+    -- ^ User warnings for imported identifiers+  , iImportWarning   :: Maybe Text+    -- ^ Whether this module should raise a warning when imported+  , iBuiltin         :: BuiltinThings (String, QName)+  , iForeignCode     :: Map BackendName [ForeignCode]+  , iHighlighting    :: HighlightingInfo+  , iDefaultPragmaOptions :: [OptionsPragma]+    -- ^ Pragma options set in library files.+  , iFilePragmaOptions    :: [OptionsPragma]+    -- ^ Pragma options set in the file.+  , iOptionsUsed     :: PragmaOptions+    -- ^ Options/features used when checking the file (can be different+    --   from options set directly in the file).+  , iPatternSyns     :: A.PatternSynDefns+  , iWarnings        :: [TCWarning]+  , iPartialDefs     :: Set QName+  }+  deriving (Show, Generic)++instance Pretty Interface where+  pretty (Interface+            sourceH source fileT importedM moduleN topModN scope insideS+            signature metas display userwarn importwarn builtin+            foreignCode highlighting libPragmaO filePragmaO oUsed+            patternS warnings partialdefs) =++    hang "Interface" 2 $ vcat+      [ "source hash:"         <+> (pretty . show) sourceH+      , "source:"              $$  nest 2 (text $ TL.unpack source)+      , "file type:"           <+> (pretty . show) fileT+      , "imported modules:"    <+> (pretty . show) importedM+      , "module name:"         <+> pretty moduleN+      , "top-level module name:" <+> pretty topModN+      , "scope:"               <+> (pretty . show) scope+      , "inside scope:"        <+> (pretty . show) insideS+      , "signature:"           <+> (pretty . show) signature+      , "meta-variables:"      <+> (pretty . show) metas+      , "display:"             <+> (pretty . show) display+      , "user warnings:"       <+> (pretty . show) userwarn+      , "import warning:"      <+> (pretty . show) importwarn+      , "builtin:"             <+> (pretty . show) builtin+      , "Foreign code:"        <+> (pretty . show) foreignCode+      , "highlighting:"        <+> (pretty . show) highlighting+      , "library pragma options:" <+> (pretty . show) libPragmaO+      , "file pragma options:" <+> (pretty . show) filePragmaO+      , "options used:"        <+> (pretty . show) oUsed+      , "pattern syns:"        <+> (pretty . show) patternS+      , "warnings:"            <+> (pretty . show) warnings+      , "partial definitions:" <+> (pretty . show) partialdefs+      ]++-- | Combines the source hash and the (full) hashes of the imported modules.+iFullHash :: Interface -> Hash+iFullHash i = combineHashes $ iSourceHash i : List.map snd (iImportedModules i)++-- | A lens for the 'iSignature' field of the 'Interface' type.++intSignature :: Lens' Signature Interface+intSignature f i = f (iSignature i) <&> \s -> i { iSignature = s }++---------------------------------------------------------------------------+-- ** Closure+---------------------------------------------------------------------------++data Closure a = Closure+  { clSignature        :: Signature+  , clEnv              :: TCEnv+  , clScope            :: ScopeInfo+  , clModuleCheckpoints :: Map ModuleName CheckpointId+  , clValue            :: a+  }+    deriving (Functor, Foldable, Generic)++instance Show a => Show (Closure a) where+  show cl = "Closure { clValue = " ++ show (clValue cl) ++ " }"++instance HasRange a => HasRange (Closure a) where+  getRange = getRange . clValue++class LensClosure a b | b -> a where+  lensClosure :: Lens' (Closure a) b++instance LensClosure a (Closure a) where+  lensClosure = id++instance LensTCEnv (Closure a) where+  lensTCEnv f cl = (f $! clEnv cl) <&> \ env -> cl { clEnv = env }++buildClosure :: (MonadTCEnv m, ReadTCState m) => a -> m (Closure a)+buildClosure x = do+    env   <- askTC+    sig   <- useR stSignature+    scope <- useR stScope+    cps   <- useR stModuleCheckpoints+    return $ Closure sig env scope cps x++---------------------------------------------------------------------------+-- ** Constraints+---------------------------------------------------------------------------++type Constraints = [ProblemConstraint]++data ProblemConstraint = PConstr+  { constraintProblems  :: Set ProblemId+  , constraintUnblocker :: Blocker+  , theConstraint       :: Closure Constraint+  }+  deriving (Show, Generic)++instance HasRange ProblemConstraint where+  getRange = getRange . theConstraint++-- | Why are we performing a modality check?+data WhyCheckModality+  = ConstructorType+  -- ^ Because --without-K is enabled, so the types of data constructors+  -- must be usable at the context's modality.+  | IndexedClause+  -- ^ Because --without-K is enabled, so the result type of clauses+  -- must be usable at the context's modality.+  | IndexedClauseArg Name Name+  -- ^ Because --without-K is enabled, so any argument (second name)+  -- which mentions a dotted argument (first name) must have a type+  -- which is usable at the context's modality.+  | GeneratedClause+  -- ^ Because we double-check the --cubical-compatible clauses. This is+  -- an internal error!+  deriving (Show, Generic)++data Constraint+  = ValueCmp Comparison CompareAs Term Term+  | ValueCmpOnFace Comparison Term Type Term Term+  | ElimCmp [Polarity] [IsForced] Type Term [Elim] [Elim]+  | SortCmp Comparison Sort Sort+  | LevelCmp Comparison Level Level+--  | ShortCut MetaId Term Type+--    -- ^ A delayed instantiation.  Replaces @ValueCmp@ in 'postponeTypeCheckingProblem'.+  | HasBiggerSort Sort+  | HasPTSRule (Dom Type) (Abs Sort)+  | CheckDataSort QName Sort+    -- ^ Check that the sort 'Sort' of data type 'QName' admits data/record types.+    -- E.g., sorts @IUniv@, @SizeUniv@ etc. do not admit such constructions.+    -- See 'Agda.TypeChecking.Rules.Data.checkDataSort'.+  | CheckMetaInst MetaId+  | CheckType Type+  | UnBlock MetaId+    -- ^ Meta created for a term blocked by a postponed type checking problem or unsolved+    --   constraints. The 'MetaInstantiation' for the meta (when unsolved) is either 'BlockedConst'+    --   or 'PostponedTypeCheckingProblem'.+  | IsEmpty Range Type+    -- ^ The range is the one of the absurd pattern.+  | CheckSizeLtSat Term+    -- ^ Check that the 'Term' is either not a SIZELT or a non-empty SIZELT.+  | FindInstance MetaId (Maybe [Candidate])+    -- ^ the first argument is the instance argument and the second one is the list of candidates+    --   (or Nothing if we haven’t determined the list of candidates yet)+  | CheckFunDef Delayed A.DefInfo QName [A.Clause] TCErr+    -- ^ Last argument is the error causing us to postpone.+  | UnquoteTactic Term Term Type   -- ^ First argument is computation and the others are hole and goal type+  | CheckLockedVars Term Type (Arg Term) Type     -- ^ @CheckLockedVars t ty lk lk_ty@ with @t : ty@, @lk : lk_ty@ and @t lk@ well-typed.+  | UsableAtModality WhyCheckModality (Maybe Sort) Modality Term+    -- ^ Is the term usable at the given modality?+    -- This check should run if the @Sort@ is @Nothing@ or @isFibrant@.+  deriving (Show, Generic)++instance HasRange Constraint where+  getRange (IsEmpty r t) = r+  getRange _ = noRange+{- no Range instances for Term, Type, Elm, Tele, Sort, Level, MetaId+  getRange (ValueCmp cmp a u v) = getRange (a,u,v)+  getRange (ElimCmp pol a v es es') = getRange (a,v,es,es')+  getRange (TelCmp a b cmp tel tel') = getRange (a,b,tel,tel')+  getRange (SortCmp cmp s s') = getRange (s,s')+  getRange (LevelCmp cmp l l') = getRange (l,l')+  getRange (UnBlock x) = getRange x+  getRange (FindInstance x cands) = getRange x+-}++instance Free Constraint where+  freeVars' c =+    case c of+      ValueCmp _ t u v      -> freeVars' (t, (u, v))+      ValueCmpOnFace _ p t u v -> freeVars' (p, (t, (u, v)))+      ElimCmp _ _ t u es es'  -> freeVars' ((t, u), (es, es'))+      SortCmp _ s s'        -> freeVars' (s, s')+      LevelCmp _ l l'       -> freeVars' (l, l')+      UnBlock _             -> mempty+      IsEmpty _ t           -> freeVars' t+      CheckSizeLtSat u      -> freeVars' u+      FindInstance _ cs     -> freeVars' cs+      CheckFunDef{}         -> mempty+      HasBiggerSort s       -> freeVars' s+      HasPTSRule a s        -> freeVars' (a , s)+      CheckLockedVars a b c d -> freeVars' ((a,b),(c,d))+      UnquoteTactic t h g   -> freeVars' (t, (h, g))+      CheckDataSort _ s     -> freeVars' s+      CheckMetaInst m       -> mempty+      CheckType t           -> freeVars' t+      UsableAtModality _ ms mod t -> freeVars' (ms, t)++instance TermLike Constraint where+  foldTerm f = \case+      ValueCmp _ t u v       -> foldTerm f (t, u, v)+      ValueCmpOnFace _ p t u v -> foldTerm f (p, t, u, v)+      ElimCmp _ _ t u es es' -> foldTerm f (t, u, es, es')+      LevelCmp _ l l'        -> foldTerm f (Level l, Level l')  -- Note wrapping as term, to ensure f gets to act on l and l'+      IsEmpty _ t            -> foldTerm f t+      CheckSizeLtSat u       -> foldTerm f u+      UnquoteTactic t h g    -> foldTerm f (t, h, g)+      SortCmp _ s1 s2        -> foldTerm f (Sort s1, Sort s2)   -- Same as LevelCmp case+      UnBlock _              -> mempty+      CheckLockedVars a b c d -> foldTerm f (a, b, c, d)+      FindInstance _ _       -> mempty+      CheckFunDef{}          -> mempty+      HasBiggerSort s        -> foldTerm f s+      HasPTSRule a s         -> foldTerm f (a, Sort <$> s)+      CheckDataSort _ s      -> foldTerm f s+      CheckMetaInst m        -> mempty+      CheckType t            -> foldTerm f t+      UsableAtModality _ ms m t   -> foldTerm f (Sort <$> ms, t)++  traverseTermM f c = __IMPOSSIBLE__ -- Not yet implemented++instance AllMetas Constraint++data Comparison = CmpEq | CmpLeq+  deriving (Eq, Show, Generic)++instance Pretty Comparison where+  pretty CmpEq  = "="+  pretty CmpLeq = "=<"++-- | An extension of 'Comparison' to @>=@.+data CompareDirection = DirEq | DirLeq | DirGeq+  deriving (Eq, Show)++instance Pretty CompareDirection where+  pretty = text . \case+    DirEq  -> "="+    DirLeq -> "=<"+    DirGeq -> ">="++-- | Embed 'Comparison' into 'CompareDirection'.+fromCmp :: Comparison -> CompareDirection+fromCmp CmpEq  = DirEq+fromCmp CmpLeq = DirLeq++-- | Flip the direction of comparison.+flipCmp :: CompareDirection -> CompareDirection+flipCmp DirEq  = DirEq+flipCmp DirLeq = DirGeq+flipCmp DirGeq = DirLeq++-- | Turn a 'Comparison' function into a 'CompareDirection' function.+--+--   Property: @dirToCmp f (fromCmp cmp) = f cmp@+dirToCmp :: (Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c+dirToCmp cont DirEq  = cont CmpEq+dirToCmp cont DirLeq = cont CmpLeq+dirToCmp cont DirGeq = flip $ cont CmpLeq++-- | We can either compare two terms at a given type, or compare two+--   types without knowing (or caring about) their sorts.+data CompareAs+  = AsTermsOf Type -- ^ @Type@ should not be @Size@.+                   --   But currently, we do not rely on this invariant.+  | AsSizes        -- ^ Replaces @AsTermsOf Size@.+  | AsTypes+  deriving (Show, Generic)++instance Free CompareAs where+  freeVars' (AsTermsOf a) = freeVars' a+  freeVars' AsSizes       = mempty+  freeVars' AsTypes       = mempty++instance TermLike CompareAs where+  foldTerm f (AsTermsOf a) = foldTerm f a+  foldTerm f AsSizes       = mempty+  foldTerm f AsTypes       = mempty++  traverseTermM f = \case+    AsTermsOf a -> AsTermsOf <$> traverseTermM f a+    AsSizes     -> return AsSizes+    AsTypes     -> return AsTypes++instance AllMetas CompareAs++instance Pretty CompareAs where+  pretty (AsTermsOf a) = ":" <+> pretty a+  pretty AsSizes       = ":" <+> text "Size"+  pretty AsTypes       = empty++---------------------------------------------------------------------------+-- * Open things+---------------------------------------------------------------------------++-- | A thing tagged with the context it came from. Also keeps the substitution from previous+--   checkpoints. This lets us handle the case when an open thing was created in a context that we+--   have since exited. Remember which module it's from to make sure we don't get confused by+--   checkpoints from other files.+data Open a = OpenThing { openThingCheckpoint    :: CheckpointId+                        , openThingCheckpointMap :: Map CheckpointId Substitution+                        , openThingModule        :: ModuleNameHash+                        , openThing              :: a }+    deriving (Show, Functor, Foldable, Traversable, Generic)++instance Decoration Open where+  traverseF f (OpenThing cp env m x) = OpenThing cp env m <$> f x++instance Pretty a => Pretty (Open a) where+  prettyPrec p (OpenThing cp env _ x) = mparens (p > 9) $+    "OpenThing" <+> pretty cp <+> pretty (Map.toList env) <?> prettyPrec 10 x++---------------------------------------------------------------------------+-- * Judgements+--+-- Used exclusively for typing of meta variables.+---------------------------------------------------------------------------++-- | Parametrized since it is used without MetaId when creating a new meta.+data Judgement a+  = HasType+    { jMetaId     :: a+    , jComparison :: Comparison -- ^ are we checking (@CmpLeq@) or inferring (@CmpEq@) the type?+    , jMetaType   :: Type+    }+  | IsSort+    { jMetaId   :: a+    , jMetaType :: Type -- Andreas, 2011-04-26: type needed for higher-order sort metas+    }+  deriving (Show, Generic)++instance Pretty a => Pretty (Judgement a) where+    pretty (HasType a cmp t) = hsep [ pretty a, ":"    , pretty t ]+    pretty (IsSort  a t)     = hsep [ pretty a, ":sort", pretty t ]++-----------------------------------------------------------------------------+-- ** Generalizable variables+-----------------------------------------------------------------------------++data DoGeneralize+  = YesGeneralizeVar  -- ^ Generalize because it is a generalizable variable.+  | YesGeneralizeMeta -- ^ Generalize because it is a metavariable and+                      --   we're currently checking the type of a generalizable variable+                      --   (this should get the default modality).+  | NoGeneralize      -- ^ Don't generalize.+  deriving (Eq, Ord, Show, Generic)++-- | The value of a generalizable variable. This is created to be a+--   generalizable meta before checking the type to be generalized.+data GeneralizedValue = GeneralizedValue+  { genvalCheckpoint :: CheckpointId+  , genvalTerm       :: Term+  , genvalType       :: Type+  } deriving (Show, Generic)++---------------------------------------------------------------------------+-- ** Meta variables+---------------------------------------------------------------------------++-- | Information about local meta-variables.++data MetaVariable =+        MetaVar { mvInfo          :: MetaInfo+                , mvPriority      :: MetaPriority -- ^ some metavariables are more eager to be instantiated+                , mvPermutation   :: Permutation+                  -- ^ a metavariable doesn't have to depend on all variables+                  --   in the context, this "permutation" will throw away the+                  --   ones it does not depend on+                , mvJudgement     :: Judgement MetaId+                , mvInstantiation :: MetaInstantiation+                , mvListeners     :: Set Listener -- ^ meta variables scheduled for eta-expansion but blocked by this one+                , mvFrozen        :: Frozen -- ^ are we past the point where we can instantiate this meta variable?+                , mvTwin          :: Maybe MetaId+                  -- ^ @Just m@ means that this meta-variable will be+                  -- equated to @m@ when the latter is unblocked. See+                  -- 'Agda.TypeChecking.MetaVars.blockTermOnProblem'.+                }+  deriving Generic++data Listener = EtaExpand MetaId+              | CheckConstraint Nat ProblemConstraint+  deriving Generic++instance Eq Listener where+  EtaExpand       x   == EtaExpand       y   = x == y+  CheckConstraint x _ == CheckConstraint y _ = x == y+  _ == _ = False++instance Ord Listener where+  EtaExpand       x   `compare` EtaExpand       y   = x `compare` y+  CheckConstraint x _ `compare` CheckConstraint y _ = x `compare` y+  EtaExpand{} `compare` CheckConstraint{} = LT+  CheckConstraint{} `compare` EtaExpand{} = GT++-- | Frozen meta variable cannot be instantiated by unification.+--   This serves to prevent the completion of a definition by its use+--   outside of the current block.+--   (See issues 118, 288, 399).+data Frozen+  = Frozen        -- ^ Do not instantiate.+  | Instantiable+    deriving (Eq, Show, Generic)++data MetaInstantiation+        = InstV Instantiation -- ^ solved+        | Open                -- ^ unsolved+        | OpenInstance        -- ^ open, to be instantiated by instance search+        | BlockedConst Term   -- ^ solution blocked by unsolved constraints+        | PostponedTypeCheckingProblem (Closure TypeCheckingProblem)+  deriving Generic++-- | Meta-variable instantiations.++data Instantiation = Instantiation+  { instTel :: [Arg String]+    -- ^ The solution is abstracted over these free variables.+  , instBody :: Term+    -- ^ The body of the solution.+  }+  deriving (Show, Generic)++-- | Information about remote meta-variables.+--+-- Remote meta-variables are meta-variables originating in other+-- modules. These meta-variables are always instantiated. We do not+-- retain all the information about a local meta-variable when+-- creating an interface:+--+-- * The 'mvPriority' field is not needed, because the meta-variable+--   cannot be instantiated.+-- * The 'mvFrozen' field is not needed, because there is no point in+--   freezing instantiated meta-variables.+-- * The 'mvListeners' field is not needed, because no meta-variable+--   should be listening to this one.+-- * The 'mvTwin' field is not needed, because the meta-variable has+--   already been instantiated.+-- * The 'mvPermutation' is currently removed, but could be retained+--   if it turns out to be useful for something.+-- * The only part of the 'mvInfo' field that is kept is the+--   'miModality' field. The 'miMetaOccursCheck' and 'miGeneralizable'+--   fields are omitted, because the meta-variable has already been+--   instantiated. The 'Range' that is part of the 'miClosRange' field+--   and the 'miNameSuggestion' field are omitted because instantiated+--   meta-variables are typically not presented to users. Finally the+--   'Closure' part of the 'miClosRange' field is omitted because it+--   can be large (at least if we ignore potential sharing).++data RemoteMetaVariable = RemoteMetaVariable+  { rmvInstantiation :: Instantiation+  , rmvModality      :: Modality+  , rmvJudgement     :: Judgement MetaId+  }+  deriving (Show, Generic)++-- | Solving a 'CheckArgs' constraint may or may not check the target type. If+--   it did, it returns a handle to any unsolved constraints.+data CheckedTarget = CheckedTarget (Maybe ProblemId)+                   | NotCheckedTarget++data PrincipalArgTypeMetas = PrincipalArgTypeMetas+  { patmMetas     :: Args -- ^ metas created for hidden and instance arguments+                          --   in the principal argument's type+  , patmRemainder :: Type -- ^ principal argument's type, stripped of hidden and+                          --   instance arguments+  }+  deriving Generic++data TypeCheckingProblem+  = CheckExpr Comparison A.Expr Type+  | CheckArgs Comparison ExpandHidden Range [NamedArg A.Expr] Type Type (ArgsCheckState CheckedTarget -> TCM Term)+  | CheckProjAppToKnownPrincipalArg Comparison A.Expr ProjOrigin (List1 QName) A.Args Type Int Term Type PrincipalArgTypeMetas+  | CheckLambda Comparison (Arg (List1 (WithHiding Name), Maybe Type)) A.Expr Type+    -- ^ @(λ (xs : t₀) → e) : t@+    --   This is not an instance of 'CheckExpr' as the domain type+    --   has already been checked.+    --   For example, when checking+    --     @(λ (x y : Fin _) → e) : (x : Fin n) → ?@+    --   we want to postpone @(λ (y : Fin n) → e) : ?@ where @Fin n@+    --   is a 'Type' rather than an 'A.Expr'.+  | DoQuoteTerm Comparison Term Type -- ^ Quote the given term and check type against `Term`+  deriving Generic++instance Pretty MetaInstantiation where+  pretty = \case+    Open                                     -> "Open"+    OpenInstance                             -> "OpenInstance"+    PostponedTypeCheckingProblem{}           -> "PostponedTypeCheckingProblem (...)"+    BlockedConst t                           -> hsep [ "BlockedConst", parens (pretty t) ]+    InstV Instantiation{ instTel, instBody } -> hsep [ "InstV", pretty instTel, parens (pretty instBody) ]++-- | Meta variable priority:+--   When we have an equation between meta-variables, which one+--   should be instantiated?+--+--   Higher value means higher priority to be instantiated.+newtype MetaPriority = MetaPriority Int+    deriving (Eq, Ord, Show, NFData)++data RunMetaOccursCheck+  = RunMetaOccursCheck+  | DontRunMetaOccursCheck+  deriving (Eq, Ord, Show, Generic)++-- | @MetaInfo@ is cloned from one meta to the next during pruning.+data MetaInfo = MetaInfo+  { miClosRange       :: Closure Range -- TODO: Not so nice. But we want both to have the environment of the meta (Closure) and its range.+  , miModality        :: Modality           -- ^ Instantiable with irrelevant/erased solution?+  , miMetaOccursCheck :: RunMetaOccursCheck -- ^ Run the extended occurs check that goes in definitions?+  , miNameSuggestion  :: MetaNameSuggestion+    -- ^ Used for printing.+    --   @Just x@ if meta-variable comes from omitted argument with name @x@.+  , miGeneralizable   :: Arg DoGeneralize+    -- ^ Should this meta be generalized if unsolved? If so, at what ArgInfo?+  }+  deriving Generic++instance LensModality MetaInfo where+  getModality = miModality+  setModality mod mi = mi { miModality = mod }+  mapModality f mi = mi { miModality = f $ miModality mi }++instance LensQuantity MetaInfo where+  getQuantity   = getQuantity . getModality+  mapQuantity f = mapModality (mapQuantity f)++instance LensRelevance MetaInfo where+  mapRelevance f = mapModality (mapRelevance f)++-- | Name suggestion for meta variable.  Empty string means no suggestion.+type MetaNameSuggestion = String++-- | For printing, we couple a meta with its name suggestion.+data NamedMeta = NamedMeta+  { nmSuggestion :: MetaNameSuggestion+  , nmid         :: MetaId+  }++instance Pretty NamedMeta where+  pretty (NamedMeta "" x) = pretty x+  pretty (NamedMeta "_" x) = pretty x+  pretty (NamedMeta s  x) = text $ "_" ++ s ++ prettyShow x++-- | Used for meta-variables from the current module.++type LocalMetaStore = Map MetaId MetaVariable++-- | Used for meta-variables from other modules (and in 'Interface's).++type RemoteMetaStore = HashMap MetaId RemoteMetaVariable++instance HasRange MetaInfo where+  getRange = clValue . miClosRange++instance HasRange MetaVariable where+    getRange m = getRange $ getMetaInfo m++instance SetRange MetaInfo where+  setRange r m = m { miClosRange = (miClosRange m) { clValue = r }}++instance SetRange MetaVariable where+  setRange r m = m { mvInfo = setRange r (mvInfo m) }++instance LensModality MetaVariable where+  getModality = getModality . mvInfo+  setModality mod mv = mv { mvInfo = setModality mod $ mvInfo mv }+  mapModality f mv = mv { mvInfo = mapModality f $ mvInfo mv }++instance LensRelevance MetaVariable where+  setRelevance mod mv = mv { mvInfo = setRelevance mod $ mvInfo mv }++instance LensQuantity MetaVariable where+  getQuantity   = getQuantity . getModality+  mapQuantity f = mapModality (mapQuantity f)++instance LensModality RemoteMetaVariable where+  getModality      = rmvModality+  mapModality f mv = mv { rmvModality = f $ rmvModality mv }++instance LensRelevance RemoteMetaVariable where+  mapRelevance f = mapModality (mapRelevance f)++instance LensQuantity RemoteMetaVariable where+  mapQuantity f = mapModality (mapQuantity f)++normalMetaPriority :: MetaPriority+normalMetaPriority = MetaPriority 0++lowMetaPriority :: MetaPriority+lowMetaPriority = MetaPriority (-10)++highMetaPriority :: MetaPriority+highMetaPriority = MetaPriority 10++getMetaInfo :: MetaVariable -> Closure Range+getMetaInfo = miClosRange . mvInfo++getMetaScope :: MetaVariable -> ScopeInfo+getMetaScope m = clScope $ getMetaInfo m++getMetaEnv :: MetaVariable -> TCEnv+getMetaEnv m = clEnv $ getMetaInfo m++getMetaSig :: MetaVariable -> Signature+getMetaSig m = clSignature $ getMetaInfo m++-- Lenses++metaFrozen :: Lens' Frozen MetaVariable+metaFrozen f mv = f (mvFrozen mv) <&> \ x -> mv { mvFrozen = x }++_mvInfo :: Lens' MetaInfo MetaVariable+_mvInfo f mv = (f $! mvInfo mv) <&> \ mi -> mv { mvInfo = mi }++-- Lenses onto Closure Range++instance LensClosure Range MetaInfo where+  lensClosure f mi = (f $! miClosRange mi) <&> \ cl -> mi { miClosRange = cl }++instance LensClosure Range MetaVariable where+  lensClosure = _mvInfo . lensClosure++-- Lenses onto IsAbstract++instance LensIsAbstract TCEnv where+  lensIsAbstract f env =+     -- Andreas, 2019-08-19+     -- Using $! to prevent space leaks like #1829.+     -- This can crash when trying to get IsAbstract from IgnoreAbstractMode.+    (f $! fromMaybe __IMPOSSIBLE__ (aModeToDef $ envAbstractMode env))+    <&> \ a -> env { envAbstractMode = aDefToMode a }++instance LensIsAbstract (Closure a) where+  lensIsAbstract = lensTCEnv . lensIsAbstract++instance LensIsAbstract MetaInfo where+  lensIsAbstract = lensClosure . lensIsAbstract++---------------------------------------------------------------------------+-- ** Interaction meta variables+---------------------------------------------------------------------------++-- | Interaction points are created by the scope checker who sets the range.+--   The meta variable is created by the type checker and then hooked up to the+--   interaction point.+data InteractionPoint = InteractionPoint+  { ipRange :: Range        -- ^ The position of the interaction point.+  , ipMeta  :: Maybe MetaId -- ^ The meta variable, if any, holding the type etc.+  , ipSolved:: Bool         -- ^ Has this interaction point already been solved?+  , ipClause:: IPClause+      -- ^ The clause of the interaction point (if any).+      --   Used for case splitting.+  }+  deriving Generic++instance Eq InteractionPoint where (==) = (==) `on` ipMeta++instance HasTag InteractionPoint where+  type Tag InteractionPoint = MetaId+  tag = ipMeta++-- | Data structure managing the interaction points.+--+--   We never remove interaction points from this map, only set their+--   'ipSolved' to @True@.  (Issue #2368)+type InteractionPoints = BiMap InteractionId InteractionPoint++-- | Flag to indicate whether the meta is overapplied in the+--   constraint.  A meta is overapplied if it has more arguments than+--   the size of the telescope in its creation environment+--   (as stored in MetaInfo).+data Overapplied = Overapplied | NotOverapplied+  deriving (Eq, Show, Generic)++-- | Datatype representing a single boundary condition:+--   x_0 = u_0, ... ,x_n = u_n ⊢ t = ?n es+data IPBoundary' t = IPBoundary+  { ipbEquations :: [(t,t)] -- ^ [x_0 = u_0, ... ,x_n = u_n]+  , ipbValue     :: t          -- ^ @t@+  , ipbMetaApp   :: t          -- ^ @?n es@+  , ipbOverapplied :: Overapplied -- ^ Is @?n@ overapplied in @?n es@ ?+  }+  deriving (Show, Functor, Foldable, Traversable, Generic)++type IPBoundary = IPBoundary' Term++-- | Which clause is an interaction point located in?+data IPClause = IPClause+  { ipcQName    :: QName              -- ^ The name of the function.+  , ipcClauseNo :: Int                -- ^ The number of the clause of this function.+  , ipcType     :: Type               -- ^ The type of the function+  , ipcWithSub  :: Maybe Substitution -- ^ Module parameter substitution+  , ipcClause   :: A.SpineClause      -- ^ The original AST clause.+  , ipcClosure  :: Closure ()         -- ^ Environment for rechecking the clause.+  , ipcBoundary :: [Closure IPBoundary] -- ^ The boundary imposed by the LHS.+  }+  | IPNoClause -- ^ The interaction point is not in the rhs of a clause.+  deriving (Generic)++instance Eq IPClause where+  IPNoClause           == IPNoClause             = True+  IPClause x i _ _ _ _ _ == IPClause x' i' _ _ _ _ _ = x == x' && i == i'+  _                    == _                      = False++---------------------------------------------------------------------------+-- ** Signature+---------------------------------------------------------------------------++data Signature = Sig+      { _sigSections    :: Sections+      , _sigDefinitions :: Definitions+      , _sigRewriteRules:: RewriteRuleMap  -- ^ The rewrite rules defined in this file.+      }+  deriving (Show, Generic)++sigSections :: Lens' Sections Signature+sigSections f s =+  f (_sigSections s) <&>+  \x -> s {_sigSections = x}++sigDefinitions :: Lens' Definitions Signature+sigDefinitions f s =+  f (_sigDefinitions s) <&>+  \x -> s {_sigDefinitions = x}++sigRewriteRules :: Lens' RewriteRuleMap Signature+sigRewriteRules f s =+  f (_sigRewriteRules s) <&>+  \x -> s {_sigRewriteRules = x}++type Sections    = Map ModuleName Section+type Definitions = HashMap QName Definition+type RewriteRuleMap = HashMap QName RewriteRules+type DisplayForms = HashMap QName [LocalDisplayForm]++newtype Section = Section { _secTelescope :: Telescope }+  deriving (Show, NFData)++instance Pretty Section where+  pretty = pretty . _secTelescope++secTelescope :: Lens' Telescope Section+secTelescope f s =+  f (_secTelescope s) <&>+  \x -> s {_secTelescope = x}++emptySignature :: Signature+emptySignature = Sig Map.empty HMap.empty HMap.empty++-- | A @DisplayForm@ is in essence a rewrite rule @q ts --> dt@ for a defined symbol (could be a+--   constructor as well) @q@. The right hand side is a 'DisplayTerm' which is used to 'reify' to a+--   more readable 'Abstract.Syntax'.+--+--   The patterns @ts@ are just terms, but the first @dfPatternVars@ variables are pattern variables+--   that matches any term.+data DisplayForm = Display+  { dfPatternVars :: Nat+    -- ^ Number @n@ of pattern variables in 'dfPats'.+  , dfPats :: Elims+    -- ^ Left hand side patterns, the @n@ first free variables are pattern variables,+    --   any variables above @n@ are fixed and only match that particular variable. This+    --   happens when you have display forms inside parameterised modules that match on the module+    --   parameters. The 'ArgInfo' is ignored in these patterns.+  , dfRHS :: DisplayTerm+    -- ^ Right hand side.+  }+  deriving (Show, Generic)++type LocalDisplayForm = Open DisplayForm++-- | A structured presentation of a 'Term' for reification into+--   'Abstract.Syntax'.+data DisplayTerm+  = DWithApp DisplayTerm [DisplayTerm] Elims+    -- ^ @(f vs | ws) es@.+    --   The first 'DisplayTerm' is the parent function @f@ with its args @vs@.+    --   The list of 'DisplayTerm's are the with expressions @ws@.+    --   The 'Elims' are additional arguments @es@+    --   (possible in case the with-application is of function type)+    --   or projections (if it is of record type).+  | DCon ConHead ConInfo [Arg DisplayTerm]+    -- ^ @c vs@.+  | DDef QName [Elim' DisplayTerm]+    -- ^ @d vs@.+  | DDot Term+    -- ^ @.v@.+  | DTerm Term+    -- ^ @v@.+  deriving (Show, Generic)++instance Free DisplayForm where+  freeVars' (Display n ps t) = underBinder (freeVars' ps) `mappend` underBinder' n (freeVars' t)++instance Free DisplayTerm where+  freeVars' (DWithApp t ws es) = freeVars' (t, (ws, es))+  freeVars' (DCon _ _ vs)      = freeVars' vs+  freeVars' (DDef _ es)        = freeVars' es+  freeVars' (DDot v)           = freeVars' v+  freeVars' (DTerm v)          = freeVars' v++instance Pretty DisplayTerm where+  prettyPrec p v =+    case v of+      DTerm v          -> prettyPrec p v+      DDot v           -> "." <> prettyPrec 10 v+      DDef f es        -> pretty f `pApp` es+      DCon c _ vs      -> pretty (conName c) `pApp` map Apply vs+      DWithApp h ws es ->+        mparens (p > 0)+          (sep [ pretty h+              , nest 2 $ fsep [ "|" <+> pretty w | w <- ws ] ])+        `pApp` es+    where+      pApp :: Pretty el => Doc -> [el] -> Doc+      pApp d els = mparens (not (null els) && p > 9) $+                   sep [d, nest 2 $ fsep (map (prettyPrec 10) els)]++instance Pretty DisplayForm where+  prettyPrec p (Display fv lhs rhs) = mparens (p > 9) $+    "Display" <?> fsep [ pshow fv, prettyPrec 10 lhs, prettyPrec 10 rhs ]++-- | By default, we have no display form.+defaultDisplayForm :: QName -> [LocalDisplayForm]+defaultDisplayForm c = []++-- | Non-linear (non-constructor) first-order pattern.+data NLPat+  = PVar !Int [Arg Int]+    -- ^ Matches anything (modulo non-linearity) that only contains bound+    --   variables that occur in the given arguments.+  | PDef QName PElims+    -- ^ Matches @f es@+  | PLam ArgInfo (Abs NLPat)+    -- ^ Matches @λ x → t@+  | PPi (Dom NLPType) (Abs NLPType)+    -- ^ Matches @(x : A) → B@+  | PSort NLPSort+    -- ^ Matches a sort of the given shape.+  | PBoundVar {-# UNPACK #-} !Int PElims+    -- ^ Matches @x es@ where x is a lambda-bound variable+  | PTerm Term+    -- ^ Matches the term modulo β (ideally βη).+  deriving (Show, Generic)+type PElims = [Elim' NLPat]++instance TermLike NLPat where+  traverseTermM f = \case+    p@PVar{}       -> return p+    PDef d ps      -> PDef d <$> traverseTermM f ps+    PLam i p       -> PLam i <$> traverseTermM f p+    PPi a b        -> PPi <$> traverseTermM f a <*> traverseTermM f b+    PSort s        -> PSort <$> traverseTermM f s+    PBoundVar i ps -> PBoundVar i <$> traverseTermM f ps+    PTerm t        -> PTerm <$> f t++  foldTerm f t = case t of+    PVar{}         -> mempty+    PDef d ps      -> foldTerm f ps+    PLam i p       -> foldTerm f p+    PPi a b        -> foldTerm f (a, b)+    PSort s        -> foldTerm f s+    PBoundVar i ps -> foldTerm f ps+    PTerm t        -> foldTerm f t++instance AllMetas NLPat++data NLPType = NLPType+  { nlpTypeSort :: NLPSort+  , nlpTypeUnEl :: NLPat+  } deriving (Show, Generic)++instance TermLike NLPType where+  traverseTermM f (NLPType s t) = NLPType <$> traverseTermM f s <*> traverseTermM f t++  foldTerm f (NLPType s t) = foldTerm f (s, t)++instance AllMetas NLPType++data NLPSort+  = PType NLPat+  | PProp NLPat+  | PSSet NLPat+  | PInf IsFibrant Integer+  | PSizeUniv+  | PLockUniv+  | PIntervalUniv+  deriving (Show, Generic)++instance TermLike NLPSort where+  traverseTermM f = \case+    PType p           -> PType <$> traverseTermM f p+    PProp p           -> PProp <$> traverseTermM f p+    PSSet p           -> PSSet <$> traverseTermM f p+    s@PInf{}          -> return s+    s@PSizeUniv{}     -> return s+    s@PLockUniv{}     -> return s+    s@PIntervalUniv{} -> return s++  foldTerm f t = case t of+    PType p           -> foldTerm f p+    PProp p           -> foldTerm f p+    PSSet p           -> foldTerm f p+    s@PInf{}          -> mempty+    s@PSizeUniv{}     -> mempty+    s@PLockUniv{}     -> mempty+    s@PIntervalUniv{} -> mempty++instance AllMetas NLPSort++type RewriteRules = [RewriteRule]++-- | Rewrite rules can be added independently from function clauses.+data RewriteRule = RewriteRule+  { rewName    :: QName      -- ^ Name of rewrite rule @q : Γ → f ps ≡ rhs@+                             --   where @≡@ is the rewrite relation.+  , rewContext :: Telescope  -- ^ @Γ@.+  , rewHead    :: QName      -- ^ @f@.+  , rewPats    :: PElims     -- ^ @Γ ⊢ f ps : t@.+  , rewRHS     :: Term       -- ^ @Γ ⊢ rhs : t@.+  , rewType    :: Type       -- ^ @Γ ⊢ t@.+  , rewFromClause :: Bool    -- ^ Was this rewrite rule created from a clause in the definition of the function?+  }+    deriving (Show, Generic)++data Definition = Defn+  { defArgInfo        :: ArgInfo -- ^ Hiding should not be used.+  , defName           :: QName   -- ^ The canonical name, used e.g. in compilation.+  , defType           :: Type    -- ^ Type of the lifted definition.+  , defPolarity       :: [Polarity]+    -- ^ Variance information on arguments of the definition.+    --   Does not include info for dropped parameters to+    --   projection(-like) functions and constructors.+  , defArgOccurrences :: [Occurrence]+    -- ^ Positivity information on arguments of the definition.+    --   Does not include info for dropped parameters to+    --   projection(-like) functions and constructors.++    --   Sometimes Agda looks up 'Occurrence's in these lists based on+    --   their position, so one might consider replacing the list+    --   with, say, an 'IntMap'. However, presumably these lists tend+    --   to be short, in which case 'IntMap's could be slower than+    --   lists. For instance, at one point the longest list+    --   encountered for the standard library (in serialised+    --   interfaces) had length 27. Distribution:+    --+    --   Length, number of lists+    --   -----------------------+    --+    --    0, 2444+    --    1,  721+    --    2,  433+    --    3,  668+    --    4,  602+    --    5,  624+    --    6,  626+    --    7,  484+    --    8,  375+    --    9,  264+    --   10,  305+    --   11,  188+    --   12,  171+    --   13,  108+    --   14,   84+    --   15,   80+    --   16,   38+    --   17,   23+    --   18,   16+    --   19,    8+    --   20,    7+    --   21,    5+    --   22,    2+    --   23,    3+    --   27,    1++  , defArgGeneralizable :: NumGeneralizableArgs+    -- ^ How many arguments should be generalised.+  , defGeneralizedParams :: [Maybe Name]+    -- ^ Gives the name of the (bound variable) parameter for named generalized+    --   parameters. This is needed to bring it into scope when type checking+    --   the data/record definition corresponding to a type with generalized+    --   parameters.+  , defDisplay        :: [LocalDisplayForm]+  , defMutual         :: MutualId+  , defCompiledRep    :: CompiledRepresentation+  , defInstance       :: Maybe QName+    -- ^ @Just q@ when this definition is an instance of class q+  , defCopy           :: Bool+    -- ^ Has this function been created by a module+                         -- instantiation?+  , defMatchable      :: Set QName+    -- ^ The set of symbols with rewrite rules that match against this symbol+  , defNoCompilation  :: Bool+    -- ^ should compilers skip this? Used for e.g. cubical's comp+  , defInjective      :: Bool+    -- ^ Should the def be treated as injective by the pattern matching unifier?+  , defCopatternLHS   :: Bool+    -- ^ Is this a function defined by copatterns?+  , defBlocked        :: Blocked_+    -- ^ What blocking tag to use when we cannot reduce this def?+    --   Used when checking a function definition is blocked on a meta+    --   in the type.+  , defLanguage       :: !Language+    -- ^ The language used for the definition.+  , theDef            :: Defn+  }+    deriving (Show, Generic)++instance LensArgInfo Definition where+  getArgInfo = defArgInfo+  mapArgInfo f def = def { defArgInfo = f $ defArgInfo def }++instance LensModality  Definition where+instance LensQuantity  Definition where+instance LensRelevance Definition where++data NumGeneralizableArgs+  = NoGeneralizableArgs+  | SomeGeneralizableArgs !Int+    -- ^ When lambda-lifting new args are generalizable if+    --   'SomeGeneralizableArgs', also when the number is zero.+  deriving Show++lensTheDef :: Lens' Defn Definition+lensTheDef f d = f (theDef d) <&> \ df -> d { theDef = df }++-- | Create a definition with sensible defaults.+defaultDefn ::+  ArgInfo -> QName -> Type -> Language -> Defn -> Definition+defaultDefn info x t lang def = Defn+  { defArgInfo        = info+  , defName           = x+  , defType           = t+  , defPolarity       = []+  , defArgOccurrences = []+  , defArgGeneralizable = NoGeneralizableArgs+  , defGeneralizedParams = []+  , defDisplay        = defaultDisplayForm x+  , defMutual         = 0+  , defCompiledRep    = noCompiledRep+  , defInstance       = Nothing+  , defCopy           = False+  , defMatchable      = Set.empty+  , defNoCompilation  = False+  , defInjective      = False+  , defCopatternLHS   = False+  , defBlocked        = NotBlocked ReallyNotBlocked ()+  , defLanguage       = lang+  , theDef            = def+  }++-- | Polarity for equality and subtype checking.+data Polarity+  = Covariant      -- ^ monotone+  | Contravariant  -- ^ antitone+  | Invariant      -- ^ no information (mixed variance)+  | Nonvariant     -- ^ constant+  deriving (Show, Eq, Generic)++instance Pretty Polarity where+  pretty = text . \case+    Covariant     -> "+"+    Contravariant -> "-"+    Invariant     -> "*"+    Nonvariant    -> "_"++-- | Information about whether an argument is forced by the type of a function.+data IsForced+  = Forced+  | NotForced+  deriving (Show, Eq, Generic)++-- | The backends are responsible for parsing their own pragmas.+data CompilerPragma = CompilerPragma Range String+  deriving (Show, Eq, Generic)++instance HasRange CompilerPragma where+  getRange (CompilerPragma r _) = r++type BackendName    = String++jsBackendName, ghcBackendName :: BackendName+jsBackendName  = "JS"+ghcBackendName = "GHC"++type CompiledRepresentation = Map BackendName [CompilerPragma]++noCompiledRep :: CompiledRepresentation+noCompiledRep = Map.empty++-- A face represented as a list of equality constraints.+-- (r,False) ↦ (r = i0)+-- (r,True ) ↦ (r = i1)+type Face = [(Term,Bool)]++-- | An alternative representation of partial elements in a telescope:+--   Γ ⊢ λ Δ. [φ₁ u₁, ... , φₙ uₙ] : Δ → PartialP (∨_ᵢ φᵢ) T+--   see cubicaltt paper (however we do not store the type T).+data System = System+  { systemTel :: Telescope+    -- ^ the telescope Δ, binding vars for the clauses, Γ ⊢ Δ+  , systemClauses :: [(Face,Term)]+    -- ^ a system [φ₁ u₁, ... , φₙ uₙ] where Γ, Δ ⊢ φᵢ and Γ, Δ, φᵢ ⊢ uᵢ+  } deriving (Show, Generic)++-- | Additional information for extended lambdas.+data ExtLamInfo = ExtLamInfo+  { extLamModule    :: ModuleName+    -- ^ For complicated reasons the scope checker decides the QName of a+    --   pattern lambda, and thus its module. We really need to decide the+    --   module during type checking though, since if the lambda appears in a+    --   refined context the module picked by the scope checker has very much+    --   the wrong parameters.+  , extLamAbsurd :: Bool+    -- ^ Was this definition created from an absurd lambda @λ ()@?+  , extLamSys :: !(Strict.Maybe System)+  } deriving (Show, Generic)++modifySystem :: (System -> System) -> ExtLamInfo -> ExtLamInfo+modifySystem f e = let !e' = e { extLamSys = f <$> extLamSys e } in e'++-- | Additional information for projection 'Function's.+data Projection = Projection+  { projProper    :: Maybe QName+    -- ^ @Nothing@ if only projection-like, @Just r@ if record projection.+    --   The @r@ is the name of the record type projected from.+    --   This field is updated by module application.+  , projOrig      :: QName+    -- ^ The original projection name+    --   (current name could be from module application).+  , projFromType  :: Arg QName+    -- ^ Type projected from. Original record type if @projProper = Just{}@.+    --   Also stores @ArgInfo@ of the principal argument.+    --   This field is unchanged by module application.+  , projIndex     :: Int+    -- ^ Index of the record argument.+    --   Start counting with 1, because 0 means that+    --   it is already applied to the record value.+    --   This can happen in module instantiation, but+    --   then either the record value is @var 0@, or @funProjection == Nothing@.+  , projLams :: ProjLams+    -- ^ Term @t@ to be be applied to record parameters and record value.+    --   The parameters will be dropped.+    --   In case of a proper projection, a postfix projection application+    --   will be created: @t = \ pars r -> r .p@+    --   (Invariant: the number of abstractions equals 'projIndex'.)+    --   In case of a projection-like function, just the function symbol+    --   is returned as 'Def':  @t = \ pars -> f@.+  } deriving (Show, Generic)++-- | Abstractions to build projection function (dropping parameters).+newtype ProjLams = ProjLams { getProjLams :: [Arg ArgName] }+  deriving (Show, Null, Generic)++-- | Building the projection function (which drops the parameters).+projDropPars :: Projection -> ProjOrigin -> Term+-- Proper projections:+projDropPars (Projection Just{} d _ _ lams) o =+  case initLast $ getProjLams lams of+    Nothing -> Def d []+    Just (pars, Arg i y) ->+      let core = Lam i $ Abs y $ Var 0 [Proj o d] in+      List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) core pars+-- Projection-like functions:+projDropPars (Projection Nothing d _ _ lams) o =+  List.foldr (\ (Arg ai x) -> Lam ai . NoAbs x) (Def d []) $+    initWithDefault __IMPOSSIBLE__ $ getProjLams lams++-- | The info of the principal (record) argument.+projArgInfo :: Projection -> ArgInfo+projArgInfo (Projection _ _ _ _ lams) =+  maybe __IMPOSSIBLE__ getArgInfo $ lastMaybe $ getProjLams lams++-- | Should a record type admit eta-equality?+data EtaEquality+  = Specified { theEtaEquality :: !HasEta }  -- ^ User specifed 'eta-equality' or 'no-eta-equality'.+  | Inferred  { theEtaEquality :: !HasEta }  -- ^ Positivity checker inferred whether eta is safe.+  deriving (Show, Eq, Generic)++instance PatternMatchingAllowed EtaEquality where+  patternMatchingAllowed = patternMatchingAllowed . theEtaEquality++instance CopatternMatchingAllowed EtaEquality where+  copatternMatchingAllowed = copatternMatchingAllowed . theEtaEquality++-- | Make sure we do not overwrite a user specification.+setEtaEquality :: EtaEquality -> HasEta -> EtaEquality+setEtaEquality e@Specified{} _ = e+setEtaEquality _ b = Inferred b++data FunctionFlag+  = FunStatic  -- ^ Should calls to this function be normalised at compile-time?+  | FunInline  -- ^ Should calls to this function be inlined by the compiler?+  | FunMacro   -- ^ Is this function a macro?+  deriving (Eq, Ord, Enum, Show, Generic)++data CompKit = CompKit+  { nameOfHComp :: Maybe QName+  , nameOfTransp :: Maybe QName+  }+  deriving (Eq, Ord, Show, Generic)++emptyCompKit :: CompKit+emptyCompKit = CompKit Nothing Nothing++defaultAxiom :: Defn+defaultAxiom = Axiom False++constTranspAxiom :: Defn+constTranspAxiom = Axiom True++data Defn+  = AxiomDefn AxiomData+      -- ^ Postulate.+  | DataOrRecSigDefn DataOrRecSigData+      -- ^ Data or record type signature that doesn't yet have a definition.+  | GeneralizableVar+      -- ^ Generalizable variable (introduced in `generalize` block).+  | AbstractDefn Defn+      -- ^ Returned by 'getConstInfo' if definition is abstract.+  | FunctionDefn FunctionData+  | DatatypeDefn DatatypeData+  | RecordDefn RecordData+  | ConstructorDefn ConstructorData+  | PrimitiveDefn PrimitiveData+      -- ^ Primitive or builtin functions.+  | PrimitiveSortDefn PrimitiveSortData+    deriving (Show, Generic)++-- The COMPLETE pragma is new in GHC 8.2+#if __GLASGOW_HASKELL__ >= 802+{-# COMPLETE+  Axiom, DataOrRecSig, GeneralizableVar, AbstractDefn,+  Function, Datatype, Record, Constructor, Primitive, PrimitiveSort #-}+#endif++data AxiomData = AxiomData+  { _axiomConstTransp :: Bool+    -- ^ Can transp for this postulate be constant?+    --   Set to @True@ for bultins like String.+  } deriving (Show, Generic)++pattern Axiom :: Bool -> Defn+pattern Axiom{ axiomConstTransp } = AxiomDefn (AxiomData axiomConstTransp)++data DataOrRecSigData = DataOrRecSigData+  { _datarecPars :: Int+  } deriving (Show, Generic)++pattern DataOrRecSig :: Int -> Defn+pattern DataOrRecSig{ datarecPars } = DataOrRecSigDefn (DataOrRecSigData datarecPars)++-- | Indicates the reason behind a function having not been marked+-- projection-like.+data ProjectionLikenessMissing+  = MaybeProjection+    -- ^ Projection-likeness analysis has not run on this function yet.+    -- It may do so in the future.+  | NeverProjection+    -- ^ The user has requested that this function be not be marked+    -- projection-like. The analysis may already have run on this+    -- function, but the results have been discarded, and it will not be+    -- run again.+  deriving (Show, Generic, Enum, Bounded)++data FunctionData = FunctionData+  { _funClauses        :: [Clause]+  , _funCompiled       :: Maybe CompiledClauses+      -- ^ 'Nothing' while function is still type-checked.+      --   @Just cc@ after type and coverage checking and+      --   translation to case trees.+  , _funSplitTree      :: Maybe SplitTree+      -- ^ The split tree constructed by the coverage+      --   checker. Needed to re-compile the clauses after+      --   forcing translation.+  , _funTreeless       :: Maybe Compiled+      -- ^ Intermediate representation for compiler backends.+  , _funCovering       :: [Clause]+      -- ^ Covering clauses computed by coverage checking.+      --   Erased by (IApply) confluence checking(?)+  , _funInv            :: FunctionInverse+  , _funMutual         :: Maybe [QName]+      -- ^ Mutually recursive functions, @data@s and @record@s.+      --   Does include this function.+      --   Empty list if not recursive.+      --   @Nothing@ if not yet computed (by positivity checker).+  , _funAbstr          :: IsAbstract+  , _funDelayed        :: Delayed+      -- ^ Are the clauses of this definition delayed?+  , _funProjection     :: Either ProjectionLikenessMissing Projection+      -- ^ Is it a record projection?+      --   If yes, then return the name of the record type and index of+      --   the record argument.  Start counting with 1, because 0 means that+      --   it is already applied to the record. (Can happen in module+      --   instantiation.) This information is used in the termination+      --   checker.+  , _funFlags          :: Set FunctionFlag+  , _funTerminates     :: Maybe Bool+      -- ^ Has this function been termination checked?  Did it pass?+  , _funExtLam         :: Maybe ExtLamInfo+      -- ^ Is this function generated from an extended lambda?+      --   If yes, then return the number of hidden and non-hidden lambda-lifted arguments.+  , _funWith           :: Maybe QName+      -- ^ Is this a generated with-function?+      --   If yes, then what's the name of the parent function?+  , _funIsKanOp        :: Maybe QName+      -- ^ Is this a helper for one of the Kan operations (transp,+      -- hcomp) on data types/records? If so, for which data type?+  } deriving (Show, Generic)++pattern Function+  :: [Clause]+  -> Maybe CompiledClauses+  -> Maybe SplitTree+  -> Maybe Compiled+  -> [Clause]+  -> FunctionInverse+  -> Maybe [QName]+  -> IsAbstract+  -> Delayed+  -> Either ProjectionLikenessMissing Projection+  -> Set FunctionFlag+  -> Maybe Bool+  -> Maybe ExtLamInfo+  -> Maybe QName+  -> Maybe QName+  -> Defn+pattern Function+  { funClauses+  , funCompiled+  , funSplitTree+  , funTreeless+  , funCovering+  , funInv+  , funMutual+  , funAbstr+  , funDelayed+  , funProjection+  , funFlags+  , funTerminates+  , funExtLam+  , funWith+  , funIsKanOp+  } = FunctionDefn (FunctionData+    funClauses+    funCompiled+    funSplitTree+    funTreeless+    funCovering+    funInv+    funMutual+    funAbstr+    funDelayed+    funProjection+    funFlags+    funTerminates+    funExtLam+    funWith+    funIsKanOp+  )++data DatatypeData = DatatypeData+  { _dataPars           :: Nat+      -- ^ Number of parameters.+  , _dataIxs            :: Nat+      -- ^ Number of indices.+  , _dataClause         :: Maybe Clause+      -- ^ This might be in an instantiated module.+  , _dataCons           :: [QName]+      -- ^ Constructor names, ordered according to the order of their definition.+  , _dataSort           :: Sort+  , _dataMutual         :: Maybe [QName]+      -- ^ Mutually recursive functions, @data@s and @record@s.+      --   Does include this data type.+      --   Empty if not recursive.+      --   @Nothing@ if not yet computed (by positivity checker).+  , _dataAbstr          :: IsAbstract+  , _dataPathCons       :: [QName]+      -- ^ Path constructor names (subset of @dataCons@).+  , _dataTranspIx       :: Maybe QName+      -- ^ If indexed datatype, name of the "index transport" function.+  , _dataTransp         :: Maybe QName+      -- ^ Transport function, should be available for all datatypes in supported sorts.+  } deriving (Show, Generic)++pattern Datatype+  :: Nat+  -> Nat+  -> (Maybe Clause)+  -> [QName]+  -> Sort+  -> Maybe [QName]+  -> IsAbstract+  -> [QName]+  -> Maybe QName+  -> Maybe QName+  -> Defn++pattern Datatype+  { dataPars+  , dataIxs+  , dataClause+  , dataCons+  , dataSort+  , dataMutual+  , dataAbstr+  , dataPathCons+  , dataTranspIx+  , dataTransp+  } = DatatypeDefn (DatatypeData+    dataPars+    dataIxs+    dataClause+    dataCons+    dataSort+    dataMutual+    dataAbstr+    dataPathCons+    dataTranspIx+    dataTransp+  )++data RecordData = RecordData+  { _recPars           :: Nat+      -- ^ Number of parameters.+  , _recClause         :: Maybe Clause+      -- ^ Was this record type created by a module application?+      --   If yes, the clause is its definition (linking back to the original record type).+  , _recConHead        :: ConHead+      -- ^ Constructor name and fields.+  , _recNamedCon       :: Bool+      -- ^ Does this record have a @constructor@?+  , _recFields         :: [Dom QName]+      -- ^ The record field names.+  , _recTel            :: Telescope+      -- ^ The record field telescope. (Includes record parameters.)+      --   Note: @TelV recTel _ == telView' recConType@.+      --   Thus, @recTel@ is redundant.+  , _recMutual         :: Maybe [QName]+      -- ^ Mutually recursive functions, @data@s and @record@s.+      --   Does include this record.+      --   Empty if not recursive.+      --   @Nothing@ if not yet computed (by positivity checker).+  , _recEtaEquality'    :: EtaEquality+      -- ^ Eta-expand at this record type?+      --   @False@ for unguarded recursive records and coinductive records+      --   unless the user specifies otherwise.+  , _recPatternMatching :: PatternOrCopattern+      -- ^ In case eta-equality is off, do we allow pattern matching on the+      --   constructor or construction by copattern matching?+      --   Having both loses subject reduction, see issue #4560.+      --   After positivity checking, this field is obsolete, part of 'EtaEquality'.+  , _recInduction      :: Maybe Induction+      -- ^ 'Inductive' or 'CoInductive'?  Matters only for recursive records.+      --   'Nothing' means that the user did not specify it, which is an error+      --   for recursive records.+  , _recTerminates     :: Maybe Bool+      -- ^ 'Just True' means that unfolding of the recursive record terminates,+      --   'Just False' means that we have no evidence for termination,+      --   and 'Nothing' means we have not run the termination checker yet.+  , _recAbstr          :: IsAbstract+  , _recComp           :: CompKit+  } deriving (Show, Generic)++pattern Record+  :: Nat+  -> Maybe Clause+  -> ConHead+  -> Bool+  -> [Dom QName]+  -> Telescope+  -> Maybe [QName]+  -> EtaEquality+  -> PatternOrCopattern+  -> Maybe Induction+  -> Maybe Bool+  -> IsAbstract+  -> CompKit+  -> Defn++pattern Record+  { recPars+  , recClause+  , recConHead+  , recNamedCon+  , recFields+  , recTel+  , recMutual+  , recEtaEquality'+  , recPatternMatching+  , recInduction+  , recTerminates+  , recAbstr+  , recComp+  } = RecordDefn (RecordData+    recPars+    recClause+    recConHead+    recNamedCon+    recFields+    recTel+    recMutual+    recEtaEquality'+    recPatternMatching+    recInduction+    recTerminates+    recAbstr+    recComp+  )++data ConstructorData = ConstructorData+  { _conPars   :: Int+      -- ^ Number of parameters.+  , _conArity  :: Int+      -- ^ Number of arguments (excluding parameters).+  , _conSrcCon :: ConHead+      -- ^ Name of (original) constructor and fields. (This might be in a module instance.)+  , _conData   :: QName+      -- ^ Name of datatype or record type.+  , _conAbstr  :: IsAbstract+  , _conInd    :: Induction+      -- ^ Inductive or coinductive?+  , _conComp   :: CompKit+      -- ^ Cubical composition.+  , _conProj   :: Maybe [QName]+      -- ^ Projections. 'Nothing' if not yet computed.+  , _conForced :: [IsForced]+      -- ^ Which arguments are forced (i.e. determined by the type of the constructor)?+      --   Either this list is empty (if the forcing analysis isn't run), or its length is @conArity@.+  , _conErased :: Maybe [Bool]+      -- ^ Which arguments are erased at runtime (computed during compilation to treeless)?+      --   'True' means erased, 'False' means retained.+      --   'Nothing' if no erasure analysis has been performed yet.+      --   The length of the list is @conArity@.+  } deriving (Show, Generic)++pattern Constructor+  :: Int+  -> Int+  -> ConHead+  -> QName+  -> IsAbstract+  -> Induction+  -> CompKit+  -> Maybe [QName]+  -> [IsForced]+  -> Maybe [Bool]+  -> Defn+pattern Constructor+  { conPars+  , conArity+  , conSrcCon+  , conData+  , conAbstr+  , conInd+  , conComp+  , conProj+  , conForced+  , conErased+  } = ConstructorDefn (ConstructorData+    conPars+    conArity+    conSrcCon+    conData+    conAbstr+    conInd+    conComp+    conProj+    conForced+    conErased+  )++data PrimitiveData = PrimitiveData+  { _primAbstr    :: IsAbstract+  , _primName     :: String+  , _primClauses  :: [Clause]+      -- ^ 'null' for primitive functions, @not null@ for builtin functions.+  , _primInv      :: FunctionInverse+      -- ^ Builtin functions can have inverses. For instance, natural number addition.+  , _primCompiled :: Maybe CompiledClauses+      -- ^ 'Nothing' for primitive functions,+      --   @'Just' something@ for builtin functions.+  } deriving (Show, Generic)++pattern Primitive+  :: IsAbstract+  -> String+  -> [Clause]+  -> FunctionInverse+  -> Maybe CompiledClauses+  -> Defn+pattern Primitive+  { primAbstr+  , primName+  , primClauses+  , primInv+  , primCompiled+  } = PrimitiveDefn (PrimitiveData+    primAbstr+    primName+    primClauses+    primInv+    primCompiled+  )++data PrimitiveSortData = PrimitiveSortData+  { _primSortName :: String+  , _primSortSort :: Sort+  } deriving (Show, Generic)++pattern PrimitiveSort+  :: String+  -> Sort+  -> Defn+pattern PrimitiveSort+  { primSortName+  , primSortSort+  } = PrimitiveSortDefn (PrimitiveSortData+    primSortName+    primSortSort+  )++-- TODO: lenses for all Defn variants++lensFunction :: Lens' FunctionData Defn+lensFunction f = \case+  FunctionDefn d -> FunctionDefn <$> f d+  _ -> __IMPOSSIBLE__++lensConstructor :: Lens' ConstructorData Defn+lensConstructor f = \case+  ConstructorDefn d -> ConstructorDefn <$> f d+  _ -> __IMPOSSIBLE__++lensRecord :: Lens' RecordData Defn+lensRecord f = \case+  RecordDefn d -> RecordDefn <$> f d+  _ -> __IMPOSSIBLE__++-- Lenses for Record++lensRecTel :: Lens' Telescope RecordData+lensRecTel f r =+  f (_recTel r) <&> \ tel -> r { _recTel = tel }++-- Pretty printing definitions++instance Pretty Definition where+  pretty Defn{..} =+    "Defn {" <?> vcat+      [ "defArgInfo        =" <?> pshow defArgInfo+      , "defName           =" <?> pretty defName+      , "defType           =" <?> pretty defType+      , "defPolarity       =" <?> pshow defPolarity+      , "defArgOccurrences =" <?> pshow defArgOccurrences+      , "defGeneralizedParams =" <?> pshow defGeneralizedParams+      , "defDisplay        =" <?> pretty defDisplay+      , "defMutual         =" <?> pshow defMutual+      , "defCompiledRep    =" <?> pshow defCompiledRep+      , "defInstance       =" <?> pshow defInstance+      , "defCopy           =" <?> pshow defCopy+      , "defMatchable      =" <?> pshow (Set.toList defMatchable)+      , "defInjective      =" <?> pshow defInjective+      , "defCopatternLHS   =" <?> pshow defCopatternLHS+      , "theDef            =" <?> pretty theDef ] <+> "}"++instance Pretty Defn where+  pretty = \case+    AxiomDefn _         -> "Axiom"+    DataOrRecSigDefn d  -> pretty d+    GeneralizableVar    -> "GeneralizableVar"+    AbstractDefn def    -> "AbstractDefn" <?> parens (pretty def)+    FunctionDefn d      -> pretty d+    DatatypeDefn d      -> pretty d+    RecordDefn d        -> pretty d+    ConstructorDefn d   -> pretty d+    PrimitiveDefn d     -> pretty d+    PrimitiveSortDefn d -> pretty d++instance Pretty DataOrRecSigData where+  pretty (DataOrRecSigData n) = "DataOrRecSig" <+> pretty n++instance Pretty ProjectionLikenessMissing where+  pretty MaybeProjection = "MaybeProjection"+  pretty NeverProjection = "NeverProjection"++instance Pretty FunctionData where+  pretty (FunctionData+      funClauses+      funCompiled+      funSplitTree+      funTreeless+      _funCovering+      funInv+      funMutual+      funAbstr+      funDelayed+      funProjection+      funFlags+      funTerminates+      _funExtLam+      funWith+      funIsKanOp+    ) =+    "Function {" <?> vcat+      [ "funClauses      =" <?> vcat (map pretty funClauses)+      , "funCompiled     =" <?> pretty funCompiled+      , "funSplitTree    =" <?> pretty funSplitTree+      , "funTreeless     =" <?> pshow funTreeless+      , "funInv          =" <?> pretty funInv+      , "funMutual       =" <?> pshow funMutual+      , "funAbstr        =" <?> pshow funAbstr+      , "funDelayed      =" <?> pshow funDelayed+      , "funProjection   =" <?> pretty funProjection+      , "funFlags        =" <?> pshow funFlags+      , "funTerminates   =" <?> pshow funTerminates+      , "funWith         =" <?> pretty funWith+      , "funIsKanOp      =" <?> pretty funWith+      ] <?> "}"++instance Pretty DatatypeData where+  pretty (DatatypeData+      dataPars+      dataIxs+      dataClause+      dataCons+      dataSort+      dataMutual+      _dataAbstr+      _dataPathCons+      _dataTranspIx+      _dataTransp+    ) =+    "Datatype {" <?> vcat+      [ "dataPars       =" <?> pshow dataPars+      , "dataIxs        =" <?> pshow dataIxs+      , "dataClause     =" <?> pretty dataClause+      , "dataCons       =" <?> pshow dataCons+      , "dataSort       =" <?> pretty dataSort+      , "dataMutual     =" <?> pshow dataMutual+      , "dataAbstr      =" <?> pshow dataAbstr+      ] <?> "}"++instance Pretty RecordData where+  pretty (RecordData+      recPars+      recClause+      recConHead+      recNamedCon+      recFields+      recTel+      recMutual+      recEtaEquality'+      _recPatternMatching+      recInduction+      _recTerminates+      recAbstr+      _recComp+    ) =+    "Record {" <?> vcat+      [ "recPars         =" <?> pshow recPars+      , "recClause       =" <?> pretty recClause+      , "recConHead      =" <?> pretty recConHead+      , "recNamedCon     =" <?> pretty recNamedCon+      , "recFields       =" <?> pretty recFields+      , "recTel          =" <?> pretty recTel+      , "recMutual       =" <?> pshow recMutual+      , "recEtaEquality' =" <?> pshow recEtaEquality'+      , "recInduction    =" <?> pshow recInduction+      , "recAbstr        =" <?> pshow recAbstr+      ] <?> "}"++instance Pretty ConstructorData where+  pretty (ConstructorData+      conPars+      conArity+      conSrcCon+      conData+      conAbstr+      conInd+      _conComp+      _conProj+      _conForced+      conErased+    ) =+    "Constructor {" <?> vcat+      [ "conPars   =" <?> pshow conPars+      , "conArity  =" <?> pshow conArity+      , "conSrcCon =" <?> pretty conSrcCon+      , "conData   =" <?> pretty conData+      , "conAbstr  =" <?> pshow conAbstr+      , "conInd    =" <?> pshow conInd+      , "conErased =" <?> pshow conErased+      ] <?> "}"++instance Pretty PrimitiveData where+  pretty (PrimitiveData+      primAbstr+      primName+      primClauses+      _primInv+      primCompiled+      ) =+    "Primitive {" <?> vcat+      [ "primAbstr    =" <?> pshow primAbstr+      , "primName     =" <?> pshow primName+      , "primClauses  =" <?> pshow primClauses+      , "primCompiled =" <?> pshow primCompiled+      ] <?> "}"++instance Pretty PrimitiveSortData where+  pretty (PrimitiveSortData primSortName primSortSort) =+    "PrimitiveSort {" <?> vcat+      [ "primSortName =" <?> pshow primSortName+      , "primSortSort =" <?> pshow primSortSort+      ] <?> "}"++instance Pretty Projection where+  pretty Projection{..} =+    "Projection {" <?> vcat+      [ "projProper   =" <?> pretty projProper+      , "projOrig     =" <?> pretty projOrig+      , "projFromType =" <?> pretty projFromType+      , "projIndex    =" <?> pshow projIndex+      , "projLams     =" <?> pretty projLams+      ]++instance Pretty c => Pretty (FunctionInverse' c) where+  pretty NotInjective = "NotInjective"+  pretty (Inverse inv) = "Inverse" <?>+    vcat [ pretty h <+> "->" <?> pretty cs+         | (h, cs) <- Map.toList inv ]++instance Pretty ProjLams where+  pretty (ProjLams args) = pretty args++-- | Is the record type recursive?+recRecursive :: Defn -> Bool+recRecursive (Record { recMutual = Just qs }) = not $ null qs+recRecursive _ = __IMPOSSIBLE__++recEtaEquality :: Defn -> HasEta+recEtaEquality = theEtaEquality . recEtaEquality'++-- | A template for creating 'Function' definitions, with sensible defaults.+emptyFunctionData :: FunctionData+emptyFunctionData = FunctionData+  { _funClauses     = []+  , _funCompiled    = Nothing+  , _funSplitTree   = Nothing+  , _funTreeless    = Nothing+  , _funInv         = NotInjective+  , _funMutual      = Nothing+  , _funAbstr       = ConcreteDef+  , _funDelayed     = NotDelayed+  , _funProjection  = Left MaybeProjection+  , _funFlags       = Set.empty+  , _funTerminates  = Nothing+  , _funExtLam      = Nothing+  , _funWith        = Nothing+  , _funCovering    = []+  , _funIsKanOp     = Nothing+  }++emptyFunction :: Defn+emptyFunction = FunctionDefn emptyFunctionData++funFlag :: FunctionFlag -> Lens' Bool Defn+funFlag flag f def@Function{ funFlags = flags } =+  f (Set.member flag flags) <&>+  \ b -> def{ funFlags = (if b then Set.insert else Set.delete) flag flags }+funFlag _ f def = f False $> def++funStatic, funInline, funMacro :: Lens' Bool Defn+funStatic       = funFlag FunStatic+funInline       = funFlag FunInline+funMacro        = funFlag FunMacro++isMacro :: Defn -> Bool+isMacro = (^. funMacro)++-- | Checking whether we are dealing with a function yet to be defined.+isEmptyFunction :: Defn -> Bool+isEmptyFunction def =+  case def of+    Function { funClauses = [] } -> True+    _ -> False++isCopatternLHS :: [Clause] -> Bool+isCopatternLHS = List.any (List.any (isJust . A.isProjP) . namedClausePats)++recCon :: Defn -> QName+recCon Record{ recConHead } = conName recConHead+recCon _ = __IMPOSSIBLE__++defIsRecord :: Defn -> Bool+defIsRecord Record{} = True+defIsRecord _        = False++defIsDataOrRecord :: Defn -> Bool+defIsDataOrRecord Record{}   = True+defIsDataOrRecord Datatype{} = True+defIsDataOrRecord _          = False++defConstructors :: Defn -> [QName]+defConstructors Datatype{dataCons = cs} = cs+defConstructors Record{recConHead = c} = [conName c]+defConstructors _ = __IMPOSSIBLE__++newtype Fields = Fields [(C.Name, Type)]+  deriving Null++-- | Did we encounter a simplifying reduction?+--   In terms of CIC, that would be a iota-reduction.+--   In terms of Agda, this is a constructor or literal+--   pattern that matched.+--   Just beta-reduction (substitution) or delta-reduction+--   (unfolding of definitions) does not count as simplifying?++data Simplification = YesSimplification | NoSimplification+  deriving (Eq, Show, Generic)++instance Null Simplification where+  empty = NoSimplification+  null  = (== NoSimplification)++instance Semigroup Simplification where+  YesSimplification <> _ = YesSimplification+  NoSimplification  <> s = s++instance Monoid Simplification where+  mempty = NoSimplification+  mappend = (<>)++data Reduced no yes+  = NoReduction no+  | YesReduction Simplification yes+  deriving Functor++redReturn :: a -> ReduceM (Reduced a' a)+redReturn = return . YesReduction YesSimplification++-- | Conceptually: @redBind m f k = either (return . Left . f) k =<< m@++redBind :: ReduceM (Reduced a a') -> (a -> b) ->+           (a' -> ReduceM (Reduced b b')) -> ReduceM (Reduced b b')+redBind ma f k = do+  r <- ma+  case r of+    NoReduction x    -> return $ NoReduction $ f x+    YesReduction _ y -> k y++-- | Three cases: 1. not reduced, 2. reduced, but blocked, 3. reduced, not blocked.+data IsReduced+  = NotReduced+  | Reduced    (Blocked ())++data MaybeReduced a = MaybeRed+  { isReduced     :: IsReduced+  , ignoreReduced :: a+  }+  deriving (Functor)++instance IsProjElim e => IsProjElim (MaybeReduced e) where+  isProjElim = isProjElim . ignoreReduced++type MaybeReducedArgs = [MaybeReduced (Arg Term)]+type MaybeReducedElims = [MaybeReduced Elim]++notReduced :: a -> MaybeReduced a+notReduced x = MaybeRed NotReduced x++reduced :: Blocked (Arg Term) -> MaybeReduced (Arg Term)+reduced b = MaybeRed (Reduced $ () <$ b) $ ignoreBlocking b++-- | Controlling 'reduce'.+data AllowedReduction+  = ProjectionReductions     -- ^ (Projection and) projection-like functions may be reduced.+  | InlineReductions         -- ^ Functions marked INLINE may be reduced.+  | CopatternReductions      -- ^ Copattern definitions may be reduced.+  | FunctionReductions       -- ^ Non-recursive functions and primitives may be reduced.+  | RecursiveReductions      -- ^ Even recursive functions may be reduced.+  | LevelReductions          -- ^ Reduce @'Level'@ terms.+  | TypeLevelReductions      -- ^ Allow @allReductions@ in types, even+                             --   if not allowed at term level (used+                             --   by confluence checker)+  | UnconfirmedReductions    -- ^ Functions whose termination has not (yet) been confirmed.+  | NonTerminatingReductions -- ^ Functions that have failed termination checking.+  deriving (Show, Eq, Ord, Enum, Bounded, Ix, Generic)++type AllowedReductions = SmallSet AllowedReduction++-- | Not quite all reductions (skip non-terminating reductions)+allReductions :: AllowedReductions+allReductions = SmallSet.delete NonTerminatingReductions reallyAllReductions++reallyAllReductions :: AllowedReductions+reallyAllReductions = SmallSet.total++data ReduceDefs+  = OnlyReduceDefs (Set QName)+  | DontReduceDefs (Set QName)+  deriving Generic++reduceAllDefs :: ReduceDefs+reduceAllDefs = DontReduceDefs empty++locallyReduceDefs :: MonadTCEnv m => ReduceDefs -> m a -> m a+locallyReduceDefs = locallyTC eReduceDefs . const++locallyReduceAllDefs :: MonadTCEnv m => m a -> m a+locallyReduceAllDefs = locallyReduceDefs reduceAllDefs++shouldReduceDef :: (MonadTCEnv m) => QName -> m Bool+shouldReduceDef f = asksTC envReduceDefs <&> \case+  OnlyReduceDefs defs -> f `Set.member` defs+  DontReduceDefs defs -> not $ f `Set.member` defs++instance Semigroup ReduceDefs where+  OnlyReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.intersection qs1 qs2+  OnlyReduceDefs qs1 <> DontReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs1 qs2+  DontReduceDefs qs1 <> OnlyReduceDefs qs2 = OnlyReduceDefs $ Set.difference   qs2 qs1+  DontReduceDefs qs1 <> DontReduceDefs qs2 = DontReduceDefs $ Set.union        qs1 qs2++instance Monoid ReduceDefs where+  mempty  = reduceAllDefs+  mappend = (<>)+++locallyReconstructed :: MonadTCEnv m => m a -> m a+locallyReconstructed = locallyTC eReconstructed . const $ True++isReconstructed :: (MonadTCEnv m) => m Bool+isReconstructed = asksTC envReconstructed++-- | Primitives++data PrimitiveImpl = PrimImpl Type PrimFun++data PrimFun = PrimFun+  { primFunName           :: QName+  , primFunArity          :: Arity+  , primFunImplementation :: [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)+  }+  deriving Generic++primFun :: QName -> Arity -> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun+primFun q ar imp = PrimFun q ar (\ args _ -> imp args)++defClauses :: Definition -> [Clause]+defClauses Defn{theDef = Function{funClauses = cs}}        = cs+defClauses Defn{theDef = Primitive{primClauses = cs}}      = cs+defClauses Defn{theDef = Datatype{dataClause = Just c}}    = [c]+defClauses Defn{theDef = Record{recClause = Just c}}       = [c]+defClauses _                                               = []++defCompiled :: Definition -> Maybe CompiledClauses+defCompiled Defn{theDef = Function {funCompiled  = mcc}} = mcc+defCompiled Defn{theDef = Primitive{primCompiled = mcc}} = mcc+defCompiled _ = Nothing++defParameters :: Definition -> Maybe Nat+defParameters Defn{theDef = Datatype{dataPars = n}} = Just n+defParameters Defn{theDef = Record  {recPars  = n}} = Just n+defParameters _                                     = Nothing++defInverse :: Definition -> FunctionInverse+defInverse Defn{theDef = Function { funInv  = inv }} = inv+defInverse Defn{theDef = Primitive{ primInv = inv }} = inv+defInverse _                                         = NotInjective++defCompilerPragmas :: BackendName -> Definition -> [CompilerPragma]+defCompilerPragmas b = reverse . fromMaybe [] . Map.lookup b . defCompiledRep+  -- reversed because we add new pragmas to the front of the list++-- | Are the clauses of this definition delayed?+defDelayed :: Definition -> Delayed+defDelayed Defn{theDef = Function{funDelayed = d}} = d+defDelayed _                                       = NotDelayed++-- | Has the definition failed the termination checker?+defNonterminating :: Definition -> Bool+defNonterminating Defn{theDef = Function{funTerminates = Just False}} = True+defNonterminating _                                                   = False++-- | Has the definition not termination checked or did the check fail?+defTerminationUnconfirmed :: Definition -> Bool+defTerminationUnconfirmed Defn{theDef = Function{funTerminates = Just True}} = False+defTerminationUnconfirmed Defn{theDef = Function{funTerminates = _        }} = True+defTerminationUnconfirmed _ = False++defAbstract :: Definition -> IsAbstract+defAbstract d = case theDef d of+    Axiom{}                   -> ConcreteDef+    DataOrRecSig{}            -> ConcreteDef+    GeneralizableVar{}        -> ConcreteDef+    AbstractDefn{}            -> AbstractDef+    Function{funAbstr = a}    -> a+    Datatype{dataAbstr = a}   -> a+    Record{recAbstr = a}      -> a+    Constructor{conAbstr = a} -> a+    Primitive{primAbstr = a}  -> a+    PrimitiveSort{}           -> ConcreteDef++defForced :: Definition -> [IsForced]+defForced d = case theDef d of+    Constructor{conForced = fs} -> fs+    Axiom{}                     -> []+    DataOrRecSig{}              -> []+    GeneralizableVar{}          -> []+    AbstractDefn{}              -> []+    Function{}                  -> []+    Datatype{}                  -> []+    Record{}                    -> []+    Primitive{}                 -> []+    PrimitiveSort{}             -> []++---------------------------------------------------------------------------+-- ** Injectivity+---------------------------------------------------------------------------++type FunctionInverse = FunctionInverse' Clause+type InversionMap c = Map TermHead [c]++data FunctionInverse' c+  = NotInjective+  | Inverse (InversionMap c)+  deriving (Show, Functor, Generic)++data TermHead = SortHead+              | PiHead+              | ConsHead QName+              | VarHead Nat+              | UnknownHead+  deriving (Eq, Ord, Show, Generic)++instance Pretty TermHead where+  pretty = \ case+    SortHead    -> "SortHead"+    PiHead      -> "PiHead"+    ConsHead q  -> "ConsHead" <+> pretty q+    VarHead i   -> text ("VarHead " ++ show i)+    UnknownHead -> "UnknownHead"++---------------------------------------------------------------------------+-- ** Mutual blocks+---------------------------------------------------------------------------++newtype MutualId = MutId Int32+  deriving (Eq, Ord, Show, Num, Enum, NFData)++---------------------------------------------------------------------------+-- ** Statistics+---------------------------------------------------------------------------++type Statistics = Map String Integer++---------------------------------------------------------------------------+-- ** Trace+---------------------------------------------------------------------------++data Call+  = CheckClause Type A.SpineClause+  | CheckLHS A.SpineLHS+  | CheckPattern A.Pattern Telescope Type+  | CheckPatternLinearityType C.Name+  | CheckPatternLinearityValue C.Name+  | CheckLetBinding A.LetBinding+  | InferExpr A.Expr+  | CheckExprCall Comparison A.Expr Type+  | CheckDotPattern A.Expr Term+  | CheckProjection Range QName Type+  | IsTypeCall Comparison A.Expr Sort+  | IsType_ A.Expr+  | InferVar Name+  | InferDef QName+  | CheckArguments Range [NamedArg A.Expr] Type (Maybe Type)+  | CheckMetaSolution Range MetaId Type Term+  | CheckTargetType Range Type Type+  | CheckDataDef Range QName [A.LamBinding] [A.Constructor]+  | CheckRecDef Range QName [A.LamBinding] [A.Constructor]+  | CheckConstructor QName Telescope Sort A.Constructor+  | CheckConstructorFitsIn QName Type Sort+  | CheckFunDefCall Range QName [A.Clause] Bool+    -- ^ Highlight (interactively) if and only if the boolean is 'True'.+  | CheckPragma Range A.Pragma+  | CheckPrimitive Range QName A.Expr+  | CheckIsEmpty Range Type+  | CheckConfluence QName QName+  | CheckWithFunctionType Type+  | CheckSectionApplication Range ModuleName A.ModuleApplication+  | CheckNamedWhere ModuleName+  -- | Checking a clause for confluence with endpoint reductions. Always+  -- @φ ⊢ f vs = rhs@ for now, but we store the simplifications of+    -- @f vs[φ]@ and @rhs[φ]@.+  | CheckIApplyConfluence+      Range  -- ^ Clause range+      QName  -- ^ Function name+      Term   -- ^ (As-is) Function applied to the patterns in this clause+      Term   -- ^ (Simplified) Function applied to the patterns in this clause+      Term   -- ^ (Simplified) clause RHS+      Type   -- ^ (Simplified) clause type+  | ScopeCheckExpr C.Expr+  | ScopeCheckDeclaration NiceDeclaration+  | ScopeCheckLHS C.QName C.Pattern+  | NoHighlighting+  | ModuleContents  -- ^ Interaction command: show module contents.+  | SetRange Range  -- ^ used by 'setCurrentRange'+  deriving Generic++instance Pretty Call where+    pretty CheckClause{}             = "CheckClause"+    pretty CheckLHS{}                = "CheckLHS"+    pretty CheckPattern{}            = "CheckPattern"+    pretty CheckPatternLinearityType{}  = "CheckPatternLinearityType"+    pretty CheckPatternLinearityValue{} = "CheckPatternLinearityValue"+    pretty InferExpr{}               = "InferExpr"+    pretty CheckExprCall{}           = "CheckExprCall"+    pretty CheckLetBinding{}         = "CheckLetBinding"+    pretty CheckProjection{}         = "CheckProjection"+    pretty IsTypeCall{}              = "IsTypeCall"+    pretty IsType_{}                 = "IsType_"+    pretty InferVar{}                = "InferVar"+    pretty InferDef{}                = "InferDef"+    pretty CheckArguments{}          = "CheckArguments"+    pretty CheckMetaSolution{}       = "CheckMetaSolution"+    pretty CheckTargetType{}         = "CheckTargetType"+    pretty CheckDataDef{}            = "CheckDataDef"+    pretty CheckRecDef{}             = "CheckRecDef"+    pretty CheckConstructor{}        = "CheckConstructor"+    pretty CheckConstructorFitsIn{}  = "CheckConstructorFitsIn"+    pretty CheckFunDefCall{}         = "CheckFunDefCall"+    pretty CheckPragma{}             = "CheckPragma"+    pretty CheckPrimitive{}          = "CheckPrimitive"+    pretty CheckWithFunctionType{}   = "CheckWithFunctionType"+    pretty CheckNamedWhere{}         = "CheckNamedWhere"+    pretty ScopeCheckExpr{}          = "ScopeCheckExpr"+    pretty ScopeCheckDeclaration{}   = "ScopeCheckDeclaration"+    pretty ScopeCheckLHS{}           = "ScopeCheckLHS"+    pretty CheckDotPattern{}         = "CheckDotPattern"+    pretty SetRange{}                = "SetRange"+    pretty CheckSectionApplication{} = "CheckSectionApplication"+    pretty CheckIsEmpty{}            = "CheckIsEmpty"+    pretty CheckConfluence{}         = "CheckConfluence"+    pretty NoHighlighting{}          = "NoHighlighting"+    pretty ModuleContents{}          = "ModuleContents"+    pretty CheckIApplyConfluence{}   = "ModuleContents"++instance HasRange Call where+    getRange (CheckClause _ c)                   = getRange c+    getRange (CheckLHS lhs)                      = getRange lhs+    getRange (CheckPattern p _ _)                = getRange p+    getRange (CheckPatternLinearityType x)       = getRange x+    getRange (CheckPatternLinearityValue x)      = getRange x+    getRange (InferExpr e)                       = getRange e+    getRange (CheckExprCall _ e _)               = getRange e+    getRange (CheckLetBinding b)                 = getRange b+    getRange (CheckProjection r _ _)             = r+    getRange (IsTypeCall cmp e s)                = getRange e+    getRange (IsType_ e)                         = getRange e+    getRange (InferVar x)                        = getRange x+    getRange (InferDef f)                        = getRange f+    getRange (CheckArguments r _ _ _)            = r+    getRange (CheckMetaSolution r _ _ _)         = r+    getRange (CheckTargetType r _ _)             = r+    getRange (CheckDataDef i _ _ _)              = getRange i+    getRange (CheckRecDef i _ _ _)               = getRange i+    getRange (CheckConstructor _ _ _ c)          = getRange c+    getRange (CheckConstructorFitsIn c _ _)      = getRange c+    getRange (CheckFunDefCall i _ _ _)           = getRange i+    getRange (CheckPragma r _)                   = r+    getRange (CheckPrimitive i _ _)              = getRange i+    getRange CheckWithFunctionType{}             = noRange+    getRange (CheckNamedWhere m)                 = getRange m+    getRange (ScopeCheckExpr e)                  = getRange e+    getRange (ScopeCheckDeclaration d)           = getRange d+    getRange (ScopeCheckLHS _ p)                 = getRange p+    getRange (CheckDotPattern e _)               = getRange e+    getRange (SetRange r)                        = r+    getRange (CheckSectionApplication r _ _)     = r+    getRange (CheckIsEmpty r _)                  = r+    getRange (CheckConfluence rule1 rule2)       = max (getRange rule1) (getRange rule2)+    getRange NoHighlighting                      = noRange+    getRange ModuleContents                      = noRange+    getRange (CheckIApplyConfluence e _ _ _ _ _) = getRange e++---------------------------------------------------------------------------+-- ** Instance table+---------------------------------------------------------------------------++-- | The instance table is a @Map@ associating to every name of+--   record/data type/postulate its list of instances+type InstanceTable = Map QName (Set QName)++-- | When typechecking something of the following form:+--+--     instance+--       x : _+--       x = y+--+--   it's not yet known where to add @x@, so we add it to a list of+--   unresolved instances and we'll deal with it later.+type TempInstanceTable = (InstanceTable , Set QName)++---------------------------------------------------------------------------+-- ** Builtin things+---------------------------------------------------------------------------++data BuiltinDescriptor+  = BuiltinData (TCM Type) [String]+  | BuiltinDataCons (TCM Type)+  | BuiltinPrim String (Term -> TCM ())+  | BuiltinSort String+  | BuiltinPostulate Relevance (TCM Type)+  | BuiltinUnknown (Maybe (TCM Type)) (Term -> Type -> TCM ())+    -- ^ Builtin of any kind.+    --   Type can be checked (@Just t@) or inferred (@Nothing@).+    --   The second argument is the hook for the verification function.++data BuiltinInfo =+   BuiltinInfo { builtinName :: String+               , builtinDesc :: BuiltinDescriptor }++type BuiltinThings pf = Map String (Builtin pf)++data Builtin pf+        = Builtin Term+        | Prim pf+        | BuiltinRewriteRelations (Set QName)+            -- ^ @BUILTIN REWRITE@.  We can have several rewrite relations.+    deriving (Show, Functor, Foldable, Traversable, Generic)++---------------------------------------------------------------------------+-- * Highlighting levels+---------------------------------------------------------------------------++-- | How much highlighting should be sent to the user interface?++data HighlightingLevel+  = None+  | NonInteractive+  | Interactive+    -- ^ This includes both non-interactive highlighting and+    -- interactive highlighting of the expression that is currently+    -- being type-checked.+    deriving (Eq, Ord, Show, Read, Generic)++-- | How should highlighting be sent to the user interface?++data HighlightingMethod+  = Direct+    -- ^ Via stdout.+  | Indirect+    -- ^ Both via files and via stdout.+    deriving (Eq, Show, Read, Generic)++-- | @ifTopLevelAndHighlightingLevelIs l b m@ runs @m@ when we're+-- type-checking the top-level module (or before we've started doing+-- this) and either the highlighting level is /at least/ @l@ or @b@ is+-- 'True'.++ifTopLevelAndHighlightingLevelIsOr ::+  MonadTCEnv tcm => HighlightingLevel -> Bool -> tcm () -> tcm ()+ifTopLevelAndHighlightingLevelIsOr l b m = do+  e <- askTC+  when (envHighlightingLevel e >= l || b) $+    case (envImportPath e) of+      -- Below the main module.+      (_:_:_) -> pure ()+      -- In or before the top-level module.+      _ -> m++-- | @ifTopLevelAndHighlightingLevelIs l m@ runs @m@ when we're+-- type-checking the top-level module (or before we've started doing+-- this) and the highlighting level is /at least/ @l@.++ifTopLevelAndHighlightingLevelIs ::+  MonadTCEnv tcm => HighlightingLevel -> tcm () -> tcm ()+ifTopLevelAndHighlightingLevelIs l =+  ifTopLevelAndHighlightingLevelIsOr l False++---------------------------------------------------------------------------+-- * Type checking environment+---------------------------------------------------------------------------++data TCEnv =+    TCEnv { envContext             :: Context+          , envLetBindings         :: LetBindings+          , envCurrentModule       :: ModuleName+          , envCurrentPath         :: Maybe AbsolutePath+            -- ^ The path to the file that is currently being+            -- type-checked.  'Nothing' if we do not have a file+            -- (like in interactive mode see @CommandLine@).+          , envAnonymousModules    :: [(ModuleName, Nat)] -- ^ anonymous modules and their number of free variables+          , envImportPath          :: [TopLevelModuleName]+            -- ^ The module stack with the entry being the top-level module as+            --   Agda chases modules. It will be empty if there is no main+            --   module, will have a single entry for the top level module, or+            --   more when descending past the main module. This is used to+            --   detect import cycles and in some cases highlighting behavior.+            --   The level of a given module is not necessarily the same as the+            --   length, in the module dependency graph, of the shortest path+            --   from the top-level module; it depends on in which order Agda+            --   chooses to chase dependencies.+          , envMutualBlock         :: Maybe MutualId -- ^ the current (if any) mutual block+          , envTerminationCheck    :: TerminationCheck ()  -- ^ are we inside the scope of a termination pragma+          , envCoverageCheck       :: CoverageCheck        -- ^ are we inside the scope of a coverage pragma+          , envMakeCase            :: Bool                 -- ^ are we inside a make-case (if so, ignore forcing analysis in unifier)+          , envSolvingConstraints  :: Bool+                -- ^ Are we currently in the process of solving active constraints?+          , envCheckingWhere       :: Bool+                -- ^ Have we stepped into the where-declarations of a clause?+                --   Everything under a @where@ will be checked with this flag on.+          , envWorkingOnTypes      :: Bool+                -- ^ Are we working on types? Turned on by 'workOnTypes'.+          , envAssignMetas         :: Bool+            -- ^ Are we allowed to assign metas?+          , envActiveProblems      :: Set ProblemId+          , envAbstractMode        :: AbstractMode+                -- ^ When checking the typesignature of a public definition+                --   or the body of a non-abstract definition this is true.+                --   To prevent information about abstract things leaking+                --   outside the module.+          , envModality            :: Modality+                -- ^ 'Relevance' component:+                -- Are we checking an irrelevant argument? (=@Irrelevant@)+                -- Then top-level irrelevant declarations are enabled.+                -- Other value: @Relevant@, then only relevant decls. are available.+                --+                -- 'Quantity' component:+                -- Are we checking a runtime-irrelevant thing? (='Quantity0')+                -- Then runtime-irrelevant things are usable.+                -- Other value: @Quantity1@, runtime relevant.+                -- @Quantityω@ is not allowed here, see Bob Atkey, LiCS 2018.+          , envSplitOnStrict       :: Bool+                -- ^ Are we currently case-splitting on a strict+                --   datatype (i.e. in SSet)? If yes, the+                --   pattern-matching unifier will solve reflexive+                --   equations even --without-K.+          , envDisplayFormsEnabled :: Bool+                -- ^ Sometimes we want to disable display forms.+          , envRange :: Range+          , envHighlightingRange :: Range+                -- ^ Interactive highlighting uses this range rather+                --   than 'envRange'.+          , envClause :: IPClause+                -- ^ What is the current clause we are type-checking?+                --   Will be recorded in interaction points in this clause.+          , envCall  :: Maybe (Closure Call)+                -- ^ what we're doing at the moment+          , envHighlightingLevel  :: HighlightingLevel+                -- ^ Set to 'None' when imported modules are+                --   type-checked.+          , envHighlightingMethod :: HighlightingMethod+          , envExpandLast :: ExpandHidden+                -- ^ When type-checking an alias f=e, we do not want+                -- to insert hidden arguments in the end, because+                -- these will become unsolved metas.+          , envAppDef :: Maybe QName+                -- ^ We are reducing an application of this function.+                -- (For tracking of incomplete matches.)+          , envSimplification :: Simplification+                -- ^ Did we encounter a simplification (proper match)+                --   during the current reduction process?+          , envAllowedReductions :: AllowedReductions+          , envReduceDefs :: ReduceDefs+          , envReconstructed :: Bool+          , envInjectivityDepth :: Int+                -- ^ Injectivity can cause non-termination for unsolvable contraints+                --   (#431, #3067). Keep a limit on the nesting depth of injectivity+                --   uses.+          , envCompareBlocked :: Bool+                -- ^ When @True@, the conversion checker will consider+                --   all term constructors as injective, including+                --   blocked function applications and metas. Warning:+                --   this should only be used when not assigning any+                --   metas (e.g. when @envAssignMetas@ is @False@ or+                --   when running @pureEqualTerms@) or else we get+                --   non-unique meta solutions.+          , envPrintDomainFreePi :: Bool+                -- ^ When @True@, types will be omitted from printed pi types if they+                --   can be inferred.+          , envPrintMetasBare :: Bool+                -- ^ When @True@, throw away meta numbers and meta elims.+                --   This is used for reifying terms for feeding into the+                --   user's source code, e.g., for the interaction tactics @solveAll@.+          , envInsideDotPattern :: Bool+                -- ^ Used by the scope checker to make sure that certain forms+                --   of expressions are not used inside dot patterns: extended+                --   lambdas and let-expressions.+          , envUnquoteFlags :: UnquoteFlags+          , envInstanceDepth :: !Int+                -- ^ Until we get a termination checker for instance search (#1743) we+                --   limit the search depth to ensure termination.+          , envIsDebugPrinting :: Bool+          , envPrintingPatternLambdas :: [QName]+                -- ^ #3004: pattern lambdas with copatterns may refer to themselves. We+                --   don't have a good story for what to do in this case, but at least+                --   printing shouldn't loop. Here we keep track of which pattern lambdas+                --   we are currently in the process of printing.+          , envCallByNeed :: Bool+                -- ^ Use call-by-need evaluation for reductions.+          , envCurrentCheckpoint :: CheckpointId+                -- ^ Checkpoints track the evolution of the context as we go+                -- under binders or refine it by pattern matching.+          , envCheckpoints :: Map CheckpointId Substitution+                -- ^ Keeps the substitution from each previous checkpoint to+                --   the current context.+          , envGeneralizeMetas :: DoGeneralize+                -- ^ Should new metas generalized over.+          , envGeneralizedVars :: Map QName GeneralizedValue+                -- ^ Values for used generalizable variables.+          , envActiveBackendName :: Maybe BackendName+                -- ^ Is some backend active at the moment, and if yes, which?+                --   NB: we only store the 'BackendName' here, otherwise+                --   @instance Data TCEnv@ is not derivable.+                --   The actual backend can be obtained from the name via 'stBackends'.+          , envConflComputingOverlap :: Bool+                -- ^ Are we currently computing the overlap between+                --   two rewrite rules for the purpose of confluence checking?+          , envCurrentlyElaborating :: Bool+                -- ^ Are we currently in the process of executing an+                --   elaborate-and-give interactive command?+          , envSyntacticEqualityFuel :: !(Strict.Maybe Int)+                -- ^ If this counter is 'Strict.Nothing', then+                -- syntactic equality checking is unrestricted. If it+                -- is zero, then syntactic equality checking is not+                -- run at all. If it is a positive number, then+                -- syntactic equality checking is allowed to run, but+                -- the counter is decreased in the failure+                -- continuation of+                -- 'Agda.TypeChecking.SyntacticEquality.checkSyntacticEquality'.+          }+    deriving (Generic)++initEnv :: TCEnv+initEnv = TCEnv { envContext             = []+                , envLetBindings         = Map.empty+                , envCurrentModule       = noModuleName+                , envCurrentPath         = Nothing+                , envAnonymousModules    = []+                , envImportPath          = []+                , envMutualBlock         = Nothing+                , envTerminationCheck    = TerminationCheck+                , envCoverageCheck       = YesCoverageCheck+                , envMakeCase            = False+                , envSolvingConstraints  = False+                , envCheckingWhere       = False+                , envActiveProblems      = Set.empty+                , envWorkingOnTypes      = False+                , envAssignMetas         = True+                , envAbstractMode        = ConcreteMode+  -- Andreas, 2013-02-21:  This was 'AbstractMode' until now.+  -- However, top-level checks for mutual blocks, such as+  -- constructor-headedness, should not be able to look into+  -- abstract definitions unless abstract themselves.+  -- (See also discussion on issue 796.)+  -- The initial mode should be 'ConcreteMode', ensuring you+  -- can only look into abstract things in an abstract+  -- definition (which sets 'AbstractMode').+                , envModality               = unitModality+                , envSplitOnStrict          = False+                , envDisplayFormsEnabled    = True+                , envRange                  = noRange+                , envHighlightingRange      = noRange+                , envClause                 = IPNoClause+                , envCall                   = Nothing+                , envHighlightingLevel      = None+                , envHighlightingMethod     = Indirect+                , envExpandLast             = ExpandLast+                , envAppDef                 = Nothing+                , envSimplification         = NoSimplification+                , envAllowedReductions      = allReductions+                , envReduceDefs             = reduceAllDefs+                , envReconstructed          = False+                , envInjectivityDepth       = 0+                , envCompareBlocked         = False+                , envPrintDomainFreePi      = False+                , envPrintMetasBare         = False+                , envInsideDotPattern       = False+                , envUnquoteFlags           = defaultUnquoteFlags+                , envInstanceDepth          = 0+                , envIsDebugPrinting        = False+                , envPrintingPatternLambdas = []+                , envCallByNeed             = True+                , envCurrentCheckpoint      = 0+                , envCheckpoints            = Map.singleton 0 IdS+                , envGeneralizeMetas        = NoGeneralize+                , envGeneralizedVars        = Map.empty+                , envActiveBackendName      = Nothing+                , envConflComputingOverlap  = False+                , envCurrentlyElaborating   = False+                , envSyntacticEqualityFuel  = Strict.Nothing+                }++class LensTCEnv a where+  lensTCEnv :: Lens' TCEnv a++instance LensTCEnv TCEnv where+  lensTCEnv = id++instance LensModality TCEnv where+  -- Cohesion shouldn't have an environment component.+  getModality = setCohesion defaultCohesion . envModality+  mapModality f e = e { envModality = setCohesion defaultCohesion $ f $ envModality e }++instance LensRelevance TCEnv where+instance LensQuantity  TCEnv where++data UnquoteFlags = UnquoteFlags+  { _unquoteNormalise :: Bool }+  deriving Generic++defaultUnquoteFlags :: UnquoteFlags+defaultUnquoteFlags = UnquoteFlags+  { _unquoteNormalise = False }++unquoteNormalise :: Lens' Bool UnquoteFlags+unquoteNormalise f e = f (_unquoteNormalise e) <&> \ x -> e { _unquoteNormalise = x }++eUnquoteNormalise :: Lens' Bool TCEnv+eUnquoteNormalise = eUnquoteFlags . unquoteNormalise++-- * e-prefixed lenses+------------------------------------------------------------------------++eContext :: Lens' Context TCEnv+eContext f e = f (envContext e) <&> \ x -> e { envContext = x }++eLetBindings :: Lens' LetBindings TCEnv+eLetBindings f e = f (envLetBindings e) <&> \ x -> e { envLetBindings = x }++eCurrentModule :: Lens' ModuleName TCEnv+eCurrentModule f e = f (envCurrentModule e) <&> \ x -> e { envCurrentModule = x }++eCurrentPath :: Lens' (Maybe AbsolutePath) TCEnv+eCurrentPath f e = f (envCurrentPath e) <&> \ x -> e { envCurrentPath = x }++eAnonymousModules :: Lens' [(ModuleName, Nat)] TCEnv+eAnonymousModules f e = f (envAnonymousModules e) <&> \ x -> e { envAnonymousModules = x }++eImportPath :: Lens' [TopLevelModuleName] TCEnv+eImportPath f e = f (envImportPath e) <&> \ x -> e { envImportPath = x }++eMutualBlock :: Lens' (Maybe MutualId) TCEnv+eMutualBlock f e = f (envMutualBlock e) <&> \ x -> e { envMutualBlock = x }++eTerminationCheck :: Lens' (TerminationCheck ()) TCEnv+eTerminationCheck f e = f (envTerminationCheck e) <&> \ x -> e { envTerminationCheck = x }++eCoverageCheck :: Lens' CoverageCheck TCEnv+eCoverageCheck f e = f (envCoverageCheck e) <&> \ x -> e { envCoverageCheck = x }++eMakeCase :: Lens' Bool TCEnv+eMakeCase f e = f (envMakeCase e) <&> \ x -> e { envMakeCase = x }++eSolvingConstraints :: Lens' Bool TCEnv+eSolvingConstraints f e = f (envSolvingConstraints e) <&> \ x -> e { envSolvingConstraints = x }++eCheckingWhere :: Lens' Bool TCEnv+eCheckingWhere f e = f (envCheckingWhere e) <&> \ x -> e { envCheckingWhere = x }++eWorkingOnTypes :: Lens' Bool TCEnv+eWorkingOnTypes f e = f (envWorkingOnTypes e) <&> \ x -> e { envWorkingOnTypes = x }++eAssignMetas :: Lens' Bool TCEnv+eAssignMetas f e = f (envAssignMetas e) <&> \ x -> e { envAssignMetas = x }++eActiveProblems :: Lens' (Set ProblemId) TCEnv+eActiveProblems f e = f (envActiveProblems e) <&> \ x -> e { envActiveProblems = x }++eAbstractMode :: Lens' AbstractMode TCEnv+eAbstractMode f e = f (envAbstractMode e) <&> \ x -> e { envAbstractMode = x }++-- Andrea 23/02/2020: use get/setModality to enforce invariants of the+--                    envModality field.+eModality :: Lens' Modality TCEnv+eModality f e = f (getModality e) <&> \ x -> setModality x e++eRelevance :: Lens' Relevance TCEnv+eRelevance = eModality . lModRelevance++eQuantity :: Lens' Quantity TCEnv+eQuantity = eModality . lModQuantity++eSplitOnStrict :: Lens' Bool TCEnv+eSplitOnStrict f e = f (envSplitOnStrict e) <&> \ x -> e { envSplitOnStrict = x }++eDisplayFormsEnabled :: Lens' Bool TCEnv+eDisplayFormsEnabled f e = f (envDisplayFormsEnabled e) <&> \ x -> e { envDisplayFormsEnabled = x }++eRange :: Lens' Range TCEnv+eRange f e = f (envRange e) <&> \ x -> e { envRange = x }++eHighlightingRange :: Lens' Range TCEnv+eHighlightingRange f e = f (envHighlightingRange e) <&> \ x -> e { envHighlightingRange = x }++eCall :: Lens' (Maybe (Closure Call)) TCEnv+eCall f e = f (envCall e) <&> \ x -> e { envCall = x }++eHighlightingLevel :: Lens' HighlightingLevel TCEnv+eHighlightingLevel f e = f (envHighlightingLevel e) <&> \ x -> e { envHighlightingLevel = x }++eHighlightingMethod :: Lens' HighlightingMethod TCEnv+eHighlightingMethod f e = f (envHighlightingMethod e) <&> \ x -> e { envHighlightingMethod = x }++eExpandLast :: Lens' ExpandHidden TCEnv+eExpandLast f e = f (envExpandLast e) <&> \ x -> e { envExpandLast = x }++eAppDef :: Lens' (Maybe QName) TCEnv+eAppDef f e = f (envAppDef e) <&> \ x -> e { envAppDef = x }++eSimplification :: Lens' Simplification TCEnv+eSimplification f e = f (envSimplification e) <&> \ x -> e { envSimplification = x }++eAllowedReductions :: Lens' AllowedReductions TCEnv+eAllowedReductions f e = f (envAllowedReductions e) <&> \ x -> e { envAllowedReductions = x }++eReduceDefs :: Lens' ReduceDefs TCEnv+eReduceDefs f e = f (envReduceDefs e) <&> \ x -> e { envReduceDefs = x }++eReconstructed :: Lens' Bool TCEnv+eReconstructed f e = f (envReconstructed e) <&> \ x -> e { envReconstructed = x }++eInjectivityDepth :: Lens' Int TCEnv+eInjectivityDepth f e = f (envInjectivityDepth e) <&> \ x -> e { envInjectivityDepth = x }++eCompareBlocked :: Lens' Bool TCEnv+eCompareBlocked f e = f (envCompareBlocked e) <&> \ x -> e { envCompareBlocked = x }++ePrintDomainFreePi :: Lens' Bool TCEnv+ePrintDomainFreePi f e = f (envPrintDomainFreePi e) <&> \ x -> e { envPrintDomainFreePi = x }++ePrintMetasBare :: Lens' Bool TCEnv+ePrintMetasBare f e = f (envPrintMetasBare e) <&> \ x -> e { envPrintMetasBare = x }++eInsideDotPattern :: Lens' Bool TCEnv+eInsideDotPattern f e = f (envInsideDotPattern e) <&> \ x -> e { envInsideDotPattern = x }++eUnquoteFlags :: Lens' UnquoteFlags TCEnv+eUnquoteFlags f e = f (envUnquoteFlags e) <&> \ x -> e { envUnquoteFlags = x }++eInstanceDepth :: Lens' Int TCEnv+eInstanceDepth f e = f (envInstanceDepth e) <&> \ x -> e { envInstanceDepth = x }++eIsDebugPrinting :: Lens' Bool TCEnv+eIsDebugPrinting f e = f (envIsDebugPrinting e) <&> \ x -> e { envIsDebugPrinting = x }++ePrintingPatternLambdas :: Lens' [QName] TCEnv+ePrintingPatternLambdas f e = f (envPrintingPatternLambdas e) <&> \ x -> e { envPrintingPatternLambdas = x }++eCallByNeed :: Lens' Bool TCEnv+eCallByNeed f e = f (envCallByNeed e) <&> \ x -> e { envCallByNeed = x }++eCurrentCheckpoint :: Lens' CheckpointId TCEnv+eCurrentCheckpoint f e = f (envCurrentCheckpoint e) <&> \ x -> e { envCurrentCheckpoint = x }++eCheckpoints :: Lens' (Map CheckpointId Substitution) TCEnv+eCheckpoints f e = f (envCheckpoints e) <&> \ x -> e { envCheckpoints = x }++eGeneralizeMetas :: Lens' DoGeneralize TCEnv+eGeneralizeMetas f e = f (envGeneralizeMetas e) <&> \ x -> e { envGeneralizeMetas = x }++eGeneralizedVars :: Lens' (Map QName GeneralizedValue) TCEnv+eGeneralizedVars f e = f (envGeneralizedVars e) <&> \ x -> e { envGeneralizedVars = x }++eActiveBackendName :: Lens' (Maybe BackendName) TCEnv+eActiveBackendName f e = f (envActiveBackendName e) <&> \ x -> e { envActiveBackendName = x }++eConflComputingOverlap :: Lens' Bool TCEnv+eConflComputingOverlap f e = f (envConflComputingOverlap e) <&> \ x -> e { envConflComputingOverlap = x }++eCurrentlyElaborating :: Lens' Bool TCEnv+eCurrentlyElaborating f e = f (envCurrentlyElaborating e) <&> \ x -> e { envCurrentlyElaborating = x }++---------------------------------------------------------------------------+-- ** Context+---------------------------------------------------------------------------++-- | The @Context@ is a stack of 'ContextEntry's.+type Context      = [ContextEntry]+type ContextEntry = Dom (Name, Type)++---------------------------------------------------------------------------+-- ** Let bindings+---------------------------------------------------------------------------++type LetBindings = Map Name (Open (Term, Dom Type))++---------------------------------------------------------------------------+-- ** Abstract mode+---------------------------------------------------------------------------++data AbstractMode+  = AbstractMode        -- ^ Abstract things in the current module can be accessed.+  | ConcreteMode        -- ^ No abstract things can be accessed.+  | IgnoreAbstractMode  -- ^ All abstract things can be accessed.+  deriving (Show, Eq, Generic)++aDefToMode :: IsAbstract -> AbstractMode+aDefToMode AbstractDef = AbstractMode+aDefToMode ConcreteDef = ConcreteMode++aModeToDef :: AbstractMode -> Maybe IsAbstract+aModeToDef AbstractMode = Just AbstractDef+aModeToDef ConcreteMode = Just ConcreteDef+aModeToDef _ = Nothing++---------------------------------------------------------------------------+-- ** Insertion of implicit arguments+---------------------------------------------------------------------------++data ExpandHidden+  = ExpandLast      -- ^ Add implicit arguments in the end until type is no longer hidden 'Pi'.+  | DontExpandLast  -- ^ Do not append implicit arguments.+  | ReallyDontExpandLast -- ^ Makes 'doExpandLast' have no effect. Used to avoid implicit insertion of arguments to metavariables.+  deriving (Eq, Generic)++isDontExpandLast :: ExpandHidden -> Bool+isDontExpandLast ExpandLast           = False+isDontExpandLast DontExpandLast       = True+isDontExpandLast ReallyDontExpandLast = True++data CandidateKind+  = LocalCandidate+  | GlobalCandidate QName+  deriving (Show, Generic)++-- | A candidate solution for an instance meta is a term with its type.+--   It may be the case that the candidate is not fully applied yet or+--   of the wrong type, hence the need for the type.+data Candidate  = Candidate { candidateKind :: CandidateKind+                            , candidateTerm :: Term+                            , candidateType :: Type+                            , candidateOverlappable :: Bool+                            }+  deriving (Show, Generic)++instance Free Candidate where+  freeVars' (Candidate _ t u _) = freeVars' (t, u)+++---------------------------------------------------------------------------+-- ** Checking arguments+---------------------------------------------------------------------------++data ArgsCheckState a = ACState+       { acRanges :: [Maybe Range]+         -- ^ Ranges of checked arguments, where present.+         -- e.g. inserted implicits have no correponding abstract syntax.+       , acElims  :: Elims+         -- ^ Checked and inserted arguments so far.+       , acConstraints :: [Maybe (Abs Constraint)]+         -- ^ Constraints for the head so far,+         -- i.e. before applying the correponding elim.+       , acType   :: Type+         -- ^ Type for the rest of the application.+       , acData   :: a+       }+  deriving (Show)+++---------------------------------------------------------------------------+-- * Type checking warnings (aka non-fatal errors)+---------------------------------------------------------------------------++-- | A non-fatal error is an error which does not prevent us from+-- checking the document further and interacting with the user.++data Warning+  = NicifierIssue            DeclarationWarning+  | TerminationIssue         [TerminationError]+  | UnreachableClauses       QName [Range]+  -- ^ `UnreachableClauses f rs` means that the clauses in `f` whose ranges are rs+  --   are unreachable+  | CoverageIssue            QName [(Telescope, [NamedArg DeBruijnPattern])]+  -- ^ `CoverageIssue f pss` means that `pss` are not covered in `f`+  | CoverageNoExactSplit     QName [Clause]+  | NotStrictlyPositive      QName (Seq OccursWhere)+  | UnsolvedMetaVariables    [Range]  -- ^ Do not use directly with 'warning'+  | UnsolvedInteractionMetas [Range]  -- ^ Do not use directly with 'warning'+  | UnsolvedConstraints      Constraints+    -- ^ Do not use directly with 'warning'+  | CantGeneralizeOverSorts [MetaId]+  | AbsurdPatternRequiresNoRHS [NamedArg DeBruijnPattern]+  | OldBuiltin               String String+    -- ^ In `OldBuiltin old new`, the BUILTIN old has been replaced by new+  | EmptyRewritePragma+    -- ^ If the user wrote just @{-\# REWRITE \#-}@.+  | EmptyWhere+    -- ^ An empty @where@ block is dead code.+  | IllformedAsClause String+    -- ^ If the user wrote something other than an unqualified name+    --   in the @as@ clause of an @import@ statement.+    --   The 'String' gives optionally extra explanation.+  | ClashesViaRenaming NameOrModule [C.Name]+    -- ^ If a `renaming' import directive introduces a name or module name clash+    --   in the exported names of a module.+    --   (See issue #4154.)+  | UselessPatternDeclarationForRecord String+    -- ^ The 'pattern' declaration is useless in the presence+    --   of either @coinductive@ or @eta-equality@.+    --   Content of 'String' is "coinductive" or "eta", resp.+  | UselessPublic+    -- ^ If the user opens a module public before the module header.+    --   (See issue #2377.)+  | UselessHiding [C.ImportedName]+    -- ^ Names in `hiding` directive that don't hide anything+    --   imported by a `using` directive.+  | UselessInline            QName+  | WrongInstanceDeclaration+  | InstanceWithExplicitArg  QName+  -- ^ An instance was declared with an implicit argument, which means it+  --   will never actually be considered by instance search.+  | InstanceNoOutputTypeName Doc+  -- ^ The type of an instance argument doesn't end in a named or+  -- variable type, so it will never be considered by instance search.+  | InstanceArgWithExplicitArg Doc+  -- ^ As InstanceWithExplicitArg, but for local bindings rather than+  --   top-level instances.+  | InversionDepthReached    QName+  -- ^ The --inversion-max-depth was reached.+  | NoGuardednessFlag        QName+  -- ^ A coinductive record was declared but neither --guardedness nor+  --   --sized-types is enabled.++  -- Generic warnings for one-off things+  | GenericWarning           Doc+    -- ^ Harmless generic warning (not an error)+  | GenericNonFatalError     Doc+    -- ^ Generic error which doesn't abort proceedings (not a warning)+  | GenericUseless  Range    Doc+    -- ^ Generic warning when code is useless and thus ignored.+    --   'Range' is for dead code highlighting.++  -- Safe flag errors+  | SafeFlagPostulate C.Name+  | SafeFlagPragma [String]                -- ^ Unsafe OPTIONS.+  | SafeFlagNonTerminating+  | SafeFlagTerminating+  | SafeFlagWithoutKFlagPrimEraseEquality+  | WithoutKFlagPrimEraseEquality+  | SafeFlagNoPositivityCheck+  | SafeFlagPolarity+  | SafeFlagNoUniverseCheck+  | SafeFlagNoCoverageCheck+  | SafeFlagInjective+  | SafeFlagEta                            -- ^ ETA pragma is unsafe.+  | OptionWarning            OptionWarning+  | ParseWarning             ParseWarning+  | LibraryWarning           LibWarning+  | DeprecationWarning String String String+    -- ^ `DeprecationWarning old new version`:+    --   `old` is deprecated, use `new` instead. This will be an error in Agda `version`.+  | UserWarning Text+    -- ^ User-defined warning (e.g. to mention that a name is deprecated)+  | DuplicateUsing (List1 C.ImportedName)+    -- ^ Duplicate mentions of the same name in @using@ directive(s).+  | FixityInRenamingModule (List1 Range)+    -- ^ Fixity of modules cannot be changed via renaming (since modules have no fixity).+  | ModuleDoesntExport C.QName [C.Name] [C.Name] [C.ImportedName]+    -- ^ Some imported names are not actually exported by the source module.+    --   The second argument is the names that could be exported.+    --   The third  argument is the module names that could be exported.+  | InfectiveImport Doc+    -- ^ Importing a file using an infective option into one which doesn't+  | CoInfectiveImport Doc+    -- ^ Importing a file not using a coinfective option from one which does+  | RewriteNonConfluent Term Term Term Doc+    -- ^ Confluence checker found critical pair and equality checking+    --   resulted in a type error+  | RewriteMaybeNonConfluent Term Term [Doc]+    -- ^ Confluence checker got stuck on computing overlap between two+    --   rewrite rules+  | RewriteAmbiguousRules Term Term Term+    -- ^ The global confluence checker found a term @u@ that reduces+    --   to both @v1@ and @v2@ and there is no rule to resolve the+    --   ambiguity.+  | RewriteMissingRule Term Term Term+    -- ^ The global confluence checker found a term @u@ that reduces+    --   to @v@, but @v@ does not reduce to @rho(u)@.+  | PragmaCompileErased BackendName QName+    -- ^ COMPILE directive for an erased symbol+  | NotInScopeW [C.QName]+    -- ^ Out of scope error we can recover from+  | UnsupportedIndexedMatch Doc+    -- ^ Was not able to compute a full equivalence when splitting.+  | AsPatternShadowsConstructorOrPatternSynonym Bool+    -- ^ The as-name in an as-pattern may not shadow a constructor (@False@)+    --   or pattern synonym name (@True@),+    --   because this can be confusing to read.+  | RecordFieldWarning RecordFieldWarning+  deriving (Show, Generic)++data RecordFieldWarning+  = DuplicateFieldsWarning [(C.Name, Range)]+      -- ^ Each redundant field comes with a range of associated dead code.+  | TooManyFieldsWarning QName [C.Name] [(C.Name, Range)]+      -- ^ Record type, fields not supplied by user, non-fields but supplied.+      --   The redundant fields come with a range of associated dead code.+  deriving (Show, Generic)++recordFieldWarningToError :: RecordFieldWarning -> TypeError+recordFieldWarningToError = \case+  DuplicateFieldsWarning    xrs -> DuplicateFields    $ map fst xrs+  TooManyFieldsWarning q ys xrs -> TooManyFields q ys $ map fst xrs++warningName :: Warning -> WarningName+warningName = \case+  -- special cases+  NicifierIssue dw             -> declarationWarningName dw+  OptionWarning ow             -> optionWarningName ow+  ParseWarning pw              -> parseWarningName pw+  LibraryWarning lw            -> libraryWarningName lw+  AsPatternShadowsConstructorOrPatternSynonym{} -> AsPatternShadowsConstructorOrPatternSynonym_+  -- scope- and type-checking errors+  AbsurdPatternRequiresNoRHS{} -> AbsurdPatternRequiresNoRHS_+  CantGeneralizeOverSorts{}    -> CantGeneralizeOverSorts_+  CoverageIssue{}              -> CoverageIssue_+  CoverageNoExactSplit{}       -> CoverageNoExactSplit_+  DeprecationWarning{}         -> DeprecationWarning_+  EmptyRewritePragma           -> EmptyRewritePragma_+  EmptyWhere                   -> EmptyWhere_+  IllformedAsClause{}          -> IllformedAsClause_+  WrongInstanceDeclaration{}   -> WrongInstanceDeclaration_+  InstanceWithExplicitArg{}    -> InstanceWithExplicitArg_+  InstanceNoOutputTypeName{}   -> InstanceNoOutputTypeName_+  InstanceArgWithExplicitArg{} -> InstanceArgWithExplicitArg_+  DuplicateUsing{}             -> DuplicateUsing_+  FixityInRenamingModule{}     -> FixityInRenamingModule_+  GenericNonFatalError{}       -> GenericNonFatalError_+  GenericUseless{}             -> GenericUseless_+  GenericWarning{}             -> GenericWarning_+  InversionDepthReached{}      -> InversionDepthReached_+  ModuleDoesntExport{}         -> ModuleDoesntExport_+  NoGuardednessFlag{}          -> NoGuardednessFlag_+  NotInScopeW{}                -> NotInScope_+  NotStrictlyPositive{}        -> NotStrictlyPositive_+  UnsupportedIndexedMatch{}    -> UnsupportedIndexedMatch_+  OldBuiltin{}                 -> OldBuiltin_+  SafeFlagNoPositivityCheck    -> SafeFlagNoPositivityCheck_+  SafeFlagNonTerminating       -> SafeFlagNonTerminating_+  SafeFlagNoUniverseCheck      -> SafeFlagNoUniverseCheck_+  SafeFlagPolarity             -> SafeFlagPolarity_+  SafeFlagPostulate{}          -> SafeFlagPostulate_+  SafeFlagPragma{}             -> SafeFlagPragma_+  SafeFlagEta                  -> SafeFlagEta_+  SafeFlagInjective            -> SafeFlagInjective_+  SafeFlagNoCoverageCheck      -> SafeFlagNoCoverageCheck_+  SafeFlagWithoutKFlagPrimEraseEquality -> SafeFlagWithoutKFlagPrimEraseEquality_+  WithoutKFlagPrimEraseEquality -> WithoutKFlagPrimEraseEquality_+  SafeFlagTerminating          -> SafeFlagTerminating_+  TerminationIssue{}           -> TerminationIssue_+  UnreachableClauses{}         -> UnreachableClauses_+  UnsolvedInteractionMetas{}   -> UnsolvedInteractionMetas_+  UnsolvedConstraints{}        -> UnsolvedConstraints_+  UnsolvedMetaVariables{}      -> UnsolvedMetaVariables_+  UselessHiding{}              -> UselessHiding_+  UselessInline{}              -> UselessInline_+  UselessPublic{}              -> UselessPublic_+  UselessPatternDeclarationForRecord{} -> UselessPatternDeclarationForRecord_+  ClashesViaRenaming{}         -> ClashesViaRenaming_+  UserWarning{}                -> UserWarning_+  InfectiveImport{}            -> InfectiveImport_+  CoInfectiveImport{}          -> CoInfectiveImport_+  RewriteNonConfluent{}        -> RewriteNonConfluent_+  RewriteMaybeNonConfluent{}   -> RewriteMaybeNonConfluent_+  RewriteAmbiguousRules{}      -> RewriteAmbiguousRules_+  RewriteMissingRule{}         -> RewriteMissingRule_+  PragmaCompileErased{}        -> PragmaCompileErased_+  -- record field warnings+  RecordFieldWarning w -> case w of+    DuplicateFieldsWarning{}   -> DuplicateFieldsWarning_+    TooManyFieldsWarning{}     -> TooManyFieldsWarning_++data TCWarning+  = TCWarning+    { tcWarningLocation :: CallStack+        -- ^ Location in the internal Agda source code location where the error raised+    , tcWarningRange    :: Range+        -- ^ Range where the warning was raised+    , tcWarning         :: Warning+        -- ^ The warning itself+    , tcWarningPrintedWarning :: Doc+        -- ^ The warning printed in the state and environment where it was raised+    , tcWarningCached :: Bool+        -- ^ Should the warning be affected by caching.+    }+  deriving (Show, Generic)++tcWarningOrigin :: TCWarning -> SrcFile+tcWarningOrigin = rangeFile . tcWarningRange++instance HasRange TCWarning where+  getRange = tcWarningRange++-- used for merging lists of warnings+instance Eq TCWarning where+  (==) = (==) `on` tcWarningPrintedWarning++---------------------------------------------------------------------------+-- * Type checking errors+---------------------------------------------------------------------------++-- | Information about a call.++data CallInfo = CallInfo+  { callInfoTarget :: QName+    -- ^ Target function name.  (Contains its range.)+  , callInfoCall :: Closure Term+    -- ^ To be formatted representation of the call.+  } deriving (Show, Generic)+    -- no Eq, Ord instances: too expensive! (see issues 851, 852)++instance HasRange CallInfo where+  getRange = getRange . callInfoTarget++-- | We only 'show' the name of the callee.+instance Pretty CallInfo where pretty = pretty . callInfoTarget++-- | Information about a mutual block which did not pass the+-- termination checker.++data TerminationError = TerminationError+  { termErrFunctions :: [QName]+    -- ^ The functions which failed to check. (May not include+    -- automatically generated functions.)+  , termErrCalls :: [CallInfo]+    -- ^ The problematic call sites.+  } deriving (Show, Generic)++-- | Error when splitting a pattern variable into possible constructor patterns.+data SplitError+  = NotADatatype        (Closure Type)  -- ^ Neither data type nor record.+  | BlockedType Blocker (Closure Type)  -- ^ Type could not be sufficiently reduced.+  | ErasedDatatype Bool (Closure Type)  -- ^ Data type, but in erased position.+                                        --   If the boolean is 'True',+                                        --   then the reason for the+                                        --   error is that the K rule+                                        --   is turned off.+  | CoinductiveDatatype (Closure Type)  -- ^ Split on codata not allowed.+  -- UNUSED, but keep!+  -- -- | NoRecordConstructor Type  -- ^ record type, but no constructor+  | UnificationStuck+    { cantSplitBlocker  :: Maybe Blocker -- ^ Blocking metavariable (if any)+    , cantSplitConName  :: QName        -- ^ Constructor.+    , cantSplitTel      :: Telescope    -- ^ Context for indices.+    , cantSplitConIdx   :: Args         -- ^ Inferred indices (from type of constructor).+    , cantSplitGivenIdx :: Args         -- ^ Expected indices (from checking pattern).+    , cantSplitFailures :: [UnificationFailure] -- ^ Reason(s) why unification got stuck.+    }+  | CosplitCatchall+      -- ^ Copattern split with a catchall+  | CosplitNoTarget+      -- ^ We do not know the target type of the clause.+  | CosplitNoRecordType (Closure Type)+      -- ^ Target type is not a record type.+  | CannotCreateMissingClause QName (Telescope,[NamedArg DeBruijnPattern]) Doc (Closure (Abs Type))++  | GenericSplitError String+  deriving (Show, Generic)++data NegativeUnification+  = UnifyConflict Telescope Term Term+  | UnifyCycle Telescope Int Term+  deriving (Show, Generic)++data UnificationFailure+  = UnifyIndicesNotVars Telescope Type Term Term Args -- ^ Failed to apply injectivity to constructor of indexed datatype+  | UnifyRecursiveEq Telescope Type Int Term          -- ^ Can't solve equation because variable occurs in (type of) lhs+  | UnifyReflexiveEq Telescope Type Term              -- ^ Can't solve reflexive equation because --without-K is enabled+  | UnifyUnusableModality Telescope Type Int Term Modality  -- ^ Can't solve equation because solution modality is less "usable"+  deriving (Show, Generic)++data UnquoteError+  = BadVisibility String (Arg I.Term)+  | ConInsteadOfDef QName String String+  | DefInsteadOfCon QName String String+  | NonCanonical String I.Term+  | BlockedOnMeta TCState Blocker+  | UnquotePanic String+  deriving (Show, Generic)++data TypeError+        = InternalError String+        | NotImplemented String+        | NotSupported String+        | CompilationError String+        | PropMustBeSingleton+        | DataMustEndInSort Term+{- UNUSED+        | DataTooManyParameters+            -- ^ In @data D xs where@ the number of parameters @xs@ does not fit the+            --   the parameters given in the forward declaraion @data D Gamma : T@.+-}+        | ShouldEndInApplicationOfTheDatatype Type+            -- ^ The target of a constructor isn't an application of its+            -- datatype. The 'Type' records what it does target.+        | ShouldBeAppliedToTheDatatypeParameters Term Term+            -- ^ The target of a constructor isn't its datatype applied to+            --   something that isn't the parameters. First term is the correct+            --   target and the second term is the actual target.+        | ShouldBeApplicationOf Type QName+            -- ^ Expected a type to be an application of a particular datatype.+        | ConstructorPatternInWrongDatatype QName QName -- ^ constructor, datatype+        | CantResolveOverloadedConstructorsTargetingSameDatatype QName (List1 QName)+          -- ^ Datatype, constructors.+        | DoesNotConstructAnElementOf QName Type -- ^ constructor, type+        | WrongHidingInLHS+            -- ^ The left hand side of a function definition has a hidden argument+            --   where a non-hidden was expected.+        | WrongHidingInLambda Type+            -- ^ Expected a non-hidden function and found a hidden lambda.+        | WrongHidingInApplication Type+            -- ^ A function is applied to a hidden argument where a non-hidden was expected.+        | WrongNamedArgument (NamedArg A.Expr) [NamedName]+            -- ^ A function is applied to a hidden named argument it does not have.+            -- The list contains names of possible hidden arguments at this point.+        | WrongIrrelevanceInLambda+            -- ^ Wrong user-given relevance annotation in lambda.+        | WrongQuantityInLambda+            -- ^ Wrong user-given quantity annotation in lambda.+        | WrongCohesionInLambda+            -- ^ Wrong user-given cohesion annotation in lambda.+        | QuantityMismatch Quantity Quantity+            -- ^ The given quantity does not correspond to the expected quantity.+        | HidingMismatch Hiding Hiding+            -- ^ The given hiding does not correspond to the expected hiding.+        | RelevanceMismatch Relevance Relevance+            -- ^ The given relevance does not correspond to the expected relevane.+        | UninstantiatedDotPattern A.Expr+        | ForcedConstructorNotInstantiated A.Pattern+        | IllformedProjectionPattern A.Pattern+        | CannotEliminateWithPattern (Maybe Blocker) (NamedArg A.Pattern) Type+        | WrongNumberOfConstructorArguments QName Nat Nat+        | ShouldBeEmpty Type [DeBruijnPattern]+        | ShouldBeASort Type+            -- ^ The given type should have been a sort.+        | ShouldBePi Type+            -- ^ The given type should have been a pi.+        | ShouldBePath Type+        | ShouldBeRecordType Type+        | ShouldBeRecordPattern DeBruijnPattern+        | NotAProjectionPattern (NamedArg A.Pattern)+        | NotAProperTerm+        | InvalidTypeSort Sort+            -- ^ This sort is not a type expression.+        | InvalidType Term+            -- ^ This term is not a type expression.+        | FunctionTypeInSizeUniv Term+            -- ^ This term, a function type constructor, lives in+            --   @SizeUniv@, which is not allowed.+        | SplitOnIrrelevant (Dom Type)+        | SplitOnUnusableCohesion (Dom Type)+        -- UNUSED: -- | SplitOnErased (Dom Type)+        | SplitOnNonVariable Term Type+        | SplitOnNonEtaRecord QName+        | DefinitionIsIrrelevant QName+        | DefinitionIsErased QName+        | VariableIsIrrelevant Name+        | VariableIsErased Name+        | VariableIsOfUnusableCohesion Name Cohesion+        | UnequalLevel Comparison Level Level+        | UnequalTerms Comparison Term Term CompareAs+        | UnequalTypes Comparison Type Type+--      | UnequalTelescopes Comparison Telescope Telescope -- UNUSED+        | UnequalRelevance Comparison Term Term+            -- ^ The two function types have different relevance.+        | UnequalQuantity Comparison Term Term+            -- ^ The two function types have different relevance.+        | UnequalCohesion Comparison Term Term+            -- ^ The two function types have different cohesion.+        | UnequalFiniteness Comparison Term Term+            -- ^ One of the function types has a finite domain (i.e. is a @Partia@l@) and the other isonot.+        | UnequalHiding Term Term+            -- ^ The two function types have different hiding.+        | UnequalSorts Sort Sort+        | UnequalBecauseOfUniverseConflict Comparison Term Term+        | NotLeqSort Sort Sort+        | MetaCannotDependOn MetaId Nat+            -- ^ The arguments are the meta variable and the parameter that it wants to depend on.+        | MetaOccursInItself MetaId+        | MetaIrrelevantSolution MetaId Term+        | MetaErasedSolution MetaId Term+        | GenericError String+        | GenericDocError Doc+        | SortOfSplitVarError (Maybe Blocker) Doc+          -- ^ the meta is what we might be blocked on.+        | BuiltinMustBeConstructor String A.Expr+        | NoSuchBuiltinName String+        | DuplicateBuiltinBinding String Term Term+        | NoBindingForBuiltin String+        | NoSuchPrimitiveFunction String+        | DuplicatePrimitiveBinding String QName QName+        | WrongModalityForPrimitive String ArgInfo ArgInfo+        | ShadowedModule C.Name [A.ModuleName]+        | BuiltinInParameterisedModule String+        | IllegalLetInTelescope C.TypedBinding+        | IllegalPatternInTelescope C.Binder+        | NoRHSRequiresAbsurdPattern [NamedArg A.Pattern]+        | TooManyFields QName [C.Name] [C.Name]+          -- ^ Record type, fields not supplied by user, non-fields but supplied.+        | DuplicateFields [C.Name]+        | DuplicateConstructors [C.Name]+        | WithOnFreeVariable A.Expr Term+        | UnexpectedWithPatterns [A.Pattern]+        | WithClausePatternMismatch A.Pattern (NamedArg DeBruijnPattern)+        | FieldOutsideRecord+        | ModuleArityMismatch A.ModuleName Telescope [NamedArg A.Expr]+        | GeneralizeCyclicDependency+        | GeneralizeUnsolvedMeta+    -- Coverage errors+-- UNUSED:        | IncompletePatternMatching Term [Elim] -- can only happen if coverage checking is switched off+        | SplitError SplitError+        | ImpossibleConstructor QName NegativeUnification+    -- Positivity errors+        | TooManyPolarities QName Int+    -- Import errors+        | LocalVsImportedModuleClash ModuleName+        | SolvedButOpenHoles+          -- ^ Some interaction points (holes) have not been filled by user.+          --   There are not 'UnsolvedMetas' since unification solved them.+          --   This is an error, since interaction points are never filled+          --   without user interaction.+        | CyclicModuleDependency [TopLevelModuleName]+        | FileNotFound TopLevelModuleName [AbsolutePath]+        | OverlappingProjects AbsolutePath TopLevelModuleName TopLevelModuleName+        | AmbiguousTopLevelModuleName TopLevelModuleName [AbsolutePath]+        | ModuleNameUnexpected TopLevelModuleName TopLevelModuleName+          -- ^ Found module name, expected module name.+        | ModuleNameDoesntMatchFileName TopLevelModuleName [AbsolutePath]+        | ClashingFileNamesFor ModuleName [AbsolutePath]+        | ModuleDefinedInOtherFile TopLevelModuleName AbsolutePath AbsolutePath+          -- ^ Module name, file from which it was loaded, file which+          -- the include path says contains the module.+    -- Scope errors+        | BothWithAndRHS+        | AbstractConstructorNotInScope A.QName+        | NotInScope [C.QName]+        | NoSuchModule C.QName+        | AmbiguousName C.QName AmbiguousNameReason+        | AmbiguousModule C.QName (List1 A.ModuleName)+        | ClashingDefinition C.QName A.QName (Maybe NiceDeclaration)+        | ClashingModule A.ModuleName A.ModuleName+        | ClashingImport C.Name A.QName+        | ClashingModuleImport C.Name A.ModuleName+        | PatternShadowsConstructor C.Name A.QName+        | DuplicateImports C.QName [C.ImportedName]+        | InvalidPattern C.Pattern+        | RepeatedVariablesInPattern [C.Name]+        | GeneralizeNotSupportedHere A.QName+        | MultipleFixityDecls [(C.Name, [Fixity'])]+        | MultiplePolarityPragmas [C.Name]+    -- Concrete to Abstract errors+        | NotAModuleExpr C.Expr+            -- ^ The expr was used in the right hand side of an implicit module+            --   definition, but it wasn't of the form @m Delta@.+        | NotAnExpression C.Expr+        | NotAValidLetBinding NiceDeclaration+        | NotValidBeforeField NiceDeclaration+        | NothingAppliedToHiddenArg C.Expr+        | NothingAppliedToInstanceArg C.Expr+    -- Pattern synonym errors+        | BadArgumentsToPatternSynonym A.AmbiguousQName+        | TooFewArgumentsToPatternSynonym A.AmbiguousQName+        | CannotResolveAmbiguousPatternSynonym (List1 (A.QName, A.PatternSynDefn))+        | UnusedVariableInPatternSynonym+    -- Operator errors+        | NoParseForApplication (List2 C.Expr)+        | AmbiguousParseForApplication (List2 C.Expr) (List1 C.Expr)+        | NoParseForLHS LHSOrPatSyn [C.Pattern] C.Pattern+            -- ^ The list contains patterns that failed to be interpreted.+            --   If it is non-empty, the first entry could be printed as error hint.+        | AmbiguousParseForLHS LHSOrPatSyn C.Pattern [C.Pattern]+            -- ^ Pattern and its possible interpretations.+        | OperatorInformation [NotationSection] TypeError+{- UNUSED+        | NoParseForPatternSynonym C.Pattern+        | AmbiguousParseForPatternSynonym C.Pattern [C.Pattern]+-}+    -- Usage errors+    -- Instance search errors+        | InstanceNoCandidate Type [(Term, TCErr)]+    -- Reflection errors+        | UnquoteFailed UnquoteError+        | DeBruijnIndexOutOfScope Nat Telescope [Name]+    -- Language option errors+        | NeedOptionCopatterns+        | NeedOptionRewriting+        | NeedOptionProp+        | NeedOptionTwoLevel+    -- Failure associated to warnings+        | NonFatalErrors [TCWarning]+    -- Instance search errors+        | InstanceSearchDepthExhausted Term Type Int+        | TriedToCopyConstrainedPrim QName+          deriving (Show, Generic)++-- | Distinguish error message when parsing lhs or pattern synonym, resp.+data LHSOrPatSyn = IsLHS | IsPatSyn+  deriving (Eq, Show, Generic)++-- | Type-checking errors.++data TCErr+  = TypeError+    { tcErrLocation :: CallStack+       -- ^ Location in the internal Agda source code where the error was raised+    , tcErrState    :: TCState+        -- ^ The state in which the error was raised.+    , tcErrClosErr  :: Closure TypeError+        -- ^ The environment in which the error as raised plus the error.+    }+  | Exception Range Doc+  | IOException TCState Range E.IOException+    -- ^ The first argument is the state in which the error was+    -- raised.+  | PatternErr Blocker+      -- ^ The exception which is usually caught.+      --   Raised for pattern violations during unification ('assignV')+      --   but also in other situations where we want to backtrack.+      --   Contains an unblocker to control when the computation should+      --   be retried.++instance Show TCErr where+  show (TypeError _ _ e)   = prettyShow (envRange $ clEnv e) ++ ": " ++ show (clValue e)+  show (Exception r d)     = prettyShow r ++ ": " ++ render d+  show (IOException _ r e) = prettyShow r ++ ": " +++                             E.displayException e+  show PatternErr{}        = "Pattern violation (you shouldn't see this)"++instance HasRange TCErr where+  getRange (TypeError _ _ cl)  = envRange $ clEnv cl+  getRange (Exception r _)     = r+  getRange (IOException s r _) = r+  getRange PatternErr{}        = noRange++instance E.Exception TCErr++-----------------------------------------------------------------------------+-- * Accessing options+-----------------------------------------------------------------------------++instance MonadIO m => HasOptions (TCMT m) where+  pragmaOptions = useTC stPragmaOptions++  commandLineOptions = do+    p  <- useTC stPragmaOptions+    cl <- stPersistentOptions . stPersistentState <$> getTC+    return $ cl { optPragmaOptions = p }++-- HasOptions lifts through monad transformers+-- (see default signatures in the HasOptions class).++-- Ternary options are annoying to deal with so we provide auxiliary+-- definitions using @collapseDefault@.++sizedTypesOption :: HasOptions m => m Bool+sizedTypesOption = collapseDefault . optSizedTypes <$> pragmaOptions++guardednessOption :: HasOptions m => m Bool+guardednessOption = collapseDefault . optGuardedness <$> pragmaOptions++withoutKOption :: HasOptions m => m Bool+withoutKOption = collapseDefault . optWithoutK <$> pragmaOptions++cubicalCompatibleOption :: HasOptions m => m Bool+cubicalCompatibleOption = collapseDefault . optCubicalCompatible <$> pragmaOptions++enableCaching :: HasOptions m => m Bool+enableCaching = optCaching <$> pragmaOptions+-----------------------------------------------------------------------------+-- * The reduce monad+-----------------------------------------------------------------------------++-- | Environment of the reduce monad.+data ReduceEnv = ReduceEnv+  { redEnv  :: TCEnv    -- ^ Read only access to environment.+  , redSt   :: TCState  -- ^ Read only access to state (signature, metas...).+  , redPred :: Maybe (MetaId -> ReduceM Bool)+    -- ^ An optional predicate that is used by 'instantiate'' and+    -- 'instantiateFull'': meta-variables are only instantiated if+    -- they satisfy this predicate.+  }++mapRedEnv :: (TCEnv -> TCEnv) -> ReduceEnv -> ReduceEnv+mapRedEnv f s = s { redEnv = f (redEnv s) }++mapRedSt :: (TCState -> TCState) -> ReduceEnv -> ReduceEnv+mapRedSt f s = s { redSt = f (redSt s) }++mapRedEnvSt :: (TCEnv -> TCEnv) -> (TCState -> TCState) -> ReduceEnv+            -> ReduceEnv+mapRedEnvSt f g (ReduceEnv e s p) = ReduceEnv (f e) (g s) p++-- Lenses+reduceEnv :: Lens' TCEnv ReduceEnv+reduceEnv f s = f (redEnv s) <&> \ e -> s { redEnv = e }++reduceSt :: Lens' TCState ReduceEnv+reduceSt f s = f (redSt s) <&> \ e -> s { redSt = e }++newtype ReduceM a = ReduceM { unReduceM :: ReduceEnv -> a }+--  deriving (Functor, Applicative, Monad)++onReduceEnv :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+onReduceEnv f (ReduceM m) = ReduceM (m . f)++fmapReduce :: (a -> b) -> ReduceM a -> ReduceM b+fmapReduce f (ReduceM m) = ReduceM $ \ e -> f $! m e+{-# INLINE fmapReduce #-}++-- Andreas, 2021-05-12, issue #5379:+-- It seems more stable to force to evaluate @mf <*> ma@+-- from left to right, for the sake of printing+-- debug messages in order.+apReduce :: ReduceM (a -> b) -> ReduceM a -> ReduceM b+apReduce (ReduceM f) (ReduceM x) = ReduceM $ \ e ->+  let g = f e+      a = x e+  in  g `pseq` a `pseq` g a+{-# INLINE apReduce #-}++-- Andreas, 2021-05-12, issue #5379+-- Since the MonadDebug instance of ReduceM is implemented via+-- unsafePerformIO, we need to force results that later+-- computations do not depend on, otherwise we lose debug messages.+thenReduce :: ReduceM a -> ReduceM b -> ReduceM b+thenReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e -> x e `pseq` y e+{-# INLINE thenReduce #-}++-- Andreas, 2021-05-14:+-- `seq` does not force evaluation order, the optimizier is allowed to replace+-- @+--    a `seq` b`+-- @+-- by:+-- @+--    b `seq` a `seq` b+-- @+-- see https://hackage.haskell.org/package/parallel/docs/Control-Parallel.html+--+-- In contrast, `pseq` is only strict in its first argument, so such a permutation+-- is forbidden.+-- If we want to ensure that debug messages are printed before exceptions are+-- propagated, we need to use `pseq`, as in:+-- @+--    unsafePerformIO (putStrLn "Black hawk is going down...") `pseq` throw HitByRPG+-- @+beforeReduce :: ReduceM a -> ReduceM b -> ReduceM a+beforeReduce (ReduceM x) (ReduceM y) = ReduceM $ \ e ->+  let a = x e+  in  a `pseq` y e `pseq` a+{-# INLINE beforeReduce #-}++bindReduce :: ReduceM a -> (a -> ReduceM b) -> ReduceM b+bindReduce (ReduceM m) f = ReduceM $ \ e -> unReduceM (f $! m e) e+{-# INLINE bindReduce #-}++instance Functor ReduceM where+  fmap = fmapReduce++instance Applicative ReduceM where+  pure x = ReduceM (const x)+  (<*>) = apReduce+  (*>)  = thenReduce+  (<*)  = beforeReduce++instance Monad ReduceM where+  return = pure+  (>>=) = bindReduce+  (>>) = (*>)+#if __GLASGOW_HASKELL__ < 806+  fail = Fail.fail+#endif++instance Fail.MonadFail ReduceM where+  fail = error++instance ReadTCState ReduceM where+  getTCState = ReduceM redSt+  locallyTCState l f = onReduceEnv $ mapRedSt $ over l f++runReduceM :: ReduceM a -> TCM a+runReduceM m = TCM $ \ r e -> do+  s <- readIORef r+  E.evaluate $ unReduceM m $ ReduceEnv e s Nothing+  -- Andreas, 2021-05-13, issue #5379+  -- This was the following, which is apparently not strict enough+  -- to force all unsafePerformIOs...+  -- runReduceM m = do+  --   e <- askTC+  --   s <- getTC+  --   return $! unReduceM m (ReduceEnv e s)++runReduceF :: (a -> ReduceM b) -> TCM (a -> b)+runReduceF f = do+  e <- askTC+  s <- getTC+  return $ \x -> unReduceM (f x) (ReduceEnv e s Nothing)++instance MonadTCEnv ReduceM where+  askTC   = ReduceM redEnv+  localTC = onReduceEnv . mapRedEnv++-- Andrea comments (https://github.com/agda/agda/issues/1829#issuecomment-522312084):+--+--   useR forces the result of projecting the lens,+--   this usually prevents retaining the whole structure when we only need a field.+--+-- This fixes (or contributes to the fix of) the space leak issue #1829 (caching).+useR :: (ReadTCState m) => Lens' a TCState -> m a+useR l = do+  !x <- (^.l) <$> getTCState+  return x++askR :: ReduceM ReduceEnv+askR = ReduceM ask++localR :: (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a+localR f = ReduceM . local f . unReduceM++instance HasOptions ReduceM where+  pragmaOptions      = useR stPragmaOptions+  commandLineOptions = do+    p  <- useR stPragmaOptions+    cl <- stPersistentOptions . stPersistentState <$> getTCState+    return $ cl{ optPragmaOptions = p }++class ( Applicative m+      , MonadTCEnv m+      , ReadTCState m+      , HasOptions m+      ) => MonadReduce m where+  liftReduce :: ReduceM a -> m a++  default liftReduce :: (MonadTrans t, MonadReduce n, t n ~ m) => ReduceM a -> m a+  liftReduce = lift . liftReduce++instance MonadReduce ReduceM where+  liftReduce = id++instance MonadReduce m => MonadReduce (ChangeT m)+instance MonadReduce m => MonadReduce (ExceptT err m)+instance MonadReduce m => MonadReduce (IdentityT m)+instance MonadReduce m => MonadReduce (ListT m)+instance MonadReduce m => MonadReduce (MaybeT m)+instance MonadReduce m => MonadReduce (ReaderT r m)+instance MonadReduce m => MonadReduce (StateT w m)+instance (Monoid w, MonadReduce m) => MonadReduce (WriterT w m)+instance MonadReduce m => MonadReduce (BlockT m)++---------------------------------------------------------------------------+-- * Monad with read-only 'TCEnv'+---------------------------------------------------------------------------++-- | @MonadTCEnv@ made into its own dedicated service class.+--   This allows us to use 'MonadReader' for 'ReaderT' extensions of @TCM@.+class Monad m => MonadTCEnv m where+  askTC   :: m TCEnv+  localTC :: (TCEnv -> TCEnv) -> m a -> m a++  default askTC :: (MonadTrans t, MonadTCEnv n, t n ~ m) => m TCEnv+  askTC = lift askTC++  default localTC+    :: (MonadTransControl t, MonadTCEnv n, t n ~ m)+    =>  (TCEnv -> TCEnv) -> m a -> m a+  localTC = liftThrough . localTC++instance MonadTCEnv m => MonadTCEnv (ChangeT m)+instance MonadTCEnv m => MonadTCEnv (ExceptT err m)+instance MonadTCEnv m => MonadTCEnv (IdentityT m)+instance MonadTCEnv m => MonadTCEnv (MaybeT m)+instance MonadTCEnv m => MonadTCEnv (ReaderT r m)+instance MonadTCEnv m => MonadTCEnv (StateT s m)+instance (Monoid w, MonadTCEnv m) => MonadTCEnv (WriterT w m)++instance MonadTCEnv m => MonadTCEnv (ListT m) where+  localTC = mapListT . localTC++asksTC :: MonadTCEnv m => (TCEnv -> a) -> m a+asksTC f = f <$> askTC++viewTC :: MonadTCEnv m => Lens' a TCEnv -> m a+viewTC l = asksTC (^. l)++-- | Modify the lens-indicated part of the @TCEnv@ in a subcomputation.+locallyTC :: MonadTCEnv m => Lens' a TCEnv -> (a -> a) -> m b -> m b+locallyTC l = localTC . over l++---------------------------------------------------------------------------+-- * Monad with mutable 'TCState'+---------------------------------------------------------------------------++-- | @MonadTCState@ made into its own dedicated service class.+--   This allows us to use 'MonadState' for 'StateT' extensions of @TCM@.+class Monad m => MonadTCState m where+  getTC :: m TCState+  putTC :: TCState -> m ()+  modifyTC :: (TCState -> TCState) -> m ()++  default getTC :: (MonadTrans t, MonadTCState n, t n ~ m) => m TCState+  getTC = lift getTC++  default putTC :: (MonadTrans t, MonadTCState n, t n ~ m) => TCState -> m ()+  putTC = lift . putTC++  default modifyTC :: (MonadTrans t, MonadTCState n, t n ~ m) => (TCState -> TCState) -> m ()+  modifyTC = lift . modifyTC++instance MonadTCState m => MonadTCState (MaybeT m)+instance MonadTCState m => MonadTCState (ListT m)+instance MonadTCState m => MonadTCState (ExceptT err m)+instance MonadTCState m => MonadTCState (ReaderT r m)+instance MonadTCState m => MonadTCState (StateT s m)+instance MonadTCState m => MonadTCState (ChangeT m)+instance MonadTCState m => MonadTCState (IdentityT m)+instance (Monoid w, MonadTCState m) => MonadTCState (WriterT w m)++-- ** @TCState@ accessors (no lenses)++getsTC :: ReadTCState m => (TCState -> a) -> m a+getsTC f = f <$> getTCState++-- | A variant of 'modifyTC' in which the computation is strict in the+-- new state.+modifyTC' :: MonadTCState m => (TCState -> TCState) -> m ()+modifyTC' f = do+  s' <- getTC+  putTC $! f s'++-- SEE TC.Monad.State+-- -- | Restore the 'TCState' after computation.+-- localTCState :: MonadTCState m => m a -> m a+-- localTCState = bracket_ getTC putTC++-- ** @TCState@ accessors via lenses++useTC :: ReadTCState m => Lens' a TCState -> m a+useTC l = do+  !x <- getsTC (^. l)+  return x++infix 4 `setTCLens`++-- | Overwrite the part of the 'TCState' focused on by the lens.+setTCLens :: MonadTCState m => Lens' a TCState -> a -> m ()+setTCLens l = modifyTC . set l++-- | Overwrite the part of the 'TCState' focused on by the lens+-- (strictly).+setTCLens' :: MonadTCState m => Lens' a TCState -> a -> m ()+setTCLens' l = modifyTC' . set l++-- | Modify the part of the 'TCState' focused on by the lens.+modifyTCLens :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()+modifyTCLens l = modifyTC . over l++-- | Modify the part of the 'TCState' focused on by the lens+-- (strictly).+modifyTCLens' :: MonadTCState m => Lens' a TCState -> (a -> a) -> m ()+modifyTCLens' l = modifyTC' . over l++-- | Modify a part of the state monadically.+modifyTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m a) -> m ()+modifyTCLensM l f = putTC =<< l f =<< getTC++-- | Modify the part of the 'TCState' focused on by the lens, and return some result.+stateTCLens :: MonadTCState m => Lens' a TCState -> (a -> (r , a)) -> m r+stateTCLens l f = stateTCLensM l $ return . f++-- | Modify a part of the state monadically, and return some result.+stateTCLensM :: MonadTCState m => Lens' a TCState -> (a -> m (r , a)) -> m r+stateTCLensM l f = do+  s <- getTC+  (result , x) <- f $ s ^. l+  putTC $ set l x s+  return result+++---------------------------------------------------------------------------+-- ** Monad with capability to block a computation+---------------------------------------------------------------------------++class Monad m => MonadBlock m where++  -- | `patternViolation b` aborts the current computation+  patternViolation :: Blocker -> m a++  default patternViolation :: (MonadTrans t, MonadBlock n, m ~ t n) => Blocker -> m a+  patternViolation = lift . patternViolation++  -- | `catchPatternErr handle m` runs m, handling pattern violations+  --    with `handle` (doesn't roll back the state)+  catchPatternErr :: (Blocker -> m a) -> m a -> m a++newtype BlockT m a = BlockT { unBlockT :: ExceptT Blocker m a }+  deriving ( Functor, Applicative, Monad, MonadTrans -- , MonadTransControl -- requires GHC >= 8.2+           , MonadIO, Fail.MonadFail+           , ReadTCState, HasOptions+           , MonadTCEnv, MonadTCState, MonadTCM+           )++instance Monad m => MonadBlock (BlockT m) where+  patternViolation = BlockT . throwError+  catchPatternErr h f = BlockT $ catchError (unBlockT f) (unBlockT . h)++instance Monad m => MonadBlock (ExceptT TCErr m) where+  patternViolation = throwError . PatternErr+  catchPatternErr h f = catchError f $ \case+    PatternErr b -> h b+    err          -> throwError err++runBlocked :: Monad m => BlockT m a -> m (Either Blocker a)+runBlocked = runExceptT . unBlockT++instance MonadBlock m => MonadBlock (MaybeT m) where+  catchPatternErr h m = MaybeT $ catchPatternErr (runMaybeT . h) $ runMaybeT m++instance MonadBlock m => MonadBlock (ReaderT e m) where+  catchPatternErr h m = ReaderT $ \ e ->+    let run = flip runReaderT e in catchPatternErr (run . h) (run m)++---------------------------------------------------------------------------+-- * Type checking monad transformer+---------------------------------------------------------------------------++-- | The type checking monad transformer.+-- Adds readonly 'TCEnv' and mutable 'TCState'.+newtype TCMT m a = TCM { unTCM :: IORef TCState -> TCEnv -> m a }++-- | Type checking monad.+type TCM = TCMT IO++{-# SPECIALIZE INLINE mapTCMT :: (forall a. IO a -> IO a) -> TCM a -> TCM a #-}+mapTCMT :: (forall a. m a -> n a) -> TCMT m a -> TCMT n a+mapTCMT f (TCM m) = TCM $ \ s e -> f (m s e)++pureTCM :: MonadIO m => (TCState -> TCEnv -> a) -> TCMT m a+pureTCM f = TCM $ \ r e -> do+  s <- liftIO $ readIORef r+  return (f s e)++-- One goal of the definitions and pragmas below is to inline the+-- monad operations as much as possible. This doesn't seem to have a+-- large effect on the performance of the normal executable, but (at+-- least on one machine/configuration) it has a massive effect on the+-- performance of the profiling executable [1], and reduces the time+-- attributed to bind from over 90% to about 25%.+--+-- [1] When compiled with -auto-all and run with -p: roughly 750%+-- faster for one example.++returnTCMT :: Applicative m => a -> TCMT m a+returnTCMT = \x -> TCM $ \_ _ -> pure x+{-# INLINE returnTCMT #-}++bindTCMT :: Monad m => TCMT m a -> (a -> TCMT m b) -> TCMT m b+bindTCMT = \(TCM m) k -> TCM $ \r e -> m r e >>= \x -> unTCM (k x) r e+{-# INLINE bindTCMT #-}++thenTCMT :: Applicative m => TCMT m a -> TCMT m b -> TCMT m b+thenTCMT = \(TCM m1) (TCM m2) -> TCM $ \r e -> m1 r e *> m2 r e+{-# INLINE thenTCMT #-}++instance Functor m => Functor (TCMT m) where+  fmap = fmapTCMT++fmapTCMT :: Functor m => (a -> b) -> TCMT m a -> TCMT m b+fmapTCMT = \f (TCM m) -> TCM $ \r e -> fmap f (m r e)+{-# INLINE fmapTCMT #-}++instance Applicative m => Applicative (TCMT m) where+  pure  = returnTCMT+  (<*>) = apTCMT++apTCMT :: Applicative m => TCMT m (a -> b) -> TCMT m a -> TCMT m b+apTCMT = \(TCM mf) (TCM m) -> TCM $ \r e -> mf r e <*> m r e+{-# INLINE apTCMT #-}++instance MonadTrans TCMT where+    lift m = TCM $ \_ _ -> m++-- We want a special monad implementation of fail.+#if __GLASGOW_HASKELL__ < 806+instance MonadIO m => Monad (TCMT m) where+#else+-- Andreas, 2022-02-02, issue #5659:+-- @transformers-0.6@ requires exactly a @Monad@ superclass constraint here+-- if we want @instance MonadTrans TCMT@.+instance Monad m => Monad (TCMT m) where+#endif+    return = pure+    (>>=)  = bindTCMT+    (>>)   = (*>)+#if __GLASGOW_HASKELL__ < 806+    fail   = Fail.fail+#endif++instance MonadIO m => Fail.MonadFail (TCMT m) where+  fail = internalError++instance MonadIO m => MonadIO (TCMT m) where+  liftIO m = TCM $ \ s env -> do+    liftIO $ wrap s (envRange env) $ do+      x <- m+      x `seq` return x+    where+      wrap s r m = E.catch m $ \ err -> do+        s <- readIORef s+        E.throwIO $ IOException s r err++instance ( MonadFix m+#if __GLASGOW_HASKELL__ < 806+         , MonadIO m+#endif+         ) => MonadFix (TCMT m) where+  mfix f = TCM $ \s env -> mdo+    x <- unTCM (f x) s env+    return x++instance MonadIO m => MonadTCEnv (TCMT m) where+  askTC             = TCM $ \ _ e -> return e+  localTC f (TCM m) = TCM $ \ s e -> m s (f e)++instance MonadIO m => MonadTCState (TCMT m) where+  getTC   = TCM $ \ r _e -> liftIO (readIORef r)+  putTC s = TCM $ \ r _e -> liftIO (writeIORef r s)+  modifyTC f = putTC . f =<< getTC++instance MonadIO m => ReadTCState (TCMT m) where+  getTCState = getTC+  locallyTCState l f = bracket_ (useTC l <* modifyTCLens l f) (setTCLens l)++instance MonadBlock TCM where+  patternViolation b = throwError (PatternErr b)+  catchPatternErr handle v =+       catchError_ v $ \err ->+       case err of+            -- Not putting s (which should really be the what's already there) makes things go+            -- a lot slower (+20% total time on standard library). How is that possible??+            -- The problem is most likely that there are internal catchErrors which forgets the+            -- state. catchError should preserve the state on pattern violations.+           PatternErr u -> handle u+           _            -> throwError err+++instance MonadError TCErr TCM where+  throwError = liftIO . E.throwIO+  catchError m h = TCM $ \ r e -> do  -- now we are in the IO monad+    oldState <- readIORef r+    unTCM m r e `E.catch` \err -> do+      -- Reset the state, but do not forget changes to the persistent+      -- component. Not for pattern violations.+      case err of+        PatternErr{} -> return ()+        _            ->+          liftIO $ do+            newState <- readIORef r+            writeIORef r $ oldState { stPersistentState = stPersistentState newState }+      unTCM (h err) r e++-- | Like 'catchError', but resets the state completely before running the handler.+--   This means it also loses changes to the 'stPersistentState'.+--+--   The intended use is to catch internal errors during debug printing.+--   In debug printing, we are not expecting state changes.+instance CatchImpossible TCM where+  catchImpossibleJust f m h = TCM $ \ r e -> do+    -- save the state+    s <- readIORef r+    catchImpossibleJust f (unTCM m r e) $ \ err -> do+      writeIORef r s+      unTCM (h err) r e++instance MonadIO m => MonadReduce (TCMT m) where+  liftReduce = liftTCM . runReduceM++instance (IsString a, MonadIO m) => IsString (TCMT m a) where+  fromString s = return (fromString s)++-- | Strict (non-shortcut) semigroup.+--+--   Note that there might be a lazy alternative, e.g.,+--   for TCM All we might want 'Agda.Utils.Monad.and2M' as concatenation,+--   to shortcut conjunction in case we already have 'False'.+--+instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a) => Semigroup (TCMT m a) where+  (<>) = liftA2 (<>)++-- | Strict (non-shortcut) monoid.+instance {-# OVERLAPPABLE #-} (MonadIO m, Semigroup a, Monoid a) => Monoid (TCMT m a) where+  mempty  = pure mempty+  mappend = (<>)+  mconcat = mconcat <.> sequence++instance {-# OVERLAPPABLE #-} (MonadIO m, Null a) => Null (TCMT m a) where+  empty = return empty+  null  = __IMPOSSIBLE__++-- | Preserve the state of the failing computation.+catchError_ :: TCM a -> (TCErr -> TCM a) -> TCM a+catchError_ m h = TCM $ \r e ->+  unTCM m r e+  `E.catch` \err -> unTCM (h err) r e++-- | Execute a finalizer even when an exception is thrown.+--   Does not catch any errors.+--   In case both the regular computation and the finalizer+--   throw an exception, the one of the finalizer is propagated.+finally_ :: TCM a -> TCM b -> TCM a+finally_ m f = do+    x <- m `catchError_` \ err -> f >> throwError err+    _ <- f+    return x++-- | Embedding a TCM computation.++class ( Applicative tcm, MonadIO tcm+      , MonadTCEnv tcm+      , MonadTCState tcm+      , HasOptions tcm+      ) => MonadTCM tcm where+    liftTCM :: TCM a -> tcm a++    default liftTCM :: (MonadTCM m, MonadTrans t, tcm ~ t m) => TCM a -> tcm a+    liftTCM = lift . liftTCM++{-# RULES "liftTCM/id" liftTCM = id #-}+instance MonadIO m => MonadTCM (TCMT m) where+    liftTCM = mapTCMT liftIO++instance MonadTCM tcm => MonadTCM (ChangeT tcm)+instance MonadTCM tcm => MonadTCM (ExceptT err tcm)+instance MonadTCM tcm => MonadTCM (IdentityT tcm)+instance MonadTCM tcm => MonadTCM (ListT tcm)+instance MonadTCM tcm => MonadTCM (MaybeT tcm)+instance MonadTCM tcm => MonadTCM (ReaderT r tcm)+instance MonadTCM tcm => MonadTCM (StateT s tcm)+instance (Monoid w, MonadTCM tcm) => MonadTCM (WriterT w tcm)++-- | We store benchmark statistics in an IORef.+--   This enables benchmarking pure computation, see+--   "Agda.Benchmarking".+instance MonadBench TCM where+  type BenchPhase TCM = Phase+  getBenchmark = liftIO $ getBenchmark+  putBenchmark = liftIO . putBenchmark+  finally = finally_++instance Null (TCM Doc) where+  empty = return empty+  null = __IMPOSSIBLE__++internalError :: (HasCallStack, MonadTCM tcm) => String -> tcm a+internalError s = withCallerCallStack $ \ loc ->+  liftTCM $ typeError' loc $ InternalError s++-- | The constraints needed for 'typeError' and similar.+type MonadTCError m = (MonadTCEnv m, ReadTCState m, MonadError TCErr m)++-- | Utility function for 1-arg constructed type errors.+-- Note that the @HasCallStack@ constraint is on the *resulting* function.+locatedTypeError :: MonadTCError m => (a -> TypeError) -> (HasCallStack => a -> m b)+locatedTypeError f e = withCallerCallStack (flip typeError' (f e))++genericError :: (HasCallStack, MonadTCError m) => String -> m a+genericError = locatedTypeError GenericError++{-# SPECIALIZE genericDocError :: Doc -> TCM a #-}+genericDocError :: (HasCallStack, MonadTCError m) => Doc -> m a+genericDocError = locatedTypeError GenericDocError++{-# SPECIALIZE typeError' :: CallStack -> TypeError -> TCM a #-}+typeError' :: MonadTCError m => CallStack -> TypeError -> m a+typeError' loc err = throwError =<< typeError'_ loc err++{-# SPECIALIZE typeError :: HasCallStack => TypeError -> TCM a #-}+typeError :: (HasCallStack, MonadTCError m) => TypeError -> m a+typeError err = withCallerCallStack $ \loc -> throwError =<< typeError'_ loc err++{-# SPECIALIZE typeError'_ :: CallStack -> TypeError -> TCM TCErr #-}+typeError'_ :: (MonadTCEnv m, ReadTCState m) => CallStack -> TypeError -> m TCErr+typeError'_ loc err = TypeError loc <$> getTCState <*> buildClosure err++{-# SPECIALIZE typeError_ :: HasCallStack => TypeError -> TCM TCErr #-}+typeError_ :: (HasCallStack, MonadTCEnv m, ReadTCState m) => TypeError -> m TCErr+typeError_ = withCallerCallStack . flip typeError'_++-- | Running the type checking monad (most general form).+{-# SPECIALIZE runTCM :: TCEnv -> TCState -> TCM a -> IO (a, TCState) #-}+runTCM :: MonadIO m => TCEnv -> TCState -> TCMT m a -> m (a, TCState)+runTCM e s m = do+  r <- liftIO $ newIORef s+  a <- unTCM m r e+  s <- liftIO $ readIORef r+  return (a, s)++-- | Running the type checking monad on toplevel (with initial state).+runTCMTop :: TCM a -> IO (Either TCErr a)+runTCMTop m = (Right <$> runTCMTop' m) `E.catch` (return . Left)++runTCMTop' :: MonadIO m => TCMT m a -> m a+runTCMTop' m = do+  r <- liftIO $ newIORef initState+  unTCM m r initEnv++-- | 'runSafeTCM' runs a safe 'TCM' action (a 'TCM' action which+--   cannot fail, except that it might raise 'IOException's) in the+--   initial environment.++runSafeTCM :: TCM a -> TCState -> IO (a, TCState)+runSafeTCM m st =+  runTCM initEnv st m `E.catch` \(e :: TCErr) -> case e of+    IOException _ _ err -> E.throwIO err+    _                   -> __IMPOSSIBLE__++-- | Runs the given computation in a separate thread, with /a copy/ of+-- the current state and environment.+--+-- Note that Agda sometimes uses actual, mutable state. If the+-- computation given to @forkTCM@ tries to /modify/ this state, then+-- bad things can happen, because accesses are not mutually exclusive.+-- The @forkTCM@ function has been added mainly to allow the thread to+-- /read/ (a snapshot of) the current state in a convenient way.+--+-- Note also that exceptions which are raised in the thread are not+-- propagated to the parent, so the thread should not do anything+-- important.++forkTCM :: TCM a -> TCM ()+forkTCM m = do+  s <- getTC+  e <- askTC+  liftIO $ void $ C.forkIO $ void $ runTCM e s m++---------------------------------------------------------------------------+-- * Names for generated definitions+---------------------------------------------------------------------------++-- | Base name for patterns in telescopes+patternInTeleName :: String+patternInTeleName = ".patternInTele"++-- | Base name for extended lambda patterns+extendedLambdaName :: String+extendedLambdaName = ".extendedlambda"++-- | Check whether we have an definition from an extended lambda.+isExtendedLambdaName :: A.QName -> Bool+isExtendedLambdaName = (extendedLambdaName `List.isPrefixOf`) . prettyShow . nameConcrete . qnameName++-- | Name of absurdLambda definitions.+absurdLambdaName :: String+absurdLambdaName = ".absurdlambda"++-- | Check whether we have an definition from an absurd lambda.+isAbsurdLambdaName :: QName -> Bool+isAbsurdLambdaName = (absurdLambdaName ==) . prettyShow . qnameName++-- | Base name for generalized variable projections+generalizedFieldName :: String+generalizedFieldName = ".generalizedField-"++-- | Check whether we have a generalized variable field+getGeneralizedFieldName :: A.QName -> Maybe String+getGeneralizedFieldName q+  | generalizedFieldName `List.isPrefixOf` strName = Just (drop (length generalizedFieldName) strName)+  | otherwise                                      = Nothing+  where strName = prettyShow $ nameConcrete $ qnameName q++---------------------------------------------------------------------------+-- * KillRange instances+---------------------------------------------------------------------------++instance KillRange Signature where+  killRange (Sig secs defs rews) = killRange2 Sig secs defs rews++instance KillRange Sections where+  killRange = fmap killRange++instance KillRange Definitions where+  killRange = fmap killRange++instance KillRange RewriteRuleMap where+  killRange = fmap killRange++instance KillRange Section where+  killRange (Section tel) = killRange1 Section tel++instance KillRange Definition where+  killRange (Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def) =+    killRange19 Defn ai name t pols occs gens gpars displ mut compiled inst copy ma nc inj copat blk lang def+    -- TODO clarify: Keep the range in the defName field?++instance KillRange NumGeneralizableArgs where+  killRange = id++instance KillRange NLPat where+  killRange (PVar x y) = killRange2 PVar x y+  killRange (PDef x y) = killRange2 PDef x y+  killRange (PLam x y) = killRange2 PLam x y+  killRange (PPi x y)  = killRange2 PPi x y+  killRange (PSort x)  = killRange1 PSort x+  killRange (PBoundVar x y) = killRange2 PBoundVar x y+  killRange (PTerm x)  = killRange1 PTerm x++instance KillRange NLPType where+  killRange (NLPType s a) = killRange2 NLPType s a++instance KillRange NLPSort where+  killRange (PType l) = killRange1 PType l+  killRange (PProp l) = killRange1 PProp l+  killRange (PSSet l) = killRange1 PSSet l+  killRange s@(PInf f n) = s+  killRange PSizeUniv = PSizeUniv+  killRange PLockUniv = PLockUniv+  killRange PIntervalUniv = PIntervalUniv++instance KillRange RewriteRule where+  killRange (RewriteRule q gamma f es rhs t c) =+    killRange6 RewriteRule q gamma f es rhs t c++instance KillRange CompiledRepresentation where+  killRange = id+++instance KillRange EtaEquality where+  killRange = id++instance KillRange System where+  killRange (System tel sys) = System (killRange tel) (killRange sys)++instance KillRange ExtLamInfo where+  killRange (ExtLamInfo m b sys) = killRange3 ExtLamInfo m b sys++instance KillRange FunctionFlag where+  killRange = id++instance KillRange CompKit where+  killRange = id++instance KillRange ProjectionLikenessMissing where+  killRange = id++instance KillRange Defn where+  killRange def =+    case def of+      Axiom a -> Axiom a+      DataOrRecSig n -> DataOrRecSig n+      GeneralizableVar -> GeneralizableVar+      AbstractDefn{} -> __IMPOSSIBLE__ -- only returned by 'getConstInfo'!+      Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with iskan ->+        killRange14 Function cls comp ct tt covering inv mut isAbs delayed proj flags term extlam with iskan+      Datatype a b c d e f g h i j   -> killRange10 Datatype a b c d e f g h i j+      Record a b c d e f g h i j k l m -> killRange13 Record a b c d e f g h i j k l m+      Constructor a b c d e f g h i j-> killRange10 Constructor a b c d e f g h i j+      Primitive a b c d e            -> killRange5 Primitive a b c d e+      PrimitiveSort a b              -> killRange2 PrimitiveSort a b++instance KillRange MutualId where+  killRange = id++instance KillRange c => KillRange (FunctionInverse' c) where+  killRange NotInjective = NotInjective+  killRange (Inverse m)  = Inverse $ killRangeMap m++instance KillRange TermHead where+  killRange SortHead     = SortHead+  killRange PiHead       = PiHead+  killRange (ConsHead q) = ConsHead $ killRange q+  killRange h@VarHead{}  = h+  killRange UnknownHead  = UnknownHead++instance KillRange Projection where+  killRange (Projection a b c d e) = killRange5 Projection a b c d e++instance KillRange ProjLams where+  killRange = id++instance KillRange a => KillRange (Open a) where+  killRange = fmap killRange++instance KillRange DisplayForm where+  killRange (Display n es dt) = killRange3 Display n es dt++instance KillRange Polarity where+  killRange = id++instance KillRange IsForced where+  killRange = id++instance KillRange DoGeneralize where+  killRange = id++instance KillRange DisplayTerm where+  killRange dt =+    case dt of+      DWithApp dt dts es -> killRange3 DWithApp dt dts es+      DCon q ci dts     -> killRange3 DCon q ci dts+      DDef q dts        -> killRange2 DDef q dts+      DDot v            -> killRange1 DDot v+      DTerm v           -> killRange1 DTerm v++instance KillRange a => KillRange (Closure a) where+  killRange = id++---------------------------------------------------------------------------+-- NFData instances+---------------------------------------------------------------------------++instance NFData NumGeneralizableArgs where+  rnf NoGeneralizableArgs       = ()+  rnf (SomeGeneralizableArgs _) = ()++instance NFData TCErr where+  rnf (TypeError a b c)   = rnf a `seq` rnf b `seq` rnf c+  rnf (Exception a b)     = rnf a `seq` rnf b+  rnf (IOException a b c) = rnf a `seq` rnf b `seq` rnf (c == c)+                            -- At the time of writing there is no+                            -- NFData instance for E.IOException.+  rnf (PatternErr a)      = rnf a++-- | This instance could be optimised, some things are guaranteed to+-- be forced.++instance NFData PreScopeState++-- | This instance could be optimised, some things are guaranteed to+-- be forced.++instance NFData PostScopeState++instance NFData TCState+instance NFData DisambiguatedName+instance NFData MutualBlock+instance NFData (BiMap RawTopLevelModuleName ModuleNameHash)+instance NFData PersistentTCState+instance NFData LoadedFileCache+instance NFData TypeCheckAction+instance NFData ModuleCheckMode+instance NFData ModuleInfo+instance NFData ForeignCode+instance NFData Interface+instance NFData a => NFData (Closure a)+instance NFData ProblemConstraint+instance NFData WhyCheckModality+instance NFData Constraint+instance NFData Signature+instance NFData Comparison+instance NFData CompareAs+instance NFData a => NFData (Open a)+instance NFData a => NFData (Judgement a)+instance NFData DoGeneralize+instance NFData GeneralizedValue+instance NFData MetaVariable+instance NFData Listener+instance NFData MetaInstantiation+instance NFData Instantiation+instance NFData RemoteMetaVariable+instance NFData Frozen+instance NFData PrincipalArgTypeMetas+instance NFData TypeCheckingProblem+instance NFData RunMetaOccursCheck+instance NFData MetaInfo+instance NFData InteractionPoint+instance NFData InteractionPoints+instance NFData Overapplied+instance NFData t => NFData (IPBoundary' t)+instance NFData IPClause+instance NFData DisplayForm+instance NFData DisplayTerm+instance NFData NLPat+instance NFData NLPType+instance NFData NLPSort+instance NFData RewriteRule+instance NFData Definition+instance NFData Polarity+instance NFData IsForced+instance NFData Projection+instance NFData ProjLams+instance NFData CompilerPragma+instance NFData System+instance NFData ExtLamInfo+instance NFData EtaEquality+instance NFData FunctionFlag+instance NFData CompKit+instance NFData AxiomData+instance NFData DataOrRecSigData+instance NFData ProjectionLikenessMissing+instance NFData FunctionData+instance NFData DatatypeData+instance NFData RecordData+instance NFData ConstructorData+instance NFData PrimitiveData+instance NFData PrimitiveSortData instance NFData Defn instance NFData Simplification instance NFData AllowedReduction
src/full/Agda/TypeChecking/Monad/Base.hs-boot view
@@ -7,7 +7,7 @@ import Data.Map (Map)  import Agda.Syntax.Common (Nat)-import Agda.Syntax.Concrete.Name (TopLevelModuleName)+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName) import Agda.Utils.FileName (AbsolutePath)  data Warning@@ -32,7 +32,7 @@ instance Functor m => Functor (TCMT m) instance MonadIO m => MonadIO (TCMT m) -#if __GLASGOW_HASKELL__ < 808+#if __GLASGOW_HASKELL__ < 806 instance MonadIO m => Monad (TCMT m) where #else -- Andreas, 2022-02-02, issue #5659:@@ -49,3 +49,4 @@  data Comparison data Polarity+data IPBoundary' a
src/full/Agda/TypeChecking/Monad/Benchmark.hs view
@@ -22,26 +22,9 @@  import Agda.Utils.Monad import Agda.Utils.Pretty (prettyShow)--benchmarkKey :: String-benchmarkKey = "profile"--benchmarkLevel :: Int-benchmarkLevel = 7--benchmarkModulesKey :: String-benchmarkModulesKey = "profile.modules"--benchmarkModulesLevel :: Int-benchmarkModulesLevel = 10--benchmarkDefsKey :: String-benchmarkDefsKey = "profile.definitions"--benchmarkDefsLevel :: Int-benchmarkDefsLevel = 10+import qualified Agda.Utils.ProfileOptions as Profile --- | When verbosity is set or changes, we need to turn benchmarking on or off.+-- | When profile options are set or changed, we need to turn benchmarking on or off. updateBenchmarkingStatus :: TCM () -- {-# SPECIALIZE updateBenchmarkingStatus :: TCM () #-} -- updateBenchmarkingStatus :: (HasOptions m, MonadBench a m) => m ()@@ -51,20 +34,14 @@ -- | Check whether benchmarking is activated. {-# SPECIALIZE benchmarking :: TCM (B.BenchmarkOn Phase) #-} benchmarking :: MonadTCM tcm => tcm (B.BenchmarkOn Phase)-benchmarking = liftTCM $ do-  -- Ulf, 2016-12-13: Using verbosity levels to control the type of-  -- benchmarking isn't ideal, but let's stick with it for now.-  internal <- hasVerbosity benchmarkKey benchmarkLevel-  defs     <- hasVerbosity benchmarkDefsKey benchmarkDefsLevel-  modules  <- hasVerbosity benchmarkModulesKey benchmarkModulesLevel-  return $ case (internal, defs, modules) of-    (True, _, _) -> B.BenchmarkSome isInternalAccount-    (_, True, _) -> B.BenchmarkSome isDefAccount-    (_, _, True) -> B.BenchmarkSome isModuleAccount-    _            -> B.BenchmarkOff+benchmarking = liftTCM $+  ifM (hasProfileOption Profile.Internal)    (pure $ B.BenchmarkSome isInternalAccount) $+  ifM (hasProfileOption Profile.Definitions) (pure $ B.BenchmarkSome isDefAccount) $+  ifM (hasProfileOption Profile.Modules)     (pure $ B.BenchmarkSome isModuleAccount) $+  pure B.BenchmarkOff  -- | Prints the accumulated benchmark results. Does nothing if--- profiling is not activated at level 2.+--   no benchmark profiling is enabled. print :: MonadTCM tcm => tcm () print = liftTCM $ whenM (B.isBenchmarkOn [] <$> benchmarking) $ do   b <- B.getBenchmark@@ -76,9 +53,8 @@   -- Ulf, 2020-03-04: Using benchmarkLevel here means that it only prints if internal benchmarking   -- is turned on, effectively making module/definition benchmarking impossible (since internal   -- takes precedence). It needs to be > 1 to avoid triggering #2602 though. Also use-  -- displayDebugMessage instead of reportSLn to avoid requiring -v profile:2 in addition to the-  -- specific profile levels.-  displayDebugMessage benchmarkKey 2 $ prettyShow b+  -- displayDebugMessage instead of reportSLn to avoid requiring -v profile:2.+  displayDebugMessage "profile" 2 $ prettyShow b  -- -- | Bill a computation to a specific account. -- {-# SPECIALIZE billTo :: Account -> TCM a -> TCM a #-}
src/full/Agda/TypeChecking/Monad/Builtin.hs view
@@ -15,21 +15,25 @@ import Control.Monad.Trans.Maybe import Control.Monad.Writer -import qualified Data.Map as Map import Data.Function ( on )+import qualified Data.Map as Map+import Data.Set (Set)  import Agda.Syntax.Common import Agda.Syntax.Position import Agda.Syntax.Literal import Agda.Syntax.Builtin import Agda.Syntax.Internal as I+import Agda.Interaction.Options.Base (PragmaOptions(..)) import Agda.TypeChecking.Monad.Base -- import Agda.TypeChecking.Functions  -- LEADS TO IMPORT CYCLE import Agda.TypeChecking.Substitute +import Agda.Utils.Functor import Agda.Utils.ListT import Agda.Utils.Monad import Agda.Utils.Maybe+import Agda.Utils.Singleton import Agda.Utils.Tuple  import Agda.Utils.Impossible@@ -54,8 +58,10 @@ deriving instance HasBuiltins m => HasBuiltins (BlockT m)  instance MonadIO m => HasBuiltins (TCMT m) where-  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useTC stLocalBuiltins)-                      (Map.lookup b <$> useTC stImportedBuiltins)+  getBuiltinThing b =+    liftM2 (unionMaybeWith unionBuiltin)+      (Map.lookup b <$> useTC stLocalBuiltins)+      (Map.lookup b <$> useTC stImportedBuiltins)  -- If Agda is changed so that the type of a literal can belong to an -- inductive family (with at least one index), then the implementation@@ -87,6 +93,7 @@   case builtin of     Just (Builtin y) -> typeError $ DuplicateBuiltinBinding b y x     Just (Prim _)    -> typeError $ NoSuchBuiltinName b+    Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__     Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b (Builtin x)  bindPrimitive :: String -> PrimFun -> TCM ()@@ -95,9 +102,25 @@   case builtin of     Just (Builtin _) -> typeError $ NoSuchPrimitiveFunction b     Just (Prim x)    -> typeError $ (DuplicatePrimitiveBinding b `on` primFunName) x pf+    Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__     Nothing          -> stLocalBuiltins `modifyTCLens` Map.insert b (Prim pf) -getBuiltin :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)+-- | Add one (more) relation symbol to the rewrite relations.+bindBuiltinRewriteRelation :: QName -> TCM ()+bindBuiltinRewriteRelation x =+  stLocalBuiltins `modifyTCLens`+    Map.insertWith unionBuiltin builtinRewrite (BuiltinRewriteRelations $ singleton x)++-- | Get the currently registered rewrite relation symbols.+getBuiltinRewriteRelations :: HasBuiltins m => m (Maybe (Set QName))+getBuiltinRewriteRelations = fmap rels <$> getBuiltinThing builtinRewrite+  where+  rels = \case+    BuiltinRewriteRelations xs -> xs+    Prim{}    -> __IMPOSSIBLE__+    Builtin{} -> __IMPOSSIBLE__++getBuiltin :: (HasBuiltins m, MonadTCError m)            => String -> m Term getBuiltin x =   fromMaybeM (typeError $ NoBindingForBuiltin x) $ getBuiltin' x@@ -106,6 +129,7 @@ getBuiltin' x = do     builtin <- getBuiltinThing x     case builtin of+        Just BuiltinRewriteRelations{} -> __IMPOSSIBLE__         Just (Builtin t) -> return $ Just $ killRange t         _                -> return Nothing @@ -113,6 +137,7 @@ getPrimitive' x = (getPrim =<<) <$> getBuiltinThing x   where     getPrim (Prim pf) = return pf+    getPrim BuiltinRewriteRelations{} = __IMPOSSIBLE__     getPrim _         = Nothing  getPrimitive :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)@@ -166,7 +191,7 @@     primFloat, primChar, primString, primUnit, primUnitUnit, primBool, primTrue, primFalse,     primSigma,     primList, primNil, primCons, primIO, primNat, primSuc, primZero, primMaybe, primNothing, primJust,-    primPath, primPathP, primInterval, primIZero, primIOne, primPartial, primPartialP,+    primPath, primPathP, primIntervalUniv, primInterval, primIZero, primIOne, primPartial, primPartialP,     primIMin, primIMax, primINeg,     primIsOne, primItIsOne, primIsOne1, primIsOne2, primIsOneEmpty,     primSub, primSubIn, primSubOut,@@ -184,7 +209,6 @@     primSizeUniv, primSize, primSizeLt, primSizeSuc, primSizeInf, primSizeMax,     primInf, primSharp, primFlat,     primEquality, primRefl,-    primRewrite, -- Name of rewrite relation     primLevel, primLevelZero, primLevelSuc, primLevelMax,     primLockUniv,     primSet, primProp, primSetOmega, primStrictSet, primSSetOmega,@@ -193,7 +217,7 @@     primQName, primArgInfo, primArgArgInfo, primArg, primArgArg, primAbs, primAbsAbs, primAgdaTerm, primAgdaTermVar,     primAgdaTermLam, primAgdaTermExtLam, primAgdaTermDef, primAgdaTermCon, primAgdaTermPi,     primAgdaTermSort, primAgdaTermLit, primAgdaTermUnsupported, primAgdaTermMeta,-    primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartName,+    primAgdaErrorPart, primAgdaErrorPartString, primAgdaErrorPartTerm, primAgdaErrorPartPatt, primAgdaErrorPartName,     primHiding, primHidden, primInstance, primVisible,     primRelevance, primRelevant, primIrrelevant,     primQuantity, primQuantity0, primQuantityω,@@ -214,15 +238,17 @@     primAgdaTCMTypeError, primAgdaTCMInferType, primAgdaTCMCheckType,     primAgdaTCMNormalise, primAgdaTCMReduce,     primAgdaTCMCatchError, primAgdaTCMGetContext, primAgdaTCMExtendContext, primAgdaTCMInContext,-    primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDefineFun,+    primAgdaTCMFreshName, primAgdaTCMDeclareDef, primAgdaTCMDeclarePostulate, primAgdaTCMDeclareData, primAgdaTCMDefineData, primAgdaTCMDefineFun,     primAgdaTCMGetType, primAgdaTCMGetDefinition,     primAgdaTCMQuoteTerm, primAgdaTCMUnquoteTerm, primAgdaTCMQuoteOmegaTerm,     primAgdaTCMBlockOnMeta, primAgdaTCMCommit, primAgdaTCMIsMacro,-    primAgdaTCMWithNormalisation, primAgdaTCMDebugPrint, primAgdaTCMWithReconsParams,+    primAgdaTCMFormatErrorParts, primAgdaTCMDebugPrint,+    primAgdaTCMWithNormalisation, primAgdaTCMWithReconsParams,     primAgdaTCMOnlyReduceDefs, primAgdaTCMDontReduceDefs,     primAgdaTCMNoConstraints,     primAgdaTCMRunSpeculative,-    primAgdaTCMExec+    primAgdaTCMExec,+    primAgdaTCMGetInstances     :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Term  primInteger                           = getBuiltin builtinInteger@@ -245,10 +271,11 @@ primJust                              = getBuiltin builtinJust primIO                                = getBuiltin builtinIO primId                                = getBuiltin builtinId-primConId                             = getBuiltin builtinConId+primConId                             = getPrimitiveTerm builtinConId primIdElim                            = getPrimitiveTerm builtinIdElim primPath                              = getBuiltin builtinPath primPathP                             = getBuiltin builtinPathP+primIntervalUniv                      = getBuiltin builtinIntervalUniv primInterval                          = getBuiltin builtinInterval primIZero                             = getBuiltin builtinIZero primIOne                              = getBuiltin builtinIOne@@ -299,7 +326,6 @@ primFlat                              = getBuiltin builtinFlat primEquality                          = getBuiltin builtinEquality primRefl                              = getBuiltin builtinRefl-primRewrite                           = getBuiltin builtinRewrite primLevel                             = getBuiltin builtinLevel primLevelZero                         = getBuiltin builtinLevelZero primLevelSuc                          = getBuiltin builtinLevelSuc@@ -362,6 +388,7 @@ primAgdaErrorPart                     = getBuiltin builtinAgdaErrorPart primAgdaErrorPartString               = getBuiltin builtinAgdaErrorPartString primAgdaErrorPartTerm                 = getBuiltin builtinAgdaErrorPartTerm+primAgdaErrorPartPatt                 = getBuiltin builtinAgdaErrorPartPatt primAgdaErrorPartName                 = getBuiltin builtinAgdaErrorPartName primAgdaLiteral                       = getBuiltin builtinAgdaLiteral primAgdaLitNat                        = getBuiltin builtinAgdaLitNat@@ -405,6 +432,8 @@ primAgdaTCMFreshName                  = getBuiltin builtinAgdaTCMFreshName primAgdaTCMDeclareDef                 = getBuiltin builtinAgdaTCMDeclareDef primAgdaTCMDeclarePostulate           = getBuiltin builtinAgdaTCMDeclarePostulate+primAgdaTCMDeclareData                = getBuiltin builtinAgdaTCMDeclareData+primAgdaTCMDefineData                 = getBuiltin builtinAgdaTCMDefineData primAgdaTCMDefineFun                  = getBuiltin builtinAgdaTCMDefineFun primAgdaTCMGetType                    = getBuiltin builtinAgdaTCMGetType primAgdaTCMGetDefinition              = getBuiltin builtinAgdaTCMGetDefinition@@ -416,12 +445,14 @@ primAgdaTCMIsMacro                    = getBuiltin builtinAgdaTCMIsMacro primAgdaTCMWithNormalisation          = getBuiltin builtinAgdaTCMWithNormalisation primAgdaTCMWithReconsParams           = getBuiltin builtinAgdaTCMWithReconsParams+primAgdaTCMFormatErrorParts           = getBuiltin builtinAgdaTCMFormatErrorParts primAgdaTCMDebugPrint                 = getBuiltin builtinAgdaTCMDebugPrint primAgdaTCMOnlyReduceDefs             = getBuiltin builtinAgdaTCMOnlyReduceDefs primAgdaTCMDontReduceDefs             = getBuiltin builtinAgdaTCMDontReduceDefs primAgdaTCMNoConstraints              = getBuiltin builtinAgdaTCMNoConstraints primAgdaTCMRunSpeculative             = getBuiltin builtinAgdaTCMRunSpeculative primAgdaTCMExec                       = getBuiltin builtinAgdaTCMExec+primAgdaTCMGetInstances               = getBuiltin builtinAgdaTCMGetInstances  -- | The coinductive primitives. @@ -456,13 +487,18 @@   , nameOfSetOmega :: IsFibrant -> QName   } -sortKit :: HasBuiltins m => m SortKit+-- | Compute a 'SortKit' in an environment that supports failures.+--+-- When 'optLoadPrimitives' is set to 'False', 'sortKit' is a fallible operation,+-- so for the uses of 'sortKit' in fallible contexts (e.g. 'TCM'),+-- we report a type error rather than exploding.+sortKit :: (HasBuiltins m, MonadTCError m, HasOptions m) => m SortKit sortKit = do-  Def set      _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSet-  Def prop     _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinProp-  Def setomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega-  Def sset     _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet-  Def ssetomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSSetOmega+  Def set      _  <- getBuiltin builtinSet+  Def prop     _  <- getBuiltin builtinProp+  Def setomega _  <- getBuiltin builtinSetOmega+  Def sset     _  <- getBuiltin builtinStrictSet+  Def ssetomega _ <- getBuiltin builtinSSetOmega   return $ SortKit     { nameOfSet      = set     , nameOfProp     = prop@@ -472,6 +508,25 @@         IsStrict  -> ssetomega     } +-- | Compute a 'SortKit' in contexts that do not support failure (e.g.+-- 'Reify'). This should only be used when we are sure that the+-- primitive sorts have been bound, i.e. because it is "after" type+-- checking.+infallibleSortKit :: HasBuiltins m => m SortKit+infallibleSortKit = do+  Def set      _  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSet+  Def prop     _  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinProp+  Def setomega _  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSetOmega+  Def sset     _  <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinStrictSet+  Def ssetomega _ <- fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinSSetOmega+  return $ SortKit+    { nameOfSet      = set+    , nameOfProp     = prop+    , nameOfSSet     = sset+    , nameOfSetOmega = \case+        IsFibrant -> setomega+        IsStrict  -> ssetomega+    }  ------------------------------------------------------------------------ -- * Path equality@@ -495,6 +550,9 @@ isPrimitive :: HasBuiltins m => String -> QName -> m Bool isPrimitive n q = (Just q ==) <$> getPrimitiveName' n +intervalSort :: Sort+intervalSort = IntervalUniv+ intervalView' :: HasBuiltins m => m (Term -> IntervalView) intervalView' = do   iz <- getBuiltinName' builtinIZero@@ -595,6 +653,23 @@   El s $ Def path $ map Apply [l, t, lhs, rhs]  ------------------------------------------------------------------------+-- * Swan's Id Equality+------------------------------------------------------------------------++-- f x (< phi , p > : Id A x _) = Just (phi,p)+conidView' :: HasBuiltins m => m (Term -> Term -> Maybe (Arg Term,Arg Term))+conidView' = do+  mn <- sequence <$> mapM getName' [builtinReflId, builtinConId]+  mio <- getTerm' builtinIOne+  let fallback = return $ \ _ _ -> Nothing+  caseMaybe mn fallback $ \ [refl,conid] ->+   caseMaybe mio fallback $ \ io -> return $ \ x t ->+    case t of+      Con h _ [] | conName h == refl -> Just (defaultArg io,defaultArg (Lam defaultArgInfo $ NoAbs "_" $ x))+      Def d es | Just [l,a,x,y,phi,p] <- allApplyElims es, d == conid -> Just (phi, p)+      _ -> Nothing++------------------------------------------------------------------------ -- * Builtin equality ------------------------------------------------------------------------ @@ -638,11 +713,18 @@ -- --   Postcondition: type is reduced. -equalityUnview :: EqualityView -> Type-equalityUnview (OtherType t) = t-equalityUnview (IdiomType t) = t-equalityUnview (EqualityType s equality l t lhs rhs) =-  El s $ Def equality $ map Apply (l ++ [t, lhs, rhs])+class EqualityUnview a where+  equalityUnview :: a -> Type++instance EqualityUnview EqualityView where+  equalityUnview = \case+    OtherType t -> t+    IdiomType t -> t+    EqualityViewType eqt -> equalityUnview eqt++instance EqualityUnview EqualityTypeData where+  equalityUnview (EqualityTypeData s equality l t lhs rhs) =+    El s $ Def equality $ map Apply (l ++ [t, lhs, rhs])  -- | Primitives with typechecking constrants. constrainedPrims :: [String]
src/full/Agda/TypeChecking/Monad/Constraints.hs view
@@ -11,6 +11,7 @@ import qualified Data.Set as Set import Data.Semigroup ((<>)) +import Agda.Interaction.Options.Base import Agda.Syntax.Internal import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Closure@@ -173,7 +174,7 @@ addAndUnblocker :: MonadBlock m => Blocker -> m a -> m a addAndUnblocker u   | u == alwaysUnblock = id-  | otherwise          = catchPatternErr $ \ u' -> patternViolation (u <> u')+  | otherwise          = catchPatternErr $ \ u' -> patternViolation (unblockOnBoth u u')  addOrUnblocker :: MonadBlock m => Blocker -> m a -> m a addOrUnblocker u@@ -201,6 +202,7 @@       FindInstance{}   -> False       HasBiggerSort{}  -> False       HasPTSRule{}     -> False+      CheckDataSort{}  -> False       ValueCmp{}       -> True       ValueCmpOnFace{} -> True       ElimCmp{}        -> True@@ -224,6 +226,24 @@ -- | Add constraint if the action raises a pattern violation catchConstraint :: MonadConstraint m => Constraint -> m () -> m () catchConstraint c = catchPatternErr $ \ unblock -> addConstraint unblock c++isInstanceConstraint :: Constraint -> Bool+isInstanceConstraint FindInstance{} = True+isInstanceConstraint _              = False++shouldPostponeInstanceSearch :: (ReadTCState m, HasOptions m) => m Bool+shouldPostponeInstanceSearch =+  and2M ((^. stConsideringInstance) <$> getTCState)+        (not . optOverlappingInstances <$> pragmaOptions)+  `or2M` ((^. stPostponeInstanceSearch) <$> getTCState)++-- | Wake constraints matching the given predicate (and aren't instance+--   constraints if 'shouldPostponeInstanceSearch').+wakeConstraints' :: MonadConstraint m => (ProblemConstraint -> WakeUp) -> m ()+wakeConstraints' p = do+  skipInstance <- shouldPostponeInstanceSearch+  let skip c = skipInstance && isInstanceConstraint (clValue $ theConstraint c)+  wakeConstraints $ wakeUpWhen (not . skip) p  --------------------------------------------------------------------------- -- * Lenses
src/full/Agda/TypeChecking/Monad/Context.hs view
@@ -1,6 +1,9 @@  module Agda.TypeChecking.Monad.Context where +import Data.Text (Text)+import qualified Data.Text as T+ import Control.Monad                ( (<=<), forM, when ) import Control.Monad.Except import Control.Monad.Reader@@ -8,10 +11,12 @@ import Control.Monad.Trans.Control  ( MonadTransControl(..), liftThrough ) import Control.Monad.Trans.Identity ( IdentityT ) import Control.Monad.Trans.Maybe-import Control.Monad.Writer+import Control.Monad.Writer         ( WriterT ) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) +import qualified Data.DList as DL+import Data.Foldable import qualified Data.List as List import qualified Data.Map as Map @@ -122,7 +127,7 @@   -- created under refined parent parameters, but as long as those modules   -- aren't named we shouldn't look at the checkpoint. The right thing to do   -- would be to not store these modules in the checkpoint map, but todo..-  stModuleCheckpoints `setTCLens` Map.union oldMods (old <$ Map.difference newMods oldMods)+  stModuleCheckpoints `setTCLens` Map.union oldMods (old <$ newMods)   unlessDebugPrinting $ reportSLn "tc.cxt.checkpoint" 105 "}"   return x @@ -228,19 +233,22 @@         setTCLens stUsedNames Map.empty         result <- f         newUsedNames <- useTC stUsedNames-        setTCLens stUsedNames $ Map.unionWith (++) origUsedNames newUsedNames+        setTCLens stUsedNames $ Map.unionWith (<>) origUsedNames newUsedNames         return (result , newUsedNames)        tellUsedName x = do         let concreteX = nameConcrete x             rawX      = nameToRawName concreteX             rootX     = nameRoot concreteX-        modifyTCLens (stUsedNames . key rootX) $ Just . (rawX:) . concat+        modifyTCLens (stUsedNames . key rootX) $+          Just . (rawX `DL.cons`) . fold        tellShadowing x useds = case Map.lookup (nameRoot $ nameConcrete x) useds of         Just shadows -> do-          reportSDoc "tc.cxt.shadowing" 80 $ pure $ "names shadowing" <+> pretty x <+> ": " <+> prettyList_ (map pretty shadows)-          modifyTCLens stShadowingNames $ Map.insertWith (++) x shadows+          reportSDoc "tc.cxt.shadowing" 80 $ pure $+            "names shadowing" <+> pretty x <+> ": " <+>+            prettyList_ (map pretty $ toList shadows)+          modifyTCLens stShadowingNames $ Map.insertWith (<>) x shadows         Nothing      -> return ()  instance MonadAddContext TCM where@@ -331,6 +339,10 @@     withFreshName noRange s $ \x -> addCtx (setNotInScope x) dom ret   contextSize _ = 1 +instance AddContext (Text, Dom Type) where+  addContext (s, dom) ret = addContext (T.unpack s, dom) ret+  contextSize _ = 1+ instance AddContext (KeepNames String, Dom Type) where   addContext (KeepNames s, dom) ret =     withFreshName noRange s $ \ x -> addCtx x dom ret@@ -414,8 +426,8 @@ -- * Querying the context  -- | Get the current context.-{-# SPECIALIZE getContext :: TCM [Dom (Name, Type)] #-}-getContext :: MonadTCEnv m => m [Dom (Name, Type)]+{-# SPECIALIZE getContext :: TCM Context #-}+getContext :: MonadTCEnv m => m Context getContext = asksTC envContext  -- | Get the size of the current context.@@ -446,8 +458,8 @@  -- | get type of bound variable (i.e. deBruijn index) ---{-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe (Dom (Name, Type))) #-}-lookupBV' :: MonadTCEnv m => Nat -> m (Maybe (Dom (Name, Type)))+{-# SPECIALIZE lookupBV' :: Nat -> TCM (Maybe ContextEntry) #-}+lookupBV' :: MonadTCEnv m => Nat -> m (Maybe ContextEntry) lookupBV' n = do   ctx <- getContext   return $ raise (n + 1) <$> ctx !!! n
src/full/Agda/TypeChecking/Monad/Debug.hs view
@@ -7,6 +7,7 @@ import qualified Control.Exception as E import qualified Control.DeepSeq as DeepSeq (force) +import Control.Applicative          ( liftA2 ) import Control.Monad.IO.Class       ( MonadIO(..) ) import Control.Monad.Except import Control.Monad.Reader@@ -17,6 +18,9 @@ import Control.Monad.Writer  import Data.Maybe+import Data.Time                    ( getCurrentTime, getCurrentTimeZone, utcToLocalTime )+import Data.Time.Format.ISO8601.Compat ( iso8601Show )+  -- This is also exported from Data.Time.Format.ISO8601, but only from time >= 1.9  import {-# SOURCE #-} Agda.TypeChecking.Errors import Agda.TypeChecking.Monad.Base@@ -29,8 +33,10 @@ import Agda.Utils.List import Agda.Utils.ListT import Agda.Utils.Maybe+import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Pretty+import Agda.Utils.ProfileOptions import Agda.Utils.Update import qualified Agda.Utils.Trie as Trie @@ -45,6 +51,7 @@   verboseBracket     :: VerboseKey -> VerboseLevel -> String -> m a -> m a    getVerbosity       :: m Verbosity+  getProfileOptions  :: m ProfileOptions    -- | Check whether we are currently debug printing.   isDebugPrinting    :: m Bool@@ -74,6 +81,11 @@     => m Verbosity   getVerbosity = lift getVerbosity +  default getProfileOptions+    :: (MonadTrans t, MonadDebug n, m ~ t n)+    => m ProfileOptions+  getProfileOptions = lift getProfileOptions+   default isDebugPrinting     :: (MonadTrans t, MonadDebug n, m ~ t n)     => m Bool@@ -90,6 +102,9 @@ defaultGetVerbosity :: HasOptions m => m Verbosity defaultGetVerbosity = optVerbose <$> pragmaOptions +defaultGetProfileOptions :: HasOptions m => m ProfileOptions+defaultGetProfileOptions = optProfiling <$> pragmaOptions+ defaultIsDebugPrinting :: MonadTCEnv m => m Bool defaultIsDebugPrinting = asksTC envIsDebugPrinting @@ -124,8 +139,21 @@     -- Force any lazy 'Impossible' exceptions to the surface and handle them.     s  <- liftIO . catchAndPrintImpossible k n . E.evaluate . DeepSeq.force $ s     cb <- getsTC $ stInteractionOutputCallback . stPersistentState-    cb (Resp_RunningInfo n s)++    -- Andreas, 2022-06-15, prefix with time stamp if `-v debug.time:100`:+    msg <- ifNotM (hasVerbosity "debug.time" 100) {-then-} (return s) {-else-} $ do+      now <- liftIO $ trailingZeros . iso8601Show <$> liftA2 utcToLocalTime getCurrentTimeZone getCurrentTime+      return $ concat [ now, ": ", s ]++    cb $ Resp_RunningInfo n msg     cont+    where+    -- Surprisingly, iso8601Show gives us _up to_ 6 fractional digits (microseconds),+    -- but not exactly 6.  https://github.com/haskell/time/issues/211+    -- So we need to do the padding ourselves.+    -- yyyy-mm-ddThh:mm:ss.ssssss+    -- 12345678901234567890123456+    trailingZeros = take 26 . (++ repeat '0')    formatDebugMessage k n d = catchAndPrintImpossible k n $ do     render <$> d `catchError` \ err -> do@@ -144,9 +172,10 @@       closeVerboseBracketException k n       throwError e -  getVerbosity     = defaultGetVerbosity-  isDebugPrinting  = defaultIsDebugPrinting-  nowDebugPrinting = defaultNowDebugPrinting+  getVerbosity      = defaultGetVerbosity+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting  -- MonadTrans default instances @@ -263,27 +292,40 @@ --   reportSLn --   reportSDoc -parseVerboseKey :: VerboseKey -> [String]-parseVerboseKey = wordsBy (`elem` (".:" :: String))- -- | Check whether a certain verbosity level is activated. -- --   Precondition: The level must be non-negative. {-# SPECIALIZE hasVerbosity :: VerboseKey -> VerboseLevel -> TCM Bool #-} hasVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m Bool-hasVerbosity k n | n < 0     = __IMPOSSIBLE__-                 | otherwise = do-    t <- getVerbosity-    let ks = parseVerboseKey k-        m  = lastWithDefault 0 $ Trie.lookupPath ks t-    return (n <= m)+hasVerbosity k n = do+  t <- getVerbosity+  return $ case t of+    Strict.Nothing -> n <= 1+    Strict.Just t+      -- This code is not executed if no debug flags have been given.+      | t == Trie.singleton [] 0 ->+        -- A special case for "-v0".+        n <= 0+      | otherwise ->+        let ks = parseVerboseKey k+            m  = lastWithDefault 0 $ Trie.lookupPath ks t+        in n <= m  -- | Check whether a certain verbosity level is activated (exact match).  {-# SPECIALIZE hasExactVerbosity :: VerboseKey -> VerboseLevel -> TCM Bool #-} hasExactVerbosity :: MonadDebug m => VerboseKey -> VerboseLevel -> m Bool-hasExactVerbosity k n =-  (Just n ==) . Trie.lookup (parseVerboseKey k) <$> getVerbosity+hasExactVerbosity k n = do+  t <- getVerbosity+  return $ case t of+    Strict.Nothing -> n == 1+    Strict.Just t+      -- This code is not executed if no debug flags have been given.+      | t == Trie.singleton [] 0 ->+        -- A special case for "-v0".+        n == 0+      | otherwise ->+        Just n == Trie.lookup (parseVerboseKey k) t  -- | Run a computation if a certain verbosity level is activated (exact match). @@ -312,13 +354,11 @@ applyWhenVerboseS :: MonadDebug m => VerboseKey -> VerboseLevel -> (m a -> m a) -> m a -> m a applyWhenVerboseS k n f a = ifM (hasVerbosity k n) (f a) a --- | Verbosity lens.-verbosity :: VerboseKey -> Lens' VerboseLevel TCState-verbosity k = stPragmaOptions . verbOpt . Trie.valueAt (parseVerboseKey k) . defaultTo 0-  where-    verbOpt :: Lens' Verbosity PragmaOptions-    verbOpt f opts = f (optVerbose opts) <&> \ v -> opts { optVerbose = v }-    -- Andreas, 2019-08-20: this lens should go into Interaction.Option.Lenses!+-- | Check whether a certain profile option is activated.+{-# SPECIALIZE hasProfileOption :: ProfileOption -> TCM Bool #-}+hasProfileOption :: MonadDebug m => ProfileOption -> m Bool+hasProfileOption opt = containsProfileOption opt <$> getProfileOptions -    defaultTo :: Eq a => a -> Lens' a (Maybe a)-    defaultTo x f m = filterMaybe (== x) <$> f (fromMaybe x m)+-- | Run some code when the given profiling option is active.+whenProfile :: MonadDebug m => ProfileOption -> m () -> m ()+whenProfile opt = whenM (hasProfileOption opt)
src/full/Agda/TypeChecking/Monad/Env.hs view
@@ -8,6 +8,7 @@  import Agda.Syntax.Common import Agda.Syntax.Abstract.Name+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad.Base
src/full/Agda/TypeChecking/Monad/Imports.hs view
@@ -7,11 +7,9 @@   , getDecodedModule   , getDecodedModules   , getImportPath-  , getImports   , getPrettyVisitedModules   , getVisitedModule   , getVisitedModules-  , isImported   , setDecodedModules   , setVisitedModules   , storeDecodedModule@@ -22,12 +20,11 @@ import Control.Arrow   ( (***) ) import Control.Monad   ( when ) -import Data.Set (Set)+import qualified Data.HashSet as HSet import qualified Data.Map as Map-import qualified Data.Set as Set  import Agda.Syntax.Abstract.Name-import qualified Agda.Syntax.Concrete.Name as C+import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base  import Agda.Utils.List ( caseListM )@@ -36,26 +33,20 @@  import Agda.Utils.Impossible -addImport :: ModuleName -> TCM ()-addImport m = modifyTCLens stImportedModules $ Set.insert m+addImport :: TopLevelModuleName -> TCM ()+addImport top = modifyTCLens' stImportedModules $ HSet.insert top -addImportCycleCheck :: C.TopLevelModuleName -> TCM a -> TCM a+addImportCycleCheck :: TopLevelModuleName -> TCM a -> TCM a addImportCycleCheck m =     localTC $ \e -> e { envImportPath = m : envImportPath e } -getImports :: TCM (Set ModuleName)-getImports = useTC stImportedModules--isImported :: ModuleName -> TCM Bool-isImported m = Set.member m <$> getImports--getImportPath :: TCM [C.TopLevelModuleName]+getImportPath :: TCM [TopLevelModuleName] getImportPath = asksTC envImportPath  visitModule :: ModuleInfo -> TCM () visitModule mi =   modifyTCLens stVisitedModules $-    Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi+    Map.insert (iTopLevelModuleName $ miInterface mi) mi  setVisitedModules :: VisitedModules -> TCM () setVisitedModules ms = setTCLens stVisitedModules ms@@ -74,7 +65,7 @@   prettyCheckMode ModuleScopeChecked                 = " (scope only)"  getVisitedModule :: ReadTCState m-                 => C.TopLevelModuleName+                 => TopLevelModuleName                  -> m (Maybe ModuleInfo) getVisitedModule x = Map.lookup x <$> useTC stVisitedModules @@ -85,19 +76,19 @@ setDecodedModules ms = modifyTC $ \s ->   s { stPersistentState = (stPersistentState s) { stDecodedModules = ms } } -getDecodedModule :: C.TopLevelModuleName -> TCM (Maybe ModuleInfo)+getDecodedModule :: TopLevelModuleName -> TCM (Maybe ModuleInfo) getDecodedModule x = Map.lookup x . stDecodedModules . stPersistentState <$> getTC  storeDecodedModule :: ModuleInfo -> TCM () storeDecodedModule mi = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =-          Map.insert (toTopLevelModuleName $ iModuleName $ miInterface mi) mi $+          Map.insert (iTopLevelModuleName $ miInterface mi) mi $             stDecodedModules (stPersistentState s)         }   } -dropDecodedModule :: C.TopLevelModuleName -> TCM ()+dropDecodedModule :: TopLevelModuleName -> TCM () dropDecodedModule x = modifyTC $ \s ->   s { stPersistentState =         (stPersistentState s) { stDecodedModules =@@ -105,7 +96,7 @@                               }   } -withImportPath :: [C.TopLevelModuleName] -> TCM a -> TCM a+withImportPath :: [TopLevelModuleName] -> TCM a -> TCM a withImportPath path = localTC $ \e -> e { envImportPath = path }  -- | Assumes that the first module in the import path is the module we are
src/full/Agda/TypeChecking/Monad/MetaVars.hs view
@@ -4,25 +4,28 @@  import Prelude hiding (null) -import Control.DeepSeq--import Control.Monad                ( (<=<), guard )-import Control.Monad.Except-import Control.Monad.State+import Control.Monad                ( (<=<), forM_, guard )+import Control.Monad.Except         ( MonadError )+import Control.Monad.State          ( StateT, execStateT, get, put )+import Control.Monad.Trans          ( MonadTrans, lift ) import Control.Monad.Trans.Identity ( IdentityT )-import Control.Monad.Reader-import Control.Monad.Writer+import Control.Monad.Reader         ( ReaderT(ReaderT), runReaderT )+import Control.Monad.Writer         ( WriterT, execWriterT, tell ) -- Control.Monad.Fail import is redundant since GHC 8.8.1 import Control.Monad.Fail (MonadFail) +import qualified Data.HashMap.Strict as HMap import qualified Data.IntMap as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List+import qualified Data.Map.Strict as MapS import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Foldable as Fold +import GHC.Stack (HasCallStack)+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.MetaVars@@ -33,15 +36,18 @@ import Agda.TypeChecking.Monad.Builtin (HasBuiltins) import Agda.TypeChecking.Monad.Trace import Agda.TypeChecking.Monad.Closure-import Agda.TypeChecking.Monad.Constraints (MonadConstraint)-import Agda.TypeChecking.Monad.Debug (MonadDebug, reportSLn)+import Agda.TypeChecking.Monad.Constraints (MonadConstraint(..))+import Agda.TypeChecking.Monad.Debug+  (MonadDebug, reportSLn, __IMPOSSIBLE_VERBOSE__) import Agda.TypeChecking.Monad.Context import Agda.TypeChecking.Monad.Signature (HasConstInfo)+import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Substitute import {-# SOURCE #-} Agda.TypeChecking.Telescope  import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Functor ((<.>))+import Agda.Utils.Lens import Agda.Utils.List (nubOn) import Agda.Utils.Maybe import Agda.Utils.Monad@@ -104,8 +110,8 @@   -- metas.   assignTerm' :: MonadMetaSolver m => MetaId -> [Arg ArgName] -> Term -> m () -  -- | Eta expand a metavariable, if it is of the specified kind.-  --   Don't do anything if the metavariable is a blocked term.+  -- | Eta-expand a local meta-variable, if it is of the specified+  -- kind. Don't do anything if the meta-variable is a blocked term.   etaExpandMeta :: [MetaKind] -> MetaId -> m ()    -- | Update the status of the metavariable@@ -116,89 +122,219 @@   --    rolled back and 'fallback' is run instead.   speculateMetas :: m () -> m KeepMetas -> m () +instance MonadMetaSolver m => MonadMetaSolver (ReaderT r m) where+  newMeta' inst f i p perm j = lift $ newMeta' inst f i p perm j+  assignV dir m us v cmp = lift $ assignV dir m us v cmp+  assignTerm' m us v = lift $ assignTerm' m us v+  etaExpandMeta k m = lift $ etaExpandMeta k m+  updateMetaVar m f = lift $ updateMetaVar m f+  speculateMetas fallback m = ReaderT $ \x -> speculateMetas (runReaderT fallback x) (runReaderT m x)+ -- | Switch off assignment of metas. dontAssignMetas :: (MonadTCEnv m, HasOptions m, MonadDebug m) => m a -> m a dontAssignMetas cont = do   reportSLn "tc.meta" 45 $ "don't assign metas"   localTC (\ env -> env { envAssignMetas = False }) cont --- | Get the meta store.-getMetaStore :: (ReadTCState m) => m MetaStore-getMetaStore = useR stMetaStore+-- | Is the meta-variable from another top-level module? -modifyMetaStore :: (MetaStore -> MetaStore) -> TCM ()-modifyMetaStore f = stMetaStore `modifyTCLens` f+isRemoteMeta :: ReadTCState m => m (MetaId -> Bool)+isRemoteMeta = do+  h <- currentModuleNameHash+  return (\m -> h /= metaModule m) +-- | If another meta-variable is created, then it will get this+-- 'MetaId' (unless the state is changed too much, for instance by+-- 'setTopLevelModule').++nextLocalMeta :: ReadTCState m => m MetaId+nextLocalMeta = useR stFreshMetaId++-- | Pairs of local meta-stores.++data LocalMetaStores = LocalMetaStores+  { openMetas :: LocalMetaStore+    -- ^ A 'MetaStore' containing open meta-variables.+  , solvedMetas :: LocalMetaStore+    -- ^ A 'MetaStore' containing instantiated meta-variables.+  }+ -- | Run a computation and record which new metas it created.-metasCreatedBy :: ReadTCState m => m a -> m (a, MetaStore)+metasCreatedBy ::+  forall m a. ReadTCState m => m a -> m (a, LocalMetaStores) metasCreatedBy m = do-  -- Compute largestMeta strictly to avoid leaking memory.-  !largestMeta <- force . fmap fst . IntMap.lookupMax <$>-                    useTC stMetaStore-  a            <- m-  ms           <- useTC stMetaStore-  let createdMetas = case largestMeta of-        Nothing          -> ms-        Just largestMeta -> snd $ IntMap.split largestMeta ms-  return (a, createdMetas)+  !nextMeta <- nextLocalMeta+  a         <- m+  os        <- created stOpenMetaStore   nextMeta+  ss        <- created stSolvedMetaStore nextMeta+  return (a, LocalMetaStores { openMetas = os, solvedMetas = ss })+  where+  created :: Lens' LocalMetaStore TCState -> MetaId -> m LocalMetaStore+  created store next = do+    ms <- useTC store+    return $ case MapS.splitLookup next ms of+      (_, Nothing, ms) -> ms+      (_, Just m,  ms) -> MapS.insert next m ms --- | Lookup a meta variable.-lookupMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)-lookupMeta' m = IntMap.lookup (metaId m) <$> getMetaStore+-- | Find information about the given local meta-variable, if any. -lookupMeta :: (MonadFail m, ReadTCState m) => MetaId -> m MetaVariable-lookupMeta m = fromMaybeM failure $ lookupMeta' m-  where failure = fail $ "no such meta variable " ++ prettyShow m+lookupLocalMeta' :: ReadTCState m => MetaId -> m (Maybe MetaVariable)+lookupLocalMeta' m = do+  mv <- lkup <$> useR stSolvedMetaStore+  case mv of+    mv@Just{} -> return mv+    Nothing   -> lkup <$> useR stOpenMetaStore+  where+  lkup = MapS.lookup m --- | Type of a term or sort meta.-metaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type-metaType x = jMetaType . mvJudgement <$> lookupMeta x+-- | Find information about the given local meta-variable. --- | Update the information associated with a meta variable.-updateMetaVarTCM :: MetaId -> (MetaVariable -> MetaVariable) -> TCM ()-updateMetaVarTCM m f = modifyMetaStore $ IntMap.adjust f $ metaId m+lookupLocalMeta ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaVariable+lookupLocalMeta m =+  fromMaybeM (__IMPOSSIBLE_VERBOSE__ err) $ lookupLocalMeta' m+  where+  err = "no such local meta-variable " ++ prettyShow m --- | Insert a new meta variable with associated information into the meta store.+-- | Find information about the (local or remote) meta-variable, if+-- any.+--+-- If no meta-variable is found, then the reason could be that the+-- dead-code elimination+-- ('Agda.TypeChecking.DeadCode.eliminateDeadCode') failed to find the+-- meta-variable, perhaps because some 'NamesIn' instance is+-- incorrectly defined.++lookupMeta ::+  ReadTCState m =>+  MetaId -> m (Maybe (Either RemoteMetaVariable MetaVariable))+lookupMeta m = do+  mv <- lookupLocalMeta' m+  case mv of+    Just mv -> return (Just (Right mv))+    Nothing -> fmap Left . HMap.lookup m <$> useR stImportedMetaStore++-- | Find the meta-variable's instantiation.++lookupMetaInstantiation ::+  ReadTCState m => MetaId -> m MetaInstantiation+lookupMetaInstantiation m = do+  mi <- lookupMeta m+  case mi of+    Just (Left mv)  -> return (InstV $ rmvInstantiation mv)+    Just (Right mv) -> return (mvInstantiation mv)+    Nothing         -> __IMPOSSIBLE__++-- | Find the meta-variable's judgement.++lookupMetaJudgement :: ReadTCState m => MetaId -> m (Judgement MetaId)+lookupMetaJudgement m = do+  mi <- lookupMeta m+  case mi of+    Just (Left mv)  -> return (rmvJudgement mv)+    Just (Right mv) -> return (mvJudgement mv)+    Nothing         -> __IMPOSSIBLE__++-- | Find the meta-variable's modality.++lookupMetaModality :: ReadTCState m => MetaId -> m Modality+lookupMetaModality m = do+  mi <- lookupMeta m+  case mi of+    Just (Left mv)  -> return (rmvModality mv)+    Just (Right mv) -> return (getModality mv)+    Nothing         -> __IMPOSSIBLE__++-- | The type of a term or sort meta-variable.+metaType :: ReadTCState m => MetaId -> m Type+metaType x = jMetaType <$> lookupMetaJudgement x++-- | Update the information associated with a local meta-variable.+updateMetaVarTCM ::+  HasCallStack => MetaId -> (MetaVariable -> MetaVariable) -> TCM ()+updateMetaVarTCM m f = do+  mv <- lookupLocalMeta' m+  case mv of+    Nothing -> do+      mv <- lookupMeta m+      case mv of+        Nothing -> __IMPOSSIBLE_VERBOSE__+                     ("Meta-variable not found: " ++ prettyShow m)+        Just{}  -> __IMPOSSIBLE_VERBOSE__+                     ("Attempt to update remote meta-variable: " +++                      prettyShow m)+    Just mv -> do+      let mv'    = f mv+          insert = (`modifyTCLens` MapS.insert m mv')+          delete = (`modifyTCLens` MapS.delete m)+      case ( isOpenMeta (mvInstantiation mv)+           , isOpenMeta (mvInstantiation mv')+           ) of+        (True,  True)  -> insert stOpenMetaStore+        (False, False) -> insert stSolvedMetaStore+        (True,  False) -> do+          delete stOpenMetaStore+          insert stSolvedMetaStore+        (False, True)  -> __IMPOSSIBLE__++-- | Insert a new meta-variable with associated information into the+-- local meta store. insertMetaVar :: MetaId -> MetaVariable -> TCM ()-insertMetaVar m mv = modifyMetaStore $ IntMap.insert (metaId m) mv+insertMetaVar m mv+  | isOpenMeta (mvInstantiation mv) = insert stOpenMetaStore+  | otherwise                       = insert stSolvedMetaStore+  where+  insert = (`modifyTCLens` MapS.insert m mv) -getMetaPriority :: (MonadFail m, ReadTCState m) => MetaId -> m MetaPriority-getMetaPriority = mvPriority <.> lookupMeta+-- | Returns the 'MetaPriority' of the given local meta-variable.+getMetaPriority ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaPriority+getMetaPriority = mvPriority <.> lookupLocalMeta -isSortMeta :: (MonadFail m, ReadTCState m) => MetaId -> m Bool-isSortMeta m = isSortMeta_ <$> lookupMeta m+isSortMeta :: ReadTCState m => MetaId -> m Bool+isSortMeta m = isSortJudgement <$> lookupMetaJudgement m  isSortMeta_ :: MetaVariable -> Bool-isSortMeta_ mv = case mvJudgement mv of-    HasType{} -> False-    IsSort{}  -> True+isSortMeta_ mv = isSortJudgement (mvJudgement mv) -getMetaType :: (MonadFail m, ReadTCState m) => MetaId -> m Type+isSortJudgement :: Judgement a -> Bool+isSortJudgement HasType{} = False+isSortJudgement IsSort{}  = True++getMetaType :: ReadTCState m => MetaId -> m Type getMetaType m = do-  mv <- lookupMeta m-  return $ case mvJudgement mv of+  j <- lookupMetaJudgement m+  return $ case j of     HasType{ jMetaType = t } -> t     IsSort{}  -> __IMPOSSIBLE__ --- | Compute the context variables that a meta should be applied to, accounting---   for pruning.+-- | Compute the context variables that a local meta-variable should+-- be applied to, accounting for pruning. getMetaContextArgs :: MonadTCEnv m => MetaVariable -> m Args getMetaContextArgs MetaVar{ mvPermutation = p } = do   args <- getContextArgs   return $ permute (takeP (length args) p) args --- | Given a meta, return the type applied to the current context.-getMetaTypeInContext :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadReduce m, HasBuiltins m)-                     => MetaId -> m Type+-- | Given a local meta-variable, return the type applied to the+-- current context.+getMetaTypeInContext ::+  (HasBuiltins m, HasCallStack, MonadDebug m, MonadReduce m,+   MonadTCEnv m, ReadTCState m) =>+  MetaId -> m Type getMetaTypeInContext m = do-  mv@MetaVar{ mvJudgement = j } <- lookupMeta m+  mv@MetaVar{ mvJudgement = j } <- lookupLocalMeta m   case j of     HasType{ jMetaType = t } -> piApplyM t =<< getMetaContextArgs mv     IsSort{}                 -> __IMPOSSIBLE__ --- | Is it a meta that might be generalized?-isGeneralizableMeta :: (ReadTCState m, MonadFail m) => MetaId -> m DoGeneralize-isGeneralizableMeta x = unArg . miGeneralizable . mvInfo <$> lookupMeta x+-- | Is it a local meta-variable that might be generalized?+isGeneralizableMeta ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m DoGeneralize+isGeneralizableMeta x =+  unArg . miGeneralizable . mvInfo <$> lookupLocalMeta x  -- | Check whether all metas are instantiated. --   Precondition: argument is a meta (in some form) or a list of metas.@@ -242,11 +378,10 @@  isInstantiatedMeta' :: (MonadFail m, ReadTCState m) => MetaId -> m (Maybe Term) isInstantiatedMeta' m = do-  mv <- lookupMeta m-  return $ case mvInstantiation mv of-    InstV tel v -> Just $ foldr mkLam v tel-    _           -> Nothing-+  inst <- lookupMetaInstantiation m+  return $ case inst of+    InstV inst -> Just $ foldr mkLam (instBody inst) (instTel inst)+    _          -> Nothing  -- | Returns all metavariables in a constraint. Slightly complicated by the --   fact that blocked terms are represented by two meta variables. To find the@@ -279,6 +414,7 @@       CheckSizeLtSat{}         -> return mempty       HasBiggerSort{}          -> return mempty       HasPTSRule{}             -> return mempty+      CheckDataSort{}          -> return mempty       CheckMetaInst x          -> return mempty       CheckType t              -> return $ allMetas Set.singleton t       CheckLockedVars a b c d  -> return $ allMetas Set.singleton (a, b, c, d)@@ -319,8 +455,11 @@         "cannot set meta name; newMeta returns " ++ show u       return () -getMetaNameSuggestion :: (MonadFail m, ReadTCState m) => MetaId -> m MetaNameSuggestion-getMetaNameSuggestion mi = miNameSuggestion . mvInfo <$> lookupMeta mi+getMetaNameSuggestion ::+  (HasCallStack, MonadDebug m, ReadTCState m) =>+  MetaId -> m MetaNameSuggestion+getMetaNameSuggestion mi =+  miNameSuggestion . mvInfo <$> lookupLocalMeta mi  setMetaNameSuggestion :: MonadMetaSolver m => MetaId -> MetaNameSuggestion -> m () setMetaNameSuggestion mi s = unless (null s || isUnderscore s) $ do@@ -329,7 +468,8 @@   updateMetaVar mi $ \ mvar ->     mvar { mvInfo = (mvInfo mvar) { miNameSuggestion = s }} --- | Change the ArgInfo that will be used when generalizing over this meta.+-- | Change the ArgInfo that will be used when generalizing over this+-- local meta-variable. setMetaGeneralizableArgInfo :: MonadMetaSolver m => MetaId -> ArgInfo -> m () setMetaGeneralizableArgInfo m i = updateMetaVar m $ \ mv ->   mv { mvInfo = (mvInfo mv)@@ -413,7 +553,7 @@     sameRange (ii, InteractionPoint r' _ False _) | r == r' = Just ii     sameRange _ = Nothing --- | Hook up meta variable to interaction point.+-- | Hook up a local meta-variable to an interaction point. connectInteractionPoint   :: MonadInteractionPoints m   => InteractionId -> MetaId -> m ()@@ -441,16 +581,19 @@ getInteractionMetas =   mapMaybe ipMeta . filter (not . ipSolved) . BiMap.elems <$> useR stInteractionPoints -getUniqueMetasRanges :: (MonadFail m, ReadTCState m) => [MetaId] -> m [Range]+getUniqueMetasRanges ::+  (HasCallStack, MonadDebug m, ReadTCState m) => [MetaId] -> m [Range] getUniqueMetasRanges = fmap (nubOn id) . mapM getMetaRange -getUnsolvedMetas :: (MonadFail m, ReadTCState m) => m [Range]+getUnsolvedMetas ::+  (HasCallStack, MonadDebug m, ReadTCState m) => m [Range] getUnsolvedMetas = do   openMetas            <- getOpenMetas   interactionMetas     <- getInteractionMetas   getUniqueMetasRanges (openMetas List.\\ interactionMetas) -getUnsolvedInteractionMetas :: (MonadFail m, ReadTCState m) => m [Range]+getUnsolvedInteractionMetas ::+  (HasCallStack, MonadDebug m, ReadTCState m) => m [Range] getUnsolvedInteractionMetas = getUniqueMetasRanges =<< getInteractionMetas  -- | Get all metas that correspond to unsolved interaction ids.@@ -523,14 +666,17 @@   => InteractionId -> m Range getInteractionRange = ipRange <.> lookupInteractionPoint --- | Get the 'Range' for a meta variable.-getMetaRange :: (MonadFail m, ReadTCState m) => MetaId -> m Range-getMetaRange = getRange <.> lookupMeta+-- | Get the 'Range' for a local meta-variable.+getMetaRange ::+  (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Range+getMetaRange = getRange <.> lookupLocalMeta -getInteractionScope-  :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m)-  => InteractionId -> m ScopeInfo-getInteractionScope = getMetaScope <.> lookupMeta <=< lookupInteractionId+getInteractionScope ::+  (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m,+   MonadTCEnv m) =>+  InteractionId -> m ScopeInfo+getInteractionScope =+  getMetaScope <.> lookupLocalMeta <=< lookupInteractionId  withMetaInfo' :: (MonadTCEnv m, ReadTCState m, MonadTrace m) => MetaVariable -> m a -> m a withMetaInfo' mv = withMetaInfo (miClosRange $ mvInfo mv)@@ -539,27 +685,24 @@ withMetaInfo mI cont = enterClosure mI $ \ r ->   setCurrentRange r cont -withInteractionId-  :: (MonadFail m, ReadTCState m, MonadError TCErr m, MonadTCEnv m, MonadTrace m)-  => InteractionId -> m a -> m a+withInteractionId ::+  (MonadDebug m, MonadFail m, ReadTCState m, MonadError TCErr m,+   MonadTCEnv m, MonadTrace m) =>+  InteractionId -> m a -> m a withInteractionId i ret = do   m <- lookupInteractionId i   withMetaId m ret -withMetaId-  :: (MonadFail m, MonadTCEnv m, ReadTCState m, MonadTrace m)-  => MetaId -> m a -> m a+withMetaId ::+  (HasCallStack, MonadDebug m, MonadTCEnv m, MonadTrace m,+   ReadTCState m) =>+  MetaId -> m a -> m a withMetaId m ret = do-  mv <- lookupMeta m+  mv <- lookupLocalMeta m   withMetaInfo' mv ret -getMetaVariables :: ReadTCState m => (MetaVariable -> Bool) -> m [MetaId]-getMetaVariables p = do-  store <- getMetaStore-  return [ MetaId i | (i, mv) <- IntMap.assocs store, p mv ]- getOpenMetas :: ReadTCState m => m [MetaId]-getOpenMetas = getMetaVariables (isOpenMeta . mvInstantiation)+getOpenMetas = MapS.keys <$> useR stOpenMetaStore  isOpenMeta :: MetaInstantiation -> Bool isOpenMeta Open                           = True@@ -579,56 +722,98 @@ unlistenToMeta l m =   updateMetaVar m $ \mv -> mv { mvListeners = Set.delete l $ mvListeners mv } --- | Get the listeners to a meta.-getMetaListeners :: (MonadFail m, ReadTCState m) => MetaId -> m [Listener]-getMetaListeners m = Set.toList . mvListeners <$> lookupMeta m+-- | Get the listeners for a local meta-variable.+getMetaListeners ::+  (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m [Listener]+getMetaListeners m = Set.toList . mvListeners <$> lookupLocalMeta m  clearMetaListeners :: MonadMetaSolver m => MetaId -> m () clearMetaListeners m =   updateMetaVar m $ \mv -> mv { mvListeners = Set.empty } +-- | Do safe eta-expansions for meta (@SingletonRecords,Levels@).+etaExpandMetaSafe :: (MonadMetaSolver m) => MetaId -> m ()+etaExpandMetaSafe = etaExpandMeta [SingletonRecords,Levels]++-- | Eta expand metavariables listening on the current meta.+etaExpandListeners :: MonadMetaSolver m => MetaId -> m ()+etaExpandListeners m = do+  ls <- getMetaListeners m+  clearMetaListeners m  -- we don't really have to do this+  mapM_ wakeupListener ls++-- | Wake up a meta listener and let it do its thing+wakeupListener :: MonadMetaSolver m => Listener -> m ()+  -- Andreas 2010-10-15: do not expand record mvars, lazyness needed for irrelevance+wakeupListener (EtaExpand x)         = etaExpandMetaSafe x+wakeupListener (CheckConstraint _ c) = do+  --reportSDoc "tc.meta.blocked" 20 $ "waking boxed constraint" <+> prettyTCM c+  modifyAwakeConstraints (c:)+  solveAwakeConstraints++solveAwakeConstraints :: (MonadConstraint m) => m ()+solveAwakeConstraints = solveAwakeConstraints' False++solveAwakeConstraints' :: (MonadConstraint m) => Bool -> m ()+solveAwakeConstraints' = solveSomeAwakeConstraints (const True)+ --------------------------------------------------------------------------- -- * Freezing and unfreezing metas. --------------------------------------------------------------------------- --- | Freeze the given meta-variables and return those that were not---   already frozen.-freezeMetas :: MetaStore -> TCM IntSet+-- | Freeze the given meta-variables (but only if they are open) and+-- return those that were not already frozen.+freezeMetas :: MonadTCState m => LocalMetaStore -> m (Set MetaId) freezeMetas ms =   execWriterT $-  modifyTCLensM stMetaStore $-  execStateT (mapM_ freeze $ IntMap.keys ms)+  modifyTCLensM stOpenMetaStore $+  execStateT (mapM_ freeze $ MapS.keys ms)   where-  freeze :: Monad m => Int -> StateT MetaStore (WriterT IntSet m) ()+  freeze ::+    Monad m =>+    MetaId -> StateT LocalMetaStore (WriterT (Set MetaId) m) ()   freeze m = do     store <- get-    case IntMap.lookup m store of+    case MapS.lookup m store of       Just mvar         | mvFrozen mvar /= Frozen -> do-          lift $ tell (IntSet.singleton m)-          put $ IntMap.insert m (mvar { mvFrozen = Frozen }) store+          lift $ tell (Set.singleton m)+          put $ MapS.insert m (mvar { mvFrozen = Frozen }) store         | otherwise -> return ()-      Nothing -> __IMPOSSIBLE__+      Nothing -> return () --- | Thaw all meta variables.+-- | Thaw all open meta variables. unfreezeMetas :: TCM ()-unfreezeMetas = modifyMetaStore $ IntMap.map unfreeze+unfreezeMetas = stOpenMetaStore `modifyTCLens` MapS.map unfreeze   where   unfreeze :: MetaVariable -> MetaVariable   unfreeze mvar = mvar { mvFrozen = Instantiable } -isFrozen :: (MonadFail m, ReadTCState m) => MetaId -> m Bool+isFrozen ::+  (HasCallStack, MonadDebug m, ReadTCState m) => MetaId -> m Bool isFrozen x = do-  mvar <- lookupMeta x+  mvar <- lookupLocalMeta x   return $ mvFrozen mvar == Frozen --- | Unfreeze meta and its type if this is a meta again.---   Does not unfreeze deep occurrences of metas.+withFrozenMetas+  :: (MonadMetaSolver m, MonadTCState m)+  => m a -> m a+withFrozenMetas act = do+  openMetas <- useR stOpenMetaStore+  frozenMetas <- freezeMetas openMetas+  result <- act+  forM_ (Set.toList frozenMetas) $ \m ->+    updateMetaVar m $ \ mv -> mv { mvFrozen = Instantiable }+  return result++-- | Unfreeze a meta and its type if this is a meta again.+--   Does not unfreeze deep occurrences of meta-variables or remote+--   meta-variables. class UnFreezeMeta a where   unfreezeMeta :: MonadMetaSolver m => a -> m ()  instance UnFreezeMeta MetaId where-  unfreezeMeta x = do+  unfreezeMeta x = unlessM (($ x) <$> isRemoteMeta) $ do     updateMetaVar x $ \ mv -> mv { mvFrozen = Instantiable }     unfreezeMeta =<< metaType x
src/full/Agda/TypeChecking/Monad/Mutual.hs view
@@ -66,14 +66,11 @@ currentOrFreshMutualBlock :: TCM MutualId currentOrFreshMutualBlock = maybe fresh return =<< asksTC envMutualBlock -lookupMutualBlock :: MutualId -> TCM MutualBlock-lookupMutualBlock mi = do-  mbs <- useTC stMutualBlocks-  case Map.lookup mi mbs of-    Just mb -> return mb-    Nothing -> return empty -- can end up here if we ask for the current mutual block and there is none+lookupMutualBlock :: ReadTCState tcm => MutualId -> tcm MutualBlock+lookupMutualBlock mi = Map.findWithDefault empty mi <$> useTC stMutualBlocks+   -- can be empty if we ask for the current mutual block and there is none --- | Reverse lookup of a mutual block id for a names.+-- | Reverse lookup of a mutual block id for a name. mutualBlockOf :: QName -> TCM MutualId mutualBlockOf x = do   mb <- Map.toList <$> useTC stMutualBlocks
src/full/Agda/TypeChecking/Monad/Open.hs view
@@ -60,11 +60,9 @@       if m == cur then return o                   else return $ OpenThing (-1) (Map.filterWithKey (\ k _ -> k == 0) env) m x -    findParent m1 m2-      | Set.null keys = empty-      | otherwise     = return $ Set.findMax keys-      where-        keys = Set.intersection (Map.keysSet m1) (Map.keysSet m2)+    findParent m1 m2 = case Map.lookupMax (Map.intersection m1 m2) of+      Nothing       -> empty+      Just (max, _) -> return max  -- | An 'Open' is closed if it has checkpoint 0. isClosed :: Open a -> Bool
src/full/Agda/TypeChecking/Monad/Options.hs view
@@ -1,6 +1,8 @@  module Agda.TypeChecking.Monad.Options where +import Prelude hiding (null)+ import Control.Arrow          ( (&&&) ) import Control.Monad          ( unless, when ) import Control.Monad.IO.Class ( MonadIO(..) )@@ -19,24 +21,28 @@ import System.FilePath  import Agda.Syntax.Common-import Agda.Syntax.Concrete (TopLevelModuleName) import qualified Agda.Syntax.Concrete as C import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.TopLevelModuleName+ import Agda.TypeChecking.Monad.Debug (reportSDoc) import Agda.TypeChecking.Warnings import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Imports import Agda.TypeChecking.Monad.State import Agda.TypeChecking.Monad.Benchmark+ import Agda.Interaction.FindFile import Agda.Interaction.Options import qualified Agda.Interaction.Options.Lenses as Lens import Agda.Interaction.Library+ import Agda.Utils.FileName import Agda.Utils.Functor import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G import Agda.Utils.List import Agda.Utils.Maybe+import Agda.Utils.Null import Agda.Utils.Pretty import Agda.Utils.Tuple import Agda.Utils.WithDefault@@ -44,26 +50,23 @@ import Agda.Utils.Impossible  -- | Sets the pragma options.-+--   Checks for unsafe combinations. setPragmaOptions :: PragmaOptions -> TCM () setPragmaOptions opts = do-  stPragmaOptions `modifyTCLens` Lens.mapSafeMode (Lens.getSafeMode opts ||)-  clo <- commandLineOptions-  let unsafe = unsafePragmaOptions clo opts-  when (Lens.getSafeMode opts && not (null unsafe)) $ warning $ SafeFlagPragma unsafe-  runOptM (checkOpts clo{ optPragmaOptions = opts }) >>= \case-    Left err   -> __IMPOSSIBLE__-    Right opts -> do-      stPragmaOptions `setTCLens` optPragmaOptions opts-      updateBenchmarkingStatus+  -- Check for unsafe pragma options if @--safe@ is on.+  when (Lens.getSafeMode opts) $+    unlessNull (unsafePragmaOptions opts) $ \ unsafe ->+      warning $ SafeFlagPragma unsafe +  stPragmaOptions `setTCLens` opts+  updateBenchmarkingStatus+ -- | Sets the command line options (both persistent and pragma options -- are updated). -- -- Relative include directories are made absolute with respect to the -- current working directory. If the include directories have changed--- (thus, they are 'Left' now, and were previously @'Right' something@),--- then the state is reset (completely, see setIncludeDirs) .+-- then the state is reset (partly, see 'setIncludeDirs'). -- -- An empty list of relative include directories (@'Left' []@) is -- interpreted as @["."]@.@@ -78,9 +81,7 @@   -> CommandLineOptions   -> TCM () setCommandLineOptions' root opts = do-  runOptM (checkOpts opts) >>= \case-    Left err   -> __IMPOSSIBLE__-    Right opts -> do+  -- Andreas, 2022-11-19: removed a call to checkOpts which did nothing.       incs <- case optAbsoluteIncludePaths opts of         [] -> do           opts' <- setLibraryPaths root opts@@ -108,15 +109,27 @@     Left s  -> typeError $ GenericDocError s     Right x -> return x -getAgdaLibFiles :: FilePath -> TCM [AgdaLibFile]-getAgdaLibFiles root = do+-- | Returns the library files for a given file.++getAgdaLibFiles+  :: AbsolutePath        -- ^ The file name.+  -> TopLevelModuleName  -- ^ The top-level module name.+  -> TCM [AgdaLibFile]+getAgdaLibFiles f m = do   useLibs <- optUseLibs <$> commandLineOptions   if | useLibs   -> libToTCM $ mkLibM [] $ getAgdaLibFiles' root      | otherwise -> return []+  where+  root = filePath (projectRoot f m) -getLibraryOptions :: FilePath -> TCM [OptionsPragma]-getLibraryOptions root = map _libPragmas <$> getAgdaLibFiles root+-- | Returns the library options for a given file. +getLibraryOptions+  :: AbsolutePath        -- ^ The file name.+  -> TopLevelModuleName  -- ^ The top-level module name.+  -> TCM [OptionsPragma]+getLibraryOptions f m = map _libPragmas <$> getAgdaLibFiles f m+ setLibraryPaths   :: AbsolutePath      -- ^ The base directory of relative paths.@@ -161,7 +174,9 @@ setOptionsFromPragma :: OptionsPragma -> TCM () setOptionsFromPragma ps = do     opts <- commandLineOptions-    runOptM (parsePragmaOptions ps opts) >>= \case+    let (z, warns) = runOptM (parsePragmaOptions ps opts)+    mapM_ (warning . OptionWarning) warns+    case z of       Left err    -> typeError $ GenericError err       Right opts' -> setPragmaOptions opts' @@ -278,16 +293,16 @@     -- A graph with one node per module in old, and an edge from m to     -- n if the module corresponding to m imports the module     -- corresponding to n.-    dependencyGraph :: G.Graph A.ModuleName ()+    dependencyGraph :: G.Graph TopLevelModuleName ()     dependencyGraph =       G.fromNodes-        [ iModuleName $ miInterface m+        [ iTopLevelModuleName $ miInterface m         | m <- Map.elems old         ]         `G.union`       G.fromEdges         [ G.Edge-            { source = iModuleName $ miInterface m+            { source = iTopLevelModuleName $ miInterface m             , target = d             , label = ()             }@@ -304,17 +319,16 @@                 -- Agda does not allow cycles in the dependency graph.                 __IMPOSSIBLE__               Graph.AcyclicSCC m ->-                case Map.lookup (A.toTopLevelModuleName m) old of+                case Map.lookup m old of                   Just m  -> m                   Nothing -> __IMPOSSIBLE__) $       G.sccs' dependencyGraph      process ::-      Map A.ModuleName ModuleInfo -> ModuleToSource -> [ModuleInfo] ->-      TCM (DecodedModules, ModuleToSource)+      Map TopLevelModuleName ModuleInfo -> ModuleToSource ->+      [ModuleInfo] -> TCM (DecodedModules, ModuleToSource)     process !keep !modFile [] = return       ( Map.fromList $-        map (mapFst A.toTopLevelModuleName) $         Map.toList keep       , modFile       )@@ -323,13 +337,12 @@           depsKept = all (`Map.member` keep) deps       (keep, modFile) <-         if not depsKept then return (keep, modFile) else do-        let n = iModuleName $ miInterface m-            t = A.toTopLevelModuleName n+        let t = iTopLevelModuleName $ miInterface m         oldF            <- findFile' t         (newF, modFile) <- liftIO $ findFile'' incs t modFile         return $ case (oldF, newF) of           (Right f1, Right f2) | f1 == f2 ->-            (Map.insert n m keep, modFile)+            (Map.insert t m keep, modFile)           _ -> (keep, modFile)       process keep modFile ms
src/full/Agda/TypeChecking/Monad/Signature.hs view
@@ -38,6 +38,7 @@ import Agda.TypeChecking.Monad.Builtin import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Constraints import Agda.TypeChecking.Monad.Env import Agda.TypeChecking.Monad.Mutual import Agda.TypeChecking.Monad.Open@@ -82,7 +83,7 @@   tel <- getContextTelescope   let tel' = replaceEmptyName "r" $ killRange $ case theDef d of               Constructor{} -> fmap hideOrKeepInstance tel-              Function{ funProjection = Just Projection{ projProper = Just{}, projIndex = n } } ->+              Function{ funProjection = Right Projection{ projProper = Just{}, projIndex = n } } ->                 let fallback = fmap hideOrKeepInstance tel in                 if n > 0 then fallback else                 -- if the record value is part of the telescope, its hiding should left unchanged@@ -109,9 +110,10 @@   addConstant q $ defaultDefn info x t lang def  -- | Set termination info of a defined function symbol.-setTerminates :: QName -> Bool -> TCM ()+setTerminates :: MonadTCState m => QName -> Bool -> m () setTerminates q b = modifySignature $ updateDefinition q $ updateTheDef $ \case     def@Function{} -> def { funTerminates = Just b }+    def@Record{}   -> def { recTerminates = Just b }     def -> def  -- | Set CompiledClauses of a defined function symbol.@@ -135,13 +137,17 @@  -- | Lifts clauses to the top-level and adds them to definition. --   Also adjusts the 'funCopatternLHS' field if necessary.-addClauses :: QName -> [Clause] -> TCM ()+addClauses :: (MonadConstraint m, MonadTCState m) => QName -> [Clause] -> m () addClauses q cls = do   tel <- getContextTelescope   modifySignature $ updateDefinition q $     updateTheDef (updateFunClauses (++ abstract tel cls))     . updateDefCopatternLHS (|| isCopatternLHS cls) +  -- Jesper, 2022-10-13: unblock any constraints that were+  -- waiting for more clauses of this function+  wakeConstraints' $ wakeIfBlockedOnDef q . constraintUnblocker+ mkPragma :: String -> TCM CompilerPragma mkPragma s = CompilerPragma <$> getCurrentRange <*> pure s @@ -180,7 +186,7 @@                        vcat [ "-" <+> pretty (getRange p) | p <- ps ]  setFunctionFlag :: FunctionFlag -> Bool -> QName -> TCM ()-setFunctionFlag flag val q = modifyGlobalDefinition q $ set (theDefLens . funFlag flag) val+setFunctionFlag flag val q = modifyGlobalDefinition q $ set (lensTheDef . funFlag flag) val  markStatic :: QName -> TCM () markStatic = setFunctionFlag FunStatic True@@ -507,14 +513,20 @@             -- This is because we may abstract the record argument later again.             -- See succeed/ProjectionNotNormalized.agda             isVar0 t = case unArg t of Var 0 [] -> True; _ -> False+            proj :: Either ProjectionLikenessMissing Projection             proj   = case oldDef of-              Function{funProjection = Just p@Projection{projIndex = n}}+              Function{funProjection = Right p@Projection{projIndex = n}}                 | size ts' < n || (size ts' == n && maybe True isVar0 (lastMaybe ts'))-                -> Just $ p { projIndex = n - size ts'-                            , projLams  = projLams p `apply` ts'-                            , projProper= copyName <$> projProper p-                            }-              _ -> Nothing+                -> Right p { projIndex = n - size ts'+                           , projLams  = projLams p `apply` ts'+                           , projProper= copyName <$> projProper p+                           }+              -- Preserve no-projection-likeness flag if it exists, and+              -- it's set to @Left _@. For future reference: The match+              -- on left can't be simplified or it accidentally+              -- circumvents the guard above.+              Function{funProjection = Left projl} -> Left projl+              _ -> Left MaybeProjection             def =               case oldDef of                 Constructor{ conPars = np, conData = d } -> return $@@ -538,37 +550,38 @@                         set funMacro  (oldDef ^. funMacro) $                         set funStatic (oldDef ^. funStatic) $                         set funInline True $-                        emptyFunction-                        { funClauses        = [cl]-                        , funCompiled       = Just cc-                        , funSplitTree      = mst-                        , funMutual         = mutual-                        , funProjection     = proj-                        , funTerminates     = Just True-                        , funExtLam         = extlam-                        , funWith           = with+                        FunctionDefn emptyFunctionData+                        { _funClauses        = [cl]+                        , _funCompiled       = Just cc+                        , _funSplitTree      = mst+                        , _funMutual         = mutual+                        , _funProjection     = proj+                        , _funTerminates     = Just True+                        , _funExtLam         = extlam+                        , _funWith           = with                         }                   reportSDoc "tc.mod.apply" 80 $ ("new def for" <+> pretty x) <?> pretty newDef                   return newDef -            cl = Clause { clauseLHSRange  = getRange $ defClauses d-                        , clauseFullRange = getRange $ defClauses d-                        , clauseTel       = EmptyTel-                        , namedClausePats = []-                        , clauseBody      = Just $ dropArgs pars $ case oldDef of-                            Function{funProjection = Just p} -> projDropParsApply p ProjSystem rel ts'+            cl = Clause { clauseLHSRange    = getRange $ defClauses d+                        , clauseFullRange   = getRange $ defClauses d+                        , clauseTel         = EmptyTel+                        , namedClausePats   = []+                        , clauseBody        = Just $ dropArgs pars $ case oldDef of+                            Function{funProjection = Right p} -> projDropParsApply p ProjSystem rel ts'                             _ -> Def x $ map Apply ts'-                        , clauseType      = Just $ defaultArg t-                        , clauseCatchall  = False+                        , clauseType        = Just $ defaultArg t+                        , clauseCatchall    = False                         , clauseExact       = Just True                         , clauseRecursive   = Just False -- definitely not recursive                         , clauseUnreachable = Just False -- definitely not unreachable-                        , clauseEllipsis  = NoEllipsis+                        , clauseEllipsis    = NoEllipsis+                        , clauseWhereModule = Nothing                         }               where                 -- The number of remaining parameters. We need to drop the                 -- lambdas corresponding to these from the clause body above.-                pars = max 0 $ maybe 0 (pred . projIndex) proj+                pars = max 0 $ either (const 0) (pred . projIndex) proj                 rel  = getRelevance $ defArgInfo d      {- Example@@ -1241,8 +1254,8 @@ isProjection_ :: Defn -> Maybe Projection isProjection_ def =   case def of-    Function { funProjection = result } -> result-    _                                   -> Nothing+    Function { funProjection = Right result } -> Just result+    _                                         -> Nothing  -- | Is it the name of a non-irrelevant record projection? {-# SPECIALIZE isProjection :: QName -> TCM (Maybe Projection) #-}
src/full/Agda/TypeChecking/Monad/SizedTypes.hs view
@@ -8,8 +8,6 @@ import Control.Monad.Except  import qualified Data.Foldable as Fold-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Traversable as Trav  import Agda.Syntax.Common@@ -22,6 +20,8 @@ import Agda.TypeChecking.Substitute  import Agda.Utils.List+import Agda.Utils.List1 (List1, pattern (:|))+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty@@ -164,7 +164,7 @@  -- | Transform list of terms into a term build from binary maximum. sizeMax :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m)-        => NonEmpty Term -> m Term+        => List1 Term -> m Term sizeMax vs = case vs of   v :| [] -> return v   vs  -> do@@ -295,7 +295,7 @@ -- * View on sizes where maximum is pulled to the top ------------------------------------------------------------------------ -type SizeMaxView = NonEmpty DeepSizeView+type SizeMaxView = List1 DeepSizeView type SizeMaxView' = [DeepSizeView]  maxViewMax :: SizeMaxView -> SizeMaxView -> SizeMaxView@@ -310,7 +310,7 @@ maxViewCons _ (DSizeInf :| _) = singleton DSizeInf maxViewCons DSizeInf _        = singleton DSizeInf maxViewCons v ws = case sizeViewComparableWithMax v ws of-  NotComparable  -> NonEmpty.cons v ws+  NotComparable  -> List1.cons v ws   YesAbove _ ws' -> v :| ws'   YesBelow{}     -> ws
src/full/Agda/TypeChecking/Monad/State.hs view
@@ -5,14 +5,13 @@  import qualified Control.Exception as E -import Control.Monad       (void)+import Control.Monad       (void, when) import Control.Monad.Trans (MonadIO, liftIO)  import Data.Maybe  import qualified Data.Map as Map -import qualified Data.List.NonEmpty as NonEmpty import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap@@ -29,6 +28,8 @@ import Agda.Syntax.Abstract.PatternSynonyms import Agda.Syntax.Abstract.Name import Agda.Syntax.Internal+import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Warnings@@ -37,8 +38,10 @@ import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.CompiledClause +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Hash import Agda.Utils.Lens+import qualified Agda.Utils.List1 as List1 import Agda.Utils.Monad (bracket_) import Agda.Utils.Pretty import Agda.Utils.Tuple@@ -326,23 +329,70 @@ -- * Top level module --------------------------------------------------------------------------- +-- | Tries to convert a raw top-level module name to a top-level+-- module name.++topLevelModuleName :: RawTopLevelModuleName -> TCM TopLevelModuleName+topLevelModuleName raw = do+  hash <- BiMap.lookup raw <$> useR stTopLevelModuleNames+  case hash of+    Just hash -> return (unsafeTopLevelModuleName raw hash)+    Nothing   -> do+      let hash = hashRawTopLevelModuleName raw+      when (hash == noModuleNameHash) $ typeError $ GenericError $+        "The module name " ++ prettyShow raw ++ " has a reserved " +++        "hash (you may want to consider renaming the module with " +++        "this name)"+      raw' <- BiMap.invLookup hash <$> useR stTopLevelModuleNames+      case raw' of+        Just raw' -> typeError $ GenericError $+          "Module name hash collision for " ++ prettyShow raw +++          " and " ++ prettyShow raw' ++ " (you may want to consider " +++          "renaming one of these modules)"+        Nothing -> do+          stTopLevelModuleNames `modifyTCLens'`+            BiMap.insert (killRange raw) hash+          return (unsafeTopLevelModuleName raw hash)+ -- | Set the top-level module. This affects the global module id of freshly --   generated names. --- TODO: Is the hash-function collision-free? If not, then the--- implementation of 'setTopLevelModule' should be changed.+setTopLevelModule :: TopLevelModuleName -> TCM ()+setTopLevelModule top = do+  let hash = moduleNameId top+  stFreshNameId `setTCLens'` NameId 0 hash+  stFreshMetaId `setTCLens'`+    MetaId { metaId     = 0+           , metaModule = hash+           } -setTopLevelModule :: C.QName -> TCM ()-setTopLevelModule x = stFreshNameId `setTCLens` NameId 0 (ModuleNameHash $ hashString $ prettyShow x)+-- | The name of the current top-level module, if any.+{-# SPECIALIZE+    currentTopLevelModule :: TCM (Maybe TopLevelModuleName) #-}+{-# SPECIALIZE+    currentTopLevelModule :: ReduceM (Maybe TopLevelModuleName) #-}+currentTopLevelModule ::+  (MonadTCEnv m, ReadTCState m) => m (Maybe TopLevelModuleName)+currentTopLevelModule = do+  m <- useR stCurrentModule+  case m of+    Just (_, top) -> return (Just top)+    Nothing       -> do+      p <- asksTC envImportPath+      return $ case p of+        top : _ -> Just top+        []      -> Nothing  -- | Use a different top-level module for a computation. Used when generating --   names for imported modules.-withTopLevelModule :: C.QName -> TCM a -> TCM a+withTopLevelModule :: TopLevelModuleName -> TCM a -> TCM a withTopLevelModule x m = do-  next <- useTC stFreshNameId+  nextN <- useTC stFreshNameId+  nextM <- useTC stFreshMetaId   setTopLevelModule x   y <- m-  stFreshNameId `setTCLens` next+  stFreshMetaId `setTCLens` nextM+  stFreshNameId `setTCLens` nextN   return y  currentModuleNameHash :: ReadTCState m => m ModuleNameHash@@ -401,7 +451,7 @@   defs <- traverse lookupSinglePatternSyn xs   case mergePatternSynDefs defs of     Just def   -> return def-    Nothing    -> typeError $ CannotResolveAmbiguousPatternSynonym (NonEmpty.zip xs defs)+    Nothing    -> typeError $ CannotResolveAmbiguousPatternSynonym $ List1.zip xs defs  lookupSinglePatternSyn :: QName -> TCM PatternSynDefn lookupSinglePatternSyn x = do
src/full/Agda/TypeChecking/Monad/Statistics.hs view
@@ -14,7 +14,7 @@ import qualified Data.Map as Map import qualified Text.PrettyPrint.Boxes as Boxes -import Agda.Syntax.Concrete.Name as C+import Agda.Syntax.TopLevelModuleName (TopLevelModuleName)  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Debug@@ -76,17 +76,17 @@ tickMax :: MonadStatistics m => String -> Integer -> m () tickMax s n = modifyCounter s (max n) --- | Print the given statistics if verbosity "profile.ticks" is given.+-- | Print the given statistics. printStatistics   :: (MonadDebug m, MonadTCEnv m, HasOptions m)-  => Int -> Maybe C.TopLevelModuleName -> Statistics -> m ()-printStatistics vl mmname stats = verboseS "profile.ticks" vl $ do+  => Maybe TopLevelModuleName -> Statistics -> m ()+printStatistics mmname stats = do   unlessNull (Map.toList stats) $ \ stats -> do     let -- First column (left aligned) is accounts.         col1 = Boxes.vcat Boxes.left  $ map (Boxes.text . fst) stats         -- Second column (right aligned) is numbers.         col2 = Boxes.vcat Boxes.right $ map (Boxes.text . showThousandSep . snd) stats         table = Boxes.hsep 1 Boxes.left [col1, col2]-    reportSLn "profile" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname ->+    reportSLn "" 1 $ caseMaybe mmname "Accumulated statistics" $ \ mname ->       "Statistics for " ++ prettyShow mname-    reportSLn "profile" 1 $ Boxes.render table+    reportSLn "" 1 $ Boxes.render table
src/full/Agda/TypeChecking/Monad/Trace.hs view
@@ -61,6 +61,7 @@     CheckDataDef{}            -> True     CheckRecDef{}             -> True     CheckConstructor{}        -> True+    CheckIApplyConfluence{}   -> True     CheckConstructorFitsIn{}  -> True     CheckFunDefCall{}         -> True     CheckPragma{}             -> True@@ -135,7 +136,7 @@     verboseS "check.ranges" 90 $       Strict.whenJust (rangeFile callRange) $ \f -> do         currentFile <- asksTC envCurrentPath-        when (currentFile /= Just f) $ do+        when (currentFile /= Just (rangeFilePath f)) $ do           reportSLn "check.ranges" 90 $             prettyShow call ++             " is setting the current range to " ++ show callRange ++@@ -190,6 +191,7 @@       CheckPrimitive{}          -> True       CheckIsEmpty{}            -> True       CheckConfluence{}         -> False+      CheckIApplyConfluence{}   -> False       CheckWithFunctionType{}   -> True       CheckSectionApplication{} -> True       CheckNamedWhere{}         -> False
src/full/Agda/TypeChecking/Names.hs view
@@ -1,7 +1,7 @@  {-| EDSL to construct terms without touching De Bruijn indices. -e.g. if given t, u :: Term, Γ ⊢ t, u : A, we can build "λ f. f t u" like this:+e.g. given t, u :: Term, Γ ⊢ t, u : A, we can build "λ f. f t u" like this:  runNames [] $ do   -- @open@ binds @t@ and @u@ to computations that know how to weaken themselves in@@ -9,10 +9,10 @@    [t,u] <- mapM open [t,u] -  -- @lam@ gives the illusion of HOAS by providing f as a computation+  -- @lam@ gives the illusion of HOAS by providing f as a computation.   -- It also extends the internal context with the name "f", so that   -- @t@ and @u@ will get weakened in the body.-  -- Then we finish the job using the (<@>) combinator from Agda.TypeChecking.Primitive+  -- We apply f with the (<@>) combinator from Agda.TypeChecking.Primitive.    lam "f" $ \ f -> f <@> t <@> u @@ -36,9 +36,14 @@  import Agda.TypeChecking.Monad hiding (getConstInfo, typeOfConst) import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Errors+import Agda.TypeChecking.Level+import Agda.TypeChecking.Pretty ()  -- instances only import Agda.TypeChecking.Free  import Agda.Utils.Fail (Fail, runFail_)+import Agda.Utils.Impossible  instance HasBuiltins m => HasBuiltins (NamesT m) where   getBuiltinThing b = lift $ getBuiltinThing b@@ -64,66 +69,77 @@            , PureTCM            ) --- deriving instance MonadState s m => MonadState s (NamesT m) +-- | A list of variable names from a context. type Names = [String]  runNamesT :: Names -> NamesT m a -> m a runNamesT n m = runReaderT (unName m) n --- We use @Fail@ instead of @Identity@ because the computation can fail. runNames :: Names -> NamesT Fail a -> a runNames n m = runFail_ (runNamesT n m)  currentCxt :: Monad m => NamesT m Names currentCxt = NamesT ask +-- | @cxtSubst Γ@ returns the substitution needed to go+--   from Γ to the current context.+--+--   Fails if @Γ@ is not a subcontext of the current one. cxtSubst :: MonadFail m => Names -> NamesT m (Substitution' a) cxtSubst ctx = do   ctx' <- currentCxt   if (ctx `isSuffixOf` ctx')      then return $ raiseS (length ctx' - length ctx)-     else fail $ "thing out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")"+     else fail $ "out of context (" ++ show ctx ++ " is not a sub context of " ++ show ctx' ++ ")" +-- | @inCxt Γ t@ takes a @t@ in context @Γ@ and produce an action that+--   will return @t@ weakened to the current context.+--+--   Fails whenever @cxtSubst Γ@ would. inCxt :: (MonadFail m, Subst a) => Names -> a -> NamesT m a inCxt ctx a = do   sigma <- cxtSubst ctx   return $ applySubst sigma a --- closed terms+-- | Closed terms cl' :: Applicative m => a -> NamesT m a cl' = pure  cl :: Monad m => m a -> NamesT m a cl = lift +-- | Open terms in the current context. open :: (MonadFail m, Subst a) => a -> NamesT m (NamesT m a) open a = do   ctx <- NamesT ask   pure $ inCxt ctx a -bind' :: (MonadFail m, Subst b, DeBruijn b, Subst a, Free a) => ArgName -> (NamesT m b -> NamesT m a) -> NamesT m a+-- | Monadic actions standing for variables.+--+--   @b@ is quantified over so the same variable can be used e.g. both+--   as a pattern and as an expression.+type Var m = forall b. (Subst b, DeBruijn b) => NamesT m b+++-- | @bind n f@ provides @f@ with a fresh variable, which can be used in any extended context.+--+--   Returns an @Abs@ which binds the extra variable.+bind :: MonadFail m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m (Abs a)+bind n f = Abs n <$> bind' n f++-- | Like @bind@ but returns a bare term.+bind' :: MonadFail m => ArgName -> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a) -> NamesT m a bind' n f = do   cxt <- NamesT ask   (NamesT . local (n:) . unName $ f (inCxt (n:cxt) (deBruijnVar 0))) -bind :: ( MonadFail m-        , Subst b-        , DeBruijn b-        , Subst a-        , Free a-        ) =>-        ArgName -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)-bind n f = Abs n <$> bind' n f +-- * Helpers to build lambda abstractions.+ glam :: MonadFail m      => ArgInfo -> ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term-glam info n f = Lam info <$> bind n f--glamN :: (Functor m, MonadFail m) =>-         [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term-glamN [] f = f $ pure []-glamN (Arg i n:ns) f = glam i n $ \ x -> glamN ns (\ xs -> f ((:) <$> (Arg i <$> x) <*> xs))+glam info n f = Lam info <$> bind n (\ x -> f x)  lam :: MonadFail m     => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term@@ -132,3 +148,89 @@ ilam :: MonadFail m     => ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term ilam n f = glam (setRelevance Irrelevant defaultArgInfo) n f+++-- * Combinators for n-ary binders.++data AbsN a = AbsN { absNName :: [ArgName], unAbsN :: a } deriving (Functor,Foldable,Traversable)++instance Subst a => Subst (AbsN a) where+  type SubstArg (AbsN a) = SubstArg a+  applySubst rho (AbsN xs a) = AbsN xs (applySubst (liftS (length xs) rho) a)++-- | Will crash on @NoAbs@+toAbsN :: Abs (AbsN a) -> AbsN a+toAbsN (Abs n x') = AbsN (n : absNName x') (unAbsN x')+toAbsN NoAbs{}    = __IMPOSSIBLE__++absAppN :: Subst a => AbsN a -> [SubstArg a] -> a+absAppN f xs = (parallelS $ reverse xs) `applySubst` unAbsN f++type ArgVars m = (forall b. (Subst b, DeBruijn b) => [NamesT m (Arg b)])++type Vars m = (forall b. (Subst b, DeBruijn b) => [NamesT m b])++bindN :: ( MonadFail m+        ) =>+        [ArgName] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)+bindN [] f = AbsN [] <$> f []+bindN (x:xs) f = toAbsN <$> bind x (\ x -> bindN xs (\ xs -> f (x:xs)))++bindNArg :: ( MonadFail m+        ) =>+        [Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)+bindNArg [] f = AbsN [] <$> f []+bindNArg (Arg i x:xs) f = toAbsN <$> bind x (\ x -> bindNArg xs (\ xs -> f ((Arg i <$> x):xs)))+++glamN :: (Functor m, MonadFail m) =>+         [Arg ArgName] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term+glamN [] f = f $ pure []+glamN (Arg i n:ns) f = glam i n $ \ x -> glamN ns (\ xs -> f ((:) <$> (Arg i <$> x) <*> xs))+++applyN :: ( Monad m+        , Subst a+        ) =>+        NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a+applyN f xs = do+  f <- f+  xs <- sequence xs+  unless (length xs == length (absNName f)) $ __IMPOSSIBLE__+  return $ absAppN f xs++applyN' :: ( Monad m+        , Subst a+        ) =>+        NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a+applyN' f xs = do+  f <- f+  xs <- xs+  unless (length xs == length (absNName f)) $ __IMPOSSIBLE__+  return $ absAppN f xs++abstractN :: ( MonadFail m+             , Abstract a+             ) =>+             NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a+abstractN tel f = do+  tel <- tel+  u <- bindN (teleNames tel) f+  return $ abstract tel $ unAbsN u++abstractT :: ( MonadFail m+             , Abstract a+             ) =>+             String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a+abstractT n ty f = do+  u <- bind n f+  ty <- ty+  let tel = ExtendTel (defaultDom ty) $ Abs n EmptyTel+  return $ abstract tel $ unAbs u+++lamTel :: Monad m => NamesT m (Abs [Term]) -> NamesT m ([Term])+lamTel t = map (Lam defaultArgInfo) . sequenceA <$> t++appTel :: Monad m => NamesT m [Term] -> NamesT m Term -> NamesT m [Term]+appTel = liftM2 (\ fs x -> map (`apply` [Arg defaultArgInfo x]) fs)
src/full/Agda/TypeChecking/Patterns/Match.hs view
@@ -19,6 +19,7 @@ import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Monad hiding (constructorForm)+import Agda.TypeChecking.Monad.Builtin (getName',builtinHComp, builtinConId) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Records @@ -56,7 +57,7 @@ buildSubstitution :: (DeBruijn a)                   => Impossible -> Int -> IntMap (Arg a) -> Substitution' a buildSubstitution err n vs = foldr cons idS $ matchedArgs' n vs-  where cons Nothing  = Strengthen err+  where cons Nothing  = strengthenS' err 1         cons (Just v) = consS (unArg v)  @@ -262,12 +263,16 @@   -- can be matched on.   isMatchable' :: HasBuiltins m => m (Blocked Term -> Maybe Term)   isMatchable' = do-    mhcomp <- getName' builtinHComp+    [mhcomp,mconid] <- mapM getName' [builtinHComp, builtinConId]     return $ \ r ->       case ignoreBlocking r of         t@Con{} -> Just t         t@(Def q [l,a,phi,u,u0]) | Just q == mhcomp                 -> Just t+        t@(Def q [l,a,x,y,phi,p]) | Just q == mconid+                -> Just t+        -- TODO this covers the transpIx functions, but it's a hack.+        t@(Def q _) | NotBlocked{blockingStatus = MissingClauses _} <- r -> Just t         _       -> Nothing    -- DefP hcomp and ConP matching.
src/full/Agda/TypeChecking/Positivity.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NondecreasingIndentation #-}  -- | Check that a datatype is strictly positive. module Agda.TypeChecking.Positivity where@@ -11,7 +12,7 @@  import Data.Either import qualified Data.Foldable as Fold-import Data.Function+import Data.Function (on) import Data.Graph (SCC(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap@@ -28,6 +29,7 @@ import Agda.Syntax.Common import qualified Agda.Syntax.Info as Info import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position (HasRange(..), noRange) import Agda.TypeChecking.Datatypes ( isDataOrRecordType ) import Agda.TypeChecking.Functions@@ -407,6 +409,8 @@   occurrences cl = do     let ps    = namedClausePats cl         items = IntMap.elems $ patItems ps -- sorted from low to high DBI+    -- TODO #3733: handle hcomp/transp clauses properly+    if hasDefP ps then return mempty else do     (Concat (mapMaybe matching (zip [0..] ps)) <>) <$> do       withExtendedOccEnv' items $         occurrences $ clauseBody cl
src/full/Agda/TypeChecking/Positivity/Occurrence.hs view
@@ -11,8 +11,6 @@ import Control.DeepSeq import Control.Monad -import Data.Data (Data)- import Data.Foldable (toList)  import Data.Map.Strict (Map)@@ -46,7 +44,7 @@     -- includes the main information, and if the first sequence is     -- non-empty, then it includes information about the context of     -- the second sequence.-  deriving (Show, Eq, Ord, Data, Generic)+  deriving (Show, Eq, Ord, Generic)  instance NFData OccursWhere @@ -63,7 +61,7 @@   | Matched          -- ^ matched against in a clause of a defined function   | IsIndex          -- ^ is an index of an inductive family   | InDefOf QName    -- ^ in the definition of a constant-  deriving (Show, Eq, Ord, Data, Generic)+  deriving (Show, Eq, Ord, Generic)  instance NFData Where @@ -78,7 +76,7 @@   | StrictPos -- ^ Strictly positive occurrence.   | GuardPos  -- ^ Guarded strictly positive occurrence (i.e., under ∞).  For checking recursive records.   | Unused    --  ^ No occurrence.-  deriving (Data, Show, Eq, Ord, Enum, Bounded)+  deriving (Show, Eq, Ord, Enum, Bounded)  -- Pretty instances.
src/full/Agda/TypeChecking/Pretty.hs view
@@ -39,12 +39,14 @@ import qualified Agda.Syntax.Info as A import Agda.Syntax.Scope.Base  (AbstractName(..)) import Agda.Syntax.Scope.Monad (withContextPrecedence)+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.Coverage.SplitTree import Agda.TypeChecking.Monad import Agda.TypeChecking.Positivity.Occurrence import Agda.TypeChecking.Substitute +import qualified Agda.Utils.BiMap as BiMap import Agda.Utils.Graph.AdjacencyMap.Unidirectional (Graph) import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as Graph import Agda.Utils.List1 ( List1, pattern (:|) )@@ -144,13 +146,7 @@ -- * The PrettyTCM class --------------------------------------------------------------------------- -type MonadPretty m =-  ( MonadReify m-  , MonadAbsToCon m-  , IsString (m Doc)-  , Null (m Doc)-  , Semigroup (m Doc)-  )+type MonadPretty m = MonadAbsToCon m  -- This instance is to satify the constraints of superclass MonadPretty: -- | This instance is more specific than a generic instance@@ -169,6 +165,8 @@ instance PrettyTCM Bool        where prettyTCM = pretty instance PrettyTCM C.Name      where prettyTCM = pretty instance PrettyTCM C.QName     where prettyTCM = pretty+instance PrettyTCM TopLevelModuleName+                               where prettyTCM = pretty instance PrettyTCM Comparison  where prettyTCM = pretty instance PrettyTCM Literal     where prettyTCM = pretty instance PrettyTCM Nat         where prettyTCM = pretty@@ -209,7 +207,7 @@ instance PrettyTCM (NamedArg A.Expr)  where prettyTCM = prettyA <=< reify instance PrettyTCM (NamedArg Term)    where prettyTCM = prettyA <=< reify instance PrettyTCM (Dom Type)         where prettyTCM = prettyA <=< reify-instance PrettyTCM (Dom (Name, Type)) where prettyTCM = prettyA <=< reify+instance PrettyTCM ContextEntry       where prettyTCM = prettyA <=< reify  instance PrettyTCM Permutation where prettyTCM = text . show instance PrettyTCM Polarity    where prettyTCM = text . show@@ -241,8 +239,26 @@ instance PrettyTCM MetaId where   prettyTCM x = do     mn <- getMetaNameSuggestion x-    pretty $ NamedMeta mn x+    prettyTCM $ NamedMeta mn x +instance PrettyTCM NamedMeta where+  prettyTCM (NamedMeta s m) = do+    current <- currentModuleNameHash+    prefix  <-+      if metaModule m == current+      then return empty+      else do+        modName <- BiMap.invLookup (metaModule m) <$>+                   useR stTopLevelModuleNames+        return $ case modName of+          Nothing      -> __IMPOSSIBLE__+          Just modName -> pretty modName <> text "."+    let inBetween = case s of+          ""  -> text "_"+          "_" -> text "_"+          s   -> text $ "_" ++ s ++ "_"+    prefix <> inBetween <> text (show (metaId m))+ instance PrettyTCM a => PrettyTCM (Blocked a) where   prettyTCM (Blocked x a) = ("[" <+> prettyTCM a <+> "]") <> text (P.prettyShow x)   prettyTCM (NotBlocked _ x) = prettyTCM x@@ -272,6 +288,9 @@ instance PrettyTCM A.TypedBinding where   prettyTCM = prettyA +instance PrettyTCM A.Pattern where+  prettyTCM = prettyA+ instance PrettyTCM Relevance where   prettyTCM = pretty @@ -289,6 +308,7 @@   prettyTCM (UnblockOnAny us) = "any" <> parens (fsep $ punctuate "," $ map prettyTCM $ Set.toList us)   prettyTCM (UnblockOnMeta m) = prettyTCM m   prettyTCM (UnblockOnProblem p) = "problem" <+> pretty p+  prettyTCM (UnblockOnDef q) = "definition" <+> pretty q  instance PrettyTCM CompareAs where   prettyTCM (AsTermsOf a) = ":" <+> prettyTCMCtx TopCtx a@@ -412,9 +432,11 @@   prettyTCM = \case     PType l   -> parens $ "Set" <+> prettyTCM l     PProp l   -> parens $ "Prop" <+> prettyTCM l+    PSSet l   -> parens $ "SSet" <+> prettyTCM l     PInf f n  -> prettyTCM (Inf f n :: Sort)     PSizeUniv -> prettyTCM (SizeUniv :: Sort)     PLockUniv -> prettyTCM (LockUniv :: Sort)+    PIntervalUniv -> prettyTCM (IntervalUniv :: Sort)  instance PrettyTCM (Elim' NLPat) where   prettyTCM (IApply x y v) = prettyTCM v
src/full/Agda/TypeChecking/Pretty.hs-boot view
@@ -31,20 +31,15 @@ pretty                :: (Applicative m, P.Pretty a) => a -> m Doc prettyList_           :: (Applicative m, Semigroup (m Doc), Foldable t) => t (m Doc) -> m Doc --- Inlining definitions of MonadReify and MonadAbsToCon to avoid--- having to import them+-- The definition of MonadAbsToCon is inlined so that the module+-- Agda.Syntax.Translation.AbstractToConcrete does not need to be+-- imported. type MonadPretty m =-  ( ( PureTCM m-    , MonadInteractionPoints m-    , MonadFresh NameId m-    )-  , ( MonadTCEnv m-    , ReadTCState m-    , MonadStConcreteNames m-    , HasOptions m-    , HasBuiltins m-    , MonadDebug m-    )+  ( MonadFresh NameId m+  , MonadInteractionPoints m+  , MonadStConcreteNames m+  , HasOptions m+  , PureTCM m   , IsString (m Doc)   , Null (m Doc)   , Semigroup (m Doc)@@ -65,6 +60,7 @@  instance PrettyTCM Name instance PrettyTCM QName+instance PrettyTCM NamedMeta instance PrettyTCM Term instance PrettyTCM Elim instance PrettyTCM Type
src/full/Agda/TypeChecking/Pretty/Call.hs view
@@ -15,6 +15,7 @@  import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Closure import Agda.TypeChecking.Monad.Debug import Agda.TypeChecking.Pretty @@ -24,6 +25,8 @@  import Agda.Utils.Impossible +import Agda.Version (docsUrl)+ sayWhere :: MonadPretty m => HasRange a => a -> m Doc -> m Doc sayWhere x d = applyUnless (null r) (prettyTCM r $$) d   where r = getRange x@@ -33,9 +36,9 @@ sayWhen r (Just cl) m = sayWhere r (m $$ prettyTCM cl)  instance PrettyTCM CallInfo where-  prettyTCM c = do-    let call = prettyTCM $ callInfoCall c-        r    = callInfoRange c+  prettyTCM (CallInfo callInfoTarget callInfoCall) = do+    let call = prettyTCM callInfoCall+        r    = getRange callInfoTarget     if null $ P.pretty r       then call       else call $$ nest 2 ("(at" <+> prettyTCM r) <> ")"@@ -142,7 +145,8 @@      CheckWithFunctionType a -> fsep $       pwords "when checking that the type" ++-      [prettyTCM a] ++ pwords "of the generated with function is well-formed"+      [prettyTCM a] ++ pwords "of the generated with function is well-formed" +++      [parens $ text $ docsUrl "language/with-abstraction.html#ill-typed-with-abstractions"]      CheckDotPattern e v -> fsep $       pwords "when checking that the given dot pattern" ++ [prettyA e] ++@@ -192,6 +196,17 @@       info = A.ModuleInfo noRange noRange Nothing Nothing Nothing      ModuleContents -> fsep $ pwords "when retrieving the contents of a module"++    CheckIApplyConfluence _ qn fn l r t -> do+      vcat+        [ fsep (pwords "when checking that a clause of" ++ [prettyTCM qn] ++ pwords "has the correct boundary.")+        , ""+        , "Specifically, the terms"+        , nest 2 (prettyTCM l)+        , "and"+        , nest 2 (prettyTCM r)+        , fsep (pwords "must be equal, since" ++ [prettyTCM fn] ++ pwords "could reduce to either.")+        ]      where     hPretty :: MonadPretty m => Arg (Named_ Expr) -> m Doc
src/full/Agda/TypeChecking/Pretty/Constraint.hs view
@@ -4,8 +4,10 @@ import Prelude hiding (null)  import qualified Data.Set as Set+import Data.Foldable (Foldable)+import qualified Data.Foldable as Foldable import qualified Data.List as List-import Data.Function+import Data.Function (on)  import Agda.Syntax.Common import Agda.Syntax.Position@@ -48,20 +50,37 @@     interestingPids = Set.unions $ map (allBlockingProblems . constraintUnblocker) cs'     stripPids (PConstr pids unblock c) = PConstr (Set.intersection pids interestingPids) unblock c -instance PrettyTCM ProblemConstraint where-  prettyTCM (PConstr pids unblock c) = prettyTCM c <?> parensNonEmpty (sep [blockedOn unblock, prPids (Set.toList pids)])-    where-      prPids []    = empty-      prPids [pid] = "belongs to problem" <+> prettyTCM pid-      prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids)+prettyRangeConstraint ::+  (MonadPretty m, Foldable f, Null (f ProblemId)) =>+  Range -> f ProblemId -> Blocker -> Doc -> m Doc+prettyRangeConstraint r pids unblock c =+  return c <?>+  sep [ prange r+      , parensNonEmpty $ sep+          [ blockedOn unblock+          , prPids (Foldable.toList pids)+          ]+      ]+  where+  prPids []    = empty+  prPids [pid] = "belongs to problem" <+> prettyTCM pid+  prPids pids  = "belongs to problems" <+> fsep (punctuate "," $ map prettyTCM pids) -      comma | null pids = empty-            | otherwise = ","+  comma | null pids = empty+        | otherwise = "," -      blockedOn (UnblockOnAll bs) | Set.null bs = empty-      blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma-      blockedOn u = "blocked on" <+> (prettyTCM u <> comma)+  blockedOn (UnblockOnAll bs) | Set.null bs = empty+  blockedOn (UnblockOnAny bs) | Set.null bs = "stuck" <> comma+  blockedOn u = "blocked on" <+> (prettyTCM u <> comma) +  prange r | null s    = pure empty+           | otherwise = text $ " [ at " ++ s ++ " ]"+    where s = P.prettyShow r++instance PrettyTCM ProblemConstraint where+  prettyTCM (PConstr pids unblock c) =+    prettyRangeConstraint noRange pids unblock =<< prettyTCM c+ instance PrettyTCM Constraint where     prettyTCM = \case         ValueCmp cmp ty s t -> prettyCmp (prettyTCM cmp) s t <?> prettyTCM ty@@ -74,7 +93,7 @@         SortCmp cmp s1 s2        -> prettyCmp (prettyTCM cmp) s1 s2         UnBlock m   -> do             -- BlockedConst t <- mvInstantiation <$> lookupMeta m-            mi <- mvInstantiation <$> lookupMeta m+            mi <- lookupMetaInstantiation m             case mi of               BlockedConst t -> prettyCmp ":=" m t               PostponedTypeCheckingProblem cl -> enterClosure cl $ \p ->@@ -127,8 +146,10 @@         UnquoteTactic v _ _ -> do           e <- reify v           prettyTCM (A.App A.defaultAppInfo_ (A.Unquote A.exprNoRange) (defaultNamedArg e))+        CheckDataSort q s -> do+          hsep [ "Sort", prettyTCM s, "of", prettyTCM q, "admits data/record definitions." ]         CheckMetaInst x -> do-          m <- lookupMeta x+          m <- lookupLocalMeta x           case mvJudgement m of             HasType{ jMetaType = t } -> prettyTCM x <+> ":" <+> prettyTCM t             IsSort{} -> prettyTCM x <+> "is a sort"@@ -136,7 +157,8 @@           prettyTCM t <+> "is a well-formed type"         CheckLockedVars t ty lk lk_ty -> do           "Lock" <+> prettyTCM lk <+> "|-" <+> prettyTCMCtx TopCtx t <+> ":" <+> prettyTCM ty-        UsableAtModality mod t -> "Is usable at" <+> prettyTCM mod <+> ":" <+> prettyTCM t+        UsableAtModality _ ms mod t -> "Is usable at" <+> text (verbalize mod) <+> "modality:" <+> prettyTCM t+          -- TODO: print @ms : Maybe Sort@ as well?        where         prettyCmp
src/full/Agda/TypeChecking/Pretty/Warning.hs view
@@ -9,7 +9,7 @@ import Control.Monad.Fail ( MonadFail )  import Data.Char ( toLower )-import Data.Function+import Data.Function (on) import Data.Maybe  import qualified Data.Set as Set@@ -82,7 +82,7 @@                concatMap termErrFunctions because)         $$ fwords "Problematic calls:"         $$ nest 2 (fmap (P.vcat . List.nub) $-              mapM prettyTCM $ List.sortBy (compare `on` callInfoRange) $+              mapM prettyTCM $ List.sortOn getRange $               concatMap termErrCalls because)      UnreachableClauses f pss -> fsep $@@ -108,6 +108,15 @@       [prettyTCM d] ++ pwords "is not strictly positive, because it occurs"       ++ [prettyTCM ocs] +    UnsupportedIndexedMatch doc -> vcat+      [ fsep (pwords "This clause uses pattern-matching features that are not yet supported by Cubical Agda,"+           ++ pwords "the function to which it belongs will not compute when applied to transports."+             )+      , ""+      , "Reason:" <+> pure doc+      , ""+      ]+     CantGeneralizeOverSorts ms -> vcat             [ text "Cannot generalize over unsolved sort metas:"             , nest 2 $ vcat [ prettyTCM x <+> text "at" <+> (pretty =<< getMetaRange x) | x <- ms ]@@ -137,6 +146,7 @@      UselessPatternDeclarationForRecord s -> fwords $ unwords       [ "`pattern' attribute ignored for", s, "record" ]+      -- the @s@ is a qualifier like "eta" or "coinductive"      UselessPublic -> fwords $ "Keyword `public' is ignored here" @@ -149,14 +159,17 @@       pwords "It is pointless for INLINE'd function" ++ [prettyTCM q] ++       pwords "to have a separate Haskell definition" -    WrongInstanceDeclaration -> fwords "Terms marked as eligible for instance search should end with a name, so `instance' is ignored here."+    WrongInstanceDeclaration -> fwords $+      "Instances should be of type {Γ} → C, where C evaluates to a postulated name or the name of " +++      "a data or record type, so `instance' is ignored here."      InstanceWithExplicitArg q -> fsep $       pwords "Instance declarations with explicit arguments are never considered by instance search," ++       pwords "so making" ++ [prettyTCM q] ++ pwords "into an instance has no effect."      InstanceNoOutputTypeName b -> fsep $-      pwords "Instance arguments whose type does not end in a named or variable type are never considered by instance search," +++      pwords "Instance arguments whose type is not {Γ} → C, where C evaluates to a postulated type, " +++      pwords "a parameter type or the name of a data or record type, are never considered by instance search," ++       pwords "so having an instance argument" ++ [return b] ++ pwords "has no effect."      InstanceArgWithExplicitArg b -> fsep $@@ -220,6 +233,8 @@     SafeFlagNoCoverageCheck -> fsep $       pwords "Cannot use NON_COVERING pragma with safe flag." +    OptionWarning ow -> pretty ow+     ParseWarning pw -> pretty pw      DeprecationWarning old new version -> fsep $@@ -248,13 +263,9 @@      LibraryWarning lw -> pretty lw -    InfectiveImport o m -> fsep $-      pwords "Importing module" ++ [pretty m] ++ pwords "using the" ++-      [pretty o] ++ pwords "flag from a module which does not."+    InfectiveImport msg -> return msg -    CoInfectiveImport o m -> fsep $-      pwords "Importing module" ++ [pretty m] ++ pwords "not using the" ++-      [pretty o] ++ pwords "flag from a module which does."+    CoInfectiveImport msg -> return msg      RewriteNonConfluent lhs rhs1 rhs2 err -> fsep       [ "Local confluence check failed:"
src/full/Agda/TypeChecking/Primitive.hs view
@@ -33,14 +33,16 @@ import Agda.TypeChecking.Telescope import Agda.TypeChecking.Level -import Agda.TypeChecking.Quote (quoteTermWithKit, quoteTypeWithKit, quotingKit)+import Agda.TypeChecking.Quote (quoteTermWithKit, quoteTypeWithKit, quoteDomWithKit, quotingKit) import Agda.TypeChecking.Primitive.Base import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Primitive.Cubical.Base import Agda.TypeChecking.Warnings  import Agda.Utils.Char import Agda.Utils.Float import Agda.Utils.List+import qualified Agda.Utils.Maybe.Strict as Strict import Agda.Utils.Monad import Agda.Utils.Pretty import Agda.Utils.Singleton@@ -167,8 +169,8 @@ instance ToTerm QName   where toTerm = return $ Lit . LitQName instance ToTerm MetaId  where   toTerm = do-    file <- getCurrentPath-    return $ Lit . LitMeta file+    top <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule+    return $ Lit . LitMeta top  instance ToTerm Integer where   toTerm = do@@ -190,6 +192,10 @@   toTerm  = do kit <- quotingKit; runReduceF (quoteTermWithKit kit)   toTermR = do quoteTermWithKit <$> quotingKit; +instance ToTerm (Dom Type) where+  toTerm  = do kit <- quotingKit; runReduceF (quoteDomWithKit kit)+  toTermR = do quoteDomWithKit <$> quotingKit+ instance ToTerm Type where   toTerm  = do kit <- quotingKit; runReduceF (quoteTypeWithKit kit)   toTermR = quoteTypeWithKit <$> quotingKit@@ -452,6 +458,13 @@       Con{} -> redReturn $ refl t       _     -> return $ NoReduction $ map notReduced ts +-- | Converts 'MetaId's to natural numbers.++metaToNat :: MetaId -> Nat+metaToNat m =+  fromIntegral (moduleNameHash $ metaModule m) * 2^64 ++  fromIntegral (metaId m)+ primMetaToNatInjective :: TCM PrimitiveImpl primMetaToNatInjective = do   meta  <- primType (undefined :: MetaId)@@ -490,9 +503,9 @@ primFloatToWord64Injective :: TCM PrimitiveImpl primFloatToWord64Injective = do   float  <- primType (undefined :: Double)-  word   <- primType (undefined :: Word64)+  mword  <- primType (undefined :: Maybe Word64)   toWord <- primFunName <$> getPrimitive "primFloatToWord64"-  mkPrimInjective float word toWord+  mkPrimInjective float mword toWord  primQNameToWord64sInjective :: TCM PrimitiveImpl primQNameToWord64sInjective = do@@ -937,7 +950,7 @@   , "primMetaEquality"    |-> mkPrimFun2 ((==) :: Rel MetaId)   , "primMetaLess"        |-> mkPrimFun2 ((<) :: Rel MetaId)   , "primShowMeta"        |-> mkPrimFun1 (T.pack . prettyShow :: MetaId -> Text)-  , "primMetaToNat"       |-> mkPrimFun1 (fromIntegral . metaId :: MetaId -> Nat)+  , "primMetaToNat"       |-> mkPrimFun1 metaToNat   , "primMetaToNatInjective" |-> primMetaToNatInjective   , "primIMin"            |-> primIMin'   , "primIMax"            |-> primIMax'@@ -946,7 +959,6 @@   , "primComp"            |-> primComp   , builtinTrans          |-> primTrans'   , builtinHComp          |-> primHComp'-  , "primIdJ"             |-> primIdJ   , "primPartial"         |-> primPartial'   , "primPartialP"        |-> primPartialP'   , builtinGlue           |-> primGlue'@@ -958,6 +970,7 @@   , "primIdPath"          |-> primIdPath'   , builtinIdElim         |-> primIdElim'   , builtinSubOut         |-> primSubOut'+  , builtinConId          |-> primConId'   , builtin_glueU         |-> prim_glueU'   , builtin_unglueU       |-> prim_unglueU'   , builtinLockUniv       |-> primLockUniv'
src/full/Agda/TypeChecking/Primitive/Base.hs view
@@ -2,8 +2,10 @@  module Agda.TypeChecking.Primitive.Base where --- Control.Monad.Fail import is redundant since GHC 8.8.1-import Control.Monad.Fail (MonadFail)+import Control.Monad             ( mzero )+import Control.Monad.Fail        ( MonadFail )+  -- Control.Monad.Fail import is redundant since GHC 8.8.1+import Control.Monad.Trans.Maybe ( MaybeT(..), runMaybeT )  import qualified Data.Map as Map @@ -62,19 +64,24 @@  hPi', nPi' :: (MonadFail m, MonadAddContext m, MonadDebug m)            => String -> NamesT m Type -> (NamesT m Term -> NamesT m Type) -> NamesT m Type-hPi' s a b = hPi s a (bind' s b)-nPi' s a b = nPi s a (bind' s b)+hPi' s a b = hPi s a (bind' s (\ x -> b x))+nPi' s a b = nPi s a (bind' s (\ x -> b x))  pPi' :: (MonadAddContext m, HasBuiltins m, MonadDebug m)      => String -> NamesT m Term -> (NamesT m Term -> NamesT m Type) -> NamesT m Type pPi' n phi b = toFinitePi <$> nPi' n (elSSet $ cl isOne <@> phi) b  where-   toFinitePi :: Type -> Type-   toFinitePi (El s (Pi d b)) = El s $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b-   toFinitePi _               = __IMPOSSIBLE__-    isOne = fromMaybe __IMPOSSIBLE__ <$> getBuiltin' builtinIsOne +-- | Turn a 'Pi' type into one whose domain is annotated finite, i.e.,+-- one that represents a @Partial@ element rather than an actual+-- function.+toFinitePi :: Type -> Type+toFinitePi (El s (Pi d b)) = El s $ Pi+  (setRelevance Irrelevant $ d { domIsFinite = True })+  b+toFinitePi _ = __IMPOSSIBLE__+ el' :: Applicative m => m Term -> m Term -> m Type el' l a = El <$> (tmSort <$> l) <*> a @@ -132,22 +139,16 @@ el :: Functor m => m Term -> m Type el t = El (mkType 0) <$> t +-- | The universe @Set0@ as a type. tset :: Applicative m => m Type tset = pure $ sort (mkType 0) +-- | @SizeUniv@ as a sort. sSizeUniv :: Sort--- sSizeUniv = mkType 0--- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428 sSizeUniv = SizeUniv +-- | @SizeUniv@ as a type. tSizeUniv :: Applicative m => m Type--- tSizeUniv = tset--- Andreas, 2016-04-14 switching off SizeUniv, unfixing issue #1428--- tSizeUniv = return $ El sSizeUniv $ Sort sSizeUniv--- Andreas, 2015-03-16 Since equality checking for types--- includes equality checking for sorts, we cannot put--- SizeUniv in Setω.  (SizeUniv : Setω) == (_0 : suc _0)--- will first instantiate _0 := Setω, which is wrong. tSizeUniv = pure $ sort sSizeUniv  -- | Abbreviation: @argN = 'Arg' 'defaultArgInfo'@.@@ -182,16 +183,18 @@   return (s, PrimImpl t $ pf { primFunName = q })  getBuiltinName :: (HasBuiltins m, MonadReduce m) => String -> m (Maybe QName)-getBuiltinName b = do-  caseMaybeM (getBuiltin' b) (return Nothing) (Just <.> getName)-  where-  getName v = do+getBuiltinName b = runMaybeT $ getQNameFromTerm =<< MaybeT (getBuiltin' b)++-- | Convert a name in 'Term' form back to 'QName'.+--+getQNameFromTerm :: MonadReduce m => Term -> MaybeT m QName+getQNameFromTerm v = do     v <- reduce v-    case unSpine $ v of+    case unSpine v of       Def x _   -> return x       Con x _ _ -> return $ conName x-      Lam _ b   -> getName $ unAbs b-      _ -> __IMPOSSIBLE__+      Lam _ b   -> getQNameFromTerm $ unAbs b+      _ -> mzero  isBuiltin :: (HasBuiltins m, MonadReduce m) => QName -> String -> m Bool isBuiltin q b = (Just q ==) <$> getBuiltinName b
src/full/Agda/TypeChecking/Primitive/Cubical.hs view
@@ -1,1821 +1,1281 @@ {-# LANGUAGE NondecreasingIndentation #-}--module Agda.TypeChecking.Primitive.Cubical where--import Prelude hiding (null, (!!))--import Control.Monad-import Control.Monad.Except-import Control.Monad.Trans ( lift )--import Data.Either ( partitionEithers )-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Foldable hiding (null)--import Agda.Interaction.Options ( optCubical )--import Agda.Syntax.Common-import Agda.Syntax.Internal--import Agda.TypeChecking.Names-import Agda.TypeChecking.Primitive.Base-import Agda.TypeChecking.Monad--import Agda.TypeChecking.Free-import Agda.TypeChecking.Substitute-import Agda.TypeChecking.Reduce-import Agda.TypeChecking.Telescope--import Agda.Utils.Functor-import Agda.Utils.Impossible-import Agda.Utils.Maybe-import Agda.Utils.Monad-import Agda.Utils.Null-import Agda.Utils.Tuple---- | Checks that the correct variant of Cubical Agda is activated.--- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased--- contexts.--requireCubical-  :: Cubical -- ^ Which variant of Cubical Agda is required?-  -> String -> TCM ()-requireCubical wanted s = do-  cubical         <- optCubical <$> pragmaOptions-  inErasedContext <- hasQuantity0 <$> getEnv-  case cubical of-    Just CFull -> return ()-    Just CErased | wanted == CErased || inErasedContext -> return ()-    _ -> typeError $ GenericError $ "Missing option " ++ opt ++ s-  where-  opt = case wanted of-    CFull   -> "--cubical"-    CErased -> "--cubical or --erased-cubical"--primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type-primIntervalType = El (SSet $ ClosedLevel 0) <$> primInterval--primINeg' :: TCM PrimitiveImpl-primINeg' = do-  requireCubical CErased ""-  t <- primIntervalType --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ ts -> do-    case ts of-     [x] -> do-       unview <- intervalUnview'-       view <- intervalView'-       sx <- reduceB' x-       ix <- intervalView (unArg $ ignoreBlocking sx)-       let-         ineg :: Arg Term -> Arg Term-         ineg = fmap (unview . f . view)-         f ix = case ix of-           IZero -> IOne-           IOne  -> IZero-           IMin x y -> IMax (ineg x) (ineg y)-           IMax x y -> IMin (ineg x) (ineg y)-           INeg x -> OTerm (unArg x)-           OTerm t -> INeg (Arg defaultArgInfo t)-       case ix of-        OTerm t -> return $ NoReduction [reduced sx]-        _       -> redReturn (unview $ f ix)-     _ -> __IMPOSSIBLE__--primDepIMin' :: TCM PrimitiveImpl-primDepIMin' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       nPi' "φ" primIntervalType $ \ φ ->-       pPi' "o" φ (\ o -> primIntervalType) --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do-    case ts of-      [x,y] -> do-        sx <- reduceB' x-        ix <- intervalView (unArg $ ignoreBlocking sx)-        itisone <- getTerm "primDepIMin" builtinItIsOne-        case ix of-          IZero -> redReturn =<< intervalUnview IZero-          IOne  -> redReturn =<< (pure (unArg y) <@> pure itisone)-          _     -> do-            sy <- reduceB' y-            iy <- intervalView =<< reduce' =<< (pure (unArg $ ignoreBlocking sy) <@> pure itisone)-            case iy of-              IZero -> redReturn =<< intervalUnview IZero-              IOne  -> redReturn (unArg $ ignoreBlocking sx)-              _     -> return $ NoReduction [reduced sx, reduced sy]-      _      -> __IMPOSSIBLE__--primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl-primIBin unit absorber = do-  requireCubical CErased ""-  t <- primIntervalType --> primIntervalType --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \ ts -> do-    case ts of-     [x,y] -> do-       sx <- reduceB' x-       ix <- intervalView (unArg $ ignoreBlocking sx)-       case ix of-         ix | ix ==% absorber -> redReturn =<< intervalUnview absorber-         ix | ix ==% unit     -> return $ YesReduction YesSimplification (unArg y)-         _     -> do-           sy <- reduceB' y-           iy <- intervalView (unArg $ ignoreBlocking sy)-           case iy of-            iy | iy ==% absorber -> redReturn =<< intervalUnview absorber-            iy | iy ==% unit     -> return $ YesReduction YesSimplification (unArg x)-            _                   -> return $ NoReduction [reduced sx,reduced sy]-     _ -> __IMPOSSIBLE__-  where-    (==%) IZero IZero = True-    (==%) IOne IOne = True-    (==%) _ _ = False---primIMin' :: TCM PrimitiveImpl-primIMin' = do-  requireCubical CErased ""-  primIBin IOne IZero--primIMax' :: TCM PrimitiveImpl-primIMax' = do-  requireCubical CErased ""-  primIBin IZero IOne--imax :: HasBuiltins m => m Term -> m Term -> m Term-imax x y = do-  x' <- x-  y' <- y-  intervalUnview (IMax (argN x') (argN y'))--imin :: HasBuiltins m => m Term -> m Term -> m Term-imin x y = do-  x' <- x-  y' <- y-  intervalUnview (IMin (argN x') (argN y'))---- ∀ {a}{c}{A : Set a}{x : A}(C : ∀ y → Id x y → Set c) → C x (conid i1 (\ i → x)) → ∀ {y} (p : Id x y) → C y p-primIdJ :: TCM PrimitiveImpl-primIdJ = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "c" (el $ cl primLevel) $ \ c ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       nPi' "C" (nPi' "y" (el' a bA) $ \ y ->-                 el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->-       el' c (bC <@> x <@>-            (cl primConId <#> a <#> bA <#> x <#> x <@> cl primIOne-                       <@> lam "i" (\ _ -> x))) -->-       hPi' "y" (el' a bA) (\ y ->-        nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->-        el' c $ bC <@> y <@> p)-  conidn <- getBuiltinName builtinConId-  conid  <- primConId-  -- TODO make a kit-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do-    unview <- intervalUnview'-    let imax x y = do x' <- x; unview . IMax (argN x') . argN <$> y;-        imin x y = do x' <- x; unview . IMin (argN x') . argN <$> y;-        ineg x = unview . INeg . argN <$> x-    mcomp <- getTerm' "primComp"-    case ts of-     [la,lc,a,x,c,d,y,eq] -> do-       seq    <- reduceB' eq-       case unArg $ ignoreBlocking $ seq of-         (Def q [Apply la,Apply a,Apply x,Apply y,Apply phi,Apply p])-           | Just q == conidn, Just comp <- mcomp -> do-          redReturn $ runNames [] $ do-             [lc,c,d,la,a,x,y,phi,p] <- mapM (open . unArg) [lc,c,d,la,a,x,y,phi,p]-             let w i = do-                   [x,y,p,i] <- sequence [x,y,p,i]-                   pure $ p `applyE` [IApply x y i]-             pure comp <#> lam "i" (\ _ -> lc)-                       <@> lam "i" (\ i ->-                              c <@> (w i)-                                <@> (pure conid <#> la <#> a <#> x <#> (w i)-                                                <@> (phi `imax` ineg i)-                                                <@> lam "j" (\ j -> w $ imin i j)))-                       <#> phi-                       <@> lam "i" (\ _ -> nolam <$> d) -- TODO block-                       <@> d-         _ -> return $ NoReduction $ map notReduced [la,lc,a,x,c,d,y] ++ [reduced seq]-     _ -> __IMPOSSIBLE__--primIdElim' :: TCM PrimitiveImpl-primIdElim' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "c" (el $ cl primLevel) $ \ c ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       nPi' "C" (nPi' "y" (el' a bA) $ \ y ->-                 el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->-       nPi' "φ" primIntervalType (\ phi ->-        nPi' "y" (el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (const x)) $ \ y ->-        let pathxy = (cl primPath <#> a <@> bA <@> x <@> oucy)-            oucy = (cl primSubOut <#> a <#> bA <#> phi <#> lam "o" (const x) <@> y)-            reflx = (lam "o" $ \ _ -> lam "i" $ \ _ -> x) -- TODO Andrea, should block on o-        in-        nPi' "w" (el's a $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w ->-        let oucw = (cl primSubOut <#> a <#> pathxy <#> phi <#> reflx <@> w) in-        el' c $ bC <@> oucy <@> (cl primConId <#> a <#> bA <#> x <#> oucy <@> phi <@> oucw))-       -->-       hPi' "y" (el' a bA) (\ y ->-        nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->-        el' c $ bC <@> y <@> p)-  conid <- primConId-  sin <- primSubIn-  path <- primPath-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ ts -> do-    case ts of-      [a,c,bA,x,bC,f,y,p] -> do-        sp <- reduceB' p-        case unArg $ ignoreBlocking sp of-          Def q [Apply _a, Apply _bA, Apply _x, Apply _y, Apply phi , Apply w] -> do-            let y' = sin `apply` [a,bA                            ,phi,argN $ unArg y]-            let w' = sin `apply` [a,argN $ path `apply` [a,bA,x,y],phi,argN $ unArg w]-            redReturn $ unArg f `apply` [phi, defaultArg y', defaultArg w']-          _ -> return $ NoReduction $ map notReduced [a,c,bA,x,bC,f,y] ++ [reduced sp]-      _ -> __IMPOSSIBLE__---primPOr :: TCM PrimitiveImpl-primPOr = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (el $ cl primLevel)    $ \ a  ->-          nPi' "i" primIntervalType $ \ i  ->-          nPi' "j" primIntervalType $ \ j  ->-          hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-          ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) -->-          ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) -->-          pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o)-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do-    case ts of-     [l,i,j,a,u,v] -> do-       si <- reduceB' i-       vi <- intervalView $ unArg $ ignoreBlocking si-       case vi of-        IOne -> redReturn (unArg u)-        IZero -> redReturn (unArg v)-        _ -> do-          sj <- reduceB' j-          vj <- intervalView $ unArg $ ignoreBlocking sj-          case vj of-            IOne -> redReturn (unArg v)-            IZero -> redReturn (unArg u)-            _ -> return $ NoReduction [notReduced l,reduced si,reduced sj,notReduced a,notReduced u,notReduced v]---     _ -> __IMPOSSIBLE__--primPartial' :: TCM PrimitiveImpl-primPartial' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) (\ a ->-        nPi' "φ" primIntervalType $ \ _ ->-        nPi' "A" (sort . tmSort <$> a) $ \ bA ->-        (sort . tmSSort <$> a))-  isOne <- primIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 3 $ \ ts -> do-    case ts of-      [l,phi,a] -> do-          (El s (Pi d b)) <- runNamesT [] $ do-                             [l,a,phi] <- mapM (open . unArg) [l,a,phi]-                             elSSet (pure isOne <@> phi) --> el' l a-          redReturn $ Pi (setRelevance Irrelevant $ d { domFinite = True }) b-      _ -> __IMPOSSIBLE__--primPartialP' :: TCM PrimitiveImpl-primPartialP' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) (\ a ->-        nPi' "φ" primIntervalType $ \ phi ->-        nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-        (sort . tmSSort <$> a))-  let toFinitePi :: Type -> Term-      toFinitePi (El _ (Pi d b)) = Pi (setRelevance Irrelevant $ d { domFinite = True }) b-      toFinitePi _               = __IMPOSSIBLE__-  v <- runNamesT [] $-        lam "a" $ \ l ->-        lam "φ" $ \ phi ->-        lam "A" $ \ a ->-        toFinitePi <$> nPi' "p" (elSSet $ cl primIsOne <@> phi) (\ p -> el' l (a <@> p))-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v--primSubOut' :: TCM PrimitiveImpl-primSubOut' = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (el $ cl primLevel) $ \ a ->-          hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-          hPi' "φ" primIntervalType $ \ phi ->-          hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u ->-          el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do-    case ts of-      [a,bA,phi,u,x] -> do-        view <- intervalView'-        sphi <- reduceB' phi-        case view $ unArg $ ignoreBlocking sphi of-          IOne -> redReturn =<< (return (unArg u) <..> (getTerm builtinSubOut builtinItIsOne))-          _ -> do-            sx <- reduceB' x-            mSubIn <- getBuiltinName' builtinSubIn-            case unArg $ ignoreBlocking $ sx of-              Def q [_,_,_, Apply t] | Just q == mSubIn -> redReturn (unArg t)-              _ -> return $ NoReduction $ map notReduced [a,bA] ++ [reduced sphi, notReduced u, reduced sx]-      _ -> __IMPOSSIBLE__--primIdFace' :: TCM PrimitiveImpl-primIdFace' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       hPi' "y" (el' a bA) $ \ y ->-       el' a (cl primId <#> a <#> bA <@> x <@> y)-       --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do-    case ts of-      [l,bA,x,y,t] -> do-        st <- reduceB' t-        mConId <- getName' builtinConId-        case unArg (ignoreBlocking st) of-          Def q [_,_,_,_, Apply phi,_] | Just q == mConId -> redReturn (unArg phi)-          _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st]-      _ -> __IMPOSSIBLE__--primIdPath' :: TCM PrimitiveImpl-primIdPath' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "a" (el $ cl primLevel) $ \ a ->-       hPi' "A" (sort . tmSort <$> a) $ \ bA ->-       hPi' "x" (el' a bA) $ \ x ->-       hPi' "y" (el' a bA) $ \ y ->-       el' a (cl primId <#> a <#> bA <@> x <@> y)-       --> el' a (cl primPath <#> a <#> bA <@> x <@> y)-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do-    case ts of-      [l,bA,x,y,t] -> do-        st <- reduceB' t-        mConId <- getName' builtinConId-        case unArg (ignoreBlocking st) of-          Def q [_,_,_,_,_,Apply w] | Just q == mConId -> redReturn (unArg w)-          _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st]-      _ -> __IMPOSSIBLE__---primTrans' :: TCM PrimitiveImpl-primTrans' = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->-          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->-          nPi' "φ" primIntervalType $ \ phi ->-          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ ts nelims -> do-    primTransHComp DoTransp ts nelims--primHComp' :: TCM PrimitiveImpl-primHComp' = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (el $ cl primLevel) $ \ a ->-          hPi' "A" (sort . tmSort <$> a) $ \ bA ->-          hPi' "φ" primIntervalType $ \ phi ->-          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) -->-          (el' a bA --> el' a bA)-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do-    primTransHComp DoHComp ts nelims--data TranspOrHComp = DoTransp | DoHComp deriving (Eq,Show)--cmdToName :: TranspOrHComp -> String-cmdToName DoTransp = builtinTrans-cmdToName DoHComp  = builtinHComp--data FamilyOrNot a-  = IsFam { famThing :: a }-  | IsNot { famThing :: a }-  deriving (Eq,Show,Functor,Foldable,Traversable)--instance Reduce a => Reduce (FamilyOrNot a) where-  reduceB' x = traverse id <$> traverse reduceB' x-  reduce' x = traverse reduce' x----- | Define a "ghcomp" version of gcomp. Normal comp looks like:------ comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0)------ So for "gcomp" we compute:------ gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0)------ The point of this is that gcomp does not produce any empty--- systems (if phi = 0 it will reduce to "forward A 0 u".-mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)-mkGComp s = do-  let getTermLocal = getTerm s-  tPOr <- getTermLocal "primPOr"-  tIMax <- getTermLocal builtinIMax-  tIMin <- getTermLocal builtinIMin-  tINeg <- getTermLocal builtinINeg-  tHComp <- getTermLocal builtinHComp-  tTrans <- getTermLocal builtinTrans-  io      <- getTermLocal builtinIOne-  iz      <- getTermLocal builtinIZero-  let ineg j = pure tINeg <@> j-      imax i j = pure tIMax <@> i <@> j-  let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))-                                      <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                      <@> r-                                      <@> u-  return $ \ la bA phi u u0 ->-    pure tHComp <#> (la <@> pure io)-                <#> (bA <@> pure io)-                <#> imax phi (ineg phi)-                <@> lam "i" (\ i ->-                      pure tPOr <#> (la <@> i)-                                <@> phi-                                <@> ineg phi-                                <@> ilam "o" (\ a -> bA <@> i)-                                <@> ilam "o" (\ o -> forward la bA i (u <@> i <..> o))-                                <@> ilam "o" (\ o -> forward la bA (pure iz) u0))-                <@> forward la bA (pure iz) u0---unglueTranspGlue :: PureTCM m =>-                  Arg Term-                  -> Arg Term-                  -> FamilyOrNot-                       (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)-                  -> m Term--- ...    |- psi, u0--- ..., i |- la, lb, bA, phi, bT, e-unglueTranspGlue psi u0 (IsFam (la, lb, bA, phi, bT, e)) = do-      let-        localUse = builtinTrans ++ " for " ++ builtinGlue-        getTermLocal = getTerm localUse-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTrans <- getTermLocal builtinTrans-      tForall  <- getTermLocal builtinFaceForall-      tEFun  <- getTermLocal builtinEquivFun-      tEProof <- getTermLocal builtinEquivProof-      tglue   <- getTermLocal builtin_glue-      tunglue <- getTermLocal builtin_unglue-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tLMax   <- getTermLocal builtinLevelMax-      tPath   <- getTermLocal builtinPath-      tTransp <- getTermLocal builtinTranspProof-      tItIsOne <- getTermLocal builtinItIsOne-      kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-      runNamesT [] $ do-        let ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j--        gcomp <- mkGComp localUse--        let transpFill la bA phi u0 i =-              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)-                          <@> ilam "j" (\ j -> bA <@> imin i j)-                          <@> (imax phi (ineg i))-                          <@> u0-        [psi,u0] <- mapM (open . unArg) [psi,u0]--        -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a-        glue1 <- do-          g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]-          return $ \ t a -> g <@> t <@> a--        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]--        -- Andreas, 2022-03-24, fixing #5838-        -- Following the updated note-        ---        --   Simon Huber, A Cubical Type Theory for Higher Inductive Types-        --   https://simhu.github.io/misc/hcomp.pdf (February 2022)-        ---        -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776--        -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/i] u0-        let unglue_u0 i =-              foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0--        view <- intervalView'--        let-          tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i-          t1 o = tf (pure io) o--          -- compute "forall. phi"-          forallphi = pure tForall <@> phi--          -- a1 with gcomp-          a1 = gcomp la bA-                 (imax psi forallphi)-                 (lam "i" $ \ i -> pure tPOr <#> (la <@> i)-                                             <@> psi-                                             <@> forallphi-                                             <@> ilam "o" (\ a -> bA <@> i)-                                             <@> ilam "o" (\ _ -> unglue_u0 i)-                                             <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i)-                                                                               <#> (la <@> i)-                                                                               <#> (bT <@> i <..> o)-                                                                               <#> (bA <@> i)-                                                                               <@> (e <@> i <..> o)-                                                                               <@> (tf i o)))-                 (unglue_u0 (pure iz))--          max l l' = pure tLMax <@> l <@> l'-          sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y-          w i o = pure tEFun <#> (lb <@> i)-                             <#> (la <@> i)-                             <#> (bT <@> i <..> o)-                             <#> (bA <@> i)-                             <@> (e <@> i <..> o)-          fiber la lb bA bB f b =-            (pure (Def (sigmaName kit) []) <#> la-                                           <#> lb-                                           <@> bA-                                           <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))--          -- We don't have to do anything special for "~ forall. phi"-          -- here (to implement "ghcomp") as it is taken care off by-          -- tEProof in t1'alpha below-          pe o = -- o : [ φ 1 ]-            pure tPOr <#> max (la <@> pure io) (lb <@> pure io)-                      <@> psi-                      <@> forallphi-                      <@> ilam "o" (\ _ ->-                             fiber (lb <@> pure io) (la <@> pure io)-                                   (bT <@> (pure io) <..> o) (bA <@> pure io)-                                   (w (pure io) o) a1)-                      <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1))-                      <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))--          -- "ghcomp" is implemented in the proof of tEProof-          -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)-          t1'alpha o = -- o : [ φ 1 ]-             pure tEProof <#> (lb <@> pure io)-                          <#> (la <@> pure io)-                          <@> (bT <@> pure io <..> o)-                          <@> (bA <@> pure io)-                          <@> (e <@> pure io <..> o)-                          <@> a1-                          <@> (imax psi forallphi)-                          <@> pe o--          -- TODO: optimize?-          t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])-          alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])-          a1' = pure tHComp-                  <#> (la <@> pure io)-                  <#> (bA <@> pure io)-                  <#> (imax (phi <@> pure io) psi)-                  <@> lam "j" (\ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)-                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> ilam "o" (\ _ -> a1))-                  <@> a1-        -- glue1 (ilam "o" t1') a1'-        a1'-unglueTranspGlue _ _ _ = __IMPOSSIBLE__--data TermPosition = Head | Eliminated deriving (Eq,Show)--headStop :: PureTCM m => TermPosition -> m Term -> m Bool-headStop tpos phi-  | Head <- tpos = do-      phi <- intervalView =<< (reduce =<< phi)-      return $ not $ isIOne phi-  | otherwise = return False--compGlue :: PureTCM m =>-                  TranspOrHComp-                  -> Arg Term-                  -> Maybe (Arg Term)-                  -> Arg Term-                  -> FamilyOrNot-                       (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)-                  -> TermPosition-                  -> m (Maybe Term)-compGlue DoHComp psi (Just u) u0 (IsNot (la, lb, bA, phi, bT, e)) tpos = do-      let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinGlue)-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tEFun  <- getTermLocal builtinEquivFun-      tglue   <- getTermLocal builtin_glue-      tunglue <- getTermLocal builtin_unglue-      io      <- getTermLocal builtinIOne-      tItIsOne <- getTermLocal builtinItIsOne-      view <- intervalView'-      runNamesT [] $ do-        [psi, u, u0] <- mapM (open . unArg) [psi, u, u0]-        [la, lb, bA, phi, bT, e] <- mapM (open . unArg) [la, lb, bA, phi, bT, e]-        ifM (headStop tpos phi) (return Nothing) $ Just <$> do--        let-          hfill la bA phi u u0 i = pure tHComp <#> la-                                               <#> bA-                                               <#> (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA)-                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> ilam "o" (\ _ -> u0))-                                               <@> u0-          tf i o = hfill lb (bT <..> o) psi u u0 i-          unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g-          a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi)-                           <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA)-                                 <@> ilam "o" (\ o -> unglue (u <@> i <..> o))-                                 <@> ilam "o" (\ o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o))-                           <@> (unglue u0)-          t1 = tf (pure io)-        -- pure tglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> (ilam "o" $ \ o -> t1 o) <@> a1-        case tpos of-          Head -> t1 (pure tItIsOne)-          Eliminated -> a1---- ...    |- psi, u0--- ..., i |- la, lb, bA, phi, bT, e-compGlue DoTransp psi Nothing u0 (IsFam (la, lb, bA, phi, bT, e)) tpos = do-      let-        localUse = builtinTrans ++ " for " ++ builtinGlue-        getTermLocal = getTerm localUse-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTrans <- getTermLocal builtinTrans-      tForall  <- getTermLocal builtinFaceForall-      tEFun  <- getTermLocal builtinEquivFun-      tEProof <- getTermLocal builtinEquivProof-      tglue   <- getTermLocal builtin_glue-      tunglue <- getTermLocal builtin_unglue-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tLMax   <- getTermLocal builtinLevelMax-      tPath   <- getTermLocal builtinPath-      tTransp <- getTermLocal builtinTranspProof-      tItIsOne <- getTermLocal builtinItIsOne-      kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-      runNamesT [] $ do-        let ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j--        gcomp <- mkGComp localUse--        let transpFill la bA phi u0 i =-              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)-                          <@> ilam "j" (\ j -> bA <@> imin i j)-                          <@> (imax phi (ineg i))-                          <@> u0-        [psi,u0] <- mapM (open . unArg) [psi,u0]--        -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a-        glue1 <- do-          g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]-          return $ \ t a -> g <@> t <@> a--        [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]--        -- Andreas, 2022-03-24, fixing #5838-        -- Following the updated note-        ---        --   Simon Huber, A Cubical Type Theory for Higher Inductive Types-        --   https://simhu.github.io/misc/hcomp.pdf (February 2022)-        ---        -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776--        -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0-        let unglue_u0 i =-              foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0--        view <- intervalView'--        ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do-        let-          tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i-          t1 o = tf (pure io) o--          -- compute "forall. phi"-          forallphi = pure tForall <@> phi--          -- a1 with gcomp-          a1 = gcomp la bA-                 (imax psi forallphi)-                 (lam "i" $ \ i -> pure tPOr <#> (la <@> i)-                                             <@> psi-                                             <@> forallphi-                                             <@> ilam "o" (\ _ -> bA <@> i)-                                             <@> ilam "o" (\ _ -> unglue_u0 i)-                                             <@> ilam "o" (\ o -> pure tEFun <#> (lb <@> i)-                                                                               <#> (la <@> i)-                                                                               <#> (bT <@> i <..> o)-                                                                               <#> (bA <@> i)-                                                                               <@> (e <@> i <..> o)-                                                                               <@> (tf i o)))-                 (unglue_u0 (pure iz))--          max l l' = pure tLMax <@> l <@> l'-          sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y-          w i o = pure tEFun <#> (lb <@> i)-                             <#> (la <@> i)-                             <#> (bT <@> i <..> o)-                             <#> (bA <@> i)-                             <@> (e <@> i <..> o)-          fiber la lb bA bB f b =-            (pure (Def (sigmaName kit) []) <#> la-                                           <#> lb-                                           <@> bA-                                           <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b))--          -- We don't have to do anything special for "~ forall. phi"-          -- here (to implement "ghcomp") as it is taken care off by-          -- tEProof in t1'alpha below-          pe o = -- o : [ φ 1 ]-            pure tPOr <#> max (la <@> pure io) (lb <@> pure io)-                      <@> psi-                      <@> forallphi-                      <@> ilam "o" (\ _ ->-                             fiber (lb <@> pure io) (la <@> pure io)-                                   (bT <@> (pure io) <..> o) (bA <@> pure io)-                                   (w (pure io) o) a1)-                      <@> ilam "o" (\ o -> sigCon u0 (lam "_" $ \ _ -> a1))-                      <@> ilam "o" (\ o -> sigCon (t1 o) (lam "_" $ \ _ -> a1))--          -- "ghcomp" is implemented in the proof of tEProof-          -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)-          t1'alpha o = -- o : [ φ 1 ]-             pure tEProof <#> (lb <@> pure io)-                          <#> (la <@> pure io)-                          <@> (bT <@> pure io <..> o)-                          <@> (bA <@> pure io)-                          <@> (e <@> pure io <..> o)-                          <@> a1-                          <@> (imax psi forallphi)-                          <@> pe o--          -- TODO: optimize?-          t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])-          alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])-          a1' = pure tHComp-                  <#> (la <@> pure io)-                  <#> (bA <@> pure io)-                  <#> (imax (phi <@> pure io) psi)-                  <@> lam "j" (\ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)-                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> ilam "o" (\ _ -> a1))-                  <@> a1--        -- glue1 (ilam "o" t1') a1'-        case tpos of-          Head -> t1' (pure tItIsOne)-          Eliminated -> a1'-compGlue cmd phi u u0 _ _ = __IMPOSSIBLE__--compHCompU :: PureTCM m =>-                    TranspOrHComp-                    -> Arg Term-                    -> Maybe (Arg Term)-                    -> Arg Term-                    -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)-                    -> TermPosition-                    -> m (Maybe Term)--compHCompU DoHComp psi (Just u) u0 (IsNot (la, phi, bT, bA)) tpos = do-      let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinHComp ++ " of Set")-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTransp  <- getTermLocal builtinTrans-      tglue   <- getTermLocal builtin_glueU-      tunglue <- getTermLocal builtin_unglueU-      tLSuc   <- getTermLocal builtinLevelSuc-      tSubIn <- getTermLocal builtinSubIn-      tItIsOne <- getTermLocal builtinItIsOne-      runNamesT [] $ do-        [psi, u, u0] <- mapM (open . unArg) [psi, u, u0]-        [la, phi, bT, bA] <- mapM (open . unArg) [la, phi, bT, bA]--        ifM (headStop tpos phi) (return Nothing) $ Just <$> do--        let-          hfill la bA phi u u0 i = pure tHComp <#> la-                                               <#> bA-                                               <#> (pure tIMax <@> phi <@> (pure tINeg <@> i))-                                               <@> lam "j" (\ j -> pure tPOr <#> la <@> phi <@> (pure tINeg <@> i) <@> ilam "o" (\ a -> bA)-                                                     <@> ilam "o" (\ o -> u <@> (pure tIMin <@> i <@> j) <..> o)-                                                     <@> ilam "o" (\ _ -> u0))-                                               <@> u0-          transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0-          tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i-          bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA-          unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g-          a1 = pure tHComp <#> la <#> bA <#> (pure tIMax <@> psi <@> phi)-                           <@> lam "i" (\ i -> pure tPOr <#> la <@> psi <@> phi <@> ilam "_" (\ _ -> bA)-                                 <@> ilam "o" (\ o -> unglue (u <@> i <..> o))-                                 <@> ilam "o" (\ o -> transp la (\ i -> bT <@> (pure tINeg <@> i) <..> o) (tf i o)))-                           <@> unglue u0-          t1 = tf (pure io)--        -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1-        case tpos of-          Eliminated -> a1-          Head       -> t1 (pure tItIsOne)----compHCompU DoTransp psi Nothing u0 (IsFam (la, phi, bT, bA)) tpos = do-      let-        localUse = builtinTrans ++ " for " ++ builtinHComp ++ " of Set"-        getTermLocal = getTerm localUse-      tPOr <- getTermLocal "primPOr"-      tIMax <- getTermLocal builtinIMax-      tIMin <- getTermLocal builtinIMin-      tINeg <- getTermLocal builtinINeg-      tHComp <- getTermLocal builtinHComp-      tTrans <- getTermLocal builtinTrans-      tTranspProof <- getTermLocal builtinTranspProof-      tSubIn <- getTermLocal builtinSubIn-      tForall  <- getTermLocal builtinFaceForall-      io      <- getTermLocal builtinIOne-      iz      <- getTermLocal builtinIZero-      tLSuc   <- getTermLocal builtinLevelSuc-      tPath   <- getTermLocal builtinPath-      tItIsOne   <- getTermLocal builtinItIsOne-      kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-      runNamesT [] $ do-        let ineg j = pure tINeg <@> j-            imax i j = pure tIMax <@> i <@> j-            imin i j = pure tIMin <@> i <@> j-            transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0--        gcomp <- mkGComp localUse--        let transpFill la bA phi u0 i =-              pure tTrans <#> ilam "j" (\ j -> la <@> imin i j)-                          <@> ilam "j" (\ j -> bA <@> imin i j)-                          <@> (imax phi (ineg i))-                          <@> u0-        [psi,u0] <- mapM (open . unArg) [psi,u0]-        glue1 <- do-          tglue   <- cl $ getTermLocal builtin_glueU-          [la, phi, bT, bA] <- mapM (open . unArg . subst 0 io) $ [la, phi, bT, bA]-          let bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA-          g <- (open =<<) $ pure tglue <#> la <#> phi <#> bT <#> bAS-          return $ \ t a -> g <@> t <@> a--        [la, phi, bT, bA] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, phi, bT, bA]--        -- Andreas, 2022-03-25, issue #5838.-        -- Port the fix of @unglueTranspGlue@ and @compGlue DoTransp@-        -- also to @compHCompU DoTransp@, as suggested by Tom Jack and Anders Mörtberg.-        -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@.-        -- The original code used it only with @i0@.-        tunglue <- cl $ getTermLocal builtin_unglueU-        let bAS i =-              pure tSubIn  <#> (pure tLSuc <@> (la <@> i))-                           <#> (Sort . tmSort <$> (la <@> i))-                           <#> (phi <@> i)-                           <@> (bA <@> i)-        let unglue_u0 i =-              pure tunglue <#> (la <@> i)-                           <#> (phi <@> i)-                           <#> (bT <@> i)-                           <#> bAS i-                           <@> u0--        ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do--        let-          lb = la-          tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <@> pure io <..> o) psi u0 i-          t1 o = tf (pure io) o--          -- compute "forall. phi"-          forallphi = pure tForall <@> phi--          -- a1 with gcomp-          a1 = gcomp la bA-                 (imax psi forallphi)-                 (lam "i" $ \ i -> pure tPOr <#> (la <@> i)-                                             <@> psi-                                             <@> forallphi-                                             <@> ilam "o" (\ _ -> bA <@> i)-                                             <@> ilam "o" (\ _ -> unglue_u0 i)-                                             <@> ilam "o" (\ o -> transp (la <@> i)-                                                                           (\ j -> bT <@> i <@> ineg j <..> o)-                                                                           (tf i o)))-                 (unglue_u0 (pure iz))--          w i o = lam "x" $-                  transp (la <@> i)-                         (\ j -> bT <@> i <@> ineg j <..> o)--          pt o = -- o : [ φ 1 ]-            pure tPOr <#> (la <@> pure io)-                      <@> psi-                      <@> forallphi-                      <@> ilam "o" (\ _ -> bT <@> pure io <@> pure io <..> o)-                      <@> ilam "o" (\ o -> u0)-                      <@> ilam "o" (\ o -> t1 o)--          -- "ghcomp" is implemented in the proof of tTranspProof-          -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda)-          t1'alpha o = -- o : [ φ 1 ]-             pure tTranspProof <#> (la <@> pure io)-                               <@> lam "i" (\ i -> bT <@> pure io <@> ineg i <..> o)-                               <@> imax psi forallphi-                               <@> pt o-                               <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io)-                                                <#> imax psi forallphi-                                                <@> a1)--          -- TODO: optimize?-          t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])-          alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])-          a1' = pure tHComp-                  <#> (la <@> pure io)-                  <#> (bA <@> pure io)-                  <#> (imax (phi <@> pure io) psi)-                  <@> lam "j" (\ j ->-                         pure tPOr <#> (la <@> pure io) <@> (phi <@> pure io) <@> psi <@> ilam "o" (\ _ -> bA <@> pure io)-                                   <@> ilam "o" (\ o -> alpha o <@@> (w (pure io) o <@> t1' o,a1,j))-                                   <@> ilam "o" (\ _ -> a1))-                  <@> a1--        -- glue1 (ilam "o" t1') a1'-        case tpos of-          Eliminated -> a1'-          Head       -> t1' (pure tItIsOne)-compHCompU _ psi _ u0 _ _ = __IMPOSSIBLE__---primTransHComp :: TranspOrHComp -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)-primTransHComp cmd ts nelims = do-  (l,bA,phi,u,u0) <- case (cmd,ts) of-        (DoTransp, [l,bA,phi,  u0]) -> do-          -- u <- runNamesT [] $ do-          --       u0 <- open $ unArg u0-          --       defaultArg <$> (ilam "o" $ \ _ -> u0)-          return $ (IsFam l,IsFam bA,phi,Nothing,u0)-        (DoHComp, [l,bA,phi,u,u0]) -> do-          -- [l,bA] <- runNamesT [] $ do-          --   forM [l,bA] $ \ a -> do-          --     let info = argInfo a-          --     a <- open $ unArg a-          --     Arg info <$> (lam "i" $ \ _ -> a)-          return $ (IsNot l,IsNot bA,phi,Just u,u0)-        _                          -> __IMPOSSIBLE__-  sphi <- reduceB' phi-  vphi <- intervalView $ unArg $ ignoreBlocking sphi-  let clP s = getTerm (cmdToName cmd) s--  -- WORK-  case vphi of-     IOne -> redReturn =<< case u of-                            -- cmd == DoComp-                            Just u -> runNamesT [] $ do-                                       u <- open (unArg u)-                                       u <@> clP builtinIOne <..> clP builtinItIsOne-                            -- cmd == DoTransp-                            Nothing -> return $ unArg u0-     _    -> do-       let fallback' sc = do-             u' <- case u of-                            -- cmd == DoComp-                     Just u ->-                              (:[]) <$> case vphi of-                                          IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do-                                            [l,c] <- mapM (open . unArg) [famThing l, ignoreBlocking sc]-                                            lam "i" $ \ i -> clP builtinIsOneEmpty <#> l-                                                                   <#> ilam "o" (\ _ -> c)-                                          _     -> return (notReduced u)-                            -- cmd == DoTransp-                     Nothing -> return []-             return $ NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0]-       sbA <- reduceB' bA-       t <- case unArg <$> ignoreBlocking sbA of-              IsFam (Lam _info t) -> Just . fmap IsFam <$> reduceB' (absBody t)-              IsFam _             -> return Nothing-              IsNot t             -> return . Just . fmap IsNot $ (t <$ sbA)-       case t of-         Nothing -> fallback' (famThing <$> sbA)-         Just st  -> do-               let-                   fallback = fallback' (fmap famThing $ st *> sbA)-                   t = ignoreBlocking st-               mHComp <- getPrimitiveName' builtinHComp-               mGlue <- getPrimitiveName' builtinGlue-               mId   <- getBuiltinName' builtinId-               pathV <- pathView'-               case famThing t of-                 MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA)-                 -- absName t instead of "i"-                 Pi a b | nelims > 0  -> maybe fallback redReturn =<< compPi cmd "i" ((a,b) <$ t) (ignoreBlocking sphi) u u0-                        | otherwise -> fallback--                 Sort (Type l) | DoTransp <- cmd -> compSort cmd fallback phi u u0 (l <$ t)--                 Def q [Apply la, Apply lb, Apply bA, Apply phi', Apply bT, Apply e] | Just q == mGlue -> do-                   maybe fallback redReturn =<< compGlue cmd phi u u0 ((la, lb, bA, phi', bT, e) <$ t) Head--                 Def q [Apply _, Apply s, Apply phi', Apply bT, Apply bA]-                   | Just q == mHComp, Sort (Type la) <- unArg s  -> do-                   maybe fallback redReturn =<< compHCompU cmd phi u u0 ((Level la <$ s, phi', bT, bA) <$ t) Head--                 -- Path/PathP-                 d | PathType _ _ _ bA x y <- pathV (El __DUMMY_SORT__ d) -> do-                   if nelims > 0 then compPathP cmd sphi u u0 l ((bA, x, y) <$ t) else fallback--                 Def q [Apply _ , Apply bA , Apply x , Apply y] | Just q == mId -> do-                   maybe fallback return =<< compId cmd sphi u u0 l ((bA, x, y) <$ t)--                 Def q es -> do-                   info <- getConstInfo q-                   let   lam_i = Lam defaultArgInfo . Abs "i"--                   case theDef info of-                     r@Record{recComp = kit} | nelims > 0, Just as <- allApplyElims es, DoTransp <- cmd, Just transpR <- nameOfTransp kit-                                -> if recPars r == 0-                                   then redReturn $ unArg u0-                                   else redReturn $ (Def transpR []) `apply`-                                               (map (fmap lam_i) as ++ [ignoreBlocking sphi,u0])-                         | nelims > 0, Just as <- allApplyElims es, DoHComp <- cmd, Just hCompR <- nameOfHComp kit-                                -> redReturn $ (Def hCompR []) `apply`-                                               (as ++ [ignoreBlocking sphi,fromMaybe __IMPOSSIBLE__ u,u0])--                         | Just as <- allApplyElims es, [] <- recFields r -> compData False (recPars r) cmd l (as <$ t) sbA sphi u u0-                     Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons}-                       | and [null pcons | DoHComp  <- [cmd]], Just as <- allApplyElims es -> compData (not $ null $ pcons) (pars+ixs) cmd l (as <$ t) sbA sphi u u0-                     Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0-                     _          -> fallback--                 _ -> fallback-  where-    compSort DoTransp fallback phi Nothing u0 (IsFam l) = do-      -- TODO should check l is constant-      redReturn $ unArg u0-    -- compSort DoHComp fallback phi (Just u) u0 (IsNot l) = -- hcomp for Set is a whnf, handled above.-    compSort _ fallback phi u u0 _ = __IMPOSSIBLE__-    compPi :: TranspOrHComp -> ArgName -> FamilyOrNot (Dom Type, Abs Type) -- Γ , i : I-            -> Arg Term -- Γ-            -> Maybe (Arg Term) -- Γ-            -> Arg Term -- Γ-            -> ReduceM (Maybe Term)-    compPi cmd t ab phi u u0 = do-     let getTermLocal = getTerm $ cmdToName cmd ++ " for function types"--     tTrans <- getTermLocal builtinTrans-     tHComp <- getTermLocal builtinHComp-     tINeg <- getTermLocal builtinINeg-     tIMax <- getTermLocal builtinIMax-     iz    <- getTermLocal builtinIZero-     let-      toLevel' t = do-        s <- reduce $ getSort t-        case s of-          (Type l) -> return (Just l)-          _        -> return Nothing-      toLevel t = fromMaybe __IMPOSSIBLE__ <$> toLevel' t-     -- make sure the codomain has a level.-     caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ _ -> do-     runNamesT [] $ do-      labA <- do-        let (x,f) = case ab of-              IsFam (a,_) -> (a, \ a -> runNames [] $ lam "i" (const (pure a)))-              IsNot (a,_) -> (a, id)-        s <- reduce $ getSort x-        case s of-          Type lx -> do-            [la,bA] <- mapM (open . f) [Level lx, unEl . unDom $ x]-            pure $ Just $ \ iOrNot phi a0 -> pure tTrans <#> lam "j" (\ j -> la <@> iOrNot j)-                                                         <@> lam "j" (\ j -> bA <@> iOrNot j)-                                                         <@> phi-                                                         <@> a0-          LockUniv -> return $ Just $ \ _ _ a0 -> a0-          _       -> return Nothing-      caseMaybe labA (return Nothing) $ \ trA -> Just <$> do-      [phi, u0] <- mapM (open . unArg) [phi, u0]-      u <- traverse open (unArg <$> u)--      glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \ u1 -> do-        case (cmd, ab, u) of-          (DoHComp, IsNot (a , b), Just u) -> do-            bT <- (raise 1 b `absApp`) <$> u1-            let v = u1-            pure tHComp <#> (Level <$> toLevel bT)-                        <#> pure (unEl                      $ bT)-                        <#> phi-                        <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) v)-                        <@> (gApply (getHiding a) u0 v)-          (DoTransp, IsFam (a , b), Nothing) -> do-            let v i = do-                       let-                         iOrNot j = pure tIMax <@> i <@> (pure tINeg <@> j)-                       trA iOrNot (pure tIMax <@> phi <@> i)-                                  u1-                -- Γ , u1 : A[i1] , i : I-                bB v = consS v (liftS 1 $ raiseS 1) `applySubst` (absBody b {- Γ , i : I , x : A[i] -})-                tLam = Lam defaultArgInfo-            bT <- bind "i" $ fmap bB . v-            -- Γ , u1 : A[i1]-            (pure tTrans <#> (tLam <$> traverse (fmap Level . toLevel) bT)-                         <@> (pure . tLam $ unEl                      <$> bT)-                         <@> phi-                         <@> gApply (getHiding a) u0 (v (pure iz)))-          (_,_,_) -> __IMPOSSIBLE__-    compPathP cmd@DoHComp sphi (Just u) u0 (IsNot l) (IsNot (bA,x,y)) = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for path types"-      tHComp <- getTermLocal builtinHComp-      tINeg <- getTermLocal builtinINeg-      tIMax <- getTermLocal builtinIMax-      tOr   <- getTermLocal "primPOr"-      let-        ineg j = pure tINeg <@> j-        imax i j = pure tIMax <@> i <@> j--      redReturn . runNames [] $ do-         [l,u,u0] <- mapM (open . unArg) [l,u,u0]-         phi      <- open . unArg . ignoreBlocking $ sphi-         [bA, x, y] <- mapM (open . unArg) [bA, x, y]-         lam "j" $ \ j ->-           pure tHComp <#> l-                       <#> (bA <@> j)-                       <#> (phi `imax` (ineg j `imax` j))-                       <@> lam "i'" (\ i ->-                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i)-                            in or phi (ineg j `imax` j)-                                          <@> ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j)) -- a0 <@@> (x <@> i, y <@> i, j)-                                          <@> (or (ineg j) j <@> ilam "_" (const x)-                                                                  <@> ilam "_" (const y)))-                       <@> (u0 <@@> (x, y, j))-    compPathP cmd@DoTransp sphi Nothing u0 (IsFam l) (IsFam (bA,x,y)) = do-      -- Γ    ⊢ l-      -- Γ, i ⊢ bA, x, y-      let getTermLocal = getTerm $ cmdToName cmd ++ " for path types"-      tINeg <- getTermLocal builtinINeg-      tIMax <- getTermLocal builtinIMax-      tOr   <- getTermLocal "primPOr"-      iz <- getTermLocal builtinIZero-      io <- getTermLocal builtinIOne-      let-        ineg j = pure tINeg <@> j-        imax i j = pure tIMax <@> i <@> j-      comp <- do-        tHComp <- getTermLocal builtinHComp-        tTrans <- getTermLocal builtinTrans-        let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))-                                            <@> lam "i" (\ i -> bA <@> (i `imax` r))-                                            <@> r-                                            <@> u-        return $ \ la bA phi u u0 ->-          pure tHComp <#> (la <@> pure io)-                      <#> (bA <@> pure io)-                      <#> phi-                      <@> lam "i" (\ i -> ilam "o" $ \ o ->-                              forward la bA i (u <@> i <..> o))-                      <@> forward la bA (pure iz) u0-      redReturn . runNames [] $ do-        [l,u0] <- mapM (open . unArg) [l,u0]-        phi      <- open . unArg . ignoreBlocking $ sphi-        [bA, x, y] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]-        lam "j" $ \ j ->-          comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j))-                      (lam "i'" $ \ i ->-                            let or f1 f2 = pure tOr <#> l <@> f1 <@> f2 <#> lam "_" (\ _ -> bA <@> i <@> j) in-                                       or phi (ineg j `imax` j)-                                          <@> ilam "o" (\ o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j))-                                          <@> (or (ineg j) j <@> ilam "_" (const (x <@> i))-                                                                  <@> ilam "_" (const (y <@> i))))-                      (u0 <@@> (x <@> pure iz, y <@> pure iz, j))-    compPathP _ sphi u a0 _ _ = __IMPOSSIBLE__-    compId cmd sphi u a0 l bA_x_y = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for " ++ builtinId-      unview <- intervalUnview'-      mConId <- getBuiltinName' builtinConId-      let isConId (Def q _) = Just q == mConId-          isConId _         = False-      sa0 <- reduceB' a0-      -- wasteful to compute b even when cheaper checks might fail-      b <- case u of-             Nothing -> return True-             Just u  -> allComponents unview (unArg . ignoreBlocking $ sphi) (unArg u) isConId-      case mConId of-        Just conid | isConId (unArg . ignoreBlocking $ sa0) , b -> (Just <$>) . (redReturn =<<) $ do-          tHComp <- getTermLocal builtinHComp-          tTrans <- getTermLocal builtinTrans-          tIMin <- getTermLocal "primDepIMin"-          tFace <- getTermLocal "primIdFace"-          tPath <- getTermLocal "primIdPath"-          tPathType <- getTermLocal builtinPath-          runNamesT [] $ do-            let io = pure $ unview IOne-                iz = pure $ unview IZero-                conId = pure $ Def conid []-            l <- case l of-                   IsFam l -> open . unArg $ l-                   IsNot l -> do-                     open (Lam defaultArgInfo $ NoAbs "_" $ unArg l)-            [p0] <- mapM (open . unArg) [a0]-            p <- case u of-                   Just u -> do-                     u <- open . unArg $ u-                     return $ \ i o -> u <@> i <..> o-                   Nothing -> do-                     return $ \ i o -> p0-            phi      <- open . unArg . ignoreBlocking $ sphi-            [bA, x, y] <--              case bA_x_y of-                IsFam (bA,x,y) -> mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]-                IsNot (bA,x,y) -> forM [bA,x,y] $ \ a -> open (Lam defaultArgInfo $ NoAbs "_" $ unArg a)-            let-              eval DoTransp l bA phi _ u0 = pure tTrans <#> l <@> bA <@> phi <@> u0-              eval DoHComp l bA phi u u0 = pure tHComp <#> (l <@> io) <#> (bA <@> io) <#> phi-                                                       <@> u <@> u0-            conId <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)-                  <@> (pure tIMin <@> phi-                                  <@> ilam "o" (\ o -> pure tFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)-                                                                   <@> (p io o)))-                  <@> (eval cmd l-                                (lam "i" $ \ i -> pure tPathType <#> (l <@> i) <#> (bA <@> i) <@> (x <@> i) <@> (y <@> i))-                                phi-                                (lam "i" $ \ i -> ilam "o" $ \ o -> pure tPath <#> (l <@> i) <#> (bA <@> i)-                                                                                    <#> (x <@> i) <#> (y <@> i)-                                                                                    <@> (p i o)-                                      )-                                (pure tPath <#> (l <@> iz) <#> (bA <@> iz) <#> (x <@> iz) <#> (y <@> iz)-                                                  <@> p0)-                      )-        _ -> return $ Nothing-    allComponents unview phi u p = do-            let-              boolToI b = if b then unview IOne else unview IZero-            as <- decomposeInterval phi-            andM . for as $ \ (bs,ts) -> do-                 let u' = listS (Map.toAscList $ Map.map boolToI bs) `applySubst` u-                 t <- reduce2Lam u'-                 return $! p $ ignoreBlocking t-    reduce2Lam t = do-          t <- reduce' t-          case lam2Abs t of-            t -> underAbstraction_ t $ \ t -> do-               t <- reduce' t-               case lam2Abs t of-                 t -> underAbstraction_ t reduceB'-         where-           lam2Abs (Lam _ t) = absBody t <$ t-           lam2Abs t         = Abs "y" (raise 1 t `apply` [argN $ var 0])-    allComponentsBack unview phi u p = do-            let-              boolToI b = if b then unview IOne else unview IZero-              lamlam t = Lam defaultArgInfo (Abs "i" (Lam (setRelevance Irrelevant defaultArgInfo) (Abs "o" t)))-            as <- decomposeInterval phi-            (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do-                 let u' = listS bs' `applySubst` u-                     bs' = (Map.toAscList $ Map.map boolToI bs)-                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]-                     -- ordering of "j,i,.." matters.-                 let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs')-                 t <- reduce2Lam u'-                 return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ])-            return $ (flags,t_alphas)-    compData False _ cmd@DoHComp (IsNot l) (IsNot ps) fsc sphi (Just u) a0 = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for data types"--      let sc = famThing <$> fsc-      tEmpty <- getTermLocal builtinIsOneEmpty-      tPOr   <- getTermLocal builtinPOr-      iO   <- getTermLocal builtinIOne-      iZ   <- getTermLocal builtinIZero-      tMin <- getTermLocal builtinIMin-      tNeg <- getTermLocal builtinINeg-      let iNeg t = tNeg `apply` [argN t]-          iMin t u = tMin `apply` [argN t, argN u]-          iz = pure iZ-      constrForm <- do-        mz <- getTerm' builtinZero-        ms <- getTerm' builtinSuc-        return $ \ t -> fromMaybe t (constructorForm' mz ms t)-      su  <- reduceB' u-      sa0 <- reduceB' a0-      view   <- intervalView'-      unview <- intervalUnview'-      let f = unArg . ignoreBlocking-          phi = f sphi-          a0 = f sa0-          isLit t@(Lit lt) = Just t-          isLit _ = Nothing-          isCon (Con h _ _) = Just h-          isCon _           = Nothing-          combine l ty d [] = d-          combine l ty d [(psi,u)] = u-          combine l ty d ((psi,u):xs)-            = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs-                        <#> ilam "o" (\ _ -> ty) -- the type-                        <@> u <@> (combine l ty d xs)-          noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0]-            where-              su' = case view phi of-                     IZero -> notBlocked $ argN $ runNames [] $ do-                                 [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]-                                 lam "i" $ \ i -> pure tEmpty <#> l-                                                              <#> ilam "o" (\ _ -> c)-                     _     -> su-          sameConHeadBack Nothing Nothing su k = noRed' su-          sameConHeadBack lt h su k = do-            let u = unArg . ignoreBlocking $ su-            (b, ts) <- allComponentsBack unview phi u $ \ t ->-                        (isLit t == lt, isCon (constrForm t) == h)-            let-              (lit,hd) = unzip b--            if isJust lt && and lit then redReturn a0 else do-            su <- caseMaybe (sequence ts) (return su) $ \ ts -> do-              let (us,bools) = unzip ts-              fmap ((sequenceA_ us $>) . argN) $ do-              let-                phis :: [Term]-                phis = for bools $ \ m ->-                            foldr (iMin . (\(i,b) -> if b then var i else iNeg (var i))) iO (Map.toList m)-              runNamesT [] $ do-                u <- open u-                [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]-                phis <- mapM open phis-                us   <- mapM (open . ignoreBlocking) us-                lam "i" $ \ i -> do-                  combine l c (u <@> i) $ zip phis (map (\ t -> t <@> i) us)--            if isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su-                      else noRed' su--      sameConHeadBack (isLit a0) (isCon a0) su $ \ h su -> do-            let u = unArg . ignoreBlocking $ su-            Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)-            case nameOfHComp cm of-              Just hcompD -> redReturn $ Def hcompD [] `apply`-                                          (ps ++ map argN [phi,u,a0])-              Nothing        -> noRed' su--    compData _     0 DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = redReturn $ unArg a0-    compData isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do-      let getTermLocal = getTerm $ cmdToName cmd ++ " for data types"-      let sc = famThing <$> fsc-      mhcompName <- getName' builtinHComp-      constrForm <- do-        mz <- getTerm' builtinZero-        ms <- getTerm' builtinSuc-        return $ \ t -> fromMaybe t (constructorForm' mz ms t)-      sa0 <- reduceB' a0-      let f = unArg . ignoreBlocking-          phi = f sphi-          a0 = f sa0-          noRed = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced sa0]-      let lam_i = Lam defaultArgInfo . Abs "i"-      case constrForm a0 of-        Con h _ args -> do-          Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)-          case nameOfTransp cm of-              Just transpD -> redReturn $ Def transpD [] `apply`-                                          (map (fmap lam_i) ps ++ map argN [phi,a0])-              Nothing        -> noRed-        Def q es | isHIT, Just q == mhcompName, Just [_l0,_c0,psi,u,u0] <- allApplyElims es -> do-           let bC = ignoreBlocking sc-           hcomp <- getTermLocal builtinHComp-           transp <- getTermLocal builtinTrans-           io <- getTermLocal builtinIOne-           iz <- getTermLocal builtinIZero-           redReturn <=< runNamesT [] $ do-             [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0]-             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)-             pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi-                   <@> lam "j" (\ j -> ilam "o" $ \ o ->-                        pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o))-                   <@> (pure transp <#> l <@> bC <@> phi <@> u0)-        _ -> noRed-    compData _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__--primComp :: TCM PrimitiveImpl-primComp = do-  requireCubical CErased ""-  t    <- runNamesT [] $-          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->-          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->-          hPi' "φ" primIntervalType $ \ phi ->-          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) -->-          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))-  one <- primItIsOne-  io  <- primIOne-  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do-    case ts of-      [l,c,phi,u,a0] -> do-        sphi <- reduceB' phi-        vphi <- intervalView $ unArg $ ignoreBlocking sphi-        case vphi of-          IOne -> redReturn (unArg u `apply` [argN io, argN one])-          _    -> do-            let getTermLocal = getTerm $ builtinComp-            tIMax <- getTermLocal builtinIMax-            tINeg <- getTermLocal builtinINeg-            tHComp <- getTermLocal builtinHComp-            tTrans <- getTermLocal builtinTrans-            iz      <- getTermLocal builtinIZero-            redReturn <=< runNamesT [] $ do-              comp <- do-                let imax i j = pure tIMax <@> i <@> j-                    forward la bA r u = pure tTrans <#> (lam "i" $ \ i -> la <@> (i `imax` r))-                                                    <@> (lam "i" $ \ i -> bA <@> (i `imax` r))-                                                    <@> r-                                                    <@> u-                return $ \ la bA phi u u0 ->-                  pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi-                              <@> lam "i" (\ i -> ilam "o" $ \ o ->-                                      forward la bA i (u <@> i <..> o))-                              <@> forward la bA (pure iz) u0--              [l,c,phi,u,a0] <- mapM (open . unArg) [l,c,phi,u,a0]-              comp l c phi u a0--      _ -> __IMPOSSIBLE__---prim_glueU' :: TCM PrimitiveImpl-prim_glueU' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->-       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do-       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)-       pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o))-         --> (el' la bA)-         --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA))-  view <- intervalView'-  one <- primItIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->-    case ts of-      [la,phi,bT,bA,t,a] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> redReturn $ unArg t `apply` [argN one]-         _    -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA,t,a])-      _ -> __IMPOSSIBLE__--prim_unglueU' :: TCM PrimitiveImpl-prim_unglueU' = do-  requireCubical CErased ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->-       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do-       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)-       el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)-         --> el' la bA)-  view <- intervalView'-  one <- primItIsOne-  mglueU <- getPrimitiveName' builtin_glueU-  mtransp <- getPrimitiveName' builtinTrans-  mHCompU <- getPrimitiveName' builtinHComp-  let mhcomp = mHCompU-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ts ->-    case ts of-      [la,phi,bT,bA,b] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> do-           tTransp <- getTerm builtin_unglueU builtinTrans-           iNeg    <- getTerm builtin_unglueU builtinINeg-           iZ      <- getTerm builtin_unglueU builtinIZero-           redReturn <=< runNamesT [] $ do-             [la,bT,b] <- mapM (open . unArg) [la,bT,b]-             pure tTransp <#> lam "i" (\ _ -> la)-                          <@> lam "i" (\ i -> bT <@> (pure iNeg <@> i) <..> pure one)-                          <@> pure iZ-                          <@> b-         _    -> do-            sb <- reduceB' b-            let fallback sbA = return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])-            case unArg $ ignoreBlocking $ sb of-               Def q [Apply _,Apply _,Apply _,Apply _,Apply _,Apply a]-                     | Just q == mglueU -> redReturn $ unArg a-               Def q [Apply l,Apply bA,Apply r,Apply u0]-                     | Just q == mtransp -> do-                     sbA <- reduceB bA-                     case unArg $ ignoreBlocking sbA of-                       Lam _ t -> do-                         st <- reduceB' (absBody t)-                         case ignoreBlocking st of-                           Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do-                             redReturn . fromMaybe __IMPOSSIBLE__ =<< compHCompU DoTransp r Nothing u0 (IsFam (la,phi,bT,bA)) Eliminated-                           _ -> fallback (st *> sbA)-                       _  -> fallback sbA-               Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0]-                     | Just q == mhcomp -> do-                     sbA <- reduceB bA-                     case unArg $ ignoreBlocking sbA of-                       Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do-                         redReturn . fromMaybe __IMPOSSIBLE__ =<< compHCompU DoHComp r (Just u) u0 (IsNot (la,phi,bT,bA)) Eliminated-                       _ -> fallback sbA-               _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])-      _ -> __IMPOSSIBLE__---primGlue' :: TCM PrimitiveImpl-primGlue' = do-  requireCubical CFull ""-  -- Glue' : ∀ {l} (A : Set l) → ∀ φ → (T : Partial (Set a) φ) (f : (PartialP φ \ o → (T o) -> A))-  --            ([f] : PartialP φ \ o → isEquiv (T o) A (f o)) → Set l-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "lb" (el $ cl primLevel) $ \ lb ->-       nPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" primIntervalType $ \ φ ->-       nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a)-       --> (sort . tmSort <$> lb))-  view <- intervalView'-  one <- primItIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->-    case ts of-     [la,lb,a,phi,t,e] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> redReturn $ unArg t `apply` [argN one]-         _    -> return (NoReduction $ map notReduced [la,lb,a] ++ [reduced sphi] ++ map notReduced [t,e])-     _ -> __IMPOSSIBLE__--prim_glue' :: TCM PrimitiveImpl-prim_glue' = do-  requireCubical CFull ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "lb" (el $ cl primLevel) $ \ lb ->-       hPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->-       pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)))-  view <- intervalView'-  one <- primItIsOne-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \ts ->-    case ts of-      [la,lb,bA,phi,bT,e,t,a] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> redReturn $ unArg t `apply` [argN one]-         _    -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e,t,a])-      _ -> __IMPOSSIBLE__--prim_unglue' :: TCM PrimitiveImpl-prim_unglue' = do-  requireCubical CFull ""-  t <- runNamesT [] $-       hPi' "la" (el $ cl primLevel) (\ la ->-       hPi' "lb" (el $ cl primLevel) $ \ lb ->-       hPi' "A" (sort . tmSort <$> la) $ \ a ->-       hPi' "φ" primIntervalType $ \ φ ->-       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->-       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->-       (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a)-  view <- intervalView'-  one <- primItIsOne-  mGlue <- getPrimitiveName' builtinGlue-  mglue <- getPrimitiveName' builtin_glue-  mtransp <- getPrimitiveName' builtinTrans-  mhcomp <- getPrimitiveName' builtinHComp-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 7 $ \ts ->-    case ts of-      [la,lb,bA,phi,bT,e,b] -> do-       sphi <- reduceB' phi-       case view $ unArg $ ignoreBlocking $ sphi of-         IOne -> do-           let argOne = setRelevance Irrelevant $ argN one-           tEFun <- getTerm builtin_unglue builtinEquivFun-           redReturn $ tEFun `apply` [lb,la,argH $ unArg bT `apply` [argOne],bA, argN $ unArg e `apply` [argOne],b]-         _    -> do-            sb <- reduceB' b-            let fallback sbA = return (NoReduction $ map notReduced [la,lb] ++ map reduced [sbA, sphi] ++ map notReduced [bT,e] ++ [reduced sb])-            case unArg $ ignoreBlocking $ sb of-               Def q [Apply _,Apply _,Apply _,Apply _,Apply _,Apply _,Apply _,Apply a]-                     | Just q == mglue -> redReturn $ unArg a-               Def q [Apply l,Apply bA,Apply r,Apply u0]-                     | Just q == mtransp -> do-                 sbA <- reduceB' bA-                 case unArg $ ignoreBlocking sbA of-                   Lam _ t -> do-                     st <- reduceB' (absBody t)-                     case ignoreBlocking st of-                       Def g es | Just [la',lb',bA',phi',bT',e'] <- allApplyElims es, Just g == mGlue -> do-                           redReturn . fromMaybe __IMPOSSIBLE__ =<< compGlue DoTransp r Nothing u0 (IsFam (la',lb',bA',phi',bT',e')) Eliminated-                       _ -> fallback (st *> sbA)-                   _ -> fallback sbA-               Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0]-                     | Just q == mhcomp -> do-                 sbA <- reduceB' bA-                 case unArg $ ignoreBlocking sbA of-                   Def g es | Just [la',lb',bA',phi',bT',e'] <- allApplyElims es, Just g == mGlue -> do-                       redReturn . fromMaybe __IMPOSSIBLE__ =<< compGlue DoHComp r (Just u) u0 (IsNot (la',lb',bA',phi',bT',e')) Eliminated-                   _ -> fallback sbA-               _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e] ++ [reduced sb])-      _ -> __IMPOSSIBLE__----- TODO Andrea: keep reductions that happen under foralls?-primFaceForall' :: TCM PrimitiveImpl-primFaceForall' = do-  requireCubical CErased ""-  t <- (primIntervalType --> primIntervalType) --> primIntervalType-  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \ts -> case ts of-    [phi] -> do-      sphi <- reduceB' phi-      case unArg $ ignoreBlocking $ sphi of-        Lam _ t -> do-          t <- reduce' t-          case t of-            NoAbs _ t -> redReturn t-            Abs _ t ->-              maybe (return $ NoReduction [reduced sphi]) redReturn-                =<< toFaceMapsPrim t-        _ -> return (NoReduction [reduced sphi])-    _ -> __IMPOSSIBLE__-  where-    toFaceMapsPrim t = do-      view <- intervalView'-      unview <- intervalUnview'-      us' <- decomposeInterval t-      fr <- getTerm builtinFaceForall builtinFaceForall-      let v = view t-          us =-            [ map Left (Map.toList bsm) ++ map Right ts-              | (bsm, ts) <- us',-                0 `Map.notMember` bsm-            ]-          fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1)))-          ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t]-          r =-            Just $-              foldr-                ( (\x r -> unview (IMax (argN x) (argN r)))-                    . foldr-                      (\x r -> unview (IMin (argN (either fm ffr x)) (argN r)))-                      (unview IOne)-                )-                (unview IZero)-                us-      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $-      return $ case us' of-        [(m, [_])] | Map.null m -> Nothing-        v -> r--decomposeInterval :: HasBuiltins m => Term -> m [(Map Int Bool,[Term])]-decomposeInterval t = do-  xs <- decomposeInterval' t-  let isConsistent xs = all (\ xs -> Set.size xs == 1) . Map.elems $ xs  -- optimize by not doing generate + filter-  return [ (Map.map (head . Set.toList) bsm,ts)-            | (bsm,ts) <- xs-            , isConsistent bsm-            ]--decomposeInterval' :: HasBuiltins m => Term -> m [(Map Int (Set Bool),[Term])]-decomposeInterval' t = do-     view   <- intervalView'-     unview <- intervalUnview'-     let f :: IntervalView -> [[Either (Int,Bool) Term]]-         -- TODO handle primIMinDep-         -- TODO? handle forall-         f IZero = mzero-         f IOne  = return []-         f (IMin x y) = do xs <- (f . view . unArg) x; ys <- (f . view . unArg) y; return (xs ++ ys)-         f (IMax x y) = msum $ map (f . view . unArg) [x,y]-         f (INeg x)   = map (either (\ (x,y) -> Left (x,not y)) (Right . unview . INeg . argN)) <$> (f . view . unArg) x-         f (OTerm (Var i [])) = return [Left (i,True)]-         f (OTerm t)          = return [Right t]-         v = view t-     return [ (bsm,ts)-            | xs <- f v-            , let (bs,ts) = partitionEithers xs-            , let bsm     = (Map.fromListWith Set.union . map (id -*- Set.singleton)) bs-            ]----- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types.---   If a type in the telescope does not support transp, @transpTel@ throws it as an exception.-transpTel :: Abs Telescope -- Γ ⊢ i.Δ-          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ-          -> Args          -- Γ ⊢ δ : Δ[0]-          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[1]-transpTel delta phi args = do-  tTransp <- liftTCM primTrans-  imin <- liftTCM primIMin-  imax <- liftTCM primIMax-  ineg <- liftTCM primINeg-  let-    noTranspError t = lift . throwError =<< liftTCM (buildClosure t)-    bapp :: (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a-    bapp t u = lazyAbsApp <$> t <*> u-    gTransp (Just l) t phi a = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a-    gTransp Nothing  t phi a = do-      -- Γ ⊢ i.Ξ-      xi <- (open =<<) $ do-        bind "i" $ \ i -> do-          TelV xi _ <- (liftTCM . telView =<<) $ t `bapp` i-          return xi-      argnames <- do-        teleArgNames . unAbs <$> xi-      glamN argnames $ \ xi_args -> do-        b' <- bind "i" $ \ i -> do-          ti <- t `bapp` i-          xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)-          xi_args <- xi_args-          ni <- pure ineg <@> i-          phi <- phi-          lift $ piApplyM ti =<< trFillTel xin phi xi_args ni-        axi <- do-          a <- a-          xif <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)-          phi <- phi-          xi_args <- xi_args-          lift $ apply a <$> transpTel xif phi xi_args-        s <- reduce $ getSort (absBody b')-        case s of-          Type l -> do-            l <- open $ lam_i (Level l)-            b' <- open b'-            axi <- open axi-            gTransp (Just l) b' phi axi-          Inf _ n  ->-            if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi-          SSet _  ->-            if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) then noTranspError b' else return axi-          _ -> noTranspError b'-    lam_i = Lam defaultArgInfo . Abs "i"-    go :: Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args-    go EmptyTel            _   []       = return []-    go (ExtendTel t delta) phi (a:args) = do-      -- Γ,i ⊢ t-      -- Γ,i ⊢ (x : t). delta-      -- Γ ⊢ a : t[0]-      s <- reduce $ getSort t-      -- Γ ⊢ b : t[1], Γ,i ⊢ b : t[i]-      (b,bf) <- runNamesT [] $ do-        l <- case s of-               SSet _ -> return Nothing-               Inf _ n -> return Nothing-               Type l -> Just <$> open (lam_i (Level l))-               _ -> noTranspError (Abs "i" (unDom t))-        t <- open $ Abs "i" (unDom t)-        [phi,a] <- mapM open [phi, unArg a]-        b <- gTransp l t phi a-        bf <- bind "i" $ \ i -> do-                            gTransp ((<$> l) $ \ l -> lam "j" $ \ j -> l <@> (pure imin <@> i <@> j))-                                    (bind "j" $ \ j -> t `bapp` (pure imin <@> i <@> j))-                                    (pure imax <@> (pure ineg <@> i) <@> phi)-                                    a-        return (b, absBody bf)-      (:) (b <$ a) <$> go (lazyAbsApp delta bf) phi args-    go (ExtendTel t delta) phi []    = __IMPOSSIBLE__-    go EmptyTel            _   (_:_) = __IMPOSSIBLE__-  go (absBody delta) phi args---- | Like @transpTel@ but performing a transpFill.-trFillTel :: Abs Telescope -- Γ ⊢ i.Δ-          -> Term-          -> Args          -- Γ ⊢ δ : Δ[0]-          -> Term          -- Γ ⊢ r : I-          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[r]-trFillTel delta phi args r = do-  imin <- liftTCM primIMin-  imax <- liftTCM primIMax-  ineg <- liftTCM primINeg-  transpTel (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r])))-            (imax `apply` [argN $ ineg `apply` [argN r], argN phi])-            args+{-# LANGUAGE TypeFamilies #-}++module Agda.TypeChecking.Primitive.Cubical+  ( module Agda.TypeChecking.Primitive.Cubical+  , module Agda.TypeChecking.Primitive.Cubical.Id+  , module Agda.TypeChecking.Primitive.Cubical.Base+  , module Agda.TypeChecking.Primitive.Cubical.Glue+  , module Agda.TypeChecking.Primitive.Cubical.HCompU+  )+  where++import Prelude hiding (null, (!!))++import Control.Monad+import Control.Monad.Except+import Control.Monad.Trans ( lift )+import Control.Exception++import Data.String++import Data.Bifunctor ( second )+import Data.Either ( partitionEithers )+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import qualified Data.List as List+import Data.Foldable hiding (null)++import Agda.Interaction.Options ( optCubical )++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern++import Agda.TypeChecking.Names+import Agda.TypeChecking.Primitive.Base+import Agda.TypeChecking.Monad++import Agda.TypeChecking.Free+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Reduce+import Agda.TypeChecking.Telescope++import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Maybe++import Agda.Utils.Impossible+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.Tuple+import Agda.Utils.Size+import Agda.Utils.BoolSet (BoolSet)+import qualified Agda.Utils.Pretty as P+import qualified Agda.Utils.BoolSet as BoolSet++import Agda.TypeChecking.Primitive.Cubical.HCompU+import Agda.TypeChecking.Primitive.Cubical.Glue+import Agda.TypeChecking.Primitive.Cubical.Base+import Agda.TypeChecking.Primitive.Cubical.Id++primPOr :: TCM PrimitiveImpl+primPOr = do+  requireCubical CErased ""+  t    <- runNamesT [] $+          hPi' "a" (el $ cl primLevel)    $ \ a  ->+          nPi' "i" primIntervalType $ \ i  ->+          nPi' "j" primIntervalType $ \ j  ->+          hPi' "A" (pPi' "o" (imax i j) $ \o -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+          ((pPi' "i1" i $ \ i1 -> el' a $ bA <..> (cl primIsOne1 <@> i <@> j <@> i1))) -->+          ((pPi' "j1" j $ \ j1 -> el' a $ bA <..> (cl primIsOne2 <@> i <@> j <@> j1))) -->+          pPi' "o" (imax i j) (\ o -> el' a $ bA <..> o)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ ts -> do+    case ts of+     [l,i,j,a,u,v] -> do+       si <- reduceB' i+       vi <- intervalView $ unArg $ ignoreBlocking si+       case vi of+        IOne -> redReturn (unArg u)+        IZero -> redReturn (unArg v)+        _ -> do+          sj <- reduceB' j+          vj <- intervalView $ unArg $ ignoreBlocking sj+          case vj of+            IOne -> redReturn (unArg v)+            IZero -> redReturn (unArg u)+            _ -> return $ NoReduction [notReduced l,reduced si,reduced sj,notReduced a,notReduced u,notReduced v]+++     _ -> __IMPOSSIBLE__++primPartial' :: TCM PrimitiveImpl+primPartial' = do+  requireCubical CErased ""+  t <- runNamesT [] $+       hPi' "a" (el $ cl primLevel) (\ a ->+        nPi' "φ" primIntervalType $ \ _ ->+        nPi' "A" (sort . tmSort <$> a) $ \ bA ->+        (sort . tmSSort <$> a))+  isOne <- primIsOne+  v <- runNamesT [] $+        lam "a" $ \ l ->+        lam "φ" $ \ phi ->+        lam "A" $ \ a ->+        unEl <$> pPi' "p" phi (\_ -> el' l a)+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v++primPartialP' :: TCM PrimitiveImpl+primPartialP' = do+  requireCubical CErased ""+  t <- runNamesT [] $+       hPi' "a" (el $ cl primLevel) (\ a ->+        nPi' "φ" primIntervalType $ \ phi ->+        nPi' "A" (pPi' "o" phi $ \ _ -> el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+        (sort . tmSSort <$> a))+  v <- runNamesT [] $+        lam "a" $ \ l ->+        lam "φ" $ \ phi ->+        lam "A" $ \ a ->+        unEl <$> pPi' "p" phi (\ p -> el' l (a <@> p))+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ _ -> redReturn v++primSubOut' :: TCM PrimitiveImpl+primSubOut' = do+  requireCubical CErased ""+  t    <- runNamesT [] $+          hPi' "a" (el $ cl primLevel) $ \ a ->+          hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          hPi' "u" (el's a $ cl primPartial <#> a <@> phi <@> bA) $ \ u ->+          el's a (cl primSub <#> a <@> bA <@> phi <@> u) --> el' a bA+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ ts -> do+    case ts of+      [a,bA,phi,u,x] -> do+        view <- intervalView'+        sphi <- reduceB' phi+        case view $ unArg $ ignoreBlocking sphi of+          IOne -> redReturn =<< (return (unArg u) <..> (getTerm builtinSubOut builtinItIsOne))+          _ -> do+            sx <- reduceB' x+            mSubIn <- getBuiltinName' builtinSubIn+            case unArg $ ignoreBlocking $ sx of+              Def q [_,_,_, Apply t] | Just q == mSubIn -> redReturn (unArg t)+              _ -> return $ NoReduction $ map notReduced [a,bA] ++ [reduced sphi, notReduced u, reduced sx]+      _ -> __IMPOSSIBLE__++primTrans' :: TCM PrimitiveImpl+primTrans' = do+  requireCubical CErased ""+  t    <- runNamesT [] $+          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->+          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->+          nPi' "φ" primIntervalType $ \ phi ->+          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))+  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 $ \ ts nelims -> do+    primTransHComp DoTransp ts nelims++primHComp' :: TCM PrimitiveImpl+primHComp' = do+  requireCubical CErased ""+  t    <- runNamesT [] $+          hPi' "a" (el $ cl primLevel) $ \ a ->+          hPi' "A" (sort . tmSort <$> a) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' a bA) -->+          (el' a bA --> el' a bA)+  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do+    primTransHComp DoHComp ts nelims++-- | Construct a helper for CCHM composition, with a string indicating+-- what function uses it.+mkComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)+mkComp s = do+  let getTermLocal = getTerm s+  tIMax  <- getTermLocal builtinIMax+  tINeg  <- getTermLocal builtinINeg+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  iz     <- getTermLocal builtinIZero+  io     <- getTermLocal builtinIOne++  let+    forward la bA r u = pure tTrans+      <#> (lam "i" $ \i -> la <@> (i `imax` r))+      <@> (lam "i" $ \i -> bA <@> (i `imax` r))+      <@> r+      <@> u++  pure $ \la bA phi u u0 ->+    pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io) <#> phi+                <@> lam "i" (\i -> ilam "o" $ \o ->+                        forward la bA i (u <@> i <..> o))+                <@> forward la bA (pure iz) u0++-- | Construct an application of buitlinComp. Use instead of 'mkComp' if+-- reducing directly to hcomp + transport would be problematic.+mkCompLazy+  :: HasBuiltins m+  => String+  -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)+mkCompLazy s = do+  let getTermLocal = getTerm s+  tComp <- getTermLocal builtinComp+  pure $ \la bA phi u u0 -> pure tComp <#> la <#> bA <#> phi <@> u <@> u0++-- | Implementation of Kan operations for Pi types. The implementation+-- of @transp@ and @hcomp@ for Pi types has many commonalities, so most+-- of it is shared between the two cases.+doPiKanOp+  :: KanOperation -- ^ Are we composing or transporting?+  -> ArgName      -- ^ Name of the binder+  -> FamilyOrNot (Dom Type, Abs Type)+  -- ^ The domain and codomain of the Pi type.+  -> ReduceM (Maybe Term)+doPiKanOp cmd t ab = do+  let getTermLocal = getTerm $ kanOpName cmd ++ " for function types"++  tTrans <- getTermLocal builtinTrans+  tHComp <- getTermLocal builtinHComp+  tINeg <- getTermLocal builtinINeg+  tIMax <- getTermLocal builtinIMax+  iz    <- getTermLocal builtinIZero++  -- We must guarantee that the codomain is a fibrant type, i.e. one+  -- that supports hcomp and transp. Otherwise, what are we even doing!+  let+    toLevel' t = do+      s <- reduce $ getSort t+      case s of+        Type l -> return (Just l)+        _      -> return Nothing+    -- But this case is actually impossible:+    toLevel t = fromMaybe __IMPOSSIBLE__ <$> toLevel' t++  caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ _ -> do+  runNamesT [] $ do++    -- When doing transport in Pi types, we need to distinguish a couple+    -- of different cases depending on the sort of the domain, since+    -- there are a couple of different possibilities for how we end up+    -- with a fibrant Pi type:+    trFibrantDomain <- do+      let+        (x, f) = case ab of+          IsFam (a, _) -> (a, \ a -> runNames [] $ lam "i" (const (pure a)))+          IsNot (a, _) -> (a, id)+      s <- reduce $ getSort x+      case s of+        -- We're looking at a fibrant Pi with fibrant domain: Transport+        -- backwards along the domain.+        Type lx -> do+          [la, bA] <- mapM (open . f) [Level lx, unEl . unDom $ x]+          pure $ Just $ \iOrNot phi a0 ->+            pure tTrans <#> lam "j" (\j -> la <@> iOrNot j)+              <@> lam "j" (\ j -> bA <@> iOrNot j)+              <@> phi+              <@> a0++        -- We're looking a fibrant Pi whose domain is a lock: No need to do anything.+        LockUniv -> return $ Just $ \_ _ a0 -> a0++        -- We're looking at an unmarked path type. Make sure that the+        -- domain is actually the interval before continuing without an+        -- adjustment, though!+        IntervalUniv -> do+          x' <- reduceB $ unDom x+          mInterval <- getBuiltinName' builtinInterval+          case unEl $ ignoreBlocking x' of+            Def q [] | Just q == mInterval -> return $ Just $ \_ _ a0 -> a0+            _ -> return Nothing++        _ -> return Nothing++    caseMaybe trFibrantDomain (return Nothing) $ \trA -> Just <$> do+    [phi, u0] <- mapM (open . unArg) [ignoreBlocking (kanOpCofib cmd), kanOpBase cmd]++    glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \u1 -> do+      case (cmd, ab) of++        -- hcomp u u0 x = hcomp (λ i o → u i o x) (u0 x). Short and sweet :)+        (HCompOp _ u _, IsNot (a , b)) -> do+          bT <- (raise 1 b `absApp`) <$> u1+          u <- open (raise 1 (unArg u))+          pure tHComp+            <#> (Level <$> toLevel bT)+            <#> pure (unEl bT)+            <#> phi+            <@> lam "i" (\ i -> ilam "o" $ \ o -> gApply (getHiding a) (u <@> i <..> o) u1)+            <@> gApply (getHiding a) u0 u1++        -- transp (λ i → (a : A i) → B i x) φ f u1 =+        --  transp (λ i → B i (transp (λ j → A (i ∨ ~ j)) (φ ∨ i) x)) φ+        --    (f (transp (λ j → A (~ j) φ x)))+        (TranspOp _ _, IsFam (a , b)) -> do+          -- trA is a function of three arguments which builds the+          -- transport fillers in the opposite direction, hence its+          -- first argument is called "iOrNot" where it's relevant.+          let+            -- Γ , u1 : A[i1] , i : I+            v i = trA (imax i . ineg) (imax phi i) u1+            bB v = consS v (liftS 1 $ raiseS 1) `applySubst`+              (absBody b {- Γ , i : I , x : A[i] -})++            -- Compute B @0 v, in the right scope+            tLam = Lam defaultArgInfo++          -- We know how to substitute v into B, but it's open in a+          -- variable, so we close over it here:+          bT <- bind "i" $ \ x -> fmap bB . v $ x++          pure tTrans+            <#> (tLam <$> traverse (fmap Level . toLevel) bT)+            <@> (pure . tLam $ unEl <$> bT)+            <@> phi+            <@> gApply (getHiding a) u0 (v (pure iz))++        (_, _) -> __IMPOSSIBLE_VERBOSE__ "Invalid Kan operation in doPiKanOp"++-- | Compute Kan operations in a type of dependent paths.+doPathPKanOp+  :: KanOperation+  -> FamilyOrNot (Arg Term)+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term)+  -> ReduceM (Reduced MaybeReducedArgs Term)+doPathPKanOp (HCompOp phi u u0) (IsNot l) (IsNot (bA,x,y)) = do+  let getTermLocal = getTerm "primHComp for path types"+  tHComp <- getTermLocal builtinHComp++  redReturn <=< runNamesT [] $ do+    [l, u, u0, phi, bA, x, y] <- mapM (open . unArg) [l, u, u0, ignoreBlocking phi, bA, x, y]++    -- hcomp in path spaces is simply hcomp in the underlying space, but+    -- fixing the endpoints at (j ∨ ~ j) in the new direction to those+    -- in the Path type.+    lam "j" $ \ j ->+      pure tHComp <#> l <#> (bA <@> j) <#> (phi `imax` (ineg j `imax` j))+        <@> lam "i'" (\i -> combineSys l (bA <@> i)+          [ (phi,    ilam "o" (\ o -> u <@> i <..> o <@@> (x, y, j)))+          , (j,      ilam "o" (const y))+          , (ineg j, ilam "o" (const x)) ])+        <@> (u0 <@@> (x, y, j))++doPathPKanOp (TranspOp phi u0) (IsFam l) (IsFam (bA,x,y)) = do+  -- Γ    ⊢ l+  -- Γ, i ⊢ bA, x, y+  let getTermLocal = getTerm "transport for path types"+  iz <- getTermLocal builtinIZero+  io <- getTermLocal builtinIOne++  -- Transport in path types becomes /CCHM/ composition in the+  -- underlying line of spaces. The intuition is that not only do we+  -- have to fix the endpoints (using composition) but also actually+  -- transport. CCHM composition conveniently does that for us!++  redReturn <=< runNamesT [] $ do+    -- In reality to avoid a round-trip between primComp we use mkComp+    -- here.+    comp <- mkComp $ "transport for path types"+    [l, u0, phi] <- traverse (open . unArg) [l, u0, ignoreBlocking phi]+    [bA, x, y] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [bA, x, y]++    lam "j" $ \ j ->+      comp l (lam "i" $ \ i -> bA <@> i <@> j) (phi `imax` (ineg j `imax` j))+        (lam "i'" $ \i -> combineSys l (bA <@> i <@> j)+          [ (phi, ilam "o" (\o -> u0 <@@> (x <@> pure iz, y <@> pure iz, j)))+          -- Note that here we have lines of endpoints which we must+          -- apply to fix the endpoints:+          , (j,      ilam "_" (const (y <@> i)))+          , (ineg j, ilam "_" (const (x <@> i)))+          ])+        (u0 <@@> (x <@> pure iz, y <@> pure iz, j))+doPathPKanOp a0 _ _ = __IMPOSSIBLE__++redReturnNoSimpl :: a -> ReduceM (Reduced a' a)+redReturnNoSimpl = pure . YesReduction NoSimplification++primTransHComp :: Command -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)+primTransHComp cmd ts nelims = do+  (l,bA,phi,u,u0) <- pure $ case (cmd,ts) of+    (DoTransp, [l, bA, phi, u0]) -> (IsFam l, IsFam bA, phi, Nothing, u0)+    (DoHComp, [l, bA, phi, u, u0]) -> (IsNot l, IsNot bA, phi, Just u, u0)+    _ -> __IMPOSSIBLE__+  sphi <- reduceB' phi+  vphi <- intervalView $ unArg $ ignoreBlocking sphi+  let clP s = getTerm "primTransHComp" s++  -- WORK+  case vphi of+    -- When φ = i1, we know what to do! These cases are counted as+    -- simplifications.+    IOne -> redReturn =<< case cmd of+      DoHComp -> runNamesT [] $ do+        -- If we're composing, then we definitely had a partial element+        -- to extend. But now it's just a total element, so we can+        -- just.. return it:+        u <- open $ unArg $ fromMaybe __IMPOSSIBLE__ u+        u <@> clP builtinIOne <..> clP builtinItIsOne+      DoTransp ->+        -- Otherwise we're in the constant part of the line to transport+        -- over, so we must return the argument unchanged.+        pure $ unArg u0++    _ -> do+    let+      fallback' sc = do+        -- Possibly optimise the partial element to reduce the size of+        -- hcomps:+        u' <- case cmd of+          DoHComp -> (:[]) <$> case vphi of+            -- If φ=i0 then tabulating equality for Partial φ A+            -- guarantees that u = is constantly isOneEmpty,+            -- regardless of how big the original term is, and+            -- isOneEmpty is *tiny*, so let's use that:+            IZero -> fmap (reduced . notBlocked . argN) . runNamesT [] $ do+                [l,c] <- mapM (open . unArg) [famThing l, ignoreBlocking sc]+                lam "i" $ \ i -> clP builtinIsOneEmpty <#> l <#> ilam "o" (\ _ -> c)++            -- Otherwise we have some interesting formula (though+            -- definitely not IOne!) and we have to keep the partial+            -- element as-is.+            _ -> pure $ notReduced $ fromMaybe __IMPOSSIBLE__ u+          DoTransp -> return []++        pure . NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0]++    -- Reduce the type whose Kan operations we're composing over:+    sbA <- reduceB' bA+    t <- case unArg <$> ignoreBlocking sbA of+      IsFam (Lam _ t) -> Just . fmap IsFam <$> reduceB' (absBody t)+      IsFam _         -> pure Nothing+      IsNot t         -> pure . Just . fmap IsNot $ (t <$ sbA)++    case t of+      -- If we don't have a grasp of the Kan operations then at least we+      -- can reuse the work we did for reducing the type later.+      Nothing -> fallback' (famThing <$> sbA)+      Just st  -> do+        -- Similarly, if we're stuck for another reason, we can reuse+        -- the work for reducing the family.+        let+          fallback = fallback' (fmap famThing $ st *> sbA)+          t = ignoreBlocking st+          operation = case cmd of+            DoTransp -> TranspOp { kanOpCofib = sphi, kanOpBase = u0 }+            DoHComp -> HCompOp+              { kanOpCofib = sphi, kanOpSides = fromMaybe __IMPOSSIBLE__ u, kanOpBase = u0 }++        mHComp <- getPrimitiveName' builtinHComp+        mGlue <- getPrimitiveName' builtinGlue+        mId   <- getBuiltinName' builtinId+        pathV <- pathView'++        -- By cases on the family, determine what Kan operation we defer+        -- to:+        case famThing t of+          -- Metavariables are stuck+          MetaV m _ -> fallback' (fmap famThing $ blocked_ m *> sbA)++          -- TODO: absName t instead of "i"+          Pi a b+            -- For Π types, we prefer to keep the Kan operations around,+            -- so only actually reduce if we applied them to a nonzero+            -- positive of eliminations+            | nelims > 0 -> maybe fallback redReturn =<< doPiKanOp operation "i" ((a, b) <$ t)+            | otherwise -> fallback++          -- For Type, we have two possibilities:+          Sort (Type l)+            -- transp (λ i → Type _) φ is always the identity function.+            | DoTransp <- cmd -> redReturn $ unArg u0+            -- hcomp {Type} is actually a normal form! This is the+            -- "HCompU" optimisation; We do not use Glue for hcomp in+            -- the universe.+            | DoHComp <- cmd -> fallback++          -- Glue types have their own implementation of Kan operations+          -- which are implemented in a different module:+          Def q [Apply la, Apply lb, Apply bA, Apply phi', Apply bT, Apply e] | Just q == mGlue -> do+            maybe fallback redReturn =<< doGlueKanOp+              operation ((la, lb, bA, phi', bT, e) <$ t) Head++          -- Formal homogeneous compositions in the universe: Our family+          -- is @hcomp {A = Type l}@, so we defer to the implementation+          -- of Kan operations for HCompU implemented above.+          Def q [Apply _, Apply s, Apply phi', Apply bT, Apply bA]+            | Just q == mHComp, Sort (Type la) <- unArg s  -> do+            maybe fallback redReturn =<< doHCompUKanOp+              operation ((Level la <$ s, phi', bT, bA) <$ t) Head++          -- PathP types have the same optimisation as for Pi types:+          -- Only compute the Kan operation if there's >0 eliminations.+          d | PathType _ _ _ bA x y <- pathV (El __DUMMY_SORT__ d) -> do+            if nelims > 0 then doPathPKanOp operation l ((bA, x, y) <$ t) else fallback++          -- Identity types:+          Def q [Apply _ , Apply bA , Apply x , Apply y] | Just q == mId -> do+            maybe fallback return =<< doIdKanOp operation l ((bA, x, y) <$ t)++          Def q es -> do+            info <- getConstInfo q+            let   lam_i = Lam defaultArgInfo . Abs "i"++            -- Record and data types have their own implementations of+            -- the Kan operations, which get generated as part of their+            -- definition.+            case theDef info of+              r@Record{recComp = kit}+                | nelims > 0, Just as <- allApplyElims es, DoTransp <- cmd, Just transpR <- nameOfTransp kit ->+                  -- Optimisation: If the record has no parameters then we can ditch the transport.+                  if recPars r == 0+                     then redReturn $ unArg u0+                     else redReturn $ Def transpR [] `apply` (map (fmap lam_i) as ++ [ignoreBlocking sphi, u0])++                -- Records know how to hcomp themselves:+                | nelims > 0, Just as <- allApplyElims es, DoHComp <- cmd, Just hCompR <- nameOfHComp kit ->+                  redReturn $ Def hCompR [] `apply` (as ++ [ignoreBlocking sphi, fromMaybe __IMPOSSIBLE__ u,u0])++                -- If this is a record with no fields, then compData+                -- will know what to do with it:+                | Just as <- allApplyElims es, [] <- recFields r -> compData Nothing False (recPars r) cmd l (as <$ t) sbA sphi u u0++              -- For data types, if this data type is indexed and/or a+              -- higher inductive type, then hcomp is normal; But+              -- compData knows what to do for the general cases.+              Datatype{dataPars = pars, dataIxs = ixs, dataPathCons = pcons, dataTransp = mtrD}+                | and [null pcons && ixs == 0 | DoHComp  <- [cmd]], Just as <- allApplyElims es ->+                  compData mtrD ((not $ null $ pcons) || ixs > 0) (pars+ixs) cmd l (as <$ t) sbA sphi u u0++              -- Is this an axiom with constrant transport? Then. Well. Transport is constant.+              Axiom constTransp | constTransp, [] <- es, DoTransp <- cmd -> redReturn $ unArg u0++              _          -> fallback++          _ -> fallback+  where+    allComponentsBack unview phi u p = do+            let+              boolToI b = if b then unview IOne else unview IZero+              lamlam t = Lam defaultArgInfo (Abs "i" (Lam (setRelevance Irrelevant defaultArgInfo) (Abs "o" t)))+            as <- decomposeInterval phi+            (flags,t_alphas) <- fmap unzip . forM as $ \ (bs,ts) -> do+                 let u' = listS bs' `applySubst` u+                     bs' = IntMap.toAscList $ IntMap.map boolToI bs+                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]+                     -- ordering of "j,i,.." matters.+                 let weaken = foldr (\ j s -> s `composeS` raiseFromS j 1) idS (map fst bs')+                 t <- reduce2Lam u'+                 return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ])+            return $ (flags,t_alphas)+    compData mtrD False _ cmd@DoHComp (IsNot l) (IsNot ps) fsc sphi (Just u) a0 = do+      let getTermLocal = getTerm $ "builtinHComp for data types"++      let sc = famThing <$> fsc+      tEmpty <- getTermLocal builtinIsOneEmpty+      tPOr   <- getTermLocal builtinPOr+      iO   <- getTermLocal builtinIOne+      iZ   <- getTermLocal builtinIZero+      tMin <- getTermLocal builtinIMin+      tNeg <- getTermLocal builtinINeg+      let iNeg t = tNeg `apply` [argN t]+          iMin t u = tMin `apply` [argN t, argN u]+          iz = pure iZ+      constrForm <- do+        mz <- getTerm' builtinZero+        ms <- getTerm' builtinSuc+        return $ \ t -> fromMaybe t (constructorForm' mz ms t)+      su  <- reduceB' u+      sa0 <- reduceB' a0+      view   <- intervalView'+      unview <- intervalUnview'+      let f = unArg . ignoreBlocking+          phi = f sphi+          a0 = f sa0+          isLit t@(Lit lt) = Just t+          isLit _ = Nothing+          isCon (Con h _ _) = Just h+          isCon _           = Nothing+          combine l ty d [] = d+          combine l ty d [(psi,u)] = u+          combine l ty d ((psi,u):xs)+            = pure tPOr <#> l <@> psi <@> foldr (imax . fst) iz xs+                        <#> ilam "o" (\ _ -> ty) -- the type+                        <@> u <@> (combine l ty d xs)+          noRed' su = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced su', reduced sa0]+            where+              su' = case view phi of+                     IZero -> notBlocked $ argN $ runNames [] $ do+                                 [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]+                                 lam "i" $ \ i -> pure tEmpty <#> l+                                                              <#> ilam "o" (\ _ -> c)+                     _     -> su+          sameConHeadBack Nothing Nothing su k = noRed' su+          sameConHeadBack lt h su k = do+            let u = unArg . ignoreBlocking $ su+            (b, ts) <- allComponentsBack unview phi u $ \ t ->+                        (isLit t == lt, isCon (constrForm t) == h)+            let+              (lit,hd) = unzip b++            if isJust lt && and lit then redReturn a0 else do+            su <- caseMaybe (sequence ts) (return su) $ \ ts -> do+              let (us,bools) = unzip ts+              fmap ((sequenceA_ us $>) . argN) $ do+              let+                phis :: [Term]+                phis = for bools $ \ m ->+                            foldr (iMin . (\(i,b) -> applyUnless b iNeg $ var i)) iO (IntMap.toList m)+              runNamesT [] $ do+                u <- open u+                [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]+                phis <- mapM open phis+                us   <- mapM (open . ignoreBlocking) us+                lam "i" $ \ i -> do+                  combine l c (u <@> i) $ zip phis (map (\ t -> t <@> i) us)++            if isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su+                      else noRed' su++      sameConHeadBack (isLit a0) (isCon a0) su $ \ h su -> do+            let u = unArg . ignoreBlocking $ su+            Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)+            case nameOfHComp cm of+              Just hcompD -> redReturn $ Def hcompD [] `apply`+                                          (ps ++ map argN [phi,u,a0])+              Nothing        -> noRed' su++    compData mtrD        _     0     DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = redReturn $ unArg a0+    compData (Just trD) isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do+      let sc = famThing <$> fsc+      let f = unArg . ignoreBlocking+          phi :: Term+          phi = f $ sphi+      let lam_i = Lam defaultArgInfo . Abs "i"+      redReturn $ Def trD [] `apply` (map (fmap lam_i) ps ++ map argN [phi,unArg a0])++    compData mtrD isHIT _ cmd@DoTransp (IsFam l) (IsFam ps) fsc sphi Nothing a0 = do+      let getTermLocal = getTerm $ builtinTrans ++ " for data types"+      let sc = famThing <$> fsc+      mhcompName <- getName' builtinHComp+      constrForm <- do+        mz <- getTerm' builtinZero+        ms <- getTerm' builtinSuc+        return $ \ t -> fromMaybe t (constructorForm' mz ms t)+      sa0 <- reduceB' a0+      let f = unArg . ignoreBlocking+          phi = f sphi+          a0 = f sa0+          noRed = return $ NoReduction [notReduced l,reduced sc, reduced sphi, reduced sa0]+      let lam_i = Lam defaultArgInfo . Abs "i"+      case constrForm a0 of+        Con h _ args -> do+          Constructor{ conComp = cm } <- theDef <$> getConstInfo (conName h)+          case nameOfTransp cm of+              Just transpD -> redReturn $ Def transpD [] `apply`+                                          (map (fmap lam_i) ps ++ map argN [phi,a0])+              Nothing        -> noRed+        Def q es | isHIT, Just q == mhcompName, Just [_l0,_c0,psi,u,u0] <- allApplyElims es -> do+           let bC = ignoreBlocking sc+           hcomp <- getTermLocal builtinHComp+           transp <- getTermLocal builtinTrans+           io <- getTermLocal builtinIOne+           iz <- getTermLocal builtinIZero+           redReturn <=< runNamesT [] $ do+             [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0]+             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)+             pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi+                   <@> lam "j" (\ j -> ilam "o" $ \ o ->+                        pure transp <#> l <@> bC <@> phi <@> (u <@> j <..> o))+                   <@> (pure transp <#> l <@> bC <@> phi <@> u0)+        _ -> noRed+    compData mtrX isHITorIx nargs cmd l t sbA sphi u u0 = do+      () <- reportSDoc "impossible" 10 $ "compData" <+> (nest 2 . vcat)+       [ "mtrX:       " <+> pretty mtrX+       , "isHITorIx:  " <+> pretty isHITorIx+       , "nargs:      " <+> pretty nargs+       , "cmd:        " <+> text (show cmd)+       , "l:          " <+> familyOrNot l+       , "t:          " <+> familyOrNot t <+> pretty (famThing t)+       , "sbA:          " <+> familyOrNot (ignoreBlocking $ sbA)+       , "sphi:       " <+> pretty (ignoreBlocking sphi)+       , "isJust u:   " <+> pretty (isJust u)+       , "u0:         " <+> pretty u0+       ]+      __IMPOSSIBLE__++--    compData _ _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__++-- | CCHM 'primComp' is implemented in terms of 'hcomp' and 'transport'.+-- The definition of it comes from 'mkComp'.+primComp :: TCM PrimitiveImpl+primComp = do+  requireCubical CErased ""+  t    <- runNamesT [] $+          hPi' "a" (primIntervalType --> el (cl primLevel)) $ \ a ->+          nPi' "A" (nPi' "i" primIntervalType $ \ i -> (sort . tmSort <$> (a <@> i))) $ \ bA ->+          hPi' "φ" primIntervalType $ \ phi ->+          nPi' "i" primIntervalType (\ i -> pPi' "o" phi $ \ _ -> el' (a <@> i) (bA <@> i)) -->+          (el' (a <@> cl primIZero) (bA <@> cl primIZero) --> el' (a <@> cl primIOne) (bA <@> cl primIOne))+  one <- primItIsOne+  io  <- primIOne+  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 $ \ ts nelims -> do+    case ts of+      [l,c,phi,u,a0] -> do+        sphi <- reduceB' phi+        vphi <- intervalView $ unArg $ ignoreBlocking sphi+        case vphi of+          -- Though we short-circuit evaluation for the rule+          --    comp A i1 (λ _ .1=1 → u) u ==> u+          -- rather than going through the motions of hcomp and transp.+          IOne -> redReturn (unArg u `apply` [argN io, argN one])+          _    -> do+            redReturnNoSimpl <=< runNamesT [] $ do+              comp <- mkComp builtinComp+              [l,c,phi,u,a0] <- mapM (open . unArg) [l,c,phi,u,a0]+              comp l c phi u a0++      _ -> __IMPOSSIBLE__+++-- TODO Andrea: keep reductions that happen under foralls?+primFaceForall' :: TCM PrimitiveImpl+primFaceForall' = do+  requireCubical CErased ""+  t <- (primIntervalType --> primIntervalType) --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case+    [phi] -> do+      sphi <- reduceB' phi+      case unArg $ ignoreBlocking $ sphi of+        Lam _ t -> do+          t <- reduce' t+          case t of+            NoAbs _ t -> redReturn t+            Abs _ t ->+              maybe (return $ NoReduction [reduced sphi]) redReturn+                =<< toFaceMapsPrim t+        _ -> return (NoReduction [reduced sphi])+    _ -> __IMPOSSIBLE__+  where+    toFaceMapsPrim t = do+      view <- intervalView'+      unview <- intervalUnview'+      us' <- decomposeInterval t+      fr <- getTerm builtinFaceForall builtinFaceForall+      let+        v = view t+        -- We decomposed the interval expression, without regard for+        -- inconsistent mappings, and now we keep only those which are+        -- stuck (the ts) and those which do not mention the 0th variable.+        us :: [[Either (Int, Bool) Term]]+        us = [ map Left (IntMap.toList bsm) ++ map Right ts+             | (bsm, ts) <- us', 0 `IntMap.notMember` bsm+             ]++        -- Turn a face mapping back into an interval expression:+        fm (i, b) = if b then var (i - 1) else unview (INeg (argN (var $ i - 1)))+        -- Apply ∀ to any indecomposable expressions we have encountered+        ffr t = fr `apply` [argN $ Lam defaultArgInfo $ Abs "i" t]++        -- Unfold one step of the foldr to avoid generation of the last+        -- ∧ i1. Marginal savings at best but it's cleaner.+        conjuncts :: [Either (Int, Bool) Term] -> Term+        conjuncts [] = unview IOne+        conjuncts [x] = either fm ffr x+        conjuncts (x:xs) =+          foldr (\x r -> unview (IMin (argN (either fm ffr x)) (argN r)))+            (either fm ffr x)+            xs++        disjuncts = foldr+          (\conj rest -> unview (IMax (argN (conjuncts conj)) (argN rest)))+          (unview IZero)+          us+      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $+      return $ case us' of+        [(m, [_])] | null m -> Nothing+        _ -> Just disjuncts++-- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types.+--   If a type in the telescope does not support transp, @transpTel@ throws it as an exception.+transpTel :: Abs Telescope -- Γ ⊢ i.Δ+          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[1]+transpTel = transpTel' False+++transpTel' :: (PureTCM m, MonadError TCErr m) =>+          Bool -> Abs Telescope -- Γ ⊢ i.Δ+          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[1]+transpTel' flag delta phi args = transpSysTel' flag delta [] phi args++type LM m a = NamesT (ExceptT (Closure (Abs Type)) m) a+-- transporting with an extra system/partial element+-- or composing when some of the system is known to be constant.+transpSysTel' :: forall m. (PureTCM m, MonadError TCErr m) =>+          Bool+          -> Abs Telescope -- Γ ⊢ i.Δ+          -> [(Term,Abs [Term])] -- [(ψ,i.δ)] with  Γ,ψ ⊢ i.δ : [i : I]. Δ[i]  -- the proof of [ψ] is not in scope.+          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ and all i.δ const on φ ∧ ψ+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[1]+transpSysTel' flag delta us phi args = do+  reportSDoc "cubical.prim.transpTel" 20 $+      sep [ text "transpSysTel'"+          , (text "delta  =" <+>) $ nest 2 $ addContext ("i" :: String, __DUMMY_DOM__) $ prettyTCM (unAbs delta)+--          , (text "us =" <+>) $ nest 2 $ prettyList $ map prettyTCM us+          , (text "phi    =" <+>) $ nest 2 $ prettyTCM phi+          , (text "args   =" <+>) $ nest 2 $ prettyList $ map prettyTCM args+          ]+  let getTermLocal = getTerm "transpSys"+  tTransp <- lift primTrans+  tComp <- getTermLocal builtinComp+  tPOr <- getTermLocal builtinPOr+  iz <- lift primIZero+  imin <- lift primIMin+  imax <- lift primIMax+  ineg <- lift primINeg+  let+    noTranspError t = do+      reportSDoc "cubical.prim.transpTel" 20 $ nest 2 $ (text "error type =" <+>) $+        addContext ("i" :: String, __DUMMY_DOM__) $ prettyTCM $ unAbs t+      lift . throwError =<< buildClosure t+    bapp :: forall m a. (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a+    bapp t u = lazyAbsApp <$> t <*> u+    doGTransp l t us phi a | null us = pure tTransp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <@> phi <@> a+                           | otherwise = pure tComp <#> l <@> (Lam defaultArgInfo . fmap unEl <$> t) <#> face <@> uphi <@> a+      where+        -- [phi -> a; us]+        face = foldr (\ x y -> pure imax <@> x <@> y) (pure iz) (phi : map fst us)+        uphi = lam "i" $ \ i -> ilam "o" $ \ o -> do+          let sys' = (phi , a) : map (mapSnd (`bapp` i)) us+              sys = map (mapSnd $ ilam "o" . const) sys'+          combine (l <@> i) (unEl <$> bapp t i) __IMPOSSIBLE__ sys <..> o+    combine l ty d [] = d+    combine l ty d [(psi,u)] = u+    combine l ty d ((psi,u):xs)+            = pure tPOr <#> l <@> psi <@> (foldr (\ x y -> pure imax <@> x <@> y) (pure iz) (map fst xs))+                        <#> (ilam "o" $ \ _ -> ty) -- the type+                        <@> u <@> (combine l ty d xs)++    gTransp :: Maybe (LM m Term) -> LM m (Abs Type) -> [(LM m Term,LM m (Abs Term))] -> LM m Term -> LM m Term -> LM m Term+    gTransp (Just l) t u phi a+     | flag = do+      t' <- t+      us' <- mapM snd u+      case ( 0 `freeIn` (raise 1 t' `lazyAbsApp` var 0)+           , 0 `freeIn` map (\ u -> raise 1 u `lazyAbsApp` var 0) us'+           ) of+        (False,False) -> a+        (False,True)  -> doGTransp l t u phi a -- TODO? optimize to "hcomp (l <@> io) (bapp t io) ((phi,NoAbs a):u) a" ?+        (True,_) -> doGTransp l t u phi a+     | otherwise = doGTransp l t u phi a++    gTransp Nothing t sys phi a = do+      let (psis,us) = unzip sys+      -- Γ ⊢ i.Ξ+      xi <- (open =<<) $ do+        bind "i" $ \ i -> do+          TelV xi _ <- (lift . telView =<<) $ t `bapp` i+          return xi+      argnames <- do+        teleArgNames . unAbs <$> xi+      glamN argnames $ \ xi_args -> do+        b' <- bind "i" $ \ i -> do+          ti <- t `bapp` i+          xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)+          xi_args <- xi_args+          ni <- pure ineg <@> i+          phi <- phi+          lift $ piApplyM ti =<< trFillTel' flag xin phi xi_args ni+        usxi <- forM us $ \ u -> bind "i" $ \ i -> do+          ui <- u `bapp` i+          xin <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)+          xi_args <- xi_args+          ni <- pure ineg <@> i+          phi <- phi+          lift $ apply ui <$> trFillTel' flag xin phi xi_args ni+        axi <- do+          a <- a+          xif <- bind "i" $ \ i -> xi `bapp` (pure ineg <@> i)+          phi <- phi+          xi_args <- xi_args+          lift $ apply a <$> transpTel' flag xif phi xi_args+        s <- reduce $ getSort (absBody b')+        reportSDoc "cubical.transp" 20 $ pretty (raise 1 b' `lazyAbsApp` var 0)+        let noTranspSort = if 0 `freeIn` (raise 1 b' `lazyAbsApp` var 0) || 0 `freeIn` (map (`lazyAbsApp` var 0) (raise 1 usxi))+              then noTranspError b'+              else return axi++        case s of+          Type l -> do+            l <- open $ lam_i (Level l)+            b' <- open b'+            axi <- open axi+            usxi <- mapM open usxi+            gTransp (Just l) b' (zip psis usxi) phi axi+          Inf _ n  -> noTranspSort+          SSet _  -> noTranspSort+          SizeUniv -> noTranspSort+          LockUniv -> noTranspSort+          IntervalUniv -> noTranspSort+          Prop{}  -> noTranspSort+          _ -> noTranspError b'+    lam_i = Lam defaultArgInfo . Abs "i"+    go :: Telescope -> [[(Term,Term)]] -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args+    go EmptyTel            [] _  []       = return []+    go (ExtendTel t delta) (u:us) phi (a:args) = do+      -- Γ,i ⊢ t+      -- Γ,i ⊢ (x : t). delta+      -- Γ ⊢ a : t[0]+      s <- reduce $ getSort t+      -- Γ ⊢ b : t[1]    Γ, i ⊢ bf : t[i]+      (b,bf) <- runNamesT [] $ do+        l <- case s of+               SSet _ -> return Nothing+               IntervalUniv -> return Nothing+               SizeUniv     -> return Nothing+               LockUniv     -> return Nothing+               Inf _ n -> return Nothing+               Type l -> Just <$> open (lam_i (Level l))+               _ -> noTranspError (Abs "i" (unDom t))+        t <- open $ Abs "i" (unDom t)+        u <- forM u $ \ (psi,upsi) -> do+              (,) <$> open psi <*> open (Abs "i" upsi)+        [phi,a] <- mapM open [phi, unArg a]+        b <- gTransp l t u phi a+        bf <- bind "i" $ \ i -> do+                            gTransp ((<$> l) $ \ l -> lam "j" $ \ j -> l <@> (pure imin <@> i <@> j))+                                    (bind "j" $ \ j -> t `bapp` (pure imin <@> i <@> j))+                                    u+                                    (pure imax <@> (pure ineg <@> i) <@> phi)+                                    a+        return (b, absBody bf)+      (:) (b <$ a) <$> go (lazyAbsApp delta bf) us phi args+    go EmptyTel            _ _ _ = __IMPOSSIBLE__+    go (ExtendTel t delta) _ _ _ = __IMPOSSIBLE__+  let (psis,uss) = unzip us+      us' | null us = replicate (length args) []+          | otherwise = map (zip psis) $ List.transpose (map absBody uss)+  go (absBody delta) us' phi args++-- | Like @transpTel@ but performing a transpFill.+trFillTel :: Abs Telescope -- Γ ⊢ i.Δ+          -> Term+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> Term          -- Γ ⊢ r : I+          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[r]+trFillTel = trFillTel' False++trFillTel' :: (PureTCM m, MonadError TCErr m) =>+          Bool+          -> Abs Telescope -- Γ ⊢ i.Δ+          -> Term+          -> Args          -- Γ ⊢ δ : Δ[0]+          -> Term          -- Γ ⊢ r : I+          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[r]+trFillTel' flag delta phi args r = do+  imin <- lift primIMin+  imax <- lift primIMax+  ineg <- lift primINeg+  transpTel' flag (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r])))+            (imax `apply` [argN $ ineg `apply` [argN r], argN phi])+            args++++-- hcompTel' :: Bool -> Telescope -> [(Term,Abs [Term])] -> [Term] -> ExceptT (Closure (Abs Type)) TCM [Term]+-- hcompTel' b delta sides base = undefined++-- hFillTel' :: Bool -> Telescope -- Γ ⊢ Δ+--           -> [(Term,Abs [Term])]  -- [(φ,i.δ)] with  Γ,φ ⊢ i.δ : I → Δ+--           -> [Term]            -- Γ ⊢ δ0 : Δ, matching the [(φ,i.δ)]+--           -> Term -- Γ ⊢ r : I+--           -> ExceptT (Closure (Abs Type)) TCM [Term]+-- hFillTel' b delta sides base = undefined++pathTelescope+  :: forall m. (PureTCM m, MonadError TCErr m) =>+  Telescope -- Δ+  -> [Arg Term] -- lhs : Δ+  -> [Arg Term] -- rhs : Δ+  -> m Telescope+pathTelescope tel lhs rhs = do+  x <- runExceptT (pathTelescope' tel lhs rhs)+  case x of+    Left t -> do+      enterClosure t $ \ t ->+                 typeError . GenericDocError =<<+                    (text "The sort of" <+> pretty t <+> text "should be of the form \"Set l\"")+    Right tel -> return tel++pathTelescope'+  :: forall m. (PureTCM m, MonadError (Closure Type) m) =>+  Telescope -- Δ+  -> [Arg Term] -- lhs : Δ+  -> [Arg Term] -- rhs : Δ+  -> m Telescope+pathTelescope' tel lhs rhs = do+  pathp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPathP+  go pathp (raise 1 tel) lhs rhs+ where+  -- Γ,i ⊢ Δ, Γ ⊢ lhs : Δ[0], Γ ⊢ rhs : Δ[1]+  go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope+  go pathp (ExtendTel a tel) (u : lhs) (v : rhs) = do+    let t = unDom a+    l <- subst 0 __DUMMY_TERM__ <$> getLevel t+    let a' = El (Type l) (apply pathp $ [argH $ Level l] ++ map argN [Lam defaultArgInfo (Abs "i" $ unEl t), unArg u, unArg v])+        -- Γ,eq : u ≡ v, i : I ⊢ m = eq i : t[i]+        -- m  = runNames [] $ do+        --        [u,v] <- mapM (open . unArg) [u,v]+        --        bind "eq" $ \ eq -> bind "i" $ \ i ->+    (ExtendTel (a' <$ a) <$>) . runNamesT [] $ do+      let nm = (absName tel)+      tel <- open $ Abs "i" tel+      [u,v] <- mapM (open . unArg) [u,v]+      [lhs,rhs] <- mapM open [lhs,rhs]+      bind nm $ \ eq -> do+        lhs <- lhs+        rhs <- rhs+        tel' <- bind "i" $ \ i ->+                  lazyAbsApp <$> (lazyAbsApp <$> tel <*> i) <*> (eq <@@> (u, v, i))+        lift $ go pathp (absBody tel') lhs rhs+  go _ EmptyTel [] [] = return EmptyTel+  go _ _ _ _ = __IMPOSSIBLE__+  getLevel :: Type -> m Level+  getLevel t = do+    s <- reduce $ getSort t+    case s of+      Type l -> pure l+      s      -> throwError =<< buildClosure t++data TranspError = CannotTransp {errorType :: (Closure (Abs Type)) }++instance Exception TranspError+instance Show TranspError where+  show _ = "TranspError"++tryTranspError :: TCM a -> TCM (Either (Closure (Abs Type)) a)+tryTranspError (TCM m) = TCM $ \ s env -> do+  mapLeft errorType <$> (try (m s env))++transpPathPTel' ::+             NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[0,i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[1,i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : PathP (λ j → Δ[j,0]) (x 0) (y 0)+             -> NamesT TCM [Arg Term] -- PathP (λ j → Δ[j,0]) (x 1) (y 1) [ φ ↦ q ]+transpPathPTel' theTel x y phi p = do+ let neg j = cl primINeg <@> j+ -- is the open overkill?+ qs <- (open =<<) $ fmap (fmap (\ (Abs n (Arg i t)) -> Arg i (Lam defaultArgInfo $ Abs n t)) . sequenceA)+                  $ bind "j" $ \ j -> do+   theTel <- absApp <$> theTel <*> j+   faces <- sequence [neg j, j]+   us <- forM [x,y] $ \ z -> do+           bind "i" $ \ i -> forM z (<@> i)+   let sys = zip faces us+   -- [(neg j, bind "i" $ \ i -> flip map x (<@> i))+   -- ,(j , bind "i" $ \ i -> flip map y (<@> i))]+   phi <- phi+   p0 <- mapM (<@> j) p+   let toArgs = zipWith (\ a t -> t <$ a) (teleArgNames (unAbs $ theTel))+   eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0)+   either (lift . lift . throw . CannotTransp) pure eq+ qs++transpPathTel' ::+             NamesT TCM (Abs Telescope) -- ^ i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : Path (Δ[0]) (x 0) (y 0)+             -> NamesT TCM [Arg Term] -- Path (Δ[1]) (x 1) (y 1) [ φ ↦ q ]+transpPathTel' theTel x y phi p = do+ let neg j = cl primINeg <@> j+ -- is the open overkill?+ qs <- (open =<<) $ fmap (fmap (\ (Abs n (Arg i t)) -> Arg i (Lam defaultArgInfo $ Abs n t)) . sequenceA)+                  $ bind "j" $ \ j -> do+   theTel <- theTel+   faces <- sequence $ [neg j, j]+   us <- forM [x,y] $ \ z -> do+           bind "i" $ \ i -> forM z (<@> i)+   let sys = zip faces us+   -- [(neg j, bind "i" $ \ i -> flip map x (<@> i))+   -- ,(j , bind "i" $ \ i -> flip map y (<@> i))]+   phi <- phi+   p0 <- mapM (<@> j) p+   let toArgs = zipWith (\ a t -> t <$ a) (teleArgNames (unAbs theTel))+   eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0)+   either (lift . lift . throw . CannotTransp) pure eq+ qs++trFillPathTel' ::+               NamesT TCM (Abs Telescope) -- ^ i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : Path (Δ[0]) (x 0) (y 0)+             -> NamesT TCM Term            -- ^ r+             -> NamesT TCM [Arg Term] -- Path (Δ[r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ]+trFillPathTel' tel x y phi p r = do+  let max i j = cl primIMin <@> i <@> j+  let min i j = cl primIMin <@> i <@> j+  let neg i = cl primINeg <@> i+  x' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM x (<@> (min r i))+  y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM y (<@> (min r i))+  transpPathTel' (bind "i" $ \ i -> absApp <$> tel <*> min r i)+                 x'+                 y'+                 (max phi (neg r))+                 p++trFillPathPTel' ::+               NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ                 const on φ+             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[0,i]  const on φ+             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[1,i]  const on φ+             -> NamesT TCM Term            -- ^ φ+             -> [NamesT TCM Term]          -- ^ p : Path (\ j -> Δ[j,0]) (x 0) (y 0)+             -> NamesT TCM Term            -- ^ r+             -> NamesT TCM [Arg Term] -- Path (\ j → Δ[j,r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ]+trFillPathPTel' tel x y phi p r = do+  let max i j = cl primIMin <@> i <@> j+  let min i j = cl primIMin <@> i <@> j+  let neg i = cl primINeg <@> i+  x' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM x (<@> (min r i))+  y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> forM y (<@> (min r i))+  transpPathPTel' (bind "j" $ \ j -> bind "i" $ \ i -> absApp <$> (absApp <$> tel <*> j) <*> min r i)+                 x'+                 y'+                 (max phi (neg r))+                 p++++-- given Γ ⊢ I type, and Γ ⊢ Δ telescope, build Δ^I such that+-- Γ ⊢ (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...)+expTelescope :: Type -> Telescope -> Telescope+expTelescope int tel = unflattenTel names ys+  where+    stel = size tel+    xs = flattenTel tel+    names = teleNames tel+    t = ExtendTel (defaultDom $ raise stel int) (Abs "i" EmptyTel)+    s = expS stel+    ys = map (fmap (abstract t) . applySubst s) xs+++-- | Γ, Δ^I, i : I |- expS |Δ| : Γ, Δ+expS :: Nat -> Substitution+expS stel = prependS __IMPOSSIBLE__+  [ Just (var n `apply` [Arg defaultArgInfo $ var 0]) | n <- [1..stel] ]+  (raiseS (stel + 1))+++-- * Special cases of Type+-----------------------------------------------------------++-- | A @Type@ with sort @Type l@+--   Such a type supports both hcomp and transp.+data LType = LEl Level Term deriving (Eq,Show)++fromLType :: LType -> Type+fromLType (LEl l t) = El (Type l) t++lTypeLevel :: LType -> Level+lTypeLevel (LEl l t) = l++toLType :: MonadReduce m => Type -> m (Maybe LType)+toLType ty = do+  sort <- reduce $ getSort ty+  case sort of+    Type l -> return $ Just $ LEl l (unEl ty)+    _      -> return $ Nothing++instance Subst LType where+  type SubstArg LType = Term+  applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t)++-- | A @Type@ that either has sort @Type l@ or is a closed definition.+--   Such a type supports some version of transp.+--   In particular we want to allow the Interval as a @ClosedType@.+data CType = ClosedType Sort QName | LType LType deriving (Eq,Show)++instance P.Pretty CType where+  pretty = P.pretty . fromCType++fromCType :: CType -> Type+fromCType (ClosedType s q) = El s (Def q [])+fromCType (LType t) = fromLType t++toCType :: MonadReduce m => Type -> m (Maybe CType)+toCType ty = do+  sort <- reduce $ getSort ty+  case sort of+    Type l -> return $ Just $ LType (LEl l (unEl ty))+    SSet{} -> do+      t <- reduce (unEl ty)+      case t of+        Def q [] -> return $ Just $ ClosedType sort q+        _        -> return $ Nothing+    _      -> return $ Nothing++instance Subst CType where+  type SubstArg CType = Term+  applySubst rho (ClosedType s q) = ClosedType (applySubst rho s) q+  applySubst rho (LType t) = LType $ applySubst rho t++hcomp+  :: (HasBuiltins m, MonadError TCErr m, MonadReduce m, MonadPretty m)+  => NamesT m Type+  -> [(NamesT m Term, NamesT m Term)]+  -> NamesT m Term+  -> NamesT m Term+hcomp ty sys u0 = do+  iz <- primIZero+  tHComp <- primHComp+  let max i j = cl primIMax <@> i <@> j+  ty <- ty+  (l, ty) <- toLType ty >>= \case+    Just (LEl l ty) -> return (l, ty)+    Nothing -> lift $ do -- TODO: support Setω properly+      typeError . GenericDocError =<< sep+        [ text "Cubical Agda: cannot generate hcomp clauses at type", prettyTCM ty ]+  l <- open $ Level l+  ty <- open $ ty+  face <- (foldr max (pure iz) $ map fst $ sys)+  sys <- lam "i'" $ \ i -> combineSys l ty [(phi, u <@> i) | (phi,u) <- sys]+  pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0++transpSys :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) =>+               NamesT m (Abs Type) -- ty+               -> [(NamesT m Term, NamesT m Term)] -- sys+               -> NamesT m Term -- φ+               -> NamesT m Term+               -> NamesT m Term+transpSys ty sys phi u = do+  let max i j = cl primIMax <@> i <@> j+  iz <- primIZero+  tTransp <- primTrans+  tComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp+  l_ty <- bind "i" $ \ i -> do+      ty <- absApp <$> ty <*> i+      toLType ty >>= \case+        Just (LEl l ty) -> return (l,ty)+        Nothing -> return (__DUMMY_LEVEL__, unEl ty) -- TODO: properly support Setω+  l <- open $ Lam defaultArgInfo . fmap (Level . fst) $ l_ty+  ty <- open $ Lam defaultArgInfo . fmap snd $ l_ty++  if null sys then pure tTransp <#> l <@> ty <@> phi <@> u else do++  let face = max phi (foldr max (pure iz) $ map fst $ sys)+  sys <- (open =<<) $ lam "i'" $ \ i -> do+    let base = (phi, ilam "o" $ \ _ -> u)+    combineSys l ty $ base : [(phi, u <@> i) | (phi,u) <- sys]++  pure tComp <#> l <@> ty <#> face <@> sys <@> u++debugClause :: String -> Clause -> TCM ()+debugClause s c = do+      reportSDoc s 20 $+        "gamma:" <+> prettyTCM gamma+      reportSDoc s 20 $ addContext gamma $+        "ps   :" <+> prettyTCM (patternsToElims ps)+      reportSDoc s 20 $ addContext gamma $+        "type :" <+> maybe "nothing" prettyTCM rhsTy+      reportSDoc s 20 $ addContext gamma $+        "body :" <+> maybe "nothing" prettyTCM rhs++      reportSDoc s 30 $+        addContext gamma $ "c:" <+> pretty c+  where+    gamma = clauseTel c+    ps = namedClausePats c+    rhsTy = clauseType c+    rhs = clauseBody c
+ src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs view
@@ -0,0 +1,438 @@+-- | Implementations of the basic primitives of Cubical Agda: The+-- interval and its operations.+module Agda.TypeChecking.Primitive.Cubical.Base+  ( requireCubical+  , primIntervalType+  , primIMin', primIMax', primDepIMin', primINeg'+  , imax, imin, ineg++  , Command(..), KanOperation(..), kanOpName, TermPosition(..), headStop+  , FamilyOrNot(..), familyOrNot++    -- * Helper functions for building terms+  , combineSys, combineSys'+  , fiber, hfill+  , decomposeInterval', decomposeInterval+  , reduce2Lam+  , isCubicalSubtype+  )+  where++import Control.Monad        ( msum, mzero )+import Control.Monad.Except ( MonadError )++import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)+import Data.String (IsString (fromString))+import Data.Bifunctor (second)+import Data.Either (partitionEithers)+import Data.Maybe (fromMaybe, maybeToList)++import qualified Agda.Utils.BoolSet as BoolSet+import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.BoolSet (BoolSet)+import Agda.Utils.Functor++import Agda.TypeChecking.Monad.Signature (HasConstInfo)+import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__)+import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Context+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Env++import Agda.TypeChecking.Substitute.Class (absBody, raise, apply)++import Agda.TypeChecking.Reduce (Reduce(..), reduceB', reduce', reduce)+import Agda.TypeChecking.Names (NamesT, runNamesT, ilam, lam)++import Agda.Interaction.Options.Base (optCubical)++import Agda.Syntax.Common+  (Cubical(..), Arg(..), Relevance(..), setRelevance, defaultArgInfo, hasQuantity0)++import Agda.TypeChecking.Primitive.Base+  (SigmaKit(..), (-->), el', nPi', pPi', (<@>), (<#>), (<..>), argN, getSigmaKit)++import Agda.Syntax.Internal+++-- | Checks that the correct variant of Cubical Agda is activated.+-- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased+-- contexts.+requireCubical+  :: Cubical -- ^ Which variant of Cubical Agda is required?+  -> String  -- ^ Why, exactly, do we need Cubical to be enabled?+  -> TCM ()+requireCubical wanted s = do+  cubical         <- optCubical <$> pragmaOptions+  inErasedContext <- hasQuantity0 <$> getEnv+  case cubical of+    Just CFull -> return ()+    Just CErased | wanted == CErased || inErasedContext -> return ()+    _ -> typeError $ GenericError $ "Missing option " ++ opt ++ s+  where+  opt = case wanted of+    CFull   -> "--cubical"+    CErased -> "--cubical or --erased-cubical"++-- | Our good friend the interval type.+primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type+primIntervalType = El intervalSort <$> primInterval++-- | Negation on the interval. Negation satisfies De Morgan's laws, and+-- their implementation is handled here.+primINeg' :: TCM PrimitiveImpl+primINeg' = do+  requireCubical CErased ""+  t <- primIntervalType --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case+    [x] -> do+      unview <- intervalUnview'+      view <- intervalView'+      sx <- reduceB' x+      ix <- intervalView (unArg $ ignoreBlocking sx)++      -- Apply De Morgan's laws.+      let+        ineg :: Arg Term -> Arg Term+        ineg = fmap (unview . f . view)++        f ix = case ix of+          IZero    -> IOne+          IOne     -> IZero+          IMin x y -> IMax (ineg x) (ineg y)+          IMax x y -> IMin (ineg x) (ineg y)+          INeg x   -> OTerm (unArg x)+          OTerm t  -> INeg (Arg defaultArgInfo t)++      -- We force the argument in case it happens to be an interval+      -- expression, but it's quite possible that it's _not_. In those+      -- cases, negation is stuck.+      case ix of+        OTerm t -> return $ NoReduction [reduced sx]+        _       -> redReturn (unview $ f ix)+    _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primINeg called with wrong arity"++-- | 'primDepIMin' expresses that cofibrations are closed under @Σ@.+-- Thus, it serves as a dependent version of 'primIMin' (which, recall,+-- implements @_∧_@). This is required for the construction of the Kan+-- operations in @Id@.+primDepIMin' :: TCM PrimitiveImpl+primDepIMin' = do+  requireCubical CErased ""+  t <- runNamesT [] $+       nPi' "φ" primIntervalType $ \ φ ->+       pPi' "o" φ (\ o -> primIntervalType) --> primIntervalType+  -- Note that the type here is @(φ : I) → (.(IsOne φ) → I) → I@, since+  -- @Partial φ I@ is not well-sorted.+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \case+    [x,y] -> do+      sx <- reduceB' x+      ix <- intervalView (unArg $ ignoreBlocking sx)+      itisone <- getTerm "primDepIMin" builtinItIsOne+      case ix of+        -- Σ 0 iy is 0, and additionally P is def.eq. to isOneEmpty.+        IZero -> redReturn =<< intervalUnview IZero+        -- Σ 1 iy is (iy 1=1).+        IOne  -> redReturn =<< (pure (unArg y) <@> pure itisone)+        _     -> do+          -- Hack: We cross our fingers and really hope that eventually+          -- ix may turn out to be i1. Regardless we evaluate iy 1=1, to+          -- short-circuit evaluate a couple of cases:+          sy <- reduceB' y+          iy <- intervalView =<< reduce' =<< (pure (unArg $ ignoreBlocking sy) <@> pure itisone)+          case iy of+            -- Σ _ (λ _ → 0) is always 0+            IZero -> redReturn =<< intervalUnview IZero+            -- Σ ix (λ _ → 1) only depends on ix+            IOne  -> redReturn (unArg $ ignoreBlocking sx)+            -- Otherwise we're well and truly blocked.+            _     -> return $ NoReduction [reduced sx, reduced sy]+    _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primDepIMin called with wrong arity"++-- | Internal helper for constructing binary operations on the interval,+-- parameterised by their unit and absorbing elements.+primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl+primIBin unit absorber = do+  requireCubical CErased ""+  t <- primIntervalType --> primIntervalType --> primIntervalType+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 2 $ \case+    [x,y] -> do+      -- Evaluation here is short-circuiting: If the LHS is either the+      -- absorbing or unit element, then the RHS does not matter.+      sx <- reduceB' x+      ix <- intervalView (unArg $ ignoreBlocking sx)+      case ix of+        ix | ix ==% absorber -> redReturn =<< intervalUnview absorber+        ix | ix ==% unit     -> return $ YesReduction YesSimplification (unArg y)+        _ -> do+          -- And in the case where the LHS is stuck, we can make+          -- progress by comparing the LHS to the absorbing/unit+          -- elements.+          sy <- reduceB' y+          iy <- intervalView (unArg $ ignoreBlocking sy)+          case iy of+            iy | iy ==% absorber -> redReturn =<< intervalUnview absorber+            iy | iy ==% unit     -> return $ YesReduction YesSimplification (unArg x)+            _                    -> return $ NoReduction [reduced sx,reduced sy]+    _ -> __IMPOSSIBLE_VERBOSE__ "binary operation on the interval called with incorrect arity"+  where+    (==%) IZero IZero = True+    (==%) IOne IOne = True+    (==%) _ _ = False+{-# INLINE primIBin #-}++-- | Implements both the @min@ connection /and/ conjunction on the+-- cofibration classifier.+primIMin' :: TCM PrimitiveImpl+primIMin' = do+  requireCubical CErased ""+  primIBin IOne IZero++-- | Implements both the @max@ connection /and/ disjunction on the+-- cofibration classifier.+primIMax' :: TCM PrimitiveImpl+primIMax' = do+  requireCubical CErased ""+  primIBin IZero IOne++-- | A helper for evaluating @max@ on the interval in TCM&co.+imax :: HasBuiltins m => m Term -> m Term -> m Term+imax x y = do+  x' <- x+  y' <- y+  intervalUnview (IMax (argN x') (argN y'))++-- | A helper for evaluating @min@ on the interval in TCM&co.+imin :: HasBuiltins m => m Term -> m Term -> m Term+imin x y = do+  x' <- x+  y' <- y+  intervalUnview (IMin (argN x') (argN y'))++-- | A helper for evaluating @neg@ on the interval in TCM&co.+ineg :: HasBuiltins m => m Term -> m Term+ineg x = do+  x' <- x+  intervalUnview (INeg (argN x'))++data Command = DoTransp | DoHComp+  deriving (Eq, Show)++-- | The built-in name associated with a particular Kan operation.+kanOpName :: KanOperation -> String+kanOpName TranspOp{} = builtinTrans+kanOpName HCompOp{}  = builtinHComp++-- | Our Kan operations are @transp@ and @hcomp@. The KanOperation+-- record stores the data associated with a Kan operation on arbitrary+-- types: A cofibration and an element of that type.+data KanOperation+  -- | A transport problem consists of a cofibration, marking where the+  -- transport is constant, and a term to move from the fibre over i0 to+  -- the fibre over i1.+  = TranspOp+    { kanOpCofib :: Blocked (Arg Term)+      -- ^ When this cofibration holds, the transport must+      -- definitionally be the identity. This is handled generically by+      -- 'primTransHComp' but specific Kan operations may still need it.+    , kanOpBase :: Arg Term+      -- ^ This is the term in @A i0@ which we are transporting.+    }+  -- | A composition problem consists of a partial element and a base.+  -- Semantically, this is justified by the types being Kan fibrations,+  -- i.e., having the lifting property against trivial cofibrations.+  -- While the specified cofibration may not be trivial, (φ ∨ ~ r) for r+  -- ∉ φ is *always* a trivial cofibration.+  | HCompOp+    { kanOpCofib :: Blocked (Arg Term)+      -- ^ Extent of definition of the partial element we are lifting+      -- against.+    , kanOpSides :: Arg Term+      -- ^ The partial element itself+    , kanOpBase  :: Arg Term+      -- ^ The base.+    }++-- | Are we looking at a family of things, or at a single thing?+data FamilyOrNot a+  = IsFam { famThing :: a }+  | IsNot { famThing :: a }+  deriving (Eq,Show,Functor,Foldable,Traversable)++familyOrNot :: IsString p => FamilyOrNot a -> p+familyOrNot (IsFam x) = "IsFam"+familyOrNot (IsNot x) = "IsNot"++instance Reduce a => Reduce (FamilyOrNot a) where+  reduceB' x = traverse id <$> traverse reduceB' x+  reduce' x = traverse reduce' x++-- | For the Kan operations in @Glue@ and @hcomp {Type}@, we optimise+-- evaluation a tiny bit by differentiating the term produced when+-- evaluating a Kan operation by itself vs evaluating it under @unglue@.+data TermPosition+  = Head+  | Eliminated+  deriving (Eq,Show)++-- | If we're computing a Kan operation for one of the "unstable" type+-- formers (@Glue@, @hcomp {Type}@), this tells us whether the type will+-- reduce further, and whether we should care.+--+-- When should we care? When we're in the 'Head' 'TermPosition'. When+-- will the type reduce further? When @φ@, its formula, is not i1.+headStop :: PureTCM m => TermPosition -> m Term -> m Bool+headStop tpos phi+  | Head <- tpos = do+    phi <- intervalView =<< (reduce =<< phi)+    return $ not $ isIOne phi+  | otherwise = return False++-- | Build a partial element. The type of the resulting partial element+-- can depend on the computed extent, which we denote by @φ@ here. Note+-- that @φ@ is the n-ary disjunction of all the @ψ@s.+combineSys+  :: HasBuiltins m+  => NamesT m Term -- The level @l : Level@+  -> NamesT m Term -- The type @A : Partial φ (Type l)@.+  -> [(NamesT m Term, NamesT m Term)]+  -- ^ A list of @(ψ, PartialP ψ λ o → A (... o ...))@ mappings. Note+  -- that by definitional proof-irrelevance of @IsOne@, the actual+  -- injection can not matter here.+  -> NamesT m Term+combineSys l ty xs = snd <$> combineSys' l ty xs++-- | Build a partial element, and compute its extent. See 'combineSys'+-- for the details.+combineSys'+  :: forall m. HasBuiltins m+  => NamesT m Term -- The level @l@+  -> NamesT m Term -- The type @A@+  -> [(NamesT m Term, NamesT m Term)]+  -> NamesT m (Term,Term)+combineSys' l ty xs = do+  tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr+  tMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax+  iz <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero+  tEmpty <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIsOneEmpty++  let+    pOr l ty phi psi u0 u1 = pure tPOr+      <#> l <@> phi <@> psi <#> (ilam "o" $ \ _ -> ty)+      <@> u0 <@> u1++    -- In one pass, compute the disjunction of all the cofibrations and+    -- compute the primPOr expression.+    combine :: [(NamesT m Term, NamesT m Term)] -> NamesT m (Term, Term)+    combine [] = (iz,) <$> (pure tEmpty <#> l <#> (ilam "o" $ \ _ -> ty))+    combine [(psi, u)] = (,) <$> psi <*> u+    combine ((psi, u):xs) = do+      (phi, c) <- combine xs+      (,) <$> imax psi (pure phi) <*> pOr l ty psi (pure phi) u (pure c)+  combine xs++-- | Helper function for constructing the type of fibres of a function+-- over a given point.+fiber+  :: (HasBuiltins m, HasConstInfo m)+  => NamesT m Term -- @la : Level@+  -> NamesT m Term -- @lb : Level@+  -> NamesT m Term -- @A : Type la@+  -> NamesT m Term -- @B : Type lb@+  -> NamesT m Term -- @f : A → B@+  -> NamesT m Term -- @x : B@+  -> NamesT m Term -- @Σ[ x ∈ A ] (f a ≡ x)@+fiber la lb bA bB f b = do+  tPath <- getTerm "fiber" builtinPath+  kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+  pure (Def (sigmaName kit) [])+    <#> la <#> lb+    <@> bA+    <@> lam "a" (\ a -> pure tPath <#> lb <#> bB <@> (f <@> a) <@> b)++-- | Helper function for constructing the filler of a given composition+-- problem.+hfill+  :: (HasBuiltins m, HasConstInfo m)+  => NamesT m Term -- @la : Level@+  -> NamesT m Term -- @A : Type la@+  -> NamesT m Term -- @φ : I@. Cofibration+  -> NamesT m Term -- @u : Partial φ A@.+  -> NamesT m Term -- @u0 : A@. Must agree with @u@ on @φ@+  -> NamesT m Term -- @i : I@. Position along the cube.+  -> NamesT m Term+hfill la bA phi u u0 i = do+  tHComp <- getTerm "hfill" builtinHComp+  pure tHComp <#> la <#> bA <#> (imax phi (ineg i))+    <@> lam "j" (\ j -> combineSys la bA+        [ (phi,    ilam "o" (\o -> u <@> (imin i j) <..> o))+        , (ineg i, ilam "o" (\_ -> u0))+        ])+    <@> u0++-- | Decompose an interval expression @i : I@ as in+-- 'decomposeInterval'', but discard any inconsistent mappings.+decomposeInterval :: HasBuiltins m => Term -> m [(IntMap Bool, [Term])]+decomposeInterval t = do+  decomposeInterval' t <&> \xs ->+    [ (bm, ts) | (bsm, ts) <- xs, bm <- maybeToList $ traverse BoolSet.toSingleton bsm ]++-- | Decompose an interval expression @φ : I@ into a set of possible+-- assignments for the variables mentioned in @φ@, together any leftover+-- neutral terms that could not be put into 'IntervalView' form.+decomposeInterval' :: HasBuiltins m => Term -> m [(IntMap BoolSet, [Term])]+decomposeInterval' t = do+  view   <- intervalView'+  unview <- intervalUnview'+  let+    f :: IntervalView -> [[Either (Int,Bool) Term]]+    -- TODO handle primIMinDep+    -- TODO? handle forall+    f IZero = mzero     -- No assignments are possible+    f IOne  = return [] -- No assignments are necessary+    -- Take the cartesian product+    f (IMin x y) = do+      xs <- (f . view . unArg) x+      ys <- (f . view . unArg) y+      return (xs ++ ys)+    -- Take the union+    f (IMax x y) = msum $ map (f . view . unArg) [x,y]+    -- Invert the possible assignments and negate the neutrals+    f (INeg x) =+      map (either (\ (x,y) -> Left (x,not y)) (Right . unview . INeg . argN))+        <$> (f . view . unArg) x+    f (OTerm (Var i [])) = return [Left (i,True)]+    f (OTerm t)          = return [Right t]++  return [ (bsm, ts)+         | xs <- f (view t)+         , let (bs,ts) = partitionEithers xs+         , let bsm     = IntMap.fromListWith BoolSet.union $ map (second BoolSet.singleton) bs+         ]++reduce2Lam :: Term -> ReduceM (Blocked Term)+reduce2Lam t = do+  t <- reduce' t+  case lam2Abs Relevant t of+    t -> underAbstraction_ t $ \ t -> do+      t <- reduce' t+      case lam2Abs Irrelevant t of+        t -> underAbstraction_ t reduceB'+  where+    lam2Abs rel (Lam _ t) = absBody t <$ t+    lam2Abs rel t         = Abs "y" (raise 1 t `apply` [setRelevance rel $ argN $ var 0])++-- | Are we looking at an application of the 'Sub' type? If so, return:+-- * The type we're an extension of+-- * The extent+-- * The partial element.+isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term))+isCubicalSubtype t = do+  t <- reduce t+  msub <- getBuiltinName' builtinSub+  case unEl t of+    Def q es | Just q == msub, Just (level:typ:phi:ext:_) <- allApplyElims es -> do+      pure (pure (unArg level, unArg typ, unArg phi, unArg ext))+    _ -> pure Nothing
+ src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs-boot view
@@ -0,0 +1,6 @@+module Agda.TypeChecking.Primitive.Cubical.Base where++import Agda.TypeChecking.Monad.Pure+import Agda.Syntax.Internal++isCubicalSubtype :: PureTCM m => Type -> m (Maybe (Term, Term, Term, Term))
+ src/full/Agda/TypeChecking/Primitive/Cubical/Glue.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Primitive.Cubical.Glue+  ( mkGComp+  , doGlueKanOp++  , primGlue'+  , prim_glue'+  , prim_unglue'+  )+  where++import Control.Monad.Except++import Agda.Utils.Functor+import Agda.Utils.Monad+import Agda.Utils.Maybe++import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Env+import Agda.TypeChecking.Substitute (absBody, apply, sort, subst, applyE)+import Agda.TypeChecking.Reduce (reduceB', reduce')+import Agda.TypeChecking.Names (NamesT, runNamesT, runNames, cl, lam, open, ilam)++import Agda.Interaction.Options.Base (optCubical)++import Agda.Syntax.Common+  ( Hiding(..), Cubical(..), Arg(..)+  , ConOrigin(..), ProjOrigin(..)+  , Relevance(..)+  , setRelevance+  , defaultArgInfo, hasQuantity0, defaultArg, setHiding+  )++import Agda.TypeChecking.Primitive.Base+  ( (-->), nPi', pPi', hPi', el, el', el's, (<@>), (<@@>), (<#>), argN, argH, (<..>)+  , SigmaKit(..), getSigmaKit+  )++import Agda.Syntax.Internal+import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__)++import Agda.TypeChecking.Primitive.Cubical.Base++-- | Define a "ghcomp" version of gcomp. Normal comp looks like:+--+-- comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0)+--+-- So for "gcomp" we compute:+--+-- gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0)+--+-- The point of this is that gcomp does not produce any empty+-- systems (if phi = 0 it will reduce to "forward A 0 u".+mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)+mkGComp s = do+  let getTermLocal = getTerm s+  tPOr <- getTermLocal "primPOr"+  tIMax <- getTermLocal builtinIMax+  tIMin <- getTermLocal builtinIMin+  tINeg <- getTermLocal builtinINeg+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  io      <- getTermLocal builtinIOne+  iz      <- getTermLocal builtinIZero+  let forward la bA r u = pure tTrans <#> lam "i" (\ i -> la <@> (i `imax` r))+                                      <@> lam "i" (\ i -> bA <@> (i `imax` r))+                                      <@> r+                                      <@> u+  return $ \ la bA phi u u0 ->+    pure tHComp <#> (la <@> pure io)+                <#> (bA <@> pure io)+                <#> imax phi (ineg phi)+                <@> lam "i" (\ i -> combineSys (la <@> i) (bA <@> i)+                                      [ (phi,      ilam "o" $ \o -> forward la bA i (u <@> i <..> o))+                                      , (ineg phi, ilam "o" $ \o -> forward la bA (pure iz) u0)+                                      ])+                <@> forward la bA (pure iz) u0++-- | Perform the Kan operations for a @Glue φ A (T , e)@ type.+doGlueKanOp+  :: PureTCM m+  => KanOperation -- ^ Are we composing or transporting?+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)+  -- ^ The data of the Glue operation: The levels of @A@ and @T@, @A@+  -- itself, the extent of @T@, @T@ itself, and the family of+  -- equivalences.+  -> TermPosition+  -- ^ Are we computing a plain hcomp/transp or are we computing under+  -- @unglue@?+  -> m (Maybe Term)++doGlueKanOp (HCompOp psi u u0) (IsNot (la, lb, bA, phi, bT, e)) tpos = do+-- hcomp {psi} u u0 : Glue {la} {lb} bA {φ} (bT, e)+-- ... |- la, lb : Level+-- ... |- bA : Type la+-- ... |- bT : Partial φ (Type lB)+-- ... |- e : PartialP φ λ o → bT o ≃ bA+  let getTermLocal = getTerm $ builtinHComp ++ " for " ++ builtinGlue+  tHComp   <- getTermLocal builtinHComp+  tEFun    <- getTermLocal builtinEquivFun+  tglue    <- getTermLocal builtin_glue+  tunglue  <- getTermLocal builtin_unglue+  io       <- getTermLocal builtinIOne+  tItIsOne <- getTermLocal builtinItIsOne+  view     <- intervalView'++  runNamesT [] $ do+    [psi, u, u0] <- mapM (open . unArg) [ignoreBlocking psi, u, u0]+    [la, lb, bA, phi, bT, e] <- mapM (open . unArg) [la, lb, bA, phi, bT, e]++    ifM (headStop tpos phi) (return Nothing) $ Just <$> do+    let+      tf i o   = hfill lb (bT <..> o) psi u u0 i+      unglue g = pure tunglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> g++      a1 = pure tHComp <#> la <#> bA <#> (imax psi phi)+        <@> lam "i" (\i -> combineSys la bA+            [ (psi, ilam "o" (\o -> unglue (u <@> i <..> o)))+            , (phi, ilam "o" (\o -> pure tEFun <#> lb <#> la <#> (bT <..> o) <#> bA <@> (e <..> o) <@> tf i o))+            ])+        <@> unglue u0++      t1 = tf (pure io)++    case tpos of+      Head       -> t1 (pure tItIsOne)+      Eliminated -> a1++-- ...    |- psi, u0+-- ..., i |- la, lb, bA, phi, bT, e+doGlueKanOp (TranspOp psi u0) (IsFam (la, lb, bA, phi, bT, e)) tpos = do+-- transp (λ i → Glue {la} {lb} bA {φ} (bT , e)) ψ u0+  let+    localUse = builtinTrans ++ " for " ++ builtinGlue+    getTermLocal = getTerm localUse+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  tForall <- getTermLocal builtinFaceForall+  tEFun   <- getTermLocal builtinEquivFun+  tEProof <- getTermLocal builtinEquivProof+  toutS   <- getTermLocal builtinSubOut+  tglue   <- getTermLocal builtin_glue+  tunglue <- getTermLocal builtin_unglue+  io      <- getTermLocal builtinIOne+  iz      <- getTermLocal builtinIZero+  tLMax   <- getTermLocal builtinLevelMax+  tTransp <- getTermLocal builtinTranspProof+  tItIsOne <- getTermLocal builtinItIsOne+  kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+  runNamesT [] $ do++    gcomp <- mkGComp localUse++    -- transpFill: transp (λ j → bA (i ∧ j)) (φ ∨ ~ i) u0+    -- connects u0 and transp bA i0 u0+    let transpFill la bA phi u0 i =+          pure tTrans <#> lam "j" (\ j -> la <@> imin i j)+                      <@> lam "j" (\ j -> bA <@> imin i j)+                      <@> (imax phi (ineg i))+                      <@> u0+    [psi,u0] <- mapM (open . unArg) [ignoreBlocking psi,u0]++    -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a+    glue1 <- do+      g <- open $ (tglue `apply`) . map ((setHiding Hidden) . (subst 0 io)) $ [la, lb, bA, phi, bT, e]+      return $ \ t a -> g <@> t <@> a++    [la, lb, bA, phi, bT, e] <- mapM (\ a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, lb, bA, phi, bT, e]++    -- Andreas, 2022-03-24, fixing #5838+    -- Following the updated note+    --+    --   Simon Huber, A Cubical Type Theory for Higher Inductive Types+    --   https://simhu.github.io/misc/hcomp.pdf (February 2022)+    --+    -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776++    -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0+    let unglue_u0 i = foldl (<#>) (pure tunglue) (map (<@> i) [la, lb, bA, phi, bT, e]) <@> u0++    view <- intervalView'++    ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do+    let+      tf i o = transpFill lb (lam "i" $ \ i -> bT <@> i <..> o) psi u0 i+      t1 o = tf (pure io) o++      -- compute "forall. phi"+      forallphi = pure tForall <@> phi++      -- a1 with gcomp+      -- a1 = gcomp (ψ ∨ (∀ i. φ)) (λ { i (ψ = i1) → unglue_u0 i ; i ((∀ i. φ) = i1) → equivFun ... })+      --        (unglue_u0 i0)+      a1 = gcomp la bA (imax psi forallphi)+        (lam "i" $ \ i -> combineSys (la <@> i) (bA <@> i)+          [ (psi,       ilam "o" $ \_ -> unglue_u0 i)+          , (forallphi, ilam "o" $ \o -> w i o <@> (tf i o))+          ])+        (unglue_u0 (pure iz))++      max l l' = pure tLMax <@> l <@> l'+      sigCon x y = pure (Con (sigmaCon kit) ConOSystem []) <@> x <@> y++      -- The underlying function of our partial equivalence at the given+      -- endpoint of the interval, together with proof (o : IsOne φ).+      w i o = pure tEFun <#> (lb <@> i)+                         <#> (la <@> i)+                         <#> (bT <@> i <..> o)+                         <#> (bA <@> i)+                         <@> (e <@> i <..> o)++      -- Type of fibres of the partial equivalence over a1.+      fiberT o = fiber (lb <@> pure io) (la <@> pure io)+        (bT <@> (pure io) <..> o) (bA <@> pure io)+        (w (pure io) o)+        a1++      -- We don't have to do anything special for "~ forall. phi"+      -- here (to implement "ghcomp") as it is taken care off by+      -- tEProof in t1'alpha below+      pe o = -- o : IsOne φ+        combineSys (max (la <@> pure io) (lb <@> pure io)) (fiberT o)+          [ (psi       , ilam "o" $ \_ -> sigCon u0     (lam "_" $ \_ -> a1))+          , (forallphi , ilam "o" $ \o -> sigCon (t1 o) (lam "_" $ \_ -> a1))+          ]+      -- pe is a partial fibre of the equivalence with extent (ψ ∨ ∀ i. φ)+      -- over a1++      -- "ghcomp" is implemented in the proof of tEProof+      -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)+      t1'alpha o = -- o : IsOne φ+         -- Because @e i1 1=1@ is an equivalence, we can extend the+         -- partial fibre @pe@ to an actual fibre of (e i1 1=1) over a1.+         pure toutS <#> (max (la <@> pure io) (lb <@> pure io)) <#> fiberT o+          <#> imax psi forallphi+          <#> pe o+          <@> (pure tEProof+                <#> (lb <@> pure io)        <#> (la <@> pure io)+                <@> (bT <@> pure io <..> o) <@> (bA <@> pure io)+                <@> (e <@> pure io <..> o)  <@> a1+                <@> (imax psi forallphi)+                <@> pe o)++      -- TODO: optimize?+      t1' o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])+      alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])+      a1' = pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io)+        <#> imax (phi <@> pure io) psi+        <@> lam "j" (\j -> combineSys (la <@> pure io) (bA <@> pure io)+          [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, j))+          , (psi,             ilam "o" $ \o -> a1)+          ])+        <@> a1++    -- glue1 (ilam "o" t1') a1'+    case tpos of+      Head -> t1' (pure tItIsOne)+      Eliminated -> a1'+doGlueKanOp _ _ _ = __IMPOSSIBLE__++-- The implementation of 'primGlue'. Handles reduction where the partial+-- element is defined.+primGlue' :: TCM PrimitiveImpl+primGlue' = do+  requireCubical CFull ""+  -- primGlue+  --   : {la lb : Level} (A : Type la) {φ : I}+  --   → (T : Partial φ (Type lb)+  --   → (e : PartialP φ λ o → A ≃ T o)+  --   → Type lb+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "lb" (el $ cl primLevel) $ \ lb ->+       nPi' "A" (sort . tmSort <$> la) $ \ a ->+       hPi' "φ" primIntervalType $ \ φ ->+       nPi' "T" (pPi' "o" φ $ \ o -> el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->+       pPi' "o" φ (\ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a)+       --> (sort . tmSort <$> lb))+  view <- intervalView'+  one <- primItIsOne+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->+    case ts of+     [la,lb,a,phi,t,e] -> do+       sphi <- reduceB' phi+       -- If @φ = i1@ then we reduce to @T 1=1@, since @Glue@ is also a Kan operation.+       case view $ unArg $ ignoreBlocking $ sphi of+         IOne -> redReturn $ unArg t `apply` [argN one]+         -- Otherwise we're a regular ol' type.+         _    -> return (NoReduction $ map notReduced [la,lb,a] ++ [reduced sphi] ++ map notReduced [t,e])+     _ -> __IMPOSSIBLE__++-- | The implementation of 'prim_glue', the introduction form for @Glue@+-- types.+prim_glue' :: TCM PrimitiveImpl+prim_glue' = do+  requireCubical CFull ""+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "lb" (el $ cl primLevel) $ \ lb ->+       hPi' "A" (sort . tmSort <$> la) $ \ a ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->+       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->+       pPi' "o" φ (\ o -> el' lb (t <@> o)) --> (el' la a --> el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)))++  -- Takes a partial element of @t : T@ and an element of the base type @A@+  -- which extends @e t@, and makes it into a Glue.+  view <- intervalView'+  one <- primItIsOne+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \case+    [la, lb, bA, phi, bT, e, t, a] -> do+      sphi <- reduceB' phi+      -- When @φ = 1@ then @t : T@ is totally defined.+      case view $ unArg $ ignoreBlocking $ sphi of+        IOne -> redReturn $ unArg t `apply` [argN one]+        -- Otherwise we'll just wait to get unglued.+        _    -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e,t,a])+    _ -> __IMPOSSIBLE__++-- | The implementation of 'prim_unglue', the elimination form for+-- @Glue@ types.+prim_unglue' :: TCM PrimitiveImpl+prim_unglue' = do+  requireCubical CFull ""+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "lb" (el $ cl primLevel) $ \ lb ->+       hPi' "A" (sort . tmSort <$> la) $ \ a ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (pPi' "o" φ $ \ o ->  el' (cl primLevelSuc <@> lb) (Sort . tmSort <$> lb)) $ \ t ->+       hPi' "e" (pPi' "o" φ $ \ o -> el' (cl primLevelMax <@> la <@> lb) $ cl primEquiv <#> lb <#> la <@> (t <@> o) <@> a) $ \ e ->+       (el' lb (cl primGlue <#> la <#> lb <@> a <#> φ <@> t <@> e)) --> el' la a)++  -- Takes an element @b : Glue φ A (T, e)@ to an element of @A@ which,+  -- under @φ@, agrees with @e b@. Recall that @φ ⊢ e : A → T@ and @φ ⊢+  -- Glue φ A (T, e) = T@ so this is well-typed.+  view <- intervalView'+  one <- primItIsOne+  mGlue <- getPrimitiveName' builtinGlue+  mglue <- getPrimitiveName' builtin_glue+  mtransp <- getPrimitiveName' builtinTrans+  mhcomp <- getPrimitiveName' builtinHComp+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 7 $ \case+    [la, lb, bA, phi, bT, e, b] -> do+      sphi <- reduceB' phi+      case view $ unArg $ ignoreBlocking $ sphi of+        -- When @φ = i1@ we have @Glue i1 A (T , e) = T@ so @b : T@,+        -- and we must produce @unglue b : A [ i1 → e b ]@. But that's+        -- just @e b@!+        IOne -> do+          let argOne = setRelevance Irrelevant $ argN one+          tEFun <- getTerm builtin_unglue builtinEquivFun+          redReturn $ tEFun `apply` [lb,la,argH $ unArg bT `apply` [argOne],bA, argN $ unArg e `apply` [argOne],b]++        -- Otherwise we're dealing with a proper glued thing.+        -- Definitely a sticky situation!+        _    -> do+          sb <- reduceB' b+          let fallback sbA = return (NoReduction $ map notReduced [la,lb] ++ map reduced [sbA, sphi] ++ map notReduced [bT,e] ++ [reduced sb])+          case unArg $ ignoreBlocking $ sb of+            -- Case 1: unglue (glue a) = a. This agrees with the @φ =+            -- i1@ reduction because under @φ@, the argument to+            -- @glue@ must be in the image of the equivalence.+            Def q es+              | Just [_, _, _, _, _, _, _, a] <- allApplyElims es+              , Just q == mglue -> redReturn $ unArg a++            -- Case 2: unglue (transp (λ i → Glue ...) r u0).+            -- Defer to the implementation of @doGlueKanOp DoTransp ... Eliminated@: It knows how to unglue itself.+            Def q [Apply l, Apply bA, Apply r, Apply u0] | Just q == mtransp -> do+              sbA <- reduceB' bA+              -- Require that bA be a lambda abstraction...+              case unArg $ ignoreBlocking sbA of+                Lam _ t -> do+                  -- And that its body reduces to a Glue type.+                  st <- reduceB' (absBody t)+                  case ignoreBlocking st of+                    -- In this case, we use the Glue data extracted from+                    -- the family we're transporting over.+                    Def g es | Just [la', lb', bA', phi', bT', e'] <- allApplyElims es, Just g == mGlue -> do+                        redReturn . fromMaybe __IMPOSSIBLE__ =<<+                          doGlueKanOp (TranspOp (notBlocked r) u0) (IsFam (la',lb',bA',phi',bT',e')) Eliminated+                    _ -> fallback (st *> sbA)+                _ -> fallback sbA++            -- Case 3: unglue (hcomp u u0).+            -- Defer to the implementation of @doGlueKanOp DoHComp ... Eliminated@: It knows how to unglue itself.+            Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] | Just q == mhcomp -> do+              sbA <- reduceB' bA+              case unArg $ ignoreBlocking sbA of+                -- Idem: use the Glue data from the type we're doing+                -- hcomp in.+                Def g es | Just [la', lb', bA', phi', bT', e'] <- allApplyElims es, Just g == mGlue -> do+                  redReturn . fromMaybe __IMPOSSIBLE__ =<<+                    doGlueKanOp (HCompOp (notBlocked r) u u0) (IsNot (la',lb',bA',phi',bT',e')) Eliminated+                _ -> fallback sbA++            _ -> return (NoReduction $ map notReduced [la,lb,bA] ++ [reduced sphi] ++ map notReduced [bT,e] ++ [reduced sb])+    _ -> __IMPOSSIBLE__
+ src/full/Agda/TypeChecking/Primitive/Cubical/HCompU.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Primitive.Cubical.HCompU+  ( doHCompUKanOp+  , prim_glueU'+  , prim_unglueU'+  )+  where++import Control.Monad+import Control.Monad.Except ( MonadError )++import Agda.Utils.Functor+import Agda.Utils.Monad+import Agda.Utils.Maybe++import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Pure+import Agda.TypeChecking.Monad.Env+import Agda.TypeChecking.Substitute (absBody, apply, sort, subst, applyE)+import Agda.TypeChecking.Reduce (reduceB', reduceB, reduce')+import Agda.TypeChecking.Names (NamesT, runNamesT, runNames, cl, lam, open, ilam)++import Agda.Interaction.Options.Base (optCubical)++import Agda.Syntax.Common+  ( Hiding(..), Cubical(..), Arg(..)+  , ConOrigin(..), ProjOrigin(..)+  , Relevance(..)+  , setRelevance+  , defaultArgInfo, hasQuantity0, defaultArg, setHiding+  )++import Agda.TypeChecking.Primitive.Base+  ( (-->), nPi', pPi', hPi', el, el', el's, (<@>), (<@@>), (<#>), argN, argH, (<..>)+  , SigmaKit(..), getSigmaKit+  )++import Agda.Syntax.Internal+import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__)++import Agda.TypeChecking.Primitive.Cubical.Glue+import Agda.TypeChecking.Primitive.Cubical.Base++-- | Perform the Kan operations for an @hcomp {A = Type} {φ} u u0@ type.+doHCompUKanOp+  :: PureTCM m+  => KanOperation+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)+  -> TermPosition+  -> m (Maybe Term)++-- TODO (Amy, 2022-08-17): This is literally the same algorithm as+-- doGlueKanOp, but specialised for using transport as the equivalence.+-- Can we deduplicate them?+doHCompUKanOp (HCompOp psi u u0) (IsNot (la, phi, bT, bA)) tpos = do+  let getTermLocal = getTerm $ (builtinHComp ++ " for " ++ builtinHComp ++ " of Set")+  io       <- getTermLocal builtinIOne+  iz       <- getTermLocal builtinIZero+  tHComp   <- getTermLocal builtinHComp+  tTransp  <- getTermLocal builtinTrans+  tglue    <- getTermLocal builtin_glueU+  tunglue  <- getTermLocal builtin_unglueU+  tLSuc    <- getTermLocal builtinLevelSuc+  tSubIn   <- getTermLocal builtinSubIn+  tItIsOne <- getTermLocal builtinItIsOne+  runNamesT [] $ do+    [psi, u, u0] <- mapM (open . unArg) [ignoreBlocking psi, u, u0]+    [la, phi, bT, bA] <- mapM (open . unArg) [la, phi, bT, bA]++    ifM (headStop tpos phi) (return Nothing) $ Just <$> do++    let+      transp la bA a0 = pure tTransp <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0+      tf i o = hfill la (bT <@> pure io <..> o) psi u u0 i++      bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA+      unglue g = pure tunglue <#> la <#> phi <#> bT <#> bAS <@> g++      a1 = pure tHComp <#> la <#> bA <#> (imax psi phi)+        <@> lam "i" (\i -> combineSys la bA+            [ (psi, ilam "o" (\o -> unglue (u <@> i <..> o)))+            , (phi, ilam "o" (\ o -> transp la (\i -> bT <@> (ineg i) <..> o) (tf i o)))+            ])+        <@> unglue u0++      t1 = tf (pure io)++    -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1+    case tpos of+      Eliminated -> a1+      Head       -> t1 (pure tItIsOne)+++doHCompUKanOp (TranspOp psi u0) (IsFam (la, phi, bT, bA)) tpos = do+  let+    localUse = builtinTrans ++ " for " ++ builtinHComp ++ " of Set"+    getTermLocal = getTerm localUse+  tPOr <- getTermLocal "primPOr"+  tIMax <- getTermLocal builtinIMax+  tIMin <- getTermLocal builtinIMin+  tINeg <- getTermLocal builtinINeg+  tHComp <- getTermLocal builtinHComp+  tTrans <- getTermLocal builtinTrans+  tTranspProof <- getTermLocal builtinTranspProof+  tSubIn <- getTermLocal builtinSubIn+  tForall  <- getTermLocal builtinFaceForall+  io      <- getTermLocal builtinIOne+  iz      <- getTermLocal builtinIZero+  tLSuc   <- getTermLocal builtinLevelSuc+  tPath   <- getTermLocal builtinPath+  tItIsOne   <- getTermLocal builtinItIsOne+  kit <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+  runNamesT [] $ do+    -- Helper definitions we'll use:+    gcomp <- mkGComp localUse++    let+      transp la bA a0 = pure tTrans <#> lam "i" (const la) <@> lam "i" bA <@> pure iz <@> a0+      transpFill la bA phi u0 i = pure tTrans+        <#> ilam "j" (\ j -> la <@> imin i j)+        <@> ilam "j" (\ j -> bA <@> imin i j)+        <@> (imax phi (ineg i))+        <@> u0++    [psi, u0] <- mapM (open . unArg) [ignoreBlocking psi, u0]+    glue1 <- do+      tglue             <- cl $ getTermLocal builtin_glueU+      [la, phi, bT, bA] <- mapM (open . unArg . subst 0 io) $ [la, phi, bT, bA]+      let bAS = pure tSubIn <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <@> bA+      g <- (open =<<) $ pure tglue <#> la <#> phi <#> bT <#> bAS+      return $ \ t a -> g <@> t <@> a++    [la, phi, bT, bA] <- mapM (\a -> open . runNames [] $ lam "i" (const (pure $ unArg a))) [la, phi, bT, bA]++    -- Andreas, 2022-03-25, issue #5838.+    -- Port the fix of @unglueTranspGlue@ and @doGlueKanOp DoTransp@+    -- also to @doHCompUKanOp DoTransp@, as suggested by Tom Jack and Anders Mörtberg.+    -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@.+    -- The original code used it only with @i0@.+    tunglue <- cl $ getTermLocal builtin_unglueU+    let+      bAS i = pure tSubIn+        <#> (pure tLSuc <@> (la <@> i)) <#> (Sort . tmSort <$> (la <@> i)) <#> (phi <@> i)+        <@> (bA <@> i)+      unglue_u0 i = pure tunglue+        <#> (la <@> i) <#> (phi <@> i) <#> (bT <@> i)+        <#> bAS i <@> u0++    ifM (headStop tpos (phi <@> pure io)) (return Nothing) $ Just <$> do++    let+      tf i o = transpFill la (lam "i" $ \ i -> bT <@> i <@> pure io <..> o) psi u0 i+      t1 o   = tf (pure io) o++      -- compute "forall. phi"+      forallphi = pure tForall <@> phi++      -- a1 with gcomp+      a1 = gcomp la bA (imax psi forallphi)+        (lam "i" $ \ i -> combineSys (la <@> i) (bA <@> i)+          [ (psi,       ilam "o" $ \_ -> unglue_u0 i)+          , (forallphi, ilam "o" (\o -> transp (la <@> i) (\j -> bT <@> i <@> ineg j <..> o) (tf i o)))+          ])+          (unglue_u0 (pure iz))++      w i o = lam "x" $ transp (la <@> i) (\j -> bT <@> i <@> ineg j <..> o)++      pt o = -- o : [ φ 1 ]+        combineSys (la <@> pure io) (bT <@> pure io <@> pure io <..> o)+          [ (psi       , ilam "o" $ \_ -> u0)+          , (forallphi , ilam "o" $ \o -> t1 o)+          ]++      -- "ghcomp" is implemented in the proof of tTranspProof+      -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda)+      t1'alpha o = -- o : [ φ 1 ]+         pure tTranspProof+          <#> (la <@> pure io) <@> lam "i" (\i -> bT <@> pure io <@> ineg i <..> o)+          <@> imax psi forallphi+          <@> pt o+          <@> (pure tSubIn <#> (la <@> pure io) <#> (bA <@> pure io) <#> imax psi forallphi+                <@> a1)++      -- TODO: optimize?+      t1' o   = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaFst kit)])+      alpha o = t1'alpha o <&> (`applyE` [Proj ProjSystem (sigmaSnd kit)])+      a1' = pure tHComp <#> (la <@> pure io) <#> (bA <@> pure io)+        <#> imax (phi <@> pure io) psi+        <@> lam "j" (\j -> combineSys (la <@> pure io) (bA <@> pure io)+          [ (phi <@> pure io, ilam "o" $ \o -> alpha o <@@> (w (pure io) o <@> t1' o, a1, j))+          , (psi,             ilam "o" $ \o -> a1)+          ])+        <@> a1++    -- glue1 (ilam "o" t1') a1'+    case tpos of+      Eliminated -> a1'+      Head       -> t1' (pure tItIsOne)+doHCompUKanOp _ _ _ = __IMPOSSIBLE__++-- | The implementation of 'prim_glueU', the introduction form for+-- @hcomp@ types.+prim_glueU' :: TCM PrimitiveImpl+prim_glueU' = do+-- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue+-- applies here.+  requireCubical CErased ""+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->+       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do+       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)+       pPi' "o" φ (\ o -> el' la (t <@> cl primIOne <..> o))+         --> (el' la bA)+         --> el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA))+  view <- intervalView'+  one <- primItIsOne+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ts ->+    case ts of+      [la,phi,bT,bA,t,a] -> do+       sphi <- reduceB' phi+       case view $ unArg $ ignoreBlocking $ sphi of+         IOne -> redReturn $ unArg t `apply` [argN one]+         _    -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA,t,a])+      _ -> __IMPOSSIBLE__++-- | The implementation of 'prim_unglueU', the elimination form for+-- @hcomp@ types.+prim_unglueU' :: TCM PrimitiveImpl+prim_unglueU' = do+-- TODO (Amy, 2022-08-17): Same thing about duplicated code with Glue+-- applies here.+  requireCubical CErased ""+  t <- runNamesT [] $+       hPi' "la" (el $ cl primLevel) (\ la ->+       hPi' "φ" primIntervalType $ \ φ ->+       hPi' "T" (nPi' "i" primIntervalType $ \ _ -> pPi' "o" φ $ \ o -> sort . tmSort <$> la) $ \ t ->+       hPi' "A" (el's (cl primLevelSuc <@> la) $ cl primSub <#> (cl primLevelSuc <@> la) <@> (Sort . tmSort <$> la) <@> φ <@> (t <@> primIZero)) $ \ a -> do+       let bA = (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <#> (t <@> primIZero) <@> a)+       el' la (cl primHComp <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> φ <@> t <@> bA)+         --> el' la bA)++  view <- intervalView'+  one <- primItIsOne+  mglueU <- getPrimitiveName' builtin_glueU+  mtransp <- getPrimitiveName' builtinTrans+  mHCompU <- getPrimitiveName' builtinHComp+  let mhcomp = mHCompU++  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case+    [la,phi,bT,bA,b] -> do+      sphi <- reduceB' phi+      case view $ unArg $ ignoreBlocking $ sphi of+        -- Case where the hcomp has reduced away: Transport backwards+        -- along the partial element we've glued.+        IOne -> do+          tTransp <- getTerm builtin_unglueU builtinTrans+          iNeg    <- getTerm builtin_unglueU builtinINeg+          iZ      <- getTerm builtin_unglueU builtinIZero+          redReturn <=< runNamesT [] $ do+            [la,bT,b] <- mapM (open . unArg) [la,bT,b]+            pure tTransp <#> lam "i" (\ _ -> la) <@> lam "i" (\ i -> bT <@> ineg i <..> pure one)+              <@> pure iZ <@> b++        -- Otherwise, we're dealing with a proper glu- didn't I already+        -- make this joke? Oh, yeah, in prim_unglue, right.+        _ -> do+          sb <- reduceB' b+          let fallback sbA = return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])+          case unArg $ ignoreBlocking $ sb of+            -- Project:+            Def q es | Just [_,_,_,_,_, a] <- allApplyElims es, Just q == mglueU -> redReturn $ unArg a++            -- Transport:+            Def q [Apply l, Apply bA, Apply r, Apply u0] | Just q == mtransp -> do+              sbA <- reduceB bA+              case unArg $ ignoreBlocking sbA of+                Lam _ t -> do+                  st <- reduceB' (absBody t)+                  case ignoreBlocking st of+                    Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do+                      redReturn . fromMaybe __IMPOSSIBLE__ =<<+                        doHCompUKanOp (TranspOp (notBlocked r) u0) (IsFam (la,phi,bT,bA)) Eliminated+                    _ -> fallback (st *> sbA)+                _  -> fallback sbA++            -- Compose:+            Def q [Apply l,Apply bA,Apply r,Apply u,Apply u0] | Just q == mhcomp -> do+              sbA <- reduceB bA+              case unArg $ ignoreBlocking sbA of+                Def h es | Just [la,_,phi,bT,bA] <- allApplyElims es, Just h == mHCompU -> do+                  redReturn . fromMaybe __IMPOSSIBLE__ =<<+                    doHCompUKanOp (HCompOp (notBlocked r) u u0) (IsNot (la,phi,bT,bA)) Eliminated+                _ -> fallback sbA+            _ -> return (NoReduction $ map notReduced [la] ++ [reduced sphi] ++ map notReduced [bT,bA] ++ [reduced sb])++    _ -> __IMPOSSIBLE__
+ src/full/Agda/TypeChecking/Primitive/Cubical/Id.hs view
@@ -0,0 +1,293 @@+-- | Implementation of the primitives relating to Cubical identity types.+module Agda.TypeChecking.Primitive.Cubical.Id+  ( -- * General elimination form+    primIdElim'+  -- * Introduction form+  , primConId'+  -- * Projection maps (primarily used internally)+  , primIdFace'+  , primIdPath'+  -- * Kan operations+  , doIdKanOp+  )+  where++import Control.Monad.Except++import Agda.Utils.Impossible (__IMPOSSIBLE__)+import Agda.Utils.Monad++import qualified Data.IntMap as IntMap+import Data.Traversable+import Data.Maybe++import Agda.TypeChecking.Monad.Builtin+import Agda.TypeChecking.Monad.Base+import Agda.TypeChecking.Monad.Env+import Agda.TypeChecking.Substitute (apply, sort, listS, applySubst)+import Agda.TypeChecking.Reduce (reduceB', reduce')+import Agda.TypeChecking.Names+  (runNamesT, runNames, cl, lam, ilam, open)++import Agda.Interaction.Options.Base (optCubical)++import Agda.Syntax.Common (Cubical(..), Arg(..), defaultArgInfo, hasQuantity0, defaultArg)++import Agda.TypeChecking.Primitive.Base+  ((-->), nPi', pPi', hPi', el, el', el's, (<@>), (<#>), (<..>), argN)++import Agda.Syntax.Internal+import Agda.TypeChecking.Monad.Debug (__IMPOSSIBLE_VERBOSE__)++import Agda.TypeChecking.Primitive.Cubical.Base++-- | Primitive elimination rule for the cubical identity types. Unlike+-- J, @idElim@ makes explicit the structure of Swan's identity types as+-- being pairs of a cofibration and a path. Moreover, it records that+-- the path is definitionally @refl@ under that cofibration.+primIdElim' :: TCM PrimitiveImpl+primIdElim' = do+  -- The implementation here looks terrible but most of it is actually+  -- the type.+  requireCubical CErased ""+  t <- runNamesT [] $+    hPi' "a" (el $ cl primLevel) $ \ a ->+    hPi' "c" (el $ cl primLevel) $ \ c ->+    hPi' "A" (sort . tmSort <$> a) $ \ bA ->+    hPi' "x" (el' a bA) $ \ x ->+    nPi' "C" (nPi' "y" (el' a bA) $ \ y ->+              el' a (cl primId <#> a <#> bA <@> x <@> y) --> (sort . tmSort <$> c)) $ \ bC ->+    -- To construct (C : (y : A) → Id A x y → Type c), it suffices to:++    -- For all cofibrations φ,+    nPi' "φ" primIntervalType (\ phi ->+      -- For all y : A [ φ → (λ _ → x) ]+      nPi' "y" (el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (const x)) $ \ y ->+      let pathxy = cl primPath <#> a <@> bA <@> x <@> outSy+          outSy  = cl primSubOut <#> a <#> bA <#> phi <#> lam "o" (const x) <@> y+          reflx  = lam "o" $ \ _ -> lam "i" $ \ _ -> x -- TODO Andrea, should block on o+      -- For all w : (Path A x (outS y)) [ φ (λ _ → refl {x = outS y} ]+      in nPi' "w" (el's a $ cl primSub <#> a <@> pathxy <@> phi <@> reflx) $ \ w ->+      let outSw = (cl primSubOut <#> a <#> pathxy <#> phi <#> reflx <@> w)+      in el' c $ bC <@> outSy <@> (cl primConId <#> a <#> bA <#> x <#> outSy <@> phi <@> outSw))+      -- Construct an inhabitant of (C (outS y) (conid φ (outS w)))+    -->+    hPi' "y" (el' a bA) (\ y ->+      nPi' "p" (el' a $ cl primId <#> a <#> bA <@> x <@> y) $ \ p ->+      el' c $ bC <@> y <@> p)++  -- Implementation starts here:+  conid <- primConId+  sin <- primSubIn+  path <- primPath+  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 8 $ \case+    [a,c,bA,x,bC,f,y,p] -> do+      sp <- reduceB' p+      cview <- conidView'+      case cview (unArg x) $ unArg $ ignoreBlocking sp of+        -- Record that the right endpoint and the path definitionally+        -- agree with x φ holds. This is guaranteed internally by the+        -- typing rule for @conId@ but can't be recovered from+        -- @primIdPath@ and @primIdFace@ (see #2598)+        Just (phi, w) -> do+          let y' = sin `apply` [a, bA, phi, argN (unArg y)]+          let w' = sin `apply` [a, argN (path `apply` [a, bA, x, y]), phi, argN (unArg w)]+          redReturn $ unArg f `apply` [phi, defaultArg y', defaultArg w']+        _ -> return $ NoReduction $ map notReduced [a,c,bA,x,bC,f,y] ++ [reduced sp]+    _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primIdElim called with wrong arity"++-- | Introduction form for the cubical identity types.+primConId' :: TCM PrimitiveImpl+primConId' = do+  requireCubical CErased ""+  t <- runNamesT [] $+    hPi' "a" (el $ cl primLevel) $ \ a ->+    hPi' "A" (sort . tmSort <$> a) $ \ bA ->+    hPi' "x" (el' a bA) $ \ x ->+    hPi' "y" (el' a bA) $ \ y ->+    primIntervalType -- Cofibration+    --> (el' a $ cl primPath <#> a <#> bA <@> x <@> y)+    --> (el' a $ cl primId <#> a <#> bA <@> x <@> y)++  -- Implementation note: conId, as the name implies, is a constructor.+  -- It's not represented as a constructor because users can't match on+  -- it (but we, internally, can: see createMissingConIdClause).++  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \case+    [l,bA,x,y,phi,p] -> do+      sphi <- reduceB' phi+      view <- intervalView'+      case view $ unArg $ ignoreBlocking sphi of+        -- But even though it's a constructor, it does reduce, in some+        -- cases: If the cofibration is definitely true, then we return+        -- reflId.  TODO: Handle this in the conversion checker instead?+        IOne -> do+          reflId <- getTerm builtinConId builtinReflId+          redReturn $ reflId+        _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced sphi, notReduced p]+    _ -> __IMPOSSIBLE_VERBOSE__ "implementation of primConId called with wrong arity"++-- | Extract the underlying cofibration from an inhabitant of the+-- cubical identity types.+--+-- TODO (Amy, 2022-08-17): Projecting a cofibration from a Kan type+-- violates the cubical phase distinction.+primIdFace' :: TCM PrimitiveImpl+primIdFace' = do+  requireCubical CErased ""+  t <- runNamesT [] $+    hPi' "a" (el $ cl primLevel) $ \ a ->+    hPi' "A" (sort . tmSort <$> a) $ \ bA ->+    hPi' "x" (el' a bA) $ \ x ->+    hPi' "y" (el' a bA) $ \ y ->+    el' a (cl primId <#> a <#> bA <@> x <@> y)+    --> primIntervalType++  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case+    [l,bA,x,y,t] -> do+      st <- reduceB' t+      mConId <- getName' builtinConId+      cview <- conidView'+      case cview (unArg x) $ unArg (ignoreBlocking st) of+        Just (phi, _) -> redReturn (unArg phi)+        _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st]+    _ -> __IMPOSSIBLE__++-- | Extract the underlying path from an inhabitant of the+-- cubical identity types.+primIdPath' :: TCM PrimitiveImpl+primIdPath' = do+  requireCubical CErased ""+  t <- runNamesT [] $+    hPi' "a" (el $ cl primLevel) $ \ a ->+    hPi' "A" (sort . tmSort <$> a) $ \ bA ->+    hPi' "x" (el' a bA) $ \ x ->+    hPi' "y" (el' a bA) $ \ y ->+    el' a (cl primId <#> a <#> bA <@> x <@> y)+    --> el' a (cl primPath <#> a <#> bA <@> x <@> y)++  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \case+    [l,bA,x,y,t] -> do+      st <- reduceB' t+      mConId <- getName' builtinConId+      cview <- conidView'+      case cview (unArg x) $ unArg (ignoreBlocking st) of+        Just (_, w) -> redReturn (unArg w)+        _ -> return $ NoReduction $ map notReduced [l,bA,x,y] ++ [reduced st]+    _ -> __IMPOSSIBLE__++-- | Check that a term matches a given predicate on every consistent+-- substitution of interval variables which makes the given cofibration+-- hold.+onEveryFace+  :: Term -- ^ The cofibration @φ@+  -> Term -- ^ The term to test+  -> (Term -> Bool)+  -- ^ The predicate to test with.+  -> ReduceM Bool+onEveryFace phi u p = do+  unview <- intervalUnview'+  let boolToI b = if b then unview IOne else unview IZero+  as <- decomposeInterval phi+  bools <- for as $ \ (bs,ts) -> do+    let u' = listS (IntMap.toAscList $ IntMap.map boolToI bs) `applySubst` u+    t <- reduce2Lam u'+    return $! p $ ignoreBlocking t+  pure (and bools)++doIdKanOp+  :: KanOperation           -- ^ Are we composing or transporting?+  -> FamilyOrNot (Arg Term) -- ^ Level argument+  -> FamilyOrNot (Arg Term, Arg Term, Arg Term)+    -- ^ Domain, left and right endpoints of the identity type+  -> ReduceM (Maybe (Reduced t Term))+doIdKanOp kanOp l bA_x_y = do+  let getTermLocal = getTerm $ kanOpName kanOp ++ " for " ++ builtinId++  unview <- intervalUnview'+  mConId <- getName' builtinConId+  cview <- conidView'+  let isConId t = isJust $ cview __DUMMY_TERM__ t++  sa0 <- reduceB' (kanOpBase kanOp)+  -- TODO: wasteful to compute b even when cheaper checks might fail+  --+  -- Should we go forward with the Kan operation? This is the case when+  -- doing transport always, and when every face fo the partial element+  -- has reduced to @conid@ otherwise. Note that @conidView@ treats+  -- @reflId@ as though it were @conid i1 refl@.+  b <- case kanOp of+    TranspOp{}    -> return True+    HCompOp _ u _ ->+      onEveryFace (unArg . ignoreBlocking . kanOpCofib $ kanOp) (unArg u) isConId++  case mConId of+    Just conid | isConId (unArg . ignoreBlocking $ sa0), b -> (Just <$>) . (redReturn =<<) $ do+      tHComp    <- getTermLocal builtinHComp+      tTrans    <- getTermLocal builtinTrans+      tIMin     <- getTermLocal "primDepIMin"+      idFace    <- getTermLocal "primIdFace"+      idPath    <- getTermLocal "primIdPath"+      tPathType <- getTermLocal builtinPath+      tConId    <- getTermLocal builtinConId++      runNamesT [] $ do+        let+          io = pure $ unview IOne+          iz = pure $ unview IZero+          conId = pure tConId++          eval TranspOp{} l bA phi _ u0 =+            pure tTrans <#> l <@> bA <@> phi <@> u0+          eval HCompOp{} l bA phi u u0 =+            pure tHComp <#> (l <@> io) <#> (bA <@> io) <#> phi <@> u <@> u0++        -- Compute a line of levels. So we can invoke 'eval' uniformly.+        l <- case l of+          IsFam l -> open . unArg $ l+          IsNot l -> open (Lam defaultArgInfo $ NoAbs "_" $ unArg l)++        p0 <- open . unArg $ kanOpBase kanOp++        -- p is the partial element we are extending against. This is+        -- used to compute the resulting cofibration, so we fake a+        -- partial element when doing transport.+        p <- case kanOp of+          HCompOp _ u _ -> do+            u <- open . unArg $ u+            pure $ \i o -> u <@> i <..> o+          TranspOp{} -> do+            pure $ \i o -> p0++        phi <- open . unArg . ignoreBlocking $ kanOpCofib kanOp++        -- Similarly to the fake line of levels above, fake lines of+        -- everything even when we're doing composition, for uniformity+        -- of eval.+        [bA, x, y] <- case bA_x_y of+          IsFam (bA, x, y) -> for [bA, x, y] $ \a ->+            open $ runNames [] $ lam "i" (const (pure $ unArg a))+          IsNot (bA, x, y) -> for [bA, x, y] $ \a ->+            open (Lam defaultArgInfo $ NoAbs "_" $ unArg a)++        -- The resulting path is constant when when+        --    @Σ φ λ o → -- primIdFace p i1 o@+        -- holds. That's why cofibrations have to be closed under Σ,+        -- c.f. primDepIMin.+        cof <- pure tIMin+          <@> phi+          <@> ilam "o" (\o ->+            pure idFace <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io) <@> (p io o))++        -- Do the Kan operation for our faces in the Path type.+        path <- eval kanOp l+          (lam "i" $ \i -> pure tPathType <#> (l <@> i) <#> (bA <@> i) <@> (x <@> i) <@> (y <@> i))+          phi+          (lam "i" $ \i -> ilam "o" $ \o ->+            pure idPath <#> (l <@> i) <#> (bA <@> i) <#> (x <@> i) <#> (y <@> i) <@> (p i o))+          (pure idPath <#> (l <@> iz) <#> (bA <@> iz) <#> (x <@> iz) <#> (y <@> iz) <@> p0)++        conId <#> (l <@> io) <#> (bA <@> io) <#> (x <@> io) <#> (y <@> io)+          <@> pure cof+          <@> pure path+    _ -> return $ Nothing
src/full/Agda/TypeChecking/ProjectionLike.hs view
@@ -161,9 +161,9 @@ --   on (applications of) projection-like functions. elimView :: PureTCM m => ProjEliminator -> Term -> m Term elimView pe v = do-  reportSDoc "tc.conv.elim" 30 $ "elimView of " <+> prettyTCM v+  reportSDoc "tc.conv.elim" 60 $ "elimView of " <+> prettyTCM v   v <- reduceProjectionLike v-  reportSDoc "tc.conv.elim" 40 $+  reportSDoc "tc.conv.elim" 65 $     "elimView (projections reduced) of " <+> prettyTCM v   case pe of     NoPostfix -> return v@@ -262,7 +262,7 @@     -- the dropped arguments.     -- Nor can abstract definitions be projection-like since they won't reduce     -- outside the abstract block.-    def@Function{funProjection = Nothing, funClauses = cls,+    def@Function{funProjection = Left MaybeProjection, funClauses = cls,                  funSplitTree = st0, funCompiled = cc0, funInv = NotInjective,                  funMutual = Just [], -- Andreas, 2012-09-28: only consider non-mutual funs                  funAbstr = ConcreteDef} -> do@@ -307,7 +307,7 @@                     , projLams     = ProjLams $ map (argFromDom . fmap fst) tel                     }               let newDef = def-                           { funProjection     = Just projection+                           { funProjection     = Right projection                            , funClauses        = cls'                            , funSplitTree      = st                            , funCompiled       = cc@@ -322,8 +322,10 @@       reportSLn "tc.proj.like" 30 $ "  injective functions can't be projections"     Function{funAbstr = AbstractDef} ->       reportSLn "tc.proj.like" 30 $ "  abstract functions can't be projections"-    Function{funProjection = Just{}} ->+    Function{funProjection = Right{}} ->       reportSLn "tc.proj.like" 30 $ "  already projection like"+    Function{funProjection = Left NeverProjection} ->+      reportSLn "tc.proj.like" 30 $ "  the user has asked for it not to be projection-like"     Function{funMutual = Just (_:_)} ->       reportSLn "tc.proj.like" 30 $ "  mutual functions can't be projections"     Function{funMutual = Nothing} ->
src/full/Agda/TypeChecking/Quote.hs view
@@ -10,8 +10,10 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Common import Agda.Syntax.Internal as I+import Agda.Syntax.Internal.Pattern ( hasDefP, dbPatPerm ) import Agda.Syntax.Literal import Agda.Syntax.Position+import Agda.Syntax.TopLevelModuleName  import Agda.TypeChecking.CompiledClause import Agda.TypeChecking.DropArgs@@ -57,7 +59,7 @@  quotingKit :: TCM QuotingKit quotingKit = do-  currentFile     <- fromMaybe __IMPOSSIBLE__ <$> asksTC envCurrentPath+  currentModule   <- fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule   hidden          <- primHidden   instanceH       <- primInstance   visible         <- primVisible@@ -174,6 +176,7 @@       quoteSort SSet{}   = pure unsupportedSort       quoteSort SizeUniv = pure unsupportedSort       quoteSort LockUniv = pure unsupportedSort+      quoteSort IntervalUniv = pure unsupportedSort       quoteSort PiSort{} = pure unsupportedSort       quoteSort FunSort{} = pure unsupportedSort       quoteSort UnivSort{}   = pure unsupportedSort@@ -198,10 +201,11 @@       quotePat (ConP c _ ps)     = conP !@ quoteQName (conName c) @@ quotePats ps       quotePat (LitP _ l)        = litP !@ quoteLit l       quotePat (ProjP _ x)       = projP !@ quoteQName x-      quotePat (IApplyP o t u x) = pure unsupported+      -- #4763: quote IApply co/patterns as though they were variables+      quotePat (IApplyP _ _ _ x) = varP !@! quoteNat (toInteger $ dbPatVarIndex x)       quotePat DefP{}            = pure unsupported -      quoteClause :: Maybe Projection -> Clause -> ReduceM Term+      quoteClause :: Either a Projection -> Clause -> ReduceM Term       quoteClause proj cl@Clause{ clauseTel = tel, namedClausePats = ps, clauseBody = body} =         case body of           Nothing -> absurdClause !@ quoteTelescope tel @@ quotePats ps'@@ -210,8 +214,8 @@           -- #5128: restore dropped parameters if projection-like           ps' =             case proj of-              Nothing -> ps-              Just p  -> pars ++ ps+              Left _ -> ps+              Right p  -> pars ++ ps                 where                   n    = projIndex p - 1                   pars = map toVar $ take n $ zip (downFrom $ size tel) (telToList tel)@@ -219,12 +223,12 @@        quoteTelescope :: Telescope -> ReduceM Term       quoteTelescope tel = quoteList quoteTelEntry $ telToList tel-        where-          quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term-          quoteTelEntry dom@Dom{ unDom = (x , t) } = do-            SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit-            Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom) +      quoteTelEntry :: Dom (ArgName, Type) -> ReduceM Term+      quoteTelEntry dom@Dom{ unDom = (x , t) } = do+        SigmaKit{..} <- fromMaybe __IMPOSSIBLE__ <$> getSigmaKit+        Con sigmaCon ConOSystem [] !@! quoteString x @@ quoteDom quoteType (fmap snd dom)+       list :: [ReduceM Term] -> ReduceM Term       list = foldr (\ a as -> cons !@ a @@ as) (pure nil) @@ -244,6 +248,11 @@       quoteArgs :: Args -> ReduceM Term       quoteArgs ts = list (map (quoteArg quoteTerm) ts) +      -- has the clause been generated (in particular by --cubical)?+      -- TODO: have an explicit clause origin field?+      generatedClause :: Clause -> Bool+      generatedClause cl = hasDefP (namedClausePats cl)+       quoteTerm :: Term -> ReduceM Term       quoteTerm v = do         v <- instantiate' v@@ -262,15 +271,16 @@               qx Function{ funExtLam = Just (ExtLamInfo m False _), funClauses = cs } = do                     -- An extended lambda should not have any extra parameters!                     unless (null conOrProjPars) __IMPOSSIBLE__+                    cs <- return $ filter (not . generatedClause) cs                     n <- size <$> lookupSection m                     let (pars, args) = splitAt n ts-                    extlam !@ list (map (quoteClause Nothing . (`apply` pars)) cs)+                    extlam !@ list (map (quoteClause (Left ()) . (`apply` pars)) cs)                            @@ list (map (quoteArg quoteTerm) args)               qx df@Function{ funExtLam = Just (ExtLamInfo _ True _), funCompiled = Just Fail{}, funClauses = [cl] } = do                     -- See also corresponding code in InternalToAbstract                     let n = length (namedClausePats cl) - 1                         pars = take n ts-                    extlam !@ list [quoteClause Nothing $ cl `apply` pars ]+                    extlam !@ list [quoteClause (Left ()) $ cl `apply` pars ]                            @@ list (drop n $ map (quoteArg quoteTerm) ts)               qx _ = do                 n <- getDefFreeVars x@@ -289,7 +299,8 @@           Level l    -> quoteTerm (unlevelWithKit lkit l)           Lit l      -> lit !@ quoteLit l           Sort s     -> sort !@ quoteSort s-          MetaV x es -> meta !@! quoteMeta currentFile x @@ quoteArgs vs+          MetaV x es -> meta !@! quoteMeta currentModule x+                              @@ quoteArgs vs             where vs = fromMaybe __IMPOSSIBLE__ $ allApplyElims es           DontCare u -> quoteTerm u           Dummy s _  -> __IMPOSSIBLE_VERBOSE__ s@@ -299,9 +310,9 @@       defParameters def False = map par hiding         where           np = case theDef def of-                 Constructor{ conPars = np }        -> np-                 Function{ funProjection = Just p } -> projIndex p - 1-                 _                                  -> 0+                 Constructor{ conPars = np }         -> np+                 Function{ funProjection = Right p } -> projIndex p - 1+                 _                                   -> 0           TelV tel _ = telView' (defType def)           hiding     = take np $ telToList tel           par d      = arg !@ quoteArgInfo (domInfo d)@@ -311,6 +322,9 @@       quoteDefn def =         case theDef def of           Function{funClauses = cs, funProjection = proj} ->+           do+            -- re #3733: maybe these should be quoted but marked as generated?+            cs <- return $ filter (not . generatedClause) cs             agdaDefinitionFunDef !@ quoteList (quoteClause proj) cs           Datatype{dataPars = np, dataCons = cs} ->             agdaDefinitionDataDef !@! quoteNat (fromIntegral np) @@ quoteList (pure . quoteName) cs@@ -323,7 +337,7 @@           GeneralizableVar{} -> pure agdaDefinitionPostulate  -- TODO: reflect generalizable vars           AbstractDefn{}-> pure agdaDefinitionPostulate           Primitive{primClauses = cs} | not $ null cs ->-            agdaDefinitionFunDef !@ quoteList (quoteClause Nothing) cs+            agdaDefinitionFunDef !@ quoteList (quoteClause (Left ())) cs           Primitive{}   -> pure agdaDefinitionPrimitive           PrimitiveSort{} -> pure agdaDefinitionPrimitive           Constructor{conData = d} ->@@ -345,8 +359,8 @@ quoteConName :: ConHead -> Term quoteConName = quoteName . conName -quoteMeta :: AbsolutePath -> MetaId -> Term-quoteMeta file = Lit . LitMeta file+quoteMeta :: TopLevelModuleName -> MetaId -> Term+quoteMeta m = Lit . LitMeta m  quoteTerm :: Term -> TCM Term quoteTerm v = do
src/full/Agda/TypeChecking/ReconstructParameters.hs view
@@ -6,7 +6,9 @@  module Agda.TypeChecking.ReconstructParameters where +import Data.Functor ( ($>) ) import Data.Maybe+ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Generic@@ -55,116 +57,109 @@  reconstructParameters' :: Action TCM -> Type -> Term -> TCM Term reconstructParameters' act a v = do-  reportSDoc "tc.with.reconstruct" 30 $+  reportSDoc "tc.reconstruct" 30 $     sep [ "reconstructing parameters in"         , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]-  v <- checkInternal' reconstructAction v CmpLeq a+  v <- checkInternal' (reconstructAction' act) v CmpLeq a -  reportSDoc "tc.with.reconstruct" 30 $+  reportSDoc "tc.reconstruct" 30 $     nest 2 $ "-->" <+> prettyTCM v   return v-  where-    reconstructAction = defaultAction{ postAction = reconstruct } -    reconstruct a v = do-      reportSDoc "tc.with.reconstruct" 30 $-        sep [ "reconstructing in"-        , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM a ] ]-      case unSpine v of-        Con h ci vs -> do-          hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h)-          TelV tel a <- telView a-          let under = size tel  -- under-applied when under > 0-          reportSDoc "tc.reconstruct" 50 $-            sep [ "reconstructing"-                , nest 2 $ sep [ prettyTCM v <+> ":"-                               , nest 2 $ prettyTCM a ] ]-          case (unEl a) of-            Def d es -> do-              Just n <- defParameters <$> getConstInfo d-              let prePs = applySubst (strengthenS impossible under) . take n $ es-              let hiddenPs = map (Apply . hideAndRelParams) $ fromMaybe __IMPOSSIBLE__ $-                               allApplyElims prePs-              reportSDoc "tc.reconstruct" 50 $ "The hiddenPs are" <+> pretty hiddenPs-              tyCon <- defType <$> getConstInfo (conName hh)-              reportSDoc "tc.reconstruct" 50 $ "Here we start infering spine"-              ((_,Con hh ci psAfterAct),_) <- inferSpine' act tyCon (Con hh ci []) (Con hh ci []) hiddenPs-              ((_,conWithPars),_) <- inferSpine' reconstructAction tyCon (Con hh ci []) (Con hh ci []) psAfterAct-              reportSDoc "tc.reconstruct" 50 $ "The spine has been inferred:" <+> pretty conWithPars-              return $ applyWithoutReversing conWithPars vs-            _ -> __IMPOSSIBLE__-        _  -> do-          vv <- elimView EvenLone v-          unSpineAndReconstruct a vv-    unSpineAndReconstruct :: Type -> Term -> TCM Term-    unSpineAndReconstruct a v =-      case v of-        Var i vs -> do-          ty <- typeOfBV i-          ctx <- getContextTelescope-          reportSDoc "tc.reconstruct" 50 $ (text ("Var case "++(show i)++" with context")) <+> prettyTCM ctx-          loop ty (Var i) vs-        Def nam vs -> do-          reportSDoc "tc.reconstruct" 50 $ "Def case"-          ty <- defType <$> getConstInfo nam-          loop ty (Def nam) vs-        MetaV id vs -> do-          reportSDoc "tc.reconstruct" 50 $ "MetaVar case"-          ty <- getMetaType id-          loop ty (MetaV id) vs-        _ -> do-          reportSDoc "tc.reconstruct" 50 $ "Another case" <+> pretty v-          return v+reconstructAction :: Action TCM+reconstructAction = reconstructAction' defaultAction++reconstructAction' :: Action TCM -> Action TCM+reconstructAction' act = act{ postAction = \ty tm -> postAction act ty tm >>= reconstruct ty }++reconstruct :: Type -> Term -> TCM Term+reconstruct ty v = do+    reportSDoc "tc.reconstruct" 30 $+      sep [ "reconstructing in"+      , nest 2 $ sep [ prettyTCM v <+> ":", nest 2 $ prettyTCM ty ] ]+    case v of+      Con h ci vs -> do+        hh <- fromRight __IMPOSSIBLE__ <$> getConHead (conName h)+        TelV tel dataTy <- telView ty+        reportSDoc "tc.reconstruct" 50 $+          sep [ "reconstructing"+              , nest 2 $ sep [ prettyTCM v <+> ":"+                             , nest 2 $ prettyTCM dataTy ] ]+        pars <- addContext tel $ extractParameters (conName h) dataTy+        -- If the constructor is underapplied, we need to escape from the telescope.+        let escape = applySubst $ strengthenS __IMPOSSIBLE__ $ size tel+        return $ Con hh ci $ map Apply (escape pars) ++ vs+      Def f es -> projView v >>= \case+        ProjectionView _f a es -> do+          recTy <- infer =<< dropParameters (unArg a)+          pars <- extractParameters f recTy+          loop ty (Def f . (map Apply pars ++) . (Apply a:)) es+        LoneProjectionLike _f i -> reduce (unEl ty) >>= \case+          Pi recTy _ -> do+            pars <- extractParameters f (unDom recTy)+            return $ Def f $ map Apply pars+          _ -> __IMPOSSIBLE__+        NoProjection{} -> do+          ty <- defType <$> getConstInfo f+          loop ty (Def f) es+      Var i es -> do+        ty <- typeOfBV i+        loop ty (Var i) es+      MetaV m es -> do+        ty <- getMetaType m+        loop ty (MetaV m) es+      _ -> return v++  where     -- @loop ty f vs@ where @ty@ is the type of @f []@ and vs are valid     -- arguments to something of type @ty@     loop :: Type -> (Elims -> Term) -> Elims -> TCM Term-    loop ty f = loop' ty f f-    -- We duplicate @f@ because we don't want the parameters to be reconstructed in-    -- type, since it would cause type-checking error when running @checkInternal'@.-    -- The first one @fTe@ is for term, the other one @fTy@ for type.-    loop' ty fTe _   []           = do-      reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> (pretty $ fTe [])-      return $ fTe []-    loop' ty fTe fTy (Apply u:es) = do+    loop ty f []           = do+      reportSDoc "tc.reconstruct" 50 $ "Loop ended" <+> pretty (f [])+      return $ f []+    loop ty f (Apply u:es) = do       reportSDoc "tc.reconstruct" 50 $ "The type before app is:" <+> pretty ty-      reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (fTe [])+      reportSDoc "tc.reconstruct" 50 $ "The term before app is:" <+> prettyTCM (f [])       uu <- dropParameters u       reportSDoc "tc.reconstruct" 50 $ "The app is:" <+> pretty uu       ty' <- piApplyM ty uu       reportSDoc "tc.reconstruct" 50 $ "The type after app is:" <+> pretty ty'-      loop' ty' (fTe . (Apply u :)) (fTy . (Apply uu :)) es-    loop' ty fTe fTy (Proj o p:es) = do+      loop ty' (f . (Apply u :)) es+    loop ty f (Proj o p:es) = do       reportSDoc "tc.reconstruct" 50 $ "The type is:" <+> pretty ty-      reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (fTe [])+      reportSDoc "tc.reconstruct" 50 $ "The term is:" <+> pretty (f [])       reportSDoc "tc.reconstruct" 50 $ "The proj is:" <+> prettyTCM p-      ty' <- reduce ty-      case unEl ty' of-        Def r pars -> do-          ~(Just (El _ (Pi _ b))) <- getDefType p ty'-          tyProj <- defType <$> getConstInfo p-          let reconstructWithoutPostFixing = reconstructAction { elimViewAction = elimView NoPostfix }-          let hiddenPs = map Apply $ mapHide tyProj $ fromMaybe __IMPOSSIBLE__ $-                               allApplyElims pars-          reportSDoc "tc.reconstruct" 50 $ "The params are" <+> pretty hiddenPs-          ((_,Def p psAfterAct),_) <- inferSpine' act tyProj (Def p []) (Def p []) hiddenPs-          ((_,projWithPars),_) <- inferSpine' reconstructWithoutPostFixing tyProj (Def p []) (Def p []) psAfterAct-          reportSDoc "tc.reconstruct" 50 $ "Spine infered" <+> pretty projWithPars-          let fTe' x = applyWithoutReversing projWithPars ((Apply $ defaultArg $ fTe []):x)-          loop' (absApp b (fTy [])) fTe' (fTy . (Proj o p:)) es-        _ -> __IMPOSSIBLE__-    loop' ty _   _   (IApply {}:vs) = __IMPOSSIBLE__--    applyWithoutReversing :: Term -> Elims -> Term-    applyWithoutReversing (Var i es)   ess = Var i (es++ess)-    applyWithoutReversing (Def n es)   ess = Def n (es++ess)-    applyWithoutReversing (Con h i es) ess = Con h i (es++ess)-    applyWithoutReversing (MetaV i es) ess = MetaV i (es++ess)-    applyWithoutReversing (Dummy s es) ess = Dummy s (es++ess)-    applyWithoutReversing _            _   = __IMPOSSIBLE__+      pars <- extractParameters p ty+      ~(Just (El _ (Pi _ b))) <- getDefType p =<< reduce ty+      let fTm = f []+      fe <- dropParameters fTm+      loop (absApp b fe) (Def p . (map Apply pars ++) . (Apply (defaultArg fTm) :)) es+    loop ty _ (IApply {}:vs) = __IMPOSSIBLE__ -    mapHide (El _ (Pi a b)) (p:tl) =-      applyWhen (getHiding a == Hidden) hideAndRelParams p : mapHide (unAbs b) tl-    mapHide t l = l+-- Extract the parameters from the type of a constructor+-- application or the type of the principal argument of a+-- projection.+extractParameters :: QName -> Type -> TCM Args+extractParameters q ty = reduce (unEl ty) >>= \case+  Def d prePs -> do+    dt <- defType <$> getConstInfo d+    reportSDoc "tc.reconstruct" 50 $ "Here we start infering spine"+    ((_,Def _ postPs),_) <- inferSpine' reconstructAction dt (Def d []) (Def d []) prePs+    reportSDoc "tc.reconstruct" 50 $ "The spine has been inferred:" <+> pretty postPs+    info <- getConstInfo q+    let mkParam = hideAndRelParams+                . isApplyElim' __IMPOSSIBLE__+    if -- Case: data or record constructor+       | Constructor{ conPars = n } <- theDef info ->+           return $ map mkParam $ take n postPs+       -- Case: regular projection+       | isProperProjection (theDef info) ->+           return $ map mkParam postPs+       -- Case: projection-like function+       | otherwise -> do+           TelV tel _ <- telViewUpTo (size postPs) $ defType info+           return $ zipWith ($>) (teleArgs tel :: Args) $ map (unArg . isApplyElim' __IMPOSSIBLE__) postPs+  _ -> __IMPOSSIBLE__  dropParameters :: TermLike a => a -> TCM a dropParameters = traverseTermM $
src/full/Agda/TypeChecking/RecordPatterns.hs view
@@ -178,8 +178,8 @@               -- inferred eta.           _ | Just (ch, b) <- eta -> yesEtaCase b ch           [(c, b)] | not comatch -> -- possible eta-match-            getConstructorInfo c >>= \ case-              RecordCon pm YesEta fs -> yesEtaCase b $+            getConstructorInfo' c >>= \ case+              Just (RecordCon pm YesEta fs) -> yesEtaCase b $                 ConHead c (IsRecord pm) Inductive (map argFromDom fs)               _ -> noEtaCase           _ -> noEtaCase
src/full/Agda/TypeChecking/Records.hs view
@@ -2,14 +2,18 @@  module Agda.TypeChecking.Records where +import Prelude hiding (null)+ import Control.Monad import Control.Monad.Except import Control.Monad.Trans.Maybe import Control.Monad.Writer+import Control.Applicative  import Data.Bifunctor import qualified Data.List as List import Data.Maybe+import Data.Set (Set) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HMap @@ -17,6 +21,7 @@ import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Concrete (FieldAssignment'(..)) import Agda.Syntax.Abstract.Name+import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn) import Agda.Syntax.Internal as I import Agda.Syntax.Position import Agda.Syntax.Scope.Base (isNameInScope)@@ -29,11 +34,14 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope import Agda.TypeChecking.Warnings+import {-# SOURCE #-} Agda.TypeChecking.Primitive.Cubical.Base (isCubicalSubtype)  import {-# SOURCE #-} Agda.TypeChecking.ProjectionLike (eligibleForProjectionLike)  import Agda.Utils.Either-import Agda.Utils.Functor (for, ($>))+import Agda.Utils.Function (applyWhen)+import Agda.Utils.Functor (for, ($>), (<&>))+import Agda.Utils.Lens import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Monad@@ -395,10 +403,23 @@     IApply{} -> __IMPOSSIBLE__  -- | Check if a name refers to an eta expandable record.+--+-- The answer is no for a record type with an erased constructor+-- unless the current quantity is \"erased\". {-# SPECIALIZE isEtaRecord :: QName -> TCM Bool #-} {-# SPECIALIZE isEtaRecord :: QName -> ReduceM Bool #-} isEtaRecord :: HasConstInfo m => QName -> m Bool-isEtaRecord r = maybe False ((YesEta ==) . recEtaEquality) <$> isRecord r+isEtaRecord r = do+  isRec <- isRecord r+  case isRec of+    Nothing -> return False+    Just r+      | recEtaEquality r /= YesEta -> return False+      | otherwise                  -> do+        constructorQ <- getQuantity <$>+                          getConstInfo (conName (recConHead r))+        currentQ     <- viewTC eQuantity+        return $ constructorQ `moreQuantity` currentQ  isEtaCon :: HasConstInfo m => QName -> m Bool isEtaCon c = getConstInfo' c >>= \case@@ -457,30 +478,31 @@   r@Record{} -> r { recEtaEquality' = setEtaEquality (recEtaEquality' r) $ NoEta pat }   _ -> __IMPOSSIBLE__ +-- | Turn on eta for non-recursive and inductive guarded recursive records,+--   unless user declared otherwise.+--   Projections do not preserve guardedness.+updateEtaForRecord :: QName -> TCM ()+updateEtaForRecord q = whenM etaEnabled $ do++  -- Do we need to switch on eta for record q?+  switchEta <- getConstInfo q <&> theDef <&> \case+    Record{ recInduction = ind, recEtaEquality' = eta }+      | Inferred NoEta{} <- eta, ind /= Just CoInductive -> True+      | otherwise -> False+    _ -> __IMPOSSIBLE__++  when switchEta $ do+    modifySignature $ updateDefinition q $ over (lensTheDef . lensRecord) $ \ d ->+      d{ _recEtaEquality' = Inferred YesEta }+ -- | Turn on eta for inductive guarded recursive records. --   Projections do not preserve guardedness. recursiveRecord :: QName -> TCM ()-recursiveRecord q = do-  ok <- etaEnabled-  modifySignature $ updateDefinition q $ updateTheDef $ \case-    r@Record{ recInduction = ind, recEtaEquality' = eta } ->-      r { recEtaEquality' = eta' }-      where-      eta' | ok, Inferred NoEta{} <- eta, ind /= Just CoInductive = Inferred YesEta-           | otherwise = eta-    _ -> __IMPOSSIBLE__+recursiveRecord = updateEtaForRecord  -- | Turn on eta for non-recursive record, unless user declared otherwise. nonRecursiveRecord :: QName -> TCM ()-nonRecursiveRecord q = whenM etaEnabled $ do-  -- Do nothing if eta is disabled by option.-  modifySignature $ updateDefinition q $ updateTheDef $ \case-    r@Record{ recInduction = ind, recEtaEquality' = Inferred (NoEta _) }-      | ind /= Just CoInductive ->-      r { recEtaEquality' = Inferred YesEta }-    r@Record{} -> r-    _          -> __IMPOSSIBLE__-+nonRecursiveRecord = updateEtaForRecord  -- | Check whether record type is marked as recursive. --@@ -508,7 +530,7 @@ -- --   Postcondition: @Δ = Γ₁, Γ', Γ₂[c Γ']@ and @Γ ⊢ σ : Δ@ and @Δ ⊢ τ : Γ@. -expandRecordVar :: Int -> Telescope -> TCM (Maybe (Telescope, Substitution, Substitution, Telescope))+expandRecordVar :: PureTCM m => Int -> Telescope -> m (Maybe (Telescope, Substitution, Substitution, Telescope)) expandRecordVar i gamma0 = do   -- Get the context with last variable added last in list.   let gamma = telToList gamma0@@ -759,59 +781,117 @@ -- Precondition: The name should refer to a record type, and the -- arguments should be the parameters to the type. isSingletonRecord :: (PureTCM m, MonadBlock m) => QName -> Args -> m Bool-isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps+isSingletonRecord r ps = isJust <$> isSingletonRecord' False r ps mempty  isSingletonRecordModuloRelevance :: (PureTCM m, MonadBlock m)                                  => QName -> Args -> m Bool-isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps+isSingletonRecordModuloRelevance r ps = isJust <$> isSingletonRecord' True r ps mempty  -- | Return the unique (closed) inhabitant if exists. --   In case of counting irrelevance in, the returned inhabitant --   contains dummy terms.-isSingletonRecord' :: forall m. (PureTCM m, MonadBlock m)-                   => Bool -> QName -> Args -> m (Maybe Term)-isSingletonRecord' regardIrrelevance r ps = do-  reportSDoc "tc.meta.eta" 30 $ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?"-  isRecord r >>= \case-    Nothing  -> return Nothing-    Just def -> do-      fmap (mkCon (recConHead def) ConOSystem) <$> check (recTel def `apply` ps)+isSingletonRecord'+  :: forall m. (PureTCM m, MonadBlock m)+  => Bool            -- ^ Should disregard irrelevant fields?+  -> QName           -- ^ Name of record type to check.+  -> Args            -- ^ Parameters given to the record type.+  -> Set QName       -- ^ Non-terminating record types we already encountered.+                     --   These are considered as non-singletons,+                     --   otherwise we would construct an infinite inhabitant (in an infinite time...).+  -> m (Maybe Term)  -- ^ The unique inhabitant, if any.  May contain dummy terms in irrelevant positions.+isSingletonRecord' regardIrrelevance r ps rs = do+  reportSDoc "tc.meta.eta" 30 $ vcat+    [ "Is" <+> prettyTCM (Def r $ map Apply ps) <+> "a singleton record type?"+    , "  already visited:" <+> hsep (map prettyTCM $ Set.toList rs)+    ]+  -- Andreas, 2022-03-10, issue #5823+  -- We need to make sure we are not infinitely unfolding records, so we only expand each once,+  -- and keep track of the recursive ones we have already seen.+  if r `Set.member` rs then no else do+    caseMaybeM (isRecord r) no $ \ def -> do+      -- We might not know yet whether a record type is recursive because the positivity checker hasn't run yet.+      -- In this case, we pessimistically consider the record type to be recursive (@True@).+      let recursive = maybe True (not . null) $ recMutual def+      -- Andreas, 2022-03-23, issue #5823+      -- We may pass through terminating record types as often as we want.+      -- If the termination checker has not run yet, we pessimistically consider the record type+      -- to be non-terminating.+      let nonTerminating = maybe True not $ recTerminates def+      reportSDoc "tc.meta.eta" 30 $ vcat+        [ hsep [ prettyTCM r, "is recursive      :", prettyTCM recursive      ]+        , hsep [ prettyTCM r, "is non-terminating:", prettyTCM nonTerminating ]+        ]+      fmap (mkCon (recConHead def) ConOSystem) <$> do+        check (applyWhen (recursive && nonTerminating) (Set.insert r) rs) $ recTel def `apply` ps   where-  check :: Telescope -> m (Maybe [Arg Term])-  check tel = do+  -- Check that all entries of the constructor telescope are singletons.+  check :: Set QName -> Telescope -> m (Maybe [Arg Term])+  check rs tel = do     reportSDoc "tc.meta.eta" 30 $       "isSingletonRecord' checking telescope " <+> prettyTCM tel     case tel of-      EmptyTel -> return $ Just []+      EmptyTel -> yes       ExtendTel dom tel -> ifM (return regardIrrelevance `and2M` isIrrelevantOrPropM dom)         {-then-}-          (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check)+          (underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) __DUMMY_TERM__ :)) . check rs)         {-else-} $ do-          isSing <- isSingletonType' regardIrrelevance $ unDom dom-          case isSing of-            Nothing  -> return Nothing-            (Just v) -> underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check+          caseMaybeM (isSingletonType' regardIrrelevance (unDom dom) rs) no $ \ v -> do+            underAbstraction dom tel $ fmap (fmap (Arg (domInfo dom) v :)) . check rs+  no  = return Nothing+  yes = return $ Just []  -- | Check whether a type has a unique inhabitant and return it. --   Can be blocked by a metavar. isSingletonType :: (PureTCM m, MonadBlock m) => Type -> m (Maybe Term)-isSingletonType = isSingletonType' False+isSingletonType t = isSingletonType' False t mempty  -- | Check whether a type has a unique inhabitant (irrelevant parts ignored). --   Can be blocked by a metavar. isSingletonTypeModuloRelevance :: (PureTCM m, MonadBlock m) => Type -> m Bool-isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t+isSingletonTypeModuloRelevance t = isJust <$> isSingletonType' True t mempty -isSingletonType' :: (PureTCM m, MonadBlock m) => Bool -> Type -> m (Maybe Term)-isSingletonType' regardIrrelevance t = do+isSingletonType'+  :: forall m. (PureTCM m, MonadBlock m)+  => Bool            -- ^ Should disregard irrelevant fields?+  -> Type            -- ^ Type to check.+  -> Set QName       -- ^ Non-terminating record typess we already encountered.+                     --   These are considered as non-singletons,+                     --   otherwise we would construct an infinite inhabitant (in an infinite time...).+  -> m (Maybe Term)  -- ^ The unique inhabitant, if any.  May contain dummy terms in irrelevant positions.+isSingletonType' regardIrrelevance t rs = do     TelV tel t <- telView t     t <- abortIfBlocked t     addContext tel $ do-      res <- isRecordType t-      case res of-        Just (r, ps, def) | YesEta <- recEtaEquality def -> do-          fmap (abstract tel) <$> isSingletonRecord' regardIrrelevance r ps-        _ -> return Nothing+      let+        -- Easy case: η for records.+        record :: m (Maybe Term)+        record = runMaybeT $ do+          (r, ps, def) <- MaybeT $ isRecordType t+          guard (YesEta == recEtaEquality def)+          abstract tel <$> MaybeT (isSingletonRecord' regardIrrelevance r ps rs)++        -- Slightly harder case: η for Sub {level} tA phi elt.+        -- tA : Type level, phi : I, elt : Partial phi tA.+        subtype :: m (Maybe Term)+        subtype = runMaybeT $ do+          (level, tA, phi, elt) <- MaybeT $ isCubicalSubtype t+          subin <- MaybeT $ getBuiltinName' builtinSubIn+          itIsOne <- MaybeT $ getBuiltinName' builtinIsOne+          phiV <- intervalView phi+          case phiV of+            -- If phi = i1, then inS (elt 1=1) is the only inhabitant.+            IOne -> do+              let+                argH = Arg $ setHiding Hidden defaultArgInfo+                it = elt `apply` [defaultArg (Def itIsOne [])]+              pure (Def subin [] `apply` [argH level, argH tA, argH phi, defaultArg it])+            -- Otherwise we're blocked+            OTerm phi' -> patternViolation (unblockOnAnyMetaIn phi')+            -- This fails the MaybeT: we're not looking at a+            -- definitional singleton.+            _ -> fail ""++      (<|>) <$> record <*> subtype  -- | Checks whether the given term (of the given type) is beta-eta-equivalent --   to a variable. Returns just the de Bruijn-index of the variable if it is,
src/full/Agda/TypeChecking/Reduce.hs view
@@ -1,6 +1,29 @@ {-# LANGUAGE NondecreasingIndentation #-} -module Agda.TypeChecking.Reduce where+module Agda.TypeChecking.Reduce+ -- Meta instantiation+ ( Instantiate, instantiate', instantiate, instantiateWhen+ -- Recursive meta instantiation+ , InstantiateFull, instantiateFull', instantiateFull+ , instantiateFullExceptForDefinitions+ -- Check for meta (no reduction)+ , IsMeta, isMeta+ -- Reduction and blocking+ , Reduce, reduce', reduceB', reduce, reduceB, reduceWithBlocker, reduceIApply'+ , reduceDefCopy, reduceDefCopyTCM+ , reduceHead+ , slowReduceTerm+ , unfoldCorecursion, unfoldCorecursionE+ , unfoldDefinitionE, unfoldDefinitionStep+ , unfoldInlined+ , appDef', appDefE'+ , abortIfBlocked, ifBlocked, isBlocked+ -- Simplification+ , Simplify, simplify, simplifyBlocked'+ -- Normalization+ , Normalise, normalise', normalise+ , slowNormaliseArgs+ ) where  import Control.Monad ( (>=>), void ) @@ -56,6 +79,18 @@ instantiateFull :: (InstantiateFull a, MonadReduce m) => a -> m a instantiateFull = liftReduce . instantiateFull' +-- | A variant of 'instantiateFull' that only instantiates those+-- meta-variables that satisfy the predicate.++instantiateWhen ::+  (InstantiateFull a, MonadReduce m) =>+  (MetaId -> ReduceM Bool) ->+  a -> m a+instantiateWhen p =+  liftReduce .+  localR (\env -> env { redPred = Just p }) .+  instantiateFull'+ reduce :: (Reduce a, MonadReduce m) => a -> m a reduce = liftReduce . reduce' @@ -80,10 +115,11 @@ normalise :: (Normalise a, MonadReduce m) => a -> m a normalise = liftReduce . normalise' --- | Normalise the given term but also preserve blocking tags---   TODO: implement a more efficient version of this.-normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t)-normaliseB = normalise >=> reduceB+-- UNUSED+-- -- | Normalise the given term but also preserve blocking tags+-- --   TODO: implement a more efficient version of this.+-- normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t)+-- normaliseB = normalise >=> reduceB  simplify :: (Simplify a, MonadReduce m) => a -> m a simplify = liftReduce . simplify'@@ -91,9 +127,9 @@ -- | Meaning no metas left in the instantiation. isFullyInstantiatedMeta :: MetaId -> TCM Bool isFullyInstantiatedMeta m = do-  mv <- lookupMeta m-  case mvInstantiation mv of-    InstV _tel v -> noMetas <$> instantiateFull v+  inst <- lookupMetaInstantiation m+  case inst of+    InstV inst -> noMetas <$> instantiateFull (instBody inst)     _ -> return False  -- | Blocking on all blockers.@@ -139,34 +175,64 @@ instance (Instantiate a, Instantiate b,Instantiate c) => Instantiate (a,b,c) where     instantiate' (x,y,z) = (,,) <$> instantiate' x <*> instantiate' y <*> instantiate' z +-- | Run the second computation if the 'redPred' predicate holds for+-- the given meta-variable (or if the predicate is not defined), and+-- otherwise the first computation.++ifPredicateDoesNotHoldFor ::+  MetaId -> ReduceM a -> ReduceM a -> ReduceM a+ifPredicateDoesNotHoldFor m doesNotHold holds = do+  pred <- redPred <$> askR+  case pred of+    Nothing -> holds+    Just p  -> ifM (p m) holds doesNotHold+ instance Instantiate Term where-  instantiate' t@(MetaV x es) = do+  instantiate' t@(MetaV x es) = ifPredicateDoesNotHoldFor x (return t) $ do     blocking <- view stInstantiateBlocking <$> getTCState -    mv <- lookupMeta x-    let mi = mvInstantiation mv+    m <- lookupMeta x+    case m of+      Just (Left rmv) -> cont (rmvInstantiation rmv) -    case mi of-      InstV tel v -> instantiate' inst-        where-          -- A slight complication here is that the meta might be underapplied,-          -- in which case we have to build the lambda abstraction before-          -- applying the substitution, or overapplied in which case we need to-          -- fall back to applyE.-          (es1, es2) = splitAt (length tel) es-          vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1-          rho = vs1 ++# wkS (length vs1) idS-                -- really should be .. ++# emptyS but using wkS makes it reduce to idS-                -- when applicable-          -- specification: inst == foldr mkLam v tel `applyE` es-          inst = applySubst rho (foldr mkLam v $ drop (length es1) tel) `applyE` es2-      _ | Just m' <- mvTwin mv, blocking -> do-            instantiate' (MetaV m' es)-      Open                             -> return t-      OpenInstance                     -> return t-      BlockedConst u | blocking  -> instantiate' . unBrave $ BraveTerm u `applyE` es-                     | otherwise -> return t-      PostponedTypeCheckingProblem _ -> return t+      Just (Right mv) -> case mvInstantiation mv of+         InstV inst -> cont inst++         _ | Just m' <- mvTwin mv, blocking ->+           instantiate' (MetaV m' es)++         Open -> return t++         OpenInstance -> return t++         BlockedConst u+           | blocking  -> instantiate' . unBrave $+                          BraveTerm u `applyE` es+           | otherwise -> return t++         PostponedTypeCheckingProblem _ -> return t++      Nothing -> __IMPOSSIBLE_VERBOSE__+                   ("Meta-variable not found: " ++ prettyShow x)+    where+    cont i = instantiate' inst+      where+      -- A slight complication here is that the meta might be underapplied,+      -- in which case we have to build the lambda abstraction before+      -- applying the substitution, or overapplied in which case we need to+      -- fall back to applyE.+      (es1, es2) = splitAt (length (instTel i)) es+      vs1 = reverse $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es1+      rho = vs1 ++# wkS (length vs1) idS+            -- really should be .. ++# emptyS but using wkS makes it reduce to idS+            -- when applicable+      -- specification:+      -- inst == foldr mkLam (instBody i) (instTel i) `applyE` es+      inst =+        applySubst rho+          (foldr mkLam (instBody i) $ drop (length es1) (instTel i))+          `applyE` es2+   instantiate' (Level l) = levelTm <$> instantiate' l   instantiate' (Sort s) = Sort <$> instantiate' s   instantiate' t = return t@@ -192,6 +258,7 @@   instantiate' b@(UnblockOnMeta x) =     ifM (isInstantiatedMeta x) (return alwaysUnblock) (return b)   instantiate' b@UnblockOnProblem{} = return b+  instantiate' b@UnblockOnDef{} = return b  instance Instantiate Sort where   instantiate' = \case@@ -203,7 +270,7 @@     s -> return s  instance (Instantiate t, Instantiate e) => Instantiate (Dom' t e) where-    instantiate' (Dom i fin n tac x) = Dom i fin n <$> instantiate' tac <*> instantiate' x+    instantiate' (Dom i n b tac x) = Dom i n b <$> instantiate' tac <*> instantiate' x  instance Instantiate a => Instantiate (Closure a) where     instantiate' cl = do@@ -231,9 +298,10 @@   instantiate' (CheckLockedVars a b c d) =     CheckLockedVars <$> instantiate' a <*> instantiate' b <*> instantiate' c <*> instantiate' d   instantiate' (UnquoteTactic t h g) = UnquoteTactic <$> instantiate' t <*> instantiate' h <*> instantiate' g+  instantiate' (CheckDataSort q s)  = CheckDataSort q <$> instantiate' s   instantiate' c@CheckMetaInst{}    = return c   instantiate' (CheckType t)        = CheckType <$> instantiate' t-  instantiate' (UsableAtModality mod t) = UsableAtModality mod <$> instantiate' t+  instantiate' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> instantiate' ms <*> instantiate' t  instance Instantiate CompareAs where   instantiate' (AsTermsOf a) = AsTermsOf <$> instantiate' a@@ -332,27 +400,42 @@     reduceB' (El s t) = workOnTypes $ fmap (El s) <$> reduceB' t  instance Reduce Sort where-    reduce' s = do+    reduceB' s = do       s <- instantiate' s+      let done | MetaS x _ <- s = return $ blocked x s+               | otherwise      = return $ notBlocked s       case s of-        PiSort a s1 s2 -> do-          (s1' , s2') <- reduce' (s1 , s2)-          maybe (return $ PiSort a s1' s2') reduce' $ piSort' a s1' s2'-        FunSort s1 s2 -> do-          (s1' , s2') <- reduce (s1 , s2)-          maybe (return $ FunSort s1' s2') reduce' $ funSort' s1' s2'-        UnivSort s' -> do-          s' <- reduce' s'-          caseMaybe (univSort' s') (return $ UnivSort s') reduce'-        Prop s'    -> Prop <$> reduce' s'-        Type s'    -> Type <$> reduce' s'-        Inf f n    -> return $ Inf f n-        SSet s'    -> SSet <$> reduce' s'-        SizeUniv   -> return SizeUniv-        LockUniv   -> return LockUniv-        MetaS x es -> return s-        DefS d es  -> return s -- postulated sorts do not reduce-        DummyS{}   -> return s+        PiSort a s1 s2 -> reduceB' (s1 , s2) >>= \case+          Blocked b (s1',s2') -> return $ Blocked b $ PiSort a s1' s2'+          NotBlocked _ (s1',s2') -> do+            -- Jesper, 2022-10-12: do instantiateFull here because+            -- `piSort'` does checking of free variables, and if we+            -- don't instantiate we might end up blocking on a solved+            -- metavariable.+            s2' <- instantiateFull s2'+            case piSort' a s1' s2' of+              Left b -> return $ Blocked b $ PiSort a s1' s2'+              Right s -> reduceB' s+        FunSort s1 s2 -> reduceB' (s1 , s2) >>= \case+          Blocked b (s1',s2') -> return $ Blocked b $ FunSort s1' s2'+          NotBlocked _ (s1',s2') -> case funSort' s1' s2' of+            Left b -> return $ Blocked b $ FunSort s1' s2'+            Right s -> reduceB' s+        UnivSort s1 -> reduceB' s1 >>= \case+          Blocked b s1' -> return $ Blocked b $ UnivSort s1'+          NotBlocked _ s1' -> case univSort' s1' of+            Left b -> return $ Blocked b $ UnivSort s1'+            Right s -> reduceB' s+        Prop l     -> notBlocked . Prop <$> reduce l+        Type l     -> notBlocked . Type <$> reduce l+        Inf f n    -> done+        SSet l     -> notBlocked . SSet <$> reduce l+        SizeUniv   -> done+        LockUniv   -> done+        IntervalUniv -> done+        MetaS x es -> done+        DefS d es  -> done -- postulated sorts do not reduce+        DummyS{}   -> done  instance Reduce Elim where   reduce' (Apply v) = Apply <$> reduce' v@@ -367,13 +450,17 @@   reduceB' (Plus n l) = fmap (Plus n) <$> reduceB' l  instance (Subst a, Reduce a) => Reduce (Abs a) where-  reduce' b@(Abs x _) = Abs x <$> underAbstraction_ b reduce'-  reduce' (NoAbs x v) = NoAbs x <$> reduce' v+  reduceB' b@(Abs x _) = fmap (Abs x) <$> underAbstraction_ b reduceB'+  reduceB' (NoAbs x v) = fmap (NoAbs x) <$> reduceB' v  -- Lists are never blocked instance Reduce t => Reduce [t] where     reduce' = traverse reduce' +-- Maybes are never blocked+instance Reduce t => Reduce (Maybe t) where+    reduce' = traverse reduce'+ instance Reduce t => Reduce (Arg t) where     reduce' a = case getRelevance a of       Irrelevant -> return a             -- Don't reduce' irr. args!?@@ -448,7 +535,7 @@       MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)       _         -> maybeFast v   where-    isOpen x = isOpenMeta . mvInstantiation <$> lookupMeta x+    isOpen x = isOpenMeta <$> lookupMetaInstantiation x     maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)  slowReduceTerm :: Term -> ReduceM (Blocked Term)@@ -470,7 +557,7 @@           v <- flip reduceIApply es                  $ unfoldDefinitionE False reduceB' (Con c ci []) (conName c) es           traverse reduceNat v-      Sort s   -> fmap Sort <$> reduceB' s+      Sort s   -> done       Level l  -> ifM (SmallSet.member LevelReductions <$> asksTC envAllowedReductions)                     {- then -} (fmap levelTm <$> reduceB' l)                     {- else -} done@@ -575,7 +662,7 @@         then reducePrimitive x v0 f es pf dontUnfold                              cls (defCompiled info) rewr         else noReduction $ notBlocked v-    PrimitiveSort{ primSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es+    PrimitiveSort{ primSortSort = s } -> yesReduction NoSimplification $ Sort s `applyE` es      _  -> do       if or@@ -753,7 +840,7 @@ appDefE_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term) appDefE_ f v0 cls mcc rewr args =   localTC (\ e -> e { envAppDef = Just f }) $-  maybe (appDefE' v0 cls rewr args)+  maybe (appDefE'' v0 cls rewr args)         (\cc -> appDefE v0 cc rewr args) mcc  @@ -771,11 +858,17 @@     NoReduction es'      -> rewrite (void es') (applyE v) rewr (ignoreBlocking es')  -- | Apply a defined function to it's arguments, using the original clauses.-appDef' :: Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)-appDef' v cls rewr args = appDefE' v cls rewr $ map (fmap Apply) args+appDef' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)+appDef' f v cls rewr args = appDefE' f v cls rewr $ map (fmap Apply) args -appDefE' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)-appDefE' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do+appDefE' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE' f v cls rewr es =+  localTC (\ e -> e { envAppDef = Just f }) $+  appDefE'' v cls rewr es++-- | Expects @'envAppDef' = Just f@ in 'TCEnv' to be able to report @'MissingClauses' f@.+appDefE'' :: Term -> [Clause] -> RewriteRules -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)+appDefE'' v cls rewr es = traceSDoc "tc.reduce" 90 ("appDefE' v = " <+> pretty v) $ do   goCls cls $ map ignoreReduced es   where     goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term)@@ -787,7 +880,9 @@         -- the remaining clauses (see Issue 907).         -- Andrea(s), 2014-12-05:  We return 'MissingClauses' here, since this         -- is the most conservative reason.-        [] -> rewrite (NotBlocked MissingClauses ()) (applyE v) rewr es+        [] -> do+          f <- fromMaybe __IMPOSSIBLE__ <$> asksTC envAppDef+          rewrite (NotBlocked (MissingClauses f) ()) (applyE v) rewr es         cl : cls -> do           let pats = namedClausePats cl               body = clauseBody cl@@ -840,9 +935,10 @@   reduce' (UnquoteTactic t h g) = UnquoteTactic <$> reduce' t <*> reduce' h <*> reduce' g   reduce' (CheckLockedVars a b c d) =     CheckLockedVars <$> reduce' a <*> reduce' b <*> reduce' c <*> reduce' d+  reduce' (CheckDataSort q s)   = CheckDataSort q <$> reduce' s   reduce' c@CheckMetaInst{}     = return c   reduce' (CheckType t)         = CheckType <$> reduce' t-  reduce' (UsableAtModality mod t) = UsableAtModality mod <$> reduce' t+  reduce' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> reduce' ms <*> reduce' t  instance Reduce CompareAs where   reduce' (AsTermsOf a) = AsTermsOf <$> reduce' a@@ -919,9 +1015,9 @@       Def f vs   -> iapp vs $ do         let keepGoing simp v = return (simp, notBlocked v)         (simpl, v) <- unfoldDefinition' False keepGoing (Def f []) f vs-        traceSDoc "tc.simplify'" 90 (-          text ("simplify': unfolding definition returns " ++ show simpl)-            <+> pretty (ignoreBlocking v)) $ do+        when (simpl == YesSimplification) $+          reportSDoc "tc.simplify'" 90 $+            pretty f <+> text ("simplify': unfolding definition returns " ++ show simpl) <+> pretty (ignoreBlocking v)         case simpl of           YesSimplification -> simplifyBlocked' v -- Dangerous, but if @simpl@ then @v /= Def f vs@           NoSimplification  -> Def f <$> simplify' vs@@ -955,6 +1051,7 @@         SSet s     -> SSet <$> simplify' s         SizeUniv   -> return s         LockUniv   -> return s+        IntervalUniv -> return s         MetaS x es -> MetaS x <$> simplify' es         DefS d es  -> DefS d <$> simplify' es         DummyS{}   -> return s@@ -1005,9 +1102,10 @@   simplify' (UnquoteTactic t h g) = UnquoteTactic <$> simplify' t <*> simplify' h <*> simplify' g   simplify' (CheckLockedVars a b c d) =     CheckLockedVars <$> simplify' a <*> simplify' b <*> simplify' c <*> simplify' d+  simplify' (CheckDataSort q s)   = CheckDataSort q <$> simplify' s   simplify' c@CheckMetaInst{}     = return c   simplify' (CheckType t)         = CheckType <$> simplify' t-  simplify' (UsableAtModality mod t) = UsableAtModality mod <$> simplify' t+  simplify' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> simplify' ms <*> simplify' t  instance Simplify CompareAs where   simplify' (AsTermsOf a) = AsTermsOf <$> simplify' a@@ -1104,6 +1202,7 @@         SSet s     -> SSet <$> normalise' s         SizeUniv   -> return SizeUniv         LockUniv   -> return LockUniv+        IntervalUniv -> return IntervalUniv         MetaS x es -> return s         DefS d es  -> return s         DummyS{}   -> return s@@ -1185,9 +1284,10 @@   normalise' (UnquoteTactic t h g) = UnquoteTactic <$> normalise' t <*> normalise' h <*> normalise' g   normalise' (CheckLockedVars a b c d) =     CheckLockedVars <$> normalise' a <*> normalise' b <*> normalise' c <*> normalise' d+  normalise' (CheckDataSort q s)   = CheckDataSort q <$> normalise' s   normalise' c@CheckMetaInst{}     = return c   normalise' (CheckType t)         = CheckType <$> normalise' t-  normalise' (UsableAtModality mod t) = UsableAtModality mod <$> normalise' t+  normalise' (UsableAtModality cc ms mod t) = flip (UsableAtModality cc) mod <$> normalise' ms <*> normalise' t  instance Normalise CompareAs where   normalise' (AsTermsOf a) = AsTermsOf <$> normalise' a@@ -1311,6 +1411,7 @@             Inf _ _    -> return s             SizeUniv   -> return s             LockUniv   -> return s+            IntervalUniv -> return s             MetaS x es -> MetaS x <$> instantiateFull' es             DefS d es  -> DefS d <$> instantiateFull' es             DummyS{}   -> return s@@ -1346,13 +1447,13 @@ instance InstantiateFull Substitution where   instantiateFull' sigma =     case sigma of-      IdS                  -> return IdS-      EmptyS err           -> return $ EmptyS err-      Wk   n sigma         -> Wk   n         <$> instantiateFull' sigma-      Lift n sigma         -> Lift n         <$> instantiateFull' sigma-      Strengthen bot sigma -> Strengthen bot <$> instantiateFull' sigma-      t :# sigma           -> consS <$> instantiateFull' t-                                    <*> instantiateFull' sigma+      IdS                    -> return IdS+      EmptyS err             -> return $ EmptyS err+      Wk   n sigma           -> Wk   n           <$> instantiateFull' sigma+      Lift n sigma           -> Lift n           <$> instantiateFull' sigma+      Strengthen bot n sigma -> Strengthen bot n <$> instantiateFull' sigma+      t :# sigma             -> consS <$> instantiateFull' t+                                      <*> instantiateFull' sigma  instance InstantiateFull ConPatternInfo where     instantiateFull' i = instantiateFull' (conPType i) <&> \ t -> i { conPType = t }@@ -1371,7 +1472,7 @@     instantiateFull' (NoAbs x a) = NoAbs x <$> instantiateFull' a  instance (InstantiateFull t, InstantiateFull e) => InstantiateFull (Dom' t e) where-    instantiateFull' (Dom i fin n tac x) = Dom i fin n <$> instantiateFull' tac <*> instantiateFull' x+    instantiateFull' (Dom i n b tac x) = Dom i n b <$> instantiateFull' tac <*> instantiateFull' x  -- Andreas, 2021-09-13, issue #5544, need to traverse @checkpoints@ map instance InstantiateFull t => InstantiateFull (Open t) where@@ -1418,9 +1519,10 @@     UnquoteTactic t g h -> UnquoteTactic <$> instantiateFull' t <*> instantiateFull' g <*> instantiateFull' h     CheckLockedVars a b c d ->       CheckLockedVars <$> instantiateFull' a <*> instantiateFull' b <*> instantiateFull' c <*> instantiateFull' d+    CheckDataSort q s   -> CheckDataSort q <$> instantiateFull' s     c@CheckMetaInst{}   -> return c     CheckType t         -> CheckType <$> instantiateFull' t-    UsableAtModality mod t -> UsableAtModality mod <$> instantiateFull' t+    UsableAtModality cc ms mod t -> flip (UsableAtModality cc) mod <$> instantiateFull' ms <*> instantiateFull' t  instance InstantiateFull CompareAs where   instantiateFull' (AsTermsOf a) = AsTermsOf <$> instantiateFull' a@@ -1459,9 +1561,11 @@ instance InstantiateFull NLPSort where   instantiateFull' (PType x) = PType <$> instantiateFull' x   instantiateFull' (PProp x) = PProp <$> instantiateFull' x+  instantiateFull' (PSSet x) = PSSet <$> instantiateFull' x   instantiateFull' (PInf f n) = return $ PInf f n   instantiateFull' PSizeUniv = return PSizeUniv   instantiateFull' PLockUniv = return PLockUniv+  instantiateFull' PIntervalUniv = return PIntervalUniv  instance InstantiateFull RewriteRule where   instantiateFull' (RewriteRule q gamma f ps rhs t c) =@@ -1535,7 +1639,7 @@   instantiateFull' (Case n bs) = Case n <$> instantiateFull' bs  instance InstantiateFull Clause where-    instantiateFull' (Clause rl rf tel ps b t catchall exact recursive unreachable ell) =+    instantiateFull' (Clause rl rf tel ps b t catchall exact recursive unreachable ell wm) =        Clause rl rf <$> instantiateFull' tel        <*> instantiateFull' ps        <*> instantiateFull' b@@ -1545,7 +1649,24 @@        <*> return recursive        <*> return unreachable        <*> return ell+       <*> return wm +instance InstantiateFull Instantiation where+  instantiateFull' (Instantiation a b) =+    Instantiation a <$> instantiateFull' b++instance InstantiateFull (Judgement MetaId) where+  instantiateFull' (HasType a b c) =+    HasType a b <$> instantiateFull' c+  instantiateFull' (IsSort a b) =+    IsSort a <$> instantiateFull' b++instance InstantiateFull RemoteMetaVariable where+  instantiateFull' (RemoteMetaVariable a b c) = RemoteMetaVariable+    <$> instantiateFull' a+    <*> return b+    <*> instantiateFull' c+ instance InstantiateFull Interface where   instantiateFull' i = do     defs <- instantiateFull' (i ^. intSignature . sigDefinitions)@@ -1556,16 +1677,17 @@  instantiateFullExceptForDefinitions' :: Interface -> ReduceM Interface instantiateFullExceptForDefinitions'-  (Interface h s ft ms mod scope inside sig display userwarn importwarn-     b foreignCode highlighting libPragmas filePragmas usedOpts patsyns-     warnings partialdefs) =-  Interface h s ft ms mod scope inside+  (Interface h s ft ms mod tlmod scope inside sig metas display userwarn+     importwarn b foreignCode highlighting libPragmas filePragmas+     usedOpts patsyns warnings partialdefs) =+  Interface h s ft ms mod tlmod scope inside     <$> ((\s r -> Sig { _sigSections     = s                       , _sigDefinitions  = sig ^. sigDefinitions                       , _sigRewriteRules = r                       })          <$> instantiateFull' (sig ^. sigSections)          <*> instantiateFull' (sig ^. sigRewriteRules))+    <*> instantiateFull' metas     <*> instantiateFull' display     <*> return userwarn     <*> return importwarn@@ -1589,6 +1711,7 @@ instance InstantiateFull a => InstantiateFull (Builtin a) where     instantiateFull' (Builtin t) = Builtin <$> instantiateFull' t     instantiateFull' (Prim x)   = Prim <$> instantiateFull' x+    instantiateFull' b@(BuiltinRewriteRelations xs) = pure b  instance InstantiateFull Candidate where   instantiateFull' (Candidate q u t ov) =
src/full/Agda/TypeChecking/Reduce/Fast.hs view
@@ -35,13 +35,16 @@ module Agda.TypeChecking.Reduce.Fast   ( fastReduce, fastNormalise ) where +import Prelude hiding ((!!))+ import Control.Applicative hiding (empty) import Control.Monad.ST import Control.Monad.ST.Unsafe (unsafeSTToIO, unsafeInterleaveST) +import qualified Data.HashMap.Strict as HMap import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as MapS import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Semigroup ((<>))@@ -138,7 +141,7 @@       Constructor{conSrcCon = c, conArity = n} -> pure CCon{cconSrcCon = c, cconArity = n}       Function{funCompiled = Just cc, funClauses = _:_, funProjection = proj} ->         pure CFun{ cfunCompiled   = fastCompiledClauses bEnv cc-                 , cfunProjection = projOrig <$> proj }+                 , cfunProjection = projOrig <$> either (const Nothing) Just proj }       Function{funClauses = []}      -> pure CAxiom       Function{}                     -> pure COther -- Incomplete definition       Datatype{dataClause = Nothing} -> pure CTyCon@@ -181,7 +184,7 @@           "primFloatIsDenormalized"    -> mkPrim 1 $ floatPred isDenormalized           "primFloatIsNegativeZero"    -> mkPrim 1 $ floatPred isNegativeZero           "primFloatIsSafeInteger"     -> mkPrim 1 $ floatPred isSafeInteger-          "primFloatToWord64"          -> mkPrim 1 $ \ [LitFloat a] -> word (doubleToWord64 a)+          -- "primFloatToWord64"          -- returns a maybe           -- "primFloatToWord64Injective" -- identities are not literals           "primNatToFloat"             -> mkPrim 1 $ \ [LitNat a] -> float (fromIntegral a)           -- "primIntToFloat"             -- integers are not literals@@ -804,11 +807,15 @@     compileAndRun . traceDoc "-- fast reduce --"   where     -- Helpers to get information from the ReduceEnv.-    metaStore      = redSt rEnv ^. stMetaStore+    localMetas     = redSt rEnv ^. stSolvedMetaStore+    remoteMetas    = redSt rEnv ^. stImportedMetaStore     -- Are we currently instance searching. In that case we don't fail hard on missing clauses. This     -- is a (very unsatisfactory) work-around for #3870.     speculative    = redSt rEnv ^. stConsideringInstance-    getMeta m      = maybe __IMPOSSIBLE__ mvInstantiation (IntMap.lookup (metaId m) metaStore)+    getMetaInst m  = case MapS.lookup m localMetas of+                       Just mv -> Just (mvInstantiation mv)+                       Nothing -> InstV . rmvInstantiation <$>+                                    HMap.lookup m remoteMetas     partialDefs    = runReduce getPartialDefs     rewriteRules f = cdefRewriteRules (constInfo f)     callByNeed     = envCallByNeed (redEnv rEnv) && not (optCallByName $ redSt rEnv ^. stPragmaOptions)@@ -860,7 +867,7 @@     --  - Look up in the environment if variable     --  - Perform a beta step if lambda and application elimination in the spine     --  - Perform a record beta step if record constructor and projection elimination in the spine-    runAM' s@(Eval cl@(Closure Unevaled t env spine) !ctrl) = {-# SCC "runAM.Eval" #-}+    runAM' s@(Eval cl@(Closure Unevaled t env spine) ctrl) = {-# SCC "runAM.Eval" #-}       case t of          -- Case: definition. Enter 'Match' state if defined function or shift to evaluating an@@ -959,12 +966,17 @@         -- environment for the closure. Avoiding shifting spines for open metas         -- save a bit of performance.         MetaV m es -> evalIApplyAM spine ctrl $-          case getMeta m of-            InstV xs t -> do+          case getMetaInst m of+            Nothing ->+              runAM (Eval (mkValue (blocked m ()) cl) ctrl)+            Just (InstV i) -> do               spine' <- elimsToSpine env es-              let (zs, env, !spine'') = buildEnv xs (spine' <> spine)-              runAM (evalClosure (lams zs t) env spine'' ctrl)-            _ -> runAM (Eval (mkValue (blocked m ()) cl) ctrl)+              let (zs, env, !spine'') = buildEnv (instTel i) (spine' <> spine)+              runAM (evalClosure (lams zs (instBody i)) env spine'' ctrl)+            Just Open{}                         -> __IMPOSSIBLE__+            Just OpenInstance{}                 -> __IMPOSSIBLE__+            Just BlockedConst{}                 -> __IMPOSSIBLE__+            Just PostponedTypeCheckingProblem{} -> __IMPOSSIBLE__          -- Case: unsupported. These terms are not handled by the abstract machine, so we fall back         -- to slowReduceTerm for these.@@ -1251,7 +1263,7 @@             (spine0, Proj o p : spine1) ->               case lookupCon p bs <|> ((`lookupCon` bs) =<< op) of                 Nothing-                  | f `elem` partialDefs -> stuckMatch (NotBlocked MissingClauses ()) stack ctrl+                  | f `elem` partialDefs -> stuckMatch (NotBlocked (MissingClauses f) ()) stack ctrl                   | otherwise          -> __IMPOSSIBLE__                 Just cc -> runAM (Match f cc (spine0 <> spine1) stack ctrl)               where CFun{ cfunProjection = op } = cdefDef (constInfo p)@@ -1374,8 +1386,8 @@     failedMatch f (CatchAll cc spine : stack :> cl) ctrl = runAM (Match f cc spine (stack :> cl) ctrl)     failedMatch f ([] :> cl) ctrl         -- Bad work-around for #3870: don't fail hard during instance search.-      | speculative          = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl)-      | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked MissingClauses ()) cl) ctrl)+      | speculative          = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)+      | f `elem` partialDefs = rewriteAM (Eval (mkValue (NotBlocked (MissingClauses f) ()) cl) ctrl)       | hasRewriting         = rewriteAM (Eval (mkValue (NotBlocked ReallyNotBlocked ()) cl) ctrl)  -- See #5396       | otherwise            = runReduce $           traceSLn "impossible" 10 ("Incomplete pattern matching when applying " ++ prettyShow f)
src/full/Agda/TypeChecking/Reduce/Monad.hs view
@@ -18,18 +18,20 @@ import System.IO.Unsafe  import Agda.Syntax.Internal-import Agda.TypeChecking.Monad hiding-  ( enterClosure, isInstantiatedMeta, verboseS, typeOfConst, lookupMeta, lookupMeta', constructorForm )+import Agda.TypeChecking.Monad hiding (enterClosure, constructorForm) import Agda.TypeChecking.Substitute  import Agda.Utils.Lens+import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Pretty () --instance only   instance HasBuiltins ReduceM where-  getBuiltinThing b = liftM2 mplus (Map.lookup b <$> useR stLocalBuiltins)-                                   (Map.lookup b <$> useR stImportedBuiltins)+  getBuiltinThing b =+    liftM2 (unionMaybeWith unionBuiltin)+      (Map.lookup b <$> useR stLocalBuiltins)+      (Map.lookup b <$> useR stImportedBuiltins)  constructorForm :: HasBuiltins m => Term -> m Term constructorForm v = do@@ -72,13 +74,13 @@ instance MonadDebug ReduceM where    traceDebugMessage k n s cont = do-    ReduceEnv env st <- askR+    ReduceEnv env st _ <- askR     unsafePerformIO $ do       _ <- runTCM env st $ displayDebugMessage k n s       return $ cont    formatDebugMessage k n d = do-    ReduceEnv env st <- askR+    ReduceEnv env st _ <- askR     unsafePerformIO $ do       (s , _) <- runTCM env st $ formatDebugMessage k n d       return $ return s@@ -86,14 +88,15 @@   verboseBracket k n s = applyWhenVerboseS k n $     bracket_ (openVerboseBracket k n s) (const $ closeVerboseBracket k n) -  getVerbosity     = defaultGetVerbosity-  isDebugPrinting  = defaultIsDebugPrinting-  nowDebugPrinting = defaultNowDebugPrinting+  getVerbosity      = defaultGetVerbosity+  getProfileOptions = defaultGetProfileOptions+  isDebugPrinting   = defaultIsDebugPrinting+  nowDebugPrinting  = defaultNowDebugPrinting  instance HasConstInfo ReduceM where   getRewriteRulesFor = defaultGetRewriteRulesFor   getConstInfo' q = do-    ReduceEnv env st <- askR+    ReduceEnv env st _ <- askR     defaultGetConstInfo st env q  instance PureTCM ReduceM where
src/full/Agda/TypeChecking/Rewriting.hs view
@@ -48,9 +48,12 @@  import Control.Monad +import Data.Foldable (toList) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List+import Data.Set (Set)+import qualified Data.Set as Set  import Agda.Interaction.Options @@ -83,6 +86,7 @@ import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible+import Agda.Utils.Either  requireOptionRewriting :: TCM () requireOptionRewriting =@@ -152,6 +156,9 @@   -- Run confluence check for the new rules   -- (should be done after adding all rules, see #3795)   whenJustM (optConfluenceCheck <$> pragmaOptions) $ \confChk -> do+    -- Warn if --cubical is enabled+    whenJustM (optCubical <$> pragmaOptions) $ \_ -> genericWarning+      "Confluence checking for --cubical is not yet supported, confluence checking might be incomplete"     -- Global confluence checker requires rules to be sorted     -- according to the generality of their lhs     when (confChk == GlobalConfluenceCheck) $@@ -160,6 +167,19 @@     reportSDoc "rewriting" 10 $       "done checking confluence of rules" <+> prettyList_ (map (prettyTCM . rewName) rews) +-- Auxiliary function for checkRewriteRule.+-- | Get domain of rewrite relation.+rewriteRelationDom :: QName -> TCM (ListTel, Dom Type)+rewriteRelationDom rel = do+  -- We know that the type of rel is that of a relation.+  relV <- relView =<< do defType <$> getConstInfo rel+  let RelView _tel delta a _a' _core = fromMaybe __IMPOSSIBLE__ relV+  reportSDoc "rewriting" 30 $ do+    "rewrite relation at type " <+> do+      inTopContext $ prettyTCM (telFromList delta) <+> " |- " <+> do+        addContext delta $ prettyTCM a+  return (delta, a)+ -- | Check the validity of @q : Γ → rel us lhs rhs@ as rewrite rule --   @ --       Γ ⊢ lhs ↦ rhs : B@@ -173,7 +193,11 @@   requireOptionRewriting   let failNoBuiltin = typeError $ GenericError $         "Cannot add rewrite rule without prior BUILTIN REWRITE"-  rel <- fromMaybeM failNoBuiltin $ getBuiltinName builtinRewrite+  rels <- fromMaybeM failNoBuiltin getBuiltinRewriteRelations+  reportSDoc "rewriting.relations" 40 $ vcat+    [ "Rewrite relations:"+    , prettyList $ map prettyTCM $ toList rels+    ]   def <- instantiateDef =<< getConstInfo q   -- Issue 1651: Check that we are not adding a rewrite rule   -- for a type signature whose body has not been type-checked yet.@@ -183,13 +207,6 @@       , prettyTCM q       , " cannot be added before the function definition"       ]-  -- We know that the type of rel is that of a relation.-  relV <- relView =<< do defType <$> getConstInfo rel-  let RelView _tel delta a _a' _core = fromMaybe __IMPOSSIBLE__ relV-  reportSDoc "rewriting" 30 $ do-    "rewrite relation at type " <+> do-      inTopContext $ prettyTCM (telFromList delta) <+> " |- " <+> do-        addContext delta $ prettyTCM a   -- Get rewrite rule (type of q).   TelV gamma1 core <- telView $ defType def   reportSDoc "rewriting" 30 $ vcat@@ -200,22 +217,38 @@   let failureWrongTarget :: TCM a       failureWrongTarget = typeError . GenericDocError =<< hsep         [ prettyTCM q , " does not target rewrite relation" ]-  let failureMetas :: TCM a-      failureMetas       = typeError . GenericDocError =<< hsep-        [ prettyTCM q , " is not a legal rewrite rule, since it contains unsolved meta variables" ]+  let failureBlocked :: Blocker -> TCM a+      failureBlocked b+        | not (null ms) = err $ "it contains the unsolved meta variable(s)" <+> prettyList_ (map prettyTCM $ Set.toList ms)+        | not (null ps) = err $ "it is blocked on problem(s)" <+> prettyList_ (map prettyTCM $ Set.toList ps)+        | not (null qs) = err $ "it requires the definition(s) of" <+> prettyList_ (map prettyTCM $ Set.toList qs)+        | otherwise = __IMPOSSIBLE__+        where+          err reason = typeError . GenericDocError =<< hsep+            [ prettyTCM q , " is not a legal rewrite rule, since" , reason ]+          ms = allBlockingMetas b+          ps = allBlockingProblems b+          qs = allBlockingDefs b   let failureNotDefOrCon :: TCM a       failureNotDefOrCon = typeError . GenericDocError =<< hsep         [ prettyTCM q , " is not a legal rewrite rule, since the left-hand side is neither a defined symbol nor a constructor" ]   let failureFreeVars :: IntSet -> TCM a       failureFreeVars xs = typeError . GenericDocError =<< hsep         [ prettyTCM q , " is not a legal rewrite rule, since the following variables are not bound by the left hand side: " , prettyList_ (map (prettyTCM . var) $ IntSet.toList xs) ]+  let failureNonLinearPars :: IntSet -> TCM a+      failureNonLinearPars xs = typeError . GenericDocError =<< do+        (prettyTCM q+          <+> " is not a legal rewrite rule, since the following parameters are bound more than once on the left hand side: "+          <+> hsep (List.intersperse "," $ map (prettyTCM . var) $ IntSet.toList xs))+          <> ". Perhaps you can use a postulate instead of a constructor as the head symbol?"   let failureIllegalRule :: TCM a -- TODO:: Defined but not used       failureIllegalRule = typeError . GenericDocError =<< hsep         [ prettyTCM q , " is not a legal rewrite rule" ]    -- Check that type of q targets rel.   case unEl core of-    Def rel' es@(_:_:_) | rel == rel' -> do+    Def rel es@(_:_:_) | rel `elem` rels -> do+      (delta, a) <- rewriteRelationDom rel       -- Because of the type of rel (Γ → sort), all es are applications.       let vs = map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es       -- The last two arguments are lhs and rhs.@@ -230,10 +263,6 @@       gamma1 <- instantiateFull gamma1       let gamma = gamma0 `abstract` gamma1 -      unless (noMetas (telToList gamma1)) $ do-        reportSDoc "rewriting" 30 $ "metas in gamma1: " <+> text (show $ allMetasList $ telToList gamma1)-        failureMetas-       -- 2017-06-18, Jesper: Unfold inlined definitions on the LHS.       -- This is necessary to replace copies created by imports by their       -- original definition.@@ -258,13 +287,9 @@          checkNoLhsReduction f hd es -        unless (noMetas (es, rhs, b)) $ do-          reportSDoc "rewriting" 30 $ "metas in lhs: " <+> text (show $ allMetasList es)-          reportSDoc "rewriting" 30 $ "metas in rhs: " <+> text (show $ allMetasList rhs)-          reportSDoc "rewriting" 30 $ "metas in b  : " <+> text (show $ allMetasList b)-          failureMetas+        ps <- catchPatternErr failureBlocked $+          patternFrom Relevant 0 (t , Def f []) es -        ps <- patternFrom Relevant 0 (t , Def f []) es         reportSDoc "rewriting" 30 $           "Pattern generated from lhs: " <+> prettyTCM (PDef f ps) @@ -295,6 +320,10 @@         unlessNull (freeVars IntSet.\\ boundVars) failureFreeVars         unlessNull (usedVars IntSet.\\ (boundVars `IntSet.union` IntSet.fromList pars)) failureFreeVars +        reportSDoc "rewriting" 70 $+          "variables bound in (erased) parameter position: " <+> text (show pars)+        unlessNull (boundVars `IntSet.intersection` IntSet.fromList pars) failureNonLinearPars+         let rew = RewriteRule q gamma f ps rhs (unDom b) False          reportSDoc "rewriting" 10 $ vcat@@ -335,7 +364,20 @@     checkAxFunOrCon :: QName -> Definition -> TCM ()     checkAxFunOrCon f def = case theDef def of       Axiom{}        -> return ()-      Function{}     -> return ()+      def@Function{} -> whenJust (maybeRight (funProjection def)) $ \proj ->+        case projProper proj of+          Just{} -> typeError . GenericDocError =<< hsep+            [ prettyTCM q , " is not a legal rewrite rule, since the head symbol"+            , prettyTCM f , "is a projection"+            ]+          Nothing -> typeError . GenericDocError =<< hsep+            [ prettyTCM q , " is not a legal rewrite rule, since the head symbol"+            , hd , "is a projection-like function."+            , "You can turn off the projection-like optimization for", hd+            , "with the pragma {-# NOT_PROJECTION_LIKE", hd, "#-}"+            , "or globally with the flag --no-projection-like"+            ]+            where hd = prettyTCM f       Constructor{}  -> return ()       AbstractDefn{} -> return ()       Primitive{}    -> return () -- TODO: is this fine?
src/full/Agda/TypeChecking/Rewriting/Clause.hs view
@@ -5,6 +5,7 @@  import Agda.Syntax.Common import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern import Agda.Syntax.Position  import Agda.TypeChecking.Monad@@ -38,6 +39,7 @@ --   if @clauseBody cl@ is @Nothing@. Precondition: @clauseType cl@ is --   not @Nothing@. clauseToRewriteRule :: QName -> QName -> Clause -> Maybe RewriteRule+clauseToRewriteRule f q cl | hasDefP (namedClausePats cl) = Nothing clauseToRewriteRule f q cl = clauseBody cl <&> \rhs -> RewriteRule   { rewName    = q   , rewContext = clauseTel cl
src/full/Agda/TypeChecking/Rewriting/Confluence.hs view
@@ -98,6 +98,14 @@ checkConfluenceOfClauses :: ConfluenceCheck -> QName -> TCM () checkConfluenceOfClauses confChk f = do   rews <- getClausesAsRewriteRules f+  let noMetasInPats rew+        | noMetas (rewPats rew) = return True+        | otherwise             = do+            genericWarning =<< do+              text "Confluence checking incomplete because the definition of" <+>+                prettyTCM f <+> text "contains unsolved metavariables."+            return False+  rews <- filterM noMetasInPats rews   let matchables = map getMatchables rews   reportSDoc "rewriting.confluence" 30 $     "Function" <+> prettyTCM f <+> "has matchable symbols" <+> prettyList_ (map prettyTCM matchables)@@ -263,6 +271,11 @@             es0        = applySubst (liftS k sub1) $ ohElims hole0             qs2        = rewPats rew2 +        -- TODO: support IApply in forceEtaExpansion+        let isIApply IApply{} = True+            isIApply _        = False+        unless (any isIApply $ drop (size es0) qs2) $ do+         -- If the second rewrite rule has more eliminations than the         -- subpattern of the first rule, the only chance of overlap is         -- by eta-expanding the subpattern of the first rule.@@ -474,7 +487,7 @@   -- For record projections @f : R Δ → A@, we rely on the invariant   -- that any clause is fully general in the parameters, i.e. it   -- is quantified over the parameter telescope @Δ@-  Function { funProjection = Just proj } -> do+  Function { funProjection = Right proj } -> do     let f          = projOrig proj         r          = unArg $ projFromType proj     rtype <- defType <$> getConstInfo r@@ -604,7 +617,7 @@ instance ParallelReduce a => ParallelReduce (Elim' a) where   parReduce (Apply u)  = Apply <$> parReduce u   parReduce e@Proj{}   = pure e-  parReduce IApply{}   = __IMPOSSIBLE__ -- not yet supported+  parReduce e@IApply{} = pure e -- TODO  instance (Free a, Subst a, ParallelReduce a) => ParallelReduce (Abs a) where   parReduce = mapAbstraction __DUMMY_DOM__ parReduce@@ -625,11 +638,11 @@     ns <- forM ms' getMetaNameSuggestion      -- Construct telescope (still containing the metas)-    let gamma = unflattenTel ns $ map defaultDom as+    let n     = size ms'+        gamma = unflattenTel' n ns $ map defaultDom as      -- Replace metas by variables-    let n           = size ms'-        metaIndex x = (n-1-) <$> elemIndex x ms'+    let metaIndex x = (n-1-) <$> elemIndex x ms'     runReaderT (metasToVars (gamma, x)) metaIndex  -- ^ A @OneHole p@ is a @p@ with a subpattern @f ps@ singled out.@@ -788,7 +801,7 @@         let a' = c `absApp` hd []         hd' <- applyE <$> applyDef o f (argFromDom b $> hd [])         fmap (e:) <$> allHoles (a' , hd') es-      IApply x y u -> __IMPOSSIBLE__ -- Not yet implemented+      IApply x y u -> empty -- TODO: support --confluence-check + --cubical  instance AllHoles Type where   type PType Type = ()@@ -835,6 +848,7 @@     SSet l       -> fmap SSet <$> allHoles_ l     SizeUniv     -> empty     LockUniv     -> empty+    IntervalUniv -> empty     PiSort{}     -> __IMPOSSIBLE__     FunSort{}    -> __IMPOSSIBLE__     UnivSort{}   -> __IMPOSSIBLE__@@ -858,7 +872,7 @@ instance AllHoles PlusLevel where   type PType PlusLevel = ()   allHoles _ (Plus n l) = do-    la <- levelType+    la <- levelType'     fmap (Plus n) <$> allHoles la l  @@ -911,6 +925,7 @@     SSet l     -> SSet     <$> metasToVars l     SizeUniv   -> pure SizeUniv     LockUniv   -> pure LockUniv+    IntervalUniv -> pure IntervalUniv     PiSort s t u -> PiSort   <$> metasToVars s <*> metasToVars t <*> metasToVars u     FunSort s t -> FunSort <$> metasToVars s <*> metasToVars t     UnivSort s -> UnivSort <$> metasToVars s
src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs view
@@ -53,7 +53,7 @@ import Agda.TypeChecking.Reduce.Monad import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Primitive.Cubical.Base  import Agda.Utils.Either import Agda.Utils.Functor@@ -165,6 +165,8 @@      [ "matching elimination " <+> addContext (gamma `abstract` k) (prettyTCM p)      , "  with               " <+> addContext k (prettyTCM v)      , "  eliminating head   " <+> addContext k (prettyTCM $ hd []) <+> ":" <+> addContext k (prettyTCM t)]) $ do++   let no  = matchingBlocked $ NotBlocked ReallyNotBlocked ()    case (p,v) of     (Apply p, Apply v) -> (addContext k $ unEl <$> reduce t) >>= \case       Pi a b -> do@@ -186,19 +188,21 @@         ("interval application at non-pi type (possible non-confluence?) " <+> prettyTCM (pathUnview t)) mzero      (Proj o f, Proj o' f') | f == f' -> do-      ~(Just (El _ (Pi a b))) <- addContext k $ getDefType f =<< reduce t-      let u = hd []-          t' = b `absApp` u-      hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u)-      match r gamma k (t',hd') ps vs+      addContext k (getDefType f =<< reduce t) >>= \case+        Just (El _ (Pi a b)) -> do+          let u = hd []+              t' = b `absApp` u+          hd' <- addContext k $ applyE <$> applyDef o f (argFromDom a $> u)+          match r gamma k (t',hd') ps vs+        _ -> no      (Proj _ f, Proj _ f') | otherwise -> do       traceSDoc "rewriting.match" 20 (sep         [ "mismatch between projections " <+> prettyTCM f         , " and " <+> prettyTCM f' ]) mzero -    (Apply{}, Proj{} ) -> __IMPOSSIBLE__-    (Proj{} , Apply{}) -> __IMPOSSIBLE__+    (Apply{}, Proj{} ) -> no+    (Proj{} , Apply{}) -> no      (IApply{} , _    ) -> __IMPOSSIBLE__ -- TODO     (_ , IApply{}    ) -> __IMPOSSIBLE__ -- TODO@@ -224,10 +228,12 @@     case (p , s) of       (PType lp  , Type l  ) -> match r gamma k () lp l       (PProp lp  , Prop l  ) -> match r gamma k () lp l+      (PSSet lp  , SSet l  ) -> match r gamma k () lp l       (PInf fp np , Inf f n)         | fp == f, np == n   -> yes       (PSizeUniv , SizeUniv) -> yes       (PLockUniv , LockUniv) -> yes+      (PIntervalUniv , IntervalUniv) -> yes        -- blocked cases       (_ , UnivSort{}) -> matchingBlocked b@@ -254,6 +260,7 @@         prettyTerm = withShowAllArguments $ addContext k $ prettyTCM v         prettyType = withShowAllArguments $ addContext k $ prettyTCM t     etaRecord <- addContext k $ isEtaRecordType t+    pview <- pathViewAsPi'whnf     prop <- fromRight __IMPOSSIBLE__ <.> runBlocked . addContext k $ isPropM t     let r = if prop then Irrelevant else r0     traceSDoc "rewriting.match" 30 (sep@@ -315,8 +322,9 @@                 match r gamma k (ft , Def f) ps es           Con c ci vs             | f == conName c -> do-                ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-                match r gamma k (ct , Con c ci) ps vs+                addContext k (getFullyAppliedConType c t) >>= \case+                  Just (_ , ct) -> match r gamma k (ct , Con c ci) ps vs+                  Nothing -> no ""           _ | Pi a b <- unEl t -> do             let ai    = domInfo a                 pbody = PDef f $ raise 1 ps ++ [ Apply $ Arg ai $ PTerm $ var 0 ]@@ -329,21 +337,27 @@           -- the pattern (p = PDef f ps) to @c (p .f1) ... (p .fn)@.             def <- addContext k $ theDef <$> getConstInfo d             (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v-            ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-            let flds = map argFromDom $ recFields def-                mkField fld = PDef f (ps ++ [Proj ProjSystem fld])-                -- Issue #3335: when matching against the record constructor,-                -- don't add projections but take record field directly.-                ps'-                  | conName c == f = ps-                  | otherwise      = map (Apply . fmap mkField) flds-            match r gamma k (ct, Con c ci) ps' (map Apply vs)+            addContext k (getFullyAppliedConType c t) >>= \case+              Just (_ , ct) -> do+                let flds = map argFromDom $ recFields def+                    mkField fld = PDef f (ps ++ [Proj ProjSystem fld])+                    -- Issue #3335: when matching against the record constructor,+                    -- don't add projections but take record field directly.+                    ps'+                      | conName c == f = ps+                      | otherwise      = map (Apply . fmap mkField) flds+                match r gamma k (ct, Con c ci) ps' (map Apply vs)+              Nothing -> no ""           v -> maybeBlock v       PLam i p' -> case unEl t of         Pi a b -> do           let body = raise 1 v `apply` [Arg i (var 0)]               k'   = ExtendTel a (Abs (absName b) k)           match r gamma k' (absBody b) (absBody p') body+        _ | Left ((a,b),(x,y)) <- pview t -> do+          let body = raise 1 v `applyE` [ IApply (raise 1 x) (raise 1 y) $ var 0 ]+              k'   = ExtendTel a (Abs "i" k)+          match r gamma k' (absBody b) (absBody p') body         v -> maybeBlock v       PPi pa pb -> case v of         Pi a b -> do@@ -367,46 +381,19 @@         _ | Just (d, pars) <- etaRecord -> do           def <- addContext k $ theDef <$> getConstInfo d           (tel, c, ci, vs) <- addContext k $ etaExpandRecord_ d pars def v-          ~(Just (_ , ct)) <- addContext k $ getFullyAppliedConType c t-          let flds = map argFromDom $ recFields def-              ps'  = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds-          match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs)+          addContext k (getFullyAppliedConType c t) >>= \case+            Just (_ , ct) -> do+              let flds = map argFromDom $ recFields def+                  ps'  = map (fmap $ \fld -> PBoundVar i (ps ++ [Proj ProjSystem fld])) flds+              match r gamma k (ct, Con c ci) (map Apply ps') (map Apply vs)+            Nothing -> no ""         v -> maybeBlock v       PTerm u -> traceSDoc "rewriting.match" 60 ("matching a PTerm" <+> addContext (gamma `abstract` k) (prettyTCM u)) $         tellEq gamma k t u v --- Checks if the given term contains any free variables that satisfy the--- given condition on their DBI, possibly reducing the term in the process.--- Returns `Right Nothing` if there are such variables, `Right (Just v')`--- if there are none (where v' is the possibly reduced version of the given--- term) or `Left b` if the problem is blocked on a meta.-reallyFree :: (MonadReduce m, Reduce a, ForceNotFree a)-           => IntSet -> a -> m (Either Blocked_ (Maybe a))-reallyFree xs v = do-  (mxs , v') <- forceNotFree xs v-  case IntMap.foldr pickFree NotFree mxs of-    MaybeFree ms-      | null ms   -> return $ Right Nothing-      | otherwise -> return $ Left $ Blocked blocker ()-      where blocker = unblockOnAll $ foldrMetaSet (Set.insert . unblockOnMeta) Set.empty ms-    NotFree -> return $ Right (Just v')--  where-    -- Check if any of the variables occur freely.-    -- Prefer occurrences that do not depend on any metas.-    pickFree :: IsFree -> IsFree -> IsFree-    pickFree f1@(MaybeFree ms1) f2-      | null ms1  = f1-    pickFree f1@(MaybeFree ms1) f2@(MaybeFree ms2)-      | null ms2  = f2-      | otherwise = f1-    pickFree f1@(MaybeFree ms1) NotFree = f1-    pickFree NotFree f2 = f2---makeSubstitution :: Telescope -> Sub -> Substitution+makeSubstitution :: Telescope -> Sub -> Maybe Substitution makeSubstitution gamma sub =-  parallelS $ map (fromMaybe __DUMMY_TERM__ . val) [0 .. size gamma-1]+  parallelS <$> traverse val [0 .. size gamma-1]     where       val i = case IntMap.lookup i sub of                 Just (Irrelevant, v) -> Just $ dontCare v@@ -431,13 +418,15 @@                    [ "matching failed during" <+> text msg                    , "blocking: " <+> text (show b) ]) $ return (Left b)   caseEitherM (runNLM $ match Relevant gamma EmptyTel t p v) (no "matching") $ \ s -> do-    let sub = makeSubstitution gamma $ s^.nlmSub+    let msub = makeSubstitution gamma $ s^.nlmSub         eqs = s^.nlmEqs-    traceSDoc "rewriting.match" 90 (text $ "sub = " ++ show sub) $ do-    ok <- checkPostponedEquations sub eqs-    case ok of-      Nothing -> return $ Right sub-      Just b  -> no "checking of postponed equations" b+    traceSDoc "rewriting.match" 90 (text $ "msub = " ++ show msub) $ case msub of+      Nothing -> no "checking that all variables are bound" notBlocked_+      Just sub -> do+        ok <- checkPostponedEquations sub eqs+        case ok of+          Nothing -> return $ Right sub+          Just b  -> no "checking of postponed equations" b  -- | Typed βη-equality, also handles empty record types. --   Returns `Nothing` if the terms are equal, or `Just b` if the terms are not@@ -463,9 +452,11 @@     vs <- freeVarsToApply c     -- Jesper, 2020-06-17, issue #4755: add dummy arguments in     -- case we don't have enough parameters-    npars <- fromMaybe __IMPOSSIBLE__ <$> getNumberOfParameters c-    let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__-    t0 <- defType <$> getConstInfo c-    t <- t0 `piApplyM` (vs ++ ws)-    return $ Just (c , t)+    getNumberOfParameters c >>= \case+      Just npars -> do+        let ws = replicate (npars - size vs) $ defaultArg __DUMMY_TERM__+        t0 <- defType <$> getConstInfo c+        t <- t0 `piApplyM` (vs ++ ws)+        return $ Just (c , t)+      Nothing -> return Nothing   _ -> return Nothing
src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs view
@@ -6,6 +6,8 @@  module Agda.TypeChecking.Rewriting.NonLinPattern where +import Prelude hiding ( null )+ import Control.Monad        ( (>=>), forM ) import Control.Monad.Reader ( asks ) @@ -15,6 +17,7 @@ import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Defs+import Agda.Syntax.Internal.MetaVars ( AllMetas, unblockOnAllMetasIn )  import Agda.TypeChecking.Datatypes import Agda.TypeChecking.Free@@ -27,7 +30,7 @@ import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope-import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Primitive.Cubical.Base  import Agda.Utils.Either import Agda.Utils.Functor@@ -57,14 +60,14 @@   patternFrom r k (t,hd) = \case     [] -> return []     (Apply u : es) -> do-      ~(Pi a b) <- unEl <$> reduce t+      (a, b) <- assertPi t       p   <- patternFrom r k a u-      t'  <- t `piApplyM` u+      let t'  = absApp b (unArg u)       let hd' = hd `apply` [ u ]       ps  <- patternFrom r k (t',hd') es       return $ Apply p : ps     (IApply x y i : es) -> do-      ~(PathType s q l b u v) <- pathView =<< reduce t+      (s, q, l, b, u, v) <- assertPath t       let t' = El s $ unArg b `apply` [ defaultArg i ]       let hd' = hd `applyE` [IApply x y i]       interval <- primIntervalType@@ -72,7 +75,7 @@       ps  <- patternFrom r k (t',hd') es       return $ IApply (PTerm x) (PTerm y) p : ps     (Proj o f : es) -> do-      ~(Just (El _ (Pi a b))) <- getDefType f =<< reduce t+      (a,b) <- assertProjOf f t       let t' = b `absApp` hd       hd' <- applyDef o f (argFromDom a $> hd)       ps  <- patternFrom r k (t',hd') es@@ -88,14 +91,15 @@  instance PatternFrom () Sort NLPSort where   patternFrom r k _ s = do-    s <- reduce s+    s <- abortIfBlocked s     case s of       Type l   -> PType <$> patternFrom r k () l       Prop l   -> PProp <$> patternFrom r k () l+      SSet l   -> PSSet <$> patternFrom r k () l       Inf f n  -> return $ PInf f n-      SSet l   -> __IMPOSSIBLE__       SizeUniv -> return PSizeUniv       LockUniv -> return PLockUniv+      IntervalUniv -> return PIntervalUniv       PiSort _ _ _ -> __IMPOSSIBLE__       FunSort _ _ -> __IMPOSSIBLE__       UnivSort _ -> __IMPOSSIBLE__@@ -116,21 +120,26 @@  instance PatternFrom Type Term NLPat where   patternFrom r0 k t v = do-    t <- reduce t+    t <- abortIfBlocked t     etaRecord <- isEtaRecordType t-    prop <- fromRight __IMPOSSIBLE__ <.> runBlocked $ isPropM t+    prop <- isPropM t     let r = if prop then Irrelevant else r0-    v <- unLevel =<< reduce v+    v <- unLevel =<< abortIfBlocked v     reportSDoc "rewriting.build" 60 $ sep       [ "building a pattern from term v = " <+> prettyTCM v       , " of type " <+> prettyTCM t       ]-    let done = return $ PTerm v+    pview <- pathViewAsPi'whnf+    let done = blockOnMetasIn v >> return (PTerm v)     case (unEl t , stripDontCare v) of       (Pi a b , _) -> do         let body = raise 1 v `apply` [ Arg (domInfo a) $ var 0 ]         p <- addContext a (patternFrom r (k+1) (absBody b) body)         return $ PLam (domInfo a) $ Abs (absName b) p+      _ | Left ((a,b),(x,y)) <- pview t -> do+        let body = raise 1 v `applyE` [ IApply (raise 1 $ x) (raise 1 $ y) $ var 0 ]+        p <- addContext a (patternFrom r (k+1) (absBody b) body)+        return $ PLam (domInfo a) $ Abs (absName b) p       (_ , Var i es)        | i < k     -> do            t <- typeOfBV i@@ -138,10 +147,11 @@        -- The arguments of `var i` should be distinct bound variables        -- in order to build a Miller pattern        | Just vs <- allApplyElims es -> do-           TelV tel _ <- telView =<< typeOfBV i-           unless (size tel >= size vs) __IMPOSSIBLE__+           TelV tel rest <- telViewPath =<< typeOfBV i+           unless (size tel >= size vs) $ blockOnMetasIn rest >> addContext tel (errNotPi rest)            let ts = applySubst (parallelS $ reverse $ map unArg vs) $ map unDom $ flattenTel tel            mbvs <- forM (zip ts vs) $ \(t , v) -> do+             blockOnMetasIn (v,t)              isEtaVar (unArg v) t >>= \case                Just j | j < k -> return $ Just $ v $> j                _              -> return Nothing@@ -156,9 +166,9 @@       (_ , _ ) | Just (d, pars) <- etaRecord -> do         def <- theDef <$> getConstInfo d         (tel, c, ci, vs) <- etaExpandRecord_ d pars def v-        caseMaybeM (getFullyAppliedConType c t) __IMPOSSIBLE__ $ \ (_ , ct) -> do+        ct <- assertConOf c t         PDef (conName c) <$> patternFrom r k (ct , Con c ci []) (map Apply vs)-      (_ , Lam i t) -> __IMPOSSIBLE__+      (_ , Lam{})   -> errNotPi t       (_ , Lit{})   -> done       (_ , Def f es) | isIrrelevant r -> done       (_ , Def f es) -> do@@ -171,8 +181,8 @@             ft <- defType <$> getConstInfo f             PDef f <$> patternFrom r k (ft , Def f []) es       (_ , Con c ci vs) | isIrrelevant r -> done-      (_ , Con c ci vs) ->-        caseMaybeM (getFullyAppliedConType c t) __IMPOSSIBLE__ $ \ (_ , ct) -> do+      (_ , Con c ci vs) -> do+        ct <- assertConOf c t         PDef (conName c) <$> patternFrom r k (ct , Con c ci []) vs       (_ , Pi a b) | isIrrelevant r -> done       (_ , Pi a b) -> do@@ -182,7 +192,7 @@       (_ , Sort s)     -> PSort <$> patternFrom r k () s       (_ , Level l)    -> __IMPOSSIBLE__       (_ , DontCare{}) -> __IMPOSSIBLE__-      (_ , MetaV{})    -> __IMPOSSIBLE__+      (_ , MetaV m _)  -> __IMPOSSIBLE__       (_ , Dummy s _)  -> __IMPOSSIBLE_VERBOSE__ s  -- | Convert from a non-linear pattern to a term.@@ -226,9 +236,11 @@ instance NLPatToTerm NLPSort Sort where   nlPatToTerm (PType l) = Type <$> nlPatToTerm l   nlPatToTerm (PProp l) = Prop <$> nlPatToTerm l+  nlPatToTerm (PSSet l) = SSet <$> nlPatToTerm l   nlPatToTerm (PInf f n) = return $ Inf f n   nlPatToTerm PSizeUniv = return SizeUniv   nlPatToTerm PLockUniv = return LockUniv+  nlPatToTerm PIntervalUniv = return IntervalUniv  -- | Gather the set of pattern variables of a non-linear pattern class NLPatVars a where@@ -247,9 +259,11 @@   nlPatVarsUnder k = \case     PType l   -> nlPatVarsUnder k l     PProp l   -> nlPatVarsUnder k l+    PSSet l   -> nlPatVarsUnder k l     PInf f n  -> empty     PSizeUniv -> empty     PLockUniv -> empty+    PIntervalUniv -> empty  instance NLPatVars NLPat where   nlPatVarsUnder k = \case@@ -289,7 +303,7 @@   getMatchables p =     case p of       PVar _ _       -> empty-      PDef f _       -> singleton f+      PDef f es      -> singleton f ++ getMatchables es       PLam _ x       -> getMatchables x       PPi a b        -> getMatchables (a,b)       PSort s        -> getMatchables s@@ -303,9 +317,11 @@   getMatchables = \case     PType l   -> getMatchables l     PProp l   -> getMatchables l+    PSSet l   -> getMatchables l     PInf f n  -> empty     PSizeUniv -> empty     PLockUniv -> empty+    PIntervalUniv -> empty  instance GetMatchables Term where   getMatchables = getDefs' __IMPOSSIBLE__ singleton@@ -336,6 +352,68 @@   freeVars' = \case     PType l   -> freeVars' l     PProp l   -> freeVars' l+    PSSet l   -> freeVars' l     PInf f n  -> mempty     PSizeUniv -> mempty     PLockUniv -> mempty+    PIntervalUniv -> mempty++-- Throws a pattern violation if the given term contains any+-- metavariables.+blockOnMetasIn :: (MonadBlock m, AllMetas t) => t -> m ()+blockOnMetasIn t = case unblockOnAllMetasIn t of+  UnblockOnAll ms | null ms -> return ()+  b -> patternViolation b++-- Helper functions+++assertPi :: Type -> TCM (Dom Type, Abs Type)+assertPi t = abortIfBlocked t >>= \case+  El _ (Pi a b) -> return (a,b)+  t             -> errNotPi t++errNotPi :: Type -> TCM a+errNotPi t = typeError . GenericDocError =<< fsep+    [ prettyTCM t+    , "should be a function type, but it isn't."+    , "Do you have any non-confluent rewrite rules?"+    ]++assertPath :: Type -> TCM (Sort, QName, Arg Term, Arg Term, Arg Term, Arg Term)+assertPath t = abortIfBlocked t >>= pathView >>= \case+  PathType s q l b u v -> return (s,q,l,b,u,v)+  OType t -> errNotPath t++errNotPath :: Type -> TCM a+errNotPath t = typeError . GenericDocError =<< fsep+    [ prettyTCM t+    , "should be a path type, but it isn't."+    , "Do you have any non-confluent rewrite rules?"+    ]++assertProjOf :: QName -> Type -> TCM (Dom Type, Abs Type)+assertProjOf f t = do+  t <- abortIfBlocked t+  getDefType f t >>= \case+    Just (El _ (Pi a b)) -> return (a,b)+    _ -> errNotProjOf f t++errNotProjOf :: QName -> Type -> TCM a+errNotProjOf f t = typeError . GenericDocError =<< fsep+      [ prettyTCM f , "should be a projection from type"+      , prettyTCM t , "but it isn't."+      , "Do you have any non-confluent rewrite rules?"+      ]++assertConOf :: ConHead -> Type -> TCM Type+assertConOf c t = getFullyAppliedConType c t >>= \case+    Just (_ , ct) -> return ct+    Nothing -> errNotConOf c t++errNotConOf :: ConHead -> Type -> TCM a+errNotConOf c t = typeError . GenericDocError =<< fsep+      [ prettyTCM c , "should be a constructor of type"+      , prettyTCM t , "but it isn't."+      , "Do you have any non-confluent rewrite rules?"+      ]
src/full/Agda/TypeChecking/Rules/Application.hs view
@@ -11,11 +11,10 @@ import Prelude hiding ( null )  import Control.Applicative        ( (<|>) )-import Control.Monad              ( forM, forM_, guard, liftM2 )-import Control.Monad.Except+import Control.Monad              ( filterM, forM, forM_, guard, liftM2 )+import Control.Monad.Except       ( ExceptT, runExceptT, MonadError, catchError, throwError ) import Control.Monad.Trans import Control.Monad.Trans.Maybe-import Control.Monad.Reader  import Data.Bifunctor import Data.Maybe@@ -48,7 +47,7 @@ import Agda.TypeChecking.MetaVars import Agda.TypeChecking.Names import Agda.TypeChecking.Pretty-import Agda.TypeChecking.Primitive+import Agda.TypeChecking.Primitive hiding (Nat) import Agda.TypeChecking.Monad import Agda.TypeChecking.Records import Agda.TypeChecking.Reduce@@ -61,6 +60,7 @@ import Agda.Utils.Functor import Agda.Utils.Lens import Agda.Utils.List  ( (!!!), groupOn, initWithDefault )+import qualified Agda.Utils.List as List import Agda.Utils.List1 ( List1, pattern (:|) ) import qualified Agda.Utils.List1 as List1 import Agda.Utils.Maybe@@ -558,44 +558,100 @@  checkArgumentsE :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Maybe Type ->                    ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)-checkArgumentsE = checkArgumentsE' NotCheckedTarget+checkArgumentsE sComp sExpand sRange sArgs sFun sApp = do+  sPathView <- pathView'+  checkArgumentsE'+    S{ sChecked       = NotCheckedTarget+     , sArgs          = zip sArgs $+                        List.suffixesSatisfying visible sArgs+     , sArgsLen       = length sArgs+     , sSizeLtChecked = False+     , sSkipCheck     = DontSkip+     , ..+     } +-- | State used by 'checkArgumentsE''.++data CheckArgumentsE'State = S+  { sChecked :: CheckedTarget+    -- ^ Have we already checked the target?+  , sComp :: Comparison+    -- ^ Comparison to use if checking the target type.+  , sExpand :: ExpandHidden+    -- ^ Insert trailing hidden arguments?+  , sRange :: Range+    -- ^ Range of the function.+  , sArgs :: [(NamedArg A.Expr, Bool)]+    -- ^ Arguments, along with information about whether a given+    -- argument and all remaining arguments are 'visible'.+  , sArgsLen :: !Nat+    -- ^ The length of 'sArgs'.+  , sFun :: Type+    -- ^ The function's type.+  , sApp :: Maybe Type+    -- ^ The type of the application.+  , sSizeLtChecked :: !Bool+    -- ^ Have we checked if 'sApp' is 'BoundedLt'?+  , sSkipCheck :: !SkipCheck+    -- ^ Should the target type check be skipped?+  , sPathView :: Type -> PathView+    -- ^ The function returned by 'pathView''.+  }++-- | Should the target type check in 'checkArgumentsE'' be skipped?++data SkipCheck+  = Skip+  | SkipNext !Nat+    -- ^ Skip the given number of checks.+  | DontSkip+ checkArgumentsE'-  :: CheckedTarget     -- ^ Have we already checked the target?-  -> Comparison        -- ^ Comparison to use if checking target type-  -> ExpandHidden      -- ^ Insert trailing hidden arguments?-  -> Range             -- ^ Range of the function.-  -> [NamedArg A.Expr] -- ^ Arguments.-  -> Type              -- ^ Type of the function.-  -> Maybe Type        -- ^ Type of the application.+  :: CheckArgumentsE'State   -> ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)  -- Case: no arguments, do not insert trailing hidden arguments: We are done.-checkArgumentsE' chk cmp exh _ [] t0 _ | isDontExpandLast exh = return $ ACState [] [] [] t0 chk+checkArgumentsE' S{ sArgs = [], .. }+  | isDontExpandLast sExpand =+    return $ ACState+      { acRanges      = []+      , acElims       = []+      , acConstraints = []+      , acType        = sFun+      , acData        = sChecked+      }  -- Case: no arguments, but need to insert trailing hiddens.-checkArgumentsE' chk cmp _ExpandLast r [] t0 mt1 =-    traceCallE (CheckArguments r [] t0 mt1) $ lift $ do-      mt1' <- traverse (unEl <.> reduce) mt1-      (us, t) <- implicitArgs (-1) (expand mt1') t0-      return $ ACState (replicate (length us) Nothing) (map Apply us) (replicate (length us) Nothing) t chk-    where-      expand (Just (Pi dom _)) Hidden     = not (hidden dom)-      expand _                 Hidden     = True-      expand (Just (Pi dom _)) Instance{} = not (isInstance dom)-      expand _                 Instance{} = True-      expand _                 NotHidden  = False+checkArgumentsE' S{ sArgs = [], .. } =+  traceCallE (CheckArguments sRange [] sFun sApp) $ lift $ do+    sApp    <- traverse (unEl <.> reduce) sApp+    (us, t) <- implicitArgs (-1) (expand sApp) sFun+    return $ ACState+      { acRanges      = replicate (length us) Nothing+      , acElims       = map Apply us+      , acConstraints = replicate (length us) Nothing+      , acType        = t+      , acData        = sChecked+      }+  where+  expand (Just (Pi dom _)) Hidden     = not (hidden dom)+  expand _                 Hidden     = True+  expand (Just (Pi dom _)) Instance{} = not (isInstance dom)+  expand _                 Instance{} = True+  expand _                 NotHidden  = False  -- Case: argument given.-checkArgumentsE' chk cmp exh r args0@(arg@(Arg info e) : args) t0 mt1 =-    traceCallE (CheckArguments r args0 t0 mt1) $ do+checkArgumentsE'+  s@S{ sArgs = sArgs@((arg@(Arg info e), sArgsVisible) : args), .. } =++    traceCallE (CheckArguments sRange (map fst sArgs) sFun sApp) $ do       lift $ reportSDoc "tc.term.args" 30 $ sep         [ "checkArgumentsE"---        , "  args0 =" <+> prettyA args0+--        , "  sArgs =" <+> prettyA sArgs         , nest 2 $ vcat           [ "e     =" <+> prettyA e-          , "t0    =" <+> prettyTCM t0-          , "t1    =" <+> maybe "Nothing" prettyTCM mt1+          , "sFun  =" <+> prettyTCM sFun+          , "sApp  =" <+> maybe "Nothing" prettyTCM sApp           ]         ]       -- First, insert implicit arguments, depending on current argument @arg@.@@ -609,11 +665,11 @@           expand hy        y = not (sameHiding hy hx) || maybe False (y /=) mx       reportSDoc "tc.term.args" 30 $ vcat         [ "calling implicitNamedArgs"-        , nest 2 $ "t0 = " <+> prettyTCM t0-        , nest 2 $ "hx = " <+> text (show hx)-        , nest 2 $ "mx = " <+> maybe "nothing" prettyTCM mx+        , nest 2 $ "sFun = " <+> prettyTCM sFun+        , nest 2 $ "hx   = " <+> text (show hx)+        , nest 2 $ "mx   = " <+> maybe "nothing" prettyTCM mx         ]-      (nargs, t) <- lift $ implicitNamedArgs (-1) expand t0+      (nargs, sFun) <- lift $ implicitNamedArgs (-1) expand sFun       -- Separate names from args.       let (mxs, us) = unzip $ map (\ (Arg ai (Named mx u)) -> (mx, Apply $ Arg ai u)) nargs           xs        = catMaybes mxs@@ -621,20 +677,27 @@       -- We need a function type here, but we don't know which kind       -- (implicit/explicit). But it might be possible to use injectivity to       -- force a pi.-      t <- lift $ forcePiUsingInjectivity t+      sFun <- lift $ forcePiUsingInjectivity sFun        -- We are done inserting implicit args.  Now, try to check @arg@.-      ifBlocked t (\ m t -> throwError $ ACState (replicate (length us) Nothing) us (replicate (length us) Nothing) t args0) $ \ _ t0' -> do+      ifBlocked sFun+        (\_ sFun -> throwError $ ACState+            { acRanges      = replicate (length us) Nothing+            , acElims       = us+            , acConstraints = replicate (length us) Nothing+            , acType        = sFun+            , acData        = map fst sArgs+            }) $ \_ sFun -> do          -- What can go wrong?          -- 1. We ran out of function types.         let shouldBePi               -- a) It is an explicit argument, but we ran out of function types.-              | visible info = lift $ typeError $ ShouldBePi t0'+              | visible info = lift $ typeError $ ShouldBePi sFun               -- b) It is an implicit argument, and we did not insert any implicits.               --    Thus, the type was not a function type to start with.-              | null xs        = lift $ typeError $ ShouldBePi t0'+              | null xs        = lift $ typeError $ ShouldBePi sFun               -- c) We did insert implicits, but we ran out of implicit function types.               --    Then, we should inform the user that we did not find his one.               | otherwise      = lift $ typeError $ WrongNamedArgument arg xs@@ -644,59 +707,106 @@         --    (Otherwise we would have ran out of function types instead.)         let wrongPi               -- b) We have not inserted any implicits.-              | null xs   = lift $ typeError $ WrongHidingInApplication t0'+              | null xs   = lift $ typeError $+                            WrongHidingInApplication sFun               -- c) We inserted implicits, but did not find his one.               | otherwise = lift $ typeError $ WrongNamedArgument arg xs -        viewPath <- lift pathView'+        let (skip, next) = case sSkipCheck of+              Skip       -> (True, Skip)+              DontSkip   -> (False, DontSkip)+              SkipNext n -> case compare n 1 of+                LT -> (False, DontSkip)+                EQ -> (True,  DontSkip)+                GT -> (True,  SkipNext (n - 1)) +        s <- return s+          { sRange     = fuseRange sRange e+          , sArgs      = args+          , sArgsLen   = sArgsLen - 1+          , sFun       = sFun+          , sSkipCheck = next+          }+         -- Check the target type if we can get away with it.-        chk' <- lift $-          case (chk, mt1) of-            (NotCheckedTarget, Just t1) | all visible args0 -> do-              let n = length args0-              TelV tel tgt <- telViewUpTo n t0'-              let dep = any (< n) $ IntSet.toList $ freeVars tgt-                  vis = all visible (telToList tel)-                  isRigid t | PathType{} <- viewPath t = return False -- Path is not rigid!-                  isRigid (El _ (Pi dom _)) = return $ visible dom-                  isRigid (El _ (Def d _))  = getConstInfo d <&> theDef <&> \ case-                    Axiom{}                   -> True-                    DataOrRecSig{}            -> True-                    AbstractDefn{}            -> True-                    Function{funClauses = cs} -> null cs-                    Datatype{}                -> True-                    Record{}                  -> True-                    Constructor{}             -> __IMPOSSIBLE__-                    GeneralizableVar{}        -> __IMPOSSIBLE__-                    Primitive{}               -> False-                    PrimitiveSort{}           -> False-                  isRigid _           = return False-              rigid <- isRigid tgt-              -- Andreas, 2019-03-28, issue #3248:-              -- If the target type is SIZELT, we need coerce, leqType is insufficient.-              -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i).-              isSizeLt <- reduce t1 >>= isSizeType <&> \case-                Just (BoundedLt _) -> True-                _ -> False-              if | dep       -> return chk    -- must be non-dependent-                 | not rigid -> return chk    -- with a rigid target-                 | not vis   -> return chk    -- and only visible arguments-                 | isSizeLt  -> return chk    -- Issue #3248, not Size<-                 | otherwise -> do-                  let tgt1 = applySubst (strengthenS impossible $ size tel) tgt+        s <- lift $+          case (sChecked, skip, sApp) of+            (NotCheckedTarget, False, Just sApp) | sArgsVisible -> do+              -- How many visible Π's (up to at most sArgsLen) does+              -- sFun start with?+              TelV tel tgt <- telViewUpTo' sArgsLen visible sFun+              let visiblePis = size tel++                  -- The free variables less than visiblePis in tgt.+                  freeInTgt =+                    fst $ IntSet.split visiblePis $ freeVars tgt++              rigid <- isRigid s tgt+              -- The target must be rigid.+              case rigid of+                IsNotRigid reason ->+                      -- Skip the next visiblePis - 1 - k checks.+                  let skip k   = s{ sSkipCheck =+                                    SkipNext $ visiblePis - 1 - k+                                  }+                      dontSkip = s+                  in return $ case reason of+                    Permanent   -> skip 0+                    Unspecified -> dontSkip+                    AVar x      ->+                      if x `IntSet.member` freeInTgt+                      then skip x+                      else skip 0+                IsRigid -> do++                      -- Is any free variable in tgt less than+                      -- visiblePis?+                  let dep = not (IntSet.null freeInTgt)+                  -- The target must be non-dependent.+                  if dep then return s else do++                  -- Andreas, 2019-03-28, issue #3248:+                  -- If the target type is SIZELT, we need coerce, leqType is insufficient.+                  -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i).+                  (isSizeLt, sApp, s) <-+                    if sSizeLtChecked+                    then return (False, sApp, s)+                    else do+                      sApp     <- reduce sApp+                      isSizeLt <- isSizeType sApp <&> \case+                        Just (BoundedLt _) -> True+                        _                  -> False+                      return ( isSizeLt+                             , sApp+                             , s{ sApp           = Just sApp+                                , sSizeLtChecked = True+                                , sSkipCheck     =+                                    if isSizeLt then Skip else DontSkip+                                }+                             )+                  if isSizeLt then return s else do++                  let tgt1 = applySubst+                               (strengthenS impossible visiblePis)+                               tgt                   reportSDoc "tc.term.args.target" 30 $ vcat                     [ "Checking target types first"                     , nest 2 $ "inferred =" <+> prettyTCM tgt1-                    , nest 2 $ "expected =" <+> prettyTCM t1 ]-                  traceCall (CheckTargetType (fuseRange r args0) tgt1 t1) $-                    CheckedTarget <$> ifNoConstraints_ (compareType cmp tgt1 t1)-                                        (return Nothing) (return . Just)+                    , nest 2 $ "expected =" <+> prettyTCM sApp ]+                  chk <-+                    traceCall+                      (CheckTargetType+                         (fuseRange sRange sArgs) tgt1 sApp) $+                      CheckedTarget <$>+                        ifNoConstraints_ (compareType sComp tgt1 sApp)+                          (return Nothing) (return . Just)+                  return s{ sChecked = chk } -            _ -> return chk+            _ -> return s -        -- t0' <- lift $ forcePi (getHiding info) (maybe "_" rangedThing $ nameOf e) t0'-        case unEl t0' of+        -- sFun <- lift $ forcePi (getHiding info)+        --                  (maybe "_" rangedThing $ nameOf e) sFun+        case unEl sFun of           Pi (Dom{domInfo = info', domName = dname, unDom = a}) b             | let name = bareNameWithDefault "_" dname,               sameHiding info info'@@ -718,13 +828,18 @@                   let e' = e { nameOf = (nameOf e) <|> dname }                   checkNamedArg (Arg info' e') a -                let c | IsLock == getLock info' = Just $ Abs "t" (CheckLockedVars (Var 0 []) (raise 1 t0') (raise 1 $ Arg info' u) (raise 1 a))+                let c | IsLock == getLock info' =+                        Just $ Abs "t" $+                        CheckLockedVars (Var 0 []) (raise 1 sFun)+                          (raise 1 $ Arg info' u) (raise 1 a)                       | otherwise = Nothing                 lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info')-                lift $ reportSDoc "tc.term.lock" 40 $ addContext (defaultDom $ t0') $ maybe (text "nothing") prettyTCM (absBody <$> c)+                lift $ reportSDoc "tc.term.lock" 40 $+                  addContext (defaultDom $ sFun) $+                  maybe (text "nothing") prettyTCM (absBody <$> c)                 -- save relevance info' from domain in argument                 addCheckedArgs us (getRange e) (Apply $ Arg info' u) c $-                  checkArgumentsE' chk' cmp exh (fuseRange r e) args (absApp b u) mt1+                  checkArgumentsE' s{ sFun = absApp b u }             | otherwise -> do                 reportSDoc "error" 10 $ nest 2 $ vcat                   [ text $ "info      = " ++ show info@@ -735,11 +850,14 @@                 wrongPi           _             | visible info-            , PathType s _ _ bA x y <- viewPath t0' -> do+            , PathType sort _ _ bA x y <- sPathView sFun -> do                 lift $ reportSDoc "tc.term.args" 30 $ text $ show bA                 u <- lift $ checkExpr (namedThing e) =<< primIntervalType                 addCheckedArgs us (getRange e) (IApply (unArg x) (unArg y) u) Nothing $-                  checkArgumentsE cmp exh (fuseRange r e) args (El s $ unArg bA `apply` [argN u]) mt1+                  checkArgumentsE'+                    s{ sChecked = NotCheckedTarget+                     , sFun     = El sort $ unArg bA `apply` [argN u]+                     }           _ -> shouldBePi   where     -- Andrea: Here one would add constraints too.@@ -752,6 +870,61 @@           let rs' = replicate (length us) Nothing ++ Just r : rs               cs' = replicate (length us) Nothing ++ c : acConstraints st           throwError $ st { acRanges = rs', acElims = us ++ u : vs, acConstraints = cs' }++-- | The result of 'isRigid'.++data IsRigid+  = IsRigid+    -- ^ The type is rigid.+  | IsNotRigid !IsPermanent+    -- ^ The type is not rigid. If the argument is 'Nothing', then+    -- this will not change. If the argument is @'Just' reason@, then+    -- this might change for the given @reason@.++-- | Is the result of 'isRigid' \"permanent\"?++data IsPermanent+  = Permanent+    -- ^ Yes.+  | AVar !Nat+    -- ^ The result does not change unless the given variable is+    -- instantiated.+  | Unspecified+    -- ^ Maybe, maybe not.++-- | Is the type \"rigid\"?++isRigid :: CheckArgumentsE'State -> Type -> TCM IsRigid+isRigid s t | PathType{} <- sPathView s t =+  -- Path is not rigid.+  return $ IsNotRigid Permanent+isRigid _ (El _ t) = case t of+  Var x _    -> return $ IsNotRigid (AVar x)+  Lam{}      -> return $ IsNotRigid Permanent+  Lit{}      -> return $ IsNotRigid Permanent+  Con{}      -> return $ IsNotRigid Permanent+  Pi dom _   -> return $+                if visible dom then IsRigid else IsNotRigid Permanent+  Sort{}     -> return $ IsNotRigid Permanent+  Level{}    -> return $ IsNotRigid Permanent+  MetaV{}    -> return $ IsNotRigid Unspecified+  DontCare{} -> return $ IsNotRigid Permanent+  Dummy{}    -> return $ IsNotRigid Permanent+  Def d _    -> getConstInfo d <&> theDef <&> \case+    Axiom{}                   -> IsRigid+    DataOrRecSig{}            -> IsRigid+    AbstractDefn{}            -> IsRigid+    Function{funClauses = cs} -> if null cs+                                 then IsRigid+                                 else IsNotRigid Unspecified+                                      -- This Reason could perhaps be+                                      -- more precise (in some cases).+    Datatype{}                -> IsRigid+    Record{}                  -> IsRigid+    Constructor{}             -> __IMPOSSIBLE__+    GeneralizableVar{}        -> __IMPOSSIBLE__+    Primitive{}               -> IsNotRigid Unspecified+    PrimitiveSort{}           -> IsNotRigid Unspecified  -- | Check that a list of arguments fits a telescope. --   Inserts hidden arguments as necessary.
src/full/Agda/TypeChecking/Rules/Builtin.hs view
@@ -13,9 +13,9 @@  import Control.Monad import Control.Monad.Except+import Control.Monad.Trans.Maybe  import Data.List (find, sortBy)-import Data.List.NonEmpty (NonEmpty(..)) import Data.Function (on)  import qualified Agda.Syntax.Abstract as A@@ -47,6 +47,7 @@  import Agda.Utils.Functor import Agda.Utils.List+import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -121,8 +122,9 @@                                                               (El (varSort 1) <$> varM 0 <@> primIZero) -->                                                               (El (varSort 1) <$> varM 0 <@> primIOne) -->                                                               return (sort $ varSort 1)))+  , (builtinIntervalUniv                     |-> BuiltinSort "primIntervalUniv")   , (builtinInterval                         |-> BuiltinData (requireCubical CErased "" >>-                                                              (return $ ssort $ ClosedLevel 0)) [builtinIZero,builtinIOne])+                                                              (return $ sort IntervalUniv)) [builtinIZero,builtinIOne])   , (builtinSub                              |-> builtinPostulateC CErased (runNamesT [] $ hPi' "a" (el $ cl primLevel) $ \ a ->                                                                    nPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->                                                                    nPi' "φ" (cl tinterval) $ \ phi ->@@ -131,7 +133,7 @@   , (builtinSubIn                            |-> builtinPostulateC CErased (runNamesT [] $                                                                    hPi' "a" (el $ cl primLevel) $ \ a ->                                                                    hPi' "A" (el' (cl primLevelSuc <@> a) (Sort . tmSort <$> a)) $ \ bA ->-                                                                   hPi' "φ" (elSSet $ cl primInterval) $ \ phi ->+                                                                   hPi' "φ" (cl tinterval) $ \ phi ->                                                                    nPi' "x" (el' a bA) $ \ x ->                                                                    el's a $ cl primSub <#> a <@> bA <@> phi <@> lam "o" (\ _ -> x)))   , (builtinIZero                            |-> BuiltinDataCons tinterval)@@ -157,18 +159,16 @@                                                                    pPi' "o" (cl primIZero) (\ o ->                                                                         el' l $ gApply' (setRelevance Irrelevant defaultArgInfo) bA o))) -  , (builtinId                               |-> builtinPostulateC CErased (hPi "a" (el primLevel) $+  , (builtinId                               |-> BuiltinData ((>>) (requireCubical CErased "") $ hPi "a" (el primLevel) $                                                               hPi "A" (return $ sort $ varSort 0) $                                                               (El (varSort 1) <$> varM 0) -->                                                               (El (varSort 1) <$> varM 0) -->-                                                              return (sort $ varSort 1)))-  , (builtinConId                            |-> builtinPostulateC CErased (hPi "a" (el primLevel) $-                                                           hPi "A" (return $ sort $ varSort 0) $-                                                           hPi "x" (El (varSort 1) <$> varM 0) $-                                                           hPi "y" (El (varSort 2) <$> varM 1) $-                                                           tinterval -->-                                                           (El (varSort 3) <$> primPath <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0) -->-                                                           (El (varSort 3) <$> primId <#> varM 3 <#> varM 2 <@> varM 1 <@> varM 0)))+                                                             return (sort $ varSort 1)) [builtinReflId])+  , (builtinReflId                           |-> BuiltinDataCons ((>>) (requireCubical CErased "") $ runNamesT [] $+                                                              hPi' "a" (el primLevel) $ \ l ->+                                                              hPi' "A" (sort . tmSort <$> l) $ \ bA ->+                                                              hPi' "x" (el' l bA) $ \ x ->+                                                              el' l (primId <#> l <#> bA <@> x <@> x)))   , (builtinEquiv                            |-> BuiltinUnknown (Just $ requireCubical CFull "" >> runNamesT [] (                                                                     hPi' "l" (el $ cl primLevel) $ \ a ->                                                                     hPi' "l'" (el $ cl primLevel) $ \ b ->@@ -195,13 +195,15 @@                                                                              (cl primEquiv <#> la <#> lb <@> bA <@> bB)) $ \ e -> do                                                                nPi' "b" (el' lb bB) $ \ b -> do                                                                 let f = cl primEquivFun <#> la <#> lb <#> bA <#> bB <@> e-                                                                    fiber = el' (cl primLevelMax <@> la <@> lb)+                                                                    lub = cl primLevelMax <@> la <@> lb+                                                                    fiber = el' lub                                                                                 (cl primSigma <#> la <#> lb                                                                                   <@> bA                                                                                   <@> lam "a" (\ a ->                                                                                          cl primPath <#> lb <#> bB <@> (f <@> a) <@> b))                                                                 nPi' "φ" (cl tinterval) $ \ phi ->-                                                                  pPi' "o" phi (\ o -> fiber) --> fiber+                                                                  nPi' "f" (pPi' "o" phi (\ o -> fiber)) $ \ pfib ->+                                                                    el' lub (cl primSub <#> lub <#> fmap unEl fiber <@> phi <@> pfib)                                                              ))                                                               (const $ const $ return ()))   , (builtinTranspProof                       |-> BuiltinUnknown (Just $ requireCubical CErased "" >> runNamesT [] (@@ -232,9 +234,10 @@                                                    , builtinAgdaTermPi, builtinAgdaTermSort                                                    , builtinAgdaTermLit, builtinAgdaTermMeta                                                    , builtinAgdaTermUnsupported])-  , builtinAgdaErrorPart                     |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartName ]+  , builtinAgdaErrorPart                     |-> BuiltinData tset [ builtinAgdaErrorPartString, builtinAgdaErrorPartTerm, builtinAgdaErrorPartPatt, builtinAgdaErrorPartName ]   , builtinAgdaErrorPartString               |-> BuiltinDataCons (tstring --> terrorpart)   , builtinAgdaErrorPartTerm                 |-> BuiltinDataCons (tterm --> terrorpart)+  , builtinAgdaErrorPartPatt                 |-> BuiltinDataCons (tpat --> terrorpart)   , builtinAgdaErrorPartName                 |-> BuiltinDataCons (tqname --> terrorpart)   -- Andreas, 2017-01-12, issue #2386: special handling of builtinEquality   -- , (builtinEquality                         |-> BuiltinData (hPi "a" (el primLevel) $@@ -304,9 +307,7 @@   , (builtinHidden                           |-> BuiltinDataCons thiding)   , (builtinInstance                         |-> BuiltinDataCons thiding)   , (builtinVisible                          |-> BuiltinDataCons thiding)-  , (builtinSizeUniv                         |-> builtinPostulate tSizeUniv) -- SizeUniv : SizeUniv--- See comment on tSizeUniv: the following does not work currently.---  , (builtinSizeUniv                          |-> builtinPostulate tSetOmega) -- SizeUniv : Setω+  , (builtinSizeUniv                         |-> builtinPostulate tsetOmega) -- SizeUniv : Setω   , (builtinSize                             |-> builtinPostulate tSizeUniv)   , (builtinSizeLt                           |-> builtinPostulate (tsize ..--> tSizeUniv))   , (builtinSizeSuc                          |-> builtinPostulate (tsize --> tsize))@@ -365,14 +366,16 @@   , builtinAgdaTCMReduce                     |-> builtinPostulate (tterm --> tTCM_ primAgdaTerm)   , builtinAgdaTCMCatchError                 |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $                                                                    tTCM 1 (varM 0) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))-  , builtinAgdaTCMGetContext                 |-> builtinPostulate (tTCM_ (unEl <$> tlist (targ ttype)))+  , builtinAgdaTCMGetContext                 |-> builtinPostulate (tTCM_ (unEl <$> ttelescope))   , builtinAgdaTCMExtendContext              |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $-                                                                   targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+                                                                   tstring --> targ ttype --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMInContext                  |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $-                                                                   tlist (targ ttype) --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))+                                                                   ttelescope --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMFreshName                  |-> builtinPostulate (tstring --> tTCM_ primQName)   , builtinAgdaTCMDeclareDef                 |-> builtinPostulate (targ tqname --> ttype --> tTCM_ primUnit)   , builtinAgdaTCMDeclarePostulate           |-> builtinPostulate (targ tqname --> ttype --> tTCM_ primUnit)+  , builtinAgdaTCMDeclareData                |-> builtinPostulate (tqname --> tnat --> ttype --> tTCM_ primUnit)+  , builtinAgdaTCMDefineData                 |-> builtinPostulate (tqname --> tlist (tpair primLevelZero primLevelZero tqname ttype) --> tTCM_ primUnit)   , builtinAgdaTCMDefineFun                  |-> builtinPostulate (tqname --> tlist tclause --> tTCM_ primUnit)   , builtinAgdaTCMGetType                    |-> builtinPostulate (tqname --> tTCM_ primAgdaTerm)   , builtinAgdaTCMGetDefinition              |-> builtinPostulate (tqname --> tTCM_ primAgdaDefinition)@@ -384,6 +387,7 @@   , builtinAgdaTCMIsMacro                    |-> builtinPostulate (tqname --> tTCM_ primBool)   , builtinAgdaTCMWithNormalisation          |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tbool --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMWithReconsParams           |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tTCM 1 (varM 0) --> tTCM 1 (varM 0))+  , builtinAgdaTCMFormatErrorParts           |-> builtinPostulate (tlist terrorpart --> tTCM_ primString)   , builtinAgdaTCMDebugPrint                 |-> builtinPostulate (tstring --> tnat --> tlist terrorpart --> tTCM_ primUnit)   , builtinAgdaTCMOnlyReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))   , builtinAgdaTCMDontReduceDefs             |-> builtinPostulate (hPi "a" tlevel $ hPi "A" (tsetL 0) $ tlist tqname --> tTCM 1 (varM 0) --> tTCM 1 (varM 0))@@ -395,6 +399,7 @@                                                                    tTCM_ (primSigma <#> primLevelZero <#> primLevelZero <@> primNat <@>                                                                           (Lam defaultArgInfo . Abs "_" <$> (primSigma <#> primLevelZero <#> primLevelZero <@> primString <@>                                                                            (Lam defaultArgInfo . Abs "_" <$> primString)))))+  , builtinAgdaTCMGetInstances               |-> builtinPostulate (tmeta --> tTCM_ (list primAgdaTerm))   ]   where         (|->) = BuiltinInfo@@ -453,7 +458,7 @@         ttelescope = tlist (tpair primLevelZero primLevelZero tstring (targ ttype))         tTCM l a   = elV l (primAgdaTCM <#> varM l <@> a)         tTCM_ a    = el (primAgdaTCM <#> primLevelZero <@> a)-        tinterval  = El (SSet $ ClosedLevel 0) <$> primInterval+        tinterval  = El IntervalUniv <$> primInterval          verifyPlus plus =             verify ["n","m"] $ \(@@) zero suc (==) (===) choice -> do@@ -844,7 +849,10 @@           t <- tcmt           (,t) <$> checkExpr e t         f v t-        bindBuiltinName s v+        if | s == builtinRewrite -> runMaybeT (getQNameFromTerm v) >>= \case+              Nothing -> genericError "Invalid rewrite relation"+              Just q  -> bindBuiltinRewriteRelation q+           | otherwise           -> bindBuiltinName s v  setConstTranspAxiom :: QName -> TCM () setConstTranspAxiom q =@@ -856,6 +864,19 @@       $ updateDefPolarity       id       . updateDefArgOccurrences (const [Unused,StrictPos,Mixed,Mixed]) +builtinIdHook :: QName -> TCM ()+builtinIdHook q = do+      modifySignature $ updateDefinition q+        $ updateDefPolarity       id+        . updateDefArgOccurrences (const [Unused,StrictPos,Mixed,Mixed])+      modifySignature $ updateDefinition q+        $ updateTheDef (\ def@Datatype{} -> def { dataPars = 3, dataIxs = 1})++builtinReflIdHook :: QName -> TCM ()+builtinReflIdHook q = do+      modifySignature $ updateDefinition q+        $ updateTheDef (\ def@Constructor{} -> def { conPars = 3, conArity = 0})+ -- | Bind a builtin thing to an expression. bindBuiltin :: String -> ResolvedName -> TCM () bindBuiltin b x = do@@ -938,11 +959,11 @@       where         -- Andreas, 2015-02-14         -- Special treatment of SizeUniv, should maybe be a primitive.-        def | b == builtinSizeUniv = emptyFunction-                { funClauses = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ]-                , funCompiled = Just (CC.Done [] $ Sort sSizeUniv)-                , funMutual    = Just []-                , funTerminates = Just True+        def | b == builtinSizeUniv = FunctionDefn $ emptyFunctionData+                { _funClauses    = [ (empty :: Clause) { clauseBody = Just $ Sort sSizeUniv } ]+                , _funCompiled   = Just (CC.Done [] $ Sort sSizeUniv)+                , _funMutual     = Just []+                , _funTerminates = Just True                 }             | otherwise = defaultAxiom @@ -979,11 +1000,15 @@               }       addConstant' q defaultArgInfo q t def       addDataCons d [q]++      when (b == builtinReflId)     $ builtinReflIdHook q+       bindBuiltinName b $ Con ch ConOSystem []      Just (BuiltinData mt cs) -> do       t <- mt       addConstant' q defaultArgInfo q t (def t)+      when (b == builtinId)     $ builtinIdHook q       bindBuiltinName b $ Def q []       where         def t = Datatype@@ -995,6 +1020,8 @@               , dataAbstr      = ConcreteDef               , dataMutual     = Nothing               , dataPathCons   = []+              , dataTranspIx   = Nothing -- Id has custom transp def.+              , dataTransp     = Nothing               }      Just (BuiltinSort sortname) -> do@@ -1004,8 +1031,13 @@                 "primStrictSet" -> mkSSet 0                 "primSetOmega" -> Inf IsFibrant 0                 "primStrictSetOmega" -> Inf IsStrict 0+                "primIntervalUniv" -> IntervalUniv                 _              -> __IMPOSSIBLE__           def = PrimitiveSort sortname s+      -- Check for the cubical flag if the sort requries it+      case sortname of+        "primIntervalUniv" -> requireCubical CErased ""+        _ -> return ()       addConstant' q defaultArgInfo q (sort $ univSort s) def       bindBuiltinName b $ Def q []
src/full/Agda/TypeChecking/Rules/Builtin/Coinduction.hs view
@@ -22,6 +22,8 @@ import Agda.TypeChecking.Rules.Builtin import Agda.TypeChecking.Rules.Term +import Agda.Utils.Lens+ -- | The type of @∞@.  typeOfInf :: TCM Type@@ -82,6 +84,7 @@                   , recEtaEquality'   = Inferred $ NoEta CopatternMatching                   , recPatternMatching= CopatternMatching                   , recMutual         = Just []+                  , recTerminates     = Just True  -- not recursive                   , recAbstr          = ConcreteDef                   , recComp           = emptyCompKit                   }@@ -134,11 +137,12 @@               ConP sharpCon cpi [ argN $ Named Nothing $ debruijnNamedVar "x" 0 ] ]           , clauseBody      = Just $ var 0           , clauseType      = Just $ defaultArg $ El (varSort 2) $ var 1-          , clauseCatchall  = False+          , clauseCatchall    = False           , clauseExact       = Just True           , clauseRecursive   = Just False           , clauseUnreachable = Just False-          , clauseEllipsis  = NoEllipsis+          , clauseEllipsis    = NoEllipsis+          , clauseWhereModule = Nothing           }         cc = Case (defaultArg 0) $ conCase sharp False $ WithArity 1 $ Done [defaultArg "x"] $ var 0         projection = Projection@@ -152,20 +156,20 @@       flatDefn { defPolarity       = []                , defArgOccurrences = [StrictPos]  -- changing that to [Mixed] destroys monotonicity of 'Rec' in test/succeed/GuardednessPreservingTypeConstructors                , defCopatternLHS = hasProjectionPatterns cc-               , theDef = emptyFunction-                   { funClauses      = [clause]-                   , funCompiled     = Just $ cc-                   , funProjection   = Just projection-                   , funMutual       = Just []-                   , funTerminates   = Just True+               , theDef = FunctionDefn emptyFunctionData+                   { _funClauses      = [clause]+                   , _funCompiled     = Just $ cc+                   , _funProjection   = Right projection+                   , _funMutual       = Just []+                   , _funTerminates   = Just True                    }                 }      -- register flat as record field for constructor sharp-    modifySignature $ updateDefinition sharp $ updateTheDef $ \ def ->-      def { conSrcCon = sharpCon }-    modifySignature $ updateDefinition inf $ updateTheDef $ \ def ->-      def { recConHead = sharpCon, recFields = [defaultDom flat] }+    modifySignature $ updateDefinition sharp $ updateTheDef $ over lensConstructor $ \ def ->+      def { _conSrcCon = sharpCon }+    modifySignature $ updateDefinition inf $ updateTheDef $ over lensRecord $ \ def ->+      def { _recConHead = sharpCon, _recFields = [defaultDom flat] }     return $ Def flat []  -- The coinductive primitives.
src/full/Agda/TypeChecking/Rules/Data.hs view
@@ -8,14 +8,23 @@ import Control.Monad.Except import Control.Monad.Trans import Control.Monad.Trans.Maybe+import Control.Exception as E +-- Control.Monad.Fail import is redundant since GHC 8.8.1+import Control.Monad.Fail (MonadFail)+ import Data.Set (Set) import qualified Data.Set as Set+import Data.List (nub) +import Agda.Interaction.Options.Base+ import qualified Agda.Syntax.Abstract as A import qualified Agda.Syntax.Concrete.Name as C import Agda.Syntax.Abstract.Views (deepUnscope) import Agda.Syntax.Internal+import Agda.Syntax.Internal.Pattern+import Agda.Syntax.Internal.MetaVars (unblockOnAnyMetaIn) import Agda.Syntax.Common import Agda.Syntax.Position import qualified Agda.Syntax.Info as Info@@ -40,6 +49,7 @@  import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ ) +import Agda.Utils.Either import Agda.Utils.List import Agda.Utils.List1 (List1, pattern (:|)) import qualified Agda.Utils.List1 as List1@@ -48,6 +58,7 @@ import Agda.Utils.Null import qualified Agda.Utils.Pretty as P import Agda.Utils.Size+import Agda.Utils.WithDefault  import Agda.Utils.Impossible @@ -85,11 +96,6 @@         dataDef <- bindGeneralizedParameters parNames t $ \ gtel t0 ->                    bindParameters (npars - length parNames) ps t0 $ \ ptel t0 -> do -            -- Parameters are always hidden in constructors-            let tel  = abstract gtel ptel-                tel' = hideAndRelParams <$> tel-            -- let tel' = hideTel tel-             -- The type we get from bindParameters is Θ -> s where Θ is the type of             -- the indices. We count the number of indices and return s.             -- We check that s is a sort.@@ -114,15 +120,9 @@                   else throwError err               reduce s -            -- when `--without-K`, all the indices should fit in the-            -- sort of the datatype (see #3420).-            let s' = case s of-                  Prop l -> Type l-                  _      -> s-            -- Andreas, 2019-07-16, issue #3916:-            -- NoUniverseCheck should also disable the index sort check!-            unless (uc == NoUniverseCheck) $-              whenM withoutKOption $ checkIndexSorts s' ixTel+            -- Parameters are always hidden in constructors.+            let tel  = abstract gtel ptel+                tel' = hideAndRelParams <$> tel              reportSDoc "tc.data.sort" 20 $ vcat               [ "checking datatype" <+> prettyTCM name@@ -138,19 +138,21 @@             let npars = size tel              -- Change the datatype from an axiom to a datatype with no constructors.-            let dataDef = Datatype-                  { dataPars       = npars-                  , dataIxs        = nofIxs-                  , dataClause     = Nothing-                  , dataCons       = []     -- Constructors are added later-                  , dataSort       = s-                  , dataAbstr      = Info.defAbstract i-                  , dataMutual     = Nothing-                  , dataPathCons   = []     -- Path constructors are added later+            let dataDef = DatatypeData+                  { _dataPars       = npars+                  , _dataIxs        = nofIxs+                  , _dataClause     = Nothing+                  , _dataCons       = []     -- Constructors are added later+                  , _dataSort       = s+                  , _dataAbstr      = Info.defAbstract i+                  , _dataMutual     = Nothing+                  , _dataPathCons   = []     -- Path constructors are added later+                  , _dataTranspIx   = Nothing -- Generated later if nofIxs > 0.+                  , _dataTransp     = Nothing -- Added later                   }              escapeContext impossible npars $ do-              addConstant' name defaultArgInfo name t dataDef+              addConstant' name defaultArgInfo name t $ DatatypeDefn dataDef                 -- polarity and argOcc.s determined by the positivity checker              -- Check the types of the constructors@@ -158,16 +160,81 @@               isPathCons <- checkConstructor name uc tel' nofIxs s c               return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing ++            -- cubical: the interval universe does not contain datatypes+            -- similar: SizeUniv, ...+            checkDataSort name s++            -- when `--without-K`, all the indices should fit in the+            -- sort of the datatype (see #3420).+            -- Andreas, 2019-07-16, issue #3916:+            -- NoUniverseCheck should also disable the index sort check!+            unless (uc == NoUniverseCheck) $+              whenM withoutKOption $ do+                let s' = case s of+                      Prop l -> Type l+                      _      -> s+                checkIndexSorts s' ixTel+             -- Return the data definition-            return dataDef{ dataPathCons = catMaybes pathCons }+            return dataDef{ _dataPathCons = catMaybes pathCons+                          }          let cons   = map A.axiomName cs  -- get constructor names +        (mtranspix, transpFun) <-+          ifM (collapseDefault . optCubicalCompatible <$> pragmaOptions)+            (do mtranspix <- inTopContext $ defineTranspIx name+                transpFun <- inTopContext $+                               defineTranspFun name mtranspix cons+                                 (_dataPathCons dataDef)+                return (mtranspix, transpFun))+            (return (Nothing, Nothing))+         -- Add the datatype to the signature with its constructors.         -- It was previously added without them.-        addConstant' name defaultArgInfo name t $-            dataDef{ dataCons = cons }+        addConstant' name defaultArgInfo name t $ DatatypeDefn+            dataDef{ _dataCons = cons+                   , _dataTranspIx = mtranspix+                   , _dataTransp   = transpFun+                   } +-- | Make sure that the target universe admits data type definitions.+--   E.g. @IUniv@, @SizeUniv@ etc. do not accept new constructions.+checkDataSort :: QName -> Sort -> TCM ()+checkDataSort name s = setCurrentRange name $ do+  ifBlocked s postpone {-else-} $ \ _ (s :: Sort) -> do+    let+      yes :: TCM ()+      yes = return ()+      no  :: TCM ()+      no  = typeError . GenericDocError =<<+              fsep [ "The universe"+                   , prettyTCM s+                   , "of"+                   , prettyTCM name+                   , "does not admit data or record declarations"+                   ]+    case s of+      -- Sorts that admit data definitions.+      Type _       -> yes+      Prop _       -> yes+      Inf _ _      -> yes+      SSet _       -> yes+      DefS _ _     -> yes+      -- Sorts that do not admit data definitions.+      SizeUniv     -> no+      LockUniv     -> no+      IntervalUniv -> no+      -- Blocked sorts.+      PiSort _ _ _ -> __IMPOSSIBLE__+      FunSort _ _  -> __IMPOSSIBLE__+      UnivSort _   -> __IMPOSSIBLE__+      MetaS _ _    -> __IMPOSSIBLE__+      DummyS _     -> __IMPOSSIBLE__+  where+    postpone :: Blocker -> Sort -> TCM ()+    postpone b s = addConstraint b $ CheckDataSort name s  -- | Ensure that the type is a sort. --   If it is not directly a sort, compare it to a 'newSortMetaBelowInf'.@@ -358,20 +425,22 @@     , builtinItIsOne     ]   if not (all isJust required) then return $ emptyCompKit else do-    hcomp  <- whenDefined (null boundary) [builtinHComp,builtinTrans] (defineTranspOrHCompD DoHComp  d con params names fsT t boundary)-    transp <- whenDefined True            [builtinTrans]              (defineTranspOrHCompD DoTransp d con params names fsT t boundary)+    hcomp  <- whenDefined (null boundary) [builtinHComp,builtinTrans]+      (defineKanOperationD DoHComp  d con params names fsT t boundary)+    transp <- whenDefined True            [builtinTrans]+      (defineKanOperationD DoTransp d con params names fsT t boundary)     return $ CompKit       { nameOfTransp = transp       , nameOfHComp  = hcomp       }   where     -- Δ^I, i : I |- sub Δ : Δ-    sub tel = parallelS [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ]+    sub tel = [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ] ++# EmptyS __IMPOSSIBLE__     withArgInfo tel = zipWith Arg (map domInfo . telToList $ tel) -    defineTranspOrHCompD cmd d con params names fsT t boundary = do+    defineKanOperationD cmd d con params names fsT t boundary = do       let project = (\ t p -> apply (Def p []) [argN t])-      stuff <- defineTranspOrHCompForFields cmd+      stuff <- defineKanOperationForFields cmd                  (guard (not $ null boundary) >> Just (Con con ConOSystem $ teleElims fsT boundary))                  project d params fsT (map argN names) t       caseMaybe stuff (return Nothing) $ \ ((theName, gamma , ty, _cl_types , bodies), theSub) -> do@@ -380,7 +449,7 @@       body <- do         case cmd of           DoHComp -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)-          DoTransp | null boundary -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)+          DoTransp | null boundary {- && null ixs -} -> return $ Con con ConOSystem (map Apply $ withArgInfo fsT bodies)                    | otherwise -> do             io <- primIOne             tIMax <- primIMax@@ -416,6 +485,7 @@               the_phi = raise (size fsT) $ var 0               -- Γ ⊢ sigma : Δ.Φ               -- sigma = [δ i1,bodies]+              -- sigma = theSub[i1]               sigma = reverse bodies ++# d1                where                 -- δ i1@@ -535,6 +605,7 @@               -- Or: Just False;  is it known to be non-recursive?           , clauseUnreachable = Just False           , clauseEllipsis    = NoEllipsis+          , clauseWhereModule = Nothing           }         cs = [clause]       addClauses theName cs@@ -595,23 +666,23 @@     noMutualBlock $ do       let cs = [ clause ]       (mst, _, cc) <- compileClauses Nothing cs-      let fun = emptyFunction-                { funClauses    = cs-                , funCompiled   = Just cc-                , funSplitTree  = mst-                , funProjection = Just $ Projection+      let fun = emptyFunctionData+                { _funClauses    = cs+                , _funCompiled   = Just cc+                , _funSplitTree  = mst+                , _funProjection = Right Projection                     { projProper   = Nothing                     , projOrig     = projName                     , projFromType = Arg (getArgInfo ty) dataName                     , projIndex    = np + 1                     , projLams     = ProjLams $ map (argFromDom . fmap fst) $ telToList projTel                     }-                , funMutual     = Just []-                , funTerminates = Just True+                , _funMutual     = Just []+                , _funTerminates = Just True                 }       lang <- getLanguage       inTopContext $ addConstant projName $-        (defaultDefn defaultArgInfo projName (unDom projType) lang fun)+        (defaultDefn defaultArgInfo projName (unDom projType) lang $ FunctionDefn fun)           { defNoCompilation  = True           , defArgOccurrences = [StrictPos]           }@@ -626,59 +697,602 @@ freshAbstractQName'_ = freshAbstractQName noFixity' . C.simpleName  --- * Special cases of Type------------------------------------------------------------+-- | Defines and returns the name of the `transpIx` function.+defineTranspIx :: QName  -- ^ datatype name+               -> TCM (Maybe QName)+defineTranspIx d = do+  def <- getConstInfo d+  case theDef def of+    Datatype { dataPars = npars+             , dataIxs = nixs+             , dataSort = s}+     -> do+      let t = defType def+      reportSDoc "tc.data.ixs" 20 $ vcat+        [ "name :" <+> prettyTCM d+        , "type :" <+> prettyTCM t+        , "npars:" <+> pretty npars+        , "nixs :" <+> pretty nixs+        ]+      if nixs == 0 then return Nothing else do+      trIx <- freshAbstractQName'_ $ "transpX-" ++ P.prettyShow (A.qnameName d)+      TelV params t' <- telViewUpTo npars t+      TelV ixs    dT <- telViewUpTo nixs t'+      -- params     ⊢ s+      -- params     ⊢ ixs+      -- params.ixs ⊢ dT+      reportSDoc "tc.data.ixs" 20 $ vcat+        [ "params :" <+> prettyTCM params+        , "ixs    :" <+> (addContext params $ prettyTCM ixs)+        , "dT     :" <+> (addContext params $ addContext ixs $ prettyTCM dT)+        ]+      -- theType <- abstract params <$> undefined+      interval <- primIntervalType+      let deltaI = expTelescope interval ixs+      iz <- primIZero+      io@(Con c _ _) <- primIOne+      imin <- getPrimitiveTerm "primIMin"+      imax <- getPrimitiveTerm "primIMax"+      ineg <- getPrimitiveTerm "primINeg"+      transp <- getPrimitiveTerm builtinTrans+      por <- getPrimitiveTerm "primPOr"+      one <- primItIsOne+      -- reportSDoc "trans.rec" 20 $ text $ show params+      -- reportSDoc "trans.rec" 20 $ text $ show deltaI+      -- reportSDoc "trans.rec" 10 $ text $ show fsT --- | A @Type@ with sort @Type l@---   Such a type supports both hcomp and transp.-data LType = LEl Level Term deriving (Eq,Show)+      -- let thePrefix = "transp-"+      -- theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name) -fromLType :: LType -> Type-fromLType (LEl l t) = El (Type l) t+      -- reportSLn "trans.rec" 5 $ ("Generated name: " ++ show theName ++ " " ++ showQNameId theName) -lTypeLevel :: LType -> Level-lTypeLevel (LEl l t) = l+      -- record type in 'exponentiated' context+      -- (params : Γ)(ixs : Δ^I), i : I |- T[params, ixs i]+      let rect' = sub ixs `applySubst` El (raise (size ixs) s) (Def d (teleElims (abstract params ixs) []))+      addContext params $ reportSDoc "tc.data.ixs" 20 $ "deltaI:" <+> prettyTCM deltaI+      addContext params $ addContext deltaI $ addContext ("i"::String, defaultDom interval) $ do+        reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty (sub ixs)+        reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty rect' -toLType :: MonadReduce m => Type -> m (Maybe LType)-toLType ty = do-  sort <- reduce $ getSort ty-  case sort of-    Type l -> return $ Just $ LEl l (unEl ty)-    _      -> return $ Nothing+      theType <- (abstract (setHiding Hidden <$> params) <$>) . (abstract deltaI <$>) $ runNamesT [] $ do+                  rect' <- open (runNames [] $ bind "i" $ \ x -> let _ = x `asTypeOf` pure (undefined :: Term) in+                                                                 pure rect')+                  nPi' "phi" (primIntervalType) $ \ phi ->+                   (absApp <$> rect' <*> pure iz) --> (absApp <$> rect' <*> pure io) -instance Subst LType where-  type SubstArg LType = Term-  applySubst rho (LEl l t) = LEl (applySubst rho l) (applySubst rho t)+      reportSDoc "tc.data.ixs" 20 $ "transpIx:" <+> prettyTCM theType+      let+        ctel = abstract params $ abstract deltaI $ ExtendTel (defaultDom $ subst 0 iz rect') (Abs "t" EmptyTel)+        ps = telePatterns ctel []+        cpi = noConPatternInfo { conPType = Just (defaultArg interval) }+        pat :: NamedArg (Pattern' DBPatVar)+        pat = defaultNamedArg $ ConP c cpi []+        clause = empty+          { clauseTel         = ctel+          , namedClausePats   = init ps ++ [pat, last ps] --- | A @Type@ that either has sort @Type l@ or is a closed definition.---   Such a type supports some version of transp.---   In particular we want to allow the Interval as a @ClosedType@.-data CType = ClosedType Sort QName | LType LType deriving (Eq,Show)+          , clauseBody        = Just $ var 0+          , clauseType        = Just $ defaultArg $ raise 1 $ subst 0 io rect'+          , clauseRecursive   = Just False  -- non-recursive+          , clauseUnreachable = Just False+          } -fromCType :: CType -> Type-fromCType (ClosedType s q) = El s (Def q [])-fromCType (LType t) = fromLType t+      noMutualBlock $ do+        let cs = [ clause ]+--        we do not compile clauses as that leads to throwing missing clauses errors.+--        (mst, _, cc) <- compileClauses Nothing cs+        let fun = emptyFunctionData+                  { _funClauses    = cs+               --   , _funCompiled   = Just cc+               --   , _funSplitTree  = mst+                  , _funProjection = Left MaybeProjection+                  , _funMutual     = Just []+                  , _funTerminates = Just True+                  , _funIsKanOp    = Just d+                  }+        inTopContext $ do+         reportSDoc "tc.transpx.type" 15 $ vcat+           [ "type of" <+> prettyTCM trIx <+> ":"+           , nest 2 $ prettyTCM theType+           ] -toCType :: MonadReduce m => Type -> m (Maybe CType)-toCType ty = do-  sort <- reduce $ getSort ty-  case sort of-    Type l -> return $ Just $ LType (LEl l (unEl ty))-    SSet l  -> do-      t <- reduce (unEl ty)-      case t of-        Def q [] -> return $ Just $ ClosedType (SSet l) q-        _        -> return $ Nothing-    _      -> return $ Nothing+         addConstant trIx $+          (defaultDefn defaultArgInfo trIx theType (Cubical CErased) $ FunctionDefn fun)+            { defNoCompilation  = True+            } -instance Subst CType where-  type SubstArg CType = Term-  applySubst rho (ClosedType s t) = ClosedType (applySubst rho s) t-  applySubst rho (LType t) = LType $ applySubst rho t+        -- reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat+        --   [ "proj" <+> prettyTCM i+        --   , nest 2 $ pretty fun+        --   ]+      -- addContext ctel $ do+      --   let es = teleElims ctel []+      --   r <- reduce $ Def trIx es+      --   reportSDoc "tc.data.ixs" 20 $ "reducedx:" <+> prettyTCM r+      --   r <- reduce $ Def trIx (init es ++ [Apply $ argN io, last es])+      --   reportSDoc "tc.data.ixs" 20 $ "reduced1:" <+> prettyTCM r+      return $ Just trIx+    _ -> __IMPOSSIBLE__+  where +    -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ+    sub tel = expS $ size tel -defineTranspOrHCompForFields-  :: TranspOrHComp++defineTranspFun :: QName -- ^ datatype+                -> Maybe QName -- ^ transpX "constructor"+                -> [QName]     -- ^ constructor names+                -> [QName]     -- ^ path cons+                -> TCM (Maybe QName) -- transp function for the datatype.+defineTranspFun d mtrX cons pathCons = do+  def <- getConstInfo d+  case theDef def of+    Datatype { dataPars = npars+             , dataIxs = nixs+             , dataSort = s@(Type _)+--             , dataCons = cons -- not there yet+             }+     -> do+      let t = defType def+      reportSDoc "tc.data.transp" 20 $ vcat+        [ "name :" <+> prettyTCM d+        , "type :" <+> prettyTCM t+        , "npars:" <+> pretty npars+        , "nixs :" <+> pretty nixs+        ]+      trD <- freshAbstractQName'_ $ "transp" ++ P.prettyShow (A.qnameName d)+      TelV params t' <- telViewUpTo npars t+      TelV ixs    dT <- telViewUpTo nixs t'++      let tel = abstract params ixs+      mixs <- runMaybeT $ traverse (traverse (MaybeT . toLType)) ixs+      caseMaybe mixs (return Nothing) $ \ _ -> do++      io@(Con io_c _ []) <- primIOne+      iz <- primIZero++      interval <- primIntervalType+      let telI = expTelescope interval tel+          sigma = sub tel+          dTs = (sigma `applySubst` El s (Def d $ map Apply $ teleArgs tel))++      theType <- (abstract telI <$>) $ runNamesT [] $ do+                  dT <- open $ Abs "i" $ dTs+                  nPi' "phi" primIntervalType $ \ phi ->+                   (absApp <$> dT <*> pure iz) --> (absApp <$> dT <*> pure io)+++      reportSDoc "tc.data.transp" 20 $ "transpD:" <+> prettyTCM theType+++      noMutualBlock $ do+        inTopContext $ addConstant trD $+          (defaultDefn defaultArgInfo trD theType (Cubical CErased) emptyFunction)+        let+          ctel = abstract telI $ ExtendTel (defaultDom $ subst 0 iz dTs) (Abs "t" EmptyTel)+          ps = telePatterns ctel []+          cpi = noConPatternInfo { conPType = Just (defaultArg interval)+                                 , conPFallThrough = True+                                 }+          pat :: NamedArg (Pattern' DBPatVar)+          pat = defaultNamedArg $ ConP io_c cpi []+          clause = empty+            { clauseTel         = ctel+            , namedClausePats   = init ps ++ [pat, last ps]++            , clauseBody        = Just $ var 0+            , clauseType        = Just $ defaultArg $ raise 1 $ subst 0 io dTs+            , clauseRecursive   = Just False  -- non-recursive+            , clauseUnreachable = Just False+            }+        let debugNoTransp cl = enterClosure cl $ \ t -> do+              reportSDoc "tc.data.transp" 20 $ addContext ("i" :: String, __DUMMY_DOM__) $+                "could not transp" <+> prettyTCM (absBody t)+        -- TODO: if no params nor indexes trD phi u0 = u0.+        ecs <- tryTranspError $ (clause:) <$> defineConClause trD (not $ null pathCons) mtrX npars nixs ixs telI sigma dTs cons+        caseEitherM (pure ecs) (\ cl -> debugNoTransp cl >> return Nothing) $ \ cs -> do+        (mst, _, cc) <- compileClauses Nothing cs+        let fun = emptyFunctionData+                  { _funClauses    = cs+                  , _funCompiled   = Just cc+                  , _funSplitTree  = mst+                  , _funProjection = Left MaybeProjection+                  , _funMutual     = Just []+                  , _funTerminates = Just True+                  , _funIsKanOp    = Just d+                  }+        inTopContext $ addConstant trD $+          (defaultDefn defaultArgInfo trD theType (Cubical CErased) $ FunctionDefn fun)+            { defNoCompilation  = True+            }+        reportSDoc "tc.data.transp" 20 $ sep+          [ "transp: compiled clauses of " <+> prettyTCM trD+          , nest 2 $ return $ P.pretty cc+          ]++        return $ Just trD+++    Datatype {} -> return Nothing+    _           -> __IMPOSSIBLE__+  where+    -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ+    sub tel = expS (size tel)++defineConClause :: QName -- ^ trD+                -> Bool  -- ^ HIT+                -> Maybe QName -- ^ trX+                -> Nat  -- ^ npars = size Δ+                -> Nat  -- ^ nixs = size X+                -> Telescope -- ^ Δ ⊢ X+                -> Telescope -- ^ (Δ.X)^I+                -> Substitution -- ^ (Δ.X)^I, i : I ⊢ σ : Δ.X+                -> Type       -- ^ (Δ.X)^I, i : I ⊢ D[δ i,x i] -- datatype+                -> [QName]      -- ^ Constructors+                -> TCM [Clause]+defineConClause trD' isHIT mtrX npars nixs xTel' telI sigma dT' cnames = do++  unless (isNothing mtrX == (nixs == 0)) $ __IMPOSSIBLE__++  io <- primIOne+  iz <- primIZero+  tHComp <- primHComp+  tINeg <- primINeg+  let max i j = cl primIMax <@> i <@> j+  let min i j = cl primIMin <@> i <@> j+  let neg i = cl primINeg <@> i+  let hcomp ty sys u0 = do+          ty <- ty+          Just (LEl l ty) <- toLType ty+          l <- open $ Level l+          ty <- open $ ty+          face <- (foldr max (pure iz) $ map fst $ sys)+          sys <- lam "i'" $ \ i -> combineSys l ty [(phi, u <@> i) | (phi,u) <- sys]+          pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0+  interval <- primIntervalType+  let intervalTel nm = ExtendTel (defaultDom interval) (Abs nm EmptyTel)++  let (parI,ixsI) = splitTelescopeAt npars telI+  let+    abstract_trD :: MonadFail m => (Vars m -> Vars m -> Vars m -> NamesT m Telescope) -> NamesT m Telescope+    abstract_trD k = do+               ixsI <- open $ AbsN (teleNames parI) ixsI+               parI <- open parI+               abstractN parI $ \ delta -> do+               abstractN (ixsI `applyN` delta) $ \ x -> do+               abstractN (pure $ intervalTel "phi") $ \ phi -> do+               k delta x phi+    bind_trD :: MonadFail m => (ArgVars m -> ArgVars m -> ArgVars m -> NamesT m b) ->+                NamesT m (AbsN (AbsN (AbsN b)))+    bind_trD k = do+      bindNArg (teleArgNames parI) $ \ delta_ps -> do+      bindNArg (teleArgNames ixsI) $ \ x_ps -> do+      bindNArg (teleArgNames $ intervalTel "phi") $ \ phi_ps -> do+      k delta_ps x_ps phi_ps+  let trD = bindNArg (teleArgNames parI) $ \ delta ->+            bindNArg (teleArgNames ixsI) $ \ x ->+            bindN ["phi","u0"]           $ \ [phi,u0] ->+              ((Def trD' [] `apply`) <$> sequence (delta ++ x)) <@> phi <@> u0+  -- [Δ] ⊢ X+  let xTel = pure $ AbsN (teleNames parI) xTel'+  -- [δ : Δ^I, x : X^I, i : I] ⊢ D (δ i) (x i)+  let dT = pure $ AbsN (teleNames parI ++ teleNames ixsI ++ ["i"]) dT'++  let hcompComputes = not $ isHIT || nixs > 0+  c_HComp <- if hcompComputes then return [] else do+      reportSDoc "tc.data.transp.con" 20 $ "======================="+      reportSDoc "tc.data.transp.con" 20 $ "hcomp"+      qHComp <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp+      hcomp_ty <- defType <$> getConstInfo qHComp+      gamma <- runNamesT [] $ do+               ixsI <- open $ AbsN (teleNames parI) ixsI+               parI <- open parI+               abstract_trD $ \ delta x _ -> do+               Just (LEl l ty) <- toLType =<< (dT `applyN` (delta ++ x ++ [pure iz]))+               -- (φ : I), (I → Partial φ (D (δ i0) (x i0))), D (δ i0) (x i0)+               TelV args _ <- lift $ telView =<< piApplyM hcomp_ty [Level l,ty]+               unless (size args == 3) __IMPOSSIBLE__+               pure args+      res <- runNamesT [] $ do+        let hcompArgs = map argN ["phi","u","u0"]+        bind_trD $ \ delta_ps x_ps phi_ps -> do+        let x = map (fmap unArg) x_ps+        let delta = map (fmap unArg) delta_ps+        let [phi] = map (fmap unArg) phi_ps+        bindNArg hcompArgs $ \ as0 -> do -- as0 : aTel[delta 0]+        let+          origPHComp = do+            Just (LEl l t) <- toLType =<< (dT `applyN` (delta ++ x ++ [pure iz]))+            let ds = map (argH . unnamed . dotP) [Level l, t]+            ps0@[_hphi,_u,_u0] <- sequence $ as0+            pure $ DefP defaultPatternInfo qHComp $ ds ++ ps0+          psHComp = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPHComp]+        let+          rhsTy = dT `applyN` (delta ++ x ++ [pure io])+        -- trD δ x φ (hcomp [hφ ↦ u] u0) ↦ rhsHComp+        let rhsHComp = do+              let [hphi,u,u0] = map (fmap unArg) as0+              -- TODO: should trD be transp for the datatype?+              let baseHComp = trD `applyN` delta `applyN` x `applyN` [phi,u0]+              let sideHComp = lam "i" $ \ i -> ilam "o" $ \ o -> do+                     trD `applyN` delta `applyN` x `applyN` [phi,u <@> i <..> o]+              hcomp rhsTy [(hphi, sideHComp)] baseHComp+        (,,) <$> psHComp <*> rhsTy <*> rhsHComp+      let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res+      (:[]) <$> mkClause gamma ps rhsTy rhs+++  c_trX   <- caseMaybe mtrX (pure []) $ \ trX -> do+        reportSDoc "tc.data.transp.con" 20 $ "======================="+        reportSDoc "tc.data.transp.con" 20 $ prettyTCM trX+        gamma <- runNamesT [] $ do+                     ixsI <- open $ AbsN (teleNames parI) ixsI+                     parI <- open parI+                     abstract_trD $ \ delta _ _ -> do+                     let delta0_refl = flip map delta $ \ p -> lam "i" $ \ _ -> p <@> pure iz+                     abstractN (ixsI `applyN` delta0_refl) $ \ x' -> do+                     abstractN (pure $ intervalTel "phi'") $ \ _ -> do+                     ty <- dT `applyN` (delta0_refl ++ x' ++ [pure iz])+                     pure $ ExtendTel (defaultDom ty) $ Abs "t" EmptyTel+        res <- runNamesT [] $+          bind_trD $ \ delta_ps x_ps phi_ps -> do+          let x = map (fmap unArg) x_ps+          let delta = map (fmap unArg) delta_ps+          let [phi] = map (fmap unArg) phi_ps+          --- pattern matching args below+          bindNArg (map (fmap (++ "'")) (teleArgNames ixsI)) $ \ x'_ps -> do+          let x' = map (fmap unArg) x'_ps :: [NamesT TCM Term]+          let phi'name = teleArgNames $ intervalTel "phi'"+          bindNArg phi'name $ \ phi'_ps -> do+          let phi's = map (fmap unArg) phi'_ps+          bindNArg [argN "t"] $ \ as0 -> do+          let deltaArg i = do+                i <- i+                xs <- sequence delta_ps+                pure $ map (fmap (`apply` [argN i])) xs++          let+            origPTrX = do+              x'_ps <- sequence x'_ps+              phi'_ps <- sequence phi'_ps+              ds <- map (setHiding Hidden . fmap (unnamed . dotP)) <$> deltaArg (pure iz)+              ps0@[_t] <- sequence as0+              pure $ DefP defaultPatternInfo trX $ ds ++ x'_ps ++ phi'_ps ++ ps0+            psTrX = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origPTrX]++            rhsTy = dT `applyN` (delta ++ x ++ [pure io])++          -- trD δ x φ (trX x' φ' t) ↦ rhsTrx+          let rhsTrX = do+                let [t] = map (fmap unArg) as0+                let [phi'] = phi's+                let telXdeltai = bind "i" $ \ i -> applyN xTel (map (<@> i) delta)+                let reflx1 = flip map x $ \ q -> lam "i" $ \ _ -> q <@> pure io+                let symx' = flip map x' $ \ q' -> lam "i" $ \ i -> q' <@> neg i+                x_tr <- mapM (open . unArg) =<< transpPathTel' telXdeltai symx' reflx1 phi' x+                let baseTrX = trD `applyN` delta `applyN` x_tr `applyN` [phi `min` phi',t]+                let sideTrX = lam "j" $ \ j -> ilam "o" $ \ _ -> do+                      let trD_f = trD `applyN` (flip map delta $ \ p -> lam "i" $ \ i -> p <@> (i `min` neg j))+                                      `applyN` (flip map x_tr  $ \ p -> lam "i" $ \ i -> p <@> (i `min` neg j))+                                      `applyN` [(phi `min` phi') `max` j,t]+                      let x_tr_f = fmap (fmap (\ (Abs n (Arg i t)) -> Arg i $ Lam defaultArgInfo (Abs n t)) . sequence) $+                           bind "i" $ \ i -> do+                            j <- j+                            map (fmap (`apply` [argN j])) <$> trFillPathTel' telXdeltai symx' reflx1 phi' x (neg i)+                      let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) x_tr_f+                      (apply (Def trX []) <$> args) <@> (phi' `max` neg j) <@> trD_f+                hcomp rhsTy [(phi,sideTrX),(phi',lam "i" $ \ _ -> ilam "o" $ \ _ -> baseTrX)]+                            baseTrX++          (,,) <$> psTrX <*> rhsTy <*> rhsTrX+++        let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ res+        (:[]) <$> mkClause gamma ps rhsTy rhs++  fmap ((c_HComp ++ c_trX) ++) $ forM cnames $ \ cname -> do+    def <- getConstInfo cname+    let+      Constructor+       { conPars = npars'+       , conArity = nargs+       , conSrcCon = chead+       } = theDef def+    do+        let tcon = defType def++        reportSDoc "tc.data.transp.con" 20 $ "======================="+        reportSDoc "tc.data.transp.con" 20 $ "tcon:" <+> prettyTCM (conName chead) <+> prettyTCM tcon++        unless (conName chead == cname && npars' == npars) $ __IMPOSSIBLE__+++        TelV prm tcon' <- telViewUpTo npars' tcon+        -- Δ ⊢ aTel+        -- Δ.aTel ⊢ ty+        -- Δ.aTel ⊢ [(φ,(l,r))] = boundary : ty+        (TelV aTel ty, boundary) <- telViewUpToPathBoundary nargs tcon'++        Def _ es <- unEl <$> reduce ty+        -- Δ.aTel ⊢ con_ixs : X+        let con_ixs = fromMaybe __IMPOSSIBLE__ $ allApplyElims $ drop npars es++        reportSDoc "tc.data.transp.con" 20 $+          addContext prm $ "aTel:" <+> prettyTCM aTel+        reportSDoc "tc.data.transp.con" 20 $+          addContext prm $ addContext aTel $ "ty:" <+> prettyTCM ty+        reportSDoc "tc.data.transp.con" 20 $+          addContext prm $ addContext aTel $ "boundary:" <+> prettyTCM boundary++        gamma <- runNamesT [] $ do+                     ixsI <- open $ AbsN (teleNames parI) ixsI+                     aTel <- open $ AbsN (teleNames prm) aTel+                     parI <- open parI+                     abstract_trD $ \ delta _ _ -> do+                     let args = aTel `applyN` map (<@> pure iz) delta+                     args+        res <- runNamesT [] $ do+          let aTelNames = teleNames aTel+              aTelArgs = teleArgNames aTel+          con_ixs <- open $ AbsN (teleNames prm ++ teleNames aTel) $ map unArg con_ixs+          bndry <- open $ AbsN (teleNames prm ++ teleNames aTel) $ boundary+          u    <- open $ AbsN (teleNames prm ++ aTelNames) $ Con chead ConOSystem (teleElims aTel boundary)+          aTel <- open $ AbsN (teleNames prm) aTel+          -- bsys : Abs Δ.Args ([phi] → ty)+          (bsysFace,bsys) <- do+            p <- bindN (teleNames prm ++ aTelNames) $ \ ts -> do+              Just (LEl l ty) <- toLType ty+              l <- open (Level l)+              ty <- open ty+              bs <- bndry `applyN` ts+              xs <- mapM (\(phi,u) -> (,) <$> open phi <*> open u) $ do+                (i,(l,r)) <- bs+                let pElem t = Lam (setRelevance Irrelevant defaultArgInfo) $ NoAbs "o" t+                [(tINeg `apply` [argN i],pElem l),(i,pElem r)]+              combineSys' l ty xs+            (,) <$> open (fst <$> p) <*> open (snd <$> p)+          bind_trD $ \ delta_ps x_ps phi_ps -> do+          let x = map (fmap unArg) x_ps+          let delta = map (fmap unArg) delta_ps+          let [phi] = map (fmap unArg) phi_ps+          --- pattern matching args below+          bindNArg aTelArgs $ \ as0 -> do -- as0 : aTel[delta 0]++          let aTel0 = aTel `applyN` map (<@> pure iz) delta++          -- telePatterns is not context invariant, so we need an open here where the context ends in aTel0.+          ps0 <- (open =<<) $ (telePatterns <$> aTel0 <*> (applyN bndry $ map (<@> pure iz) delta ++ map (fmap unArg) as0))++          let deltaArg i = do+                i <- i+                xs <- sequence delta_ps+                pure $ map (fmap (`apply` [argN i])) xs++          let+            origP = ConP chead noConPatternInfo <$> ps0+            ps = sequence $ delta_ps ++ x_ps ++ phi_ps ++ [argN . unnamed <$> origP]+          let+            orig = patternToTerm <$> origP+            rhsTy = dT `applyN` (delta ++ x ++ [pure io])++          (,,) <$> ps <*> rhsTy <*> do++          -- Declared Constructors.+          let aTelI = bind "i" $ \ i -> aTel `applyN` map (<@> i) delta++          eas1 <- (=<<) (lift . runExceptT) $ transpTel <$> aTelI <*> phi <*> sequence as0++          caseEitherM (pure eas1) (lift . lift . E.throw . CannotTransp) $ \ as1 -> do++          as1 <- mapM (open . unArg) as1++          as01 <- (open =<<) $ bind "i" $ \ i -> do+            eas01 <- (=<<) (lift . runExceptT) $ trFillTel <$> aTelI <*> phi <*> sequence as0 <*> i+            caseEitherM (pure eas01) (lift . lift . E.throw . CannotTransp) pure++          let argApp a t = liftM2 (\ a t -> fmap (`apply` [argN t]) a) a t+          let+            argLam :: MonadFail m => String -> (Var m -> NamesT m (Arg Term)) -> NamesT m (Arg Term)+            argLam n f = (\ (Abs n (Arg i t)) -> Arg i $ Lam defaultArgInfo $ Abs n t) <$> bind "n" f+          let cas1 = applyN u $ map (<@> pure io) delta ++ as1++          let base | Nothing <- mtrX = cas1+                   | Just trX <- mtrX = do+                       let theTel = bind "j" $ \ j -> bind "i" $ \ i -> applyN xTel (map (<@> max i j) delta)+                       let theLeft = lamTel $ bind "i" $ \ i -> do+                             as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i)+                             con_ixs `applyN` (map (<@> i) delta ++ as01)+                       theLeft <- mapM open =<< theLeft+                       theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> do+                         con_ixs `applyN` (map (<@> pure io) delta ++ as1)++                       trx' <- transpPathPTel' theTel x theRight phi theLeft+                       let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io)) (forM trx' $ \ q' -> do+                                                                       q' <- open q'+                                                                       argLam "i" $ \ i -> q' `argApp` neg i)+                       (apply (Def trX []) <$> args) <@> phi <@> cas1+++          if null boundary then base else do++          -- We have to correct the boundary for path constructors.++          -- bline : Abs I ([phi] → ty)+          let blineFace = applyN bsysFace $ map (<@> pure io) delta ++ as1+          let bline = do+                let theTel = bind "j" $ \ j -> bind "i" $ \ i -> applyN xTel (map (<@> max i j) delta)+                let theLeft = lamTel $ bind "i" $ \ i -> do+                      as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i)+                      con_ixs `applyN` (map (<@> i) delta ++ as01)+                theLeft <- mapM open =<< theLeft+                theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ i -> do+                  con_ixs `applyN` (map (<@> pure io) delta ++ as1)+                let q2_f = bind "i" $ \ i -> map unArg <$> trFillPathPTel' theTel x theRight phi theLeft i++                lam "i" $ \ i -> do+                let v0 = do+                     as01 <- mapM (open . unArg) =<< (absApp <$> as01 <*> i)+                     applyN bsys $ map (<@> i) delta ++ as01+                let squeezedv0 = ilam "o" $ \ o -> do+                      let+                        delta_f :: [NamesT TCM Term]+                        delta_f = flip map delta $ \ p -> lam "j" $ \ j -> p <@> (j `max` i)+                      x_f <- (mapM open =<<) $ lamTel $ bind "j" $ \ j ->+                                 (absApp <$> q2_f <*> j) `appTel` i+                      trD `applyN` delta_f `applyN` x_f `applyN` [phi `max` i, v0 <..> o]++                caseMaybe mtrX squeezedv0 $ \ trX -> ilam "o" $ \ o -> do+                  q2 <- transpPathPTel' theTel x theRight phi theLeft+                  let args = liftM2 (++) (map (setHiding Hidden) <$> deltaArg (pure io))+                                         (forM q2 $ \ q' -> do+                                            q' <- open q'+                                            argLam "j" $ \ j -> q' `argApp` (neg j `min` i))++                  (apply (Def trX []) <$> args) <@> (neg i `max` phi) <@> (squeezedv0 <..> o)+          hcomp+             rhsTy+             [(blineFace,lam "i" $ \ i -> bline <@> (neg i))+             ,(phi      ,lam "i" $ \ _ -> ilam "o" $ \ _ -> orig)+             ]+             base++        let+          (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res+        mkClause gamma ps rhsTy rhs+  where+    mkClause gamma ps rhsTy rhs = do+      let+        c = Clause+            { clauseTel         = gamma+            , clauseType        = Just . argN $ rhsTy+            , namedClausePats   = ps+            , clauseFullRange   = noRange+            , clauseLHSRange    = noRange+            , clauseCatchall    = False+            , clauseBody        = Just $ rhs+            , clauseRecursive   = Nothing+            -- it is indirectly recursive through transp, does it count?+            , clauseUnreachable = Just False+            , clauseEllipsis    = NoEllipsis+            , clauseExact       = Nothing+            , clauseWhereModule = Nothing+            }+      reportSDoc "tc.data.transp.con" 20 $+        "gamma:" <+> prettyTCM gamma+      reportSDoc "tc.data.transp.con" 20 $ addContext gamma $+        "ps   :" <+> prettyTCM (patternsToElims ps)+      reportSDoc "tc.data.transp.con" 20 $ addContext gamma $+        "type :" <+> prettyTCM rhsTy+      reportSDoc "tc.data.transp.con" 20 $ addContext gamma $+        "body :" <+> prettyTCM rhs++      reportSDoc "tc.data.transp.con" 30 $+        addContext gamma $ "c:" <+> pretty c+      return c+++defineKanOperationForFields+  :: Command   -> (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ   -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term   -> QName       -- ^ some name, e.g. record name@@ -687,7 +1301,7 @@   -> [Arg QName] -- ^ fields' names   -> Type        -- ^ record type Δ ⊢ T   -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution))-defineTranspOrHCompForFields cmd pathCons project name params fsT fns rect =+defineKanOperationForFields cmd pathCons project name params fsT fns rect =    case cmd of        DoTransp -> runMaybeT $ do          fsT' <- traverse (traverse (MaybeT . toCType)) fsT@@ -709,6 +1323,13 @@   -> [Arg QName] -- ^ fields' names   -> Type        -- ^ record type Δ ⊢ T   -> TCM ((QName, Telescope, Type, [Dom Type], [Term]), Substitution)+     -- ^ @((name, tel, rtype, clause_types, bodies), sigma)@+     --   name: name of transport function for this constructor/record. clauses still missing.+     --   tel: Ξ telescope for the RHS, Ξ ⊃ (Δ^I, φ : I), also Ξ ⊢ us0 : Φ[δ 0]+     --   rtype: Ξ ⊢ T' := T[δ 1]+     --   clause_types: Ξ ⊢ Φ' := Φ[δ 1]+     --   bodies: Ξ ⊢ us1 : Φ'+     --   sigma:  Ξ, i : I ⊢ σ : Δ.Φ -- line [δ 0,us0] ≡ [δ 0,us1] defineTranspForFields pathCons applyProj name params fsT fns rect = do   interval <- primIntervalType   let deltaI = expTelescope interval params@@ -720,9 +1341,9 @@   transp <- getPrimitiveTerm builtinTrans   -- por <- getPrimitiveTerm "primPOr"   -- one <- primItIsOne-  reportSDoc "trans.rec" 20 $ text $ show params-  reportSDoc "trans.rec" 20 $ text $ show deltaI-  reportSDoc "trans.rec" 10 $ text $ show fsT+  reportSDoc "trans.rec" 20 $ pretty params+  reportSDoc "trans.rec" 20 $ pretty deltaI+  reportSDoc "trans.rec" 10 $ pretty fsT    let thePrefix = "transp-"   theName <- freshAbstractQName'_ $ thePrefix ++ P.prettyShow (A.qnameName name)@@ -741,7 +1362,7 @@   lang <- getLanguage   noMutualBlock $ addConstant theName $     (defaultDefn defaultArgInfo theName theType lang-       (emptyFunction { funTerminates = Just True }))+       (FunctionDefn $ emptyFunctionData { _funTerminates = Just True, _funIsKanOp = Just name }))       { defNoCompilation = True }   -- ⊢ Γ = gamma = (δ : Δ^I) (φ : I) (u0 : R (δ i0))   -- Γ ⊢     rtype = R (δ i1)@@ -852,17 +1473,7 @@     -- (params : Δ^I), i : I |- T[params i]     rect' = sub params `applySubst` rect     -- Δ^I, i : I |- sub Δ : Δ-    sub tel = parallelS [ var n `apply` [Arg defaultArgInfo $ var 0] | n <- [1..size tel] ]-    -- given I type, and Δ telescope, build Δ^I such that-    -- (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...)-    expTelescope :: Type -> Telescope -> Telescope-    expTelescope int tel = unflattenTel names ys-      where-        xs = flattenTel tel-        names = teleNames tel-        t = ExtendTel (defaultDom $ raise (size tel) int) (Abs "i" EmptyTel)-        s = sub tel-        ys = map (fmap (abstract t) . applySubst s) xs+    sub tel = expS $ size tel  -- invariant: resulting tel Γ is such that Γ = (δ : Δ), (φ : I), (u : ...), (a0 : R δ)) --            where u and a0 have types matching the arguments of primHComp.@@ -909,7 +1520,7 @@   lang <- getLanguage   noMutualBlock $ addConstant theName $     (defaultDefn defaultArgInfo theName theType lang-       (emptyFunction { funTerminates = Just True }))+       (FunctionDefn $ emptyFunctionData { _funTerminates = Just True, _funIsKanOp = Just name }))       { defNoCompilation = True }   --   ⊢ Γ = gamma = (δ : Δ) (φ : I) (_ : (i : I) -> Partial φ (R δ)) (_ : R δ)   -- Γ ⊢     rtype = R δ@@ -996,7 +1607,7 @@              comp lvl                   filled_ty                   phi-                  (lam "i" $ \ i -> lam "o" $ \ o -> proj $ w <@> i <@> o) -- TODO wait for phi = 1+                  (lam "i" $ \ i -> ilam "o" $ \ o -> proj $ w <@> i <..> o) -- TODO wait for phi = 1                   (proj w0)    reportSDoc "hcomp.rec" 60 $ text $ "filled_types sorts:" ++ show (map (getSort . fromLType . unDom) filled_types)@@ -1118,9 +1729,9 @@   -- noConstraints $ s' `leqSort` s    withoutK <- withoutKOption-  when withoutK $ whenM (isFibrant s) $ do+  when withoutK $ do     q <- viewTC eQuantity-    usableAtModality (setQuantity q defaultModality) (unEl t)+    usableAtModality' (Just s) ConstructorType (setQuantity q defaultModality) (unEl t)    fitsIn' withoutK forceds t s   where
+ src/full/Agda/TypeChecking/Rules/Data.hs-boot view
@@ -0,0 +1,6 @@+module Agda.TypeChecking.Rules.Data where++import Agda.Syntax.Internal         ( QName, Sort )+import Agda.TypeChecking.Monad.Base ( TCM )++checkDataSort :: QName -> Sort -> TCM ()
src/full/Agda/TypeChecking/Rules/Decl.hs view
@@ -9,8 +9,7 @@  import Data.Either (partitionEithers) import qualified Data.Foldable as Fold-import qualified Data.IntMap as IntMap-import qualified Data.IntSet as IntSet+import qualified Data.Map.Strict as MapS import Data.Maybe import qualified Data.Set as Set import Data.Set (Set)@@ -194,6 +193,9 @@       -- TODO: Benchmarking for unquote.       A.UnquoteDecl mi is xs e -> checkMaybeAbstractly is $ checkUnquoteDecl mi is xs e       A.UnquoteDef is xs e     -> impossible $ checkMaybeAbstractly is $ checkUnquoteDef is xs e+      A.UnquoteData is x uc js cs e -> checkMaybeAbstractly (is ++ js) $ do+        reportSDoc "tc.unquote.data" 20 $ "Checking unquoteDecl data" <+> prettyTCM x+        Nothing <$ unquoteTop (x:cs) e      whenNothingM (asksTC envMutualBlock) $ do @@ -201,7 +203,8 @@       highlight_ DontHightlightModuleContents d        -- Defaulting of levels (only when --cumulativity)-      whenM (optCumulativity <$> pragmaOptions) $ defaultLevelsToZero metas+      whenM (optCumulativity <$> pragmaOptions) $+        defaultLevelsToZero (openMetas metas)        -- Post-typing checks.       whenJust finalChecks $ \ theMutualChecks -> do@@ -213,17 +216,13 @@         case d of             A.Generalize{} -> pure ()             _ -> do-              reportSLn "tc.decl" 20 $ "Freezing all metas."-              void $ freezeMetas metas+              reportSLn "tc.decl" 20 $ "Freezing all open metas."+              void $ freezeMetas (openMetas metas)          theMutualChecks      where -    -- check record or data type signature-    checkSig kind i x gtel t = checkTypeSignature' (Just gtel) $-      A.Axiom kind i defaultArgInfo Nothing x t-     -- Switch maybe to abstract mode, benchmark, and debug print bracket.     check :: forall m i a           . ( MonadTCEnv m, MonadPretty m, MonadDebug m@@ -308,7 +307,7 @@     case theDef def of       Record{ recEtaEquality' = Inferred YesEta } -> return $ Just $ Left q       Function-        { funProjection = Nothing+        { funProjection = Left MaybeProjection             -- Andreas, 2017-08-10, issue #2664:             -- Do not record pattern translate record projection definitions!         , funCompiled   = Just cc@@ -384,6 +383,10 @@ --   mutual block we have. Hence the flag. highlight_ :: HighlightModuleContents -> A.Declaration -> TCM () highlight_ hlmod d = do+  reportSDoc "tc.decl" 45 $+    text "Highlighting a declaration with the following spine:"+      $$+    text (show $ A.declarationSpine d)   let highlight d = generateAndPrintSyntaxInfo d Full True   Bench.billTo [Bench.Highlighting] $ case d of     A.Axiom{}                -> highlight d@@ -402,11 +405,13 @@     A.Generalize{}           -> highlight d     A.UnquoteDecl{}          -> highlight d     A.UnquoteDef{}           -> highlight d+    A.UnquoteData{}           -> highlight d     A.Section i x tel ds     -> do       highlight (A.Section i x tel [])       when (hlmod == DoHighlightModuleContents) $ mapM_ (highlight_ hlmod) (deepUnscopeDecls ds)     A.RecSig{}               -> highlight d-    A.RecDef i x uc dir ps tel cs -> highlight (A.RecDef i x uc dir A.noDataDefParams dummy cs)+    A.RecDef i x uc dir ps tel cs ->+      highlight (A.RecDef i x uc dir ps dummy cs)       -- The telescope has already been highlighted.       where       -- Andreas, 2016-01-22, issue 1790@@ -524,10 +529,12 @@     (a, ms) <- metasCreatedBy m     reportSLn "tc.decl" 20 $ "Attempting to solve constraints before freezing."     wakeupConstraints_   -- solve emptiness and instance constraints-    xs <- freezeMetas ms+    xs <- freezeMetas (openMetas ms)     reportSDoc "tc.decl.ax" 20 $ vcat-      [ "Abstract type signature produced new metas: " <+> sep (map prettyTCM $ IntMap.keys ms)-      , "We froze the following ones of these:       " <+> sep (map prettyTCM $ IntSet.toList xs)+      [ "Abstract type signature produced new open metas: " <+>+        sep (map prettyTCM $ MapS.keys (openMetas ms))+      , "We froze the following ones of these:            " <+>+        sep (map prettyTCM $ Set.toList xs)       ]     return a @@ -635,8 +642,8 @@    -- Set blocking tag to MissingClauses if we still expect clauses   let blk = case kind of-        FunName   -> NotBlocked MissingClauses   ()-        MacroName -> NotBlocked MissingClauses   ()+        FunName   -> NotBlocked (MissingClauses x) ()+        MacroName -> NotBlocked (MissingClauses x) ()         _         -> NotBlocked ReallyNotBlocked ()    -- Not safe. See Issue 330@@ -645,12 +652,13 @@   lang <- getLanguage   let defn = defaultDefn info x t lang $         case kind of   -- #4833: set abstract already here so it can be inherited by with functions-          FunName   -> emptyFunction{ funAbstr = Info.defAbstract i }-          MacroName -> set funMacro True emptyFunction{ funAbstr = Info.defAbstract i }+          FunName   -> fun+          MacroName -> set funMacro True fun           DataName  -> DataOrRecSig npars           RecName   -> DataOrRecSig npars           AxiomName -> defaultAxiom     -- Old comment: NB: used also for data and record type sigs           _         -> __IMPOSSIBLE__+        where fun = FunctionDefn $ emptyFunctionData{ _funAbstr = Info.defAbstract i }    addConstant x =<< do     useTerPragma $ defn@@ -741,6 +749,12 @@             Function{} -> markStatic x             _          -> typeError $ GenericError "STATIC directive only works on functions"         A.InjectivePragma x -> markInjective x+        A.NotProjectionLikePragma qn -> do+          def <- getConstInfo qn+          case theDef def of+            it@Function{} ->+              modifyGlobalDefinition qn $ \def -> def { theDef = it { funProjection = Left NeverProjection } }+            _ -> typeError $ GenericError "NOT_PROJECTION_LIKE directive only applies to functions"         A.InlinePragma b x -> do           def <- getConstInfo x           case theDef def of@@ -781,6 +795,12 @@    (blockId, ) . mutualNames <$> lookupMutualBlock blockId +    -- check record or data type signature+checkSig :: KindOfName -> A.DefInfo -> QName -> A.GeneralizeTelescope -> A.Expr -> TCM ()+checkSig kind i x gtel t = checkTypeSignature' (Just gtel) $+  A.Axiom kind i defaultArgInfo Nothing x t++ -- | Type check the type signature of an inductive or recursive definition. checkTypeSignature :: A.TypeSignature -> TCM () checkTypeSignature = checkTypeSignature' Nothing@@ -1029,6 +1049,7 @@       A.UnquoteDecl  {} -> "UnquoteDecl"       A.ScopedDecl   {} -> "ScopedDecl"       A.UnquoteDef   {} -> "UnquoteDef"+      A.UnquoteData   {} -> "UnquoteDecl data"  debugPrintDecl :: A.Declaration -> TCM () debugPrintDecl d = do
src/full/Agda/TypeChecking/Rules/Decl.hs-boot view
@@ -3,8 +3,10 @@  import Agda.Syntax.Info (ModuleInfo) import Agda.Syntax.Abstract+import Agda.Syntax.Scope.Base import Agda.TypeChecking.Monad.Base (TCM)  checkDecls :: [Declaration] -> TCM () checkDecl  :: Declaration -> TCM ()+checkSig   :: KindOfName -> DefInfo -> QName -> GeneralizeTelescope -> Expr -> TCM () checkSectionApplication :: ModuleInfo -> ModuleName -> ModuleApplication -> ScopeCopyInfo -> TCM ()
src/full/Agda/TypeChecking/Rules/Def.hs view
@@ -8,7 +8,7 @@ import Control.Monad.Except ( MonadError(..) )  import Data.Bifunctor-import Data.Function+import Data.Function (on) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.List as List@@ -73,6 +73,7 @@ import qualified Agda.Utils.SmallSet as SmallSet  import Agda.Utils.Impossible+import Agda.Utils.WithDefault  --------------------------------------------------------------------------- -- * Definitions by pattern matching@@ -82,7 +83,7 @@ checkFunDef delayed i name cs = do         -- Reset blocking tag (in case a previous attempt was blocked)         modifySignature $ updateDefinition name $ updateDefBlocked $ const $-          NotBlocked MissingClauses ()+          NotBlocked (MissingClauses name) ()         -- Get the type and relevance of the function         def <- instantiateDef =<< getConstInfo name         let t    = defType def@@ -97,7 +98,7 @@                 -- See issue 729.                 -- Ulf, 2021-02-09: also unfreeze metas in the sort of this type                 whenM (isFrozen x) $ do-                  xs <- allMetasList . jMetaType . mvJudgement <$> lookupMeta x+                  xs <- allMetasList . jMetaType . mvJudgement <$> lookupLocalMeta x                   mapM_ unfreezeMeta (x : xs)                 checkAlias t info delayed i name e mc             | otherwise -> do -- Warn about abstract alias (will never work!)@@ -106,7 +107,7 @@               -- blocks you might actually have solved the type of an alias by the time you get to               -- the definition. See test/Succeed/SizeInfinity.agda for an example where this               -- happens.-              whenM (isOpenMeta . mvInstantiation <$> lookupMeta x) $+              whenM (isOpenMeta <$> lookupMetaInstantiation x) $                 setCurrentRange i $ genericWarning =<<                   "Missing type signature for abstract definition" <+> (prettyTCM name <> ".") $$                   fsep (pwords "Types of abstract definitions are never inferred since this would leak" ++@@ -184,27 +185,27 @@         _          -> id    -- Add the definition-  addConstant' name ai name t-                   $ set funMacro (Info.defMacro i == MacroDef) $-                     emptyFunction-                      { funClauses = [ Clause  -- trivial clause @name = v@-                          { clauseLHSRange  = getRange i-                          , clauseFullRange = getRange i-                          , clauseTel       = EmptyTel-                          , namedClausePats = []-                          , clauseBody      = Just $ bodyMod v-                          , clauseType      = Just $ Arg ai t-                          , clauseCatchall  = False-                          , clauseExact     = Just True-                          , clauseRecursive = Nothing   -- we don't know yet-                          , clauseUnreachable = Just False-                          , clauseEllipsis = NoEllipsis-                          } ]-                      , funCompiled = Just $ Done [] $ bodyMod v-                      , funSplitTree = Just $ SplittingDone 0-                      , funDelayed  = delayed-                      , funAbstr    = Info.defAbstract i-                      }+  addConstant' name ai name t $ set funMacro (Info.defMacro i == MacroDef) $+      FunctionDefn emptyFunctionData+          { _funClauses   = [ Clause  -- trivial clause @name = v@+              { clauseLHSRange    = getRange i+              , clauseFullRange   = getRange i+              , clauseTel         = EmptyTel+              , namedClausePats   = []+              , clauseBody        = Just $ bodyMod v+              , clauseType        = Just $ Arg ai t+              , clauseCatchall    = False+              , clauseExact       = Just True+              , clauseRecursive   = Nothing   -- we don't know yet+              , clauseUnreachable = Just False+              , clauseEllipsis    = NoEllipsis+              , clauseWhereModule = Nothing+              } ]+          , _funCompiled  = Just $ Done [] $ bodyMod v+          , _funSplitTree = Just $ SplittingDone 0+          , _funDelayed   = delayed+          , _funAbstr     = Info.defAbstract i+          }    -- Andreas, 2017-01-01, issue #2372:   -- Add the definition to the instance table, if needed, to update its type.@@ -332,15 +333,16 @@                  let c = Clause                        { clauseFullRange = noRange                        , clauseLHSRange  = noRange-                       , clauseTel = tel+                       , clauseTel       = tel                        , namedClausePats = teleNamedArgs tel-                       , clauseBody = Nothing-                       , clauseType = Just (defaultArg t)-                       , clauseCatchall = False-                       , clauseExact     = Just True-                       , clauseRecursive = Just False+                       , clauseBody      = Nothing+                       , clauseType      = Just (defaultArg t)+                       , clauseCatchall    = False+                       , clauseExact       = Just True+                       , clauseRecursive   = Just False                        , clauseUnreachable = Just False-                       , clauseEllipsis = NoEllipsis+                       , clauseEllipsis    = NoEllipsis+                       , clauseWhereModule = Nothing                        }                  return (cs ++ [c], pure sys) @@ -408,20 +410,26 @@          -- Add the definition         inTopContext $ addConstant name =<< do++          reportSDoc "tc.def.fun.clauses" 15 $ inTopContext $ do+            vcat [ "final clauses for" <+> prettyTCM name <+>  ":"+                 , nest 2 $ vcat $ map (prettyTCM . QNamed name) cs+                 ]+           -- If there was a pragma for this definition, we can set the           -- funTerminates field directly.           defn <- autoInline $              set funMacro (ismacro || Info.defMacro i == MacroDef) $-             emptyFunction-             { funClauses        = cs-             , funCompiled       = Just cc-             , funSplitTree      = mst-             , funDelayed        = delayed-             , funInv            = inv-             , funAbstr          = Info.defAbstract i-             , funExtLam         = (\ e -> e { extLamSys = sys }) <$> extlam-             , funWith           = with-             , funCovering       = covering+             FunctionDefn emptyFunctionData+             { _funClauses        = cs+             , _funCompiled       = Just cc+             , _funSplitTree      = mst+             , _funDelayed        = delayed+             , _funInv            = inv+             , _funAbstr          = Info.defAbstract i+             , _funExtLam         = (\ e -> e { extLamSys = sys }) <$> extlam+             , _funWith           = with+             , _funCovering       = covering              }           lang <- getLanguage           useTerPragma $@@ -476,7 +484,10 @@   A.LHSWith core wps [] ->     let ps' = map (fmap $ fmap patOfName) ps in     A.LHSWith core (insertIn ps' wps) []-  _ -> __IMPOSSIBLE__+  -- Andreas, AIM XXXV, 2022-05-09, issue #5728:+  -- Cases other than LHSWith actually do not make sense, but let them+  -- through to get a proper error later.+  lhs -> lhs    where @@ -590,7 +601,7 @@              initWithDefault __IMPOSSIBLE__ $ List.tails pcs) $ \ ((phi1,cl1):pcs') -> do         forM_ pcs' $ \ (phi2,cl2) -> do           phi12 <- reduce (imin `apply` [argN phi1, argN phi2])-          forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \ sigma -> do+          forallFaceMaps phi12 (\ _ _ -> __IMPOSSIBLE__) $ \_ sigma -> do             let args = sigma `applySubst` teleArgs gamma                 t' = sigma `applySubst` t                 fromReduced (YesReduction _ x) = x@@ -600,7 +611,7 @@                   TelV delta _ <- telViewUpTo extra t'                   fmap (abstract delta) $ addContext delta $ do                     fmap fromReduced $ runReduceM $-                      appDef' (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta)+                      appDef' f (Def f []) [cl] [] (map notReduced $ raise (size delta) args ++ teleArgs delta)             v1 <- body cl1             v2 <- body cl2             equalTerm t' v1 v2@@ -670,7 +681,7 @@  checkClause t withSub c@(A.Clause lhs@(A.SpineLHS i x aps) strippedPats rhs0 wh catchall) = do   cxtNames <- reverse . map (fst . unDom) <$> getContext-  checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit) -> do+  checkClauseLHS t withSub c $ \ lhsResult@(LHSResult npars delta ps absurdPat trhs patSubst asb psplit ixsplit) -> do         -- Note that we might now be in irrelevant context,         -- in case checkLeftHandSide walked over an irrelevant projection pattern. @@ -715,7 +726,7 @@               [ "double checking rhs"               , nest 2 (prettyTCM v <+> " : " <+> prettyTCM (unArg trhs))               ]-            nonConstraining $ checkInternal v CmpLeq $ unArg trhs+            noConstraints $ withFrozenMetas $ checkInternal v CmpLeq $ unArg trhs           Nothing -> return ()          reportSDoc "tc.lhs.top" 10 $ vcat@@ -737,19 +748,6 @@             ]           ] -        -- check naturality wrt the interval.-        let-          -- TODO:: Defined but not used-          iApplyVars :: [NamedArg DeBruijnPattern] -> [(Int, (Term,Term))]-          iApplyVars ps = flip concatMap (map namedArg ps) $ \case-                             IApplyP _ t u x -> [(dbPatVarIndex x,(t,u))]-                             VarP{} -> []-                             ProjP{}-> []-                             LitP{} -> []-                             DotP{} -> []-                             DefP _ _ ps -> iApplyVars ps-                             ConP _ _ ps -> iApplyVars ps-         -- compute body modification for irrelevant definitions, see issue 610         rel <- asksTC getRelevance         let bodyMod body = case rel of@@ -774,7 +772,8 @@                  , clauseExact       = exact                  , clauseRecursive   = Nothing -- we don't know yet                  , clauseUnreachable = Nothing -- we don't know yet-                 , clauseEllipsis  = lhsEllipsis i+                 , clauseEllipsis    = lhsEllipsis i+                 , clauseWhereModule = A.whereModule wh                  }  @@ -802,7 +801,7 @@   -> A.RHS                   -- ^ Rhs to check.   -> TCM (Maybe Term, WithFunctionProblem)                                               -- Note: the as-bindings are already bound (in checkClause)-checkRHS i x aps t lhsResult@(LHSResult _ delta ps absurdPat trhs _ _asb _) rhs0 =+checkRHS i x aps t lhsResult@(LHSResult _ delta ps absurdPat trhs _ _asb _ _) rhs0 =   handleRHS rhs0 where    handleRHS :: A.RHS -> TCM (Maybe Term, WithFunctionProblem)@@ -1018,7 +1017,7 @@   -> [A.Clause]                        -- ^ With-clauses to check.   -> TCM (Maybe Term, WithFunctionProblem)                                 -- Note: as-bindings already bound (in checkClause)-checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _) vtys0 cs =+checkWithRHS x aux t (LHSResult npars delta ps _absurdPat trhs _ _asb _ _) vtys0 cs =   verboseBracket "tc.with.top" 25 "checkWithRHS" $ do     Bench.billTo [Bench.Typing, Bench.With] $ do         withArgs <- withArguments vtys0@@ -1206,7 +1205,8 @@    -- Check the with function   let info = Info.mkDefInfo (nameConcrete $ qnameName aux) noFixity' PublicAccess abstr (getRange cs)-  checkFunDefS withFunType defaultArgInfo NotDelayed Nothing (Just f) info aux (Just withSub) cs+  ai <- defArgInfo <$> getConstInfo f+  checkFunDefS withFunType ai NotDelayed Nothing (Just f) info aux (Just withSub) cs   return $ Just $ call_in_parent  -- | Type check a where clause.@@ -1214,8 +1214,8 @@   :: A.WhereDeclarations -- ^ Where-declarations to check.   -> TCM a               -- ^ Continuation.   -> TCM a-checkWhere wh@(A.WhereDecls whmod ds) ret = do-  ensureNoNamedWhereInRefinedContext whmod+checkWhere wh@(A.WhereDecls whmod whNamed ds) ret = do+  when (not whNamed) $ ensureNoNamedWhereInRefinedContext whmod   loop ds   where     loop = \case
src/full/Agda/TypeChecking/Rules/Display.hs view
@@ -1,7 +1,6 @@  module Agda.TypeChecking.Rules.Display (checkDisplayPragma) where -import qualified Data.List.NonEmpty as NonEmpty import Control.Monad.State import Data.Maybe @@ -65,7 +64,7 @@       pars =         case theDef def of           Constructor { conPars = p } -> p-          Function { funProjection = Just Projection{projIndex = i} }+          Function { funProjection = Right Projection{projIndex = i} }             | i > 0 -> i - 1           _ -> 0
src/full/Agda/TypeChecking/Rules/LHS.hs view
@@ -92,6 +92,8 @@ import Agda.Utils.Tuple  import Agda.Utils.Impossible+import Agda.Utils.WithDefault+import Agda.TypeChecking.Free (freeIn)  --UNUSED Liang-Ting Chen 2019-07-16 ---- | Compute the set of flexible patterns in a list of patterns. The result is@@ -639,10 +641,12 @@     -- (Issue 2303).   , lhsPartialSplit :: IntSet     -- ^ have we done a partial split?+  , lhsIndexedSplit :: Bool+    -- ^ have we split on an indexed type?   }  instance InstantiateFull LHSResult where-  instantiateFull' (LHSResult n tel ps abs t sub as psplit) = LHSResult n+  instantiateFull' (LHSResult n tel ps abs t sub as psplit ixsplit) = LHSResult n     <$> instantiateFull' tel     <*> instantiateFull' ps     <*> instantiateFull' abs@@ -650,6 +654,7 @@     <*> instantiateFull' sub     <*> instantiateFull' as     <*> pure psplit+    <*> pure ixsplit  -- | Check a LHS. Main function. --@@ -688,7 +693,7 @@       eqs0 = zipWith3 ProblemEq (map namedArg cps) (map var $ downFrom $ size tel) (flattenTel tel)    let finalChecks :: LHSState a -> TCM a-      finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit) = do+      finalChecks (LHSState delta qs0 (Problem eqs rps _) b psplit ixsplit) = do          reportSDoc "tc.lhs.top" 20 $ vcat           [ "lhs: final checks with remaining equations"@@ -701,6 +706,22 @@         addContext delta $ do           mapM_ noShadowingOfConstructors eqs +          -- When working --without-K or --cubical-compatible, we have+          -- to check that the target type can be used at the “ambient”+          -- modality. For --cubical-compatible, this just improves an+          -- error message (printing the type rather than the generated+          -- RHS). For --without-K, it implements the same check without+          -- necessarily generating --cubical code.+          -- The reason for this check is that a clause+          --    foo : x ≡ y → ... → T y+          --    foo refl ... = ...+          -- in Cubical mode, gets elaborated to an extra clause of the+          -- form+          --    foo (transp p φ x) ... = transp (λ i → T (p i)) φ (foo x ...)+          -- (approximately), where T is the target type. That is: to+          -- implement the substitution T[y/x], we use an actual+          -- transport. See #5448.+         arity_a <- arityPiPath a         -- Compute substitution from the out patterns @qs0@         let notProj ProjP{} = False@@ -768,7 +789,7 @@          let hasAbsurd = not . null $ absurds -        let lhsResult = LHSResult (length cxt) delta qs hasAbsurd b patSub asb (IntSet.fromList $ catMaybes psplit)+        let lhsResult = LHSResult (length cxt) delta qs hasAbsurd b patSub asb (IntSet.fromList $ catMaybes psplit) ixsplit          -- Debug output         reportSDoc "tc.lhs.top" 10 $@@ -779,11 +800,13 @@                  , "asb     = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM asb)                  , "absurds = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map prettyTCM absurds)                  , "qs      = " <+> addContext delta (prettyList $ map pretty qs)+                 , "b       = " <+> addContext delta (prettyTCM b)                  ]                ]         reportSDoc "tc.lhs.top" 30 $           nest 2 $ vcat                  [ "vars   = " <+> pretty vars+                 , "b      = " <+> pretty b                  ]         reportSDoc "tc.lhs.top" 20 $ nest 2 $ "withSub  = " <+> pretty withSub         reportSDoc "tc.lhs.top" 20 $ nest 2 $ "weakSub  = " <+> pretty weakSub@@ -825,6 +848,107 @@   (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` (size cxt)) $ checkLHS f st   return result +-- | Check that this split will generate a modality-correct internal+-- clause when --cubical-compatible is used. This means that the type of+-- anything which might be transported must be modality-correct. This is+-- necessarily an approximate check. We assume that any argument which+-- (a) comes after and (b) mentions a dotted argument will be+-- transported, which is probably an overestimate.+conSplitModalityCheck+  :: Modality+  -- ^ Modality to check at+  -> PatternSubstitution+  -- ^ Substitution resulting from index unification. @Γ ⊢ ρ : Δ'@,+  -- where @Δ'@ is the context we're in, and @Γ@ is the clause telescope+  -- before unification.+  -> Int       -- ^ Variable x at which we split+  -> Telescope -- ^ The telescope @Γ@ itself+  -> Type      -- ^ Target type of the clause.+  -> TCM ()+conSplitModalityCheck mod rho blocking gamma target = when (any ((/= defaultModality) . getModality) gamma) $ do+  reportSDoc "tc.lhs.top" 30 $ vcat+    [ "LHS modality check for modality: " <+> prettyTCM mod+    , "rho:    " <+> inTopContext (prettyTCM rho)+    , "gamma:  " <+> inTopContext (prettyTCM gamma)+    , "target: " <+> prettyTCM target <+> parens (pretty target)+    , "Δ'target: " <+> prettyTCM (applyPatSubst rho target)+    , "blocking:" <+> prettyTCM blocking+    ]+  case firstForced rho (length gamma) of+    Just ix -> do+      -- We've found a forced argument. This means that the unifier has+      -- decided to kill a unification variable, and any of its+      -- occurrences in the generated term will be replaced by an+      -- occurrence of a path, and any terms whose types mention that+      -- variable will be transported.+      let+        (gamma0, delta) = splitTelescopeAt (length gamma - ix) gamma+        name = inTopContext . addContext gamma . nameOfBV+        delta'target = applyPatSubst rho target+      reportSDoc "tc.lhs.top" 30 $ vcat+        [ "found forced argument!"+        , "forced: " <+> prettyTCM ix+        , "before: " <+> inTopContext (prettyTCM gamma0)+        , "after:  " <+> inTopContext (addContext gamma0 (prettyTCM delta))+        ]+      forced <- name ix+      forM_ (zip [ix - 1, ix - 2 ..] (telToList delta)) $ \(arg, d) -> do+        -- Example: The first argument after the first forced variable. So+        -- we have e.g.:+        --   Γ = Γ₀.x.Δ+        --   Δ' ⊢ ρ : Γ₀.x.Δ+        --   Γ₀ ⊢ x : Type+        -- but we need+        --   Δ' ⊢ x : Type,+        -- since Δ' is the context we are in. Then we have+        --   Γ ⊢ x[wkS |Δ|] : Type+        -- and consequently+        --   Δ' ⊢ x[wkS |Δ|][ρ] : Type+        let+          rho' = composeS rho (wkS (arg + 1) idS)+        ty' <- reduce (applyPatSubst rho' (unEl (snd (unDom d))))+        let+          -- It's actually rather tricky to know when, exactly, a+          -- transport will be needed in a position that forces an+          -- usable-at-modality check. Our current heuristic is:+          --+          -- The variable we're looking at has a fibrant type, with the+          -- first forced variable free.+          -- The variable appears free in the result type.+          docheck = and+            [ ix `freeIn` applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d)))+            , arg /= blocking+            , arg `freeIn` target+            ]+        reportSDoc "tc.lhs.top" 30 $ vcat+          [ "arg:        " <+> pretty arg+          , "arg type:   " <+> prettyTCM (applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d))))+          , "check       " <+> pretty docheck+          ]+        argn <- name arg+        when docheck $+          usableAtModality (IndexedClauseArg forced argn) mod ty'+    Nothing -> pure ()++  -- ALways check the target clause type. Specifically, we check it both+  -- in Δ' and in Γ. The check in Δ' will sometimes let slip by a+  -- quantity violation which is masked by an indexed match (recall that+  -- the unifier likes to replace @0-variables for @ω-variables). A+  -- concrete case where this happens is #5468. Check in Δ' first since+  -- that will have the forced variable names.+  usableAtModality IndexedClause mod (unEl (applyPatSubst rho target))+  inTopContext $ addContext gamma $ usableAtModality IndexedClause mod (unEl target)+  where+    -- Find the first dotted pattern in the substitution. "First" =+    -- "earliest bound", so counts down from the length of the+    -- telescope.+    firstForced :: PatternSubstitution -> Int -> Maybe Int+    firstForced pat level+      | level >= 0 = case lookupS pat level of+        DotP{} -> Just level+        _ -> firstForced pat (level - 1)+      | otherwise = Nothing+ -- | Determine which splits should be tried. splitStrategy :: [ProblemEq] -> [ProblemEq] splitStrategy = filter shouldSplit@@ -859,7 +983,7 @@ checkLHS mf = updateModality checkLHS_ where     -- If the target type is irrelevant or in Prop,     -- we need to check the lhs in irr. cxt. (see Issue 939).- updateModality cont st@(LHSState tel ip problem target psplit) = do+ updateModality cont st@(LHSState tel ip problem target psplit _) = do       let m = getModality target       applyModalityToContext m $ do         cont $ over (lhsTel . listTel)@@ -867,9 +991,10 @@         -- Andreas, 2018-10-23, issue #3309         -- the modalities in the clause telescope also need updating. - checkLHS_ st@(LHSState tel ip problem target psplit) = do-  reportSDoc "lhs" 10 $ "tel is" <+> prettyTCM tel-  reportSDoc "lhs" 10 $ "ip is" <+> pretty ip+ checkLHS_ st@(LHSState tel ip problem target psplit ixsplit) = do+  reportSDoc "tc.lhs" 40 $ "tel is" <+> prettyTCM tel+  reportSDoc "tc.lhs" 40 $ "ip is" <+> pretty ip+  reportSDoc "tc.lhs" 40 $ "target is" <+> addContext tel (prettyTCM target)   if isSolvedProblem problem then     liftTCM $ (problem ^. problemCont) st   else do@@ -981,7 +1106,7 @@           ip'      = ip ++ [projP]           -- drop the projection pattern (already splitted)           problem' = over problemRestPats tail problem-      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit)+      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit)       -- Split a Partial.@@ -1041,9 +1166,9 @@                  -> ExceptT TCErr tcm (LHSState a)     splitPartial delta1 dom adelta2 ts = do -      unless (domFinite dom) $ liftTCM $ addContext delta1 $+      unless (domIsFinite dom) $ liftTCM $ addContext delta1 $         softTypeError . GenericDocError =<<-        hsep [ "Not a finite domain:" , prettyTCM $ unDom dom ]+        vcat [ "Splitting on partial elements is only allowed at the type Partial, but the domain here is" , nest 2 $ prettyTCM $ unDom dom ]        tInterval <- liftTCM $ primIntervalType @@ -1107,7 +1232,7 @@          phi <- reduce phi          reportSDoc "tc.lhs.split.partial" 10 $ text "phi (reduced) =" <+> prettyTCM phi          refined <- forallFaceMaps phi (\ bs m t -> typeError $ GenericError $ "face blocked on meta")-                            (\ sigma -> (,sigma) <$> getContextTelescope)+                            (\_ sigma -> (,sigma) <$> getContextTelescope)          case refined of            [(gamma,sigma)] -> return (gamma,sigma)            []              -> typeError $ GenericError $ "The face constraint is unsatisfiable."@@ -1141,7 +1266,7 @@       -- Compute the new state       let problem' = set problemEqs eqs' problem       reportSDoc "tc.lhs.split.partial" 60 $ text (show problem')-      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n]))+      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++ [Just o_n]) ixsplit)       splitLit :: Telescope      -- The types of arguments before the one we split on@@ -1180,7 +1305,7 @@        -- Compute the new state       let problem' = set problemEqs eqs' problem-      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit)+      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' psplit ixsplit)       splitCon :: Telescope      -- The types of arguments before the one we split on@@ -1223,6 +1348,15 @@       unlessM (splittableCohesion info) $         addContext delta1 $ softTypeError $ SplitOnUnusableCohesion dom +      -- Should we attempt to compute a left inverse for this clause? When+      -- --cubical-compatible --flat-split is given, we don't generate a+      -- left inverse (at all). This means that, when the coverage checker+      -- gets to the clause this was in, it won't generate a (malformed!)+      -- transpX clause for @♭ matching.+      -- TODO(Amy): properly support transpX when @♭ stuff is in the+      -- context.+      let genTrx = boolToMaybe ((getCohesion info == Flat)) SplitOnFlat+       -- We should be at a data/record type       (dr, d, pars, ixs) <- addContext delta1 $ isDataOrRecordType a       let isRec = case dr of@@ -1335,7 +1469,7 @@       -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope       -- TODO: should we propagate the modality in general?       -- See also Coverage checking.-      da' <- do+      da' <- addContext delta1Gamma $ do              let updCoh = composeCohesion (getCohesion info)              TelV tel dt <- telView da'              return $ abstract (mapCohesion updCoh <$> tel) a@@ -1343,7 +1477,7 @@       let stuck b errs = softTypeError $ SplitError $             UnificationStuck b (conName c) (delta1 `abstract` gamma) cixs ixs' errs -      liftTCM (withKIfStrict $ unifyIndices delta1Gamma flex da' cixs ixs') >>= \case+      liftTCM (withKIfStrict $ unifyIndices genTrx delta1Gamma flex da' cixs ixs') >>= \case          -- Mismatch.  Report and abort.         NoUnify neg -> hardTypeError $ ImpossibleConstructor (conName c) neg@@ -1433,9 +1567,16 @@                      Quantity1{} -> __IMPOSSIBLE__                      Quantityω{} -> q +          liftTCM $ addContext delta' $ do+            withoutK <- collapseDefault . optWithoutK <$> pragmaOptions+            cubical <- collapseDefault . optCubicalCompatible <$> pragmaOptions+            mod <- viewTC eModality+            when ((withoutK || cubical) && not (null ixs)) $+              conSplitModalityCheck mod rho (length delta2) tel (unArg target)+           -- if rest type reduces,           -- extend the split problem by previously not considered patterns-          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit+          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit (ixsplit || not (null ixs))            reportSDoc "tc.lhs.top" 12 $ sep             [ "new problem from rest"
src/full/Agda/TypeChecking/Rules/LHS/Implicit.hs view
@@ -90,7 +90,8 @@       let ps0@(~(p1 : ps1)) = hs ++ ps       reduce a >>= piOrPath >>= \case         -- If @a@ is a function (or path) type, continue inserting after @p1@.-        Left (_, b) -> (p1 :) <$> insertImplicitPatternsT exh ps1 (absBody b)+        Left (dom, cod) -> underAbstraction dom cod $ \b ->+          (p1 :) <$> insertImplicitPatternsT exh ps1 b         -- Otherwise, we are done.         Right{}     -> return ps0   where
src/full/Agda/TypeChecking/Rules/LHS/Problem.hs view
@@ -236,6 +236,8 @@     --   be type-checked in irrelevant mode.   , _lhsPartialSplit :: ![Maybe Int]     -- ^ have we splitted with a PartialFocus?+  , _lhsIndexedSplit :: !Bool+    -- ^ Have we split on any indexed inductive types?   }  lhsTel :: Lens' Telescope (LHSState a)@@ -409,7 +411,7 @@   instantiateFull' (AsB x v a m) = AsB x <$> instantiateFull' v <*> instantiateFull' a <*> pure m  instance PrettyTCM (LHSState a) where-  prettyTCM (LHSState tel outPat (Problem eqs rps _) target _) = vcat+  prettyTCM (LHSState tel outPat (Problem eqs rps _) target _ _) = vcat     [ "tel             = " <+> prettyTCM tel     , "outPat          = " <+> addContext tel (prettyTCMPatternList outPat)     , "problemEqs      = " <+> addContext tel (prettyList_ $ map prettyTCM eqs)
src/full/Agda/TypeChecking/Rules/LHS/ProblemRest.hs view
@@ -96,18 +96,23 @@   -> (LHSState a -> TCM a) -- ^ Continuation for when checking the patterns is complete.   -> TCM (LHSState a)      -- ^ The initial LHS state constructed from the user patterns. initLHSState delta eqs ps a ret = do+  reportSDoc "tc.lhs.init" 40 $ vcat+    [ "initLHSState"+    , nest 2 $ "delta = " <+> prettyTCM delta+    , nest 2 $ "a     = " <+> addContext delta (prettyTCM a)+    ]   let problem = Problem eqs ps ret       qs0     = teleNamedArgs delta -  updateProblemRest $ LHSState delta qs0 problem (defaultArg a) []+  updateProblemRest $ LHSState delta qs0 problem (defaultArg a) [] False  -- | Try to move patterns from the problem rest into the problem. --   Possible if type of problem rest has been updated to a function type. updateProblemRest   :: forall m a. (PureTCM m, MonadError TCErr m, MonadTrace m, MonadFresh NameId m)   => LHSState a -> m (LHSState a)-updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit) = do-  ps <- addContext tel0 $ insertImplicitPatternsT ExpandLast ps $ unArg a+updateProblemRest st@(LHSState tel0 qs0 p@(Problem oldEqs ps ret) a psplit ixsplit) = addContext tel0 $ do+  ps <- insertImplicitPatternsT ExpandLast ps $ unArg a   reportSDoc "tc.lhs.imp" 20 $     "insertImplicitPatternsT returned" <+> fsep (map prettyA ps)   -- (Issue 734: Do only the necessary telView to preserve clause types as much as possible.)@@ -157,4 +162,5 @@                    }     , _lhsTarget  = a $> b     , _lhsPartialSplit = psplit+    , _lhsIndexedSplit = ixsplit     }
src/full/Agda/TypeChecking/Rules/LHS/Unify.hs view
@@ -118,6 +118,8 @@ module Agda.TypeChecking.Rules.LHS.Unify   ( UnificationResult   , UnificationResult'(..)+  , NoLeftInv(..)+  , unifyIndices'   , unifyIndices ) where  import Prelude hiding (null)@@ -135,7 +137,7 @@  import qualified Agda.Benchmarking as Bench -import Agda.Interaction.Options (optInjectiveTypeConstructors)+import Agda.Interaction.Options (optInjectiveTypeConstructors, optCubical, optWithoutK)  import Agda.Syntax.Common import Agda.Syntax.Internal@@ -143,6 +145,11 @@  import Agda.TypeChecking.Monad import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Monad.Builtin -- (constructorForm, getTerm, builtinPathP)+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Names+import Agda.TypeChecking.Conversion -- equalTerm import Agda.TypeChecking.Conversion.Pure import Agda.TypeChecking.Constraints import Agda.TypeChecking.Datatypes@@ -159,7 +166,11 @@ import Agda.TypeChecking.Records  import Agda.TypeChecking.Rules.LHS.Problem+import Agda.TypeChecking.Rules.LHS.Unify.Types+import Agda.TypeChecking.Rules.LHS.Unify.LeftInverse +import Agda.Utils.Empty+import Agda.Utils.Either import Agda.Utils.Benchmark import Agda.Utils.Either import Agda.Utils.Function@@ -174,10 +185,12 @@ import Agda.Utils.Permutation import Agda.Utils.Singleton import Agda.Utils.Size+import Agda.Utils.WithDefault import Agda.Utils.Tuple  import Agda.Utils.Impossible + -- | Result of 'unifyIndices'. type UnificationResult = UnificationResult'   ( Telescope                  -- @tel@@@ -185,6 +198,13 @@   , [NamedArg DeBruijnPattern] -- @ps@    s.t. @tel ⊢ ps    : eqTel @   ) +type FullUnificationResult = UnificationResult'+  ( Telescope                  -- @tel@+  , PatternSubstitution        -- @sigma@ s.t. @tel ⊢ sigma : varTel@+  , [NamedArg DeBruijnPattern] -- @ps@    s.t. @tel ⊢ ps    : eqTel @+  , Either NoLeftInv (Substitution, Substitution) -- (τ,leftInv)+  )+ data UnificationResult' a   = Unifies  a                        -- ^ Unification succeeded.   | NoUnify  NegativeUnification      -- ^ Terms are not unifiable.@@ -204,27 +224,29 @@ -- --   The result is the most general unifier of @us@ and @vs@. unifyIndices-  :: (PureTCM m, MonadBench m, BenchPhase m ~ Bench.Phase)-  => Telescope     -- ^ @gamma@-  -> FlexibleVars  -- ^ @flex@-  -> Type          -- ^ @a@-  -> Args          -- ^ @us@-  -> Args          -- ^ @vs@+  :: (PureTCM m, MonadBench m, BenchPhase m ~ Bench.Phase, MonadError TCErr m)+  => Maybe NoLeftInv -- ^ Do we have a reason for not computing a left inverse?+  -> Telescope       -- ^ @gamma@+  -> FlexibleVars    -- ^ @flex@+  -> Type            -- ^ @a@+  -> Args            -- ^ @us@+  -> Args            -- ^ @vs@   -> m UnificationResult-unifyIndices tel flex a us vs =+unifyIndices linv tel flex a us vs =   Bench.billTo [Bench.Typing, Bench.CheckLHS, Bench.UnifyIndices] $-    unifyIndices' tel flex a us vs+    fmap (\(a,b,c,_) -> (a,b,c)) <$> unifyIndices' linv tel flex a us vs  unifyIndices'-  :: (PureTCM m)-  => Telescope     -- ^ @gamma@+  :: (PureTCM m, MonadError TCErr m)+  => Maybe NoLeftInv -- ^ Do we have a reason for not computing a left inverse?+  -> Telescope     -- ^ @gamma@   -> FlexibleVars  -- ^ @flex@   -> Type          -- ^ @a@   -> Args          -- ^ @us@   -> Args          -- ^ @vs@-  -> m UnificationResult-unifyIndices' tel flex a [] [] = return $ Unifies (tel, idS, [])-unifyIndices' tel flex a us vs = do+  -> m FullUnificationResult+unifyIndices' linv tel flex a [] [] = return $ Unifies (tel, idS, [], Right (idS, raiseS 1))+unifyIndices' linv tel flex a us vs = do     reportSDoc "tc.lhs.unify" 10 $       sep [ "unifyIndices"           , ("tel  =" <+>) $ nest 2 $ prettyTCM tel@@ -235,376 +257,29 @@           ]     initialState    <- initUnifyState tel flex a us vs     reportSDoc "tc.lhs.unify" 20 $ "initial unifyState:" <+> prettyTCM initialState-    reportSDoc "tc.lhs.unify" 70 $ "initial unifyState:" <+> text (show initialState)-    (result,output) <- runUnifyLogT $ unify initialState rightToLeftStrategy-    let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState)-    return $ fmap (\s -> (varTel s , unifySubst output , ps)) result--------------------------------------------------------- Equalities-------------------------------------------------------data Equality = Equal-  { _eqType  :: Dom Type-  , _eqLeft  :: Term-  , _eqRight :: Term-  }--instance Reduce Equality where-  reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v--eqConstructorForm :: HasBuiltins m => Equality -> m Equality-eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v--eqUnLevel :: HasBuiltins m => Equality -> m Equality-eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v-  where-    unLevel (Level l) = reallyUnLevelView l-    unLevel u         = return u--------------------------------------------------------- Unify state-------------------------------------------------------data UnifyState = UState-  { varTel   :: Telescope     -- ^ Don't reduce!-  , flexVars :: FlexibleVars-  , eqTel    :: Telescope     -- ^ Can be reduced eagerly.-  , eqLHS    :: [Arg Term]    -- ^ Ends up in dot patterns (should not be reduced eagerly).-  , eqRHS    :: [Arg Term]    -- ^ Ends up in dot patterns (should not be reduced eagerly).-  } deriving (Show)--- Issues #3578 and #4125: avoid unnecessary reduction in unifier.--lensVarTel   :: Lens' Telescope UnifyState-lensVarTel   f s = f (varTel s) <&> \ tel -> s { varTel = tel }---UNUSED Liang-Ting Chen 2019-07-16---lensFlexVars :: Lens' FlexibleVars UnifyState---lensFlexVars f s = f (flexVars s) <&> \ flex -> s { flexVars = flex }--lensEqTel    :: Lens' Telescope UnifyState-lensEqTel    f s = f (eqTel s) <&> \ x -> s { eqTel = x }----UNUSED Liang-Ting Chen 2019-07-16---lensEqLHS    :: Lens' Args UnifyState---lensEqLHS    f s = f (eqLHS s) <&> \ x -> s { eqLHS = x }----UNUSED Liang-Ting Chen 2019-07-16---lensEqRHS    :: Lens' Args UnifyState---lensEqRHS    f s = f (eqRHS s) <&> \ x -> s { eqRHS = x }---- UNUSED Andreas, 2019-10-14--- instance Reduce UnifyState where---   reduce' (UState var flex eq lhs rhs) =---     UState <$> reduce' var---            <*> pure flex---            <*> reduce' eq---            <*> reduce' lhs---            <*> reduce' rhs---- Andreas, 2019-10-14, issues #3578 and #4125:--- | Don't ever reduce the whole 'varTel', as it will destroy--- readability of the context in interactive editing!--- To make sure this insight is not lost, the following--- dummy instance should prevent a proper 'Reduce' instance for 'UnifyState'.-instance Reduce UnifyState where-  reduce' = __IMPOSSIBLE__----UNUSED Liang-Ting Chen 2019-07-16---reduceEqTel :: UnifyState -> TCM UnifyState---reduceEqTel = lensEqTel reduce---- UNUSED Andreas, 2019-10-14--- instance Normalise UnifyState where---   normalise' (UState var flex eq lhs rhs) =---     UState <$> normalise' var---            <*> pure flex---            <*> normalise' eq---            <*> normalise' lhs---            <*> normalise' rhs--instance PrettyTCM UnifyState where-  prettyTCM state = "UnifyState" $$ nest 2 (vcat $-    [ "variable tel:  " <+> prettyTCM gamma-    , "flexible vars: " <+> pshow (map flexVarF $ flexVars state)-    , "equation tel:  " <+> addContext gamma (prettyTCM delta)-    , "equations:     " <+> addContext gamma (prettyList_ (zipWith prettyEquality (eqLHS state) (eqRHS state)))-    ])-    where-      flexVarF fi = (flexVar fi, flexForced fi)-      gamma = varTel state-      delta = eqTel state-      prettyEquality x y = prettyTCM x <+> "=?=" <+> prettyTCM y--initUnifyState-  :: PureTCM m-  => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState-initUnifyState tel flex a lhs rhs = do-  (tel, a, lhs, rhs) <- instantiateFull (tel, a, lhs, rhs)-  let n = size lhs-  unless (n == size rhs) __IMPOSSIBLE__-  TelV eqTel _ <- telView a-  unless (n == size eqTel) __IMPOSSIBLE__-  return $ UState tel flex eqTel lhs rhs-  -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce-  -- reduce $ UState tel flex eqTel lhs rhs--isUnifyStateSolved :: UnifyState -> Bool-isUnifyStateSolved = null . eqTel--varCount :: UnifyState -> Int-varCount = size . varTel---- | Get the type of the i'th variable in the given state-getVarType :: Int -> UnifyState -> Dom Type-getVarType i s = indexWithDefault __IMPOSSIBLE__ (flattenTel $ varTel s) i--getVarTypeUnraised :: Int -> UnifyState -> Dom Type-getVarTypeUnraised i s = snd <$> indexWithDefault __IMPOSSIBLE__ (telToList $ varTel s) i--eqCount :: UnifyState -> Int-eqCount = size . eqTel---- | Get the k'th equality in the given state. The left- and right-hand sides---   of the equality live in the varTel telescope, and the type of the equality---   lives in the varTel++eqTel telescope-getEquality :: Int -> UnifyState -> Equality-getEquality k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =-    Equal (indexWithDefault __IMPOSSIBLE__ (flattenTel eqs) k)-          (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k)-          (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k)---- | As getEquality, but with the unraised type-getEqualityUnraised :: Int -> UnifyState -> Equality-getEqualityUnraised k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =-    Equal (snd <$> indexWithDefault __IMPOSSIBLE__ (telToList eqs) k)-          (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k)-          (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k)----UNUSED Liang-Ting Chen 2019-07-16---getEqInfo :: Int -> UnifyState -> ArgInfo---getEqInfo k UState { eqTel = eqs } =---  domInfo $ indexWithDefault __IMPOSSIBLE__ (telToList eqs) k-------- | Add a list of equations to the front of the equation telescope---addEqs :: Telescope -> [Arg Term] -> [Arg Term] -> UnifyState -> UnifyState---addEqs tel us vs s =---  s { eqTel = tel `abstract` eqTel s---    , eqLHS = us ++ eqLHS s---    , eqRHS = vs ++ eqRHS s---    }---  where k = size tel------addEq :: Type -> Arg Term -> Arg Term -> UnifyState -> UnifyState---addEq a u v = addEqs (ExtendTel (defaultDom a) (Abs underscore EmptyTel)) [u] [v]+    (result,log) <- runUnifyLogT $ unify initialState rightToLeftStrategy+    forM result $ \ s -> do -- Unifies case+        let output = mconcat [output | (UnificationStep _ _ output,_) <- log ]+        let ps = applySubst (unifyProof output) $ teleNamedArgs (eqTel initialState)+        tauInv <- do+          strict     <- asksTC envSplitOnStrict+          cubicalCompatible <- cubicalCompatibleOption+          withoutK <- withoutKOption+          case linv of+            Just reason -> pure (Left reason)+            Nothing+              | strict            -> pure (Left SplitOnStrict)+              | cubicalCompatible -> buildLeftInverse initialState log+              | withoutK          -> pure (Left NoCubical)+              | otherwise         -> pure (Left WithKEnabled)+        reportSDoc "tc.lhs.unify" 20 $ "ps:" <+> pretty ps+        return $ (varTel s, unifySubst output, ps, tauInv)   --- | Instantiate the k'th variable with the given value.---   Returns Nothing if there is a cycle.-solveVar :: Int             -- ^ Index @k@-         -> DeBruijnPattern -- ^ Solution @u@-         -> UnifyState -> Maybe (UnifyState, PatternSubstitution)-solveVar k u s = case instantiateTelescope (varTel s) k u of-  Nothing -> Nothing-  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState-      { varTel   = tel'-      , flexVars = permuteFlex (reverseP rho) $ flexVars s-      , eqTel    = applyPatSubst sigma $ eqTel s-      , eqLHS    = applyPatSubst sigma $ eqLHS s-      , eqRHS    = applyPatSubst sigma $ eqRHS s-      }-  where-    permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars-    permuteFlex perm =-      mapMaybe $ \(FlexibleVar ai fc k p x) ->-        FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm)--applyUnder :: Int -> Telescope -> Term -> Telescope-applyUnder k tel u- | k < 0     = __IMPOSSIBLE__- | k == 0    = tel `apply1` u- | otherwise = case tel of-    EmptyTel         -> __IMPOSSIBLE__-    ExtendTel a tel' -> ExtendTel a $-      Abs (absName tel') $ applyUnder (k-1) (absBody tel') u--dropAt :: Int -> [a] -> [a]-dropAt _ [] = __IMPOSSIBLE__-dropAt k (x:xs)- | k < 0     = __IMPOSSIBLE__- | k == 0    = xs- | otherwise = x : dropAt (k-1) xs---- | Solve the k'th equation with the given value, which can depend on---   regular variables but not on other equation variables.-solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution)-solveEq k u s = (,sigma) $ s-    { eqTel    = applyUnder k (eqTel s) u'-    , eqLHS    = dropAt k $ eqLHS s-    , eqRHS    = dropAt k $ eqRHS s-    }-  where-    u'    = raise k u-    n     = eqCount s-    sigma = liftS (n-k-1) $ consS (dotP u') idS----UNUSED Liang-Ting Chen 2019-07-16----- | Simplify the k'th equation with the given value (which can depend on other-----   equation variables). Returns Nothing if there is a cycle.---simplifyEq :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution)---simplifyEq k u s = case instantiateTelescope (eqTel s) k u of---  Nothing -> Nothing---  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState---    { varTel   = varTel s---    , flexVars = flexVars s---    , eqTel    = tel'---    , eqLHS    = permute rho $ eqLHS s---    , eqRHS    = permute rho $ eqRHS s---    }----------------------------------------------------------- Unification strategies-------------------------------------------------------data UnifyStep-  = Deletion-    { deleteAt           :: Int-    , deleteType         :: Type-    , deleteLeft         :: Term-    , deleteRight        :: Term-    }-  | Solution-    { solutionAt         :: Int-    , solutionType       :: Dom Type-    , solutionVar        :: FlexibleVar Int-    , solutionTerm       :: Term-    }-  | Injectivity-    { injectAt           :: Int-    , injectType         :: Type-    , injectDatatype     :: QName-    , injectParameters   :: Args-    , injectIndices      :: Args-    , injectConstructor  :: ConHead-    }-  | Conflict-    { conflictAt         :: Int-    , conflictType       :: Type-    , conflictDatatype   :: QName-    , conflictParameters :: Args-    , conflictLeft       :: Term-    , conflictRight      :: Term-    }-  | Cycle-    { cycleAt            :: Int-    , cycleType          :: Type-    , cycleDatatype      :: QName-    , cycleParameters    :: Args-    , cycleVar           :: Int-    , cycleOccursIn      :: Term-    }-  | EtaExpandVar-    { expandVar           :: FlexibleVar Int-    , expandVarRecordType :: QName-    , expandVarParameters :: Args-    }-  | EtaExpandEquation-    { expandAt           :: Int-    , expandRecordType   :: QName-    , expandParameters   :: Args-    }-  | LitConflict-    { litConflictAt      :: Int-    , litType            :: Type-    , litConflictLeft    :: Literal-    , litConflictRight   :: Literal-    }-  | StripSizeSuc-    { stripAt            :: Int-    , stripArgLeft       :: Term-    , stripArgRight      :: Term-    }-  | SkipIrrelevantEquation-    { skipIrrelevantAt   :: Int-    }-  | TypeConInjectivity-    { typeConInjectAt    :: Int-    , typeConstructor    :: QName-    , typeConArgsLeft    :: Args-    , typeConArgsRight   :: Args-    } deriving (Show)--instance PrettyTCM UnifyStep where-  prettyTCM step = case step of-    Deletion k a u v -> "Deletion" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "type:       " <+> prettyTCM a-      , "lhs:        " <+> prettyTCM u-      , "rhs:        " <+> prettyTCM v-      ])-    Solution k a i u -> "Solution" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "type:       " <+> prettyTCM a-      , "variable:   " <+> text (show (flexVar i, flexPos i, flexForced i, flexKind i))-      , "term:       " <+> prettyTCM u-      ])-    Injectivity k a d pars ixs c -> "Injectivity" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "type:       " <+> prettyTCM a-      , "datatype:   " <+> prettyTCM d-      , "parameters: " <+> prettyList_ (map prettyTCM pars)-      , "indices:    " <+> prettyList_ (map prettyTCM ixs)-      , "constructor:" <+> prettyTCM c-      ])-    Conflict k a d pars u v -> "Conflict" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "type:       " <+> prettyTCM a-      , "datatype:   " <+> prettyTCM d-      , "parameters: " <+> prettyList_ (map prettyTCM pars)-      , "lhs:        " <+> prettyTCM u-      , "rhs:        " <+> prettyTCM v-      ])-    Cycle k a d pars i u -> "Cycle" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "type:       " <+> prettyTCM a-      , "datatype:   " <+> prettyTCM d-      , "parameters: " <+> prettyList_ (map prettyTCM pars)-      , "variable:   " <+> text (show i)-      , "term:       " <+> prettyTCM u-      ])-    EtaExpandVar fi r pars -> "EtaExpandVar" $$ nest 2 (vcat $-      [ "variable:   " <+> text (show fi)-      , "record type:" <+> prettyTCM r-      , "parameters: " <+> prettyTCM pars-      ])-    EtaExpandEquation k r pars -> "EtaExpandEquation" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "record type:" <+> prettyTCM r-      , "parameters: " <+> prettyTCM pars-      ])-    LitConflict k a u v -> "LitConflict" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "type:       " <+> prettyTCM a-      , "lhs:        " <+> prettyTCM u-      , "rhs:        " <+> prettyTCM v-      ])-    StripSizeSuc k u v -> "StripSizeSuc" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "lhs:        " <+> prettyTCM u-      , "rhs:        " <+> prettyTCM v-      ])-    SkipIrrelevantEquation k -> "SkipIrrelevantEquation" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      ])-    TypeConInjectivity k d us vs -> "TypeConInjectivity" $$ nest 2 (vcat $-      [ "position:   " <+> text (show k)-      , "datatype:   " <+> prettyTCM d-      , "lhs:        " <+> prettyList_ (map prettyTCM us)-      , "rhs:        " <+> prettyList_ (map prettyTCM vs)-      ])- type UnifyStrategy = forall m. (PureTCM m, MonadPlus m) => UnifyState -> m UnifyStep + --UNUSED Liang-Ting Chen 2019-07-16 --leftToRightStrategy :: UnifyStrategy --leftToRightStrategy s =@@ -657,10 +332,10 @@      | Just fi <- findFlexible i flex      , Just fj <- findFlexible j flex -> do        let choice = chooseFlex fi fj-           firstTryLeft  = msum [ return (Solution k dom{unDom = ha} fi v)-                                , return (Solution k dom{unDom = ha} fj u)]-           firstTryRight = msum [ return (Solution k dom{unDom = ha} fj u)-                                , return (Solution k dom{unDom = ha} fi v)]+           firstTryLeft  = msum [ return (Solution k dom{unDom = ha} fi v left)+                                , return (Solution k dom{unDom = ha} fj u right)]+           firstTryRight = msum [ return (Solution k dom{unDom = ha} fj u right)+                                , return (Solution k dom{unDom = ha} fi v left)]        reportSDoc "tc.lhs.unify" 40 $ "fi = " <+> text (show fi)        reportSDoc "tc.lhs.unify" 40 $ "fj = " <+> text (show fj)        reportSDoc "tc.lhs.unify" 40 $ "chooseFlex: " <+> text (show choice)@@ -670,20 +345,25 @@          ExpandBoth   -> mzero -- This should be taken care of by etaExpandEquationStrategy          ChooseEither -> firstTryRight     (Just i, _)-     | Just fi <- findFlexible i flex -> return $ Solution k dom{unDom = ha} fi v+     | Just fi <- findFlexible i flex -> return $ Solution k dom{unDom = ha} fi v left     (_, Just j)-     | Just fj <- findFlexible j flex -> return $ Solution k dom{unDom = ha} fj u+     | Just fj <- findFlexible j flex -> return $ Solution k dom{unDom = ha} fj u right     _ -> mzero   where     flex = flexVars s     n = eqCount s+    left = Left (); right = Right ()  dataStrategy :: Int -> UnifyStrategy dataStrategy k s = do-  Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< reduce (getEqualityUnraised k s)-  sa <- reduce $ getSort a+  Equal Dom{unDom = a} u v <- eqConstructorForm =<< eqUnLevel =<< getReducedEqualityUnraised k s+  sortOk <- reduce (getSort a) <&> \case+    Type{} -> True+    Inf{}  -> True+    SSet{} -> True+    _      -> False   case unEl a of-    Def d es | Type{} <- sa -> do+    Def d es | sortOk -> do       npars <- catMaybesMP $ getNumberOfParameters d       let (pars,ixs) = splitAt npars $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es       reportSDoc "tc.lhs.unify" 40 $ addContext (varTel s `abstract` eqTel s) $@@ -726,7 +406,7 @@  etaExpandVarStrategy :: Int -> UnifyStrategy etaExpandVarStrategy k s = do-  Equal Dom{unDom = a} u v <- eqUnLevel <=< reduce $ getEquality k s+  Equal Dom{unDom = a} u v <- eqUnLevel =<< getReducedEquality k s   shouldEtaExpand u v a s `mplus` shouldEtaExpand v u a s   where     -- TODO: use IsEtaVar to check if the term is a variable@@ -739,7 +419,9 @@       -- record or if it's unified against a record constructor term. Basically       -- we need to avoid EtaExpandEquation if EtaExpandVar is possible, or the       -- forcing translation is unhappy.-      b         <- reduce $ unDom $ getVarTypeUnraised (varCount s - 1 - i) s+      let k  = varCount s - 1 - i -- position of var i in telescope+          b0 = unDom $ getVarTypeUnraised k s+      b         <- addContext (telFromList $ take k $ telToList $ varTel s) $ reduce b0       (d, pars) <- catMaybesMP $ isEtaRecordType b       ps        <- fromMaybeMP $ allProjElims es       guard =<< orM@@ -760,7 +442,7 @@ etaExpandEquationStrategy :: Int -> UnifyStrategy etaExpandEquationStrategy k s = do   -- Andreas, 2019-02-23, re #3578, is the following reduce redundant?-  Equal Dom{unDom = a} u v <- reduce $ getEqualityUnraised k s+  Equal Dom{unDom = a} u v <- getReducedEqualityUnraised k s   (d, pars) <- catMaybesMP $ addContext tel $ isEtaRecordType a   guard =<< orM     [ (Right True ==) <$> runBlocked (isSingletonRecord d pars)@@ -789,7 +471,7 @@ simplifySizesStrategy :: Int -> UnifyStrategy simplifySizesStrategy k s = do   isSizeName <- isSizeNameTest-  Equal Dom{unDom = a} u v <- reduce $ getEquality k s+  Equal Dom{unDom = a} u v <- getReducedEquality k s   case unEl a of     Def d _ -> do       guard $ isSizeName d@@ -806,7 +488,7 @@ injectiveTypeConStrategy k s = do   injTyCon <- optInjectiveTypeConstructors <$> pragmaOptions   guard injTyCon-  eq <- eqUnLevel <=< reduce $ getEquality k s+  eq <- eqUnLevel =<< getReducedEquality k s   case eq of     Equal a u@(Def d es) v@(Def d' es') | d == d' -> do       -- d must be a data, record or axiom@@ -829,7 +511,7 @@  injectivePragmaStrategy :: Int -> UnifyStrategy injectivePragmaStrategy k s = do-  eq <- eqUnLevel <=< reduce $ getEquality k s+  eq <- eqUnLevel =<< getReducedEquality k s   case eq of     Equal a u@(Def d es) v@(Def d' es') | d == d' -> do       -- d must have an injective pragma@@ -842,8 +524,9 @@  skipIrrelevantStrategy :: Int -> UnifyStrategy skipIrrelevantStrategy k s = do-  let Equal a _ _ = getEquality k s                               -- reduce not necessary-  guard . (== Right True) =<< runBlocked (isIrrelevantOrPropM a)  -- reduction takes place here+  let Equal a _ _ = getEquality k s                                 -- reduce not necessary+  addContext (varTel s `abstract` eqTel s) $+    guard . (== Right True) =<< runBlocked (isIrrelevantOrPropM a)  -- reduction takes place here   -- TODO: do something in case the above is blocked (i.e. `Left b`)   return $ SkipIrrelevantEquation k @@ -852,47 +535,9 @@ -- Actually doing the unification ---------------------------------------------------- -data UnifyLogEntry-  = UnificationStep  UnifyState UnifyStep---  | UnificationDone  UnifyState -- unused?--type UnifyLog = [UnifyLogEntry]--data UnifyOutput = UnifyOutput-  { unifySubst :: PatternSubstitution-  , unifyProof :: PatternSubstitution-  , unifyLog   :: UnifyLog-  }--instance Semigroup UnifyOutput where-  x <> y = UnifyOutput-    { unifySubst = unifySubst y `composeS` unifySubst x-    , unifyProof = unifyProof y `composeS` unifyProof x-    , unifyLog   = unifyLog x ++ unifyLog y-    }--instance Monoid UnifyOutput where-  mempty  = UnifyOutput IdS IdS []-  mappend = (<>)--type UnifyLogT m a = WriterT UnifyOutput m a--tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()-tellUnifySubst sub = tell $ UnifyOutput sub IdS []--tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()-tellUnifyProof sub = tell $ UnifyOutput IdS sub []--writeUnifyLog :: MonadWriter UnifyOutput m => UnifyLogEntry -> m ()-writeUnifyLog x = tell $ UnifyOutput IdS IdS [x]--runUnifyLogT :: UnifyLogT m a -> m (a,UnifyOutput)-runUnifyLogT = runWriterT- unifyStep-  :: (PureTCM m, MonadWriter UnifyOutput m)+  :: (PureTCM m, MonadWriter UnifyOutput m, MonadError TCErr m)   => UnifyState -> UnifyStep -> m (UnificationResult' UnifyState)- unifyStep s Deletion{ deleteAt = k , deleteType = a , deleteLeft = u , deleteRight = v } = do     -- Check definitional equality of u and v     isReflexive <- addContext (varTel s) $ runBlocked $ pureEqualTerm a u v@@ -923,7 +568,7 @@   let ctype  = defType cdef `piApply` pars   addContext (varTel s `abstract` eqTel1) $ reportSDoc "tc.lhs.unify" 40 $     "Constructor type: " <+> prettyTCM ctype-  TelV ctel ctarget <- telView ctype+  TelV ctel ctarget <- addContext (varTel s `abstract` eqTel1) $ telView ctype   let cixs = case unEl ctarget of                Def d' es | d == d' ->                  let args = fromMaybe __IMPOSSIBLE__ $ allApplyElims es@@ -943,7 +588,12 @@   -- computeNeighbourhood function in Agda.TypeChecking.Coverage.   let hduTel = eqTel1 `abstract` ctel       notforced = replicate (size hduTel) NotForced-  res <- addContext (varTel s) $ unifyIndices'++  -- The left inverse computed here is not actually used when computing+  -- a left inverse for the overall match, so as a slight optimisation+  -- we just don't bother computing it. __IMPOSSIBLE__ because that+  -- field in the result is never evaluated.+  res <- addContext (varTel s) $ unifyIndices' (Just __IMPOSSIBLE__)            hduTel            (allFlexVars notforced hduTel)            (raise (size ctel) dtype)@@ -973,10 +623,10 @@        tellUnifyProof rho -      eqTel' <- reduce eqTel'+      eqTel' <- addContext (varTel s) $ reduce eqTel'        -- Compute new lhs and rhs by matching the old ones against rho-      (lhs', rhs') <- do+      (lhs', rhs') <- addContext (varTel s) $ do         let ps = applySubst rho $ teleNamedArgs $ eqTel s         (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s         (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s@@ -995,7 +645,7 @@                          (varTel s `abstract` eqTel s) a                          (raise n u) (raise n v) (raise (n-k) ixs)] -    Unifies (eqTel1', rho0, _) -> do+    Unifies (eqTel1', rho0, _, _) -> do       -- Split ps0 into parts for eqTel1 and ctel       let (rho1, rho2) = splitS (size ctel) rho0 @@ -1008,10 +658,10 @@        tellUnifyProof rho -      eqTel' <- reduce eqTel'+      eqTel' <- addContext (varTel s) $ reduce eqTel'        -- Compute new lhs and rhs by matching the old ones against rho-      (lhs', rhs') <- do+      (lhs', rhs') <- addContext (varTel s) $ do         let ps = applySubst rho $ teleNamedArgs $ eqTel s         (lhsMatch, _) <- Match.matchPatterns ps $ eqLHS s         (rhsMatch, _) <- Match.matchPatterns ps $ eqRHS s@@ -1226,7 +876,7 @@   caseEitherM (return eusable) (return . UnifyBlocked) $ \ usable -> do    reportSDoc "tc.lhs.unify" 45 $ "Modality ok: " <+> prettyTCM usable-  unless usable $ reportSLn "tc.lhs.unify" 65 $ "Rejected solution: " ++ show u+  unless usable $ reportSDoc "tc.lhs.unify" 65 $ "Rejected solution: " <+> prettyTCM u    -- We need a Flat equality to solve a Flat variable.   -- This also ought to take care of the need for a usableCohesion check.@@ -1255,14 +905,14 @@ solutionStep _ _ _ = __IMPOSSIBLE__  unify-  :: (PureTCM m, MonadWriter UnifyOutput m)+  :: (PureTCM m, MonadWriter UnifyLog' m, MonadError TCErr m)   => UnifyState -> UnifyStrategy -> m (UnificationResult' UnifyState) unify s strategy = if isUnifyStateSolved s                    then return $ Unifies s                    else tryUnifyStepsAndContinue (strategy s)   where     tryUnifyStepsAndContinue-      :: (PureTCM m, MonadWriter UnifyOutput m)+      :: (PureTCM m, MonadWriter UnifyLog' m, MonadError TCErr m)       => ListT m UnifyStep -> m (UnificationResult' UnifyState)     tryUnifyStepsAndContinue steps = do       x <- foldListT tryUnifyStep failure steps@@ -1272,19 +922,20 @@         UnifyBlocked b -> return $ UnifyBlocked b         UnifyStuck err -> return $ UnifyStuck err -    tryUnifyStep :: (PureTCM m, MonadWriter UnifyOutput m)+    tryUnifyStep :: (PureTCM m, MonadWriter UnifyLog' m, MonadError TCErr m)                  => UnifyStep                  -> m (UnificationResult' UnifyState)                  -> m (UnificationResult' UnifyState)     tryUnifyStep step fallback = do       addContext (varTel s) $         reportSDoc "tc.lhs.unify" 20 $ "trying unifyStep" <+> prettyTCM step-      x <- unifyStep s step+      (x, output) <- runWriterT $ unifyStep s step       case x of         Unifies s'   -> do           reportSDoc "tc.lhs.unify" 20 $ "unifyStep successful."           reportSDoc "tc.lhs.unify" 20 $ "new unifyState:" <+> prettyTCM s'-          writeUnifyLog $ UnificationStep s step+          -- tell output+          writeUnifyLog $ (UnificationStep s step output,s')           return x         NoUnify{}       -> return x         UnifyBlocked b1 -> do
+ src/full/Agda/TypeChecking/Rules/LHS/Unify/LeftInverse.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE NondecreasingIndentation #-}+module Agda.TypeChecking.Rules.LHS.Unify.LeftInverse where++import Prelude hiding ((!!), null)++import Control.Monad+import Control.Monad.State+import Control.Monad.Writer (WriterT(..), MonadWriter(..))+import Control.Monad.Except++import Data.Semigroup hiding (Arg)+import qualified Data.List as List+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)++import qualified Agda.Benchmarking as Bench++import Agda.Interaction.Options (optInjectiveTypeConstructors, optCubical, optWithoutK)++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Literal++import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Monad.Builtin -- (constructorForm, getTerm, builtinPathP)+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Names+import Agda.TypeChecking.Conversion -- equalTerm+import Agda.TypeChecking.Conversion.Pure+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Level (reallyUnLevelView)+import Agda.TypeChecking.Reduce+import qualified Agda.TypeChecking.Patterns.Match as Match+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Free+import Agda.TypeChecking.Free.Precompute+import Agda.TypeChecking.Free.Reduce+import Agda.TypeChecking.Records++import Agda.TypeChecking.Rules.LHS.Problem+import Agda.TypeChecking.Rules.LHS.Unify.Types++import Agda.Utils.Empty+import Agda.Utils.Either+import Agda.Utils.Benchmark+import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.PartialOrd+import Agda.Utils.Permutation+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.WithDefault+import Agda.Utils.Tuple++import Agda.Utils.Impossible++instance PrettyTCM NoLeftInv where+  prettyTCM (UnsupportedYet s) = fsep $ pwords "It relies on" ++ [explainStep s <> ","] ++ pwords "which is not yet supported"+  prettyTCM UnsupportedCxt     = fwords "it relies on higher-dimensional unification, which is not yet supported"+  prettyTCM (Illegal s)        = fsep $ pwords "It relies on" ++ [explainStep s <> ","] ++ pwords "which is incompatible with" ++ [text "Cubical Agda"]+  prettyTCM NoCubical          = fwords "Cubical Agda is disabled"+  prettyTCM WithKEnabled       = fwords "The K rule is enabled"+  prettyTCM SplitOnStrict      = fwords "It splits on a type in SSet"+  prettyTCM SplitOnFlat        = fwords "It splits on a @♭ argument"++data NoLeftInv+  = UnsupportedYet {badStep :: UnifyStep}+  | Illegal        {badStep :: UnifyStep}+  | NoCubical+  | WithKEnabled+  | SplitOnStrict  -- ^ splitting on a Strict Set.+  | SplitOnFlat    -- ^ splitting on a @♭ argument+  | UnsupportedCxt+  deriving Show++buildLeftInverse :: (PureTCM tcm, MonadError TCErr tcm) => UnifyState -> UnifyLog -> tcm (Either NoLeftInv (Substitution, Substitution))+buildLeftInverse s0 log = do+  reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do+    cubical <- optCubical <$> pragmaOptions+    "cubical:" <+> text (show cubical)+  reportSDoc "tc.lhs.unify.inv.badstep" 20 $ do+    pathp <- getTerm' builtinPathP+    "pathp:" <+> text (show $ isJust pathp)+  let cond = andM+       -- TODO: handle open contexts: they happen during "higher dimensional" unification,+       --       in injectivity cases.+       [+         null <$> getContext+       ]+  ifNotM cond (return $ Left UnsupportedCxt) $ do+  equivs <- forM log $ uncurry buildEquiv+  case sequence equivs of+    Left no -> do+      reportSDoc "tc.lhs.unify.inv.badstep" 20 $ "No Left Inverse:" <+> prettyTCM (badStep no)+      return (Left no)+    Right xs -> do+    -- Γ,φ,us =_Δ vs ⊢ τ0 : Γ', φ+    -- Γ,φ,us =_Δ vs, i : I ⊢ leftInv0 : Γ,φ,us =_Δ vs+    -- leftInv0 : [wkS |φ,us =_Δ vs| ρ,φ,refls][τ0] = IdS : Γ,φ,us =_Δ vs+    (tau0,leftInv0) <- case xs of+      [] -> return (idS,raiseS 1)+      xs -> do+        let+            loop [] = __IMPOSSIBLE__+            loop [x] = return $ fst x+            loop (x:xs) = do+              r <- loop xs+              uncurry composeRetract x r+        (_,_,tau,leftInv) <- loop xs+        return (tau,leftInv)+    -- Γ,φ,us =_Δ vs ⊢ τ0 : Γ', φ+    -- leftInv0 : [wkS |φ,us =_Δ vs| ρ,1,refls][τ] = idS : Γ,φ,us =_Δ vs+    let tau = tau0 `composeS` raiseS 1+    unview <- intervalUnview'+    let replaceAt n x xs = xs0 ++ x:xs1+                where (xs0,_:xs1) = splitAt n xs+    let max r s = unview $ IMax (argN r) (argN s)+        neg r = unview $ INeg (argN r)+    let phieq = neg (var 0) `max` var (size (eqTel s0) + 1)+                       -- I + us =_Δ vs -- inplaceS+    let leftInv = termsS __IMPOSSIBLE__ $ replaceAt (size (varTel s0)) phieq $ map (lookupS leftInv0) $ downFrom (size (varTel s0) + 1 + size (eqTel s0))+    let working_tel = abstract (varTel s0) (ExtendTel __DUMMY_DOM__ $ Abs "phi0" $ (eqTel s0))+    reportSDoc "tc.lhs.unify.inv" 20 $ "=== before mod"+    do+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0    :" <+> prettyTCM tau0+        addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__)+                               $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv0:  " <+> prettyTCM leftInv0++    reportSDoc "tc.lhs.unify.inv" 20 $ "=== after mod"+    do+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau    :" <+> prettyTCM tau+        addContext working_tel $ addContext ("r" :: String, __DUMMY_DOM__)+                               $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv:   " <+> prettyTCM leftInv++    return $ Right (tau,leftInv)++type Retract = (Telescope, Substitution, Substitution, Substitution)+     -- Γ (the problem, including equalities),+     -- Δ ⊢ ρ : Γ+     -- Γ ⊢ τ : Δ+     -- Γ, i : I ⊢ leftInv : Γ, such that (λi. leftInv) : ρ[τ] = id_Γ++--- Γ ⊢ us : Δ   Γ ⊢ termsS e us : Δ+termsS ::  DeBruijn a => Impossible -> [a] -> Substitution' a+termsS e xs = reverse xs ++# EmptyS e++composeRetract :: (PureTCM tcm, MonadError TCErr tcm, MonadDebug tcm,HasBuiltins tcm, MonadAddContext tcm) => Retract -> Term -> Retract -> tcm Retract+composeRetract (prob0,rho0,tau0,leftInv0) phi0 (prob1,rho1,tau1,leftInv1) = do+  reportSDoc "tc.lhs.unify.inv" 20 $ "=== composing"+  reportSDoc "tc.lhs.unify.inv" 20 $ "Γ0   :" <+> prettyTCM prob0+  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0  :" <+> prettyTCM tau0+  reportSDoc "tc.lhs.unify.inv" 20 $ "Γ1   :" <+> prettyTCM prob1+  addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau1  :" <+> prettyTCM tau1+++  {-+  Γ0 = prob0+  S0 ⊢ ρ0 : Γ0+  Γ0 ⊢ τ0 : S0+  Γ0 ⊢ leftInv0 : ρ0[τ0] = idΓ0+  Γ0 ⊢ φ0+  Γ0,φ0 ⊢ leftInv0 = refl++  Γ1 = prob1+  S1 ⊢ ρ1 : Γ1+  Γ1 ⊢ τ1 : S1+  Γ1 ⊢ leftInv1 : ρ1[τ1] = idΓ1+  Γ1 ⊢ φ1 = φ0[τ0] (**)+  Γ1,φ1 ⊢ leftInv1 = refl+  S0 = Γ1++  (**) implies?+  Γ0,φ0 ⊢ leftInv1[τ0] = refl  (*)+++  S1 ⊢ ρ := ρ0[ρ1] : Γ0+  Γ0 ⊢ τ := τ1[τ0] : S1+  -}++  let prob = prob0+  let rho = rho1 `composeS` rho0+  let tau = tau0 `composeS` tau1++  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau  :" <+> prettyTCM tau++  {-+  Γ0 ⊢ leftInv : ρ[τ] = idΓ0+  Γ0 ⊢ leftInv : ρ0[ρ1[τ1]][τ0] = idΓ0+  Γ0 ⊢ step0 := ρ0[leftInv1[τ0]] : ρ0[ρ1[τ1]][τ0] = ρ0[τ0]++  Γ0,φ0 ⊢ step0 = refl     by (*)+++  Γ0 ⊢ leftInv := step0 · leftInv0 : ρ0[ρ1[τ1]][τ0] = idΓ0++  Γ0 ⊢ leftInv := tr (\ i → ρ0[ρ1[τ1]][τ0] = leftInv0[i]) φ0 step0+  Γ0,φ0 ⊢ leftInv = refl  -- because it will become step0, which is refl when φ0++  Γ0, i : I ⊢ hcomp {Γ0} (\ j → \ { (i = 0) -> ρ0[ρ1[τ1]][τ0]+                                  ; (i = 1) -> leftInv0[j]+                                  ; (φ0 = 1) -> γ0+                                  })+                         (step0[i])+++++  -}+  let step0 = liftS 1 tau0 `composeS` leftInv1 `composeS` rho0++  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv0  :" <+> prettyTCM leftInv0+  addContext prob1 $ reportSDoc "tc.lhs.unify.inv" 20 $ "rho0  :" <+> prettyTCM rho0+  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau0  :" <+> prettyTCM tau0+  addContext prob0 $ reportSDoc "tc.lhs.unify.inv" 20 $ "rhos0[tau0]  :" <+> prettyTCM (tau0 `composeS` rho0)++  addContext prob1 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv1  :" <+> prettyTCM leftInv1+  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $ reportSDoc "tc.lhs.unify.inv" 20 $ "step0  :" <+> prettyTCM step0++  interval <- primIntervalType+  max <- primIMax+  neg <- primINeg+  Right leftInv <- fmap sequenceA $ addContext prob0 $ runNamesT (teleNames prob0) $ do+             phi <- open phi0+             g0 <- open $ raise (size prob0) prob0+             step0 <- open $ Abs "i" $ step0 `applySubst` teleArgs prob0+             leftInv0 <- open $ Abs "i" $ map unArg $ leftInv0 `applySubst` teleArgs prob0+             bind "i" $ \ i -> addContext ("i" :: String, defaultDom interval) $ do+              tel <- bind "_" $ \ (_ :: NamesT tcm Term) -> g0+              step0i <- lazyAbsApp <$> step0 <*> i+              face <- pure max <@> (pure neg <@> i) <@> phi+              leftInv0 <- leftInv0+              i <- i+              -- this composition could be optimized further whenever step0i is actually constant in i.+              lift $ (runExceptT $ map unArg <$> transpSysTel' True tel [(i, leftInv0)] face step0i)+  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $+    reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv  :" <+> prettyTCM (absBody leftInv)+  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $+    reportSDoc "tc.lhs.unify.inv" 40 $ "leftInv  :" <+> pretty (absBody leftInv)+  addContext prob0 $ addContext ("r" :: String, __DUMMY_DOM__) $+    reportSDoc "tc.lhs.unify.inv" 40 $ "leftInvSub  :" <+> pretty (termsS __IMPOSSIBLE__ $ absBody $ leftInv)+  return (prob, rho, tau , termsS __IMPOSSIBLE__ $ absBody $ leftInv)++buildEquiv :: forall tcm. (PureTCM tcm, MonadError TCErr tcm) => UnifyLogEntry -> UnifyState -> tcm (Either NoLeftInv (Retract,Term))+buildEquiv (UnificationStep st step@(Solution k ty fx tm side) output) next = runExceptT $ do+        let+          errorToUnsupported :: ExceptT a tcm b -> ExceptT NoLeftInv tcm b+          errorToUnsupported m = withExceptT (\ _ -> UnsupportedYet step) m+        reportSDoc "tc.lhs.unify.inv" 20 $ "step unifyState:" <+> prettyTCM st+        reportSDoc "tc.lhs.unify.inv" 20 $ "step step:" <+> addContext (varTel st) (prettyTCM step)+        unview <- intervalUnview'+        cxt <- getContextTelescope+        reportSDoc "tc.lhs.unify.inv" 20 $ "context:" <+> prettyTCM cxt+        let+          -- k counds in eqs from the left+          m = varCount st+          gamma = varTel st+          eqs = eqTel st+          u = eqLHS st !! k+          v = eqRHS st !! k+          x = flexVar fx+          neqs = size eqs+          phis = 1 -- neqs+        interval <- lift $ primIntervalType+         -- Γ, φs : I^phis+        let gamma_phis = abstract gamma $ telFromList $+              map (defaultDom . (,interval) . ("phi" ++) . show) [0 .. phis - 1]+        working_tel <- abstract gamma_phis <$>+          errorToUnsupported (pathTelescope' (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st))+        reportSDoc "tc.lhs.unify.inv" 20 $ vcat+          [ "working tel:" <+> prettyTCM (working_tel :: Telescope)+          , addContext working_tel $ "working tel args:" <+> prettyTCM (teleArgs working_tel :: [Arg Term])+          ]+        (tau,leftInv,phi) <- addContext working_tel $ runNamesT [] $ do+          let raiseFrom tel x = raise (size working_tel - size tel) x++          [u,v] <- mapM (open . raiseFrom gamma . unArg) [u,v]+          -- φ+          let phi = raiseFrom gamma_phis $ var 0+          -- working_tel ⊢ γ₁,x,γ₂,φ,eqs+          let all_args = teleArgs working_tel+          -- Γ₁,x : A,Γ₂+--          gamma <- open $ raiseFrom EmptyTel gamma+          -- -- γ₁,x,γ₂,φ,eqs : W+          -- working_tel <- open $ raiseFrom EmptyTel working_tel++          -- eq_tel <- open $ raiseFrom gamma (eqTel st)++          -- [lhs,rhs] <- mapM (open . raiseFrom gamma) [eqLHS st,eqRHS st]+          let bindSplit (tel1,tel2) = (tel1,AbsN (teleNames tel1) tel2)+          -- . ⊢ Γ₁  ,  γ₁. (x : A),Γ₂,φ : I,[lhs ≡ rhs]+          let (gamma1, xxi) = bindSplit $ splitTelescopeAt (size gamma - x - 1) working_tel+          let (gamma1_args,xxi_args) = splitAt (size gamma1) all_args+              (_x_arg:xi_args) = xxi_args+              (x_arg:xi0,k_arg:xi1) = splitAt ((size gamma - size gamma1) + phis + k) xxi_args+              -- W ⊢ (x : A),Γ₂,φ : I,[lhs ≡ rhs]+          let+            xxi_here :: Telescope+            xxi_here = absAppN xxi $ map unArg gamma1_args+          --                                                      x:A,Γ₂                φ+          let (xpre,krest) = bindSplit $ splitTelescopeAt ((size gamma - size gamma1) + phis + k) xxi_here+          k_arg <- open $ unArg k_arg+          xpre <- open xpre+          krest <- open krest+          delta <- bindN ["x","eq"] $ \ [x,eq] -> do+                     let pre = apply1 <$> xpre <*> x+                     abstractN pre $ \ args ->+                       apply1 <$> applyN krest (x:args) <*> eq+--          let delta_zero = absAppN delta $ map unArg [x_arg,k_arg]+          let d_zero_args = xi0 ++ xi1+          reportSDoc "tc.lhs.unify.inv" 20 $ "size delta:" <+> text (show $ size $ unAbsN delta)+          reportSDoc "tc.lhs.unify.inv" 20 $ "size d0args:" <+> text (show $ size d_zero_args)+          let appSide = case side of+                          Left{} -> id+                          Right{} -> unview . INeg . argN+          let+                  -- csingl :: NamesT tcm Term -> NamesT tcm [Arg Term]+                  csingl i = mapM (fmap defaultArg) $ csingl' i+                  -- csingl' :: NamesT tcm Term -> [NamesT tcm Term]+                  csingl' i = [ k_arg <@@> (u, v, appSide <$> i)+                              , lam "j" $ \ j ->+                                  let r i j = case side of+                                            Left{} -> unview (IMax (argN j) (argN i))+                                            Right{} -> unview (IMin (argN j) (argN . unview $ INeg $ argN i))+                                  in k_arg <@@> (u, v, r <$> i <*> j)+                              ]+          let replaceAt n x xs = xs0 ++ x:xs1+                where (xs0,_:xs1) = splitAt n xs+              dropAt n xs = xs0 ++ xs1+                where (xs0,_:xs1) = splitAt n xs+          delta <- open delta+          d <- bind "i" $ \ i -> applyN delta (csingl' i)++          -- Andrea 06/06/2018+          -- We do not actually add a transp/fill if the family is+          -- constant (TODO: postpone for metas) This is so variables+          -- whose types do not depend on "x" are left alone, in+          -- particular those the solution "t" depends on.+          --+          -- We might want to instead use the info discovered by the+          -- solver when checking if "t" depends on "x" to decide what+          -- to transp and what not to.+          let flag = True+                 {-   φ -}+          tau <- {-dropAt (size gamma - 1 + k) .-} (gamma1_args ++) <$>+                                                   lift (errorToUnsupported (transpTel' flag d phi d_zero_args))+          reportSDoc "tc.lhs.unify.inv" 20 $ "tau    :" <+> prettyTCM (map (setHiding NotHidden) tau)+          leftInv <- do+            gamma1_args <- open gamma1_args+            phi <- open phi+            -- xxi_here <- open xxi_here+            -- (xi_here_f :: Abs Telescope) <- bind "i" $ \ i -> apply <$> xxi_here <*> (take 1 `fmap` csingl i)+            -- xi_here_f <- open xi_here_f+            -- xi_args <- open xi_args+            -- xif <- bind "i" $ \ i -> do+            --                      m <- (runExceptT <$> (trFillTel' flag <$> xi_here_f <*> phi <*> xi_args <*> i))+            --                      either __IMPOSSIBLE__ id <$> lift m+            -- xif <- open xif++            xi0 <- open xi0+            xi1 <- open xi1+            delta0 <- bind "i" $ \ i -> apply <$> xpre <*> (take 1 `fmap` csingl i)+            delta0 <- open delta0+            xi0f <- bind "i" $ \ i -> do+                                 m <- trFillTel' flag <$> delta0 <*> phi <*> xi0 <*> i+                                 lift (errorToUnsupported m)+            xi0f <- open xi0f++            delta1 <- bind "i" $ \ i -> do++                   args <- mapM (open . unArg) =<< (lazyAbsApp <$> xi0f <*> i)+                   apply <$> applyN krest ((take 1 $ csingl' i) ++ args) <*> (drop 1 `fmap` csingl i)+            delta1 <- open delta1+            xi1f <- bind "i" $ \ i -> do+                                 m <- trFillTel' flag <$> delta1 <*> phi <*> xi1 <*> i+                                 lift (errorToUnsupported m)+            xi1f <- open xi1f+            fmap absBody $ bind "i" $ \ i' -> do+              let (+++) m = liftM2 (++) m+                  i = cl (lift primINeg) <@> i'+--              replaceAt (size gamma + k) <$> (fmap defaultArg $ cl primIMax <@> phi <@> i) <*> do+              do+                gamma1_args +++ (take 1 `fmap` csingl i +++ ((lazyAbsApp <$> xi0f <*> i) +++ (drop 1 `fmap` csingl i +++ (lazyAbsApp <$> xi1f <*> i))))+          return (tau,leftInv,phi)+        iz <- lift $ primIZero+        io <- lift $ primIOne+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tau    :" <+> prettyTCM (map (setHiding NotHidden) tau)+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "tauS   :" <+> prettyTCM (termsS __IMPOSSIBLE__ $ map unArg tau)+        addContext working_tel $ addContext ("r" :: String, defaultDom interval)+                               $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv:   " <+> prettyTCM (map (setHiding NotHidden) leftInv)+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv[0]:" <+> (prettyTCM =<< reduce (subst 0 iz $ map (setHiding NotHidden) leftInv))+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "leftInv[1]:" <+> (prettyTCM =<< reduce  (subst 0 io $ map (setHiding NotHidden) leftInv))+        addContext working_tel $ reportSDoc "tc.lhs.unify.inv" 20 $ "[rho]tau :" <+>+                                                                                  -- k   φ+          prettyTCM (applySubst (termsS __IMPOSSIBLE__ $ map unArg tau) $ fromPatternSubstitution+                                                                      $ raise (size (eqTel st) - 1{-k-} + phis {-neqs{-φs-} - 1{-φ0-}-})+                                                                      $ unifySubst output)+        reportSDoc "tc.lhs.unify.inv" 20 $ "."+        let rho0 = fromPatternSubstitution $ unifySubst output+        addContext (varTel next) $ addContext (eqTel next) $ reportSDoc "tc.lhs.unify.inv" 20 $+          "prf :" <+> prettyTCM (fromPatternSubstitution $ unifyProof output)+        let c0 = Lam defaultArgInfo $ Abs "i" $ raise 1 $ lookupS (fromPatternSubstitution $ unifyProof output) (neqs - k - 1)+        let c = liftS (size $ eqTel next) (raiseS 1) `applySubst` c0+        addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $+          reportSDoc "tc.lhs.unify.inv" 20 $ "c :" <+> prettyTCM c+--        let rho = liftS (neqs - k - 1) $ consS (raise (1 + k) c) $ liftS (1 + k) rho0+        let rho = singletonS (neqs - k - 1) c  `composeS` liftS (1 + neqs) rho0+        reportSDoc "tc.lhs.unify.inv" 20 $ text "old_sizes: " <+> pretty (size $ varTel st, size $ eqTel st)+        reportSDoc "tc.lhs.unify.inv" 20 $ text "new_sizes: " <+> pretty (size $ varTel next, size $ eqTel next)+--        addContext (abstract (varTel next) $ ExtendTel __DUMMY_DOM__ (Abs "φ" $ raise 1 $ eqTel next)) $+        addContext (varTel next) $ addContext ("φ" :: String, __DUMMY_DOM__) $ addContext (raise 1 $ eqTel next) $+          reportSDoc "tc.lhs.unify.inv" 20 $ "rho   :" <+> prettyTCM rho+        return $ ((working_tel+                 , rho+                 , termsS __IMPOSSIBLE__ $ map unArg tau+                 , termsS __IMPOSSIBLE__ $ map unArg leftInv)+                 , phi)+buildEquiv (UnificationStep st step@(EtaExpandVar fv _d _args) output) next = fmap Right $ do+        reportSDoc "tc.lhs.unify.inv" 20 "buildEquiv EtaExpandVar"+        let+          gamma = varTel st+          eqs = eqTel st+          x = flexVar fv+          neqs = size eqs+          phis = 1+        interval <- primIntervalType+         -- Γ, φs : I^phis+        let gamma_phis = abstract gamma $ telFromList $+              map (defaultDom . (,interval) . ("phi"++) . show) [0 .. phis - 1]+        working_tel <- abstract gamma_phis <$>+          pathTelescope (raise phis $ eqTel st) (raise phis $ eqLHS st) (raise phis $ eqRHS st)+        let raiseFrom tel x = (size working_tel - size tel) + x+        let phi = var $ raiseFrom gamma_phis 0++        caseMaybeM (expandRecordVar (raiseFrom gamma x) working_tel) __IMPOSSIBLE__ $ \ (_,tau,rho,_) -> do+          reportSDoc "tc.lhs.unify.inv" 20 $ addContext working_tel $ "tau    :" <+> prettyTCM tau+          return $ ((working_tel,rho,tau,raiseS 1),phi)++buildEquiv (UnificationStep st step output) _ = do+  reportSDoc "tc.lhs.unify.inv" 20 $ "steps"+  let illegal     = return $ Left $ Illegal step+      unsupported = return $ Left $ UnsupportedYet step+  case step of+    Deletion{}           -> illegal+    TypeConInjectivity{} -> illegal+    -- These should end up in a NoUnify+    Conflict{}    -> __IMPOSSIBLE__+    LitConflict{} -> __IMPOSSIBLE__+    Cycle{}       -> __IMPOSSIBLE__+    _ -> unsupported++explainStep :: MonadPretty m => UnifyStep -> m Doc+explainStep Injectivity{injectConstructor = ch} =+  "injectivity of the data constructor" <+> prettyTCM (conName ch)+explainStep TypeConInjectivity{} = "injectivity of type constructors"+explainStep Deletion{}           = "the K rule"+explainStep Solution{}           = "substitution in Setω"+-- Note: this is the actual reason that a Solution step can fail, rather+-- than the explanation for the actual step+explainStep Conflict{}          = "the disjointness of data constructors"+explainStep LitConflict{}       = "the disjointness of literal values"+explainStep Cycle{}             = "the impossibility of cyclic values"+explainStep EtaExpandVar{}      = "eta-expansion of variables"+explainStep EtaExpandEquation{} = "eta-expansion of equations"+explainStep StripSizeSuc{}      = "the injectivity of size successors"+explainStep SkipIrrelevantEquation{} = "ignoring irrelevant equations"
+ src/full/Agda/TypeChecking/Rules/LHS/Unify/Types.hs view
@@ -0,0 +1,510 @@+module Agda.TypeChecking.Rules.LHS.Unify.Types where++import Prelude hiding (null)++import Control.Monad+import Control.Monad.State+import Control.Monad.Writer (WriterT(..), MonadWriter(..))+import Control.Monad.Except++import Data.Foldable (toList)+import Data.Semigroup hiding (Arg)+import Data.DList (DList)+import qualified Data.List as List+import qualified Data.IntSet as IntSet+import qualified Data.IntMap as IntMap+import Data.IntMap (IntMap)++import qualified Agda.Benchmarking as Bench++import Agda.Interaction.Options (optInjectiveTypeConstructors, optCubical, optWithoutK)++import Agda.Syntax.Common+import Agda.Syntax.Internal+import Agda.Syntax.Literal++import Agda.TypeChecking.Monad+import qualified Agda.TypeChecking.Monad.Benchmark as Bench+import Agda.TypeChecking.Monad.Builtin -- (constructorForm, getTerm, builtinPathP)+import Agda.TypeChecking.Primitive hiding (Nat)+import Agda.TypeChecking.Primitive.Cubical+import Agda.TypeChecking.Names+import Agda.TypeChecking.Conversion -- equalTerm+import Agda.TypeChecking.Conversion.Pure+import Agda.TypeChecking.Constraints+import Agda.TypeChecking.Datatypes+import Agda.TypeChecking.Irrelevance+import Agda.TypeChecking.Level (reallyUnLevelView)+import Agda.TypeChecking.Reduce+import qualified Agda.TypeChecking.Patterns.Match as Match+import Agda.TypeChecking.Pretty+import Agda.TypeChecking.Substitute+import Agda.TypeChecking.Telescope+import Agda.TypeChecking.Free+import Agda.TypeChecking.Free.Precompute+import Agda.TypeChecking.Free.Reduce+import Agda.TypeChecking.Records++import Agda.TypeChecking.Rules.LHS.Problem++import Agda.Utils.Empty+import Agda.Utils.Either+import Agda.Utils.Benchmark+import Agda.Utils.Either+import Agda.Utils.Function+import Agda.Utils.Functor+import Agda.Utils.Lens+import Agda.Utils.List+import Agda.Utils.ListT+import Agda.Utils.Maybe+import Agda.Utils.Monad+import Agda.Utils.Null+import Agda.Utils.PartialOrd+import Agda.Utils.Permutation+import Agda.Utils.Singleton+import Agda.Utils.Size+import Agda.Utils.WithDefault+import Agda.Utils.Tuple++import Agda.Utils.Impossible++----------------------------------------------------+-- Equalities+----------------------------------------------------++data Equality = Equal+  { _eqType  :: Dom Type+  , _eqLeft  :: Term+  , _eqRight :: Term+  }++-- Jesper, 2020-01-19: The type type lives in the context of the+-- variables+equations, while the lhs/rhs only depend on the+-- variables, so there is no way to give a correct Reduce instance.+-- WRONG:+-- instance Reduce Equality where+--   reduce' (Equal a u v) = Equal <$> reduce' a <*> reduce' u <*> reduce' v++eqConstructorForm :: HasBuiltins m => Equality -> m Equality+eqConstructorForm (Equal a u v) = Equal a <$> constructorForm u <*> constructorForm v++eqUnLevel :: HasBuiltins m => Equality -> m Equality+eqUnLevel (Equal a u v) = Equal a <$> unLevel u <*> unLevel v+  where+    unLevel (Level l) = reallyUnLevelView l+    unLevel u         = return u++----------------------------------------------------+-- Unify state+----------------------------------------------------++data UnifyState = UState+  { varTel   :: Telescope     -- ^ Don't reduce!+  , flexVars :: FlexibleVars+  , eqTel    :: Telescope     -- ^ Can be reduced eagerly.+  , eqLHS    :: [Arg Term]    -- ^ Ends up in dot patterns (should not be reduced eagerly).+  , eqRHS    :: [Arg Term]    -- ^ Ends up in dot patterns (should not be reduced eagerly).+  } deriving (Show)+-- Issues #3578 and #4125: avoid unnecessary reduction in unifier.++lensVarTel   :: Lens' Telescope UnifyState+lensVarTel   f s = f (varTel s) <&> \ tel -> s { varTel = tel }+--UNUSED Liang-Ting Chen 2019-07-16+--lensFlexVars :: Lens' FlexibleVars UnifyState+--lensFlexVars f s = f (flexVars s) <&> \ flex -> s { flexVars = flex }++lensEqTel    :: Lens' Telescope UnifyState+lensEqTel    f s = f (eqTel s) <&> \ x -> s { eqTel = x }++--UNUSED Liang-Ting Chen 2019-07-16+--lensEqLHS    :: Lens' Args UnifyState+--lensEqLHS    f s = f (eqLHS s) <&> \ x -> s { eqLHS = x }++--UNUSED Liang-Ting Chen 2019-07-16+--lensEqRHS    :: Lens' Args UnifyState+--lensEqRHS    f s = f (eqRHS s) <&> \ x -> s { eqRHS = x }++-- UNUSED Andreas, 2019-10-14+-- instance Reduce UnifyState where+--   reduce' (UState var flex eq lhs rhs) =+--     UState <$> reduce' var+--            <*> pure flex+--            <*> reduce' eq+--            <*> reduce' lhs+--            <*> reduce' rhs++-- Andreas, 2019-10-14, issues #3578 and #4125:+-- | Don't ever reduce the whole 'varTel', as it will destroy+-- readability of the context in interactive editing!+-- To make sure this insight is not lost, the following+-- dummy instance should prevent a proper 'Reduce' instance for 'UnifyState'.+instance Reduce UnifyState where+  reduce' = __IMPOSSIBLE__++--UNUSED Liang-Ting Chen 2019-07-16+--reduceEqTel :: UnifyState -> TCM UnifyState+--reduceEqTel = lensEqTel reduce++-- UNUSED Andreas, 2019-10-14+-- instance Normalise UnifyState where+--   normalise' (UState var flex eq lhs rhs) =+--     UState <$> normalise' var+--            <*> pure flex+--            <*> normalise' eq+--            <*> normalise' lhs+--            <*> normalise' rhs++instance PrettyTCM UnifyState where+  prettyTCM state = "UnifyState" $$ nest 2 (vcat $+    [ "variable tel:  " <+> prettyTCM gamma+    , "flexible vars: " <+> pshow (map flexVarF $ flexVars state)+    , "equation tel:  " <+> addContext gamma (prettyTCM delta)+    , "equations:     " <+> addContext gamma (prettyList_ (zipWith prettyEquality (eqLHS state) (eqRHS state)))+    ])+    where+      flexVarF fi = (flexVar fi, flexForced fi)+      gamma = varTel state+      delta = eqTel state+      prettyEquality x y = prettyTCM x <+> "=?=" <+> prettyTCM y++initUnifyState+  :: PureTCM m+  => Telescope -> FlexibleVars -> Type -> Args -> Args -> m UnifyState+initUnifyState tel flex a lhs rhs = do+  (tel, a, lhs, rhs) <- instantiateFull (tel, a, lhs, rhs)+  let n = size lhs+  unless (n == size rhs) __IMPOSSIBLE__+  TelV eqTel _ <- telView a+  unless (n == size eqTel) __IMPOSSIBLE__+  return $ UState tel flex eqTel lhs rhs+  -- Andreas, 2019-02-23, issue #3578: do not eagerly reduce+  -- reduce $ UState tel flex eqTel lhs rhs++isUnifyStateSolved :: UnifyState -> Bool+isUnifyStateSolved = null . eqTel++varCount :: UnifyState -> Int+varCount = size . varTel++-- | Get the type of the i'th variable in the given state+getVarType :: Int -> UnifyState -> Dom Type+getVarType i s = indexWithDefault __IMPOSSIBLE__ (flattenTel $ varTel s) i++getVarTypeUnraised :: Int -> UnifyState -> Dom Type+getVarTypeUnraised i s = snd <$> indexWithDefault __IMPOSSIBLE__ (telToList $ varTel s) i++eqCount :: UnifyState -> Int+eqCount = size . eqTel++-- | Get the k'th equality in the given state. The left- and right-hand sides+--   of the equality live in the varTel telescope, and the type of the equality+--   lives in the varTel++eqTel telescope+getEquality :: Int -> UnifyState -> Equality+getEquality k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =+    Equal (indexWithDefault __IMPOSSIBLE__ (flattenTel eqs) k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k)++getReducedEquality+  :: (MonadReduce m, MonadAddContext m)+  => Int -> UnifyState -> m Equality+getReducedEquality k s = do+  let Equal a u v = getEquality k s+  addContext (varTel s) $ Equal+    <$> addContext (eqTel s) (reduce a)+    <*> reduce u+    <*> reduce v++-- | As getEquality, but with the unraised type+getEqualityUnraised :: Int -> UnifyState -> Equality+getEqualityUnraised k UState { eqTel = eqs, eqLHS = lhs, eqRHS = rhs } =+    Equal (snd <$> indexWithDefault __IMPOSSIBLE__ (telToList eqs) k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ lhs k)+          (unArg $ indexWithDefault __IMPOSSIBLE__ rhs k)++getReducedEqualityUnraised+  :: (MonadReduce m, MonadAddContext m)+  => Int -> UnifyState -> m Equality+getReducedEqualityUnraised k s = do+  let Equal a u v = getEqualityUnraised k s+  addContext (varTel s) $ Equal+    <$> addContext (telFromList $ take k $ telToList $ eqTel s) (reduce a)+    <*> reduce u+    <*> reduce v++--UNUSED Liang-Ting Chen 2019-07-16+--getEqInfo :: Int -> UnifyState -> ArgInfo+--getEqInfo k UState { eqTel = eqs } =+--  domInfo $ indexWithDefault __IMPOSSIBLE__ (telToList eqs) k+--+---- | Add a list of equations to the front of the equation telescope+--addEqs :: Telescope -> [Arg Term] -> [Arg Term] -> UnifyState -> UnifyState+--addEqs tel us vs s =+--  s { eqTel = tel `abstract` eqTel s+--    , eqLHS = us ++ eqLHS s+--    , eqRHS = vs ++ eqRHS s+--    }+--  where k = size tel+--+--addEq :: Type -> Arg Term -> Arg Term -> UnifyState -> UnifyState+--addEq a u v = addEqs (ExtendTel (defaultDom a) (Abs underscore EmptyTel)) [u] [v]++++-- | Instantiate the k'th variable with the given value.+--   Returns Nothing if there is a cycle.+solveVar :: Int             -- ^ Index @k@+         -> DeBruijnPattern -- ^ Solution @u@+         -> UnifyState -> Maybe (UnifyState, PatternSubstitution)+solveVar k u s = case instantiateTelescope (varTel s) k u of+  Nothing -> Nothing+  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState+      { varTel   = tel'+      , flexVars = permuteFlex (reverseP rho) $ flexVars s+      , eqTel    = applyPatSubst sigma $ eqTel s+      , eqLHS    = applyPatSubst sigma $ eqLHS s+      , eqRHS    = applyPatSubst sigma $ eqRHS s+      }+  where+    permuteFlex :: Permutation -> FlexibleVars -> FlexibleVars+    permuteFlex perm =+      mapMaybe $ \(FlexibleVar ai fc k p x) ->+        FlexibleVar ai fc k p <$> List.elemIndex x (permPicks perm)++applyUnder :: Int -> Telescope -> Term -> Telescope+applyUnder k tel u+ | k < 0     = __IMPOSSIBLE__+ | k == 0    = tel `apply1` u+ | otherwise = case tel of+    EmptyTel         -> __IMPOSSIBLE__+    ExtendTel a tel' -> ExtendTel a $+      Abs (absName tel') $ applyUnder (k-1) (absBody tel') u++dropAt :: Int -> [a] -> [a]+dropAt _ [] = __IMPOSSIBLE__+dropAt k (x:xs)+ | k < 0     = __IMPOSSIBLE__+ | k == 0    = xs+ | otherwise = x : dropAt (k-1) xs++-- | Solve the k'th equation with the given value, which can depend on+--   regular variables but not on other equation variables.+solveEq :: Int -> Term -> UnifyState -> (UnifyState, PatternSubstitution)+solveEq k u s = (,sigma) $ s+    { eqTel    = applyUnder k (eqTel s) u'+    , eqLHS    = dropAt k $ eqLHS s+    , eqRHS    = dropAt k $ eqRHS s+    }+  where+    u'    = raise k u+    n     = eqCount s+    sigma = liftS (n-k-1) $ consS (dotP u') idS++--UNUSED Liang-Ting Chen 2019-07-16+---- | Simplify the k'th equation with the given value (which can depend on other+----   equation variables). Returns Nothing if there is a cycle.+--simplifyEq :: Int -> Term -> UnifyState -> Maybe (UnifyState, PatternSubstitution)+--simplifyEq k u s = case instantiateTelescope (eqTel s) k u of+--  Nothing -> Nothing+--  Just (tel' , sigma , rho) -> Just $ (,sigma) $ UState+--    { varTel   = varTel s+--    , flexVars = flexVars s+--    , eqTel    = tel'+--    , eqLHS    = permute rho $ eqLHS s+--    , eqRHS    = permute rho $ eqRHS s+--    }+--+----------------------------------------------------+-- Unification strategies+----------------------------------------------------++data UnifyStep+  = Deletion+    { deleteAt           :: Int+    , deleteType         :: Type+    , deleteLeft         :: Term+    , deleteRight        :: Term+    }+  | Solution+    { solutionAt         :: Int+    , solutionType       :: Dom Type+    , solutionVar        :: FlexibleVar Int+    , solutionTerm       :: Term+    , solutionSide       :: Either () ()+      -- ^ side of the equation where the variable is.+    }+  | Injectivity+    { injectAt           :: Int+    , injectType         :: Type+    , injectDatatype     :: QName+    , injectParameters   :: Args+    , injectIndices      :: Args+    , injectConstructor  :: ConHead+    }+  | Conflict+    { conflictAt         :: Int+    , conflictType       :: Type+    , conflictDatatype   :: QName+    , conflictParameters :: Args+    , conflictLeft       :: Term+    , conflictRight      :: Term+    }+  | Cycle+    { cycleAt            :: Int+    , cycleType          :: Type+    , cycleDatatype      :: QName+    , cycleParameters    :: Args+    , cycleVar           :: Int+    , cycleOccursIn      :: Term+    }+  | EtaExpandVar+    { expandVar           :: FlexibleVar Int+    , expandVarRecordType :: QName+    , expandVarParameters :: Args+    }+  | EtaExpandEquation+    { expandAt           :: Int+    , expandRecordType   :: QName+    , expandParameters   :: Args+    }+  | LitConflict+    { litConflictAt      :: Int+    , litType            :: Type+    , litConflictLeft    :: Literal+    , litConflictRight   :: Literal+    }+  | StripSizeSuc+    { stripAt            :: Int+    , stripArgLeft       :: Term+    , stripArgRight      :: Term+    }+  | SkipIrrelevantEquation+    { skipIrrelevantAt   :: Int+    }+  | TypeConInjectivity+    { typeConInjectAt    :: Int+    , typeConstructor    :: QName+    , typeConArgsLeft    :: Args+    , typeConArgsRight   :: Args+    } deriving (Show)++instance PrettyTCM UnifyStep where+  prettyTCM step = case step of+    Deletion k a u v -> "Deletion" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    Solution k a i u s -> "Solution" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "variable:   " <+> text (show (flexVar i, flexPos i, flexForced i, flexKind i))+      , "term:       " <+> prettyTCM u+      , "side:       " <+> text (show s)+      ])+    Injectivity k a d pars ixs c -> "Injectivity" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "datatype:   " <+> prettyTCM d+      , "parameters: " <+> prettyList_ (map prettyTCM pars)+      , "indices:    " <+> prettyList_ (map prettyTCM ixs)+      , "constructor:" <+> prettyTCM c+      ])+    Conflict k a d pars u v -> "Conflict" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "datatype:   " <+> prettyTCM d+      , "parameters: " <+> prettyList_ (map prettyTCM pars)+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    Cycle k a d pars i u -> "Cycle" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "datatype:   " <+> prettyTCM d+      , "parameters: " <+> prettyList_ (map prettyTCM pars)+      , "variable:   " <+> text (show i)+      , "term:       " <+> prettyTCM u+      ])+    EtaExpandVar fi r pars -> "EtaExpandVar" $$ nest 2 (vcat $+      [ "variable:   " <+> text (show fi)+      , "record type:" <+> prettyTCM r+      , "parameters: " <+> prettyTCM pars+      ])+    EtaExpandEquation k r pars -> "EtaExpandEquation" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "record type:" <+> prettyTCM r+      , "parameters: " <+> prettyTCM pars+      ])+    LitConflict k a u v -> "LitConflict" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "type:       " <+> prettyTCM a+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    StripSizeSuc k u v -> "StripSizeSuc" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "lhs:        " <+> prettyTCM u+      , "rhs:        " <+> prettyTCM v+      ])+    SkipIrrelevantEquation k -> "SkipIrrelevantEquation" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      ])+    TypeConInjectivity k d us vs -> "TypeConInjectivity" $$ nest 2 (vcat $+      [ "position:   " <+> text (show k)+      , "datatype:   " <+> prettyTCM d+      , "lhs:        " <+> prettyList_ (map prettyTCM us)+      , "rhs:        " <+> prettyList_ (map prettyTCM vs)+      ])+++----------------------------------------------------+-- Unify Log and monad+----------------------------------------------------++data UnifyLogEntry+ -- = UnificationDone  UnifyState+  = UnificationStep UnifyState UnifyStep UnifyOutput++type UnifyLog = [(UnifyLogEntry,UnifyState)]++-- | This variant of 'UnifyLog' is used to ensure that 'tell' is not+-- expensive.+type UnifyLog' = DList (UnifyLogEntry, UnifyState)++-- Given varΓ ⊢ eqΓ, varΓ ⊢ us, vs : eqΓ+data UnifyOutput = UnifyOutput+  { unifySubst :: PatternSubstitution -- varΓ' ⊢ σ : varΓ+  , unifyProof :: PatternSubstitution -- varΓ',eqΓ' ⊢ ps : eqΓ[σ]+                                      -- varΓ', us' =_eqΓ' vs' ⊢ ap(ps) : us[σ] =_{eqΓ[σ]} vs[σ]+--  , unifyLog   :: UnifyLog+  }++instance Semigroup UnifyOutput where+  x <> y = UnifyOutput+    { unifySubst = unifySubst y `composeS` unifySubst x+    , unifyProof = unifyProof y `composeS` unifyProof x+--    , unifyLog   = unifyLog x ++ unifyLog y+    }++instance Monoid UnifyOutput where+  mempty  = UnifyOutput IdS IdS -- []+  mappend = (<>)++type UnifyLogT m a = WriterT UnifyLog' m a++type UnifyStepT m a = WriterT UnifyOutput m a++tellUnifySubst :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()+tellUnifySubst sub = tell $ UnifyOutput sub IdS++tellUnifyProof :: MonadWriter UnifyOutput m => PatternSubstitution -> m ()+tellUnifyProof sub = tell $ UnifyOutput IdS sub++writeUnifyLog ::+  MonadWriter UnifyLog' m => (UnifyLogEntry, UnifyState) -> m ()+writeUnifyLog x = tell (singleton x) -- UnifyOutput IdS IdS [x]++runUnifyLogT :: Functor m => UnifyLogT m a -> m (a, UnifyLog)+runUnifyLogT m = mapSnd toList <$> runWriterT m
src/full/Agda/TypeChecking/Rules/Record.hs view
@@ -11,6 +11,7 @@ import Agda.Interaction.Options  import qualified Agda.Syntax.Abstract as A+import qualified Agda.Syntax.Abstract.Views as A import Agda.Syntax.Common import Agda.Syntax.Internal import Agda.Syntax.Internal.Pattern@@ -31,11 +32,15 @@ import Agda.TypeChecking.CompiledClause (hasProjectionPatterns) import Agda.TypeChecking.CompiledClause.Compile -import Agda.TypeChecking.Rules.Data ( getGeneralizedParameters, bindGeneralizedParameters, bindParameters, fitsIn, forceSort,-                                      defineCompData, defineTranspOrHCompForFields )+import Agda.TypeChecking.Rules.Data+  ( getGeneralizedParameters, bindGeneralizedParameters, bindParameters+  , checkDataSort, fitsIn, forceSort+  , defineCompData, defineKanOperationForFields+  ) import Agda.TypeChecking.Rules.Term ( isType_ ) import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl (checkDecl) +import Agda.Utils.List (headWithDefault) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null@@ -60,7 +65,7 @@ -- --     [@ps@]      Record parameters. -----     [@contel@]  Approximate type of constructor (@fields@ -> Set).+--     [@contel@]  Approximate type of constructor (@fields@ -> dummy). --                 Does not include record parameters. -- --     [@fields@]  List of field signatures.@@ -71,11 +76,19 @@   -> UniverseCheck             -- ^ Check universes?   -> A.RecordDirectives        -- ^ (Co)Inductive, (No)Eta, (Co)Pattern, Constructor?   -> A.DataDefParams           -- ^ Record parameters.-  -> A.Expr                    -- ^ Approximate type of constructor (@fields@ -> Set).+  -> A.Expr                    -- ^ Approximate type of constructor (@fields@ -> dummy).                                --   Does not include record parameters.   -> [A.Field]                 -- ^ Field signatures.   -> TCM ()-checkRecDef i name uc (RecordDirectives ind eta0 pat con) (A.DataDefParams gpars ps) contel fields =+checkRecDef i name uc (RecordDirectives ind eta0 pat con) (A.DataDefParams gpars ps) contel0 fields = do++  -- Andreas, 2022-10-06, issue #6165:+  -- The target type of the constructor is a meaningless dummy expression which does not type-check.+  -- We replace it by Set/Type (builtinSet) which is still incorrect but type-checks.+  -- It will be fixed after type-checking.+  aType <- A.Def . fromMaybe __IMPOSSIBLE__ <$> getBuiltinName' builtinSet+  let contel = A.unPiView . (\ (A.PiView tels _) -> A.PiView tels aType) . A.piView $ contel0+   traceCall (CheckRecDef (getRange name) name ps fields) $ do     reportSDoc "tc.rec" 10 $ vcat       [ "checking record def" <+> prettyTCM name@@ -226,6 +239,8 @@                   -- in case the record turns out to be recursive.               -- Determined by positivity checker:               , recMutual         = Nothing+              -- Determined by the termination checker:+              , recTerminates     = Nothing               , recComp           = emptyCompKit -- filled in later               } @@ -258,6 +273,10 @@       -- Check that the fields fit inside the sort       _ <- fitsIn uc [] contype s +      -- Check that the sort admits record declarations.+      checkDataSort name s++       {- Andreas, 2011-04-27 WRONG because field types are checked again          and then non-stricts should not yet be irrelevant @@ -298,11 +317,16 @@        let m = qnameToMName name  -- Name of record module. +      eraseRecordParameters <- optEraseRecordParameters <$> pragmaOptions+      let maybeErase :: forall a. LensQuantity a => a -> a+          maybeErase | eraseRecordParameters = setQuantity zeroQuantity+                     | otherwise             = id+       -- Andreas, 2016-02-09 setting all parameters hidden in the record       -- section telescope changes the semantics, see e.g.       -- test/Succeed/RecordInParModule.       -- Ulf, 2016-03-02 but it's the right thing to do (#1759)-      modifyContextInfo hideOrKeepInstance $ addRecordVar $ do+      modifyContextInfo (hideOrKeepInstance . maybeErase) $ addRecordVar $ do          -- Add the record section. @@ -321,17 +345,20 @@       -- Andreas, 2016-02-09, Issue 1815 (see also issue 1759).       -- For checking the record declarations, hide the record parameters       -- and the parameters of the parent modules.-      modifyContextInfo hideOrKeepInstance $ addRecordVar $ do+      modifyContextInfo (hideOrKeepInstance . maybeErase) $ do+        params <- getContext          -- Check the types of the fields and the other record declarations.-        withCurrentModule m $ do+        addRecordVar $ withCurrentModule m $ do            -- Andreas, 2013-09-13, 2016-01-06.           -- Argument telescope for the projections: all parameters are hidden.           -- This means parameters of the parent modules and of the current           -- record type.           -- See test/Succeed/ProjectionsTakeModuleTelAsParameters.agda.-          tel' <- getContextTelescope+          tel' <- do+            r <- headWithDefault __IMPOSSIBLE__ <$> getContext+            return $ telFromList' nameToArgName $ reverse $ r : params           setModuleCheckpoint m           checkRecordProjections m name hasNamedCon con tel' ftel fields @@ -345,7 +372,6 @@       modifySignature $ updateDefinition conName $ \def ->         def { defMatchable = Set.fromList $ map unDom fs } -      return ()   where   -- Andreas, 2020-04-19, issue #4560   -- If the user declared the record constructor as @pattern@,@@ -408,8 +434,8 @@   reportSDoc "tc.rec.cxt" 30 $ prettyTCM fsT   reportSDoc "tc.rec.cxt" 30 $ pretty rect   if not $ all isJust required then return $ emptyCompKit else do-    transp <- whenDefined [builtinTrans]              (defineTranspOrHCompR DoTransp name params fsT fns rect)-    hcomp  <- whenDefined [builtinTrans,builtinHComp] (defineTranspOrHCompR DoHComp name params fsT fns rect)+    transp <- whenDefined [builtinTrans]              (defineKanOperationR DoTransp name params fsT fns rect)+    hcomp  <- whenDefined [builtinTrans,builtinHComp] (defineKanOperationR DoHComp name params fsT fns rect)     return $ CompKit       { nameOfTransp = transp       , nameOfHComp  = hcomp@@ -420,17 +446,17 @@       if all isJust xs then m else return Nothing  -defineTranspOrHCompR ::-  TranspOrHComp+defineKanOperationR+  :: Command   -> QName       -- ^ some name, e.g. record name   -> Telescope   -- ^ param types Δ   -> Telescope   -- ^ fields' types Δ ⊢ Φ   -> [Arg QName] -- ^ fields' names   -> Type        -- ^ record type Δ ⊢ T   -> TCM (Maybe QName)-defineTranspOrHCompR cmd name params fsT fns rect = do+defineKanOperationR cmd name params fsT fns rect = do   let project = (\ t fn -> t `applyE` [Proj ProjSystem fn])-  stuff <- fmap fst <$> defineTranspOrHCompForFields cmd Nothing project name params fsT fns rect+  stuff <- fmap fst <$> defineKanOperationForFields cmd Nothing project name params fsT fns rect    caseMaybe stuff (return Nothing) $ \ (theName, gamma, rtype, clause_types, bodies) -> do   -- phi = 1 clause@@ -474,36 +500,38 @@                 (g0,_:g1) = splitAt (size gamma - 1 - ix) $ flattenTel gamma                 (ns0,_:ns1) = splitAt (size gamma - 1 - ix) $ teleNames gamma -              c = Clause { clauseTel       = gamma'-                         , clauseType      = Just $ argN t-                         , namedClausePats = pats-                         , clauseFullRange = noRange+              c = Clause { clauseFullRange = noRange                          , clauseLHSRange  = noRange-                         , clauseCatchall  = False+                         , clauseTel       = gamma'+                         , namedClausePats = pats                          , clauseBody      = Just $ rhs+                         , clauseType      = Just $ argN t+                         , clauseCatchall    = False                          , clauseExact       = Just True                          , clauseRecursive   = Just False  -- definitely non-recursive!                          , clauseUnreachable = Just False-                         , clauseEllipsis  = NoEllipsis+                         , clauseEllipsis    = NoEllipsis+                         , clauseWhereModule = Nothing                          }            reportSDoc "trans.rec.face" 17 $ text $ show c            return c   cs <- forM (zip3 fns clause_types bodies) $ \ (fname, clause_ty, body) -> do           let               pats = teleNamedArgs gamma ++ [defaultNamedArg $ ProjP ProjSystem $ unArg fname]-              c = Clause { clauseTel       = gamma-                         , clauseType      = Just $ argN (unDom clause_ty)-                         , namedClausePats = pats-                         , clauseFullRange = noRange+              c = Clause { clauseFullRange = noRange                          , clauseLHSRange  = noRange-                         , clauseCatchall  = False+                         , clauseTel       = gamma+                         , namedClausePats = pats                          , clauseBody      = Just body+                         , clauseType      = Just $ argN (unDom clause_ty)+                         , clauseCatchall    = False                          , clauseExact       = Just True                          , clauseRecursive   = Nothing                              -- Andreas 2020-02-06 TODO                              -- Or: Just False;  is it known to be non-recursive?                          , clauseUnreachable = Just False-                         , clauseEllipsis  = NoEllipsis+                         , clauseEllipsis    = NoEllipsis+                         , clauseWhereModule = Nothing                          }           reportSDoc "trans.rec" 17 $ text $ show c           reportSDoc "trans.rec" 16 $ text "type =" <+> text (show (clauseType c))@@ -680,7 +708,8 @@                             , clauseExact       = Just True                             , clauseRecursive   = Just False                             , clauseUnreachable = Just False-                            , clauseEllipsis  = NoEllipsis+                            , clauseEllipsis    = NoEllipsis+                            , clauseWhereModule = Nothing                             }          let projection = Projection@@ -717,14 +746,14 @@         escapeContext impossible (size tel) $ do           lang <- getLanguage           addConstant projname $-            (defaultDefn ai projname (killRange finalt) lang-              emptyFunction-                { funClauses        = [clause]-                , funCompiled       = Just cc-                , funSplitTree      = mst-                , funProjection     = Just projection-                , funMutual         = Just []  -- Projections are not mutually recursive with anything-                , funTerminates     = Just True+            (defaultDefn ai projname (killRange finalt) lang $ FunctionDefn+              emptyFunctionData+                { _funClauses        = [clause]+                , _funCompiled       = Just cc+                , _funSplitTree      = mst+                , _funProjection     = Right projection+                , _funMutual         = Just []  -- Projections are not mutually recursive with anything+                , _funTerminates     = Just True                 })               { defArgOccurrences = [StrictPos]               , defCopatternLHS   = hasProjectionPatterns cc
src/full/Agda/TypeChecking/Rules/Term.hs view
@@ -17,7 +17,7 @@ import Agda.Interaction.Options import Agda.Interaction.Highlighting.Generate (disambiguateRecordFields) -import Agda.Syntax.Abstract (Binder)+import Agda.Syntax.Abstract (Binder, TypedBindingInfo (tbTacticAttr)) import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Abstract.Views as A import qualified Agda.Syntax.Info as A@@ -207,7 +207,7 @@         , prettyTCM x         , text $ " for interaction point " ++ show ii         ]-      mv <- lookupMeta x+      mv <- lookupLocalMeta x       let s0 = jMetaType . mvJudgement $ mv       -- Andreas, 2016-10-14, issue #2257       -- The meta was created in a context of length @n@.@@ -357,7 +357,7 @@ checkTypedBindings :: LamOrPi -> A.TypedBinding -> (Telescope -> TCM a) -> TCM a checkTypedBindings lamOrPi (A.TBind r tac xps e) ret = do     let xs = fmap (updateNamedArg $ A.unBind . A.binderName) xps-    tac <- traverse (checkTacticAttribute lamOrPi) tac+    tac <- traverse (checkTacticAttribute lamOrPi) (tbTacticAttr tac)     whenJust tac $ \ t -> reportSDoc "tc.term.tactic" 30 $ "Checked tactic attribute:" <?> prettyTCM t     -- Andreas, 2011-04-26 irrelevant function arguments may appear     -- non-strictly in the codomain type@@ -415,14 +415,13 @@   expectedType <- el primAgdaTerm --> el (primAgdaTCM <#> primLevelZero <@> primUnit)   checkExpr e expectedType -ifPath :: Type -> TCM a -> TCM a -> TCM a-ifPath ty fallback work = do-  pv <- pathView ty-  if isPathType pv then work else fallback- checkPath :: A.TypedBinding -> A.Expr -> Type -> TCM Term-checkPath b@(A.TBind _ _ (x':|[]) typ) body ty = do-    let x    = updateNamedArg (A.unBind . A.binderName) x'+checkPath b@(A.TBind _r _tac (xp :| []) typ) body ty = do+ reportSDoc "tc.term.lambda" 30 $ hsep [ "checking path lambda", prettyA xp ]+ case (A.extractPattern $ namedArg xp) of+  Just{}  -> setCurrentRange xp $ genericError $ "Patterns are not allowed in Path-lambdas"+  Nothing -> do+    let x    = updateNamedArg (A.unBind . A.binderName) xp         info = getArgInfo x     PathType s path level typ lhs rhs <- pathView ty     interval <- primIntervalType@@ -434,11 +433,12 @@         rhs' = subst 0 iOne  v     let t = Lam info $ Abs (namedArgName x) v     let btyp i = El s (unArg typ `apply` [argN i])-    locallyTC eRange (const noRange) $ blockTerm ty $ traceCall (SetRange $ getRange body) $ do+    locallyTC eRange (const noRange) $ blockTerm ty $ setCurrentRange body $ do       equalTerm (btyp iZero) lhs' (unArg lhs)       equalTerm (btyp iOne) rhs' (unArg rhs)       return t checkPath b body ty = __IMPOSSIBLE__+ --------------------------------------------------------------------------- -- * Lambda abstractions ---------------------------------------------------------------------------@@ -490,11 +490,11 @@     info = getArgInfo $ List1.head xs      trySeeingIfPath = do-      cubical <- optCubical <$> pragmaOptions+      cubical <- isJust . optCubical <$> pragmaOptions       reportSLn "tc.term.lambda" 60 $ "trySeeingIfPath for " ++ show xps-      let postpone' = if isJust cubical then postpone else \ _ _ -> dontUseTargetType+      let postpone' = if cubical then postpone else \ _ _ -> dontUseTargetType       ifBlocked target postpone' $ \ _ t -> do-        ifPath t dontUseTargetType $ if isJust cubical+        ifNotM (isPathType <$> pathView t) dontUseTargetType {-else-} $ if cubical           then checkPath b body t           else genericError $ unwords                  [ "Option --cubical/--erased-cubical needed to build"@@ -595,15 +595,7 @@   | otherwise = do       let rPi  = getRelevance dom  -- relevance of function type       let rLam = getRelevance info -- relevance of lambda-        -- Andreas, 2017-01-24, issue #2429-        -- we should report an error if we try to check a relevant function-        -- against an irrelevant function type (subtyping violation)-      unless (moreRelevant rPi rLam) $ do-        -- @rLam == Relevant@ is impossible here-        -- @rLam == Irrelevant@ is impossible here (least relevant)-        -- this error can only happen if @rLam == NonStrict@ and @rPi == Irrelevant@-        unless (rLam == NonStrict) __IMPOSSIBLE__  -- separate tests for separate line nums-        unless (rPi == Irrelevant) __IMPOSSIBLE__+      unless (sameRelevance rPi rLam) $         typeError WrongIrrelevanceInLambda       return info @@ -754,8 +746,8 @@             (\ d -> (defaultDefn (setModality mod info') aux t' lang d)                     { defPolarity       = [Nonvariant]                     , defArgOccurrences = [Unused] })-            $ emptyFunction-              { funClauses        =+            $ FunctionDefn emptyFunctionData+              { _funClauses        =                   [ Clause                     { clauseLHSRange  = getRange e                     , clauseFullRange = getRange e@@ -767,14 +759,15 @@                     , clauseExact       = Just False                     , clauseRecursive   = Just False                     , clauseUnreachable = Just True -- absurd clauses are unreachable-                    , clauseEllipsis  = NoEllipsis+                    , clauseEllipsis    = NoEllipsis+                    , clauseWhereModule = Nothing                     }                   ]-              , funCompiled       = Just $ Fail [Arg info' "()"]-              , funSplitTree      = Just $ SplittingDone 0-              , funMutual         = Just []-              , funTerminates     = Just True-              , funExtLam         = Just $ ExtLamInfo top True empty+              , _funCompiled       = Just $ Fail [Arg info' "()"]+              , _funSplitTree      = Just $ SplittingDone 0+              , _funMutual         = Just []+              , _funTerminates     = Just True+              , _funExtLam         = Just $ ExtLamInfo top True empty               }           -- Andreas 2012-01-30: since aux is lifted to toplevel           -- it needs to be applied to the current telescope (issue 557)@@ -894,7 +887,7 @@     -- There might be metas in the blocker not known in the reset state, as they could have been     -- created somewhere on the way to the type error.     blocker <- (`onBlockingMetasM` blocker) $ \ x ->-                lookupMeta' x >>= \ case+                lookupMeta x >>= \ case       -- Case: we do not know the meta, so cannot unblock.       Nothing -> return neverUnblock       -- Case: we know the meta here.@@ -908,8 +901,10 @@       -- fact not very helpful. Yes there is no hope of solving the problem, but throwing a hard       -- error means we rob the user of the tools needed to figure out why the meta has not been       -- solved. Better to leave the constraint.-      Just m | InstV{} <- mvInstantiation m -> return alwaysUnblock-             | otherwise -> return $ unblockOnMeta x+      Just Left{} -> return alwaysUnblock+      Just (Right m)+        | InstV{} <- mvInstantiation m -> return alwaysUnblock+        | otherwise                    -> return $ unblockOnMeta x      -- If it's not blocked or we can't ever unblock reraise the error.     if blocker `elem` [neverUnblock, alwaysUnblock] then reraise else handle (err, blocker)@@ -993,6 +988,15 @@         , "  con = " <> return (P.pretty con)         ] +      -- Record expressions corresponding to erased record+      -- constructors can only be used in compile-time mode.+      constructorQ <- getQuantity <$> getConstInfo (conName con)+      currentQ     <- viewTC eQuantity+      unless (constructorQ `moreQuantity` currentQ) $+        typeError $ GenericError $+        "A record expression corresponding to an erased record " +++        "constructor must only be used in erased settings"+       -- Andreas, 2018-09-06, issue #3122.       -- Associate the concrete record field names used in the record expression       -- to their counterpart in the record type definition.@@ -1245,8 +1249,6 @@             (dontCare <$> do applyRelevanceToContext Irrelevant $ checkExpr' cmp e t)             (internalError "DontCare may only appear in irrelevant contexts") -        A.ETel _   -> __IMPOSSIBLE__-         A.Dot{} -> genericError "Invalid dotted expression"          -- Application@@ -1327,7 +1329,6 @@       A.Rec{}        -> True       A.RecUpdate{}  -> True       A.ScopedExpr{} -> __IMPOSSIBLE__-      A.ETel{}       -> __IMPOSSIBLE__       _ -> False  ---------------------------------------------------------------------------@@ -1362,10 +1363,10 @@   case ok of     Left (BlockedOnMeta oldState blocker) -> do       putTC oldState-      let stripFreshMeta x = maybe neverUnblock (const $ unblockOnMeta x) <$> lookupMeta' x+      let stripFreshMeta x = maybe neverUnblock (const $ unblockOnMeta x) <$> lookupLocalMeta' x       blocker' <- onBlockingMetasM stripFreshMeta blocker       r <- case Set.toList $ allBlockingMetas blocker' of-            x : _ -> getRange <$> lookupMeta' x+            x : _ -> getRange <$> lookupLocalMeta' x             []    -> return noRange       setCurrentRange r $         addConstraint blocker' (UnquoteTactic tac hole goal)@@ -1470,7 +1471,7 @@   -> TCM (Args, Type)   -- ^ Remaining inferred arguments, remaining type. checkKnownArguments []           vs t = return (vs, t) checkKnownArguments (arg : args) vs t = do-  (vs', t') <- traceCall (SetRange $ getRange arg) $ checkKnownArgument arg vs t+  (vs', t') <- setCurrentRange arg $ checkKnownArgument arg vs t   checkKnownArguments args vs' t'  -- | Check an argument whose value we already know.@@ -1647,7 +1648,7 @@         ]       ]     fvs <- getContextSize-    checkLeftHandSide (CheckPattern p EmptyTel t) Nothing [p0] t0 Nothing [] $ \ (LHSResult _ delta0 ps _ _t _ asb _) -> bindAsPatterns asb $ do+    checkLeftHandSide (CheckPattern p EmptyTel t) Nothing [p0] t0 Nothing [] $ \ (LHSResult _ delta0 ps _ _t _ asb _ _) -> bindAsPatterns asb $ do           -- After dropping the free variable patterns there should be a single pattern left.       let p = case drop fvs ps of [p] -> namedArg p; _ -> __IMPOSSIBLE__           -- Also strip the context variables from the telescope
src/full/Agda/TypeChecking/Serialise.hs view
@@ -36,19 +36,21 @@ import Control.Monad.IO.Class ( MonadIO(..) ) import Control.Monad.Reader import Control.Monad.State.Strict+import Control.Monad.ST.Trans  import Data.Array.IArray+import Data.Array.IO import Data.Word+import Data.Int (Int32) import Data.ByteString.Lazy    ( ByteString ) import Data.ByteString.Builder ( byteString, toLazyByteString ) import qualified Data.ByteString.Lazy as L-import qualified Data.HashTable.IO as H import qualified Data.Map as Map import qualified Data.Binary as B import qualified Data.Binary.Get as B import qualified Data.Binary.Put as B import qualified Data.List as List-import Data.Function+import Data.Function (on) #if !(MIN_VERSION_base(4,11,0)) import Data.Semigroup((<>)) #endif@@ -67,10 +69,11 @@  import Agda.TypeChecking.Monad -import Agda.Utils.FileName (canonicalizeAbsolutePath) import Agda.Utils.Hash+import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef import Agda.Utils.Null+import qualified Agda.Utils.ProfileOptions as Profile  import Agda.Utils.Impossible @@ -79,7 +82,7 @@ -- 32-bit machines). Word64 does not have these problems.  currentInterfaceVersion :: Word64-currentInterfaceVersion = 20220211 * 10 + 0+currentInterfaceVersion = 20221119 * 10 + 0  -- | The result of 'encode' and 'encodeInterface'. @@ -96,18 +99,15 @@  encode :: EmbPrj a => a -> TCM Encoded encode a = do-    collectStats <- hasVerbosity "profile.serialize" 20-    fileMod <- sourceToModule+    collectStats <- hasProfileOption Profile.Serialize     newD@(Dict nD ltD stD bD iD dD _tD       _nameD       _qnameD       nC ltC stC bC iC dC tC       nameC       qnameC-      stats _ _) <- liftIO $ emptyDict collectStats-    root <- liftIO $ (`runReaderT` newD) $ do-       icodeFileMod fileMod  -- Only fills absPathD from fileMod-       icode a+      stats _) <- liftIO $ emptyDict collectStats+    root <- liftIO $ (`runReaderT` newD) $ icode a     nL  <- benchSort $ l nD     stL <- benchSort $ l stD     ltL <- benchSort $ l ltD@@ -115,9 +115,9 @@     iL  <- benchSort $ l iD     dL  <- benchSort $ l dD     -- Record reuse statistics.-    verboseS "profile.sharing" 10 $ do+    whenProfile Profile.Sharing $ do       statistics "pointers" tC-    verboseS "profile.serialize" 10 $ do+    whenProfile Profile.Serialize $ do       statistics "Integer"     iC       statistics "Lazy Text"   ltC       statistics "Strict Text" stC@@ -167,13 +167,32 @@ --       (shared, total) <- readIORef stats --       return (B.encode currentInterfaceVersion <> --               G.compress (B.encode (root, nL, sL, iL, dL)), shared, total)---     verboseS "profile.sharing" 10 $ do+--     whenProfile Profile.Sharing $ do --       tickN "pointers (reused)" $ fromIntegral shared --       tickN "pointers" $ fromIntegral total --     return x --   where --   l h = List.map fst . List.sortBy (compare `on` snd) <$> H.toList h +newtype ListLike a = ListLike { unListLike :: Array Int32 a }++instance B.Binary a => B.Binary (ListLike a) where+  put = __IMPOSSIBLE__ -- Will never serialise this+  get = fmap ListLike $ runSTArray $ do+    n <- lift (B.get :: B.Get Int)+    arr <- newArray_ (0, fromIntegral n - 1) :: STT s B.Get (STArray s Int32 a)++    -- We'd like to use 'for_ [0..n-1]' here, but unfortunately GHC doesn't unfold+    -- the list construction and so performs worse than the hand-written version.+    let+      getMany i = if i == n then return () else do+        x <- lift B.get+        unsafeWriteSTArray arr i x+        getMany (i + 1)+    () <- getMany 0++    return arr+ -- | Decodes an uncompressed bytestring (without extra hashes or magic -- numbers). The result depends on the include path. --@@ -195,8 +214,9 @@      then noResult "Garbage at end."      else do -      st <- St (ar nL) (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL)-              <$> liftIO H.new+      let nL' = ar nL+      st <- St nL' (ar ltL) (ar stL) (ar bL) (ar iL) (ar dL)+              <$> liftIO (newArray (bounds nL') mempty)               <*> return mf <*> return incs       (r, st) <- runStateT (runExceptT (value r)) st       return (Just $ modFile st, r)@@ -224,7 +244,7 @@       return Nothing    where-  ar l = listArray (0, List.genericLength l - 1) l+  ar = unListLike    noResult s = return (Nothing, Left $ GenericError s) @@ -294,20 +314,3 @@  decodeFile :: FilePath -> TCM (Maybe Interface) decodeFile f = decodeInterface =<< liftIO (L.readFile f)---- | Store a 'SourceToModule' (map from 'AbsolutePath' to 'TopLevelModuleName')---   as map from 'AbsolutePath' to 'Int32', in order to directly get the identifiers---   from absolute pathes rather than going through top level module names.-icodeFileMod-  :: SourceToModule-     -- ^ Maps file names to the corresponding module names.-     --   Must contain a mapping for every file name that is later encountered.-  -> S ()-icodeFileMod fileMod = do-  hmap <- asks absPathD-  forM_ (Map.toList fileMod) $ \ (absolutePath, topLevelModuleName) -> do-    -- Andreas, 2020-08-11, issue #4828.-    -- Expand symlinks before storing in the dictonary.-    absolutePath <- liftIO $ canonicalizeAbsolutePath absolutePath-    i <- icod_ topLevelModuleName-    liftIO $ H.insert hmap absolutePath i
src/full/Agda/TypeChecking/Serialise/Base.hs view
@@ -16,9 +16,10 @@ import Data.Proxy  import Data.Array.IArray+import Data.Array.IO+import qualified Data.HashMap.Strict as Hm import qualified Data.ByteString.Lazy as L import Data.Hashable-import qualified Data.HashTable.IO as H import Data.Int (Int32) import Data.Maybe import qualified Data.Binary as B@@ -32,6 +33,8 @@ import Agda.TypeChecking.Monad.Base (TypeError(GenericError), ModuleToSource)  import Agda.Utils.FileName+import Agda.Utils.HashTable (HashTable)+import qualified Agda.Utils.HashTable as H import Agda.Utils.IORef import Agda.Utils.Lens import Agda.Utils.Monad@@ -42,19 +45,6 @@  type Node = [Int32] --- | The type of hashtables used in this module.------ A very limited amount of testing indicates that 'H.CuckooHashTable'--- is somewhat slower than 'H.BasicHashTable', and that--- 'H.LinearHashTable' and the hashtables from "Data.Hashtable" are--- much slower.--#if defined(mingw32_HOST_OS) && defined(x86_64_HOST_ARCH)-type HashTable k v = H.CuckooHashTable k v-#else-type HashTable k v = H.BasicHashTable k v-#endif- -- | Structure providing fresh identifiers for hash map --   and counting hash map hits (i.e. when no fresh identifier required). #ifdef DEBUG@@ -119,7 +109,6 @@   , collectStats :: Bool     -- ^ If @True@ collect in @stats@ the quantities of     --   calls to @icode@ for each @Typeable a@.-  , absPathD     :: !(HashTable AbsolutePath Int32) -- ^ Not written to interface file.   }  -- | Creates an empty dictionary.@@ -128,15 +117,15 @@      -- ^ Collect statistics for @icode@ calls?   -> IO Dict emptyDict collectStats = Dict-  <$> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new-  <*> H.new+  <$> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty+  <*> H.empty   <*> newIORef farEmpty   <*> newIORef farEmpty   <*> newIORef farEmpty@@ -146,15 +135,14 @@   <*> newIORef farEmpty   <*> newIORef farEmpty   <*> newIORef farEmpty-  <*> H.new+  <*> H.empty   <*> pure collectStats-  <*> H.new  -- | Universal type, wraps everything. data U = forall a . Typeable a => U !a  -- | Univeral memo structure, to introduce sharing during decoding-type Memo = HashTable (Int32, TypeRep) U    -- (node index, type rep)+type Memo = IOArray Int32 (Hm.HashMap TypeRep U) -- node index -> (type rep -> value)  -- | State of the decoder. data St = St@@ -380,14 +368,14 @@     let aTyp = typeRep (Proxy :: Proxy a)     -- to introduce sharing, see if we have seen a thing     -- represented by ix before-    maybeU <- liftIO $ H.lookup memo (ix, aTyp)-    case maybeU of+    slot <- liftIO $ readArray memo ix+    case Hm.lookup aTyp slot of       -- yes, we have seen it before, use the version from memo       Just (U u) -> maybe malformed return (cast u)       -- no, it's new, so generate it via valu and insert it into memo       Nothing    -> do           v <- valu . (! ix) =<< gets nodeE-          liftIO $ H.insert memo (ix, aTyp) (U v)+          liftIO $ writeArray memo ix (Hm.insert aTyp (U v) slot)           return v  -- | @icodeArgs proxy (a1, ..., an)@ maps @icode@ over @a1@, ..., @an@
src/full/Agda/TypeChecking/Serialise/Instances.hs view
@@ -4,7 +4,7 @@ module Agda.TypeChecking.Serialise.Instances () where  import Agda.Syntax.Position-import Agda.Syntax.Abstract.Name+import Agda.Syntax.TopLevelModuleName import Agda.TypeChecking.Monad.Base import Agda.TypeChecking.Serialise.Base import Agda.TypeChecking.Serialise.Instances.Common (SerialisedRange(..))@@ -12,21 +12,24 @@ import Agda.TypeChecking.Serialise.Instances.Errors () import Agda.Utils.Hash -type RangedImportedModules = [(SerialisedRange, ModuleName, Hash)]+type RangedImportedModules =+  [(SerialisedRange, TopLevelModuleName, Hash)] -fromImportedModules :: [(ModuleName, Hash)] -> RangedImportedModules+fromImportedModules ::+  [(TopLevelModuleName, Hash)] -> RangedImportedModules fromImportedModules ms = [(SerialisedRange $ getRange x, x, hash) | (x, hash) <- ms] -toImportedModules :: RangedImportedModules -> [(ModuleName, Hash)]+toImportedModules ::+  RangedImportedModules -> [(TopLevelModuleName, Hash)] toImportedModules ms = [(setRange (underlyingRange r) x, hash) | (r, x, hash) <- ms]  instance EmbPrj Interface where-  icod_ (Interface a b c d e f g h i j k l m n o p q r s t) =-      icodeN' interface a b c (fromImportedModules d) e f g h i j k l m n o p q r s t+  icod_ (Interface a b c d e f g h i j k l m n o p q r s t u v) =+      icodeN' interface a b c (fromImportedModules d) e f g h i j k l m n o p q r s t u v     where interface a b c = Interface a b c . toImportedModules    value = vcase valu where-    valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t] =-        valuN interface a b c d e f g h i j k l m n o p q r s t+    valu [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v] =+        valuN interface a b c d e f g h i j k l m n o p q r s t u v       where interface a b c = Interface a b c . toImportedModules     valu _ = malformed
src/full/Agda/TypeChecking/Serialise/Instances/Common.hs view
@@ -13,7 +13,6 @@ import Data.Word import qualified Data.Foldable as Fold import Data.Hashable-import qualified Data.HashTable.IO as H import Data.Int (Int32)  import Data.Map (Map)@@ -21,8 +20,6 @@ import Data.Set (Set) import qualified Data.IntSet as IntSet import Data.IntSet (IntSet)-import Data.List.NonEmpty (NonEmpty(..), nonEmpty)-import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Set as Set import Data.Sequence (Seq) import qualified Data.Sequence as Seq@@ -41,6 +38,7 @@ import qualified Agda.Syntax.Abstract as A import Agda.Syntax.Position as P import Agda.Syntax.Literal+import Agda.Syntax.TopLevelModuleName import Agda.Interaction.FindFile  import Agda.TypeChecking.Serialise.Base@@ -49,6 +47,9 @@ import qualified Agda.Utils.BiMap as BiMap import qualified Agda.Utils.Empty as Empty import Agda.Utils.FileName+import qualified Agda.Utils.HashTable as H+import Agda.Utils.List1 (List1)+import qualified Agda.Utils.List1 as List1 import Agda.Utils.List2 (List2(List2)) import qualified Agda.Utils.List2 as List2 import Agda.Utils.Maybe@@ -194,36 +195,6 @@     [1, a] -> valuN Cubical a     _      -> malformed -instance EmbPrj AbsolutePath where-  icod_ file = do-    d <- asks absPathD-    -- Andreas, 2020-08-11, issue #4828-    -- AbsolutePath is no longer canonical (can contain symlinks).-    -- The dictonary contains canonical pathes, though.-    file <- liftIO $ canonicalizeAbsolutePath file-    liftIO $ flip fromMaybeM (H.lookup d file) $ do-      -- The path @file@ should be cached in the dictionary @d@.-      -- This seems not to be the case, thus, crash here.-      -- But leave some hints for the posterity why things could go so wrong.-      -- reportSLn "impossible" 10 -- does not work here-      putStrLn $ unlines $-        [ "Panic while serializing absolute path: " ++ show file-        , "The path could not be found in the dictionary:"-        ]-      print =<< H.toList d-      __IMPOSSIBLE__--  value m = do-    m :: TopLevelModuleName-            <- value m-    mf      <- gets modFile-    incs    <- gets includes-    (r, mf) <- liftIO $ findFile'' incs m mf-    modify $ \s -> s { modFile = mf }-    case r of-      Left err -> throwError $ findErrorToTypeError m err-      Right f  -> return (srcFilePath f)- instance EmbPrj a => EmbPrj (Position' a) where   icod_ (P.Pn file pos line col) = icodeN' P.Pn file pos line col @@ -240,7 +211,7 @@     _ -> malformed  instance EmbPrj TopLevelModuleName where-  icod_ (TopLevelModuleName a b) = icodeN' TopLevelModuleName a b+  icod_ (TopLevelModuleName a b c) = icodeN' TopLevelModuleName a b c    value = valueN TopLevelModuleName @@ -253,9 +224,9 @@ --                            valu [x, xs] = valu2 (:) x xs --                            valu _       = malformed -instance EmbPrj a => EmbPrj (NonEmpty a) where-  icod_ = icod_ . NonEmpty.toList-  value = maybe malformed return . nonEmpty <=< value+instance EmbPrj a => EmbPrj (List1 a) where+  icod_ = icod_ . List1.toList+  value = maybe malformed return . List1.nonEmpty <=< value  instance EmbPrj a => EmbPrj (List2 a) where   icod_ = icod_ . List2.toList@@ -266,9 +237,31 @@   icod_ m = icode (BiMap.toDistinctAscendingLists m)   value m = BiMap.fromDistinctAscendingLists <$> value m ++-- | Encode a list of key-value pairs as a flat list.+mapPairsIcode :: (EmbPrj k, EmbPrj v) => [(k, v)] -> S Int32+mapPairsIcode xs = icodeNode =<< convert [] xs where+  -- As we need to call `convert' in the tail position, the resulting list is+  -- written (and read) in reverse order, with the highest pair first in the+  -- resulting list.+  convert ys [] = return ys+  convert ys ((start, entry):xs) = do+    start <- icode start+    entry <- icode entry+    convert (start:entry:ys) xs++mapPairsValue :: (EmbPrj k, EmbPrj v) => [Int32] -> R [(k, v)]+mapPairsValue = convert [] where+  convert ys [] = return ys+  convert ys (start:entry:xs) = do+    start <- value start+    entry <- value entry+    convert ((start, entry):ys) xs+  convert _ _ = malformed+ instance (Ord a, EmbPrj a, EmbPrj b) => EmbPrj (Map a b) where-  icod_ m = icode (Map.toAscList m)-  value m = Map.fromDistinctAscList <$> value m+  icod_ m = mapPairsIcode (Map.toAscList m)+  value = vcase (fmap Map.fromDistinctAscList . mapPairsValue)  instance (Ord a, EmbPrj a) => EmbPrj (Set a) where   icod_ s = icode (Set.toAscList s)@@ -292,6 +285,21 @@    value = valueN P.Interval +instance EmbPrj RangeFile where+  icod_ (RangeFile _ Nothing)  = __IMPOSSIBLE__+  icod_ (RangeFile _ (Just a)) = icode a++  value r = do+    m :: TopLevelModuleName+            <- value r+    mf      <- gets modFile+    incs    <- gets includes+    (r, mf) <- liftIO $ findFile'' incs m mf+    modify $ \s -> s { modFile = mf }+    case r of+      Left err -> throwError $ findErrorToTypeError m err+      Right f  -> return $ RangeFile (srcFilePath f) (Just m)+ -- | Ranges are always deserialised as 'noRange'.  instance EmbPrj Range where@@ -386,23 +394,29 @@    value = valueN (\ f n -> Fixity' f n noRange) -instance EmbPrj GenPart where-  icod_ (BindHole a b)   = icodeN 0 BindHole a b-  icod_ (NormalHole a b) = icodeN 1 NormalHole a b-  icod_ (WildHole a)     = icodeN 2 WildHole a-  icod_ (IdPart a)       = icodeN' IdPart a+instance EmbPrj BoundVariablePosition where+  icod_ (BoundVariablePosition a b) = icodeN' BoundVariablePosition a b +  value = valueN BoundVariablePosition++instance EmbPrj NotationPart where+  icod_ (VarPart a b)  = icodeN 0 VarPart a b+  icod_ (HolePart a b) = icodeN 1 HolePart a b+  icod_ (WildPart a)   = icodeN 2 WildPart a+  icod_ (IdPart a)     = icodeN' IdPart a+   value = vcase valu where-    valu [0, a, b] = valuN BindHole a b-    valu [1, a, b] = valuN NormalHole a b-    valu [2, a]    = valuN WildHole a+    valu [0, a, b] = valuN VarPart a b+    valu [1, a, b] = valuN HolePart a b+    valu [2, a]    = valuN WildPart a     valu [a]       = valuN IdPart a     valu _         = malformed  instance EmbPrj MetaId where-  icod_ (MetaId n) = icod_ n-  value i = MetaId <$> value i+  icod_ (MetaId a b) = icode (a, b) +  value m = uncurry MetaId <$> value m+ instance EmbPrj A.QName where   icod_ n@(A.QName a b) = icodeMemo qnameD qnameC (qnameId n) $ icodeN' A.QName a b @@ -453,8 +467,8 @@   value = valueN NameId  instance (Eq k, Hashable k, EmbPrj k, EmbPrj v) => EmbPrj (HashMap k v) where-  icod_ m = icode (HMap.toList m)-  value m = HMap.fromList `fmap` value m+  icod_ m = mapPairsIcode (HMap.toList m)+  value = vcase (fmap HMap.fromList . mapPairsValue)  instance EmbPrj a => EmbPrj (WithHiding a) where   icod_ (WithHiding a b) = icodeN' WithHiding a b
src/full/Agda/TypeChecking/Serialise/Instances/Errors.hs view
@@ -16,6 +16,7 @@ import Agda.Interaction.Library.Base import Agda.Termination.CutOff import Agda.Utils.Pretty+import Agda.Utils.ProfileOptions  import Agda.Utils.Impossible @@ -62,8 +63,8 @@     IllformedAsClause a                   -> icodeN 15 IllformedAsClause a     WithoutKFlagPrimEraseEquality         -> icodeN 16 WithoutKFlagPrimEraseEquality     InstanceWithExplicitArg a             -> icodeN 17 InstanceWithExplicitArg a-    InfectiveImport a b                   -> icodeN 18 InfectiveImport a b-    CoInfectiveImport a b                 -> icodeN 19 CoInfectiveImport a b+    InfectiveImport a                     -> icodeN 18 InfectiveImport a+    CoInfectiveImport a                   -> icodeN 19 CoInfectiveImport a     InstanceNoOutputTypeName a            -> icodeN 20 InstanceNoOutputTypeName a     InstanceArgWithExplicitArg a          -> icodeN 21 InstanceArgWithExplicitArg a     WrongInstanceDeclaration              -> icodeN 22 WrongInstanceDeclaration@@ -84,6 +85,8 @@     RewriteMissingRule a b c              -> icodeN 37 RewriteMissingRule a b c     ParseWarning a                        -> icodeN 38 ParseWarning a     NoGuardednessFlag a                   -> icodeN 39 NoGuardednessFlag a+    UnsupportedIndexedMatch f             -> icodeN 40 UnsupportedIndexedMatch f+    OptionWarning a                       -> icodeN 41 OptionWarning a    value = vcase $ \ case     [0, a, b]            -> valuN UnreachableClauses a b@@ -104,8 +107,8 @@     [15, a]              -> valuN IllformedAsClause a     [16]                 -> valuN WithoutKFlagPrimEraseEquality     [17, a]              -> valuN InstanceWithExplicitArg a-    [18, a, b]           -> valuN InfectiveImport a b-    [19, a, b]           -> valuN CoInfectiveImport a b+    [18, a]              -> valuN InfectiveImport a+    [19, a]              -> valuN CoInfectiveImport a     [20, a]              -> valuN InstanceNoOutputTypeName a     [21, a]              -> valuN InstanceArgWithExplicitArg a     [22]                 -> valuN WrongInstanceDeclaration@@ -126,8 +129,18 @@     [37, a, b, c]        -> valuN RewriteMissingRule a b c     [38, a]              -> valuN ParseWarning a     [39, a]              -> valuN NoGuardednessFlag a+    [40, a]              -> valuN UnsupportedIndexedMatch a+    [41, a]              -> valuN OptionWarning a     _ -> malformed +instance EmbPrj OptionWarning where+  icod_ = \case+    OptionRenamed a b -> icodeN' OptionRenamed a b++  value = vcase $ \case+    [a, b] -> valuN OptionRenamed a b+    _ -> malformed+ instance EmbPrj ParseWarning where   icod_ = \case     OverlappingTokensWarning a -> icodeN 0 OverlappingTokensWarning a@@ -191,6 +204,7 @@     InvalidConstructor a              -> icodeN 30 InvalidConstructor a     InvalidConstructorBlock a         -> icodeN 31 InvalidConstructorBlock a     MissingDeclarations a             -> icodeN 32 MissingDeclarations a+    HiddenGeneralize r                -> icodeN 33 HiddenGeneralize r    value = vcase $ \case     [0, a]   -> valuN UnknownNamesInFixityDecl a@@ -226,6 +240,7 @@     [30,r]   -> valuN InvalidConstructor r     [31,r]   -> valuN InvalidConstructorBlock r     [32,r]   -> valuN MissingDeclarations r+    [33,r]   -> valuN HiddenGeneralize r     _ -> malformed  instance EmbPrj LibWarning where@@ -265,16 +280,36 @@    value = valueN text +instance EmbPrj InfectiveCoinfective where+  icod_ Infective   = icodeN' Infective+  icod_ Coinfective = icodeN 0 Coinfective++  value = vcase valu where+    valu []  = valuN Infective+    valu [0] = valuN Coinfective+    valu _   = malformed+ instance EmbPrj PragmaOptions where   icod_ = \case-    PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ->-      icodeN' PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc+    PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ddd eee fff ggg hhh ->+      icodeN' PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ddd eee fff ggg hhh    value = vcase $ \case-    [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, ll, mm, nn, oo, pp, qq, rr, ss, tt, uu, vv, ww, xx, yy, zz, aaa, bbb, ccc] ->-      valuN PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc+    [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, ll, mm, nn, oo, pp, qq, rr, ss, tt, uu, vv, ww, xx, yy, zz, aaa, bbb, ccc, ddd, eee, fff, ggg, hhh] ->+      valuN PragmaOptions a b c d e f g h i j k l m n o p q r s t u v w x y z aa bb cc dd ee ff gg hh ii jj kk ll mm nn oo pp qq rr ss tt uu vv ww xx yy zz aaa bbb ccc ddd eee fff ggg hhh     _ -> malformed +instance EmbPrj ProfileOptions where+  icod_ opts = icode (profileOptionsToList opts)+  value = fmap profileOptionsFromList . value++instance EmbPrj ProfileOption where+  icod_ = icode . fromEnum+  value = value >=> \ n -> if lo <= n && n <= hi then pure (toEnum n) else malformed+    where+      lo = fromEnum (minBound :: ProfileOption)+      hi = fromEnum (maxBound :: ProfileOption)+ instance EmbPrj UnicodeOrAscii  instance EmbPrj ConfluenceCheck where@@ -295,9 +330,202 @@     _ -> malformed  instance EmbPrj WarningName where-  icod_ x = icod_ (warningName2String x)+  icod_ = return . \case+    OverlappingTokensWarning_                    -> 0+    UnsupportedAttribute_                        -> 1+    MultipleAttributes_                          -> 2+    LibUnknownField_                             -> 3+    EmptyAbstract_                               -> 4+    EmptyConstructor_                            -> 5+    EmptyField_                                  -> 6+    EmptyGeneralize_                             -> 7+    EmptyInstance_                               -> 8+    EmptyMacro_                                  -> 9+    EmptyMutual_                                 -> 10+    EmptyPostulate_                              -> 11+    EmptyPrimitive_                              -> 12+    EmptyPrivate_                                -> 13+    EmptyRewritePragma_                          -> 14+    EmptyWhere_                                  -> 15+    HiddenGeneralize_                            -> 16+    InvalidCatchallPragma_                       -> 17+    InvalidConstructor_                          -> 18+    InvalidConstructorBlock_                     -> 19+    InvalidCoverageCheckPragma_                  -> 20+    InvalidNoPositivityCheckPragma_              -> 21+    InvalidNoUniverseCheckPragma_                -> 22+    InvalidRecordDirective_                      -> 23+    InvalidTerminationCheckPragma_               -> 24+    MissingDeclarations_                         -> 25+    MissingDefinitions_                          -> 26+    NotAllowedInMutual_                          -> 27+    OpenPublicAbstract_                          -> 28+    OpenPublicPrivate_                           -> 29+    PolarityPragmasButNotPostulates_             -> 30+    PragmaCompiled_                              -> 31+    PragmaNoTerminationCheck_                    -> 32+    ShadowingInTelescope_                        -> 33+    UnknownFixityInMixfixDecl_                   -> 34+    UnknownNamesInFixityDecl_                    -> 35+    UnknownNamesInPolarityPragmas_               -> 36+    UselessAbstract_                             -> 37+    UselessInstance_                             -> 38+    UselessPrivate_                              -> 39+    AbsurdPatternRequiresNoRHS_                  -> 40+    AsPatternShadowsConstructorOrPatternSynonym_ -> 41+    CantGeneralizeOverSorts_                     -> 42+    ClashesViaRenaming_                          -> 43+    CoverageIssue_                               -> 44+    CoverageNoExactSplit_                        -> 45+    DeprecationWarning_                          -> 46+    DuplicateUsing_                              -> 47+    FixityInRenamingModule_                      -> 48+    GenericNonFatalError_                        -> 49+    GenericUseless_                              -> 50+    GenericWarning_                              -> 51+    IllformedAsClause_                           -> 52+    InstanceArgWithExplicitArg_                  -> 53+    InstanceWithExplicitArg_                     -> 54+    InstanceNoOutputTypeName_                    -> 55+    InversionDepthReached_                       -> 56+    ModuleDoesntExport_                          -> 57+    NoGuardednessFlag_                           -> 58+    NotInScope_                                  -> 59+    NotStrictlyPositive_                         -> 60+    UnsupportedIndexedMatch_                        -> 61+    OldBuiltin_                                  -> 62+    PragmaCompileErased_                         -> 63+    RewriteMaybeNonConfluent_                    -> 64+    RewriteNonConfluent_                         -> 65+    RewriteAmbiguousRules_                       -> 66+    RewriteMissingRule_                          -> 67+    SafeFlagEta_                                 -> 68+    SafeFlagInjective_                           -> 69+    SafeFlagNoCoverageCheck_                     -> 70+    SafeFlagNonTerminating_                      -> 71+    SafeFlagNoPositivityCheck_                   -> 72+    SafeFlagNoUniverseCheck_                     -> 73+    SafeFlagPolarity_                            -> 74+    SafeFlagPostulate_                           -> 75+    SafeFlagPragma_                              -> 76+    SafeFlagTerminating_                         -> 77+    SafeFlagWithoutKFlagPrimEraseEquality_       -> 78+    TerminationIssue_                            -> 79+    UnreachableClauses_                          -> 80+    UnsolvedConstraints_                         -> 81+    UnsolvedInteractionMetas_                    -> 82+    UnsolvedMetaVariables_                       -> 83+    UselessHiding_                               -> 84+    UselessInline_                               -> 85+    UselessPatternDeclarationForRecord_          -> 86+    UselessPublic_                               -> 87+    UserWarning_                                 -> 88+    WithoutKFlagPrimEraseEquality_               -> 89+    WrongInstanceDeclaration_                    -> 90+    CoInfectiveImport_                           -> 91+    InfectiveImport_                             -> 92+    DuplicateFieldsWarning_                      -> 93+    TooManyFieldsWarning_                        -> 94+    OptionRenamed_                               -> 95 -  value = (maybe malformed return . string2WarningName) <=< value+  value = \case+    0  -> return OverlappingTokensWarning_+    1  -> return UnsupportedAttribute_+    2  -> return MultipleAttributes_+    3  -> return LibUnknownField_+    4  -> return EmptyAbstract_+    5  -> return EmptyConstructor_+    6  -> return EmptyField_+    7  -> return EmptyGeneralize_+    8  -> return EmptyInstance_+    9  -> return EmptyMacro_+    10 -> return EmptyMutual_+    11 -> return EmptyPostulate_+    12 -> return EmptyPrimitive_+    13 -> return EmptyPrivate_+    14 -> return EmptyRewritePragma_+    15 -> return EmptyWhere_+    16 -> return HiddenGeneralize_+    17 -> return InvalidCatchallPragma_+    18 -> return InvalidConstructor_+    19 -> return InvalidConstructorBlock_+    20 -> return InvalidCoverageCheckPragma_+    21 -> return InvalidNoPositivityCheckPragma_+    22 -> return InvalidNoUniverseCheckPragma_+    23 -> return InvalidRecordDirective_+    24 -> return InvalidTerminationCheckPragma_+    25 -> return MissingDeclarations_+    26 -> return MissingDefinitions_+    27 -> return NotAllowedInMutual_+    28 -> return OpenPublicAbstract_+    29 -> return OpenPublicPrivate_+    30 -> return PolarityPragmasButNotPostulates_+    31 -> return PragmaCompiled_+    32 -> return PragmaNoTerminationCheck_+    33 -> return ShadowingInTelescope_+    34 -> return UnknownFixityInMixfixDecl_+    35 -> return UnknownNamesInFixityDecl_+    36 -> return UnknownNamesInPolarityPragmas_+    37 -> return UselessAbstract_+    38 -> return UselessInstance_+    39 -> return UselessPrivate_+    40 -> return AbsurdPatternRequiresNoRHS_+    41 -> return AsPatternShadowsConstructorOrPatternSynonym_+    42 -> return CantGeneralizeOverSorts_+    43 -> return ClashesViaRenaming_+    44 -> return CoverageIssue_+    45 -> return CoverageNoExactSplit_+    46 -> return DeprecationWarning_+    47 -> return DuplicateUsing_+    48 -> return FixityInRenamingModule_+    49 -> return GenericNonFatalError_+    50 -> return GenericUseless_+    51 -> return GenericWarning_+    52 -> return IllformedAsClause_+    53 -> return InstanceArgWithExplicitArg_+    54 -> return InstanceWithExplicitArg_+    55 -> return InstanceNoOutputTypeName_+    56 -> return InversionDepthReached_+    57 -> return ModuleDoesntExport_+    58 -> return NoGuardednessFlag_+    59 -> return NotInScope_+    60 -> return NotStrictlyPositive_+    61 -> return UnsupportedIndexedMatch_+    62 -> return OldBuiltin_+    63 -> return PragmaCompileErased_+    64 -> return RewriteMaybeNonConfluent_+    65 -> return RewriteNonConfluent_+    66 -> return RewriteAmbiguousRules_+    67 -> return RewriteMissingRule_+    68 -> return SafeFlagEta_+    69 -> return SafeFlagInjective_+    70 -> return SafeFlagNoCoverageCheck_+    71 -> return SafeFlagNonTerminating_+    72 -> return SafeFlagNoPositivityCheck_+    73 -> return SafeFlagNoUniverseCheck_+    74 -> return SafeFlagPolarity_+    75 -> return SafeFlagPostulate_+    76 -> return SafeFlagPragma_+    77 -> return SafeFlagTerminating_+    78 -> return SafeFlagWithoutKFlagPrimEraseEquality_+    79 -> return TerminationIssue_+    80 -> return UnreachableClauses_+    81 -> return UnsolvedConstraints_+    82 -> return UnsolvedInteractionMetas_+    83 -> return UnsolvedMetaVariables_+    84 -> return UselessHiding_+    85 -> return UselessInline_+    86 -> return UselessPatternDeclarationForRecord_+    87 -> return UselessPublic_+    88 -> return UserWarning_+    89 -> return WithoutKFlagPrimEraseEquality_+    90 -> return WrongInstanceDeclaration_+    91 -> return CoInfectiveImport_+    92 -> return InfectiveImport_+    93 -> return DuplicateFieldsWarning_+    94 -> return TooManyFieldsWarning_+    95 -> return OptionRenamed_+    _ -> malformed   instance EmbPrj CutOff where
src/full/Agda/TypeChecking/Serialise/Instances/Highlighting.hs view
@@ -2,6 +2,9 @@  module Agda.TypeChecking.Serialise.Instances.Highlighting where +import qualified Data.Map.Strict as Map+import Data.Strict.Tuple (Pair(..))+ import qualified Agda.Interaction.Highlighting.Range   as HR import qualified Agda.Interaction.Highlighting.Precise as HP import qualified Agda.Utils.RangeMap                   as RM@@ -115,15 +118,26 @@    value = valueN HP.DefinitionSite -instance EmbPrj a => EmbPrj (RM.PairInt a) where-  icod_ (RM.PairInt a) = icodeN' RM.PairInt a--  value = valueN RM.PairInt- instance EmbPrj a => EmbPrj (RM.RangeMap a) where-  icod_ (RM.RangeMap f) = icodeN' RM.RangeMap f+  -- Write the RangeMap as flat list rather than a list of (Int, (Int, x)). Much+  -- like Map, we need to call `convert' in the tail position and so the output+  -- list is written (and read) in reverse order.+  icod_ (RM.RangeMap f) = icodeNode =<< convert [] (Map.toAscList f) where+    convert ys [] = return ys+    convert ys ((start, RM.PairInt (end :!: entry)):xs) = do+      start <- icode start+      end <- icode end+      entry <- icode entry+      convert (start:end:entry:ys) xs -  value = valueN RM.RangeMap+  value = vcase (fmap (RM.RangeMap . Map.fromDistinctAscList) . convert []) where+    convert ys [] = return ys+    convert ys (start:end:entry:xs) = do+      start <- value start+      end <- value end+      entry <- value entry+      convert ((start, RM.PairInt (end :!: entry)):ys) xs+    convert _ _ = malformed  instance EmbPrj HP.TokenBased where   icod_ HP.TokenBased        = icodeN 0 ()
src/full/Agda/TypeChecking/Serialise/Instances/Internal.hs view
@@ -21,7 +21,7 @@ import Agda.Utils.Impossible  instance EmbPrj a => EmbPrj (Dom a) where-  icod_ (Dom a b c d e) = icodeN' Dom a b c d e+  icod_ (Dom a c d e f) = icodeN' Dom a c d e f    value = valueN Dom @@ -102,13 +102,11 @@   icod_ (Def      a b) = icodeN 3 Def a b   icod_ (Con    a b c) = icodeN 4 Con a b c   icod_ (Pi       a b) = icodeN 5 Pi a b+  icod_ (MetaV    a b) = icodeN 6 MetaV a b   icod_ (Sort     a  ) = icodeN 7 Sort a-  icod_ (MetaV    a b) = __IMPOSSIBLE__   icod_ (DontCare a  ) = icodeN 8 DontCare a   icod_ (Level    a  ) = icodeN 9 Level a-  icod_ (Dummy s _)    = do-    liftIO $ putStrLn $ "Dummy term in serialization: " ++ s-    __IMPOSSIBLE__+  icod_ (Dummy    a b) = icodeN 10 Dummy a b    value = vcase valu where     valu [a]       = valuN var   a@@ -118,9 +116,11 @@     valu [3, a, b] = valuN Def   a b     valu [4, a, b, c] = valuN Con a b c     valu [5, a, b] = valuN Pi    a b+    valu [6, a, b] = valuN MetaV a b     valu [7, a]    = valuN Sort  a     valu [8, a]    = valuN DontCare a     valu [9, a]    = valuN Level a+    valu [10, a, b] = valuN Dummy a b     valu _         = malformed  instance EmbPrj Level where@@ -149,13 +149,12 @@   icod_ (PiSort a b c) = icodeN 4 PiSort a b c   icod_ (FunSort a b) = icodeN 5 FunSort a b   icod_ (UnivSort a) = icodeN 6 UnivSort a-  icod_ (MetaS a b)  = __IMPOSSIBLE__   icod_ (DefS a b)   = icodeN 7 DefS a b   icod_ (SSet  a  ) = icodeN 8 SSet a   icod_ LockUniv    = icodeN 9 LockUniv-  icod_ (DummyS s)   = do-    liftIO $ putStrLn $ "Dummy sort in serialization: " ++ s-    __IMPOSSIBLE__+  icod_ IntervalUniv = icodeN 10 IntervalUniv+  icod_ (MetaS a b)  = icodeN 11 MetaS a b+  icod_ (DummyS s)   = icodeN 12 DummyS s    value = vcase valu where     valu [0, a]    = valuN Type  a@@ -168,6 +167,9 @@     valu [7, a, b] = valuN DefS a b     valu [8, a]    = valuN SSet a     valu [9]       = valuN LockUniv+    valu [10]      = valuN IntervalUniv+    valu [11, a, b] = valuN MetaS a b+    valu [12, s]   = valuN DummyS s     valu _         = malformed  instance EmbPrj DisplayForm where@@ -217,14 +219,14 @@   icod_ (StuckOn a)      = icodeN 0 StuckOn a   icod_ Underapplied     = icodeN 1 Underapplied   icod_ AbsurdMatch      = icodeN 2 AbsurdMatch-  icod_ MissingClauses   = icodeN 3 MissingClauses+  icod_ (MissingClauses a) = icodeN 3 MissingClauses a    value = vcase valu where     valu []     = valuN ReallyNotBlocked     valu [0, a] = valuN StuckOn a     valu [1]    = valuN Underapplied     valu [2]    = valuN AbsurdMatch-    valu [3]    = valuN MissingClauses+    valu [3, a] = valuN MissingClauses a     valu _      = malformed  instance EmbPrj Blocked_ where@@ -262,7 +264,9 @@   icod_ (PProp a)   = icodeN 1 PProp a   icod_ (PInf f a)  = icodeN 2 PInf f a   icod_ PSizeUniv   = icodeN 3 PSizeUniv-  icod_ PLockUniv   = icodeN 4 PSizeUniv+  icod_ PLockUniv   = icodeN 4 PLockUniv+  icod_ PIntervalUniv = icodeN 5 PIntervalUniv+  icod_ (PSSet a)   = icodeN 6 PSSet a    value = vcase valu where     valu [0, a] = valuN PType a@@ -270,6 +274,8 @@     valu [2, f, a] = valuN PInf f a     valu [3]    = valuN PSizeUniv     valu [4]    = valuN PLockUniv+    valu [5]    = valuN PIntervalUniv+    valu [6, a] = valuN PSSet a     valu _      = malformed  instance EmbPrj RewriteRule where@@ -361,13 +367,13 @@     valu [1,a] = valuN Inferred a     valu _     = malformed +instance EmbPrj ProjectionLikenessMissing+ instance EmbPrj Defn where   icod_ (Axiom       a)                                 = icodeN 0 Axiom a-  icod_ (Function    a b s t (_:_) c d e f g h i j k)   = __IMPOSSIBLE__-  icod_ (Function    a b s t []    c d e f g h i j k)   =-    icodeN 1 (\ a b s -> Function a b s t []) a b s c d e f g h i j k-  icod_ (Datatype    a b c d e f g h)                   = icodeN 2 Datatype a b c d e f g h-  icod_ (Record      a b c d e f g h i j k l)           = icodeN 3 Record a b c d e f g h i j k l+  icod_ (Function    a b s t u c d e f g h i j k l)     = icodeN 1 (\ a b s -> Function a b s t) a b s u c d e f g h i j k l+  icod_ (Datatype    a b c d e f g h i j)               = icodeN 2 Datatype a b c d e f g h i j+  icod_ (Record      a b c d e f g h i j k l m)         = icodeN 3 Record a b c d e f g h i j k l m   icod_ (Constructor a b c d e f g h i j)               = icodeN 4 Constructor a b c d e f g h i j   icod_ (Primitive   a b c d e)                         = icodeN 5 Primitive a b c d e   icod_ (PrimitiveSort a b)                             = icodeN 6 PrimitiveSort a b@@ -376,15 +382,15 @@   icod_ DataOrRecSig{}                                  = __IMPOSSIBLE__    value = vcase valu where-    valu [0, a]                                     = valuN Axiom a-    valu [1, a, b, s, c, d, e, f, g, h, i, j, k]    = valuN (\ a b s -> Function a b s Nothing []) a b s c d e f g h i j k-    valu [2, a, b, c, d, e, f, g, h]                = valuN Datatype a b c d e f g h-    valu [3, a, b, c, d, e, f, g, h, i, j, k, l]    = valuN Record  a b c d e f g h i j k l-    valu [4, a, b, c, d, e, f, g, h, i, j]          = valuN Constructor a b c d e f g h i j-    valu [5, a, b, c, d, e]                         = valuN Primitive   a b c d e-    valu [6, a, b]                                  = valuN PrimitiveSort a b-    valu [7]                                        = valuN GeneralizableVar-    valu _                                          = malformed+    valu [0, a]                                        = valuN Axiom a+    valu [1, a, b, s, u, c, d, e, f, g, h, i, j, k, l] = valuN (\ a b s -> Function a b s Nothing) a b s u c d e f g h i j k l+    valu [2, a, b, c, d, e, f, g, h, i, j]             = valuN Datatype a b c d e f g h i j+    valu [3, a, b, c, d, e, f, g, h, i, j, k, l, m]    = valuN Record   a b c d e f g h i j k l m+    valu [4, a, b, c, d, e, f, g, h, i, j]             = valuN Constructor a b c d e f g h i j+    valu [5, a, b, c, d, e]                            = valuN Primitive   a b c d e+    valu [6, a, b]                                     = valuN PrimitiveSort a b+    valu [7]                                           = valuN GeneralizableVar+    valu _                                             = malformed  instance EmbPrj LazySplit where   icod_ StrictSplit = icodeN' StrictSplit@@ -472,7 +478,7 @@     valu _      = malformed  instance EmbPrj I.Clause where-  icod_ (Clause a b c d e f g h i j k) = icodeN' Clause a b c d e f g h i j k+  icod_ (Clause a b c d e f g h i j k l) = icodeN' Clause a b c d e f g h i j k l    value = valueN Clause @@ -536,25 +542,55 @@ instance EmbPrj a => EmbPrj (Builtin a) where   icod_ (Prim    a) = icodeN' Prim a   icod_ (Builtin a) = icodeN 1 Builtin a+  icod_ (BuiltinRewriteRelations a) = icodeN 2 BuiltinRewriteRelations a    value = vcase valu where     valu [a]    = valuN Prim    a     valu [1, a] = valuN Builtin a+    valu [2, a] = valuN BuiltinRewriteRelations a     valu _      = malformed  instance EmbPrj a => EmbPrj (Substitution' a) where-  icod_ IdS              = icodeN' IdS-  icod_ (EmptyS a)       = icodeN 1 EmptyS a-  icod_ (a :# b)         = icodeN 2 (:#) a b-  icod_ (Strengthen a b) = icodeN 3 Strengthen a b-  icod_ (Wk a b)         = icodeN 4 Wk a b-  icod_ (Lift a b)       = icodeN 5 Lift a b+  icod_ IdS                = icodeN' IdS+  icod_ (EmptyS a)         = icodeN' EmptyS a+  icod_ (a :# b)           = icodeN' (:#) a b+  icod_ (Strengthen a b c) = icodeN 0 Strengthen a b c+  icod_ (Wk a b)           = icodeN 1 Wk a b+  icod_ (Lift a b)         = icodeN 2 Lift a b    value = vcase valu where-    valu []        = valuN IdS-    valu [1, a]    = valuN EmptyS a-    valu [2, a, b] = valuN (:#) a b-    valu [3, a, b]    = valuN Strengthen a b-    valu [4, a, b] = valuN Wk a b-    valu [5, a, b] = valuN Lift a b+    valu []           = valuN IdS+    valu [a]          = valuN EmptyS a+    valu [a, b]       = valuN (:#) a b+    valu [0, a, b, c] = valuN Strengthen a b c+    valu [1, a, b]    = valuN Wk a b+    valu [2, a, b]    = valuN Lift a b+    valu _            = malformed++instance EmbPrj Instantiation where+  icod_ (Instantiation a b) = icodeN' Instantiation a b+  value = valueN Instantiation++instance EmbPrj Comparison where+  icod_ CmpEq  = icodeN' CmpEq+  icod_ CmpLeq = icodeN 0 CmpLeq++  value = vcase valu+    where+    valu []  = valuN CmpEq+    valu [0] = valuN CmpLeq+    valu _   = malformed++instance EmbPrj a => EmbPrj (Judgement a) where+  icod_ (HasType a b c) = icodeN' HasType a b c+  icod_ (IsSort a b)    = icodeN' IsSort a b++  value = vcase valu+    where+    valu [a, b, c] = valuN HasType a b c+    valu [a, b]    = valuN IsSort a b     valu _         = malformed++instance EmbPrj RemoteMetaVariable where+  icod_ (RemoteMetaVariable a b c) = icodeN' RemoteMetaVariable a b c+  value = valueN RemoteMetaVariable
src/full/Agda/TypeChecking/SizedTypes.hs view
@@ -4,13 +4,11 @@  import Prelude hiding (null) -import Control.Monad import Control.Monad.Except ( MonadError(..) ) import Control.Monad.Writer ( MonadWriter(..), WriterT(..), runWriterT )  import qualified Data.Foldable as Fold import qualified Data.List as List-import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set)@@ -32,10 +30,12 @@  import Agda.Utils.Functor import Agda.Utils.List as List+import Agda.Utils.List1 (pattern (:|)) import Agda.Utils.Maybe import Agda.Utils.Monad import Agda.Utils.Null import Agda.Utils.Pretty (Pretty, prettyShow)+import qualified Agda.Utils.ProfileOptions as Profile import Agda.Utils.Singleton import Agda.Utils.Size import Agda.Utils.Tuple@@ -316,6 +316,7 @@       nest 2 $ sep [ pretty u <+> prettyTCM cmp                    , pretty v                    ]+  whenProfile Profile.Conversion $ tick "compare sizes"   us <- sizeMaxView u   vs <- sizeMaxView v   compareMaxViews cmp us vs@@ -397,10 +398,11 @@ giveUp :: (MonadConversion m) => Comparison -> Type -> Term -> Term -> m () giveUp cmp size u v =   ifM (asksTC envAssignMetas)-    {-then-} (addConstraint unblock $ ValueCmp CmpLeq AsSizes u v)+    {-then-} (do+      -- TODO: compute proper blocker+      unblock <- unblockOnAnyMetaIn <$> instantiateFull [u, v]+      addConstraint unblock $ ValueCmp CmpLeq AsSizes u v)     {-else-} (typeError $ UnequalTerms cmp u v AsSizes)-  where-    unblock = unblockOnAnyMetaIn [u, v]  -- | Checked whether a size constraint is trivial (like @X <= X+1@). trivial :: (MonadConversion m) => Term -> Term -> m Bool@@ -464,7 +466,7 @@     getOpenMetas >>= do       mapM $ \ m -> do         let no = return Nothing-        mi <- lookupMeta m+        mi <- lookupLocalMeta m         case mvJudgement mi of           _ | BlockedConst{} <- mvInstantiation mi -> no  -- Blocked terms should not be touched (#2637, #2881)           HasType _ cmp a -> do@@ -517,7 +519,7 @@   deriving (Eq, Show)  instance Pretty OldSizeExpr where-  pretty (SizeMeta m _) = P.text $ "X" ++ show (fromIntegral m :: Int)+  pretty (SizeMeta m _) = P.text "X" <> P.pretty m   pretty (Rigid i)      = P.text $ "c" ++ show i  -- | Size constraints we can solve.@@ -629,109 +631,3 @@            return $ Leq (SizeMeta m xs') n (SizeMeta l [0..size ys-1])          -- give up        | otherwise -> Nothing---- | Main function.---   Uses the old solver for size constraints using "Agda.Utils.Warshall".---   This solver does not smartly use size hypotheses @j : Size< i@.---   It only checks that its computed solution is compatible-oldSolveSizeConstraints :: TCM ()-oldSolveSizeConstraints = whenM haveSizedTypes $ do-  reportSLn "tc.size.solve" 70 $ "Considering to solve size constraints"-  cs0 <- getSizeConstraints (== CmpLeq)-  cs <- oldComputeSizeConstraints cs0-  ms <- getSizeMetas True -- get all size metas, also interaction metas--  when (not (null cs) || not (null ms)) $ do-    reportSLn "tc.size.solve" 10 $ "Solving size constraints " ++ show cs--    cs <- return $ mapMaybe oldCanonicalizeSizeConstraint cs-    reportSLn "tc.size.solve" 10 $ "Canonicalized constraints: " ++ show cs--    let -- Error for giving up-        cannotSolve = typeError . GenericDocError =<<-          vcat ("Cannot solve size constraints" : map prettyTCM cs0)--        -- Size metas in constraints.-        metas0 :: [(MetaId, Int)]  -- meta id + arity-        metas0 = List.nubOn id $ map (mapSnd length) $ concatMap flexibleVariables cs--        -- Unconstrained size metas that do not occur in constraints.-        metas1 :: [(MetaId, Int)]-        metas1 = forMaybe ms $ \ (m, _, tel) ->-          maybe (Just (m, size tel)) (const Nothing) $-            lookup m metas0--        -- All size metas-        metas = metas0 ++ metas1--    reportSLn "tc.size.solve" 15 $ "Metas: " ++ show metas0 ++ ", " ++ show metas1--    verboseS "tc.size.solve" 20 $-        -- debug print the type of all size metas-        forM_ metas $ \ (m, _) ->-            reportSDoc "tc.size.solve" 20 $ prettyTCM =<< mvJudgement <$> lookupMeta m--    -- Run the solver.-    unlessM (oldSolver metas cs) cannotSolve--    -- Double-checking the solution.--    -- Andreas, 2012-09-19-    -- The returned solution might not be consistent with-    -- the hypotheses on rigid vars (j : Size< i).-    -- Thus, we double check that all size constraints-    -- have been solved correctly.-    flip catchError (const cannotSolve) $-      noConstraints $-        forM_ cs0 $ withConstraint solveConstraint----- | Old solver for size constraints using "Agda.Utils.Warshall".---   This solver does not smartly use size hypotheses @j : Size< i@.-oldSolver-  :: [(MetaId, Int)]      -- ^ Size metas and their arity.-  -> [OldSizeConstraint]  -- ^ Size constraints (in preprocessed form).-  -> TCM Bool             -- ^ Returns @False@ if solver fails.-oldSolver metas cs = do-  let cannotSolve    = return False-      mkFlex (m, ar) = W.NewFlex (fromIntegral m) $ \ i -> fromIntegral i < ar-      mkConstr (Leq a n b)  = W.Arc (mkNode a) n (mkNode b)-      mkNode (Rigid i)      = W.Rigid $ W.RVar i-      mkNode (SizeMeta m _) = W.Flex $ fromIntegral m--  -- run the Warshall solver-  case W.solve $ map mkFlex metas ++ map mkConstr cs of-    Nothing  -> cannotSolve-    Just sol -> do-      reportSLn "tc.size.solve" 10 $ "Solved constraints: " ++ prettyShow sol-      suc   <- primSizeSuc-      infty <- primSizeInf-      let plus v 0 = v-          plus v n = suc `apply1` plus v (n - 1)--          inst (i, e) = do--            let m  = fromIntegral i  -- meta variable identifier-                ar = fromMaybe __IMPOSSIBLE__ $ lookup m metas  -- meta var arity--                term (W.SizeConst W.Infinite) = infty-                term (W.SizeVar j n) | j < ar = plus (var $ ar - j - 1) n-                term _                        = __IMPOSSIBLE__--                tel = replicate ar $ defaultArg "s"-                -- convert size expression to term-                v = term e--            reportSDoc "tc.size.solve" 20 $ sep-              [ pretty m <+> ":="-              , nest 2 $ prettyTCM v-              ]--            -- Andreas, 2012-09-25: do not assign interaction metas to \infty-            let isInf (W.SizeConst W.Infinite) = True-                isInf _                        = False-            unlessM (((isInf e &&) . isJust <$> isInteractionMeta m) `or2M` isFrozen m) $-              assignTerm m tel v--      mapM_ inst $ Map.toList sol-      return True
src/full/Agda/TypeChecking/SizedTypes/Solve.hs view
@@ -57,7 +57,8 @@ import Data.Either import Data.Foldable (forM_) import qualified Data.Foldable as Fold-import Data.Function+import Data.Function (on)+import qualified Data.IntSet as IntSet import qualified Data.List as List import Data.Monoid import qualified Data.Map as Map@@ -137,7 +138,7 @@      -- @allMetas@ does not reduce or instantiate;     -- this is why we require the size constraints to be normalised.-    return (cl, map metaId . Set.toList $+    return (cl, Set.toList $       sizeMetaSet `Set.intersection` allMetas singleton c)    -- Now, some constraints may have no metas (clcs), the others have at least one (othercs).@@ -303,7 +304,10 @@   where     raiseMaybe n c = do       -- Fine if we have to weaken or strengthening is safe.-      guard $ n >= 0 || List.all (>= -n) (VarSet.toList $ allFreeVars c)+      guard $+        n >= 0 ||+        -- Are all free variables at least -n?+        IntSet.null (fst $ IntSet.split (-n) $ allFreeVars c)       return $ raise n c  @@ -368,7 +372,7 @@   -- Cluster constraints according to the meta variables they mention.   -- @csNoM@ are the constraints that do not mention any meta.   let (csNoM, csMs) = (`List.partitionMaybe` ccs') $ \ p@(c0, c) ->-        fmap (p,) $ nonEmpty $ map (metaId . sizeMetaId) $ Set.toList $ flexs c+        fmap (p,) $ nonEmpty $ map sizeMetaId $ Set.toList $ flexs c   -- @css@ are the clusters of constraints.       css :: [List1 (CC,HypSizeConstraint)]       css = cluster' csMs@@ -390,7 +394,7 @@   let err reason = typeError . GenericDocError =<< do         vcat $           [ text $ "Cannot solve size constraints" ] ++ prettyCs ++-          [ text $ "Reason: " ++ reason ]+          [ "Reason:" <+> reason ]   reportSDoc "tc.size.solve" 20 $ vcat $     "Solving constraint cluster" : prettyCs   -- Find the super context of all contexts.@@ -465,11 +469,11 @@   -- Convert size metas to flexible vars.   let metas :: [SizeMeta]       metas = concatMap (foldMap (:[])) csC-      csF   :: [Size.Constraint' NamedRigid Int]-      csF   = map (fmap (metaId . sizeMetaId)) csC+      csF   :: [Size.Constraint' NamedRigid MetaId]+      csF   = map (fmap sizeMetaId) csC    -- Construct the hypotheses graph.-  let hyps = map (fmap (metaId . sizeMetaId)) hs+  let hyps = map (fmap sizeMetaId) hs   -- There cannot be negative cycles in hypotheses graph due to scoping.   let hg = either __IMPOSSIBLE__ id $ hypGraph (rigids csF) hyps @@ -487,7 +491,7 @@   -- Andreas, 2016-07-13, issue 2096.   -- Running the solver once might result in unsolvable left-over constraints.   -- We need to iterate the solver to detect this.-  sol :: Solution NamedRigid Int <- either err return $+  sol :: Solution NamedRigid MetaId <- either err return $     iterateSolver Map.empty hg csF emptySolution    -- Convert solution to meta instantiation.@@ -495,29 +499,28 @@     unless (validOffset a) __IMPOSSIBLE__     -- Solution does not contain metas     u <- unSizeExpr $ fmap __IMPOSSIBLE__ a-    let x = MetaId m     let SizeMeta _ xs = fromMaybe __IMPOSSIBLE__ $-          List.find ((m==) . metaId . sizeMetaId) metas+          List.find ((m==) . sizeMetaId) metas     -- Check that solution is well-scoped     let ys = rigidIndex <$> Set.toList (rigids a)         ok = all (`elem` xs) ys -- TODO: more efficient     -- unless ok $ err "ill-scoped solution for size meta variable"     u <- if ok then return u else primSizeInf-    t <- getMetaType x+    t <- getMetaType m     reportSDoc "tc.size.solve" 20 $ unsafeModifyContext (const gamma) $ do       let args = map (Apply . defaultArg . var) xs-      "solution " <+> prettyTCM (MetaV x args) <+> " := " <+> prettyTCM u+      "solution " <+> prettyTCM (MetaV m args) <+> " := " <+> prettyTCM u     reportSDoc "tc.size.solve" 60 $ vcat       [ text $ "  xs = " ++ show xs       , text $ "  u  = " ++ show u       ]-    ifM (isFrozen x `or2M` (not <$> asksTC envAssignMetas)) (return Set.empty) $ do-      assignMeta n x t xs u-      return $ Set.singleton x+    ifM (isFrozen m `or2M` (not <$> asksTC envAssignMetas)) (return Set.empty) $ do+      assignMeta n m t xs u+      return $ Set.singleton m     -- WRONG:     -- let partialSubst = List.sort $ zip xs $ map var $ downFrom n-    -- assignMeta' n x t (length xs) partialSubst u-    -- WRONG: assign DirEq x (map (defaultArg . var) xs) u+    -- assignMeta' n m t (length xs) partialSubst u+    -- WRONG: assign DirEq m (map (defaultArg . var) xs) u    -- Possibly set remaining size metas to ∞ (issue 1862)   -- unless we have an interaction meta in the cluster (issue 2095).
src/full/Agda/TypeChecking/SizedTypes/Syntax.hs view
@@ -11,6 +11,8 @@ import Data.Set (Set) import qualified Data.Set as Set +import Agda.TypeChecking.Monad.Base (TCM)+import qualified Agda.TypeChecking.Pretty as P import Agda.TypeChecking.SizedTypes.Utils  import Agda.Utils.Functor@@ -58,6 +60,9 @@ instance Pretty Flex where   pretty = text . flexId +instance P.PrettyTCM Flex where+  prettyTCM = return . pretty+ -- | Size expressions appearing in constraints. data SizeExpr' rigid flex   = Const { offset :: Offset }                   -- ^ Constant number @n@.@@ -170,14 +175,19 @@       Flex x  n -> Flex x  $ n + m       Infty     -> Infty +-- | Error messages produced by the constraint simplification monad.++type Error = TCM Doc+ -- * Constraint simplification -type CTrans r f = Constraint' r f -> Either String [Constraint' r f]+type CTrans r f = Constraint' r f -> Either Error [Constraint' r f]  -- | Returns an error message if we have a contradictory constraint. simplify1 :: (Pretty f, Pretty r, Eq r) => CTrans r f -> CTrans r f simplify1 test c = do-  let err = Left $ "size constraint " ++ prettyShow c ++ " is inconsistent"+  let err = Left $ "size constraint" P.<+> P.pretty c P.<+>+                   "is inconsistent"   case c of     -- rhs is Infty     Constraint a           Le  Infty -> return []
src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs view
@@ -14,6 +14,8 @@ import Data.Map (Map) import qualified Data.Map as Map +import Agda.TypeChecking.Pretty (PrettyTCM)+import qualified Agda.TypeChecking.Pretty as P import Agda.TypeChecking.SizedTypes.Syntax import Agda.TypeChecking.SizedTypes.Utils @@ -428,7 +430,7 @@ type HypGraph r f = Graph r f Label  hypGraph :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) =>-  Set rigid -> [Hyp' rigid flex] -> Either String (HypGraph rigid flex)+  Set rigid -> [Hyp' rigid flex] -> Either Error (HypGraph rigid flex) hypGraph is hyps0 = do   -- get a list of hypothesis from a list of constraints   hyps <- concat <$> mapM (simplify1 $ \ c -> return [c]) hyps0@@ -446,8 +448,10 @@   | Just l <- lookupEdge hg n1 n2 = l   | otherwise                               = top -simplifyWithHypotheses :: (Ord rigid, Ord flex, Pretty rigid, Pretty flex) =>-  HypGraph rigid flex -> [Constraint' rigid flex] -> Either String [Constraint' rigid flex]+simplifyWithHypotheses ::+  (Ord rigid, Ord flex, Pretty rigid, Pretty flex) =>+  HypGraph rigid flex -> [Constraint' rigid flex] ->+  Either Error [Constraint' rigid flex] simplifyWithHypotheses hg cons = concat <$> mapM (simplify1 test) cons   where     -- Test whether a constraint is compatible with the hypotheses:@@ -458,7 +462,8 @@           l' = hypConn hg n1 n2       -- l' <- lookupEdge hg n1 n2       unless (l' <= l) $ Left $-        "size constraint " ++ prettyShow c ++ " not consistent with size hypotheses"+        "size constraint" P.<+> P.pretty c P.<+>+        "not consistent with size hypotheses"       return [c]       -- if (l' <= l) then Just [c] else Nothing @@ -467,7 +472,9 @@  type ConGraph r f = Graph r f Label -constraintGraph :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either String (ConGraph r f)+constraintGraph ::+  (Ord r, Ord f, Pretty r, Pretty f) =>+  [Constraint' r f] -> HypGraph r f -> Either Error (ConGraph r f) constraintGraph cons0 hg = do   traceM $ "original constraints cons0 = " ++ prettyShow cons0   -- Simplify constraints, ensure they are locally consistent with@@ -487,7 +494,9 @@  type ConGraphs r f = Graphs r f Label -constraintGraphs :: (Ord r, Ord f, Pretty r, Pretty f) => [Constraint' r f] -> HypGraph r f -> Either String ([f], ConGraphs r f)+constraintGraphs ::+  (Ord r, Ord f, Pretty r, Pretty f) =>+  [Constraint' r f] -> HypGraph r f -> Either Error ([f], ConGraphs r f) constraintGraphs cons0 hg = do   traceM $ "original constraints cons0 = " ++ prettyShow cons0   -- Simplify constraints, ensure they are locally consistent with@@ -858,11 +867,11 @@   solveGraph-  :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f)   => Polarities f   -> HypGraph r f   -> ConGraph r f-  -> Either String (Solution r f)+  -> Either Error (Solution r f) solveGraph pols hg g = do   let (Bounds lbs ubs fs) = bounds g       -- flexibles to solve for@@ -881,8 +890,9 @@           []     -> return $ Nothing           (a:as) -> do             case foldM (lub hg) a as of-              Nothing -> Left $ "inconsistent lower bound for " ++ prettyShow x               Just l  -> return $ Just $ truncateOffset l+              Nothing -> Left $+                "inconsistent lower bound for" P.<+> P.prettyTCM x       -- compute minimum of upper bounds       ub <- do         case ux of@@ -891,7 +901,8 @@             case foldM (glb hg) a as of               Just l | validOffset l                  -> return $ Just l                      | Just l' <- findRigidBelow hg l -> return $ Just l'-              _ -> Left $ "inconsistent upper bound for " ++ prettyShow x+              _ -> Left $+                "inconsistent upper bound for" P.<+> P.prettyTCM x       case (lb, ub) of         (Just l, Nothing) -> return $ Just l  -- solve x = lower bound         (Nothing, Just u) -> return $ Just u  -- solve x = upper bound@@ -907,11 +918,11 @@ -- | Solve a forest of constraint graphs relative to a hypotheses graph. --   Concatenate individual solutions. solveGraphs-  :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f)   => Polarities f   -> HypGraph r f   -> ConGraphs r f-  -> Either String (Solution r f)+  -> Either Error (Solution r f) solveGraphs pols hg gs =   Solution . Map.unions <$> mapM (theSolution <.> solveGraph pols hg) gs @@ -924,7 +935,7 @@   => HypGraph r f   -> [Constraint' r f]   -> Solution r f-  -> Either String ()+  -> Either Error () verifySolution hg cs sol = do   cs <- return $ subst sol cs   traceM $ "substituted constraints " ++ prettyShow cs@@ -949,7 +960,7 @@ --   which would otherwise go unnoticed.  iterateSolver-  :: (Ord r, Ord f, Pretty r, Pretty f, Show r, Show f)+  :: (Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f)   => Polarities f      -- ^ Meta variable polarities (prefer lower or upper solution?).   -> HypGraph r f@@ -958,7 +969,7 @@      -- ^ Constraints to solve.   -> Solution r f      -- ^ Previous substitution (already applied to constraints).-  -> Either String (Solution r f)+  -> Either Error (Solution r f)      -- ^ Accumulated substition.  iterateSolver pols hg cs sol0 = do
src/full/Agda/TypeChecking/Sort.hs view
@@ -64,8 +64,8 @@ inferUnivSort s = do   s <- reduce s   case univSort' s of-    Just s' -> return s'-    Nothing -> do+    Right s' -> return s'+    Left _ -> do       -- Jesper, 2020-04-19: With the addition of Setωᵢ and the PTS       -- rule SizeUniv : Setω, every sort (with no metas) now has a       -- bigger sort, so we do not need to add a constraint.@@ -165,7 +165,7 @@   :: forall m. (PureTCM m, MonadBlock m)   => Term -> m Sort sortOf t = do-  reportSDoc "tc.sort" 40 $ "sortOf" <+> prettyTCM t+  reportSDoc "tc.sort" 60 $ "sortOf" <+> prettyTCM t   sortOfT =<< elimView EvenLone t    where@@ -175,7 +175,7 @@         let a = unEl $ unDom adom         sa <- sortOf a         sb <- mapAbstraction adom (sortOf . unEl) b-        return $ piSort (unEl <$> adom) sa sb+        inferPiSort (adom $> El sa a) sb       Sort s     -> return $ univSort s       Var i es   -> do         a <- typeOfBV i
src/full/Agda/TypeChecking/Substitute.hs view
@@ -19,15 +19,17 @@  import Control.Arrow (first, second) import Control.Monad (guard)+import Control.Monad.Except (throwError)+ import Data.Coerce-import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Map (Map)+import qualified Data.Map.Strict as MapS import Data.Maybe import Data.HashMap.Strict (HashMap)  import Debug.Trace (trace)-import Language.Haskell.TH.Syntax (thenCmp) -- lexicographic combination of Ordering  import Agda.Interaction.Options @@ -46,6 +48,7 @@ import Agda.TypeChecking.Substitute.Class import Agda.TypeChecking.Substitute.DeBruijn +import Agda.Utils.Either import Agda.Utils.Empty import Agda.Utils.Functor import Agda.Utils.List@@ -79,7 +82,7 @@         case es of           Apply a : es0      -> lazyAbsApp (coerce b :: Abs t) (coerce $ unArg a) `app` es0           IApply _ _ a : es0 -> lazyAbsApp (coerce b :: Abs t) (coerce a)         `app` es0-          _             -> err __IMPOSSIBLE__+          _                  -> err __IMPOSSIBLE__       MetaV x es' -> MetaV x (es' ++ es)       Lit{}       -> err __IMPOSSIBLE__       Level{}     -> err __IMPOSSIBLE__@@ -89,8 +92,8 @@       DontCare mv -> dontCare $ mv `app` es  -- Andreas, 2011-10-02         -- need to go under DontCare, since "with" might resurrect irrelevant term    where-     app :: Coercible t x => x -> Elims -> Term-     app t es = coerce $ (coerce t :: t) `applyE` es+     app :: Coercible t a => a -> Elims -> Term+     app u es = coerce $ (coerce u :: t) `applyE` es      err e = err' e (coerce m) es  instance Apply Term where@@ -99,12 +102,14 @@ instance Apply BraveTerm where   applyE = applyTermE (\ _ t es ->  Dummy "applyE" (Apply (defaultArg t) : es)) --- | If $v$ is a record value, @canProject f v@+-- | If @v@ is a record or constructed value, @canProject f v@ --   returns its field @f@. canProject :: QName -> Term -> Maybe (Arg Term) canProject f v =   case v of-    (Con (ConHead _ IsRecord{} _ fs) _ vs) -> do+    -- Andreas, 2022-06-10, issue #5922: also unfold data projections+    -- (not just record projections).+    (Con (ConHead _ _ _ fs) _ vs) -> do       (fld, i) <- findWithIndex ((f==) . unArg) fs       -- Jesper, 2019-10-17: dont unfold irrelevant projections       guard $ not $ isIrrelevant fld@@ -115,10 +120,10 @@  -- | Eliminate a constructed term. conApp :: forall t. (Coercible t Term, Apply t) => (Empty -> Term -> Elims -> Term) -> ConHead -> ConInfo -> Elims -> Elims -> Term-conApp fk ch                  ci args []             = Con ch ci args-conApp fk ch                  ci args (a@Apply{} : es) = conApp @t fk ch ci (args ++ [a]) es-conApp fk ch                  ci args (a@IApply{} : es) = conApp @t fk ch ci (args ++ [a]) es-conApp fk ch@(ConHead c _ _ fs) ci args ees@(Proj o f : es) =+conApp fallback ch                    ci args []                  = Con ch ci args+conApp fallback ch                    ci args    (a@Apply{} : es) = conApp @t fallback ch ci (args ++ [a]) es+conApp fallback ch                    ci args   (a@IApply{} : es) = conApp @t fallback ch ci (args ++ [a]) es+conApp fallback ch@(ConHead c _ _ fs) ci args ees@(Proj o f : es) =   let failure :: forall a. a -> a       failure err = flip trace err $ concat         [ "conApp: constructor ", prettyShow c@@ -127,7 +132,7 @@         , " projected by ", prettyShow f         ]       isApply e = fromMaybe (failure __IMPOSSIBLE__) $ isApplyElim e-      stuck err = fk err (Con ch ci args) [Proj o f]+      stuck err = fallback err (Con ch ci args) [Proj o f]       -- Recurse using the instance for 't', see @applyTermE@       app :: Term -> Elims -> Term       app v es = coerce $ applyE (coerce v :: t) es@@ -303,7 +308,7 @@     AbstractDefn d -> AbstractDefn $ apply d args     Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv             , funExtLam = extLam-            , funProjection = Nothing } ->+            , funProjection = Left _ } ->       d { funClauses    = apply cs args         , funCompiled   = apply cc args         , funCovering   = apply cov args@@ -313,19 +318,19 @@      Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv             , funExtLam = extLam-            , funProjection = Just p0} ->+            , funProjection = Right p0 } ->       case p0 `apply` args of         p@Projection{ projIndex = n }           | n < 0     -> d { funProjection = __IMPOSSIBLE__ } -- TODO (#3123): we actually get here!           -- case: applied only to parameters-          | n > 0     -> d { funProjection = Just p }+          | n > 0     -> d { funProjection = Right p }           -- case: applied also to record value (n == 0)           | otherwise ->               d { funClauses        = apply cs args'                 , funCompiled       = apply cc args'                 , funCovering       = apply cov args'                 , funInv            = apply inv args'-                , funProjection     = if isVar0 then Just p{ projIndex = 0 } else Nothing+                , funProjection     = if isVar0 then Right p{ projIndex = 0 } else Left MaybeProjection                 , funExtLam         = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam                 }               where@@ -360,7 +365,7 @@     -- It is assumed that we only apply a clause to "parameters", i.e.     -- arguments introduced by lambda lifting. The problem is that these aren't     -- necessarily the first elements of the clause telescope.-    apply cls@(Clause rl rf tel ps b t catchall exact recursive unreachable ell) args+    apply cls@(Clause rl rf tel ps b t catchall exact recursive unreachable ell wm) args       | length args > length ps = __IMPOSSIBLE__       | otherwise =       Clause rl rf@@ -373,6 +378,7 @@              recursive              unreachable              ell+             wm       where         -- We have         --  Γ ⊢ args, for some outer context Γ@@ -443,13 +449,19 @@             IApplyP _ _ _ (DBPatVar _ i) -> newTel (n - 1) (subTel (size tel - 1 - i) v tel) (substP i (raise (n - 1) v) ps) vs         newTel _ tel _ _ = __IMPOSSIBLE__ +        projections :: ConHead -> Term -> [Term]         projections c v = [ relToDontCare ai $                             -- #4528: We might have bogus terms here when printing a clause that                             --        cannot be taken. To mitigate the problem we use a Def instead                             --        a Proj elim for data constructors, which at least stops conApp                             --        from crashing. See #4989 for not printing bogus terms at all.                             case conDataRecord c of-                              IsData     -> Def f [Apply (Arg ai v)]+                              IsData     -> defApp f [] [Apply (Arg ai v)]+                                              -- Andreas, 2022-06-10, issue #5922.+                                              -- This was @Def f [Apply (Arg ai v)]@, but are we sure+                                              -- that @v@ isn't a matching @Con@?  The testcase for+                                              -- #5922 does not require this precaution,+                                              -- but I sleep better this way...                               IsRecord{} -> applyE v [Proj ProjSystem f]                           | Arg ai f <- conFields c ] @@ -655,7 +667,7 @@     AbstractDefn d -> AbstractDefn $ abstract tel d     Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv             , funExtLam = extLam-            , funProjection = Nothing  } ->+            , funProjection = Left _  } ->       d { funClauses  = abstract tel cs         , funCompiled = abstract tel cc         , funCovering = abstract tel cov@@ -664,19 +676,22 @@         }     Function{ funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv             , funExtLam = extLam-            , funProjection = Just p } ->+            , funProjection = Right p } ->       -- Andreas, 2015-05-11 if projection was applied to Var 0       -- then abstract over last element of tel (the others are params).-      if projIndex p > 0 then d' else-        d' { funClauses  = map (abstractClause tel1) cs-           , funCompiled = abstract tel1 cc-           , funCovering = abstract tel1 cov-           , funInv      = abstract tel1 inv-           , funExtLam   = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam-           }+      if projIndex p > 0 then+        d { funProjection = Right $ abstract tel p+          , funClauses    = map (abstractClause EmptyTel) cs+          }+      else+        d { funProjection = Right $ abstract tel p+          , funClauses    = map (abstractClause tel1) cs+          , funCompiled   = abstract tel1 cc+          , funCovering   = abstract tel1 cov+          , funInv        = abstract tel1 inv+          , funExtLam     = modifySystem (\ _ -> __IMPOSSIBLE__) <$> extLam+          }         where-          d' = d { funProjection = Just $ abstract tel p-                 , funClauses    = map (abstractClause EmptyTel) cs }           tel1 = telFromList $ drop (size tel - 1) $ telToList tel           -- #5128: clause telescopes should be abstracted over the full telescope, regardless of           --        projection shenanigans.@@ -702,7 +717,7 @@         where n = size tel  instance Abstract Clause where-  abstract tel (Clause rl rf tel' ps b t catchall exact recursive unreachable ell) =+  abstract tel (Clause rl rf tel' ps b t catchall exact recursive unreachable ell wm) =     Clause rl rf (abstract tel tel')            (namedTelVars m tel ++ ps)            b@@ -712,6 +727,7 @@            recursive            unreachable            ell+           wm       where m = size tel + size tel'  instance Abstract CompiledClauses where@@ -777,8 +793,28 @@  -- | If @permute π : [a]Γ -> [a]Δ@, then @applySubst (renamingR π) : Term Δ -> Term Γ@ renamingR :: DeBruijn a => Permutation -> Substitution' a-renamingR p@(Perm n _) = permute (reverseP p) (map deBruijnVar [0..]) ++# raiseS n+renamingR p@(Perm n is) = xs ++# raiseS n+  where+  xs = map (\i -> deBruijnVar (n - 1 - i)) (reverse is) +  -- The list xs used to be defined in the following way:+  --+  --   permute (reverseP p) (map deBruijnVar [0..])+  --+  -- We have that+  --+  --     permute (reverseP p) (map deBruijnVar [0..])+  --   = permute (Perm n $ map ((n - 1) -) $ reverse is)+  --       (map deBruijnVar [0..])+  --   = map (map deBruijnVar [0..] !!)+  --       (map ((n - 1) -) $ reverse is)+  --   = map deBruijnVar (map ((n - 1) -) $ reverse is)+  --   = map (\i -> deBruijnVar (n - 1 - i)) (reverse is).+  --+  -- The latter code is linear in the length of is (if deBruijnVar+  -- takes constant time), while the time complexity of the former+  -- code depends on the value of the largest index in is.+ -- | The permutation should permute the corresponding context. (right-to-left list) renameP :: Subst a => Impossible -> Permutation -> a -> a renameP err p = applySubst (renaming err p)@@ -832,6 +868,7 @@     SSet n     -> SSet $ sub n     SizeUniv   -> SizeUniv     LockUniv   -> LockUniv+    IntervalUniv -> IntervalUniv     PiSort a s1 s2 -> coerce $ piSort (coerce $ sub a) (coerce $ sub s1) (coerce $ sub s2)     FunSort s1 s2 -> coerce $ funSort (coerce $ sub s1) (coerce $ sub s2)     UnivSort s -> coerce $ univSort $ coerce $ sub s@@ -937,9 +974,11 @@   applySubst rho = \case     PType l   -> PType $ applySubst rho l     PProp l   -> PProp $ applySubst rho l+    PSSet l   -> PSSet $ applySubst rho l     PInf f n  -> PInf f n     PSizeUniv -> PSizeUniv     PLockUniv -> PLockUniv+    PIntervalUniv -> PIntervalUniv  instance Subst RewriteRule where   type SubstArg RewriteRule = NLPat@@ -992,9 +1031,10 @@     HasPTSRule a s           -> HasPTSRule (rf a) (rf s)     CheckLockedVars a b c d  -> CheckLockedVars (rf a) (rf b) (rf c) (rf d)     UnquoteTactic t h g      -> UnquoteTactic (rf t) (rf h) (rf g)+    CheckDataSort q s        -> CheckDataSort q (rf s)     CheckMetaInst m          -> CheckMetaInst m     CheckType t              -> CheckType (rf t)-    UsableAtModality mod m   -> UsableAtModality mod (rf m)+    UsableAtModality cc ms mod m -> UsableAtModality cc (rf ms) mod (rf m)     where       rf :: forall a. TermSubst a => a -> a       rf x = applySubst rho x@@ -1072,11 +1112,14 @@  instance Subst EqualityView where   type SubstArg EqualityView = Term-  applySubst rho (OtherType t) = OtherType-    (applySubst rho t)-  applySubst rho (IdiomType t) = IdiomType-    (applySubst rho t)-  applySubst rho (EqualityType s eq l t a b) = EqualityType+  applySubst rho = \case+    OtherType t          -> OtherType $ applySubst rho t+    IdiomType t          -> IdiomType $ applySubst rho t+    EqualityViewType eqt -> EqualityViewType $ applySubst rho eqt++instance Subst EqualityTypeData where+  type SubstArg EqualityTypeData = Term+  applySubst rho (EqualityTypeData s eq l t a b) = EqualityTypeData     (applySubst rho s)     eq     (map (applySubst rho) l)@@ -1198,10 +1241,12 @@ telView'UpTo n t = case unEl t of   Pi a b  -> absV a (absName b) $ telView'UpTo (n - 1) (absBody b)   _       -> TelV EmptyTel t-  where-    absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t +-- | Add given binding to the front of the telescope.+absV :: Dom a -> ArgName -> TelV a -> TelV a+absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t + -- ** Creating telescopes from lists of types  -- | Turn a typed binding @(x1 .. xn : A)@ into a telescope.@@ -1403,7 +1448,8 @@   _               == _                 = False  instance Ord Term where-  Var a b    `compare` Var x y    = compare x a `thenCmp` compare b y -- sort de Bruijn indices down (#2765)+  Var a b    `compare` Var x y    = compare (x, b) (a, y)+                                    -- sort de Bruijn indices down (#2765)   Var{}      `compare` _          = LT   _          `compare` Var{}      = GT   Def a b    `compare` Def x y    = compare (a, b) (x, y)@@ -1492,17 +1538,23 @@ --   known (i.e. it is not just @UnivSort s@). -- --   Precondition: @s@ is reduced-univSort' :: Sort -> Maybe Sort-univSort' (Type l) = Just $ Type $ levelSuc l-univSort' (Prop l) = Just $ Type $ levelSuc l-univSort' (Inf f n) = Just $ Inf f $ 1 + n-univSort' (SSet l) = Just $ SSet $ levelSuc l-univSort' SizeUniv = Just $ Inf IsFibrant 0-univSort' LockUniv = Just $ Inf IsFibrant 0 -- lock polymorphism is not actually supported-univSort' s        = Nothing+univSort' :: Sort -> Either Blocker Sort+univSort' (Type l)     = Right $ Type $ levelSuc l+univSort' (Prop l)     = Right $ Type $ levelSuc l+univSort' (Inf f n)    = Right $ Inf f $ 1 + n+univSort' (SSet l)     = Right $ SSet $ levelSuc l+univSort' SizeUniv     = Right $ Inf IsFibrant 0+univSort' LockUniv     = Right $ Inf IsFibrant 0 -- lock polymorphism is not actually supported+univSort' IntervalUniv = Right $ SSet $ ClosedLevel 1+univSort' (MetaS m _)  = Left neverUnblock+univSort' FunSort{}    = Left neverUnblock+univSort' PiSort{}     = Left neverUnblock+univSort' UnivSort{}   = Left neverUnblock+univSort' DefS{}       = Left neverUnblock+univSort' DummyS{}     = Left neverUnblock  univSort :: Sort -> Sort-univSort s = fromMaybe (UnivSort s) $ univSort' s+univSort s = fromRight (const $ UnivSort s) $ univSort' s  sort :: Sort -> Type sort s = El (univSort s) $ Sort s@@ -1510,24 +1562,34 @@ ssort :: Level -> Type ssort l = sort (SSet l) --- | Returns @Nothing@ for unknown (meta) sorts, and otherwise returns---   @Just (b,f)@ where @b@ indicates smallness and @f@ fibrancy.---   I.e., @b@ is @True@ for (relatively) small sorts like @Set l@ and---   @Prop l@, and instead @b@ is @False@ for large sorts such as @Setω@.-isSmallSort :: Sort -> Maybe (Bool,IsFibrant)-isSmallSort Type{}     = Just (True,IsFibrant)-isSmallSort Prop{}     = Just (True,IsFibrant)-isSmallSort SizeUniv   = Just (True,IsFibrant)-isSmallSort LockUniv   = Just (True,IsFibrant)-isSmallSort (Inf f _)  = Just (False,f)-isSmallSort SSet{}     = Just (True,IsStrict)-isSmallSort MetaS{}    = Nothing-isSmallSort FunSort{}  = Nothing-isSmallSort PiSort{}   = Nothing-isSmallSort UnivSort{} = Nothing-isSmallSort DefS{}     = Nothing-isSmallSort DummyS{}   = Nothing+-- | A sort can either be small (Set l, Prop l, Size, ...)  or large+--   (Setω n).+data SizeOfSort+  = SmallSort IsFibrant+  | LargeSort IsFibrant Integer +-- | Returns @Left blocker@ for unknown (blocked) sorts, and otherwise+--   returns @Right s@ where @s@ indicates the size and fibrancy.+sizeOfSort :: Sort -> Either Blocker SizeOfSort+sizeOfSort Type{}       = Right $ SmallSort IsFibrant+sizeOfSort Prop{}       = Right $ SmallSort IsFibrant+sizeOfSort SizeUniv     = Right $ SmallSort IsFibrant+sizeOfSort LockUniv     = Right $ SmallSort IsFibrant+sizeOfSort IntervalUniv = Right $ SmallSort IsStrict+sizeOfSort (Inf f n)    = Right $ LargeSort f n+sizeOfSort SSet{}       = Right $ SmallSort IsStrict+sizeOfSort (MetaS m _)  = Left $ unblockOnMeta m+sizeOfSort FunSort{}    = Left neverUnblock+sizeOfSort PiSort{}     = Left neverUnblock+sizeOfSort UnivSort{}   = Left neverUnblock+sizeOfSort DefS{}       = Left neverUnblock+sizeOfSort DummyS{}     = Left neverUnblock++isSmallSort :: Sort -> Bool+isSmallSort s = case sizeOfSort s of+  Right SmallSort{} -> True+  _                 -> False+ fibrantLub :: IsFibrant -> IsFibrant -> IsFibrant fibrantLub IsStrict a = IsStrict fibrantLub a IsStrict = IsStrict@@ -1535,41 +1597,71 @@  -- | Compute the sort of a function type from the sorts of its --   domain and codomain.-funSort' :: Sort -> Sort -> Maybe Sort+funSort' :: Sort -> Sort -> Either Blocker Sort funSort' a b = case (a, b) of-  (Inf af m      , Inf bf n     ) -> Just $ Inf (fibrantLub af bf) $ max m n-  (Inf af m      , b            ) | Just (True,bf) <- isSmallSort b -> Just $ Inf (fibrantLub af bf) m-  (a             , Inf bf n     ) | Just (True,af) <- isSmallSort a -> Just $ Inf (fibrantLub af bf) n-  (Type a        , Type b       ) -> Just $ Type $ levelLub a b-  (LockUniv      , b            ) -> Just b+  (Type a        , Type b       ) -> Right $ Type $ levelLub a b+  (Prop a        , Type b       ) -> Right $ Type $ levelLub a b+  (Type a        , Prop b       ) -> Right $ Prop $ levelLub a b+  (Prop a        , Prop b       ) -> Right $ Prop $ levelLub a b+  (SSet a        , SSet b       ) -> Right $ SSet $ levelLub a b+  (Type a        , SSet b       ) -> Right $ SSet $ levelLub a b+  (SSet a        , Type b       ) -> Right $ SSet $ levelLub a b+  (SSet a        , Prop b       ) -> Right $ SSet $ levelLub a b+  (Prop a        , SSet b       ) -> Right $ SSet $ levelLub a b+  (Inf af m      , b            ) -> sizeOfSort b >>= \case+    SmallSort bf   -> Right $ Inf (fibrantLub af bf) m+    LargeSort bf n -> Right $ Inf (fibrantLub af bf) $ max m n+  (a             , Inf bf n     ) -> sizeOfSort a >>= \case+    SmallSort af   -> Right $ Inf (fibrantLub af bf) n+    LargeSort af m -> Right $ Inf (fibrantLub af bf) $ max m n+  (LockUniv      , b            ) -> Right b   -- No functions into lock types-  (a             , LockUniv     ) -> Nothing-  (SizeUniv      , b            ) -> Just b-  (a             , SizeUniv     ) | Just (True,_) <- isSmallSort a -> Just SizeUniv-  (Prop a        , Type b       ) -> Just $ Type $ levelLub a b-  (Type a        , Prop b       ) -> Just $ Prop $ levelLub a b-  (Prop a        , Prop b       ) -> Just $ Prop $ levelLub a b-  (SSet a        , SSet b       ) -> Just $ SSet $ levelLub a b-  (Type a        , SSet b       ) -> Just $ SSet $ levelLub a b-  (SSet a        , Type b       ) -> Just $ SSet $ levelLub a b-  (a             , b            ) -> Nothing+  (a             , LockUniv     ) -> Left neverUnblock+  -- @IntervalUniv@ behaves like @SSet@, but functions into @Type@ land in @Type@+  (IntervalUniv  , IntervalUniv ) -> Right $ SSet $ ClosedLevel 0+  (IntervalUniv  , SSet b       ) -> Right $ SSet $ b+  (IntervalUniv  , Type b       ) -> Right $ Type $ b+  (IntervalUniv  , _            ) -> Left neverUnblock+  (Type a        , IntervalUniv ) -> Right $ SSet $ a+  (SSet a        , IntervalUniv ) -> Right $ SSet $ a+  (_             , IntervalUniv ) -> Left neverUnblock+  (SizeUniv      , b            ) -> Right b+  (a             , SizeUniv     ) -> sizeOfSort a >>= \case+    SmallSort{} -> Right SizeUniv+    LargeSort{} -> Left neverUnblock+  (MetaS m _     , _            ) -> Left $ unblockOnMeta m+  (_             , MetaS m _    ) -> Left $ unblockOnMeta m+  (FunSort{}     , _            ) -> Left neverUnblock+  (_             , FunSort{}    ) -> Left neverUnblock+  (PiSort{}      , _            ) -> Left neverUnblock+  (_             , PiSort{}     ) -> Left neverUnblock+  (UnivSort{}    , _            ) -> Left neverUnblock+  (_             , UnivSort{}   ) -> Left neverUnblock+  (DefS{}        , _            ) -> Left neverUnblock+  (_             , DefS{}       ) -> Left neverUnblock+  (DummyS{}      , _            ) -> Left neverUnblock+  (_             , DummyS{}     ) -> Left neverUnblock  funSort :: Sort -> Sort -> Sort-funSort a b = fromMaybe (FunSort a b) $ funSort' a b+funSort a b = fromRight (const $ FunSort a b) $ funSort' a b  -- | Compute the sort of a pi type from the sorts of its domain --   and codomain.-piSort' :: Dom Term -> Sort -> Abs Sort -> Maybe Sort-piSort' a s1       (NoAbs _ s2) = Just $ FunSort s1 s2+piSort' :: Dom Term -> Sort -> Abs Sort -> Either Blocker Sort+piSort' a s1       (NoAbs _ s2) = Right $ FunSort s1 s2 piSort' a s1 s2Abs@(Abs   _ s2) = case flexRigOccurrenceIn 0 s2 of-  Nothing -> Just $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs-  Just o | Just (True, f1) <- isSmallSort s1, Just (True, f2) <- isSmallSort s2 -> case o of-    StronglyRigid -> Just $ Inf (fibrantLub f1 f2) 0-    Unguarded     -> Just $ Inf (fibrantLub f1 f2) 0-    WeaklyRigid   -> Just $ Inf (fibrantLub f1 f2) 0-    Flexible _    -> Nothing-  Just o | Inf f1 n <- s1 , Just (True, f2) <- isSmallSort s2 -> Just $ Inf (fibrantLub f1 f2) n-  Just _ -> Nothing+  Nothing -> Right $ FunSort s1 $ noabsApp __IMPOSSIBLE__ s2Abs+  Just o  -> case (sizeOfSort s1 , sizeOfSort s2) of+    (Right (SmallSort f1) , Right (SmallSort f2)) -> case o of+      StronglyRigid -> Right $ Inf (fibrantLub f1 f2) 0+      Unguarded     -> Right $ Inf (fibrantLub f1 f2) 0+      WeaklyRigid   -> Right $ Inf (fibrantLub f1 f2) 0+      Flexible ms   -> Left $ metaSetToBlocker ms+    (Right (LargeSort f1 n) , Right (SmallSort f2)) -> Right $ Inf (fibrantLub f1 f2) n+    (_                     , Right LargeSort{}    ) -> __IMPOSSIBLE__ -- large sorts cannot depend on variables+    (Left blocker          , Right _              ) -> Left blocker+    (Right _               , Left blocker         ) -> Left blocker+    (Left blocker1         , Left blocker2        ) -> Left $ unblockOnBoth blocker1 blocker2  -- Andreas, 2019-06-20 -- KEEP the following commented out code for the sake of the discussion on irrelevance.@@ -1601,9 +1693,7 @@ --     Flexible _    -> Nothing  piSort :: Dom Term -> Sort -> Abs Sort -> Sort-piSort a s1 s2 = case piSort' a s1 s2 of-  Just s  -> s-  Nothing -> PiSort a s1 s2+piSort a s1 s2 = fromRight (const $ PiSort a s1 s2) $ piSort' a s1 s2  --------------------------------------------------------------------------- -- * Level stuff@@ -1611,15 +1701,13 @@  -- ^ Computes @n0 ⊔ a₁ ⊔ a₂ ⊔ ... ⊔ aₙ@ and return its canonical form. levelMax :: Integer -> [PlusLevel] -> Level-levelMax n0 as0 = Max n as+levelMax !n0 as0 = Max n as   where     -- step 1: flatten nested @Level@ expressions in @PlusLevel@s     Max n1 as1 = expandLevel $ Max n0 as0-    -- step 2: remove subsumed @PlusLevel@s-    as2       = removeSubsumed as1-    -- step 3: sort remaining @PlusLevel@s-    as        = List.sort as2-    -- step 4: set constant to 0 if it is subsumed by one of the @PlusLevel@s+    -- step 2: remove subsumed @PlusLevel@s and sort what remains+    as        = removeSubsumed as1+    -- step 3: set constant to 0 if it is subsumed by one of the @PlusLevel@s     greatestB = Prelude.maximum $ 0 : [ n | Plus n _ <- as ]     n | n1 > greatestB = n1       | otherwise      = 0@@ -1637,12 +1725,11 @@     expandTm (Level l)       = expandLevel l     expandTm l               = atomicLevel l -    removeSubsumed [] = []-    removeSubsumed (Plus n a : bs)-      | not $ null ns = removeSubsumed bs-      | otherwise     = Plus n a : removeSubsumed [ b | b@(Plus _ a') <- bs, a /= a' ]-      where-        ns = [ m | Plus m a' <- bs, a == a', m > n ]+    removeSubsumed =+      map (\(a, n) -> Plus n a) .+      MapS.toAscList .+      MapS.fromListWith max .+      map (\(Plus n a) -> (a, n))  -- | Given two levels @a@ and @b@, compute @a ⊔ b@ and return its --   canonical form.
src/full/Agda/TypeChecking/Substitute/Class.hs view
@@ -89,7 +89,7 @@ subst i u = applySubst $ singletonS i u  strengthen :: Subst a => Impossible -> a -> a-strengthen err = applySubst (compactS err [Nothing])+strengthen err = applySubst (strengthenS err 1)  -- | Replace what is now de Bruijn index 0, but go under n binders. --   @substUnder n u == subst n (raise n u)@.@@ -162,10 +162,15 @@ dropS n IdS                = raiseS n dropS n (Wk m rho)         = wkS m (dropS n rho) dropS n (u :# rho)         = dropS (n - 1) rho-dropS n (Strengthen _ rho) = dropS (n - 1) rho-dropS n (Lift 0 rho)       = __IMPOSSIBLE__-dropS n (Lift m rho)       = wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho dropS n (EmptyS err)       = throwImpossible err+dropS n (Lift m rho)+  -- dropS n (Lift m rho) =+  --   wkS 1 $ dropS (n - 1) $ liftS (m - 1) rho+  | n > m     = wkS m $ dropS (n - m) rho+  | otherwise = wkS n $ liftS (m - n) rho+dropS n (Strengthen err m rho)+  | n < m     = Strengthen err (m - n) rho+  | otherwise = dropS (n - m) rho  -- | @applySubst (ρ `composeS` σ) v == applySubst ρ (applySubst σ v)@ composeS :: EndoSubst a => Substitution' a -> Substitution' a -> Substitution' a@@ -174,7 +179,7 @@ composeS rho (EmptyS err) = EmptyS err composeS rho (Wk n sgm) = composeS (dropS n rho) sgm composeS rho (u :# sgm) = applySubst rho u :# composeS rho sgm-composeS rho (Strengthen err sgm) = Strengthen err (composeS rho sgm)+composeS rho (Strengthen err n sgm) = Strengthen err n (composeS rho sgm) composeS rho (Lift 0 sgm) = __IMPOSSIBLE__ composeS (u :# rho) (Lift n sgm) = u :# composeS rho (liftS (n - 1) sgm) composeS rho (Lift n sgm) = lookupS rho 0 :# composeS rho (wkS 1 (liftS (n - 1) sgm))@@ -183,14 +188,23 @@ --   Γ ⊢ σ : Δ --   Γ ⊢ δ : Θσ splitS :: Int -> Substitution' a -> (Substitution' a, Substitution' a)-splitS 0 rho                  = (rho, EmptyS impossible)-splitS n (u :# rho)           = second (u :#) $ splitS (n - 1) rho-splitS n (Strengthen err rho) = second (Strengthen err) $ splitS (n - 1) rho-splitS n (Lift 0 _)           = __IMPOSSIBLE__-splitS n (Wk m rho)           = wkS m *** wkS m $ splitS n rho-splitS n IdS                  = (raiseS n, liftS n $ EmptyS impossible)-splitS n (Lift m rho)         = wkS 1 *** liftS 1 $ splitS (n - 1) (liftS (m - 1) rho)-splitS n (EmptyS err)         = __IMPOSSIBLE__+splitS 0 rho                    = (rho, EmptyS impossible)+splitS n (u :# rho)             = second (u :#) $ splitS (n - 1) rho+splitS n (Lift 0 _)             = __IMPOSSIBLE__+splitS n (Wk m rho)             = wkS m *** wkS m $ splitS n rho+splitS n IdS                    = ( raiseS n+                                  , liftS n $ EmptyS impossible+                                  )+splitS n (Lift m rho)           = wkS 1 *** liftS 1 $+                                  splitS (n - 1) (liftS (m - 1) rho)+splitS n (EmptyS err)           = __IMPOSSIBLE__+splitS n (Strengthen err m rho)+  -- splitS n (Strengthen err 1 rho) =+  --   second (Strengthen err) $ splitS (n - 1) rho+  | n > m     = second (Strengthen err m) $+                splitS (n - m) rho+  | otherwise = second (Strengthen err n) $+                splitS 0 (Strengthen err (m - n) rho)  infixr 4 ++# @@ -203,21 +217,47 @@ --        Γ ⊢ prependS vs ρ : Δ, Θ --   @ prependS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a -> Substitution' a-prependS err us rho = foldr f rho us+prependS err us rho = go 0 us   where-    f Nothing  rho = Strengthen err rho-    f (Just u) rho = consS u rho+  -- The function strengthenS' is not used here, to avoid replacing+  -- the "error message" of a potential outermost Strengthen+  -- constructor in rho.+  str 0 = id+  str n = Strengthen err n +  go !n (Just u  : us) = str n (consS u (go 0 us))+  go  n (Nothing : us) = go (1 + n) us+  go  n []             = str n rho++-- | @+--        Γ ⊢ reverse vs : Δ+--      -----------------------------+--        Γ ⊢ parallelS vs ρ : Γ, Δ+--   @+--+--   Note the @Γ@ in @Γ, Δ@. parallelS :: DeBruijn a => [a] -> Substitution' a parallelS us = us ++# idS -compactS :: DeBruijn a => Impossible -> [Maybe a] -> Substitution' a-compactS err us = prependS err us idS- -- | Γ ⊢ (strengthenS ⊥ |Δ|) : Γ,Δ strengthenS :: Impossible -> Int -> Substitution' a-strengthenS err = indexWithDefault __IMPOSSIBLE__ $ iterate (Strengthen err) idS+strengthenS err n = case compare n 0 of+  LT -> __IMPOSSIBLE__+  EQ -> idS+  GT -> Strengthen err n idS +-- | A \"smart\" variant of 'Strengthen'. If 'strengthenS' is applied+-- to a substitution with an outermost 'Strengthen' constructor, then+-- the \"error message\" of that constructor is discarded in favour of+-- the 'Impossible' argument of this function.+strengthenS' :: Impossible -> Int -> Substitution' a -> Substitution' a+strengthenS' err m rho = case compare m 0 of+  LT -> __IMPOSSIBLE__+  EQ -> rho+  GT -> case rho of+    Strengthen _ n rho -> Strengthen err (m + n) rho+    _                  -> Strengthen err m       rho+ lookupS :: EndoSubst a => Substitution' a -> Nat -> a lookupS rho i = case rho of   IdS                    -> deBruijnVar i@@ -227,10 +267,10 @@   u :# rho   | i == 0    -> u              | i < 0     -> __IMPOSSIBLE__              | otherwise -> lookupS rho (i - 1)-  Strengthen err rho-             | i == 0    -> throwImpossible err+  Strengthen err n rho              | i < 0     -> __IMPOSSIBLE__-             | otherwise -> lookupS rho (i - 1)+             | i < n     -> throwImpossible err+             | otherwise -> lookupS rho (i - n)   Lift n rho | i < n     -> deBruijnVar i              | otherwise -> raise n $ lookupS rho (i - n)   EmptyS err             -> throwImpossible err
src/full/Agda/TypeChecking/Substitute/DeBruijn.hs view
@@ -47,3 +47,7 @@   debruijnNamedVar = DBPatVar   deBruijnView = Just . dbPatVarIndex ++instance DeBruijn a => DeBruijn (Named_ a) where+  debruijnNamedVar nm i = unnamed $ debruijnNamedVar nm i+  deBruijnView = deBruijnView . namedThing
src/full/Agda/TypeChecking/SyntacticEquality.hs view
@@ -7,7 +7,13 @@ --   by a more efficient routine which only traverses and instantiates the terms --   as long as they are equal. -module Agda.TypeChecking.SyntacticEquality (SynEq, checkSyntacticEquality) where+module Agda.TypeChecking.SyntacticEquality+  ( SynEq+  , checkSyntacticEquality+  , checkSyntacticEquality'+  , syntacticEqualityFuelRemains+  )+  where  import Control.Arrow            ( (***) ) import Control.Monad            ( zipWithM )@@ -19,33 +25,95 @@ import Agda.Syntax.Common import Agda.Syntax.Internal -import Agda.TypeChecking.Monad (ReduceM, MonadReduce(..), pragmaOptions, isInstantiatedMeta)+import Agda.TypeChecking.Monad+  (ReduceM, MonadReduce(..), TCEnv(..), MonadTCEnv(..), pragmaOptions,+   isInstantiatedMeta) import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute -import Agda.Utils.Monad (ifM)-+import qualified Agda.Utils.Maybe.Strict as Strict+import Agda.Utils.Monad (ifM, and2M) --- | Syntactic equality check for terms.+-- | Syntactic equality check for terms. If syntactic equality+-- checking has fuel left, then 'checkSyntacticEquality' behaves as if+-- it were implemented in the following way (which does not match the+-- given type signature), only that @v@ and @v'@ are only fully+-- instantiated to the depth where they are equal (and the amount of+-- fuel is reduced by one unit in the failure branch): --   @---      checkSyntacticEquality v v' = do+--      checkSyntacticEquality v v' s f = do --        (v, v') <- instantiateFull (v, v')---         return ((v, v'), v==v')+--        if v == v' then s v v' else f v v' --   @---   only that @v, v'@ are only fully instantiated to the depth---   where they are equal.+-- If syntactic equality checking does not have fuel left, then+-- 'checkSyntacticEquality' instantiates the two terms and takes the+-- failure branch. -----   This means in particular that the returned @v,v'@ cannot be @MetaV@s---   that are instantiated.+-- Note that in either case the returned values @v@ and @v'@ cannot be+-- @MetaV@s that are instantiated. -{-# SPECIALIZE checkSyntacticEquality :: Term -> Term -> ReduceM ((Term, Term), Bool) #-}-{-# SPECIALIZE checkSyntacticEquality :: Type -> Type -> ReduceM ((Type, Type), Bool) #-}-checkSyntacticEquality :: (Instantiate a, SynEq a, MonadReduce m) => a -> a -> m ((a, a), Bool)-checkSyntacticEquality v v' = liftReduce $ do-  ifM (optSyntacticEquality <$> pragmaOptions)-  {-then-} (synEq v v' `runStateT` True)-  {-else-} ((,False) <$> instantiate (v,v'))+{-# SPECIALIZE checkSyntacticEquality ::+      Term -> Term ->+      (Term -> Term -> ReduceM a) ->+      (Term -> Term -> ReduceM a) ->+      ReduceM a #-}+{-# SPECIALIZE checkSyntacticEquality ::+      Type -> Type ->+      (Type -> Type -> ReduceM a) ->+      (Type -> Type -> ReduceM a) ->+      ReduceM a #-}+checkSyntacticEquality+  :: (Instantiate a, SynEq a, MonadReduce m)+  => a+  -> a+  -> (a -> a -> m b)  -- ^ Continuation used upon success.+  -> (a -> a -> m b)  -- ^ Continuation used upon failure, or if+                      --   syntactic equality checking has been turned+                      --   off.+  -> m b+checkSyntacticEquality u v s f =+  ifM syntacticEqualityFuelRemains+  {-then-} (checkSyntacticEquality' u v s (\u v -> localTC decreaseFuel (f u v)))+  {-else-} (uncurry f =<< instantiate (u, v))+  where+  decreaseFuel env =+    case envSyntacticEqualityFuel env of+      Strict.Nothing -> env+      Strict.Just n  ->+        env { envSyntacticEqualityFuel = Strict.Just (pred n) } +-- | Syntactic equality check for terms without checking remaining fuel.++{-# SPECIALIZE checkSyntacticEquality' ::+      Term -> Term ->+      (Term -> Term -> ReduceM a) ->+      (Term -> Term -> ReduceM a) ->+      ReduceM a #-}+{-# SPECIALIZE checkSyntacticEquality' ::+      Type -> Type ->+      (Type -> Type -> ReduceM a) ->+      (Type -> Type -> ReduceM a) ->+      ReduceM a #-}+checkSyntacticEquality'+  :: (Instantiate a, SynEq a, MonadReduce m)+  => a+  -> a+  -> (a -> a -> m b)  -- ^ Continuation used upon success.+  -> (a -> a -> m b)  -- ^ Continuation used upon failure.+  -> m b+checkSyntacticEquality' u v s f = do+  ((u, v), equal) <- liftReduce $ synEq u v `runStateT` True+  if equal then s u v else f u v++-- | Does the syntactic equality check have any remaining fuel?++syntacticEqualityFuelRemains :: MonadReduce m => m Bool+syntacticEqualityFuelRemains = do+  fuel <- envSyntacticEqualityFuel <$> askTC+  return $ case fuel of+    Strict.Nothing -> True+    Strict.Just n  -> n > 0+ -- | Monad for checking syntactic equality type SynEqM = StateT Bool ReduceM @@ -122,6 +190,7 @@       (UnivSort a, UnivSort a') -> UnivSort <$$> synEq a a'       (SizeUniv, SizeUniv  ) -> pure2 s       (LockUniv, LockUniv  ) -> pure2 s+      (IntervalUniv, IntervalUniv) -> pure2 s       (Prop l  , Prop l'   ) -> Prop <$$> synEq l l'       (Inf f m , Inf f' n) | f == f', m == n -> pure2 s       (SSet l  , SSet l'   ) -> SSet <$$> synEq l l'@@ -165,8 +234,8 @@  -- Ignore the tactic. instance SynEq a => SynEq (Dom a) where-  synEq d@(Dom ai b x t a) d'@(Dom ai' b' x' _ a')-    | x == x'   = Dom <$$> synEq ai ai' <**> synEq b b' <**> pure2 x <**> pure2 t <**> synEq a a'+  synEq d@(Dom ai x f t a) d'@(Dom ai' x' f' _ a')+    | x == x'   = Dom <$$> synEq ai ai' <**> pure2 x <**> synEq f f' <**> pure2 t <**> synEq a a'     | otherwise = inequal (d, d')  instance SynEq ArgInfo where
src/full/Agda/TypeChecking/Telescope.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ViewPatterns #-}  module Agda.TypeChecking.Telescope where @@ -5,6 +6,7 @@  import Control.Monad +import Data.Bifunctor (first) import Data.Foldable (find) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet@@ -61,14 +63,21 @@ -- | Unflatten: turns a flattened telescope into a proper telescope. Must be --   properly ordered. unflattenTel :: [ArgName] -> [Dom Type] -> Telescope-unflattenTel []   []            = EmptyTel-unflattenTel (x : xs) (a : tel) = ExtendTel a' (Abs x tel')-  where-    tel' = unflattenTel xs tel+unflattenTel xs tel = unflattenTel' (size tel) xs tel++-- | A variant of 'unflattenTel' which takes the size of the last+-- argument as an argument.+unflattenTel' :: Int -> [ArgName] -> [Dom Type] -> Telescope+unflattenTel' !n xs tel = case (xs, tel) of+  ([],     [])      -> EmptyTel+  (x : xs, a : tel) -> ExtendTel a' (Abs x tel')+    where+    tel' = unflattenTel' (n - 1) xs tel     a'   = applySubst rho a-    rho  = parallelS (replicate (size tel + 1) (withCallerCallStack impossibleTerm))-unflattenTel [] (_ : _) = __IMPOSSIBLE__-unflattenTel (_ : _) [] = __IMPOSSIBLE__+    rho  = parallelS $+           replicate n (withCallerCallStack impossibleTerm)+  ([],    _ : _) -> __IMPOSSIBLE__+  (_ : _, [])    -> __IMPOSSIBLE__  -- | Rename the variables in the telescope to the given names --   Precondition: @size xs == size tel@.@@ -100,7 +109,7 @@ --   | (x, Dom {domInfo = info, unDom = (name,_)}) <- zip xs l ] --   where l = telToList tel -teleNamedArgs :: (DeBruijn a) => Telescope -> [NamedArg a]+teleNamedArgs :: (DeBruijn a) => Tele (Dom t) -> [NamedArg a] teleNamedArgs = map namedArgFromDom . teleDoms  -- | A variant of `teleNamedArgs` which takes the argument names (and the argument info)@@ -374,28 +383,29 @@ telViewUpTo' n p t = do   t <- reduce t   case unEl t of-    Pi a b | p a -> absV a (absName b) <$> do-                      underAbstractionAbs a b $ \b -> telViewUpTo' (n - 1) p b-    _            -> return $ TelV EmptyTel t-  where-    absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t+    Pi a b | p a ->+          -- Force the name to avoid retaining the rest of b.+      let !bn = absName b in+      absV a bn <$> do+        underAbstractionAbs a b $ \b -> telViewUpTo' (n - 1) p b+    _ -> return $ TelV EmptyTel t  telViewPath :: PureTCM m => Type -> m TelView telViewPath = telViewUpToPath (-1)  -- | @telViewUpToPath n t@ takes off $t$ --   the first @n@ (or arbitrary many if @n < 0@) function domains or Path types.+--+-- @telViewUpToPath n t = fst <$> telViewUpToPathBoundary'n t@ telViewUpToPath :: PureTCM m => Int -> Type -> m TelView-telViewUpToPath 0 t = return $ TelV EmptyTel t-telViewUpToPath n t = do-  vt <- pathViewAsPi $ t-  case vt of-    Left (a,b)     -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)-    Right (El _ t) | Pi a b <- t-                   -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)-    Right t        -> return $ TelV EmptyTel t+telViewUpToPath n t = if n == 0 then done t else do+  pathViewAsPi t >>= \case+    Left  (a, b)          -> recurse a b+    Right (El _ (Pi a b)) -> recurse a b+    Right t               -> done t   where-    absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t+    done t      = return $ TelV EmptyTel t+    recurse a b = absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)  -- | [[ (i,(x,y)) ]] = [(i=0) -> x, (i=1) -> y] type Boundary = Boundary' (Term,Term)@@ -405,20 +415,18 @@ -- by the Path types encountered. The boundary terms live in the -- telescope given by the @TelView@. -- Each point of the boundary has the type of the codomain of the Path type it got taken from, see @fullBoundary@.-telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView,Boundary)-telViewUpToPathBoundary' 0 t = return $ (TelV EmptyTel t,[])-telViewUpToPathBoundary' n t = do-  vt <- pathViewAsPi' $ t-  case vt of-    Left ((a,b),xy) -> addEndPoints xy . absV a (absName b) <$> telViewUpToPathBoundary' (n - 1) (absBody b)-    Right (El _ t) | Pi a b <- t-                   -> absV a (absName b) <$> telViewUpToPathBoundary' (n - 1) (absBody b)-    Right t        -> return $ (TelV EmptyTel t,[])+telViewUpToPathBoundary' :: PureTCM m => Int -> Type -> m (TelView, Boundary)+telViewUpToPathBoundary' n t = if n == 0 then done t else do+  pathViewAsPi' t >>= \case+    Left ((a, b), xy)     -> addEndPoints xy <$> recurse a b+    Right (El _ (Pi a b)) -> recurse a b+    Right t               -> done t   where-    absV a x (TelV tel t, cs) = (TelV (ExtendTel a (Abs x tel)) t, cs)-    addEndPoints xy (telv@(TelV tel _),cs) = (telv, (var $ size tel - 1, xyInTel):cs)-      where-       xyInTel = raise (size tel) xy+    done t      = return (TelV EmptyTel t, [])+    recurse a b = first (absV a (absName b)) <$> do+      underAbstractionAbs a b $ \b -> telViewUpToPathBoundary' (n - 1) b+    addEndPoints xy (telv@(TelV tel _), cs) =+      (telv, (var $ size tel - 1, raise (size tel) xy) : cs)   fullBoundary :: Telescope -> Boundary -> Boundary@@ -478,10 +486,12 @@         Just i | Just (t,u) <- matchVar i -> IApply t u p         _                                 -> Apply a +-- | Reduces 'Type'. pathViewAsPi   :: PureTCM m => Type -> m (Either (Dom Type, Abs Type) Type) pathViewAsPi t = either (Left . fst) Right <$> pathViewAsPi' t +-- | Reduces 'Type'. pathViewAsPi'   :: PureTCM m => Type -> m (Either ((Dom Type, Abs Type), (Term,Term)) Type) pathViewAsPi' t = do@@ -492,45 +502,43 @@   => m (Type -> Either ((Dom Type, Abs Type), (Term,Term)) Type) pathViewAsPi'whnf = do   view <- pathView'-  minterval  <- getBuiltin' builtinInterval-  return $ \ t -> case view t of-    PathType s l p a x y | Just interval <- minterval ->+  minterval  <- getTerm' builtinInterval+  return $ \case+    (view -> PathType s l p a x y) | Just interval <- minterval ->       let name | Lam _ (Abs n _) <- unArg a = n                | otherwise = "i"-          i = El (SSet $ ClosedLevel 0) interval       in-        Left $ ((defaultDom $ i, Abs name $ El (raise 1 s) $ raise 1 (unArg a) `apply` [defaultArg $ var 0]), (unArg x, unArg y))+        Left ( ( defaultDom $ El intervalSort interval+               , Abs name $ El (raise 1 s) $ raise 1 (unArg a) `apply` [defaultArg $ var 0]+               )+             , (unArg x, unArg y)+             ) -    _    -> Right t+    t    -> Right t --- | returns Left (a,b) in case the type is @Pi a b@ or @PathP b _ _@---   assumes the type is in whnf.+-- | Returns @Left (a,b)@ in case the type is @Pi a b@ or @PathP b _ _@.+--   Assumes the 'Type' is in whnf. piOrPath :: HasBuiltins m => Type -> m (Either (Dom Type, Abs Type) Type) piOrPath t = do-  t <- pathViewAsPi'whnf <*> pure t-  case t of-    Left (p,_) -> return $ Left p-    Right (El _ (Pi a b)) -> return $ Left (a,b)-    Right t -> return $ Right t+  (pathViewAsPi'whnf <*> pure t) <&> \case+    Left (p, _)           -> Left p+    Right (El _ (Pi a b)) -> Left (a,b)+    Right _               -> Right t +-- | Assumes 'Type' is in whnf. telView'UpToPath :: Int -> Type -> TCM TelView-telView'UpToPath 0 t = return $ TelV EmptyTel t-telView'UpToPath n t = do-  vt <- pathViewAsPi'whnf <*> pure t-  case vt of-    Left ((a,b),_)     -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)-    Right (El _ t) | Pi a b <- t-                   -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)-    Right t        -> return $ TelV EmptyTel t+telView'UpToPath n t = if n == 0 then done else do+  piOrPath t >>= \case+    Left (a, b) -> absV a (absName b) <$> telViewUpToPath (n - 1) (absBody b)+    Right _     -> done   where-    absV a x (TelV tel t) = TelV (ExtendTel a (Abs x tel)) t+    done = return $ TelV EmptyTel t  telView'Path :: Type -> TCM TelView telView'Path = telView'UpToPath (-1) -isPath-  :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type))-isPath t = either Just (const Nothing) <$> pathViewAsPi t+isPath :: PureTCM m => Type -> m (Maybe (Dom Type, Abs Type))+isPath = either Just (const Nothing) <.> pathViewAsPi  telePatterns :: DeBruijn a => Telescope -> Boundary -> [NamedArg (Pattern' a)] telePatterns = telePatterns' teleNamedArgs
src/full/Agda/TypeChecking/Telescope/Path.hs view
@@ -17,6 +17,7 @@ import Agda.TypeChecking.Substitute import Agda.TypeChecking.Telescope +import Agda.Utils.Functor import Agda.Utils.List import Agda.Utils.Maybe import Agda.Utils.Size@@ -91,27 +92,34 @@ --   Does not reduce the type. arityPiPath :: Type -> TCM Int arityPiPath t = do-  t' <- piOrPath t-  case t' of-    Left (_ , u) -> (+1) <$> arityPiPath (unAbs u)-    Right _ -> return 0+  piOrPath t >>= \case+    Left (_, u) -> (+1) <$> arityPiPath (unAbs u)+    Right _     -> return 0 -iApplyVars :: DeBruijn a => [NamedArg (Pattern' a)] -> [Int]-iApplyVars ps = flip concatMap (map namedArg ps) $ \case-                             IApplyP _ t u x ->-                               [fromMaybe __IMPOSSIBLE__ (deBruijnView x)]-                             VarP{} -> []-                             ProjP{}-> []-                             LitP{} -> []-                             DotP{} -> []-                             DefP _ _ ps -> iApplyVars ps-                             ConP _ _ ps -> iApplyVars ps+-- | Collect the interval copattern variables as list of de Bruijn indices.+class IApplyVars p where+  iApplyVars :: p -> [Int] +instance DeBruijn a => IApplyVars (Pattern' a) where+  iApplyVars = \case+    IApplyP _ t u x -> [ fromMaybe __IMPOSSIBLE__ $ deBruijnView x ]+    VarP{}          -> []+    ProjP{}         -> []+    LitP{}          -> []+    DotP{}          -> []+    DefP _ _ ps     -> iApplyVars ps+    ConP _ _ ps     -> iApplyVars ps++instance IApplyVars p => IApplyVars (NamedArg p) where+  iApplyVars = iApplyVars . namedArg++instance IApplyVars p => IApplyVars [p] where+  iApplyVars = concatMap iApplyVars++-- | Check whether a type is the built-in interval type. isInterval :: (MonadTCM m, MonadReduce m) => Type -> m Bool isInterval t = liftTCM $ do-  mi <- getName' builtinInterval-  caseMaybe mi (return False) $ \ i -> do-  t <- reduce $ unEl t-  case t of-    Def q [] -> return $ q == i-    _        -> return $ False+  caseMaybeM (getName' builtinInterval) (return False) $ \ i -> do+  reduce (unEl t) <&> \case+    Def q [] -> q == i+    _        -> False
src/full/Agda/TypeChecking/Unquote.hs view
@@ -2,10 +2,10 @@ module Agda.TypeChecking.Unquote where  import Control.Arrow          ( first, second, (&&&) )-import Control.Monad          ( (<=<) )+import Control.Monad          ( (<=<), liftM2 ) import Control.Monad.Except   ( MonadError(..), ExceptT(..), runExceptT ) import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.Reader   ( ReaderT(..), runReaderT )+import Control.Monad.Reader   ( ReaderT(..), runReaderT, ask ) import Control.Monad.State    ( gets, modify, StateT(..), runStateT ) import Control.Monad.Writer   ( MonadWriter(..), WriterT(..), runWriterT ) import Control.Monad.Trans    ( lift )@@ -28,10 +28,13 @@ import Agda.Syntax.Internal as I import qualified Agda.Syntax.Reflected as R import qualified Agda.Syntax.Abstract as A+import Agda.Syntax.Abstract.Views+import Agda.Syntax.Translation.InternalToAbstract import Agda.Syntax.Literal import Agda.Syntax.Position import Agda.Syntax.Info import Agda.Syntax.Translation.ReflectedToAbstract+import Agda.Syntax.Scope.Base (KindOfName(ConName, DataName))  import Agda.Interaction.Library ( ExeName ) import Agda.Interaction.Options ( optTrustedExecutables, optAllowExec )@@ -39,6 +42,7 @@ import Agda.TypeChecking.Constraints import Agda.TypeChecking.Monad import Agda.TypeChecking.Free+import Agda.TypeChecking.Irrelevance ( workOnTypes ) import Agda.TypeChecking.Pretty import Agda.TypeChecking.Reduce import Agda.TypeChecking.Substitute@@ -49,9 +53,12 @@ import Agda.TypeChecking.Primitive import Agda.TypeChecking.ReconstructParameters import Agda.TypeChecking.CheckInternal+import Agda.TypeChecking.InstanceArguments ( getInstanceCandidates )  import {-# SOURCE #-} Agda.TypeChecking.Rules.Term import {-# SOURCE #-} Agda.TypeChecking.Rules.Def+import {-# SOURCE #-} Agda.TypeChecking.Rules.Decl+import Agda.TypeChecking.Rules.Data  import Agda.Utils.Either import Agda.Utils.Lens@@ -62,6 +69,7 @@ import qualified Agda.Interaction.Options.Lenses as Lens  import Agda.Utils.Impossible+import Agda.Syntax.Abstract (TypedBindingInfo(tbTacticAttr))  agdaTermType :: TCM Type agdaTermType = El (mkType 0) <$> primAgdaTerm@@ -112,8 +120,9 @@  inOriginalContext :: UnquoteM a -> UnquoteM a inOriginalContext m =-  packUnquoteM $ \ cxt s ->-    unsafeModifyContext (const cxt) $ unpackUnquoteM m cxt s+  packUnquoteM $ \ cxt s -> do+    n <- getContextSize+    escapeContext __IMPOSSIBLE__ (n - length cxt) $ unpackUnquoteM m cxt s  isCon :: ConHead -> TCM Term -> UnquoteM Bool isCon con tm = do t <- liftTCM tm@@ -282,11 +291,12 @@ unquoteNString :: Arg Term -> UnquoteM Text unquoteNString = unquoteN -data ErrorPart = StrPart String | TermPart A.Expr | NamePart QName+data ErrorPart = StrPart String | TermPart A.Expr | PattPart A.Pattern | NamePart QName  instance PrettyTCM ErrorPart where-  prettyTCM (StrPart s) = text s+  prettyTCM (StrPart s)  = text s   prettyTCM (TermPart t) = prettyTCM t+  prettyTCM (PattPart p) = prettyTCM p   prettyTCM (NamePart x) = prettyTCM x  -- | We do a little bit of work here to make it possible to generate nice@@ -302,6 +312,7 @@         (s0, "")        -> consLine (StrPart s0) (splitLines ss)         _               -> __IMPOSSIBLE__     splitLines (p@TermPart{} : ss) = consLine p (splitLines ss)+    splitLines (p@PattPart{} : ss) = consLine p (splitLines ss)     splitLines (p@NamePart{} : ss) = consLine p (splitLines ss)      consLine l []        = [[l]]@@ -315,6 +326,7 @@       Con c _ es | Just [x] <- allApplyElims es ->         choice [ (c `isCon` primAgdaErrorPartString, StrPart . T.unpack <$> unquoteNString x)                , (c `isCon` primAgdaErrorPartTerm,   TermPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Term)))+               , (c `isCon` primAgdaErrorPartPatt,   PattPart <$> ((liftTCM . toAbstractWithoutImplicit) =<< (unquoteN x :: UnquoteM R.Pattern)))                , (c `isCon` primAgdaErrorPartName,   NamePart <$> unquoteN x) ]                __IMPOSSIBLE__       _ -> throwError $ NonCanonical "error part" t@@ -407,13 +419,12 @@   unquote t = do     t <- reduceQuotedTerm t     case t of-      Lit (LitMeta f x) -> liftTCM $ do-        live <- (f ==) <$> getCurrentPath-        unless live $ do-            m <- fromMaybe __IMPOSSIBLE__ <$> lookupModuleFromSource f+      Lit (LitMeta m x) -> liftTCM $ do+        live <- (Just m ==) <$> currentTopLevelModule+        unless live $             typeError . GenericDocError =<<               sep [ "Can't unquote stale metavariable"-                  , pretty m <> "." <> pretty x ]+                  , pretty m <> "._" <> pretty (metaId x) ]         return x       _ -> throwError $ NonCanonical "meta variable" t @@ -451,7 +462,11 @@           , (c `isCon` primAgdaLitChar,   LitChar   <$> unquoteN x)           , (c `isCon` primAgdaLitString, LitString <$> unquoteNString x)           , (c `isCon` primAgdaLitQName,  LitQName  <$> unquoteN x)-          , (c `isCon` primAgdaLitMeta,   LitMeta   <$> getCurrentPath <*> unquoteN x) ]+          , (c `isCon` primAgdaLitMeta,+             LitMeta+               <$> (fromMaybe __IMPOSSIBLE__ <$> currentTopLevelModule)+               <*> unquoteN x)+          ]           __IMPOSSIBLE__       Con c _ _ -> __IMPOSSIBLE__       _ -> throwError $ NonCanonical "literal" t@@ -480,7 +495,7 @@           , (c `isCon` primAgdaTermMeta,    R.Meta    <$> unquoteN x <*> unquoteN y)           , (c `isCon` primAgdaTermLam,     R.Lam     <$> unquoteN x <*> unquoteN y)           , (c `isCon` primAgdaTermPi,      mkPi      <$> unquoteN x <*> unquoteN y)-          , (c `isCon` primAgdaTermExtLam,  R.ExtLam  <$> (List1.fromList <$> unquoteN x) <*> unquoteN y)+          , (c `isCon` primAgdaTermExtLam,  R.ExtLam  <$> (List1.fromListSafe __IMPOSSIBLE__ <$> unquoteN x) <*> unquoteN y)           ]           __IMPOSSIBLE__         where@@ -559,8 +574,10 @@              , (f `isDef` primAgdaTCMReduce,                     tcFun1 tcReduce                     u)              , (f `isDef` primAgdaTCMGetType,                    tcFun1 tcGetType                    u)              , (f `isDef` primAgdaTCMGetDefinition,              tcFun1 tcGetDefinition              u)+             , (f `isDef` primAgdaTCMFormatErrorParts,           tcFun1 tcFormatErrorParts           u)              , (f `isDef` primAgdaTCMIsMacro,                    tcFun1 tcIsMacro                    u)              , (f `isDef` primAgdaTCMFreshName,                  tcFun1 tcFreshName                  u)+             , (f `isDef` primAgdaTCMGetInstances,               uqFun1 tcGetInstances               u)              ]              failEval     I.Def f [u, v] ->@@ -568,19 +585,21 @@              , (f `isDef` primAgdaTCMCheckType,  tcFun2 tcCheckType  u v)              , (f `isDef` primAgdaTCMDeclareDef, uqFun2 tcDeclareDef u v)              , (f `isDef` primAgdaTCMDeclarePostulate, uqFun2 tcDeclarePostulate u v)+             , (f `isDef` primAgdaTCMDefineData, uqFun2 tcDefineData u v)              , (f `isDef` primAgdaTCMDefineFun,  uqFun2 tcDefineFun  u v)-             , (f `isDef` primAgdaTCMQuoteOmegaTerm, tcQuoteTerm (unElim v))+             , (f `isDef` primAgdaTCMQuoteOmegaTerm, tcQuoteTerm (sort $ Inf IsFibrant 0) (unElim v))              ]              failEval     I.Def f [l, a, u] ->       choice [ (f `isDef` primAgdaTCMReturn,      return (unElim u))              , (f `isDef` primAgdaTCMTypeError,   tcFun1 tcTypeError   u)-             , (f `isDef` primAgdaTCMQuoteTerm,   tcQuoteTerm (unElim u))+             , (f `isDef` primAgdaTCMQuoteTerm,   tcQuoteTerm (mkT (unElim l) (unElim a)) (unElim u))              , (f `isDef` primAgdaTCMUnquoteTerm, tcFun1 (tcUnquoteTerm (mkT (unElim l) (unElim a))) u)              , (f `isDef` primAgdaTCMBlockOnMeta, uqFun1 tcBlockOnMeta u)              , (f `isDef` primAgdaTCMDebugPrint,  tcFun3 tcDebugPrint l a u)              , (f `isDef` primAgdaTCMNoConstraints, tcNoConstraints (unElim u))              , (f `isDef` primAgdaTCMWithReconsParams, tcWithReconsParams (unElim u))+             , (f `isDef` primAgdaTCMDeclareData, uqFun3 tcDeclareData l a u)              , (f `isDef` primAgdaTCMRunSpeculative, tcRunSpeculative (unElim u))              , (f `isDef` primAgdaTCMExec, tcFun3 tcExec l a u)              ]@@ -588,12 +607,15 @@     I.Def f [_, _, u, v] ->       choice [ (f `isDef` primAgdaTCMCatchError,    tcCatchError    (unElim u) (unElim v))              , (f `isDef` primAgdaTCMWithNormalisation, tcWithNormalisation (unElim u) (unElim v))-             , (f `isDef` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v))              , (f `isDef` primAgdaTCMInContext,     tcInContext     (unElim u) (unElim v))              , (f `isDef` primAgdaTCMOnlyReduceDefs, tcOnlyReduceDefs (unElim u) (unElim v))              , (f `isDef` primAgdaTCMDontReduceDefs, tcDontReduceDefs (unElim u) (unElim v))              ]              failEval+    I.Def f [_, _, u, v, w] ->+      choice [ (f `isDef` primAgdaTCMExtendContext, tcExtendContext (unElim u) (unElim v) (unElim w))+             ]+             failEval     I.Def f [_, _, _, _, m, k] ->       choice [ (f `isDef` primAgdaTCMBind, tcBind (unElim m) (unElim k)) ]              failEval@@ -688,6 +710,9 @@       modify (second $ const s)       liftTCM primUnitUnit +    tcFormatErrorParts :: [ErrorPart] -> TCM Term+    tcFormatErrorParts msg = quoteString . prettyShow <$> prettyErrorParts msg+     tcTypeError :: [ErrorPart] -> TCM a     tcTypeError err = typeError . GenericDocError =<< prettyErrorParts err @@ -715,18 +740,25 @@     tcCheckType :: R.Term -> R.Type -> TCM Term     tcCheckType v a = do       r <- isReconstructed-      a <- locallyReduceAllDefs $ isType_ =<< toAbstract_ a+      a <- workOnTypes $ locallyReduceAllDefs $ isType_ =<< toAbstract_ a       e <- toAbstract_ v       v <- checkExpr e a       if r then do         v <- process v-        v <- locallyReduceAllDefs $ reconstructParameters' defaultAction a v+        v <- locallyReduceAllDefs $ reconstructParameters a v         locallyReconstructed (quoteTerm v)       else         quoteTerm =<< process v -    tcQuoteTerm :: Term -> UnquoteM Term-    tcQuoteTerm v = liftTCM $ quoteTerm =<< process v+    tcQuoteTerm :: Type -> Term -> UnquoteM Term+    tcQuoteTerm a v = liftTCM $ do+      r <- isReconstructed+      if r then do+        v <- process v+        v <- locallyReduceAllDefs $ reconstructParameters a v+        locallyReconstructed (quoteTerm v)+      else+        quoteTerm =<< process v      tcUnquoteTerm :: Type -> R.Term -> TCM Term     tcUnquoteTerm a v = do@@ -762,32 +794,36 @@     tcGetContext :: UnquoteM Term     tcGetContext = liftTCM $ do       r <- isReconstructed-      as <- map (fmap snd) <$> getContext+      as <- map (nameToArgName . fst . unDom &&& fmap snd) <$> getContext       as <- etaContract =<< process as       if r then do-         as <- recons (reverse as)-         let as' = reverse as-         locallyReconstructed $ buildList <*> mapM quoteDom as'+        as <- recons (reverse as)+        let as' = reverse as+        locallyReconstructed $ buildList <*> mapM quoteDomWithName as'       else-         buildList <*> mapM quoteDom as+        buildList <*> mapM quoteDomWithName as       where-         recons :: [Dom Type] -> TCM [Dom Type]-         recons [] = return []-         recons (d@Dom {unDom=t} : ds) = do-           t <- locallyReduceAllDefs $ reconstructParametersInType t-           let d' = d{unDom=t}-           ds' <- addContext d' $ recons ds-           return $ d' : ds'+        recons :: [(ArgName, Dom Type)] -> TCM [(ArgName, Dom Type)]+        recons []                        = return []+        recons ((s, d@Dom {unDom=t}):ds) = do+          t <- locallyReduceAllDefs $ reconstructParametersInType t+          let d' = d{unDom=t}+          ds' <- addContext (s, d') $ recons ds+          return $ (s, d'):ds' -    extendCxt :: Arg R.Type -> UnquoteM a -> UnquoteM a-    extendCxt a m = do-      a <- locallyReduceAllDefs $ liftTCM $ traverse (isType_ <=< toAbstract_) a-      liftU1 (addContext ("x" :: String, domFromArg a :: Dom Type)) m+        quoteDomWithName :: (ArgName, Dom Type) -> TCM Term+        quoteDomWithName (x, t) = toTerm <*> pure (T.pack x, t) -    tcExtendContext :: Term -> Term -> UnquoteM Term-    tcExtendContext a m = do+    extendCxt :: Text -> Arg R.Type -> UnquoteM a -> UnquoteM a+    extendCxt s a m = do+      a <- workOnTypes $ locallyReduceAllDefs $ liftTCM $ traverse (isType_ <=< toAbstract_) a+      liftU1 (addContext (s, domFromArg a :: Dom Type)) m++    tcExtendContext :: Term -> Term -> Term -> UnquoteM Term+    tcExtendContext s a m = do+      s <- unquote s       a <- unquote a-      fmap (strengthen impossible) $ extendCxt a $ do+      fmap (strengthen impossible) $ extendCxt s a $ do         v <- evalTCM $ raise 1 m         when (freeIn 0 v) $ liftTCM $ genericDocError =<<           hcat ["Local variable '", prettyTCM (var 0), "' escaping in result of extendContext:"]@@ -797,11 +833,11 @@     tcInContext :: Term -> Term -> UnquoteM Term     tcInContext c m = do       c <- unquote c-      liftU1 unsafeInTopContext $ go c (evalTCM m)+      inOriginalContext $ go c (evalTCM m)       where-        go :: [Arg R.Type] -> UnquoteM Term -> UnquoteM Term-        go []       m = m-        go (a : as) m = go as (extendCxt a m)+        go :: [(Text , Arg R.Type)] -> UnquoteM Term -> UnquoteM Term+        go []             m = m+        go ((s , a) : as) m = go as (extendCxt s a m)      constInfo :: QName -> TCM Definition     constInfo x = either err return =<< getConstInfo' x@@ -810,7 +846,7 @@     tcGetType :: QName -> TCM Term     tcGetType x = do       r  <- isReconstructed-      ci <- constInfo x+      ci <- constInfo x >>= instantiateDef       let t = defType ci       if r then do         t <- locallyReduceAllDefs $ reconstructParametersInType t@@ -833,11 +869,11 @@       if r then         tcGetDefinitionRecons x       else-        quoteDefn =<< constInfo x+        quoteDefn =<< instantiateDef =<< constInfo x      tcGetDefinitionRecons :: QName -> TCM Term     tcGetDefinitionRecons x = do-      ci@(Defn {theDef=d}) <- constInfo x+      ci@(Defn {theDef=d}) <- constInfo x >>= instantiateDef       case d of         f@(Function {funClauses=cs}) -> do           cs' <- mapM reconsClause cs@@ -913,6 +949,86 @@         when (isInstance i) $ addTypedInstance x a         primUnitUnit +    -- A datatype is expected to be declared with a function type.+    -- The second argument indicates how many preceding types are parameters.+    tcDeclareData :: QName -> Integer -> R.Type -> UnquoteM Term+    tcDeclareData x npars t = inOriginalContext $ do+      setDirty+      tell [x]+      liftTCM $ do+        reportSDoc "tc.unquote.decl" 10 $ sep+          [ "declare Data" <+> prettyTCM x <+> ":"+          , nest 2 $ prettyR t+          ]+        alreadyDefined <- isRight <$> getConstInfo' x+        when alreadyDefined $ genericError $ "Multiple declarations of " ++ prettyShow x+        e <- toAbstract_ t+        -- The type to be checked with @checkSig@ is without parameters.+        let (tel, e') = splitPars (fromInteger npars) e+        ac <- asksTC (^. lensIsAbstract)+        let defIn = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ac noRange+        checkSig DataName defIn x (A.GeneralizeTel Map.empty tel) e'+        primUnitUnit++    tcDefineData :: QName -> [(QName, R.Type)] -> UnquoteM Term+    tcDefineData x cs = inOriginalContext $ (setDirty >>) $ liftTCM $ do+      caseEitherM (getConstInfo' x)+        (const $ genericError $ "Missing declaration for " ++ prettyShow x) $ \def -> do+        npars <- case theDef def of+                   DataOrRecSig n -> return n+                   _              -> genericError $ prettyShow x +++                     " is not declared as a datatype or record, or it already has a definition."++        -- For some reasons, reifying parameters and adding them to the context via+        -- `addContext` before `toAbstract_` is different from substituting the type after+        -- `toAbstract_, so some dummy parameters are added and removed later.+        es <- mapM (toAbstract_ . addDummy npars . snd) cs+        reportSDoc "tc.unquote.def" 10 $ vcat $+          [ "declaring constructors of" <+> prettyTCM x <+> ":" ] ++ map prettyA es++        -- Translate parameters from internal definitions back to abstract syntax.+        t   <- instantiateFull . defType =<< instantiateDef def+        tel <- reify =<< theTel <$> telViewUpTo npars t++        es' <- case mapM (uncurry (substNames' tel) . splitPars npars) es of+                 Nothing -> genericError $ "Number of parameters doesn't match!"+                 Just es -> return es++        ac <- asksTC (^. lensIsAbstract)+        let i = mkDefInfo (nameConcrete $ qnameName x) noFixity' PublicAccess ac noRange+            conNames = map fst cs+            toAxiom c e = A.Axiom ConName i defaultArgInfo Nothing c e+            as = zipWith toAxiom conNames es'+            lams = map (\case {A.TBind _ tac (b :| []) _ -> A.DomainFree (tbTacticAttr tac) b+                              ;_ -> __IMPOSSIBLE__ }) tel+        reportSDoc "tc.unquote.def" 10 $ vcat $+          [ "checking datatype: " <+> prettyTCM x <+> " with constructors:"+          , nest 2 (vcat (map prettyTCM conNames))+          ]+        checkDataDef i x YesUniverseCheck (A.DataDefParams Set.empty lams) as+        primUnitUnit+      where+        addDummy :: Int -> R.Type -> R.Type+        addDummy 0 t = t+        addDummy n t = R.Pi (defaultDom (R.Sort $ R.LitS 0)) (R.Abs "dummy" $ addDummy (n - 1) t)++        substNames' :: [A.TypedBinding] -> [A.TypedBinding] -> A.Expr -> Maybe A.Expr+        substNames' (a : as) (b : bs) e = do+          let (A.TBind _ _ (na :| _) expra) = a+              (A.TBind _ _ (nb :| _) exprb) = b+              getName n = A.unBind . A.binderName $ namedArg n+          e' <- substNames' as bs e+          return $ mapExpr (substName (getName na) (getName nb)) e'+          where+            -- Substitute @Var x@ for @Var y@ in an @Expr@.+            substName :: Name -> Name -> (A.Expr -> A.Expr)+            substName x y e@(A.Var n)+                    | y == n    = A.Var x+                    | otherwise = e+            substName _ _ e = e+        substNames' [] [] e = return e+        substNames' _ _ _ = Nothing+     tcDefineFun :: QName -> [R.Clause] -> UnquoteM Term     tcDefineFun x cs = inOriginalContext $ (setDirty >>) $ liftTCM $ do       whenM (isLeft <$> getConstInfo' x) $@@ -936,7 +1052,18 @@         _ -> liftTCM $ typeError . GenericDocError =<<           "Should be a pair: " <+> prettyTCM u +    tcGetInstances :: MetaId -> UnquoteM Term+    tcGetInstances m = liftTCM (getInstanceCandidates m) >>= \case+      Left unblock -> do+        s <- gets snd+        throwError (BlockedOnMeta s unblock)+      Right cands -> liftTCM $+        buildList <*> mapM (quoteTerm . candidateTerm) cands +    splitPars :: Int -> A.Expr -> ([A.TypedBinding], A.Expr)+    splitPars 0 e = ([] , e)+    splitPars npars (A.Pi _ (n :| _) e) = first (n :) (splitPars (npars - 1) e)+    splitPars npars e = __IMPOSSIBLE__ ------------------------------------------------------------------------ -- * Trusted executables ------------------------------------------------------------------------
src/full/Agda/TypeChecking/Warnings.hs view
@@ -17,10 +17,10 @@   ) where  import Control.Monad ( forM, unless )-import Control.Monad.Except+import Control.Monad.Except ( MonadError(..) ) import Control.Monad.Reader ( ReaderT ) import Control.Monad.State ( StateT )-import Control.Monad.Trans ( lift )+import Control.Monad.Trans ( MonadTrans, lift )  import qualified Data.List as List import qualified Data.Map  as Map
src/full/Agda/TypeChecking/With.hs view
@@ -2,6 +2,8 @@  module Agda.TypeChecking.With where +import Prelude hiding ((!!))+ import Control.Monad import Control.Monad.Writer (WriterT, runWriterT, tell)
src/full/Agda/Utils/AssocList.hs view
@@ -8,7 +8,7 @@  import Prelude hiding (lookup) -import Data.Function+import Data.Function (on) import Data.List (lookup) import qualified Data.List as List import qualified Data.Map  as Map
src/full/Agda/Utils/Benchmark.hs view
@@ -15,7 +15,7 @@ import Control.Monad.IO.Class ( MonadIO(..) )  -import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Monoid import Data.Maybe
src/full/Agda/Utils/BiMap.hs view
@@ -12,7 +12,7 @@ import Control.Monad.Identity import Control.Monad.State -import Data.Function+import Data.Function (on) import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map@@ -58,8 +58,8 @@ -- Every value of this type must satisfy 'biMapInvariant'.  data BiMap k v = BiMap-  { biMapThere :: Map k v-  , biMapBack  :: Map (Tag v) k+  { biMapThere :: !(Map k v)+  , biMapBack  :: !(Map (Tag v) k)   }   deriving Generic @@ -81,6 +81,16 @@ instance Null (BiMap k v) where   empty = BiMap Map.empty Map.empty   null  = null . biMapThere++-- | Is the value a source key? O(log n).++source :: Ord k => k -> BiMap k v -> Bool+source k = Map.member k . biMapThere++-- | Is the value a target key? O(log n).++target :: Ord (Tag v) => Tag v -> BiMap k v -> Bool+target k = Map.member k . biMapBack  -- | Lookup. O(log n).
+ src/full/Agda/Utils/BoolSet.hs view
@@ -0,0 +1,182 @@+-- | Representation of @'Set' 'Bool'@ as a 4-element enum type.+--+-- All operations in constant time and space.+--+-- Mimics the interface of 'Data.Set'.+--+-- Import as:+-- @+--    import qualified Agda.Utils.BoolSet as BoolSet+--    import Agda.Utils.BoolSet (BoolSet)+-- @++module Agda.Utils.BoolSet+  ( BoolSet+  , (\\)+  , complement+  , delete+  , difference+  , elems+  , empty+  , fromList, fromAscList, fromDistinctAscList+  , insert+  , intersection+  , isSubsetOf+  , lookupMin+  , member+  , notMember+  , null+  , singleton+  , size+  , toList, toAscList+  , toSingleton+  , total+  , union+  ) where++import Prelude hiding (null)++import Agda.Utils.Impossible++-- | Isomorphic to @'Set' 'Bool'@.+data BoolSet = SetEmpty | SetTrue | SetFalse | SetBoth+  deriving (Eq, Ord, Show, Enum, Bounded)++-- * Query++null :: BoolSet -> Bool+null = (SetEmpty ==)++size :: BoolSet -> Int+size = \case+  SetEmpty -> 0+  SetTrue  -> 1+  SetFalse -> 1+  SetBoth  -> 2++member :: Bool -> BoolSet -> Bool+member b = \case+  SetEmpty -> False+  SetBoth  -> True+  SetTrue  -> b+  SetFalse -> not b++-- | @not . member b@.+notMember :: Bool -> BoolSet -> Bool+notMember b = not . member b++isSubsetOf ::  BoolSet -> BoolSet -> Bool+isSubsetOf = curry $ \case+  (SetEmpty , _        ) -> True+  (_        , SetBoth  ) -> True+  (SetTrue  , SetTrue  ) -> True+  (SetFalse , SetFalse ) -> True+  _                      -> False++lookupMin :: BoolSet -> Maybe Bool+lookupMin = \case+  SetEmpty -> Nothing+  SetTrue  -> Just True+  _        -> Just False++-- | @toSingleton s == Just b@ iff @s == singleton b@.+toSingleton :: BoolSet -> Maybe Bool+toSingleton  = \case+  SetTrue  -> Just True+  SetFalse -> Just False+  _        -> Nothing++-- * Construction++-- | The empty set.+empty :: BoolSet+empty = SetEmpty++-- | The full set.+total :: BoolSet+total = SetBoth++-- | A singleton set.+singleton :: Bool -> BoolSet+singleton = \case+  True  -> SetTrue+  False -> SetFalse++insert :: Bool -> BoolSet -> BoolSet+insert b = \case+  SetBoth  -> SetBoth+  SetEmpty -> singleton b+  SetTrue  -> if b then SetTrue else SetBoth+  SetFalse -> if b then SetBoth else SetFalse++delete :: Bool -> BoolSet -> BoolSet+delete b = \case+  SetEmpty -> SetEmpty+  SetTrue  -> if b then SetEmpty else SetTrue+  SetFalse -> if b then SetFalse else SetEmpty+  SetBoth  -> if b then SetFalse else SetTrue++-- * Combine++complement :: BoolSet -> BoolSet+complement = \case+  SetEmpty -> SetBoth+  SetBoth  -> SetEmpty+  SetTrue  -> SetFalse+  SetFalse -> SetTrue++difference, (\\) :: BoolSet -> BoolSet -> BoolSet+difference = curry $ \case+  (SetEmpty , _        ) -> SetEmpty+  (_        , SetBoth  ) -> SetEmpty+  (s        , SetEmpty ) -> s+  (SetBoth  , SetTrue  ) -> SetFalse+  (SetBoth  , SetFalse ) -> SetTrue+  (SetTrue  , SetTrue  ) -> SetEmpty+  (SetTrue  , SetFalse ) -> SetTrue+  (SetFalse , SetTrue  ) -> SetFalse+  (SetFalse , SetFalse ) -> SetEmpty+(\\)       = difference++intersection ::  BoolSet -> BoolSet -> BoolSet+intersection = curry $ \case+  (SetEmpty , _        ) -> SetEmpty+  (_        , SetEmpty ) -> SetEmpty+  (SetBoth  , s        ) -> s+  (s        , SetBoth  ) -> s+  (SetTrue  , SetTrue  ) -> SetTrue+  (SetFalse , SetTrue  ) -> SetEmpty+  (SetTrue  , SetFalse ) -> SetEmpty+  (SetFalse , SetFalse ) -> SetFalse++union ::  BoolSet -> BoolSet -> BoolSet+union = curry $ \case+  (SetBoth  , _        ) -> SetBoth+  (_        , SetBoth  ) -> SetBoth+  (SetEmpty , s        ) -> s+  (s        , SetEmpty ) -> s+  (SetTrue  , SetTrue  ) -> SetTrue+  (SetFalse , SetTrue  ) -> SetBoth+  (SetTrue  , SetFalse ) -> SetBoth+  (SetFalse , SetFalse ) -> SetFalse++-- * Conversion++elems, toList, toAscList :: BoolSet -> [Bool]+elems     = \case+  SetEmpty -> []+  SetTrue  -> [True]+  SetFalse -> [False]+  SetBoth  -> [False, True]+toList    = elems+toAscList = elems++fromList, fromAscList, fromDistinctAscList :: [Bool] -> BoolSet+fromList            = foldr insert SetEmpty+fromAscList         = fromList+fromDistinctAscList = \case+  []            -> SetEmpty+  [False]       -> SetFalse+  [True]        -> SetTrue+  [False, True] -> SetBoth+  _             -> __IMPOSSIBLE__
src/full/Agda/Utils/Cluster.hs view
@@ -3,8 +3,7 @@ -- | Create clusters of non-overlapping things.  module Agda.Utils.Cluster-  ( C-  , cluster+  ( cluster   , cluster'   ) where @@ -14,7 +13,7 @@ import Data.Equivalence.Monad (runEquivT, equateAll, classDesc) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.IntMap as IntMap+import qualified Data.Map.Strict as MapS #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup #endif@@ -23,27 +22,24 @@ import Agda.Utils.Singleton import Agda.Utils.Fail --- | Characteristic identifiers.-type C = Int---- | Given a function @f :: a -> NonEmpty C@ which returns a non-empty list of---   characteristics @C@ of @a@, partition a list of @a@s into groups---   such that each element in a group shares at least one characteristic+-- | Given a function @f :: a -> NonEmpty c@ which returns a non-empty list of+--   characteristics of @a@, partition a list of @a@s into groups such+--   that each element in a group shares at least one characteristic --   with at least one other element of the group.-cluster :: (a -> NonEmpty C) -> [a] -> [NonEmpty a]+cluster :: Ord c => (a -> NonEmpty c) -> [a] -> [NonEmpty a] cluster f as = cluster' $ map (\ a -> (a, f a)) as  -- | Partition a list of @a@s paired with a non-empty list of---   characteristics @C@ into groups---   such that each element in a group shares at least one characteristic---   with at least one other element of the group.-cluster' :: [(a, NonEmpty C)] -> [NonEmpty a]+--   characteristics into groups such that each element in a group+--   shares at least one characteristic with at least one other+--   element of the group.+cluster' :: Ord c => [(a, NonEmpty c)] -> [NonEmpty a] cluster' acs = runFail_ $ runEquivT id const $ do   -- Construct the equivalence classes of characteristics.   forM_ acs $ \ (_, c :| cs) -> equateAll $ c:cs   -- Pair each element with its class.-  cas <- forM acs $ \ (a, c :| _) -> classDesc c <&> \ k -> IntMap.singleton k (singleton a)+  cas <- forM acs $ \ (a, c :| _) -> classDesc c <&> \ k -> MapS.singleton k (singleton a)   -- Create a map from class to elements.-  let m = IntMap.unionsWith (<>) cas+  let m = MapS.unionsWith (<>) cas   -- Return the values of the map-  return $ IntMap.elems m+  return $ MapS.elems m
src/full/Agda/Utils/Empty.hs view
@@ -4,14 +4,10 @@ import Control.DeepSeq import Control.Exception (evaluate) -import Data.Data (Data)- import Agda.Utils.Impossible   data Empty--deriving instance Data Empty  -- | Values of type 'Empty' are not forced, because 'Empty' is used as -- a constructor argument in 'Agda.Syntax.Internal.Substitution''.
src/full/Agda/Utils/FileName.hs view
@@ -10,6 +10,7 @@   , sameFile   , doesFileExistCaseSensitive   , isNewerThan+  , relativizeAbsolutePath   ) where  import System.Directory@@ -22,8 +23,7 @@ import System.Win32        ( findFirstFile, findClose, getFindDataFileName ) #endif -import Data.Data           ( Data )-import Data.Function+import Data.Function (on) import Data.Hashable       ( Hashable ) import Data.Text           ( Text ) import qualified Data.Text as Text@@ -39,7 +39,7 @@ -- paths point to the same files or directories.  newtype AbsolutePath = AbsolutePath { textPath :: Text }-  deriving (Show, Eq, Ord, Data, Hashable, NFData)+  deriving (Show, Eq, Ord, Hashable, NFData)  -- | Extract the 'AbsolutePath' to be used as 'FilePath'. filePath :: AbsolutePath -> FilePath@@ -91,7 +91,7 @@   AbsolutePath . Text.pack <$> canonicalizePath (Text.unpack f)  -- | Tries to establish if the two file paths point to the same file--- (or directory).+-- (or directory). False negatives may be returned.  sameFile :: AbsolutePath -> AbsolutePath -> IO Bool sameFile = liftA2 equalFilePath `on` (canonicalizePath . filePath)@@ -125,3 +125,28 @@             newT <- getModificationTime new             oldT <- getModificationTime old             return $ newT >= oldT++-- | A partial version of 'System.FilePath.makeRelative' with flipped arguments,+--   returning 'Nothing' if the given path cannot be relativized to the given @root@.+relativizeAbsolutePath ::+     AbsolutePath+       -- ^ The absolute path we see to relativize.+  -> AbsolutePath+       -- ^ The root for relativization.+  -> Maybe FilePath+       -- ^ The relative path, if any.+relativizeAbsolutePath apath aroot+  | rest /= path = Just rest+  | otherwise    = Nothing+  where+  path = filePath apath+  root = filePath aroot+  rest = makeRelative root path+    -- Andreas, 2022-10-10+    -- See https://gitlab.haskell.org/haskell/filepath/-/issues/130.+    -- 'System.FilePath.makeRelative' is strangely enough a total function,+    -- and it returns the original @path@ if it could not be relativized to+    -- the @root@, or if the @root@ was ".".+    -- In our case, the @root@ is absolute, so we should expect @rest@ to+    -- always be different from @path@ if @path@ is relative to @root@.+    -- In the extreme case, @root = "/"@ and @path == "/" ++ rest@.
src/full/Agda/Utils/Float.hs view
@@ -221,8 +221,10 @@   | isNaN x   = nan   | otherwise = x -doubleToWord64 :: Double -> Word64-doubleToWord64 = castDoubleToWord64 . normaliseNaN+doubleToWord64 :: Double -> Maybe Word64+doubleToWord64 x+  | isNaN x   = Nothing+  | otherwise = Just (castDoubleToWord64 x)  -- |Denotational equality for floating point numbers, checks bitwise equality. --
src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs view
@@ -79,7 +79,7 @@ import qualified Data.Array.IArray as Array import Data.Sequence (Seq) import qualified Data.Sequence as Seq-import Data.Function+import Data.Function (on) import qualified Data.Graph as Graph import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap
src/full/Agda/Utils/Graph/TopSort.hs view
@@ -3,6 +3,7 @@     ( topSort     ) where +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map import qualified Agda.Utils.Graph.AdjacencyMap.Unidirectional as G@@ -21,14 +22,17 @@ --   Note: should be stable to preserve order of generalizable variables. Algorithm due to Richard --   Eisenberg, and works by walking over the list left-to-right and moving each node the minimum --   distance left to guarantee topological ordering.-topSort :: Ord n => [n] -> [(n, n)] -> Maybe [n]-topSort nodes edges = go [] nodes+topSort :: Ord n => Set n -> [(n, n)] -> Maybe [n]+topSort nodes edges = go [] (Set.toList nodes)   where     -- #4253: The input edges do not necessarily include transitive dependencies, so take transitive     --        closure before sorting.     w      = Just () -- () is not a good edge label since it counts as a "zero" edge and will be ignored-    g      = G.transitiveClosure $ G.fromNodes nodes `G.union` G.fromEdges [G.Edge a b w | (a, b) <- edges]-    deps a = Map.keysSet $ G.graph g Map.! a+    g      = G.transitiveClosure $+               G.fromNodeSet nodes `G.union`+               G.fromEdges [G.Edge a b w | (a, b) <- edges]+    -- Only the keys of these maps are used.+    deps a = G.graph g Map.! a      -- acc: Already sorted nodes in reverse order paired with accumulated set of nodes that must     -- come before it@@ -38,10 +42,9 @@     insert a [] = Just [(a, deps a)]     insert a bs0@((b, before_b) : bs)       | before && after = Nothing-      | before          = ((b, Set.union before_a before_b) :) <$> insert a bs  -- a must come before b-      | otherwise       = Just $ (a, Set.union before_a before_b) : bs0+      | before          = ((b, Map.union before_a before_b) :) <$> insert a bs  -- a must come before b+      | otherwise       = Just $ (a, Map.union before_a before_b) : bs0       where         before_a = deps a-        before = Set.member a before_b-        after  = Set.member b before_a-+        before = Map.member a before_b+        after  = Map.member b before_a
+ src/full/Agda/Utils/HashTable.hs view
@@ -0,0 +1,57 @@+------------------------------------------------------------------------+-- | Hash tables.+------------------------------------------------------------------------++module Agda.Utils.HashTable+  ( HashTable+  , empty+  , insert+  , lookup+  , toList+  ) where++import Prelude hiding (lookup)++import Data.Hashable+import qualified Data.Vector.Hashtables as H+import qualified Data.Vector.Mutable as VM++-- | Hash tables.++-- A very limited amount of (possibly outdated) testing indicates+-- that, for the use in Agda's serialiser/deserialiser,+-- Data.HashTable.IO.CuckooHashTable is somewhat slower than+-- Data.HashTable.IO.BasicHashTable, and that+-- Data.HashTable.IO.LinearHashTable and the hashtables from+-- Data.Hashtable are much slower. However, other (also possibly+-- outdated) testing suggests that Data.HashTable.IO.CuckooHashTable+-- is quite a bit faster than Data.HashTable.IO.BasicHashTable for+-- 64-bit Windows. Some more recent, also limited, testing suggests+-- that the following hash table implementation from+-- Data.Vector.Hashtables is quite a bit faster than+-- Data.HashTable.IO.BasicHashTable (see issue #5966).++newtype HashTable k v =+  HashTable (H.Dictionary (H.PrimState IO) VM.MVector k VM.MVector v)++-- | An empty hash table.++empty :: IO (HashTable k v)+empty = HashTable <$> H.initialize 0++-- | Inserts the key and the corresponding value into the hash table.++insert :: (Eq k, Hashable k) => HashTable k v -> k -> v -> IO ()+insert (HashTable h) = H.insert h++-- | Tries to find a value corresponding to the key in the hash table.++lookup :: (Eq k, Hashable k) => HashTable k v -> k -> IO (Maybe v)+lookup (HashTable h) = H.lookup h++-- | Converts the hash table to a list.+--+-- The order of the elements in the list is unspecified.++toList :: (Eq k, Hashable k) => HashTable k v -> IO [(k, v)]+toList (HashTable h) = H.toList h
src/full/Agda/Utils/IO/UTF8.hs view
@@ -1,25 +1,31 @@ -- | Text IO using the UTF8 character encoding.  module Agda.Utils.IO.UTF8-  ( readTextFile+  ( ReadException+  , readTextFile   , Agda.Utils.IO.UTF8.readFile   , Agda.Utils.IO.UTF8.writeFile   , writeTextToFile   ) where +import Control.Exception import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T import qualified Data.Text.Lazy.IO as T+import qualified Data.ByteString.Lazy as B import qualified System.IO as IO+import qualified System.IO.Error as E  -- | Converts many character sequences which may be interpreted as -- line or paragraph separators into '\n'.------ Note that '\r\n' is assumed to have already been converted to '\n'.  convertLineEndings :: Text -> Text-convertLineEndings = T.map convert+convertLineEndings = T.map convert . convertCRLF   where+  -- Replaces CR LF with LF.+  convertCRLF = T.replace "\x000D\n" "\n"+   -- ASCII:   convert '\x000D' = '\n'  -- CR  (Carriage return)   convert '\x000C' = '\n'  -- FF  (Form feed)@@ -30,21 +36,36 @@   -- Not a line ending (or '\x000A'):   convert c        = c +-- | A kind of exception that can be thrown by 'readTextFile' and+-- 'readFile'.+newtype ReadException+  = DecodingError FilePath+    -- ^ Decoding failed for the given file.+  deriving Show++instance Exception ReadException where+  displayException (DecodingError file) =+    "Failed to read " ++ file ++ ".\n" +++    "Please ensure that this file uses the UTF-8 character encoding."+ -- | Reads a UTF8-encoded text file and converts many character -- sequences which may be interpreted as line or paragraph separators -- into '\n'.+--+-- If the file cannot be decoded, then a 'ReadException' is raised.  readTextFile :: FilePath -> IO Text-readTextFile file = convertLineEndings <$> do-  h <- IO.openFile file IO.ReadMode-  IO.hSetNewlineMode h $-    IO.NewlineMode { IO.inputNL = IO.CRLF, IO.outputNL = IO.LF }-  IO.hSetEncoding h IO.utf8-  T.hGetContents h+readTextFile file = do+  s <- T.decodeUtf8' <$> B.readFile file+  case s of+    Right s -> return $ convertLineEndings s+    Left _  -> throw $ DecodingError file  -- | Reads a UTF8-encoded text file and converts many character -- sequences which may be interpreted as line or paragraph separators -- into '\n'.+--+-- If the file cannot be decoded, then a 'ReadException' is raised.  readFile :: FilePath -> IO String readFile f = do
src/full/Agda/Utils/List.hs view
@@ -7,15 +7,18 @@ import Data.Array (Array, array, listArray) import qualified Data.Array as Array import Data.Bifunctor-import Data.Function+import Data.Function (on)+import Data.Hashable import qualified Data.List as List import qualified Data.List.NonEmpty as List1 import Data.List.NonEmpty (pattern (:|), (<|)) import Data.Maybe import qualified Data.Map as Map+import qualified Data.HashMap.Strict as HMap import qualified Data.Set as Set  import qualified Agda.Utils.Bag as Bag+import Agda.Utils.CallStack.Base import Agda.Utils.Function (applyWhen) import Agda.Utils.Functor  ((<.>)) import Agda.Utils.Tuple@@ -151,13 +154,27 @@ -- * Lookup and indexing --------------------------------------------------------------------------- --- | Lookup function (partially safe).+-- | Lookup function (safe). --   O(min n index). (!!!) :: [a] -> Int -> Maybe a-[]       !!! _         = Nothing-(x : _)  !!! 0         = Just x-(_ : xs) !!! n         = xs !!! (n - 1)+xs !!! (!i)+  | i < 0     = Nothing+  | otherwise = index xs i+  where+  index []       !i = Nothing+  index (x : xs) 0  = Just x+  index (x : xs) i  = index xs (i - 1) +-- | A variant of 'Prelude.!!' that might provide more informative+-- error messages if the index is out of bounds.+--+-- Precondition: The index should not be out of bounds.++(!!) :: HasCallStack => [a] -> Int -> a+xs !! i = case xs !!! i of+  Just x  -> x+  Nothing -> __IMPOSSIBLE__+ -- | Lookup function with default value for index out of range. --   O(min n index). --@@ -420,14 +437,43 @@   | SSSStrip (ReversedSuffix a) -- ^ "Negative string" to remove from end. List may be empty.   | SSSResult [a]               -- ^ "Positive string" (result). Non-empty list. +-- | Returns a list with one boolean for each non-empty suffix of the+-- list, starting with the longest suffix (the entire list). Each+-- boolean is 'True' exactly when every element in the corresponding+-- suffix satisfies the predicate.+--+-- An example:+-- @+--  'suffixesSatisfying' 'Data.Char.isLower' "AbCde" =+--  [False, False, False, True, True]+-- @+--+-- For total predicates @p@ and finite and total lists @xs@ the+-- following holds:+-- @+--  'suffixesSatisfying' p xs = 'map' ('all' p) ('List.init' ('List.tails' xs))+-- @+suffixesSatisfying :: (a -> Bool) -> [a] -> [Bool]+suffixesSatisfying p =+  snd .+  foldr (\x (b, bs) -> let !b' = p x && b in (b', b' : bs))+        (True, [])+ -- ** Finding overlap --- | Find out whether the first string @xs@---   has a suffix that is a prefix of the second string @ys@.+-- | Find the longest suffix of the first string @xs@+--   that is a prefix of the second string @ys@. --   So, basically, find the overlap where the strings can be glued together. --   Returns the index where the overlap starts and the length of the overlap. --   The length of the overlap plus the index is the length of the first string. --   Note that in the worst case, the empty overlap @(length xs,0)@ is returned.+--+--   Worst-case time complexity is quadratic: @O(min(n,m)²)@+--   where @n = length xs@ and @m = length ys@.+--+--   There might be asymptotically better implementations following+--   Knuth-Morris-Pratt (KMP), but for rather short lists this is good enough.+-- findOverlap :: forall a. Eq a => [a] -> [a] -> (Int, Int) findOverlap xs ys =   headWithDefault __IMPOSSIBLE__ $ mapMaybe maybePrefix $ zip [0..] (List.tails xs)@@ -460,21 +506,6 @@                    []            -> []                    ((_, z) : zs) -> grp z zs --- | Split a list into sublists. Generalisation of the prelude function---   @words@.---   O(n).------   > words xs == wordsBy isSpace xs-wordsBy :: (a -> Bool) -> [a] -> [[a]]-wordsBy p xs = yesP xs-    where-        yesP xs = noP (dropWhile p xs)--        noP []  = []-        noP xs  = ys : yesP zs-            where-                (ys,zs) = break p xs- -- | Chop up a list in chunks of a given length. -- O(n). chop :: Int -> [a] -> [[a]]@@ -592,6 +623,38 @@     | b `Set.member` s = loop s as     | otherwise        = a : loop (Set.insert b s) as     where b = f a++-- | A variant of 'nubOn' that is parametrised by a function that is+-- used to select which element from a group of equal elements that is+-- returned. The returned elements keep the order that they had in the+-- input list.+--+-- Precondition: The length of the input list must be at most+-- @'maxBound' :: 'Int'@.++nubFavouriteOn+  :: forall a b c. (Ord b, Eq c, Hashable c)+  => (a -> b)+     -- ^ The values returned by this function are used to determine+     -- which element from a group of equal elements that is returned:+     -- the smallest one is chosen (and if two elements are equally+     -- small, then the first one is chosen).+  -> (a -> c)+     -- ^ Two elements are treated as equal if this function returns+     -- the same value for both elements.+  -> [a] -> [a]+nubFavouriteOn fav f = go 0 HMap.empty+  where+  go :: Int -> HMap.HashMap c ((b, Int), a) -> [a] -> [a]+  go !pos !acc (x : xs) =+    go (1 + pos)+       (HMap.insertWith+          (\new old -> if fst new < fst old then new else old)+          (f x) ((fav x, pos), x) acc)+       xs+  go _ acc [] =+    map snd $ List.sortBy (compare `on` snd . fst) $+    HMap.elems acc  -- -- | Efficient variant of 'nubBy' for finite lists (using sorting). -- -- O(n log n)
src/full/Agda/Utils/List1.hs view
@@ -22,6 +22,7 @@ module Agda.Utils.List1   ( module Agda.Utils.List1   , module List1+  , module IsList   ) where  import Prelude hiding (filter)@@ -35,15 +36,27 @@ import qualified Data.Maybe as Maybe import qualified Data.Semigroup as Semigroup -import qualified Data.List.NonEmpty (NonEmpty)-import Data.List.NonEmpty as List1 hiding (NonEmpty)+import Data.List.NonEmpty as List1 hiding (fromList, toList)+import qualified Data.List.NonEmpty as List1 (toList) +import GHC.Exts as IsList ( IsList(..) )+ import Agda.Utils.Functor ((<.>)) import Agda.Utils.Null (Null(..)) import qualified Agda.Utils.List as List -type List1 = Data.List.NonEmpty.NonEmpty+type List1 = NonEmpty+type String1 = List1 Char +-- | Safe version of 'Data.List.NonEmpty.fromList'.++fromListSafe+  :: List1 a  -- ^ Default value if convertee is empty.+  -> [a]      -- ^ List to convert, supposedly non-empty.+  -> List1 a  -- ^ Converted list.+fromListSafe err   [] = err+fromListSafe _ (x:xs) = x :| xs+ -- | Return the last element and the rest.  initLast :: List1 a -> ([a], a)@@ -66,7 +79,7 @@ -- | Prepend a list to a non-empty list.  prependList :: [a] -> List1 a -> List1 a-prependList as bs = foldr (<|) bs as+prependList as bs = Prelude.foldr (<|) bs as #endif  -- | More precise type for @snoc@.@@ -90,6 +103,20 @@       []                 -> []       ((_false, z) : zs) -> grp z zs +-- | Split a list into sublists. Generalisation of the prelude function+--   @words@.+--   Same as 'Data.List.Split.wordsBy' and 'Data.List.Extra.wordsBy',+--   but with the non-emptyness guarantee on the chunks.+--   O(n).+--+--   > words xs == wordsBy isSpace xs+wordsBy :: (a -> Bool) -> [a] -> [List1 a]+wordsBy p = loop+  where+  loop as = case List.dropWhile p as of+    []   -> []+    x:xs -> (x :| ys) : loop zs where (ys, zs) = List.break p xs+ -- | Breaks a list just /after/ an element satisfying the predicate is --   found. --@@ -171,3 +198,11 @@  zipWithM_ :: Applicative m => (a -> b -> m c) -> List1 a -> List1 b -> m () zipWithM_ f (a :| as) (b :| bs) = f a b *> List.zipWithM_ f as bs++-- | List 'Data.List.foldr' but with a base case for the singleton list.++foldr :: (a -> b -> b) -> (a -> b) -> List1 a -> b+foldr f g (x :| xs) = loop x xs+  where+  loop x []       = g x+  loop x (y : ys) = f x $ loop y ys
src/full/Agda/Utils/List2.hs view
@@ -15,7 +15,6 @@ import Control.DeepSeq import Control.Monad                   ( (<=<) ) -import Data.Data                       ( Data ) import qualified Data.List as List  import GHC.Exts                        ( IsList(..) )@@ -28,21 +27,32 @@  -- | Lists of length ≥2. data List2 a = List2 a a [a]-  deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable) --- | Safe. O(1).-head :: List2 a -> a-head (List2 a _ _) = a+-- * Conversion from and to other list types. --- | Safe. O(1).-tail :: List2 a -> List1 a-tail (List2 a b cs) = b :| cs+-- | 'fromList' is unsafe.+instance IsList (List2 a) where+  type Item (List2 a) = a --- | Safe. O(n).-init :: List2 a -> List1 a-init (List2 a b cs) = a :| List1.init (b :| cs)+  -- Unsafe! O(1).+  fromList :: [a] -> List2 a+  fromList (a : b : cs) = List2 a b cs+  fromList _            = __IMPOSSIBLE__ +  toList :: List2 a -> [a]+  toList (List2 a b cs) = a : b : cs++-- | Unsafe! O(1).+fromList1 :: List1 a -> List2 a+fromList1 (a :| b : cs) = List2 a b cs+fromList1 _             = __IMPOSSIBLE__+ -- | Safe. O(1).+toList1 :: List2 a -> List1 a+toList1 (List2 a b cs) = a :| b : cs++-- | Safe. O(1). fromListMaybe :: [a] -> Maybe (List2 a) fromListMaybe = fromList1Maybe <=< List1.nonEmpty @@ -52,25 +62,47 @@   (a :| b : cs) -> Just (List2 a b cs)   _ -> Nothing -instance IsList (List2 a) where-  type Item (List2 a) = a+-- | Any 'List1' is either a singleton or a 'List2'. O(1).+fromList1Either :: List1 a -> Either a (List2 a)+fromList1Either (a :| as) = case as of+  []   -> Left a+  b:bs -> Right (List2 a b bs) -  -- Unsafe! O(1).-  fromList :: [a] -> List2 a-  fromList (a : b : cs) = List2 a b cs-  fromList _            = __IMPOSSIBLE__+-- | Inverse of 'fromList1Either'. O(1).+toList1Either :: Either a (List2 a) -> List1 a+toList1Either = \case+  Left  a              -> a :| []+  Right (List2 a b bs) -> a :| b : bs -  toList :: List2 a -> [a]-  toList (List2 a b cs) = a : b : cs+-- * Construction +-- | O(1).+cons :: a -> List1 a -> List2 a+cons x (y :| ys) = List2 x y ys++-- | O(length first list).+append :: List1 a -> List1 a -> List2 a+append (x :| xs) ys = cons x $ List1.prependList xs ys++-- | O(length first list).+appendList :: List2 a -> [a] -> List2 a+appendList (List2 x y ys) zs = List2 x y $ mappend ys zs++-- * Destruction+ -- | Safe. O(1).-toList1 :: List2 a -> List1 a-toList1 (List2 a b cs) = a :| b : cs+head :: List2 a -> a+head (List2 a _ _) = a --- | Unsafe!-fromList1 :: List1 a -> List2 a-fromList1 (a :| b : cs) = List2 a b cs-fromList1 _             = __IMPOSSIBLE__+-- | Safe. O(1).+tail :: List2 a -> List1 a+tail (List2 a b cs) = b :| cs++-- | Safe. O(n).+init :: List2 a -> List1 a+init (List2 a b cs) = a :| List1.init (b :| cs)++-- * Partition  break :: (a -> Bool) -> List2 a -> ([a],[a]) break p = List.break p . toList
src/full/Agda/Utils/Maybe/Strict.hs view
@@ -1,14 +1,3 @@--- Liang-Ting Chen (2019-07-04):--- Consider using Data.Maybe.Strict instead--- Andreas Abel (2019-07-05)@GitHub:--- The dependencies of strict-base-types are too heavy,--- especially since it depends on lens which we consciously ruled out.--{-# LANGUAGE CPP #-}---{-# OPTIONS_GHC -fno-warn-orphans #-}- -- | A strict version of the 'Maybe' type. -- --   Import qualified, as in@@ -24,62 +13,17 @@  module Agda.Utils.Maybe.Strict   ( module Data.Strict.Maybe+  , module Data.Strict.Classes   , module Agda.Utils.Maybe.Strict   ) where --- The following code is copied from--- http://hackage.haskell.org/package/strict-base-types-0.3.0/docs/src/Data-Maybe-Strict.html--import           Prelude             hiding (Maybe (..), maybe, null)-import qualified Prelude             as Lazy+import Prelude hiding (Maybe(..), maybe) -import           Control.DeepSeq     (NFData (..))-import           Data.Binary         (Binary (..))-import           Data.Data           (Data (..))-import           Data.Semigroup      (Semigroup, (<>))-import           Data.Strict.Maybe   (Maybe (Nothing, Just), fromJust,-                                      fromMaybe, isJust, isNothing, maybe)-import           GHC.Generics        (Generic (..))+import Data.Strict.Classes+import Data.Strict.Maybe  import Agda.Utils.Null -toStrict :: Lazy.Maybe a -> Maybe a-toStrict Lazy.Nothing  = Nothing-toStrict (Lazy.Just x) = Just x--toLazy :: Maybe a -> Lazy.Maybe a-toLazy Nothing  = Lazy.Nothing-toLazy (Just x) = Lazy.Just x--#if !(MIN_VERSION_strict(0,4,0))-deriving instance Data a => Data (Maybe a)-deriving instance Generic  (Maybe a)---- The monoid instance was fixed in strict-base-types 0.5.0. See--- Issue 1805.-instance Semigroup a => Semigroup (Maybe a) where-  (<>) = unionMaybeWith (<>)--instance Semigroup a => Monoid (Maybe a) where-  mempty  = Nothing-  mappend = (<>)--instance Foldable Maybe where-    foldMap _ Nothing  = mempty-    foldMap f (Just x) = f x--instance Traversable Maybe where-    traverse _ Nothing  = pure Nothing-    traverse f (Just x) = Just <$> f x--instance NFData a => NFData (Maybe a) where-  rnf = rnf . toLazy--instance Binary a => Binary (Maybe a) where-  put = put . toLazy-  get = toStrict <$> get-#endif- -- | Note that strict Maybe is an 'Applicative' only modulo strictness. --   The laws only hold in the strict semantics. --   Eg. @pure f <*> pure _|_ = _|_@, but according to the laws for@@ -94,31 +38,6 @@ instance Null (Maybe a) where   empty = Nothing   null = isNothing---- | Analogous to 'Lazy.listToMaybe' in "Data.Maybe".-listToMaybe :: [a] -> Maybe a-listToMaybe []        =  Nothing-listToMaybe (a:_)     =  Just a---- | Analogous to 'Lazy.maybeToList' in "Data.Maybe".-maybeToList :: Maybe a -> [a]-maybeToList  Nothing   = []-maybeToList  (Just x)  = [x]---- | Analogous to 'Lazy.catMaybes' in "Data.Maybe".-catMaybes :: [Maybe a] -> [a]-catMaybes ls = [x | Just x <- ls]---- | Analogous to 'Lazy.mapMaybe' in "Data.Maybe".-mapMaybe :: (a -> Maybe b) -> [a] -> [b]-mapMaybe _ []     = []-mapMaybe f (x:xs) = case f x of-    Nothing -> rs-    Just r  -> r:rs-  where-    rs = mapMaybe f xs---- The remaining code is a copy of Agda.Utils.Maybe  -- * Collection operations.
src/full/Agda/Utils/Monad.hs view
@@ -7,11 +7,15 @@     )     where -import Control.Applicative  ( liftA2 )-import Control.Monad        ( MonadPlus(..), guard, unless, when )-import Control.Monad.Except ( MonadError(catchError, throwError) )-import Control.Monad.State  ( MonadState(get, put) )+import Control.Applicative    ( liftA2 )+import Control.Monad          ( MonadPlus(..), guard, unless, when )+import Control.Monad.Except   ( MonadError(catchError, throwError) )+import Control.Monad.Identity ( runIdentity )+import Control.Monad.State    ( MonadState(get, put) )+import Control.Monad.Writer   ( MonadWriter(tell), Writer, WriterT, mapWriterT ) +import Data.Bifunctor         ( first, second )+import Data.Bool              ( bool ) import Data.Traversable as Trav hiding (for, sequence) import Data.Foldable as Fold import Data.Maybe@@ -19,7 +23,8 @@  import Agda.Utils.Applicative import Agda.Utils.Either-import Agda.Utils.Null (ifNotNullM)+import Agda.Utils.Null (empty, ifNotNullM)+import Agda.Utils.Singleton  import Agda.Utils.Impossible @@ -54,20 +59,20 @@ and2M ma mb = ifM ma mb (return False)  andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool-andM = Fold.foldl and2M (return True)+andM = Fold.foldl' and2M (return True) -allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool-allM xs f = andM $ fmap f xs+allM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool+allM xs f = Fold.foldl' (\b -> and2M b . f) (return True) xs  -- | Lazy monadic disjunction. or2M :: Monad m => m Bool -> m Bool -> m Bool or2M ma = ifM ma (return True)  orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool-orM = Fold.foldl or2M (return False)+orM = Fold.foldl' or2M (return False) -anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool-anyM xs f = orM $ fmap f xs+anyM :: (Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool+anyM xs f = Fold.foldl' (\b -> or2M b . f) (return False) xs  -- | Lazy monadic disjunction with @Either@  truth values. --   Returns the last error message if all fail.@@ -164,11 +169,9 @@  -- | A ``monadic'' version of @'partition' :: (a -> Bool) -> [a] -> ([a],[a]) partitionM :: (Functor m, Applicative m) => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM f xs =-  foldr-    (\x -> (<*>) ((\b (l, r) -> if b then (x : l, r) else (l, x : r)) <$> f x))-    (pure ([], []))-    xs+partitionM f =+  foldr (\ x mlr -> bool (first (x:)) (second (x:)) <$> f x <*> mlr)+        (pure empty)  -- MonadPlus ----------------------------------------------------------------- @@ -231,3 +234,12 @@ -- | Restore state after computation. localState :: MonadState s m => m a -> m a localState = bracket_ get put++-- Writer monad -----------------------------------------------------------++embedWriter :: (Monoid w, Monad m) => Writer w a -> WriterT w m a+embedWriter = mapWriterT (pure . runIdentity)++-- | Output a single value.+tell1 :: (Monoid ws, Singleton w ws, MonadWriter ws m) => w -> m ()+tell1 = tell . singleton
src/full/Agda/Utils/Null.hs view
@@ -8,8 +8,12 @@ import Prelude hiding (null)  import Control.Monad-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad.Except   ( ExceptT )+import Control.Monad.Identity ( Identity(..) )+import Control.Monad.Reader   ( ReaderT )+import Control.Monad.State    ( StateT  )+import Control.Monad.Writer   ( WriterT )+import Control.Monad.Trans    ( lift    )  import qualified Data.ByteString.Char8 as ByteStringChar8 import qualified Data.ByteString.Lazy as ByteStringLazy@@ -122,11 +126,27 @@   empty = mempty   null  = isEmpty +instance Null a => Null (Identity a) where+  empty = return empty+  null  = null . runIdentity++instance Null a => Null (IO a) where+  empty = return empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m) => Null (ExceptT e m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__+ instance (Null (m a), Monad m) => Null (ReaderT r m a) where   empty = lift empty   null  = __IMPOSSIBLE__ -instance (Null (m a), Monad m) => Null (StateT r m a) where+instance (Null (m a), Monad m) => Null (StateT s m a) where+  empty = lift empty+  null  = __IMPOSSIBLE__++instance (Null (m a), Monad m, Monoid w) => Null (WriterT w m a) where   empty = lift empty   null  = __IMPOSSIBLE__
src/full/Agda/Utils/Permutation.hs view
@@ -6,19 +6,18 @@ import Control.DeepSeq import Control.Monad (filterM) +import Data.Array.Unboxed import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap+import qualified Data.IntMap.Strict as IntMapS+import qualified Data.IntSet as IntSet import Data.Functor.Identity import qualified Data.List as List import Data.Maybe-import Data.Array -import Data.Data (Data)- import GHC.Generics (Generic)  import Agda.Utils.Functor-import Agda.Utils.List ((!!!)) import Agda.Utils.Null import Agda.Utils.Size import Agda.Utils.Tuple@@ -37,7 +36,7 @@ --   @Perm : {m : Nat}(n : Nat) -> Vec (Fin n) m -> Permutation@ --   @m@ is the 'size' of the permutation. data Permutation = Perm { permRange :: Int, permPicks :: [Int] }-  deriving (Eq, Data, Generic)+  deriving (Eq, Generic)  instance Show Permutation where   show (Perm n xs) = showx [0..n - 1] ++ " -> " ++ showx xs@@ -63,15 +62,45 @@ -- --   Agda typing: --   @permute (Perm {m} n is) : Vec A m -> Vec A n@+--+-- Precondition for @'permute' ('Perm' _ is) xs@: Every index in @is@+-- must be non-negative and, if @xs@ is finite, then every index must+-- also be smaller than the length of @xs@.+--+-- The implementation is supposed to be extensionally equal to the+-- following one (if different exceptions are identified), but in some+-- cases more efficient:+-- @+--   permute ('Perm' _ is) xs = 'map' (xs 'Agda.Utils.List.!!') is+-- @ permute :: Permutation -> [a] -> [a]-permute p xs = map (fromMaybe __IMPOSSIBLE__) (safePermute p xs)--safePermute :: Permutation -> [a] -> [Maybe a]-safePermute (Perm _ is) xs = map (xs !!!!) is+permute (Perm _ is) xs = go mempty 0 xs is   where-    xs !!!! n | n < 0     = Nothing-              | otherwise = xs !!! n+  -- Computes the list of permuted elements.+  go :: IntMap a  -- A map from positions to elements that have+                  -- already been seen.+     -> Int       -- The number of elements that have been seen (the+                  -- size of the map).+     -> [a]       -- Elements that have not yet been seen.+     -> [Int]     -- Indices to process.+     -> [a]+  go seen !n xs []       = []+  go seen  n xs (i : is)+    | i < n     = fromMaybe __IMPOSSIBLE__+                    (IntMap.lookup i seen) :+                  go seen n xs is+    | otherwise = scan seen n xs (i - n) is +  -- Finds the element at the given position and continues.+  scan :: IntMap a -> Int -> [a] -> Int -> [Int] -> [a]+  scan seen !n (x : xs) !i is+    | i == 0 = x : (go $! seen') n' xs is+    | i > 0  = (scan $! seen') n' xs (i - 1) is+    where+    seen' = IntMap.insert n x seen+    n'    = n + 1+  scan seen n xs !_ is = __IMPOSSIBLE__ : go seen n xs is+ -- |  Invert a Permutation on a partial finite int map. -- @inversePermute perm f = f'@ -- such that @permute perm f' = f@@@ -100,7 +129,10 @@     where tabulate m = for [0..n-1] $ \ i -> IntMap.lookup i m  instance InversePermute (Int -> a) [Maybe a] where-  inversePermute (Perm n xs) f = for [0..n-1] $ \ x -> f <$> List.elemIndex x xs+  inversePermute (Perm n xs) f =+    for [0..n-1] $ \i -> f <$> IntMap.lookup i m+    where+    m = IntMapS.fromListWith (flip const) $ zip xs [0..]  -- | Identity permutation. idP :: Int -> Permutation@@ -112,7 +144,11 @@  -- | Pick the elements that are not picked by the permutation. droppedP :: Permutation -> Permutation-droppedP (Perm n xs) = Perm n $ [0..n-1] List.\\ xs+droppedP (Perm n xs) = Perm n $ filter (notInXs !) [0 .. n - 1]+  where+  notInXs :: UArray Int Bool+  notInXs =+    accumArray (flip const) True (0, n - 1) (zip xs (repeat False))  -- | @liftP k@ takes a @Perm {m} n@ to a @Perm {m+k} (n+k)@. --   Analogous to 'Agda.TypeChecking.Substitution.liftS',@@ -141,16 +177,19 @@ --   @composeP p (invertP err p) == p@ invertP :: Int -> Permutation -> Permutation invertP err p@(Perm n xs) = Perm (size xs) $ elems tmpArray-  where tmpArray = accumArray (const id) err (0, n-1) $ zip xs [0..]+  where+  -- This array cannot be unboxed, because it should be possible to+  -- instantiate err with __IMPOSSIBLE__.+  tmpArray :: Array Int Int+  tmpArray = accumArray (const id) err (0, n-1) $ zip xs [0..]  -- | Turn a possible non-surjective permutation into a surjective permutation. compactP :: Permutation -> Permutation-compactP (Perm n xs) = Perm m $ map adjust xs+compactP p@(Perm _ xs) = Perm (length xs) $ map adjust xs   where-    m            = List.genericLength xs-    missing      = [0..n - 1] List.\\ xs-    holesBelow k = List.genericLength $ filter (< k) missing-    adjust k = k - holesBelow k+  missing      = IntSet.fromList $ permPicks $ droppedP p+  holesBelow k = IntSet.size $ fst $ IntSet.split k missing+  adjust k     = k - holesBelow k  -- | @permute (reverseP p) xs == --    reverse $ permute p $ reverse xs@@@ -225,7 +264,7 @@   { dropN    :: Int  -- ^ Non-negative number of things to drop.   , dropFrom :: a    -- ^ Where to drop from.   }-  deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)  -- | Things that support delayed dropping. class DoDrop a where
src/full/Agda/Utils/Pointer.hs view
@@ -7,26 +7,16 @@ import Control.DeepSeq import Control.Concurrent.MVar -import Data.Function+import Data.Function (on) import Data.Hashable import Data.IORef  import System.IO.Unsafe -import Data.Data (Data (..))-import Data.Typeable (Typeable)- import Agda.Utils.Impossible  data Ptr a = Ptr { ptrTag :: !Integer                  , ptrRef :: !(IORef a) }-  deriving Data---- cheating because you shouldn't be digging this far anyway-instance Typeable a => Data (IORef a) where-  gunfold _ _ _ = __IMPOSSIBLE__-  toConstr      = __IMPOSSIBLE__-  dataTypeOf    = __IMPOSSIBLE__  {-# NOINLINE freshVar #-} freshVar :: MVar Integer
src/full/Agda/Utils/Pretty.hs view
@@ -10,7 +10,6 @@  import Prelude hiding (null) -import Data.Data (Data(..)) import qualified Data.Foldable as Fold import Data.Int (Int32) import Data.IntSet (IntSet)@@ -174,12 +173,6 @@ -- | Handles strings with newlines properly (preserving indentation) multiLineText :: String -> Doc multiLineText = vcat . map text . lines---- cheating because you shouldn't be digging this far anyway-instance Data Doc where-  gunfold _ _ _ = __IMPOSSIBLE__-  toConstr      = __IMPOSSIBLE__-  dataTypeOf    = __IMPOSSIBLE__  infixl 6 <?> -- | @a <?> b = hang a 2 b@
+ src/full/Agda/Utils/ProfileOptions.hs view
@@ -0,0 +1,107 @@++module Agda.Utils.ProfileOptions+  ( ProfileOption(..)+  , ProfileOptions+  , noProfileOptions+  , addProfileOption+  , containsProfileOption+  , profileOptionsToList+  , profileOptionsFromList+  , validProfileOptionStrings+  ) where++import Control.DeepSeq+import Control.Monad+import Data.List (intercalate)+import Data.Char (toLower)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map+import GHC.Generics (Generic)+import Text.EditDistance (restrictedDamerauLevenshteinDistance, defaultEditCosts)++-- | Various things that can be measured when checking an Agda development. Turned on with+--   the `--profile` flag, for instance `--profile=sharing` to turn on the 'Sharing' option.+--   'Internal', 'Modules', and 'Definitions' are mutually exclusive.+--+--   NOTE: Changing this data type requires bumping the interface version number in+--   'Agda.TypeChecking.Serialise.currentInterfaceVersion'.+data ProfileOption = Internal     -- ^ Measure time taken by various parts of the system (type checking, serialization, etc)+                   | Modules      -- ^ Measure time spent on individual (Agda) modules+                   | Definitions  -- ^ Measure time spent on individual (Agda) definitions+                   | Sharing      -- ^ Measure things related to sharing+                   | Serialize    -- ^ Collect detailed statistics about serialization+                   | Constraints  -- ^ Collect statistics about constraint solving+                   | Metas        -- ^ Count number of created metavariables+                   | Interactive  -- ^ Measure time of interactive commands+                   | Conversion   -- ^ Collect statistics about conversion checking+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance NFData ProfileOption++-- | A set of 'ProfileOption's+newtype ProfileOptions = ProfileOpts { unProfileOpts :: Set ProfileOption }+  deriving (Show, Eq, NFData)++-- | The empty set of profiling options.+noProfileOptions :: ProfileOptions+noProfileOptions = ProfileOpts Set.empty++addAllProfileOptions :: ProfileOptions -> ProfileOptions+addAllProfileOptions (ProfileOpts opts) = ProfileOpts $ foldl ins opts [minBound..maxBound]+  where+    ins os o | any (incompatible o) os = os+             | otherwise               = Set.insert o os++-- | Strings accepted by 'addProfileOption'+validProfileOptionStrings :: [String]+validProfileOptionStrings = "all" : map optName [minBound .. maxBound :: ProfileOption]++parseOpt :: String -> Either String ProfileOption+parseOpt = \ s -> case Map.lookup s names of+    Nothing -> Left $ err s+    Just o  -> Right o+  where+    names = Map.fromList [ (optName o, o) | o <- [minBound .. maxBound] ]++    close s t = restrictedDamerauLevenshteinDistance defaultEditCosts s t <= 3+    err  s = concat ["Not a valid profiling option: '", s, "'. ", hint s]+    hint s = case filter (close s) (Map.keys names) of+               [] -> concat [ "Valid options are ", intercalate ", " $ Map.keys names, ", or all." ]+               ss -> concat [ "Did you mean ", intercalate " or " ss, "?" ]++optName :: ProfileOption -> String+optName = map toLower . show++incompatible :: ProfileOption -> ProfileOption -> Bool+incompatible o1 o2+  | o1 == o2  = False+  | otherwise = any (\ set -> elem o1 set && elem o2 set) sets+  where+    sets = [[Internal, Modules, Definitions]]++-- | Parse and add a profiling option to a set of profiling options. Returns `Left` with a helpful+--   error message if the option doesn't parse or if it's incompatible with existing options.+--   The special string "all" adds all options compatible with the given set and prefering the first+--   of incompatible options. So `--profile=all` sets 'Internal' over 'Modules' and 'Definitions',+--   but `--profile=modules --profile=all` sets 'Modules' and not 'Internal'.+addProfileOption :: String -> ProfileOptions -> Either String ProfileOptions+addProfileOption "all" opts = pure $ addAllProfileOptions opts+addProfileOption s (ProfileOpts opts) = do+  o <- parseOpt s+  let conflicts = filter (incompatible o) (Set.toList opts)+  unless (null conflicts) $ Left $ concat ["Cannot use profiling option '", s, "' with '", optName $ head $ conflicts, "'"]+  return $ ProfileOpts $ Set.insert o opts++-- | Check if a given profiling option is present in a set of profiling options.+containsProfileOption :: ProfileOption -> ProfileOptions -> Bool+containsProfileOption o (ProfileOpts opts) = Set.member o opts++-- | Use only for serialization.+profileOptionsToList :: ProfileOptions -> [ProfileOption]+profileOptionsToList (ProfileOpts opts) = Set.toList opts++-- | Use only for serialization.+profileOptionsFromList :: [ProfileOption] -> ProfileOptions+profileOptionsFromList opts = ProfileOpts $ Set.fromList opts
src/full/Agda/Utils/Singleton.hs view
@@ -6,6 +6,8 @@ import Data.Semigroup (Semigroup(..)) import Data.Monoid (Endo(..)) +import Data.DList (DList)+import qualified Data.DList as DL import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap@@ -36,6 +38,7 @@ instance Collection a       [a]           where fromList = id instance Collection a       ([a] -> [a])  where fromList = (++) instance Collection a       (Endo [a])    where fromList = Endo . fromList+instance Collection a       (DList a)     where fromList = DL.fromList instance Collection a       (Seq a)       where fromList = Seq.fromList instance Collection Int     IntSet        where fromList = IntSet.fromList instance Collection (Int,a) (IntMap a)    where fromList = IntMap.fromList@@ -61,6 +64,7 @@ instance Singleton a   [a]         where singleton = (:[]) instance Singleton a  ([a] -> [a]) where singleton = (:) instance Singleton a   (Endo [a])  where singleton = Endo . (:)+instance Singleton a   (DList a)   where singleton = DL.singleton instance Singleton a   (NonEmpty a)                                    where singleton = (:| []) instance Singleton a   (Seq a)     where singleton = Seq.singleton
src/full/Agda/Utils/SmallSet.hs view
@@ -25,7 +25,7 @@   , insert   , intersection   , isSubsetOf-  , mapMemberShip+  , mapMembership   , member   , notMember   , null@@ -33,7 +33,7 @@   , toList, toAscList   , total   , union-  , zipMemberShipWith+  , zipMembershipWith   ) where  import Prelude hiding (null)@@ -42,14 +42,20 @@  import Data.Array.IArray (Ix, Array) import qualified Data.Array.IArray as Array-import Data.Data (Data)  -- Note: we might want to use unboxed arrays, but they have no Data instance+--+-- Update: There is currently no need for a Data instance. An attempt+-- was made to replace Array with Data.Array.Unboxed.UArray. Limited+-- testing suggested that this does not make much of a difference in+-- practice (at least not when it comes to type-checking the standard+-- library up to and including Data.Nat, with Agda compiled without+-- -foptimise-heavily).  -- | Let @n@ be the size of type @a@. type SmallSetElement a = (Bounded a, Ix a) newtype SmallSet a = SmallSet { theSmallSet :: Array a Bool }-  deriving (Eq, Ord, Show, Data, NFData)+  deriving (Eq, Ord, Show, NFData)  -- * Query @@ -96,28 +102,28 @@  -- | Time O(n). complement :: SmallSetElement a => SmallSet a -> SmallSet a-complement = mapMemberShip not+complement = mapMembership not  -- | Time O(n). difference, (\\) :: SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a-difference = zipMemberShipWith $ \ b c -> b && not c+difference = zipMembershipWith $ \ b c -> b && not c (\\)       = difference  -- | Time O(n). intersection ::  SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a-intersection = zipMemberShipWith (&&)+intersection = zipMembershipWith (&&)  -- | Time O(n). union ::  SmallSetElement a => SmallSet a -> SmallSet a -> SmallSet a-union = zipMemberShipWith (||)+union = zipMembershipWith (||)  -- | Time O(n).-mapMemberShip :: SmallSetElement a => (Bool -> Bool) -> SmallSet a -> SmallSet a-mapMemberShip f = SmallSet . Array.amap f . theSmallSet+mapMembership :: SmallSetElement a => (Bool -> Bool) -> SmallSet a -> SmallSet a+mapMembership f = SmallSet . Array.amap f . theSmallSet  -- | Time O(n).-zipMemberShipWith :: SmallSetElement a => (Bool -> Bool -> Bool) -> SmallSet a -> SmallSet a -> SmallSet a-zipMemberShipWith f s t = fromBoolList $ toBoolListZipWith f s t+zipMembershipWith :: SmallSetElement a => (Bool -> Bool -> Bool) -> SmallSet a -> SmallSet a -> SmallSet a+zipMembershipWith f s t = fromBoolList $ toBoolListZipWith f s t  -- * Conversion
src/full/Agda/Utils/Trie.hs view
@@ -14,7 +14,7 @@  import Control.DeepSeq -import Data.Function+import Data.Function (on) import qualified Data.Maybe as Lazy import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map
src/full/Agda/Utils/Warshall.hs view
@@ -11,6 +11,8 @@ -} module Agda.Utils.Warshall where +import Prelude hiding ((!!))+ import Control.Monad.State  import Data.Maybe@@ -20,7 +22,7 @@ import qualified Data.Map as Map  import Agda.Utils.SemiRing-import Agda.Utils.List (nubOn)+import Agda.Utils.List ((!!), nubOn) import Agda.Utils.Pretty as P  import Agda.Utils.Impossible
src/full/Agda/Version.hs view
@@ -1,6 +1,7 @@ module Agda.Version   ( version   , package+  , docsUrl   ) where  import GHC.Generics ( Generic, Rep, packageName )@@ -21,5 +22,10 @@  package :: String package = packageName (undefined :: Rep AnArbitrarySymbolInThisPackage p)++-- | Returns a URL corresponding to the given section in the documentation for+-- the current version.+docsUrl :: String -> String+docsUrl section = "https://agda.readthedocs.io/en/v" ++ version ++ "/" ++ section  data AnArbitrarySymbolInThisPackage deriving Generic
stack-8.0.2.yaml view
@@ -3,27 +3,41 @@ compiler-check: match-exact  extra-deps:-- QuickCheck-2.14.2+- Cabal-3.6.3.0 - ansi-terminal-0.10.3 - ansi-wl-pprint-0.6.9+- assoc-1.0.2 - async-2.2.1+- base-orphans-0.8.7+- bifunctors-5.5.13 - binary-0.8.3.0+- cabal-doctest-1.0.9+- comonad-5.0.8 - cpphs-1.20.9 - containers-0.5.11.0+- happy-1.20.0+- hashable-1.2.7.0+- indexed-traversable-0.1.2 - optparse-applicative-0.15.1.0 - parallel-3.2.2.0+- parsec-3.1.15.1+- primitive-0.7.2.0+- profunctors-5.2.2 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0+- scientific-0.3.6.2 - splitmix-0.1.0.3-- tasty-1.1.0.4-- tasty-silver-3.1.13-- tasty-quickcheck-0.10.1.1+- strict-0.4.0.1+- tagged-0.8.6.1 - text-1.2.3.1+- th-abstraction-0.4.5.0+- these-1.1.1.1 - uuid-types-1.0.3+- vector-0.12.3.1+- vector-hashtables-0.1.1.1 - wcwidth-0.0.2-- text-icu-0.7.1.0+- text-icu-0.8.0.2 -# Local packages, usually specified by relative directory name-packages:-- '.'+# instead of time-1.9, we add time-compat+- time-compat-1.9.2.2
stack-8.10.7.yaml view
@@ -1,7 +1,7 @@-resolver: lts-18.22+resolver: lts-18.28 compiler: ghc-8.10.7 compiler-check: match-exact -# Local packages, usually specified by relative directory name-packages:-- '.'+extra-deps:+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
stack-8.2.2.yaml view
@@ -3,22 +3,39 @@ compiler-check: match-exact  extra-deps:-- QuickCheck-2.14.2+- OneTuple-0.3+- StateVar-1.2.2+- aeson-1.5.6.0+- assoc-1.0.2 - async-2.2.1+- base-compat-0.12.2+- base-compat-batteries-0.12.2+- base-orphans-0.8.7+- bifunctors-5.5.13 - binary-0.8.3.0 - cpphs-1.20.9+- comonad-5.0.8 - containers-0.5.11.0+- contravariant-1.5.5+- data-fix-0.3.2+- generic-deriving-1.14.2+- indexed-traversable-0.1.2+- primitive-0.7.4.0 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - splitmix-0.1.0.3-- tasty-1.1.0.4-- tasty-silver-3.1.13+- strict-0.4.0.1+- tagged-0.8.6.1 - text-1.2.3.1+- th-abstraction-0.4.5.0+- these-1.1.1.1+- unordered-containers-0.2.19.1 - uuid-types-1.0.3+- vector-0.12.3.1+- vector-hashtables-0.1.1.1 - wcwidth-0.0.2-- text-icu-0.7.1.0+- text-icu-0.8.0.2 -# Local packages, usually specified by relative directory name-packages:-- '.'+# instead of time-1.9, we add time-compat+- time-compat-1.9.5
stack-8.4.4.yaml view
@@ -3,16 +3,28 @@ compiler-check: match-exact  extra-deps:-- QuickCheck-2.14.2+- aeson-1.5.6.0+- assoc-1.0.2+- base-orphans-0.8.7+- bifunctors-5.5.13+- comonad-5.0.8 - cpphs-1.20.9+- data-fix-0.3.2+- generic-deriving-1.14.2+- indexed-traversable-0.1.2+- primitive-0.7.4.0 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - splitmix-0.1.0.3-- tasty-silver-3.1.13 - uuid-types-1.0.3-- text-icu-0.7.1.0+- strict-0.4.0.1+- tagged-0.8.6.1+- text-icu-0.8.0.2+- th-abstraction-0.4.5.0+- these-1.1.1.1+- unordered-containers-0.2.19.1+- vector-hashtables-0.1.1.1 -# Local packages, usually specified by relative directory name-packages:-- '.'+# instead of time-1.9, we add time-compat+- time-compat-1.9.5
stack-8.6.5.yaml view
@@ -3,19 +3,18 @@ compiler-check: match-exact  extra-deps:-- QuickCheck-2.14.2 - STMonadTrans-0.4.3 - cpphs-1.20.9 - data-hash-0.2.0.1 - equivalence-0.3.4 - geniplate-mirror-0.7.6+- primitive-0.7.4.0 - random-1.2.0 - regex-base-0.94.0.0 - regex-tdfa-1.3.1.0 - splitmix-0.1.0.3+- strict-0.4.0.1+- these-1.1.1.1 - uuid-types-1.0.3-- text-icu-0.7.1.0--# Local packages, usually specified by relative directory name-packages:-- '.'+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
stack-8.8.4.yaml view
@@ -3,11 +3,9 @@ compiler-check: match-exact  extra-deps:-- QuickCheck-2.14.2+- primitive-0.7.4.0 - random-1.2.0 - splitmix-0.1.0.3-- text-icu-0.7.1.0--# Local packages, usually specified by relative directory name-packages:-  - '.'+- strict-0.4.0.1+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
− stack-9.0.1.yaml 
@@ -1,25 +0,0 @@-resolver: nightly-2022-01-06-compiler: ghc-9.0.1-compiler-check: match-exact--extra-deps:-# Andreas, 2021-11-13-# happy-1.21.0 is deprecated, but currently in nightly-# (commercialhaskell/stackage#6294)-- happy-1.20.0-# Andreas, 2022-02-07-# On Windows, we install the latest ICU (v69), which is only supported from text-icu >= 0.8-- text-icu-0.8.0--flags:-  transformers-compat:-    five-three: true-  # Andreas, 2021-11-14-  # Work around problem in nightly-2021-11-12-  # (commercialhaskell/stackage#6304 and RyanGlScott/mintty#4):-  mintty:-    Win32-2-13-1: false--# Local packages, usually specified by relative directory name-packages:-- '.'
stack-9.0.2.yaml view
@@ -1,7 +1,7 @@-resolver: lts-19.0+resolver: lts-19.33 compiler: ghc-9.0.2 compiler-check: match-exact -# Local packages, usually specified by relative directory name-packages:-- '.'+extra-deps:+- text-icu-0.8.0.2+- vector-hashtables-0.1.1.1
− stack-9.2.1.yaml 
@@ -1,136 +0,0 @@-resolver: ghc-9.2.1-compiler: ghc-9.2.1-compiler-check: match-exact--extra-deps:-- Diff-0.4.0-- HUnit-1.6.2.0-- ListLike-4.7.6-- OneTuple-0.3.1-- QuickCheck-2.14.2-- StateVar-1.2.2-- STMonadTrans-0.4.6-- aeson-2.0.2.0-- alex-3.2.6-- ansi-terminal-0.11-- ansi-wl-pprint-0.6.9-- assoc-1.0.2-- async-2.2.4-- attoparsec-0.14.2-- base-compat-0.12.1-- base-compat-batteries-0.12.1-- base-orphans-0.8.6-- bifunctors-5.5.11-- blaze-builder-0.4.2.2-- blaze-html-0.9.1.2-- blaze-markup-0.8.2.8-- boxes-0.1.5-- call-stack-0.4.0-- case-insensitive-1.2.1.0-- clock-0.8.2-- cmdargs-0.10.21-- colour-2.3.6-- comonad-5.0.8-- contravariant-1.5.5-- cpphs-1.20.9.1-- data-default-0.7.1.1-- data-default-class-0.1.2.0-- data-default-instances-containers-0.0.1-- data-default-instances-dlist-0.0.1-- data-default-instances-old-locale-0.0.1-- data-fix-0.3.2-- data-hash-0.2.0.1-- distributive-0.6.2.1-- dlist-1.0-- edit-distance-0.2.2.1-- equivalence-0.3.5-- extensible-exceptions-0.1.1.4-- fail-4.9.0.0-- filemanip-0.3.6.3-- fmlist-0.9.4-- generic-deriving-1.14.1-- gitrev-1.3.1-- happy-1.20.0-- hashable-1.3.5.0-- hashtables-1.2.4.2-- haskell-lexer-1.1-- hostname-1.0-- indexed-traversable-0.1.2-- indexed-traversable-instances-0.1.1-- integer-logarithms-1.0.3.1-- mintty-0.1.2-- monad-control-1.0.3.1-- murmur-hash-0.1.0.10-- network-uri-2.6.4.1-- old-locale-1.0.0.7-- optparse-applicative-0.16.1.0-- parallel-3.2.2.0-- polyparse-1.13-- pretty-show-1.10-- primitive-0.7.3.0-- process-extras-0.7.4-- random-1.2.1-- regex-base-0.94.0.1-- regex-posix-0.96.0.1-- regex-tdfa-1.3.1.1-- safe-0.3.19-- scientific-0.3.7.0-- semialign-1.2.0.1-- semigroupoids-5.3.6-- silently-1.2.5.2-- split-0.2.3.4-- splitmix-0.1.0.4-- strict-0.4.0.1-- tagged-0.8.6.1-- tasty-1.4.2-- tasty-hunit-0.10.0.3-- tasty-quickcheck-0.10.1.2-- tasty-silver-3.3.1-- temporary-1.3-- test-framework-0.8.2.0-- test-framework-hunit-0.3.0.2-- text-icu-0.8.0.1-- text-short-0.1.4-- th-abstraction-0.4.3.0-- th-compat-0.1.3-- these-1.1.1.1-- time-compat-1.9.6.1-- transformers-base-0.4.6-- transformers-compat-0.7.1-- unbounded-delays-0.1.1.1-- unix-compat-0.5.3-- unordered-containers-0.2.15.0-- uri-encode-1.5.0.7-- utf8-string-1.0.2-- uuid-types-1.0.5-- vector-0.12.3.1-- wcwidth-0.0.2-- witherable-0.4.2-- xml-1.3.14-- zlib-0.6.2.3--# Andreas, 2021-11-13:-# Windows needs this instead of time-1.11.*, via unix-compat-- time-1.9.3--# Andreas, 2021-11-13: unix-compat (0.5.3) needs Win32 < 2.12-# See https://github.com/jacobstanley/unix-compat/issues/48-# Andreas, 2021-11-14: haskeline (0.8.2) needs Win32 < 2.10 || >= 2.12-- Win32-2.9.0.0--# Fixup:-- Cabal-3.6.2.0-# "this GHC boot package has been pruned (issue #4510);"-- directory-1.3.7.0-- haskeline-0.8.2-- process-1.6.13.2-- unix-2.7.2.2---flags:-  transformers-compat:-    five-three: true--# Local packages, usually specified by relative directory name-packages:-- '.'
− stack-9.2.2.yaml 
@@ -1,6 +0,0 @@-resolver: nightly-2022-03-26-compiler: ghc-9.2.2-compiler-check: match-exact--packages:-- '.'
+ stack-9.2.5.yaml view
@@ -0,0 +1,6 @@+resolver: lts-20.9+compiler: ghc-9.2.5+compiler-check: match-exact++extra-deps:+- vector-hashtables-0.1.1.1
+ stack-9.4.4.yaml view
@@ -0,0 +1,10 @@+resolver: nightly-2023-01-29+compiler: ghc-9.4.4+compiler-check: match-exact++flags:+  mintty:+    win32-2-13-1: false++extra-deps:+- vector-hashtables-0.1.1.1